inst/theme_generator_app/utils/helpers.R

In fanggong/themeGenerator: Theme Generator For "ggplot2"

# 属性：theme对象中每个元素包含的元素
# 比如对于theme_get()$line，其有六个属性
# 分别为colour, size, linetype, lineend, arrow

# theme对象中的元素下的属性决定了其用什么方法进行赋值
# 比如theme_get()$line使用element_line()进行赋值
# 再比如theme_get()$legend.justification使用element_justification()进行赋值
# 对应关系见ele_config.yaml


# 将一个reactiveValues对象转换成theme对象
.reactiveValues_to_theme <- function(x) {
  x <- reactiveValuesToList(x)
  for (ele in ELEMENTS) {
    if (inherits(x[[ele]], "function")){
      if (is.null(x[[ele]]())) {
        x[ele] <- list(NULL)
      } else {
        x[[ele]] <- x[[ele]]()
      }
    }
  }
  attr(x, "class") <- c("theme", "gg")
  attr(x, "complete") <- TRUE
  attr(x, "validate") <- TRUE
  return(x)
}


# 一个theme对象内的各元素的属性有三种状态
# Romove表示不给该属性分配空间
# Inherit表示从父属性继承
# Assign表示直接对该属性赋值
.types <- function(del = NULL) {
  type_choices <- c("Remove", "Inherit", "Assign")
  if (missing(del)) {
    return(type_choices)
  } else {
    return(type_choices[del])
  }
}


# 当属性的值为NA时，对应Remove
# 当属性的值为NULL时，对应Inherit
# 当属性的值为FALSE时，对应Remove（这个是arrow对象导致的特例）
# 以上情况之外时，对应Assign
.get_attr_type <- function(x) {
  types <- .types()
  x <- x[1]
  if (is.null(x)) {
    return(types[2])
  } else if (is.na(x)) {
    return(types[1])
  } else if (inherits(x, "logical")) {
    if (x) {
      return(types[3])
    } else {
      return(types[1])
    }
  } else {
    return(types[3])
  }
}


# 根据属性的值切换属性下相关控件是否可用
# 当属性的值是Assign时，可用
# 当属性的值不是Assign时，不可用
.toggle_controler <- function(controler, elements, input) {
  observeEvent(input[[controler]], {
    if (input[[controler]] != .types(3)) {
      for (each in elements) {
        shinyjs::disable(each)
      }
    } else {
      for (each in elements) {
        shinyjs::enable(each)
      }
    }
  })
}


# 当属性的初始值非Assign时，返回一个初始默认值给相关控件
.set_default <- function(args, default) {
  ifelse(.get_attr_type(args) == .types(3), args, default)
}


# 对属性赋值
# 对于属性xx，会对变量xx进行赋值，然后将xx给到该属性所属元素对应的方法进行赋值
# 当xx_type为Remove时，xx <- NA
# 当xx_type为Inherit时，xx <- NULL
# 当xx_type为Assign时，根据input赋值
.assign <- function(x, input) {
  for (controler in x) {
    ele <- stringr::str_split(controler, "_type", simplify = TRUE)[1]
    if (input[[controler]] == .types(1)) {
      assign(ele, NA, envir = parent.env(environment()))
    } else if (input[[controler]] == .types(2)) {
      assign(ele, NULL, envir = parent.env(environment()))
    } else {
      if (ele == "size") {
        assign(
          ele, do.call(input$size_unit, list(input$size_value)),
          envir = parent.env(environment())
        )
      } else if (ele == "arrow") {
        assign(
          ele, arrow(input$angle, unit(input$value, input$unit), input$ends, input$type),
          envir = parent.env(environment())
        )
      } else if (ele == "justification") {
        assign(
          ele, c(input$just_x, input$just_y), envir = parent.env(environment())
        )
      } else if (ele == "linetype") {
        assign(
          ele, ifelse(input$linetype %in% as.character(0:8), as.numeric(input$linetype), input$linetype),
          envir = parent.env(environment())
        )
      } else if (ele == "margin") {
        assign(
          ele,
          margin(
            t = input$value_top, b = input$value_bottom, l = input$value_left, r = input$value_right,
            unit = c(input$unit_top, input$unit_bottom, input$unit_left, input$unit_right)
          ),
          envir = parent.env(environment())
        )
      } else if (ele == "position") {
        if (input$position == "string") {
          assign(ele, input$position_xy, envir = parent.env(environment()))
        } else {
          assign(
            ele, c(input$position_x, input$position_y), envir = parent.env(environment())
          )
        }
      } else if (ele == "unit") {
        assign(
          ele, unit(input$value, input$unit), envir = parent.env(environment())
        )
      } else {
        assign(
          ele, input[[ele]], envir = parent.env(environment())
        )
      }
    }
  }
}


# 生成示例图
.get_plot <- function(graph) {
  if (graph() == "default") {
    plot <- reactiveValuesToList(default_plot)
    plot <- plot$base +
      plot$legend +
      plot$facet +
      plot$title +
      plot$subtitle +
      plot$caption +
      plot$tag
  } else if (graph() == "custom") {
    plot <- reactiveValuesToList(custom_plot)
    plot <- plot$plot
  }
  plot + .reactiveValues_to_theme(new_theme)
}


# 返回renderCachedPlot()的key，该key为四个值组成的列表
# 主题（new_theme）
# 默认示例图（default_plot）
# 自定义示例图（custom_plot）
# 选择展示的示例图（default or custom）
.cache_key <- function(graph = NULL) {
  list(
    .reactiveValues_to_theme(new_theme),
    reactiveValuesToList(default_plot),
    reactiveValuesToList(custom_plot),
    ifelse(is.null(graph), 1, graph())
  )
}