Merge pull request #13 from rnabioco/trace_position

Added ability to select cells using trace_position parameter

NAMESPACE

@@ -7,6 +7,7 @@ export(GeomPointTrace)
 export(as_label)
 export(as_name)
 export(draw_key_point_trace)
+export(enexpr)
 export(enquo)
 export(enquos)
 export(expr)
@@ -43,17 +44,25 @@ export(scale_trace_size_ordinal)
 export(sym)
 export(syms)
 import(ggplot2)
+importFrom(dplyr,filter)
+importFrom(dplyr,mutate)
 importFrom(grid,gpar)
 importFrom(grid,grobName)
 importFrom(grid,grobTree)
 importFrom(grid,pointsGrob)
 importFrom(rlang,"%||%")
 importFrom(rlang,":=")
 importFrom(rlang,.data)
+importFrom(rlang,abort)
 importFrom(rlang,as_label)
 importFrom(rlang,as_name)
+importFrom(rlang,enexpr)
 importFrom(rlang,enquo)
 importFrom(rlang,enquos)
 importFrom(rlang,expr)
+importFrom(rlang,is_call)
+importFrom(rlang,is_function)
+importFrom(rlang,is_missing)
 importFrom(rlang,sym)
 importFrom(rlang,syms)
+importFrom(rlang,warn)

R/geom-point-trace.R

@@ -41,30 +41,76 @@
 #'    that define both data and aesthetics and shouldn't inherit behaviour from
 #'    the default plot specification, e.g. [borders()].
 #' @eval rd_aesthetics("geom", "point_trace")
-#' @rdname geom_point_trace
+#' @importFrom dplyr filter mutate
 #' @export
 # https://stackoverflow.com/questions/67573707/ggplot-extension-function-to-plot-a-superimposed-mean-in-a-scatterplot
 geom_point_trace <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity",
                              ..., trace_position = "all", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
 
