Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Cleanup #37

Merged
merged 6 commits into from
Sep 17, 2021
Merged

Cleanup #37

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
1491ab0
fix so lineend, join, mitre work with background_params
sheridar Sep 16, 2021
3b24fd2
cleanup geom_path draw_group()
sheridar Sep 17, 2021
142cc74
more geom_path_trace() cleanup
sheridar Sep 17, 2021
04bf657
fix group order geom_line
sheridar Sep 17, 2021
66b6d25
%||% operator
sheridar Sep 17, 2021
2508cf2
Merge branch 'cleanup' of github.com:rnabioco/ggtrace into cleanup
sheridar Sep 17, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
225 changes: 122 additions & 103 deletions R/geom-path-trace.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand Down Expand Up @@ -48,23 +44,60 @@ 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 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(
"bkgd_colour", "bkgd_fill", "bkgd_size",
"bkgd_stroke", "bkgd_linetype", "bkgd_alpha"
)


#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
Expand All @@ -74,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,
Expand All @@ -95,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)
Expand All @@ -109,23 +135,25 @@ 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
},

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
Expand All @@ -151,8 +179,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]
Expand Down Expand Up @@ -188,6 +216,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)
Expand Down Expand Up @@ -216,39 +251,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 {
Expand All @@ -259,39 +290,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]
)
}

Expand Down Expand Up @@ -327,11 +354,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(
Expand Down Expand Up @@ -372,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)
Expand All @@ -395,11 +418,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(
Expand Down Expand Up @@ -453,15 +472,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 {
Expand All @@ -470,10 +489,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]
Expand Down
6 changes: 6 additions & 0 deletions R/utilities-ggplot2.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
}
2 changes: 1 addition & 1 deletion man/geom_path_trace.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion vignettes/geom-line-trace.Rmd
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
)
```

Expand Down