R/geom_factory_point.R

In k-hench/geomfactory: Parallel ggplot color scales

#' Create an alternative color aesthetic for geom_point
#'
#' \code{factory_geom_point} is the factory function for the geom_point.
#' Given the name of the new the new color aesthetic (eg. by \code{aes_name = test}),
#' it creates the new geom \code{geom_point_test(), a manual and a contiuous scale for the
#' new aesthetic for both color and fill  (\code{scale_test_c_manual()/
#' \code{scale_test_f_manual()} and \code{scale_test_c_continuous()}/ scale_test_f_continuous()})
#' as well as a guide that can chandle the new aesthetic (\code{guide_colourbar_test()}).
#'
#' The newly created aesthetics are then \code{test_c} (color) and \code{test_f} (fill).
#'
#'
#' @param aes_name string skalar, the name of the new geom
#'
#' @examples
#' factory_geom_point('var3')
#'
#' @export
factory_geom_point <- function(aes_name){

  aes_c <- str_c(aes_name,'_c')
  aes_f <- str_c(aes_name,'_f')

  geom_point_alt <<- function(mapping = NULL, data = NULL,
                             stat = "identity", position = "identity",
                             ...,
                             na.rm = FALSE,
                             show.legend = NA,
                             inherit.aes = TRUE) {
    layer(
      data = data,
      mapping = mapping,
      stat = stat,
      geom = get(str_c("GeomPoint_",aes_name)),
      position = position,
      show.legend = show.legend,
      inherit.aes = inherit.aes,
      params = list(
        na.rm = na.rm,
        ...
      )
    )
  }

  aes_defaults <- tibble( shape = 19, size = 1.5,
          aes_c = rgb(0,0,0),
          aes_f = rgb(0,0,0),
          alpha = NA,
          stroke = 0.5) %>%
    set_names(.,nm = c('shape', 'size', aes_c, aes_f, 'alpha', 'stroke'))

  GeomPoint_alt <<- ggproto(str_c("GeomPoint_",aes_name), Geom,
                            required_aes = c("x", "y"),
                            non_missing_aes = c("size", "shape",
                                                aes_c, aes_f),
                            default_aes = aes_defaults %>% purrr::pmap(prep_aes) %>% .[[1]],
                              #aes(
                              #shape = 19, size = 1.5,
                             # aes_c = "rgb(0,0,0)", aes_f = "rgb(0,0,0)",
                              #alpha = NA, stroke = 0.5
                            #),

                            draw_panel = function(data, panel_params, coord, na.rm = FALSE) {
                              if (is.character(data$shape)) {
                                data$shape <- translate_shape_string(data$shape)
                              }

                              coords <- coord$transform(data, panel_params)
                              ggplot2:::ggname(str_c("geom_point_",aes_name),
                                     grid::pointsGrob(
                                       coords$x, coords$y,
                                       pch = coords$shape,
                                       gp = grid::gpar(
                                         col = alpha(coords[aes_c] %>% unlist() %>% unname(), coords$alpha),
                                         fill = alpha(coords[aes_f] %>% unlist() %>% unname(), coords$alpha),
                                         # Stroke is added around the outside of the point
                                         fontsize = coords$size * .pt + coords$stroke * .stroke / 2,
                                         lwd = coords$stroke * .stroke / 2
                                       )
                                     )
                              )
                            },

                            draw_key = draw_key_point
  )




  scale_alt_c_manual <<- function (..., values, aesthetics = aes_c){
    manual_scale_alt(aesthetics, values, ...)
  }

  scale_alt_f_manual <<- function (..., values, aesthetics = aes_f){
    manual_scale_alt(aesthetics, values, ...)
  }

  scale_alt_c_continuous <<- function(..., low = "#084082ff", high = "#f0a830ff", space = "Lab",
                                    na.value = "grey50", guide = str_c("colourbar_",aes_name), aesthetics = aes_c) {
    ggplot2:::continuous_scale(aesthetics, "gradient", scales::seq_gradient_pal(low, high, space),
                               na.value = na.value, guide = guide, ...)
  }

  scale_alt_f_continuous <<- function(..., low = "#084082ff", high = "#f0a830ff", space = "Lab",
                                    na.value = "grey50", guide = str_c("colourbar_",aes_name), aesthetics = aes_f) {
    ggplot2:::continuous_scale(aesthetics, "gradient", scales::seq_gradient_pal(low, high, space),
                               na.value = na.value, guide = guide, ...)
  }


  manual_scale_alt <- function(aesthetic, values = NULL, ...) {
    # check for missing `values` parameter, in lieu of providing
    # a default to all the different scale_*_manual() functions
    if (rlang::is_missing(values)) {
      values <- NULL
    } else {
      force(values)
    }

    pal <- function(n) {
      if (n > length(values)) {
        stop("Insufficient values in manual scale. ", n, " needed but only ",
             length(values), " provided.", call. = FALSE)
      }
      values
    }
    discrete_scale(aesthetic, "manual", pal,
                   guide =  guide_legend(override.aes = list(colour = values)), ...)

  }

  guide_colourbar_alt <<- function(

    # title
    title = waiver(),
    title.position = NULL,
    title.theme = NULL,
    title.hjust = NULL,
    title.vjust = NULL,

    # label
    label = TRUE,
    label.position = NULL,
    label.theme = NULL,
    label.hjust = NULL,
    label.vjust = NULL,

    # bar
    barwidth = NULL,
    barheight = NULL,
    nbin = 20,
    raster = TRUE,

    # frame
    frame.colour = NULL,
    frame.linewidth = 0.5,
    frame.linetype = 1,

    # ticks
    ticks = TRUE,
    ticks.colour = "white",
    ticks.linewidth = 0.5,
    draw.ulim= TRUE,
    draw.llim = TRUE,

    # general
    direction = NULL,
    default.unit = "line",
    reverse = FALSE,
    order = 0,
    available_aes = c("colour", "color", "fill", str_c(aes_name,c('','_c','_f'))),

    ...) {

    if (!is.null(barwidth) && !grid::is.unit(barwidth)) barwidth <- unit(barwidth, default.unit)
    if (!is.null(barheight) && !grid::is.unit(barheight)) barheight <- unit(barheight, default.unit)

    structure(list(
      # title
      title = title,
      title.position = title.position,
      title.theme = title.theme,
      title.hjust = title.hjust,
      title.vjust = title.vjust,

      # label
      label = label,
      label.position = label.position,
      label.theme = label.theme,
      label.hjust = label.hjust,
      label.vjust = label.vjust,

      # bar
      barwidth = barwidth,
      barheight = barheight,
      nbin = nbin,
      raster = raster,

      # frame
      frame.colour = frame.colour,
      frame.linewidth = frame.linewidth,
      frame.linetype = frame.linetype,

      # ticks
      ticks = ticks,
      ticks.colour = ticks.colour,
      ticks.linewidth = ticks.linewidth,
      draw.ulim = draw.ulim,
      draw.llim = draw.llim,

      # general
      direction = direction,
      default.unit = default.unit,
      reverse = reverse,
      order = order,

      # parameter
      available_aes = available_aes,
      ...,
      name = str_c("colorbar_",aes_name)),
      class = c("guide", "colorbar")
    )
  }

  mv(from = "geom_point_alt", to = str_c('geom_point_',aes_name),envir = parent.frame())
  mv(from = "GeomPoint_alt", to = str_c("GeomPoint_",aes_name),envir = parent.frame())
  mv(from = "scale_alt_c_manual", to = str_c('scale_',aes_name,'_c_manual'),envir = parent.frame())
  mv(from = "scale_alt_f_manual", to = str_c('scale_',aes_name,'_f_manual'),envir = parent.frame())
  mv(from = "scale_alt_c_continuous", to = str_c('scale_',aes_name,'_c_continuous'),envir = parent.frame())
  mv(from = "scale_alt_f_continuous", to = str_c('scale_',aes_name,'_f_continuous'),envir = parent.frame())
  mv(from = "guide_colourbar_alt", to = str_c("guide_colourbar_",aes_name),envir = parent.frame())
}