ggplot2 geom_rug() produces different line length with wide plot - r

I posted this as follow up to a 'sibling' question with lattice (i.e. Lattice's `panel.rug` produces different line length with wide plot) but due to different graphical system it deserves to be separate.
When producing a wide plot in ggplot2 with margins that include geom_rug() from ggthemes, the length of the lines in rugged margins is longer in the y-axis than x-axis:
library(ggplot2)
library(ggthemes)
png(width=800, height=400)
ggplot(swiss, aes(Education, Fertility)) + geom_point() + geom_rug()
dev.off()
I would like those rug lines in x- and y-axes to be the same length regardless of the shape of a plot (note: right now the rug lines will only be the same length when the plot is square).

This followed hadley's current previous geom_rug code, but modified it to add (or subtract) an absolute amount for interior units of the rug-ticks. It's really an application of the grid::unit-function more than anything else, since it uses the fact that units can be added and subtracted with different bases. You could modify it to accept a "rug_len"-argument with a default of your choosing, say unit(0.5, "cm"). (Do need to remember to set the environment of the function, so that one closure, geom_rug2, can call the next closure, ggplot2::'+', correctly.)
geom_rug2 <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity", sides = "bl", ...) {
GeomRug2$new(mapping = mapping, data = data, stat = stat, position = position, sides = sides, ...)
}
GeomRug2 <- proto(ggplot2:::Geom, {
objname <- "rug2"
draw <- function(., data, scales, coordinates, sides, ...) {
rugs <- list()
data <- coord_transform(coordinates, data, scales)
if (!is.null(data$x)) {
if(grepl("b", sides)) {
rugs$x_b <- segmentsGrob(
x0 = unit(data$x, "native"), x1 = unit(data$x, "native"),
y0 = unit(0, "npc"), y1 = unit(0, "npc")+unit(1, "cm"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
if(grepl("t", sides)) {
rugs$x_t <- segmentsGrob(
x0 = unit(data$x, "native"), x1 = unit(data$x, "native"),
y0 = unit(1, "npc"), y1 = unit(1, "npc")-unit(1, "cm"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
}
if (!is.null(data$y)) {
if(grepl("l", sides)) {
rugs$y_l <- segmentsGrob(
y0 = unit(data$y, "native"), y1 = unit(data$y, "native"),
x0 = unit(0, "npc"), x1 = unit(0, "npc")+unit(1, "cm"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
if(grepl("r", sides)) {
rugs$y_r <- segmentsGrob(
y0 = unit(data$y, "native"), y1 = unit(data$y, "native"),
x0 = unit(1, "npc"), x1 = unit(1, "npc")-unit(1, "cm"),
gp = gpar(col = alpha(data$colour, data$alpha), lty = data$linetype, lwd = data$size * .pt)
)
}
}
gTree(children = do.call("gList", rugs))
}
default_stat <- function(.) StatIdentity
default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)
guide_geom <- function(.) "path"
})
environment(geom_rug2) <- environment(ggplot)
p <- qplot(x,y)
p + geom_rug2(size=.1)
With your code creating a png I get:

I'm not sure if there's a way to control the rug segment length in geom_rug (I couldn't find one). However, you can create your own rug using geom_segment and hard-code the segment lengths or add some logic to programatically produce equal-length rug lines. For example:
# Aspect ratio
ar = 0.33
# Distance from lowest value to start of rug segment
dist = 2
# Rug length factor
rlf = 2.5
ggplot(swiss, aes(Education, Fertility)) + geom_point() +
geom_segment(aes(y=Fertility, yend=Fertility,
x=min(swiss$Education) - rlf*ar*dist, xend=min(swiss$Education) - ar*dist)) +
geom_segment(aes(y=min(swiss$Fertility) - rlf*dist, yend=min(swiss$Fertility) - dist,
x=Education, xend=Education)) +
coord_fixed(ratio=ar,
xlim=c(min(swiss$Education) - rlf*ar*dist, 1.03*max(swiss$Education)),
ylim=c(min(swiss$Fertility) - rlf*dist, 1.03*max(swiss$Fertility)))
Or if you just want to hard-code it:
ggplot(swiss, aes(Education, Fertility)) + geom_point() +
geom_segment(aes(y=Fertility, yend=Fertility,
x=min(swiss$Education) - 3, xend=min(swiss$Education) - 1.5)) +
geom_segment(aes(y=min(swiss$Fertility) - 6, yend=min(swiss$Fertility) - 3,
x=Education, xend=Education)) +
coord_cartesian(xlim=c(min(swiss$Education) - 3, 1.03*max(swiss$Education)),
ylim=c(min(swiss$Fertility) - 6, 1.03*max(swiss$Fertility)))

As of ggplot2 v3.2.0 you can pass a length argument to geom_rug() to specify the absolute length of the rug:
library(ggplot2)
library(ggthemes)
png(width=800, height=400)
ggplot(swiss, aes(Education, Fertility)) + geom_point() + geom_rug(length = unit(0.5,"cm"))
dev.off()

Delving into the structure of the ggplot grob:
Minor edit: updating to ggplot2 2.2.1
library(ggplot2)
p = ggplot(swiss, aes(Education, Fertility)) + geom_point() + geom_rug()
# Get the ggplot grob
gp = ggplotGrob(p)
# Set end points of rug segments
library(grid)
gp$grobs[[6]]$children[[4]]$children[[1]]$y1 = unit(0.03, "snpc")
gp$grobs[[6]]$children[[4]]$children[[2]]$x1 = unit(0.03, "snpc")
png(width=900, height=300)
grid.draw(gp)
dev.off()

Another under-the-hood solution. First, I get the ggplot grob, and then I use the editGrob function from the grid package. With editGrob, I simply name the grob to be edited; it's easier than having to follow the grob's structure all the way to the relevant parameters. Normally, editGrob can't see all of the ggplot grobs, but they can be exposed with grid.force().
library(ggplot2)
library(grid)
p = ggplot(swiss, aes(Education, Fertility)) + geom_point() + geom_rug()
# Get the ggplot grob
gp = ggplotGrob(p)
# Get names of relevant grobs.
# The grid.force function generates the gtable's at-drawing-time contents.
names.grobs = grid.ls(grid.force(gp))$name # We're interested in the children of rugs.gTree
segments = names.grobs[which(grepl("GRID.segments", names.grobs))]
# Check them out
str(getGrob(grid.force(gp), gPath(segments[1]))) # Note: y1 = 0.03 npc
str(getGrob(grid.force(gp), gPath(segments[2]))) # Note: x1 = 0.03 npc
# Set y1 and x1 to 0.03 snpc
gp = editGrob(grid.force(gp), gPath(segments[1]), y1 = unit(0.03, "snpc"))
gp = editGrob(grid.force(gp), gPath(segments[2]), x1 = unit(0.03, "snpc"))
png(width=900, height=300)
grid.draw(gp)
dev.off()

Related

Adding arrows to the color or fill legend in ggplot2 [duplicate]

I'd like to make a plot using ggplot2 where some of the fill values are clipped, i.e. values above or below the limits of the color scale are displayed as the minimum/maximum color. I can get this to work like this, using a combination of limit and oob (out of bounds):
library(ggplot2)
library(scales)
ggplot() + ... + scale_fill_viridis(na.value="white", limit=c(0, 10), oob=squish)
But there is no information in the colorbar that indicates there are values present outside of the limits.
How can I reproduce this matplotlib example in ggplot: https://stackoverflow.com/a/32072348
Specifically, how to get the triangles at the end of the colorbar?
As far as I'm aware there is not a package that implements triangle ends for colourbars in ggplot2 (but please let me know if there is!). However, we can implement our own. We'd need a constructor for our custom guide and a way to draw it. Most of the stuff is already implemented in guide_colourbar() and methods for their class, so what we need to do is just tag on our own class and expand the guide_gengrob method. The code below should work for vertically oriented colourbars. You'd need to know some stuff about the grid package and gtable package to follow along.
library(ggplot2)
library(gtable)
library(grid)
my_triangle_colourbar <- function(...) {
guide <- guide_colourbar(...)
class(guide) <- c("my_triangle_colourbar", class(guide))
guide
}
guide_gengrob.my_triangle_colourbar <- function(...) {
# First draw normal colourbar
guide <- NextMethod()
# Extract bar / colours
is_bar <- grep("^bar$", guide$layout$name)
bar <- guide$grobs[[is_bar]]
extremes <- c(bar$raster[1], bar$raster[length(bar$raster)])
# Extract size
width <- guide$widths[guide$layout$l[is_bar]]
height <- guide$heights[guide$layout$t[is_bar]]
short <- min(convertUnit(width, "cm", valueOnly = TRUE),
convertUnit(height, "cm", valueOnly = TRUE))
# Make space for triangles
guide <- gtable_add_rows(guide, unit(short, "cm"),
guide$layout$t[is_bar] - 1)
guide <- gtable_add_rows(guide, unit(short, "cm"),
guide$layout$t[is_bar])
# Draw triangles
top <- polygonGrob(
x = unit(c(0, 0.5, 1), "npc"),
y = unit(c(0, 1, 0), "npc"),
gp = gpar(fill = extremes[1], col = NA)
)
bottom <- polygonGrob(
x = unit(c(0, 0.5, 1), "npc"),
y = unit(c(1, 0, 1), "npc"),
gp = gpar(fill = extremes[2], col = NA)
)
# Add triangles to guide
guide <- gtable_add_grob(
guide, top,
t = guide$layout$t[is_bar] - 1,
l = guide$layout$l[is_bar]
)
guide <- gtable_add_grob(
guide, bottom,
t = guide$layout$t[is_bar] + 1,
l = guide$layout$l[is_bar]
)
return(guide)
}
You can then use your custom guide as the guide argument in a scale.
g <- ggplot(mtcars, aes(mpg, wt)) +
geom_point(aes(colour = drat))
g + scale_colour_viridis_c(
limits = c(3, 4), oob = scales::oob_squish,
guide = my_triangle_colourbar()
)
There isn't really a natural way to colour out-of-bounds values differently, but you can make very small slices near the extremes a different colour.
g + scale_colour_gradientn(
colours = c("red", scales::viridis_pal()(255), "hotpink"),
limits = c(3, 4), oob = scales::oob_squish,
guide = my_triangle_colourbar()
)
Created on 2021-07-19 by the reprex package (v1.0.0)
library(gg.layers)
library(ggplot2)
library(rcolors)
brk <- c(-Inf, -1, 0, 1, 3, 6, 9, Inf)
nbrk <- length(brk) - 1
cols <- get_color(rcolors$amwg256, nbrk)
g <- make_colorbar(
at = brk, col = cols, height = 1,
tck = 0.4,
space = "right",
legend.text.location = c(0.3, 0.5),
legend.text.just = c(0.5, 0.5),
# legend.text = list(fontfamily = "Times", cex = 1.1),
hjust = 0.05
)
p <- ggplot(mtcars, aes(mpg, disp)) + geom_point()
p + g
https://github.com/rpkgs/gg.layers
Triangles? No idea. Colors? You can set a gradient with custom values where your normal range is manually defined and your extremes are something else.
library(ggplot2)
# example taken from ?viridis::scale_colour_viridis, even if I don't use that function
dsub <- subset(diamonds, x > 5 & x < 6 & y > 5 & y < 6)
dsub$diff <- with(dsub, sqrt(abs(x-y))* sign(x-y))
d <- ggplot(dsub, aes(x, y, colour=diff)) + geom_point()
d +
scale_color_gradientn(
colours=c("red", "red", "blue", "green", "yellow", "red", "red"),
values = c(0, 0.1-1e-9, 0.1, 0.5, 0.9, 0.9+1e-9, 1),
breaks = c(-0.51, -.4, 0, .4, .62),
label = function(z) replace(z, c(1, length(z)), c("Min", "Max"))) +
theme_bw()
I doubled "red" on each end so that there would be no gradient transition with the neighboring colors. You can choose a different color for one end (while in this case it's clear if it's extreme-high or extreme-low).
I chose to manually control values= and labels= to include arbitrary points and labels for the extremes. This can be improved based on your preferences.
The disadvantage to this is that you have to define the viridis colors manually; should not be too difficult. I've hastily approximated it here, I'm confident you can choose better colors for the internal gradient portion.

How can I add triangles to a ggplot2 colorbar in R to indicate out of bound values?

I'd like to make a plot using ggplot2 where some of the fill values are clipped, i.e. values above or below the limits of the color scale are displayed as the minimum/maximum color. I can get this to work like this, using a combination of limit and oob (out of bounds):
library(ggplot2)
library(scales)
ggplot() + ... + scale_fill_viridis(na.value="white", limit=c(0, 10), oob=squish)
But there is no information in the colorbar that indicates there are values present outside of the limits.
How can I reproduce this matplotlib example in ggplot: https://stackoverflow.com/a/32072348
Specifically, how to get the triangles at the end of the colorbar?
As far as I'm aware there is not a package that implements triangle ends for colourbars in ggplot2 (but please let me know if there is!). However, we can implement our own. We'd need a constructor for our custom guide and a way to draw it. Most of the stuff is already implemented in guide_colourbar() and methods for their class, so what we need to do is just tag on our own class and expand the guide_gengrob method. The code below should work for vertically oriented colourbars. You'd need to know some stuff about the grid package and gtable package to follow along.
library(ggplot2)
library(gtable)
library(grid)
my_triangle_colourbar <- function(...) {
guide <- guide_colourbar(...)
class(guide) <- c("my_triangle_colourbar", class(guide))
guide
}
guide_gengrob.my_triangle_colourbar <- function(...) {
# First draw normal colourbar
guide <- NextMethod()
# Extract bar / colours
is_bar <- grep("^bar$", guide$layout$name)
bar <- guide$grobs[[is_bar]]
extremes <- c(bar$raster[1], bar$raster[length(bar$raster)])
# Extract size
width <- guide$widths[guide$layout$l[is_bar]]
height <- guide$heights[guide$layout$t[is_bar]]
short <- min(convertUnit(width, "cm", valueOnly = TRUE),
convertUnit(height, "cm", valueOnly = TRUE))
# Make space for triangles
guide <- gtable_add_rows(guide, unit(short, "cm"),
guide$layout$t[is_bar] - 1)
guide <- gtable_add_rows(guide, unit(short, "cm"),
guide$layout$t[is_bar])
# Draw triangles
top <- polygonGrob(
x = unit(c(0, 0.5, 1), "npc"),
y = unit(c(0, 1, 0), "npc"),
gp = gpar(fill = extremes[1], col = NA)
)
bottom <- polygonGrob(
x = unit(c(0, 0.5, 1), "npc"),
y = unit(c(1, 0, 1), "npc"),
gp = gpar(fill = extremes[2], col = NA)
)
# Add triangles to guide
guide <- gtable_add_grob(
guide, top,
t = guide$layout$t[is_bar] - 1,
l = guide$layout$l[is_bar]
)
guide <- gtable_add_grob(
guide, bottom,
t = guide$layout$t[is_bar] + 1,
l = guide$layout$l[is_bar]
)
return(guide)
}
You can then use your custom guide as the guide argument in a scale.
g <- ggplot(mtcars, aes(mpg, wt)) +
geom_point(aes(colour = drat))
g + scale_colour_viridis_c(
limits = c(3, 4), oob = scales::oob_squish,
guide = my_triangle_colourbar()
)
There isn't really a natural way to colour out-of-bounds values differently, but you can make very small slices near the extremes a different colour.
g + scale_colour_gradientn(
colours = c("red", scales::viridis_pal()(255), "hotpink"),
limits = c(3, 4), oob = scales::oob_squish,
guide = my_triangle_colourbar()
)
Created on 2021-07-19 by the reprex package (v1.0.0)
library(gg.layers)
library(ggplot2)
library(rcolors)
brk <- c(-Inf, -1, 0, 1, 3, 6, 9, Inf)
nbrk <- length(brk) - 1
cols <- get_color(rcolors$amwg256, nbrk)
g <- make_colorbar(
at = brk, col = cols, height = 1,
tck = 0.4,
space = "right",
legend.text.location = c(0.3, 0.5),
legend.text.just = c(0.5, 0.5),
# legend.text = list(fontfamily = "Times", cex = 1.1),
hjust = 0.05
)
p <- ggplot(mtcars, aes(mpg, disp)) + geom_point()
p + g
https://github.com/rpkgs/gg.layers
Triangles? No idea. Colors? You can set a gradient with custom values where your normal range is manually defined and your extremes are something else.
library(ggplot2)
# example taken from ?viridis::scale_colour_viridis, even if I don't use that function
dsub <- subset(diamonds, x > 5 & x < 6 & y > 5 & y < 6)
dsub$diff <- with(dsub, sqrt(abs(x-y))* sign(x-y))
d <- ggplot(dsub, aes(x, y, colour=diff)) + geom_point()
d +
scale_color_gradientn(
colours=c("red", "red", "blue", "green", "yellow", "red", "red"),
values = c(0, 0.1-1e-9, 0.1, 0.5, 0.9, 0.9+1e-9, 1),
breaks = c(-0.51, -.4, 0, .4, .62),
label = function(z) replace(z, c(1, length(z)), c("Min", "Max"))) +
theme_bw()
I doubled "red" on each end so that there would be no gradient transition with the neighboring colors. You can choose a different color for one end (while in this case it's clear if it's extreme-high or extreme-low).
I chose to manually control values= and labels= to include arbitrary points and labels for the extremes. This can be improved based on your preferences.
The disadvantage to this is that you have to define the viridis colors manually; should not be too difficult. I've hastily approximated it here, I'm confident you can choose better colors for the internal gradient portion.

How does The Economist make these lines near the title using using ggplot?

I really like the aesthetics of The Economist magazine and I use the theme_economist often. However, I am curious as to how they create the red lines in the top left in a lot of their charts. See image below and where I circled.
This question is a mix of "how to annotate outside the plot area" and "how to annotate in npc coordinates". Therefore, I offer two options.
Both unfortunately require a bit of trial and error in order to correctly place the segment. For option 1, it is the y coordinate which we have to "guess", and for option 2 it's x!
In order to make y slightly less guess work, I tried an approach to position is relative to the default axis breaks. using the fabulous information from this answer. This is of course not necessary, one can also simply trial and error.
For option 2, I modified a function from user Allan Cameron's answer here. He mentions a way to figure out x and y, I guess one could use the title, and then place the annotation based on that.
library(ggplot2)
p <-
ggplot(mtcars, aes(mpg, wt)) +
geom_point() +
ggtitle("lorem ipsum") +
theme(plot.margin = margin(t = 1.5, unit = "lines")) # this is always necessary
# OPTION 1
# semi-programmatic approach to figure out y coordinates
y_defaultticks <- with(mtcars, labeling::extended(range(wt)[1], range(wt)[2], m = 5))
y_default <- y_defaultticks[2] - y_defaultticks[1]
y_seg <- max(mtcars$wt) + 0.75 * y_default
p +
annotate(geom = "segment", x = - Inf, xend = 12, y = y_seg, yend = y_seg,
color = "red", size = 5) +
coord_cartesian(clip = "off", ylim = c(NA, max(mtcars$wt)),
xlim = c(min(mtcars$mpg), NA))
# OPTION 2
annotate_npc <- function(x, y, height, width, ...) {
grid::grid.draw(grid::rectGrob(
x = unit(x, "npc"), y = unit(y, "npc"), height = unit(height, "npc"), width = unit(width, "npc"),
gp = grid::gpar(...)
))
}
p
annotate_npc(x = 0.07, y = 1, height = 0.05, width = 0.05, fill = "red", col = NA)
Created on 2021-01-02 by the reprex package (v0.3.0)

Add axes to grid of ggplots

I have a grid composed of several ggplots and want to add an x axis, where axis ticks and annotations are added between the plots. I could not came up with a better solution than to create a custom plot for the axis and adding it below with arrangeGrob. But they do not align with the plots (I draw arrows where the numbers should be). Also there is a large white space below which I don't want.
I will also need an analogue for the y-axis.
library(ggplot2)
library(gridExtra)
library(ggpubr)
library(grid)
# Create a grid with several ggplots
p <-
ggplot(mtcars, aes(wt, mpg)) +
geom_point() +
theme_transparent() +
theme(plot.background = element_rect(color = "black"))
main.plot <- arrangeGrob(p, p, p, p, p, p, p, p, ncol = 4, nrow = 2)
# grid.draw(main.plot)
# Now add an x axis to the main plot
x.breaks <- c(0, 1, 2.5, 8, 10)
p.axis <- ggplot() +
ylim(-0.1, 0) +
xlim(1, length(x.breaks)) +
ggpubr::theme_transparent()
for (i in seq_along(x.breaks)) {
p.axis <- p.axis +
geom_text(aes_(x = i, y = -0.01, label = as.character(x.breaks[i])), color = "red")
}
# p.axis
final.plot <- arrangeGrob(main.plot, p.axis, nrow = 2)
grid.draw(final.plot)
Any help appreciated.
Note: In the code below, I assume each plot in your grid has equal width / height, & used equally spaced label positions. If that's not the case, you'll have to adjust the positions yourself.
Adding x-axis to main.plot:
library(gtable)
# create additional row below main plot
# height may vary, depending on your actual plot dimensions
main.plot.x <- gtable_add_rows(main.plot, heights = unit(20, "points"))
# optional: check results to verify position of the new row
dev.off(); gtable_show_layout(main.plot.x)
# create x-axis labels as a text grob
x.axis.grob <- textGrob(label = x.breaks,
x = unit(seq(0, 1, length.out = length(x.breaks)), "npc"),
y = unit(0.75, "npc"),
just = "top")
# insert text grob
main.plot.x <- gtable_add_grob(main.plot.x,
x.axis.grob,
t = nrow(main.plot.x),
l = 1,
r = ncol(main.plot.x),
clip = "off")
# check results
dev.off(); grid.draw(main.plot.x)
You can do the same for the y-axis:
# create additional col
main.plot.xy <- gtable_add_cols(main.plot.x, widths = unit(20, "points"), pos = 0)
# create y-axis labels as a text grob
y.breaks <- c("a", "b", "c") # placeholder, since this wasn't specified in the question
y.axis.grob <- textGrob(label = y.breaks,
x = unit(0.75, "npc"),
y = unit(seq(0, 1, length.out = length(y.breaks)), "npc"),
just = "right")
# add text grob into main plot's gtable
main.plot.xy <- gtable_add_grob(main.plot.xy,
y.axis.grob,
t = 1,
l = 1,
b = nrow(main.plot.xy) - 1,
clip = "off")
# check results
dev.off(); grid.draw(main.plot.xy)
(Note that the above order of x-axis followed by y-axis should not be switched blindly. If you are adding rows / columns, it's good habit to use gtable_show_layout() frequently to check the latest gtable object dimensions, & ensure that you are inserting new grobs into the right cells.)
Finally, let's add some buffer on all sides, so that the labels & plot borders don't get cut off:
final.plot <- gtable_add_padding(main.plot.xy,
padding = unit(20, "points"))
dev.off(); grid.draw(final.plot)

How to create base R plot 'type = b' equivalent in ggplot2?

Base plot() functionality allows one to set type='b' and get a combined line and point plot in which the points are offset from the line segments
plot(pressure, type = 'b', pch = 19)
I can easily create a ggplot with lines and points as follows.
ggplot(pressure, aes(temperature, pressure)) +
geom_line() +
geom_point()
The lines, however, run right up to the points. I can envision a way that I might hack together something like type='b' functionality using other geoms (e.g. geom_segment()?), but I am wondering if there is a more direct way to accomplish this with geom_line() and geom_point().
A slightly hacky way of doing this is to overplot a small black point on a larger white point:
ggplot(pressure, aes(temperature, pressure)) +
geom_line() +
geom_point(size=5, colour="white") +
geom_point(size=2) +
theme_classic() +
theme(panel.background = element_rect(colour = "black"))
In addition, following Control point border thickness in ggplot, in version 2.0.0 of ggplot2 it's possible to use the stroke argument of geom_point to control the border thickness, so the two geom_points can be replaced by just (e.g.) geom_point(size=2, shape=21, fill="black", colour="white", stroke=3), eliminating the need to overlay the points.
One option which is less hacky than manually matching the stroke color with the panel background is to get the panel background beforehand, either from theme_get for the default theme, or with a specific theme that you'll be using. Using a stroked shape like 21 lets you make the inner circle black and the stroke the same color as the background.
library(ggplot2)
bgnd <- theme_get()$panel.background$fill
ggplot(pressure, aes(x = temperature, y = pressure)) +
geom_line() +
geom_point(shape = 21, fill = "black", size = 2, stroke = 1, color = bgnd)
A couple SO questions (here's one) deal with the math behind shortening segments between points. It's simple but tedious geometry. But in the time since this question was first posted, the lemon package has come out, which has a geom to do this. It's got arguments for how to calculate the shortening, which probably require just some simple tweaking.
library(lemon)
ggplot(pressure, aes(x = temperature, y = pressure)) +
geom_pointline()
Ok I have an implementation of a geom, that does not rely on hardcoding and should not have wierd offsets. It's essentialy a geom_point() implementation, that draws a path* between points, draws a larger background point with colours set to the panel background and then the normal points.
*note that path's behaviour is not to connect points along the x-axis, but along row-order in the data.frame that is given to ggplot. You can sort your data beforehand if you want geom_line() behaviour.
The main problem for me was to get the inner workings of the geom drawing code to retrieve the theme of the current plot to extract the background colour of the panel. Due to this, I'm very unsure how stable this would be (and would welcome any tips), but at least it works.
EDIT: should be more stable now
Let's get to the, admittedly lengthy, ggproto object code:
GeomPointPath <- ggproto(
"GeomPointPath", GeomPoint,
draw_panel = function(self, data, panel_params, coord, na.rm = FALSE)
{
# bgcol <- sys.frame(4)$theme$panel.background$fill
# if (is.null(bgcol)) {
# bgcol <- theme_get()$panel.background$fill
# }
# EDIT: More robust bgcol finding -----------
# Find theme, approach as in https://github.com/tidyverse/ggplot2/issues/3116
theme <- NULL
for(i in 1:20) {
env <- parent.frame(i)
if("theme" %in% names(env)) {
theme <- env$theme
break
}
}
if (is.null(theme)) {
theme <- theme_get()
}
# Lookup likely background fills
bgcol <- theme$panel.background$fill
if (is.null(bgcol)) {
bgcol <- theme$plot.background$fill
}
if (is.null(bgcol)) {
bgcol <- theme$rect$fill
}
if (is.null(bgcol)) {
# Default to white if no fill can be found
bgcol <- "white"
}
# END EDIT ------------------
if (is.character(data$shape)) {
data$shape <- ggplot2:::translate_shape_string(data$shape)
}
coords <- coord$transform(data, panel_params)
# Draw background points
bgpoints <- grid::pointsGrob(
coords$x, coords$y, pch = coords$shape,
gp = grid::gpar(
col = alpha(bgcol, NA),
fill = alpha(bgcol, NA),
fontsize = (coords$size * .pt + coords$stroke * .stroke/2) * coords$mult,
lwd = coords$stroke * .stroke/2
)
)
# Draw actual points
mypoints <- grid::pointsGrob(
coords$x, coords$y, pch = coords$shape,
gp = grid::gpar(
col = alpha(coords$colour, coords$alpha),
fill = alpha(coords$fill, coords$alpha),
fontsize = coords$size * .pt + coords$stroke * .stroke/2,
lwd = coords$stroke * .stroke/2
)
)
# Draw line
myline <- grid::polylineGrob(
coords$x, coords$y,
id = match(coords$group, unique(coords$group)),
default.units = "native",
gp = grid::gpar(
col = alpha(coords$colour, coords$alpha),
fill = alpha(coords$colour, coords$alpha),
lwd = (coords$linesize * .pt),
lty = coords$linetype,
lineend = "butt",
linejoin = "round", linemitre = 10
)
)
# Place graphical objects in a tree
ggplot2:::ggname(
"geom_pointpath",
grid::grobTree(myline, bgpoints, mypoints)
)
},
# Set some defaults, assures that aesthetic mappings can be made
default_aes = aes(
shape = 19, colour = "black", size = 1.5, fill = NA, alpha = NA, stroke = 0.5,
linesize = 0.5, linetype = 1, mult = 3,
)
)
Observant people may have noticed the line bgcol <- sys.frame(4)$theme$panel.background$fill. I could not find another way to access the current plot's theme, without having to adjust at least several other functions to pass the theme as an argument. In my version of ggplot (3.1.0), the 4th sys.frame() is the environment of the ggplot2:::ggplot_gtable.ggplot_built call wherein the geom drawing code is evaluated. It's quite easy to imagine that this function can be updated in the future -which can change the scoping- hence the stability warning. As a backup, it defaults to the global theme settings when it can't find the current theme.
EDIT: should now be more stable
Onwards to the layer wrapper which is pretty much self-explanatory:
geom_pointpath <- 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 = GeomPointPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...))
}
Adding it to a ggplot should be a familiar thing. Just setting the theme to the default theme_gray() to test that it indeed takes the current plot's theme.
theme_set(theme_gray())
g <- ggplot(pressure, aes(temperature, pressure)) +
geom_pointpath() +
theme(panel.background = element_rect(fill = "dodgerblue"))
Of course, this method will obscure grid lines with the background points, but that is the tradeoff I was willing to make to prevent wonkyness due to line path shortening. Line sizes, line types, and the relative size of the background points can be set with aes(linesize = ..., linetype = ..., mult = ...) or per the ... argument in geom_pointpath(). It inherits the other aesthetics from GeomPoint.
I'm sorry for answering twice, but this seems sufficiently different to merit a different answer.
I've given this question some more thought and I'll concede that a geometric approach is indeed the better approach over the point-over-point approach. However, the geometric approach comes with its own set of problems, namely that any attempt at pre-computing coordinates before draw-time is going to give you some skew in one way or another (see a follow up question from #Tjebo).
It is next to impossible to know the aspect ratio or exact sizes of the plot a priori, except by setting an aspect ratio manually or using the space argument of facet_grid(). Because this is impossible, any precomputed set of coordinates is going to be inadequate if the plot is resized.
I've shamelessly stolen some good ideas from other people, so thanks to #Tjebo and #moody_mudskipper for the maths and credit to ggplot guru thomasp85 and the ggforce package for the calculating at drawtime inspiration.
On with it; first we'll define our ggproto as before, now making a custom grob class for our path. An important detail is that we convert our xy coordinates to formal units.
GeomPointPath <- ggproto(
"GeomPointPath", GeomPoint,
draw_panel = function(data, panel_params, coord, na.rm = FALSE){
# Default geom point behaviour
if (is.character(data$shape)) {
data$shape <- translate_shape_string(data$shape)
}
coords <- coord$transform(data, panel_params)
my_points <- pointsGrob(
coords$x,
coords$y,
pch = coords$shape,
gp = gpar(col = alpha(coords$colour, coords$alpha),
fill = alpha(coords$fill, coords$alpha),
fontsize = coords$size * .pt + coords$stroke * .stroke/2,
lwd = coords$stroke * .stroke/2))
# New behaviour
## Convert x and y to units
x <- unit(coords$x, "npc")
y <- unit(coords$y, "npc")
## Make custom grob class
my_path <- grob(
x = x,
y = y,
mult = (coords$size * .pt + coords$stroke * .stroke/2) * coords$mult,
name = "pointpath",
gp = grid::gpar(
col = alpha(coords$colour, coords$alpha),
fill = alpha(coords$colour, coords$alpha),
lwd = (coords$linesize * .pt),
lty = coords$linetype,
lineend = "butt",
linejoin = "round", linemitre = 10
),
vp = NULL,
### Now this is the important bit:
cl = 'pointpath'
)
## Combine grobs
ggplot2:::ggname(
"geom_pointpath",
grid::grobTree(my_path, my_points)
)
},
# Adding some defaults for lines and mult
default_aes = aes(
shape = 19, colour = "black", size = 1.5, fill = NA, alpha = NA, stroke = 0.5,
linesize = 0.5, linetype = 1, mult = 0.5,
)
)
Through the magic of object oriented programming, we can now write a new method for our new grob class. While that may be uninteresting in and of itself, it gets particularly interesting if we write this method for makeContent, which is called every time a grob is drawn. So, let's write a method that invokes the mathematical operations on the exact coordinates the graphics device is going to use:
# Make hook for drawing
makeContent.pointpath <- function(x){
# Convert npcs to absolute units
x_new <- convertX(x$x, "mm", TRUE)
y_new <- convertY(x$y, "mm", TRUE)
# Do trigonometry stuff
hyp <- sqrt(diff(x_new)^2 + diff(y_new)^2)
sin_plot <- diff(y_new) / hyp
cos_plot <- diff(x_new) / hyp
diff_x0_seg <- head(x$mult, -1) * cos_plot
diff_x1_seg <- (hyp - head(x$mult, -1)) * cos_plot
diff_y0_seg <- head(x$mult, -1) * sin_plot
diff_y1_seg <- (hyp - head(x$mult, -1)) * sin_plot
x0 = head(x_new, -1) + diff_x0_seg
x1 = head(x_new, -1) + diff_x1_seg
y0 = head(y_new, -1) + diff_y0_seg
y1 = head(y_new, -1) + diff_y1_seg
keep <- unclass(x0) < unclass(x1)
# Remove old xy coordinates
x$x <- NULL
x$y <- NULL
# Supply new xy coordinates
x$x0 <- unit(x0, "mm")[keep]
x$x1 <- unit(x1, "mm")[keep]
x$y0 <- unit(y0, "mm")[keep]
x$y1 <- unit(y1, "mm")[keep]
# Set to segments class
class(x)[1] <- 'segments'
x
}
Now all we need is a layer wrapper like before, which does nothing special:
geom_pointpath <- 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 = GeomPointPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...))
}
The demonstration:
g <- ggplot(pressure, aes(temperature, pressure)) +
# Ribbon for showing no point-over-point background artefacts
geom_ribbon(aes(ymin = pressure - 50, ymax = pressure + 50), alpha = 0.2) +
geom_pointpath()
And this should be stable for any resized aspect ratio. You can supply aes(mult = ...) or just mult = ... to control the size of the gaps between segments. By default it is proportional to the point sizes, so varying the point size while keeping the gap contant is a challenge. Segments that are shorter than two times the gap are deleted.
This is now possible with the CRAN package {ggh4x}. Funny fact, the geom for this package saw the light of the day on this SO post :) Thanks teunbrand!
library(ggh4x)
#> Loading required package: ggplot2
ggplot(pressure, aes(temperature, pressure)) +
geom_pointpath()
Created on 2021-11-13 by the reprex package (v2.0.1)

Resources