From 1491ab027b41ded8930879b182e88426cdb29cde Mon Sep 17 00:00:00 2001 From: rmsheridan Date: Thu, 16 Sep 2021 16:38:35 -0600 Subject: [PATCH 1/5] fix so lineend, join, mitre work with background_params --- R/geom-path-trace.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/R/geom-path-trace.R b/R/geom-path-trace.R index 834b623..ad9baf7 100644 --- a/R/geom-path-trace.R +++ b/R/geom-path-trace.R @@ -188,6 +188,13 @@ GeomPathTrace <- ggproto( return(zeroGrob()) } + # Set values for params + # if params are not present in munched use default value + arrow <- munched$arrow %||% arrow + lineend <- munched$lineend %||% lineend + linejoin <- munched$linejoin %||% linejoin + linemitre <- munched$linemitre %||% linemitre + # Work out whether we should use lines or segments attr <- dapply(munched, "group", function(df) { linetype <- unique(df$linetype) From 3b24fd274d9ff62e4e811bd1a2e0fe8ceba62cff Mon Sep 17 00:00:00 2001 From: rmsheridan Date: Thu, 16 Sep 2021 22:44:25 -0600 Subject: [PATCH 2/5] cleanup geom_path draw_group() --- R/geom-path-trace.R | 115 ++++++++++++++++------------------ vignettes/geom-line-trace.Rmd | 2 +- 2 files changed, 55 insertions(+), 62 deletions(-) diff --git a/R/geom-path-trace.R b/R/geom-path-trace.R index ad9baf7..c4fe454 100644 --- a/R/geom-path-trace.R +++ b/R/geom-path-trace.R @@ -48,6 +48,7 @@ geom_path_trace <- function(mapping = NULL, data = NULL, stat = "identity", posi ) } + # Function to use for transforming data when predicate is passed to # trace_position path_trans_fn <- function(dat, ex, inv = FALSE) { @@ -189,7 +190,7 @@ GeomPathTrace <- ggproto( } # Set values for params - # if params are not present in munched use default value + # if params are not present in munched, use default value arrow <- munched$arrow %||% arrow lineend <- munched$lineend %||% lineend linejoin <- munched$linejoin %||% linejoin @@ -223,39 +224,35 @@ GeomPathTrace <- ggproto( if (!constant) { - # For trace linetype is always 1 - trace_grob <- grid::segmentsGrob( - munched$x[!end], munched$y[!end], - munched$x[!start], munched$y[!start], - - default.units = "native", - arrow = arrow, - - gp = grid::gpar( - col = alpha(munched$colour, munched$alpha)[!end], - lwd = munched$size[!end] * .pt + munched$stroke[!end] * .pt * 2, - lty = 1, - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre + create_seg_grob <- function(clr, strk, lty) { + grid::segmentsGrob( + munched$x[!end], munched$y[!end], + munched$x[!start], munched$y[!start], + + default.units = "native", + arrow = arrow, + + gp = grid::gpar( + col = alpha(clr, munched$alpha)[!end], + lwd = munched$size[!end] * .pt + strk * .pt * 2, + lty = lty, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) ) - ) - - line_grob <- grid::segmentsGrob( - munched$x[!end], munched$y[!end], - munched$x[!start], munched$y[!start], + } - default.units = "native", - arrow = arrow, + trace_grob <- create_seg_grob( + clr = munched$colour, + strk = munched$stroke[!end], + lty = 1 + ) - gp = grid::gpar( - col = alpha(munched$fill, munched$alpha)[!end], - lwd = munched$size[!end] * .pt, - lty = munched$linetype[!end], - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre - ) + line_grob <- create_seg_grob( + clr = munched$fill, + strk = 0, + lty = munched$linetype[!end] ) } else { @@ -266,39 +263,35 @@ GeomPathTrace <- ggproto( id <- match(munched$orig_group, unique(munched$orig_group)) } - trace_grob <- grid::polylineGrob( - munched$x, munched$y, - - id = id, - default.units = "native", - arrow = arrow, - - # For trace linetype is always 1 - gp = grid::gpar( - col = alpha(munched$colour, munched$alpha)[start], - lwd = munched$size[start] * .pt + munched$stroke * .pt * 2, - lty = 1, - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre + create_line_grob <- function(clr, strk, lty) { + grid::polylineGrob( + munched$x, munched$y, + + id = id, + default.units = "native", + arrow = arrow, + + gp = grid::gpar( + col = alpha(clr, munched$alpha)[start], + lwd = munched$size[start] * .pt + strk * .pt * 2, + lty = lty, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) ) - ) - - line_grob <- grid::polylineGrob( - munched$x, munched$y, + } - id = id, - default.units = "native", - arrow = arrow, + trace_grob <- create_line_grob( + clr = munched$colour, + strk = munched$stroke, + lty = 1 + ) - gp = grid::gpar( - col = alpha(munched$fill, munched$alpha)[start], - lwd = munched$size[start] * .pt, - lty = munched$linetype[start], - lineend = lineend, - linejoin = linejoin, - linemitre = linemitre - ) + line_grob <- create_line_grob( + clr = munched$fill, + strk = 0, + lty = munched$linetype[start] ) } diff --git a/vignettes/geom-line-trace.Rmd b/vignettes/geom-line-trace.Rmd index a04d700..bc5a158 100644 --- a/vignettes/geom-line-trace.Rmd +++ b/vignettes/geom-line-trace.Rmd @@ -113,7 +113,7 @@ p + geom_line_trace( trace_position = grepl("^[A-Z]A", name), stroke = 1, - background_params = list(fill = "grey75") + background_params = list(linetype = 2) ) ``` From 142cc74faed41e27474f29967e71b9113832a03f Mon Sep 17 00:00:00 2001 From: rmsheridan Date: Thu, 16 Sep 2021 23:48:28 -0600 Subject: [PATCH 3/5] more geom_path_trace() cleanup --- R/geom-path-trace.R | 100 ++++++++++++++++++++++++----------------- man/geom_path_trace.Rd | 2 +- 2 files changed, 60 insertions(+), 42 deletions(-) diff --git a/R/geom-path-trace.R b/R/geom-path-trace.R index c4fe454..b2ca4b3 100644 --- a/R/geom-path-trace.R +++ b/R/geom-path-trace.R @@ -16,11 +16,7 @@ geom_path_trace <- function(mapping = NULL, data = NULL, stat = "identity", posi show.legend = NA, inherit.aes = TRUE) { if (substitute(trace_position) != "all") { - if (is.null(mapping)) { - mapping <- ggplot2::aes() - } - - mapping$KEEP_THIS_ROW <- as.name("KEEP_THIS_ROW") + mapping <- add_dummy_aes(mapping, KEEP_CLMN) } params <- list( @@ -48,17 +44,52 @@ geom_path_trace <- function(mapping = NULL, data = NULL, stat = "identity", posi ) } +# To filter data when user passes a predicate to trace_position, a new column +# is added to mark rows to be highlighted. The column name is specified by +# KEEP_CLMN. +# To keep this column in the data, KEEP_CLMN must also be added to aes, and a +# value must be provided to default_aes(). +KEEP_CLMN <- "KEEP_THIS_ROW_PLEASE" + +# Helper to add dummy aes +add_dummy_aes <- function(mapping, nm) { + if (is.null(mapping)) { + mapping <- ggplot2::aes() + } + + mapping[[nm]] <- as.name(nm) + + mapping +} # Function to use for transforming data when predicate is passed to # trace_position path_trans_fn <- function(dat, ex, inv = FALSE) { if (inv) { - return(transform(dat, KEEP_THIS_ROW = !eval(ex))) + dat <- transform(dat, KEEP_THIS_ROW_PLEASE = !eval(ex)) + + } else { + dat <- transform(dat, KEEP_THIS_ROW_PLEASE = eval(ex)) } - transform(dat, KEEP_THIS_ROW = eval(ex)) + names(dat)[names(dat) == "KEEP_THIS_ROW_PLEASE"] <- KEEP_CLMN + + dat } +# Default aes for geom_path_trace geoms +# set this outside of ggproto since need to add dummy KEEP_CLMN so this column +# is included for trace_position predicate +default_path_aes <- ggplot2::aes( + colour = "black", + fill = "black", + size = 0.5, + stroke = 0.5, + linetype = 1, + alpha = NA +) + +default_path_aes[[KEEP_CLMN]] <- TRUE # Extra parameters to include for background points extra_bkgd_params <- c( @@ -66,6 +97,7 @@ extra_bkgd_params <- c( "bkgd_stroke", "bkgd_linetype", "bkgd_alpha" ) + #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -75,15 +107,7 @@ GeomPathTrace <- ggproto( required_aes = c("x", "y"), - default_aes = ggplot2::aes( - colour = "black", - fill = "black", - size = 0.5, - stroke = 0.5, - linetype = 1, - alpha = NA, - KEEP_THIS_ROW = TRUE - ), + default_aes = default_path_aes, extra_params = c( extra_bkgd_params, @@ -110,11 +134,13 @@ GeomPathTrace <- ggproto( data <- drop_na_values(data) - if (!all(data$KEEP_THIS_ROW)) { - data[!data$KEEP_THIS_ROW, "y"] <- NA + # If KEEP_CLMN has been modified by user-provided predicate, add NAs to + # create line breaks + if (!all(data[[KEEP_CLMN]])) { + data[!data[[KEEP_CLMN]], "y"] <- NA data <- drop_na_values(data, warn = FALSE) - data <- data[, colnames(data) != "KEEP_THIS_ROW"] + data <- data[, colnames(data) != KEEP_CLMN] } data @@ -122,11 +148,11 @@ GeomPathTrace <- ggproto( setup_data = function(data, params) { - # Want to adjust groups if KEEP_THIS_ROW column is present in data - # this column is added when user passes predicate to trace_position and - # indicates which data points should be highlighted - if (!all(data$KEEP_THIS_ROW)) { - d <- data[, !colnames(data) %in% c("KEEP_THIS_ROW", "group")] + # Do not want KEEP_CLMN to influence groups since this column is only + # needed to select data point to highlight. Need to re-adjust groups if + # KEEP_CLMN has been modified by user-provided predicate + if (!all(data[[KEEP_CLMN]])) { + d <- data[, !colnames(data) %in% c(KEEP_CLMN, "group")] d <- add_group(d) data$group <- d$group @@ -152,8 +178,8 @@ GeomPathTrace <- ggproto( } } - # Add background new data columns for background_params - # should not override the original columns since final parameters (colour, + # Add new background data columns for background_params + # should not overwrite the original columns since final parameters (colour, # fill, etc.) have not been set for groups yet bkgd_clmns <- names(params)[grepl("^bkgd_", names(params))] data[bkgd_clmns] <- params[bkgd_clmns] @@ -327,11 +353,7 @@ geom_line_trace <- function(mapping = NULL, data = NULL, stat = "identity", posi trace_position = "all", background_params = NULL, ...) { if (substitute(trace_position) != "all") { - if (is.null(mapping)) { - mapping <- ggplot2::aes() - } - - mapping$KEEP_THIS_ROW <- as.name("KEEP_THIS_ROW") + mapping <- add_dummy_aes(mapping, KEEP_CLMN) } params <- list( @@ -395,11 +417,7 @@ geom_step_trace <- function(mapping = NULL, data = NULL, stat = "identity", posi trace_position = "all", background_params = NULL, ...) { if (substitute(trace_position) != "all") { - if (is.null(mapping)) { - mapping <- ggplot2::aes() - } - - mapping$KEEP_THIS_ROW <- as.name("KEEP_THIS_ROW") + mapping <- add_dummy_aes(mapping, KEEP_CLMN) } params <- list( @@ -453,15 +471,15 @@ stairstep <- function(data, direction = "hv") { } if (direction == "vh") { - xs <- rep(1:n, each = 2)[-2*n] + xs <- rep(1:n, each = 2)[-2 * n] ys <- c(1, rep(2:n, each = 2)) } else if (direction == "hv") { - ys <- rep(1:n, each = 2)[-2*n] + ys <- rep(1:n, each = 2)[-2 * n] xs <- c(1, rep(2:n, each = 2)) } else if (direction == "mid") { - xs <- rep(1:(n-1), each = 2) + xs <- rep(1:(n - 1), each = 2) ys <- rep(1:n, each = 2) } else { @@ -470,10 +488,10 @@ stairstep <- function(data, direction = "hv") { if (direction == "mid") { gaps <- data$x[-1] - data$x[-n] - mid_x <- data$x[-n] + gaps/2 # map the mid-point between adjacent x-values + mid_x <- data$x[-n] + gaps / 2 # map the mid-point between adjacent x-values x <- c(data$x[1], mid_x[xs], data$x[n]) y <- c(data$y[ys]) - data_attr <- data[c(1,xs,n), setdiff(names(data), c("x", "y"))] + data_attr <- data[c(1, xs, n), setdiff(names(data), c("x", "y"))] } else { x <- data$x[xs] diff --git a/man/geom_path_trace.Rd b/man/geom_path_trace.Rd index c61aadb..0d54f4e 100644 --- a/man/geom_path_trace.Rd +++ b/man/geom_path_trace.Rd @@ -136,7 +136,7 @@ Trace lines to improve clarity of plots with overplotted geoms. \item \code{colour} \item \code{fill} \item \code{group} - \item \code{KEEP_THIS_ROW} + \item \code{KEEP_THIS_ROW_PLEASE} \item \code{linetype} \item \code{size} \item \code{stroke} From 04bf657f9a45ab4f61b4f37c6fd0b5d87e93ec9f Mon Sep 17 00:00:00 2001 From: rmsheridan Date: Fri, 17 Sep 2021 00:04:32 -0600 Subject: [PATCH 4/5] fix group order geom_line --- R/geom-path-trace.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/geom-path-trace.R b/R/geom-path-trace.R index b2ca4b3..8587f73 100644 --- a/R/geom-path-trace.R +++ b/R/geom-path-trace.R @@ -78,7 +78,7 @@ path_trans_fn <- function(dat, ex, inv = FALSE) { } # Default aes for geom_path_trace geoms -# set this outside of ggproto since need to add dummy KEEP_CLMN so this column +# set this outside of ggproto since need to add KEEP_CLMN so this column # is included for trace_position predicate default_path_aes <- ggplot2::aes( colour = "black", @@ -120,6 +120,7 @@ GeomPathTrace <- ggproto( # Drop missing values at the start or end of a line - can't drop in the # middle since you expect those to be shown by a break in the line # do not include colour here so the user can choose to exclude the outline + # by setting colour = NA drop_na_values <- function(dat, warn = TRUE, clmns = c("x", "y", "size", "fill", "stroke", "linetype")) { complete <- stats::complete.cases(dat[clmns]) kept <- stats::ave(complete, dat$group, FUN = keep_mid_true) @@ -394,11 +395,11 @@ GeomLineTrace <- ggproto( }, setup_data = function(data, params) { + data$flipped_aes <- params$flipped_aes + data <- data[order(data$PANEL, data$group, data$x), ] data <- GeomPathTrace$setup_data(data, params) - data$flipped_aes <- params$flipped_aes - data <- flip_data(data, params$flipped_aes) data <- data[order(data$PANEL, data$group, data$x), ] data <- flip_data(data, params$flipped_aes) From 66b6d25694a93ba9c6b2f34766aa3daff790ea93 Mon Sep 17 00:00:00 2001 From: rmsheridan Date: Fri, 17 Sep 2021 00:13:18 -0600 Subject: [PATCH 5/5] %||% operator --- R/utilities-ggplot2.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/utilities-ggplot2.R b/R/utilities-ggplot2.R index 1ad03fb..170dca3 100644 --- a/R/utilities-ggplot2.R +++ b/R/utilities-ggplot2.R @@ -374,3 +374,9 @@ 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) + +# Used by geom_path_trace +# https://github.com/tidyverse/ggplot2/blob/master/R/utilities.r +"%||%" <- function(a, b) { + if (!is.null(a)) a else b +}