-  if (!trace_position %in% c("all", "bottom")) {
-    stop("trace_position must be either 'all' or 'bottom'")
+  if (rlang::is_call(rlang::enexpr(trace_position))) {
+
+    bkgd_data <- data
+
+    if (!is.null(data)) {
+      data <- ggplot2::fortify(data)
+    }
+
+    if (rlang::is_function(data)) {
+
+      data_fn <- data
+
+      data <- ggplot2::fortify(~ dplyr::filter(data_fn(...), {{trace_position}}))
+
+    } else if (is.data.frame(data) || is.null(data)) {
+
+      data <- ggplot2::fortify(~ dplyr::filter(.x, {{trace_position}}))
+    }
+
+    bkgd_params  <- list(na.rm = na.rm, ...)
+    bkgd_params  <- bkgd_params[!grepl("^trace_", names(bkgd_params))]
+    bkgd_mapping <- mapping[!grepl("^trace_", names(mapping))]
+
+    bkgd_lyr <- ggplot2::layer(
+      data        = bkgd_data,
+      mapping     = bkgd_mapping,
+      stat        = stat,
+      geom        = ggplot2::GeomPoint,
+      position    = position,
+      show.legend = show.legend,
+      inherit.aes = inherit.aes,
+      params      = bkgd_params
+    )
+
+  } else if (is.character(rlang::enexpr(trace_position)) && trace_position == "bottom") {
+
+    data <- ggplot2::fortify(~ dplyr::mutate(.x, BOTTOM_TRACE_GROUP = "BOTTOM_TRACE_GROUP"))
+
+    if (is.null(mapping)) {
+      mapping <- ggplot2::aes()
+    }
+
+    mapping$group <- sym("BOTTOM_TRACE_GROUP")
+
+  } else if (!is.character(rlang::enexpr(trace_position)) || !trace_position %in% c("all", "bottom")) {
+    stop("trace_position must be 'all' or 'bottom' or a predicate specifying which points to trace")
   }
 
-  layer(
+  trace_lyr <- layer(
     data        = data,
     mapping     = mapping,
     stat        = stat,
     geom        = GeomPointTrace,
     position    = position,
     show.legend = show.legend,
     inherit.aes = inherit.aes,
-    params      = list(
-      trace_position = trace_position,
-      na.rm = na.rm,
-      ...
-    )
+    params      = list(na.rm = na.rm, ...)
   )
+
+  if (rlang::is_call(rlang::enexpr(trace_position))) {
+    trace_lyr <- list(bkgd_lyr, trace_lyr)
+  }
+
+  trace_lyr
 }
 
 #' GeomPointTrace
@@ -81,27 +127,19 @@ GeomPointTrace <- ggplot2::ggproto(
   non_missing_aes = c("size", "shape", "colour", "trace_size", "trace_colour", "trace_linetype"),
 
   default_aes = ggplot2::aes(
-    shape  = 19,
-    colour = "black",
-    fill   = NA,
-    alpha  = 1,
-    size   = 1.5,
-    stroke = 0.5,
+    shape          = 19,
+    colour         = "black",
+    fill           = NA,
+    alpha          = 1,
+    size           = 1.5,
+    stroke         = 0.5,
     trace_color    = "black",
     trace_alpha    = 1,
     trace_size     = 1,
     trace_linetype = 1
   ),
 
-  setup_data = function(data, params) {
-    if (params$trace_position == "bottom") {
-      data$group <- -1
-    }
-
-    data
-  },
-
-  draw_group = function(data, panel_params, coord, trace_position = "all", na.rm = FALSE) {
+  draw_group = function(self, data, panel_params, coord, trace_position = "all", na.rm = FALSE) {
 
     if (is.character(data$shape)) {
       data$shape <- translate_shape_string(data$shape)
@@ -307,4 +345,10 @@ translate_trace_shape <- function(pch) {
   res
 }
 
+#' Helper to name grid objects
+#' @noRd
+ggname <- function(prefix, grob) {
+  grob$name <- grid::grobName(grob, prefix)
 
+  grob
+}

R/scale-trace-linetype.R

@@ -10,6 +10,12 @@ scale_trace_linetype_binned <- function(..., na.value = "blank") {
   binned_scale("trace_linetype", "linetype_b", binned_pal(scales::linetype_pal()), ...)
 }
 
+binned_pal <- function(palette) {
+  function(x) {
+    palette(length(x))
+  }
+}
+
 #' @rdname scale_trace_linetype
 #' @export
 scale_trace_linetype_continuous <- function(...) {

R/scale-trace-manual.R

@@ -138,3 +138,6 @@ manual_scale <- function(aesthetic, values = NULL, breaks = waiver(), ..., limit
   }
   discrete_scale(aesthetic, "manual", pal, breaks = breaks, limits = limits, ...)
 }
+
+is.waive <- function(x) inherits(x, "waiver")
+

R/utilities.R → R/utilities-ggplot2.R

@@ -1,13 +1,16 @@
-
-#' Name ggplot grid object
-#' Helper to name grid objects
-#' https://github.com/tidyverse/ggplot2/blob/master/R/utilities-grid.r
-#' @noRd
-ggname <- function(prefix, grob) {
-  grob$name <- grid::grobName(grob, prefix)
-  grob
-}
-
+#' Base ggproto classes for ggplot2
+#'
+#' If you are creating a new geom, stat, position, or scale in another package,
+#' you'll need to extend from `ggplot2::Geom`, `ggplot2::Stat`,
+#' `ggplot2::Position`, or `ggplot2::Scale`.
+#'
+#' @seealso ggproto
+#' @keywords internal
+#' @name ggplot2-ggproto
+NULL
+
+# Helpers used to add info for geom documentation
+# https://github.com/tidyverse/ggplot2/blob/master/R/utilities-help.r
 rd_aesthetics <- function(type, name) {
   obj <- switch(
     type,
@@ -46,6 +49,8 @@ rd_aesthetics_item <- function(x) {
   )
 }
 
+# Used by rd_aesthetics
+# https://github.com/tidyverse/ggplot2/blob/master/R/layer.r
 check_subclass <- function(x, subclass, argname = to_lower_ascii(subclass),
                            env = parent.frame()) {
 
@@ -71,23 +76,26 @@ check_subclass <- function(x, subclass, argname = to_lower_ascii(subclass),
 }
 
 # Look for object first in parent environment and if not found, then in
-# ggplot2 namespace environment.  This makes it possible to override default
+# ggplot2 namespace environment. This makes it possible to override default
 # scales by setting them in the parent environment.
+# Used by check_subclass
+# https://github.com/tidyverse/ggplot2/blob/master/R/scale-type.R
 find_global <- function(name, env, mode = "any") {
-
   if (exists(name, envir = env, mode = mode)) {
     return(get(name, envir = env, mode = mode))
   }
 
   nsenv <- asNamespace("ggplot2")
-
   if (exists(name, envir = nsenv, mode = mode)) {
     return(get(name, envir = nsenv, mode = mode))
   }
 
   NULL
 }
 
+# Convert to camel case
+# Used by check_subclass
+# https://github.com/tidyverse/ggplot2/blob/master/R/layer.r
 camelize <- function(x, first = FALSE) {
   x <- gsub("_(.)", "\\U\\1", x, perl = TRUE)
 
@@ -98,20 +106,15 @@ camelize <- function(x, first = FALSE) {
   x
 }
 
+# Used by camelize
+# https://github.com/tidyverse/ggplot2/blob/master/R/utilities.r
 firstUpper <- function(s) {
   paste0(to_upper_ascii(substring(s, 1, 1)), substring(s, 2))
 }
 
-# Use chartr() for safety since toupper() fails to convert i to I in Turkish locale
+# Used by camelize and check_subclass
+# https://github.com/tidyverse/ggplot2/blob/master/R/utilities.r
 lower_ascii <- "abcdefghijklmnopqrstuvwxyz"
 upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x)
 to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x)
-
-binned_pal <- function(palette) {
-  function(x) {
-    palette(length(x))
-  }
-}
-
-is.waive <- function(x) inherits(x, "waiver")

R/utilities-tidy-eval.R

@@ -41,7 +41,7 @@
 #' @md
 #' @name tidyeval
 #' @keywords internal
-#' @importFrom rlang expr enquo enquos sym syms .data := %||% as_name as_label
-#' @aliases expr enquo enquos sym syms .data := %||% as_name as_label
-#' @export expr enquo enquos sym syms .data := %||% as_name as_label
+#' @importFrom rlang abort warn is_call is_function is_missing expr enexpr enquo enquos sym syms .data := %||% as_name as_label
+#' @aliases abort warn is_call is_function is_missing expr enquo enquos sym syms .data := %||% as_name as_label
+#' @export expr enexpr enquo enquos sym syms .data := %||% as_name as_label
 NULL