I am trying to create a new geom in ggplot2 named geom_pointpath() as below.
It is a modified geom_line() which plots selected points along with the lines. I have added a new aesthetic disp.pt which is a logical vector which specified which of the coordinates to be plotted as points.
library(rlang)
library(ggplot2)
library(stats)
library(cli)
library(ggplot2)
library(grid)
keep_mid_true <- getFromNamespace("keep_mid_true", "ggplot2")
snake_class <- getFromNamespace("snake_class", "ggplot2")
check_linewidth <- getFromNamespace("check_linewidth", "ggplot2")
dapply <- getFromNamespace("dapply", "ggplot2")
unique0 <- getFromNamespace("unique0", "ggplot2")
data_frame0 <- getFromNamespace("data_frame0", "ggplot2")
fill_alpha <- getFromNamespace("fill_alpha", "ggplot2")
repair_segment_arrow <- getFromNamespace("repair_segment_arrow", "ggplot2")
snakeize <- getFromNamespace("snakeize", "ggplot2")
lower_ascii <- "abcdefghijklmnopqrstuvwxyz"
upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
to_lower_ascii <- getFromNamespace("to_lower_ascii", "ggplot2")
to_upper_ascii <- getFromNamespace("to_upper_ascii", "ggplot2")
translate_shape_string <- getFromNamespace("translate_shape_string", "ggplot2")
deg2rad <- getFromNamespace("deg2rad", "ggplot2")
geom_pathpoint <- function(mapping = NULL, data = NULL,
stat = "identity", position = "identity",
...,
lineend = "butt",
linejoin = "round",
linemitre = 10,
arrow = NULL,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomPathPoint,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list2(
lineend = lineend,
linejoin = linejoin,
linemitre = linemitre,
arrow = arrow,
na.rm = na.rm,
...
)
)
}
GeomPathPoint <- ggproto("GeomPathPoint", Geom,
required_aes = c("x", "y"),
default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA,
# geom_point
size = 1.5, shape = 19, fill = NA, stroke = 0.5,
# Add
disp.pt = T),
non_missing_aes = c("linewidth", "colour", "linetype",
# geom_point
"size", "shape",
# Add
"disp.pt"),
handle_na = function(self, data, params) {
# 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
aesthetics <- c(self$required_aes, self$non_missing_aes)
complete <- stats::complete.cases(data[names(data) %in% aesthetics])
kept <- stats::ave(complete, data$group, FUN = keep_mid_true)
data <- data[kept, ]
if (!all(kept) && !params$na.rm) {
cli::cli_warn(paste0(
"Removed {sum(!kept)} row{?s} containing missing values or values ",
"outside the scale range ({.fn {snake_class(self)}})."
))
}
data
},
draw_panel = function(self, data, panel_params, coord, arrow = NULL,
lineend = "butt", linejoin = "round", linemitre = 10,
na.rm = FALSE) {
# browser()
# table(data$group, data$disp.pt)
data <- check_linewidth(data, snake_class(self))
if (!anyDuplicated(data$group)) {
cli::cli_inform(c(
"{.fn {snake_class(self)}}: Each group consists of only one observation.",
i = "Do you need to adjust the {.field group} aesthetic?"
))
}
# must be sorted on group
data <- data[order(data$group), , drop = FALSE]
munched <- coord_munch(coord, data, panel_params)
# Silently drop lines with less than two points, preserving order
rows <- stats::ave(seq_len(nrow(munched)), munched$group, FUN = length)
munched <- munched[rows >= 2, ]
if (nrow(munched) < 2) return(zeroGrob())
# Work out whether we should use lines or segments
attr <- dapply(munched, "group", function(df) {
linetype <- unique0(df$linetype)
data_frame0(
solid = identical(linetype, 1) || identical(linetype, "solid"),
constant = nrow(unique0(df[, names(df) %in% c("alpha", "colour", "linewidth", "linetype")])) == 1,
.size = 1
)
})
solid_lines <- all(attr$solid)
constant <- all(attr$constant)
if (!solid_lines && !constant) {
cli::cli_abort("{.fn {snake_class(self)}} can't have varying {.field colour}, {.field linewidth}, and/or {.field alpha} along the line when {.field linetype} isn't solid.")
}
# Work out grouping variables for grobs
n <- nrow(munched)
group_diff <- munched$group[-1] != munched$group[-n]
start <- c(TRUE, group_diff)
end <- c(group_diff, TRUE)
# geom_point
if (is.character(data$shape)) {
data$shape <- translate_shape_string(data$shape)
}
# geom_point
coords <- coord$transform(data, panel_params)
# Add
if (!(is.null(coords$disp.pt))) {
coords <- coords[coords$disp.pt == TRUE, ]
}
# geom_point
stroke_size <- coords$stroke
stroke_size[is.na(stroke_size)] <- 0
if (!constant) {
out <- gTree()
for (i in seq_along(unique0(munched$group))) {
munched_id <- munched[munched$group == i, ]
arrow <- repair_segment_arrow(arrow, munched_id$group)
lineg_id <- grid::segmentsGrob(
munched_id$x[!end], munched_id$y[!end], munched_id$x[!start], munched_id$y[!start],
default.units = "native", arrow = arrow,
gp = grid::gpar(
col = alpha(munched_id$colour, munched_id$alpha)[!end],
fill = alpha(munched_id$colour, munched_id$alpha)[!end],
lwd = munched_id$linewidth[!end] * .pt,
lty = munched_id$linetype[!end],
lineend = lineend,
linejoin = linejoin,
linemitre = linemitre
)
)
coords_id <- coords[coords$group == i, ]
pointg_id <-
# geom_point
grid::pointsGrob(
coords_id$x, coords_id$y,
pch = coords_id$shape,
gp = grid::gpar(
col = alpha(coords_id$colour, coords_id$alpha),
fill = fill_alpha(coords_id$fill, coords_id$alpha),
# Stroke is added around the outside of the point
fontsize = coords_id$size * .pt + stroke_size[coords$group == i] * .stroke / 2,
lwd = coords_id$stroke * .stroke / 2
)
)
out <- addGrob(out, child = lineg_id)
out <- addGrob(out, child = pointg_id)
rm(munched_id, lineg_id, coords_id, pointg_id)
}
out
} else {
id <- match(munched$group, unique0(munched$group))
out <- gTree()
for (i in seq_along(unique0(munched$group))) {
munched_id <- munched[munched$group == i, ]
lineg_id <- grid::polylineGrob(
munched_id$x, munched_id$y, #id = id,
default.units = "native", arrow = arrow,
gp = grid::gpar(
col = alpha(munched_id$colour, munched_id$alpha)[start],
fill = alpha(munched_id$colour, munched_id$alpha)[start],
lwd = munched_id$linewidth[start] * .pt,
lty = munched_id$linetype[start],
lineend = lineend,
linejoin = linejoin,
linemitre = linemitre
)
)
coords_id <- coords[coords$group == i, ]
pointg_id <-
# geom_point
grid::pointsGrob(
coords_id$x, coords_id$y,
pch = coords_id$shape,
gp = grid::gpar(
col = alpha(coords_id$colour, coords_id$alpha),
fill = fill_alpha(coords_id$fill, coords_id$alpha),
# Stroke is added around the outside of the point
fontsize = coords_id$size * .pt + stroke_size[coords$group == i] * .stroke / 2,
lwd = coords_id$stroke * .stroke / 2
)
)
out <- addGrob(out, child = lineg_id)
out <- addGrob(out, child = pointg_id)
rm(munched_id, lineg_id, coords_id, pointg_id)
}
out
}
},
draw_key = draw_key_path,
rename_size = TRUE
)
geom_linepoint <- function(mapping = NULL, data = NULL, stat = "identity",
position = "identity", na.rm = FALSE, orientation = NA,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomLinePoint,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list2(
na.rm = na.rm,
orientation = orientation,
...
)
)
}
GeomLinePoint <- ggproto("GeomLinePoint", GeomPathPoint,
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
extra_params = c("na.rm", "orientation"),
setup_data = function(data, params) {
data$flipped_aes <- params$flipped_aes
data <- flip_data(data, params$flipped_aes)
data <- data[order(data$PANEL, data$group, data$x), ]
flip_data(data, params$flipped_aes)
}
)
# Prepare sample data
library(dplyr)
dataTest = data.frame(
NoDays = rep(1:10,6),
Prod = c(rep(1:10,3),rep(2*(1:10),3))+rnorm(60,3,1),
uid = rep(1:3,each=10,times=2),
Location = rep(letters[1:2],each=30)
)
dataTest <- dataTest %>%
mutate(uid=paste(Location,uid,sep=""))
dataTest$show <- sample(c(T, F), replace = T, size = nrow(dataTest))
ggplot(dataTest, mapping=aes(x=NoDays, y=Prod,
group=uid, colour=Location)) +
geom_line()
I am facing errors because the data is not being properly prepared for the draw_panel by ggplot_build() when the aesthetic group is not specified. If group is specified, then there is no error.
Example 1
# No error
ggplot(dataTest, mapping=aes(x=NoDays, y=Prod,
group=uid, colour=Location,
disp.pt = show)) +
geom_linepoint()
ggplot(dataTest, mapping=aes(x=NoDays, y=Prod,
group=uid, colour=Location)) +
geom_linepoint(mapping = aes(disp.pt = show))
ggplot(dataTest, mapping=aes(x=NoDays, y=Prod,
colour=Location,
disp.pt = show)) +
geom_linepoint()
# Called from: draw_panel(..., self = self)
#
# Error in `geom_linepoint()`:
# ! Problem while converting geom to grob.
# ℹ Error occurred in the 1st layer.
# Caused by error in `unit()`:
# ! 'x' and 'units' must have length > 0
# Run `rlang::last_trace()` to see where the error occurred.
# Called from: signal_abort(cnd, .file)
Data in draw_panel with group aesthetic specified.
# table(data$group, data$disp.pt)
#
# FALSE TRUE
# 1 6 4
# 2 4 6
# 3 6 4
# 4 6 4
# 5 4 6
# 6 6 4
Data in draw_panel without group aesthetic specified.
# table(data$group, data$disp.pt)
#
# FALSE TRUE
# 1 16 0
# 2 0 14
# 3 16 0
# 4 0 14
Example 2
# No error
ggplot(dataTest[dataTest$uid == "a1", ],
mapping=aes(x=NoDays, y=Prod, group=uid)) +
geom_linepoint(mapping = aes(disp.pt = show))
# table(data$group, data$disp.pt)
#
# FALSE TRUE
# 1 6 4
# Error
ggplot(dataTest[dataTest$uid == "a1", ],
mapping=aes(x=NoDays, y=Prod)) +
geom_linepoint(mapping = aes(disp.pt = show))
# table(data$group, data$disp.pt)
#
# FALSE TRUE
# 1 6 0
# 2 0 4
How to fix this ? This issue is not there with geom_line().