Fontsize error when creating new Geom in ggplot2 - r

I am trying to create a new geom that will create a wind radii chart from hurricane data.
The data needed to run this came be generated from the following:
storm_observation <- data_frame(longitude = c(-89.6, -89.6, -89.6),
latitude = c(29.5, 29.5, 29.5),
wind_speed = c("34", "50", "64"),
ne = c(200, 120, 90),
nw = c(100, 75, 60),
se = c(200, 120, 90),
sw = c(150, 75, 60))
My code to create the new Geom is included below, but is throwing a strange error related to fontsize:
Error in check.length(gparname) : 'gpar' element 'fontsize' must not be length 0
I have attempted to include fontsize in the default_aes and gpar() functions, but it still resulted in the same error. Any help would be appreciated. NOTE: This requires tidyr, dplyr and geosphere packages.
GeomHurricane <- ggproto("GeomPolygon", Geom,
required_aes = c("x", "y", "r_ne", "r_se", "r_nw", "r_sw",
"fill", "colour"),
default_aes = aes(scale_radii = 0.8, alpha = 0.8, linetype = 1, size = 0.5),
draw_group = function(data, panel_scales, coord) {
## Create function for conditional mutation
mutate_cond <- function(.data, condition, ..., envir = parent.frame()) {
condition <- eval(substitute(condition), .data, envir)
.data[condition, ] <- .data[condition, ] %>% mutate(...)
.data
}
## Create df of bearings for later joining
bearingDF <- tibble::data_frame(bearing = c(360,1:90,90:180,180:270,270:360),
direction = rep(c("r_ne", "r_se", "r_sw", "r_nw"),
each = 91)) %>%
dplyr::bind_rows(tibble::data_frame(bearing = rep(0, 4),
direction = c("r_ne", "r_se", "r_sw", "r_nw")))
## Transform data in tidy format and combine with bearings
data <- data %>%
dplyr::select(x, y, r_ne, r_nw, r_se, r_sw, colour, fill,
PANEL, group, scale_radii, alpha, linetype,
size) %>%
tidyr::gather(direction, distance, -x, -y, -colour, -fill,
-PANEL, -group, -scale_radii, -alpha, -linetype,
-size) %>%
dplyr::mutate(distance = distance * 1852 * scale_radii) %>%
dplyr::left_join(bearingDF, by = "direction") %>%
mutate_cond(bearing == 0, distance = 0)
## Generate correct lat/lon for perimeter of polygons
data <- data %>%
dplyr::bind_cols(as.data.frame(geosphere::destPoint(as.matrix(data[,1:2]),
data$bearing,
data$distance))) %>%
dplyr::select(-x, -y) %>%
dplyr::rename(x = lon, y = lat)
## Coord transform and take first row
coords <- coord$transform(data, panel_scales)
first_row <- coords[1, , drop = FALSE]
grid::polygonGrob(
coords$x, coords$y,
default.units = "native",
gp = grid::gpar(
col = first_row$colour,
fill = scales::alpha(first_row$fill, first_row$alpha),
lwd = first_row$size * .pt,
lty = first_row$linetype
)
)
})
geom_hurricane <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity",
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) {
layer(geom = GeomHurricane, mapping = mapping, data = data, stat = stat,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...))}
Here is the code to create the map using the new geom:
get_map("Louisiana", zoom = 6, maptype = "toner-background", source = "stamen") %>%
ggmap(extent = "device") +
geom_hurricane(data = storm_observation,
aes(x = longitude, y = latitude,
r_ne = ne, r_se = se, r_nw = nw, r_sw = sw,
fill = wind_speed, color = wind_speed)) +
scale_color_manual(name = "Wind speed (kts)",
values = c("red", "orange", "yellow")) +
scale_fill_manual(name = "Wind speed (kts)",
values = c("red", "orange", "yellow"))

I figured it out. Had somehow forgotten to include draw_key = draw_key_polygon, once I added that back into the ggproto function everything worked.
Thanks!

Related

custom `geom_` with two different styles for plotting

My goal is to write a custom geom_ method that calculates and plots, e.g., confidence intervals and these should be plotted either as polygons or as lines. The question now is, where to check which "style" should be plotted?
So far I have tried out three different approaches,
(i) write two different geom_/stat_ for line and polygon style plots,
(ii) write a single geom_/stat_ which uses a custom GeomMethod,
(iii) write a single geom_/stat_ which uses either GeomPolygon or GeomLine.
In my opinion, to sum up
(i) is more or less straightforward but only bypasses the problem,
(ii) works when you use either GeomPath$draw_panel() or GeomPolygon$draw_panel() depending on an extra parameter style. But here I can't work it out to set default_aes depending also on the extra argument style. Compare also the answer here.
(iii) works when calling geom_ but fails for calling stat_ as the name matching within ggplot2 fails. See minimal example below.
Setting up the methods of approach (iii):
geom_my_confint <- function(mapping = NULL, data = NULL, stat = "my_confint",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,
style = c("polygon", "line"), ...) {
style <- match.arg(style)
ggplot2::layer(
geom = if (style == "line") GeomPath else GeomPolygon,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
style = style,
...
)
)
}
stat_my_confint <- function(mapping = NULL, data = NULL, geom = "my_confint",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,
style = c("polygon", "line"), ...) {
style <- match.arg(style)
ggplot2::layer(
geom = geom,
stat = StatMyConfint,
data = data,
mapping = mapping,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
style = style,
...
)
)
}
StatMyConfint <- ggplot2::ggproto("StatMyConfint", ggplot2::Stat,
compute_group = function(data, scales, style) {
if (style == "polygon") {
nd <- data.frame(
x = c(data$x, rev(data$x)),
y = c(data$y - 1, rev(data$y) + 1)
)
nd
} else {
nd <- data.frame(
x = rep(data$x, 2),
y = c(data$y - 1, data$y + 1),
group = c(rep(1, 5), rep(2, 5))
)
nd
}
},
required_aes = c("x", "y")
)
Trying out the methods of approach (iii):
library("ggplot2")
d <- data.frame(
x = seq(1, 5),
y = seq(1, 5)
)
ggplot(d, aes(x = x, y = y)) + geom_line() + geom_my_confint(style = "polygon", alpha = 0.2)
ggplot(d, aes(x = x, y = y)) + geom_line() + geom_my_confint(style = "line", linetype = 2)
This works well so far. However when calling the stat_ there is an error in ggplot2:::check_subclass because there is no GeomMyConfint method.
ggplot(d, aes(x = x, y = y)) + geom_line() + stat_my_confint()
# Error: Can't find `geom` called 'my_confint'
Any solutions or suggestions for alternative approaches?
The following isn't very elegant but seems to work. Let's define the following constructor, wherein the geom is set to GeomMyConfint, which we'll define further down.
geom_my_confint <- function(mapping = NULL, data = NULL, stat = "my_confint",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,
style = c("polygon", "line"), ...) {
style <- match.arg(style)
ggplot2::layer(
geom = GeomMyConfint,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
style = style,
...
)
)
}
Below is the paired ggproto class. I've amended the use_defaults method to replace a defaulted colour by some text. Then later, the draw_panel() method chooses the actual default to replace the text we've inserted earlier, depending on the style argument.
GeomMyConfint <- ggproto(
"GeomMyConfint", GeomPolygon,
# Tag colour if it has been defaulted
use_defaults = function(self, data, params = list(), modifiers = aes()) {
has_colour <- "colour" %in% names(data) || "colour" %in% names(params)
data <- ggproto_parent(GeomPolygon, self)$use_defaults(
data, params, modifiers
)
if (!has_colour) {
data$colour <- "default_colour"
}
data
},
# Resolve colour defaults here
draw_panel = function(
data, panel_params, coord,
# Polygon arguments
rule = "evenodd",
# Line arguments
lineend = "butt", linejoin = "round", linemitre = 10,
na.rm = FALSE, arrow = NULL,
# Switch argument
style = "polygon")
{
if (style == "polygon") {
data$colour[data$colour == "default_colour"] <- NA
GeomPolygon$draw_panel(data, panel_params, coord, rule)
} else {
data$colour[data$colour == "default_colour"] <- "black"
GeomPath$draw_panel(data, panel_params, coord,
arrow, lineend, linejoin, linemitre, na.rm)
}
}
)
Then then works with the rest of the functions from your example.
A more elegant method might be to use the vctrs package to define a custom S3 class for defaulted values that is easy to recognise, but I haven't seen people trying to use aes(colour = I("default_colour")) before, so you're probably safe aside from this one single edge case.
Based on #teunbrand's answer and how geom_sf() is implemented, I came up with the following solution supporting approach (ii):
geom_my_confint <- function(mapping = NULL, data = NULL, stat = "my_confint",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,
type = c("polygon", "line"), ...) {
type <- match.arg(type)
ggplot2::layer(
geom = GeomMyConfint,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
type = type,
...
)
)
}
GeomMyConfint <- ggplot2::ggproto("GeomMyConfint", ggplot2::Geom,
## Setting up all defaults needed for `GeomPolygon` and `GeomPath`
default_aes = ggplot2::aes(
colour = NA,
fill = NA,
size = NA,
linetype = NA,
alpha = NA,
subgroup = NULL
),
draw_panel = function(data, panel_params, coord,
rule = "evenodd", # polygon arguments
lineend = "butt", linejoin = "round", # line arguments
linemitre = 10, na.rm = FALSE, arrow = NULL, # line arguments
type = c("polygon", "line")) {
type <- match.arg(type)
## Swap NAs in `default_aes` with own defaults
data <- my_modify_list(data, my_default_aesthetics(type), force = FALSE)
if (type == "polygon") {
GeomPolygon$draw_panel(data, panel_params, coord, rule)
} else {
GeomPath$draw_panel(data, panel_params, coord,
arrow, lineend, linejoin, linemitre, na.rm)
}
},
draw_key = function(data, params, size) {
## Swap NAs in `default_aes` with own defaults
data <- my_modify_list(data, my_default_aesthetics(params$type), force = FALSE)
if (params$type == "polygon") {
draw_key_polygon(data, params, size)
} else {
draw_key_path(data, params, size)
}
}
)
## Helper function inspired by internal from `ggplot2` defined in `performance.R`
my_modify_list <- function(old, new, force = FALSE) {
if (force) {
for (i in names(new)) old[[i]] <- new[[i]]
} else {
for (i in names(new)) old[[i]] <- if (all(is.na(old[[i]]))) new[[i]] else old[[i]]
}
old
}
## Helper function inspired by internal from `ggplot2` defined in `geom-sf.R`
my_default_aesthetics <- function(type) {
if (type == "line") {
my_modify_list(GeomPath$default_aes, list(colour = "red", linetype = 2), force = TRUE)
} else {
my_modify_list(GeomPolygon$default_aes, list(fill = "red", alpha = 0.2), force = TRUE)
}
}
I've kept the stat_my_confint() and StatMyConfint() from above unchanged (only the argument style is now called type according to the naming w/i geom_sf()):
stat_my_confint <- function(mapping = NULL, data = NULL, geom = "my_confint",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,
type = c("polygon", "line"), ...) {
type <- match.arg(type)
ggplot2::layer(
geom = geom,
stat = StatMyConfint,
data = data,
mapping = mapping,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
type = type,
...
)
)
}
StatMyConfint <- ggplot2::ggproto("StatMyConfint", ggplot2::Stat,
compute_group = function(data, scales, type) {
if (type == "polygon") {
nd <- data.frame(
x = c(data$x, rev(data$x)),
y = c(data$y - 1, rev(data$y) + 1)
)
nd
} else {
nd <- data.frame(
x = rep(data$x, 2),
y = c(data$y - 1, data$y + 1),
group = c(rep(1, 5), rep(2, 5))
)
nd
}
},
required_aes = c("x", "y")
)
Now the examples from above work fine:
library("ggplot2")
d1 <- data.frame(
x = seq(1, 5),
y = seq(1, 5)
)
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint()
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint(type = "line")
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint(type = "polygon", alpha = 0.8)
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint(type = "line", linetype = 4, colour = "red")
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint()
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint(type = "line")
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint(type = "polygon", alpha = 0.8)
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint(type = "line", linetype = 4, colour = "red")
However, the solution still fails if you want additionally, e.g., set the fill colour of the polygon by an external grouping variable:
d2 <- data.frame(
x = rep(seq(1, 5), 2),
y = rep(seq(1, 5), 2),
z = factor(c(rep(1, 5), rep(2, 5)))
)
ggplot(d2, aes(x = x, y = y)) + geom_line() + geom_my_confint() + facet_wrap(.~z)
# no error
ggplot(d2, aes(x = x, y = y, fill = z)) + geom_line() + geom_my_confint() + facet_wrap(.~z)
# Error in grid.Call.graphics(C_setviewport, vp, TRUE) :
# non-finite location and/or size for viewport
So still no perfect answer. Help/extensions appreciated!
EDIT:
The error no longer occurs if the size argument is set to 0.5 within GeomMyConfint$default_aes():
Not clear to me why - anyone?!
Here, this works as I don't change the default size for GeomPolygon or GeomPath, but would be problematic otherwise.
I do not find any more errors (for now).
The adapted code:
GeomMyConfint <- ggplot2::ggproto("GeomMyConfint", ggplot2::Geom,
## Setting up all defaults needed for `GeomPolygon` and `GeomPath`
default_aes = ggplot2::aes(
colour = NA,
fill = NA,
size = 0.5,
linetype = NA,
alpha = NA,
subgroup = NULL
),
draw_panel = function(data, panel_params, coord,
rule = "evenodd", # polygon arguments
lineend = "butt", linejoin = "round", # line arguments
linemitre = 10, na.rm = FALSE, arrow = NULL, # line arguments
type = c("polygon", "line")) {
type <- match.arg(type)
## Swap NAs in `default_aes` with own defaults
data <- my_modify_list(data, my_default_aesthetics(type), force = FALSE)
if (type == "polygon") {
GeomPolygon$draw_panel(data, panel_params, coord, rule)
} else {
GeomPath$draw_panel(data, panel_params, coord,
arrow, lineend, linejoin, linemitre, na.rm)
}
},
draw_key = function(data, params, size) {
## Swap NAs in `default_aes` with own defaults
data <- my_modify_list(data, my_default_aesthetics(params$type), force = FALSE)
if (params$type == "polygon") {
draw_key_polygon(data, params, size)
} else {
draw_key_path(data, params, size)
}
}
)
The plot:
ggplot(d2, aes(x = x, y = y, fill = z)) + geom_line() + geom_my_confint() + facet_wrap(.~z)

How to tell ggplot2 to use an user created scale for a new aesthetic.

I'm writing a package that extends ggplot2. One of those extensions is a geom_arrow() that takes aesthetics mag and angle to plot vector fields by magnitude and direction. I also created a scale_mag() to manipulate the length of the arrows with the prospect of creating also a new guide. Right now both geom and scale work as expected when added together.
ggplot(geo, aes(lon, lat)) +
geom_arrow(aes(mag = mag, angle = angle)) +
scale_mag()
But if I don't add scale_mag(), it doesn't work at all. What I want is for this scale to work like scale_color(), which is added by default when the color aesthetic is present.
Here is the code as it is right now:
geom_arrow <- function(mapping = NULL, data = NULL,
stat = "arrow",
position = "identity", ...,
start = 0,
direction = 1,
# scale = 1,
min.mag = 0,
skip = 0,
skip.x = skip,
skip.y = skip,
arrow.angle = 15,
arrow.length = 0.5,
arrow.ends = "last",
arrow.type = "closed",
arrow = grid::arrow(arrow.angle, unit(arrow.length, "lines"),
ends = arrow.ends, type = arrow.type),
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(geom = GeomArrow,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
start = start,
direction = direction,
arrow = arrow,
lineend = lineend,
na.rm = na.rm,
# scale = scale,
skip.x = skip.x,
skip.y = skip.y,
min.mag = min.mag,
...)
)
}
GeomArrow <- ggplot2::ggproto("GeomArrow", Geom,
required_aes = c("x", "y"),
default_aes = ggplot2::aes(color = "black", size = 0.5, min.mag = 0,
linetype = 1, alpha = NA),
draw_key = ggplot2::draw_key_path,
draw_panel = function(data, panel_scales, coord,
arrow = arrow, lineend = lineend,
start = start, direction = direction,
preserve.dir = TRUE) {
coords <- coord$transform(data, panel_scales)
unit.delta <- "snpc"
if (preserve.dir == FALSE) {
coords$angle <- with(coords, atan2(yend - y, xend - x)*180/pi)
unit.delta <- "npc"
}
coords$dx <- with(coords, mag*cos(angle*pi/180))
coords$dy <- with(coords, mag*sin(angle*pi/180))
# from https://stackoverflow.com/questions/47814998/how-to-make-segments-that-preserve-angles-in-different-aspect-ratios-in-ggplot2
xx <- grid::unit.c(grid::unit(coords$x, "npc"),
grid::unit(coords$x, "npc") + grid::unit(coords$dx, unit.delta))
yy <- grid::unit.c(grid::unit(coords$y, "npc"),
grid::unit(coords$y, "npc") + grid::unit(coords$dy, unit.delta))
mag <- with(coords, mag/max(mag, na.rm = T))
arrow$length <- unit(as.numeric(arrow$length)*mag, attr(arrow$length, "unit"))
pol <- grid::polylineGrob(x = xx, y = yy,
default.units = "npc",
arrow = arrow,
gp = grid::gpar(col = coords$colour,
fill = scales::alpha(coords$colour, coords$alpha),
alpha = ifelse(is.na(coords$alpha), 1, coords$alpha),
lwd = coords$size*.pt,
lty = coords$linetype,
lineend = lineend),
id = rep(seq(nrow(coords)), 2))
pol
})
StatArrow <- ggplot2::ggproto("StatArrow", ggplot2::Stat,
required_aes = c("x", "y"),
default_aes = ggplot2::aes(min.mag = 0, dx = NULL, dy = NULL,
mag = NULL, angle = NULL),
compute_group = function(data, scales,
skip.x = skip.x, skip.y = skip.y,
min.mag = min.mag) {
min.mag <- data$min.mag %||% min.mag
if (is.null(data$mag) | is.null(data$angle)) {
if (is.null(data$dx) | is.null(data$dy)) stop("stat_arrow need dx, dy or mag angle (improve mesage!!)")
data$mag <- with(data, Mag(dx, dy))
data$angle <- with(data, atan2(dy, dx)*180/pi)
} else {
data$dx <- with(data, mag*cos(angle*pi/180))
data$dy <- with(data, mag*sin(angle*pi/180))
}
data <- subset(data, x %in% JumpBy(unique(x), skip.x + 1) &
y %in% JumpBy(unique(y), skip.y + 1) &
mag >= min.mag)
data$xend = with(data, x + dx)
data$yend = with(data, y + dy)
data
}
)
scale_mag <- function(length = 0.1,
max = waiver(),
default_unit = "lines") {
# if (!is.unit(length)) length <- ggplot2::unit(length, default_unit)
continuous_scale("mag",
"mag",
identity,
rescaler = rescale_mag(length, max),
guide = "none")
}
# scale_type.mag <- function(x) "vector"
rescale_mag <- function(length, max) {
function(x, from) {
if (is.waive(max)) max <- max(x, na.rm = T)
scales::rescale(x, c(0, length), c(0, max))
}
}
Finally, I find the answer!
Based on the code in ggplot2/R/scale-type.R, there should be a scale named scale_mag_continuous in the parent environment of find_scale function. Then, this scale can be find automatically.
geo <- tibble(lon = 1:10, lat = 1:10, mag = 1:10, angle = 1:10)
scale_mag_continuous <- scale_mag
ggplot(geo, aes(lon, lat)) +
geom_arrow(aes(mag = mag, angle = angle))
I added a default theme to ggplot for a work package by overloading the ggplot function, basically like this:
ggplot <- function(...) {ggplot2::ggplot(...) + your_added_thing()}
If you want it to be less obtrusive, rename your version of ggplot:
jjplot <- function (...) {ggplot2::ggplot(...) + my_added_thing()}
this page will be helpful for you.
https://gist.github.com/wch/3250485
especially, the code below:
#This tells ggplot2 what scale to look for, for yearmon
scale_type.yearmon <- function(x) "yearmon"

Generating multiple geom_smooth lines of data samples

Attempting to build a new geom function here that will take a sample of points from a dataset by group, and fit a number of local regressions through the individual subsets. This would generate multiple local regression lines as samples of a full dataset. In the end generating something akin to this:
Though I'm continuing to get errors with the function I've built below (with reprex). Any assistance is appreciated. Thank you!
library(ggplot2)
library(dplyr)
geom_mline <- function(mapping = NULL, data = NULL, stat = "mline",
position = "identity", show.legend = NA,
inherit.aes = TRUE, na.rm = TRUE,
SPAN = .9, N_size = 50, N_LOESS = 50, ...) {
layer(
geom = geomMline,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(SPAN=SPAN,
N_size=N_size,
N_LOESS=N_LOESS,
...)
)
}
geomMline <- ggproto("geomMline", GeomLine,
required_aes = c("x", "y"),
default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA)
)
stat_mline <- function(mapping = NULL, data = NULL, geom = "line",
position = "identity", show.legend = NA, inherit.aes = TRUE,
SPAN = .9, N_size = 50, N_LOESS = 50, ...) {
layer(
stat = StatMline,
data = data,
mapping = mapping,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(SPAN=SPAN,
N_size=N_size,
N_LOESS=N_LOESS,
...
)
)
}
StatMline <- ggproto("StatMline", Stat,
required_aes = c("x", "y"),
compute_group = function(self, data, scales, params,
SPAN = .9, N_size = 50, N_LOESS = 50) {
tf <- tempfile(fileext=".png")
png(tf)
plot.new()
colnames(data) <- c("x", "variable", "y")
LOESS_DF <- data.frame(y = seq(min(data$x),
max(data$x),
length.out = 50))
for(i in 1:N_LOESS){
# sample N_size points
df_sample <- sample_n(data, N_size)
# fit a loess
xx <- df_sample$x
yy <- df_sample$y
tp_est <- loess(yy ~ xx , span = SPAN)
# predict accross range of x using loess model
loess_vec <- data.frame(
predict(tp_est, newdata =
data.frame(xx = seq(min(data$x), max(data$x), length.out = 500))))
colnames(loess_vec) <- as.character(i)
# repeat x times
LOESS_DF <- cbind(LOESS_DF,loess_vec)
#str(LOESS_DF)
}
invisible(dev.off())
unlink(tf)
data.frame(reshape2::melt(LOESS_DF, id = "y"))
}
)
# dummy data
library(reshape2)
x <- seq(1,1000,1)
y1 <- rnorm(n = 1000,mean = x*2^1.1, sd = 200)
y2 <- rnorm(n = 1000,mean = x*1, sd = 287.3)
y3 <- rnorm(n = 1000,mean = x*1.1, sd = 100.1)
data <- data.frame(x , y1, y2, y3)
data <- melt(data, id.vars = "x")
str(data)
ggplot(data,aes(x,value,group = variable, color = va
riable))+geom_point()
ggplot(data = data, aes(x = x, y = value, group=variable, color = variable)) +
#geom_point(color="black") +
#geom_smooth(se=FALSE, linetype="dashed", size=0.5) +
#stat_mline(SPAN = .2, N_size = 50, N_LOESS = 5)
geom_mline(SPAN = .2, N_size = 50, N_LOESS = 5)
#data <- subset(data, variable == "y2")
You could use the existing geom_smooth geom and use lapply to generate geom_smooth calls from multiple random samples from the original data frame. For example:
# Fake data
set.seed(2)
dat = data.frame(x = runif(100, 0, 10))
dat$y = 2*dat$x - 0.5*dat$x^2 - 5 + rnorm(100, 0, 5)
ggplot(dat, aes(x, y)) +
geom_point() +
lapply(1:10, function(i) {
geom_smooth(data=dat[sample(1:nrow(dat), 20), ], se=FALSE)
})
Or, keeping it all in the tidyverse:
library(tidyverse)
ggplot(dat, aes(x, y)) +
geom_point() +
map(1:10, ~geom_smooth(data=dat[sample(1:nrow(dat), 20), ], se=FALSE))
Here's a way to plot the quantiles within ggplot. I'm not sure if it's possible to get stat_quantile to plot a ribbon. To get that, you might have to calculate the quantile regression outside of ggplot and add use geom_ribbon to add the values.
ggplot(dat, aes(x, y)) +
geom_point() +
geom_quantile(quantiles=c(0.1, 0.5, 0.9), formula=y ~ poly(x, 2),
aes(color=factor(..quantile..), size=factor(..quantile..))) +
scale_color_manual(values=c("red","blue","red")) +
scale_size_manual(values=c(1,2,1)) +
labs(colour="Quantile") +
guides(colour=guide_legend(reverse=TRUE), size=FALSE) +
theme_classic()

How to modify the backgroup color of label in the multiple-ggproto using ggplot2

I want to draw a graph which is familiar to the enterotype plot in the research. But my new multiple-ggproto seems terrible as showed in p1, owing to the missing backgroup color of the label. I've tried multiple variations of this, for example modify GeomLabel$draw_panel in order to reset the default arguments of geom in ggplot2::ggproto. However, I could not find the labelGrob() function which is removed in ggplot2 and grid package. Thus, the solution of modification didn't work. How to modify the backgroup color of label in the multiple-ggproto. Any ideas? Thanks in advance. Here is my code and two pictures.
p1: the background color of label should be white or the text color should be black.
P2:displays the wrong point color, line color and legend.
geom_enterotype <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity",
alpha = 0.3, prop = 0.5, ..., lineend = "butt", linejoin = "round",
linemitre = 1, arrow = NULL, na.rm = FALSE, parse = FALSE,
nudge_x = 0, nudge_y = 0, label.padding = unit(0.15, "lines"),
label.r = unit(0.15, "lines"), label.size = 0.1,
show.legend = TRUE, inherit.aes = TRUE) {
library(ggplot2)
# create new stat and geom for PCA scatterplot with ellipses
StatEllipse <- ggproto("StatEllipse", Stat,
required_aes = c("x", "y"),
compute_group = function(., data, scales, level = 0.75, segments = 51, ...) {
library(MASS)
dfn <- 2
dfd <- length(data$x) - 1
if (dfd < 3) {
ellipse <- rbind(c(NA, NA))
} else {
v <- cov.trob(cbind(data$x, data$y))
shape <- v$cov
center <- v$center
radius <- sqrt(dfn * qf(level, dfn, dfd))
angles <- (0:segments) * 2 * pi/segments
unit.circle <- cbind(cos(angles), sin(angles))
ellipse <- t(center + radius * t(unit.circle %*% chol(shape)))
}
ellipse <- as.data.frame(ellipse)
colnames(ellipse) <- c("x", "y")
return(ellipse)
})
# write new ggproto
GeomEllipse <- ggproto("GeomEllipse", Geom,
draw_group = function(data, panel_scales, coord) {
n <- nrow(data)
if (n == 1)
return(zeroGrob())
munched <- coord_munch(coord, data, panel_scales)
munched <- munched[order(munched$group), ]
first_idx <- !duplicated(munched$group)
first_rows <- munched[first_idx, ]
grid::pathGrob(munched$x, munched$y, default.units = "native",
id = munched$group,
gp = grid::gpar(col = first_rows$colour,
fill = alpha(first_rows$fill, first_rows$alpha), lwd = first_rows$size * .pt, lty = first_rows$linetype))
},
default_aes = aes(colour = "NA", fill = "grey20", size = 0.5, linetype = 1, alpha = NA, prop = 0.5),
handle_na = function(data, params) {
data
},
required_aes = c("x", "y"),
draw_key = draw_key_path
)
# create a new stat for PCA scatterplot with lines which totally directs to the center
StatConline <- ggproto("StatConline", Stat,
compute_group = function(data, scales) {
library(miscTools)
library(MASS)
df <- data.frame(data$x,data$y)
mat <- as.matrix(df)
center <- cov.trob(df)$center
names(center)<- NULL
mat_insert <- insertRow(mat, 2, center )
for(i in 1:nrow(mat)) {
mat_insert <- insertRow( mat_insert, 2*i, center )
next
}
mat_insert <- mat_insert[-c(2:3),]
rownames(mat_insert) <- NULL
mat_insert <- as.data.frame(mat_insert,center)
colnames(mat_insert) =c("x","y")
return(mat_insert)
},
required_aes = c("x", "y")
)
# create a new stat for PCA scatterplot with center labels
StatLabel <- ggproto("StatLabel" ,Stat,
compute_group = function(data, scales) {
library(MASS)
df <- data.frame(data$x,data$y)
center <- cov.trob(df)$center
names(center)<- NULL
center <- t(as.data.frame(center))
center <- as.data.frame(cbind(center))
colnames(center) <- c("x","y")
rownames(center) <- NULL
return(center)
},
required_aes = c("x", "y")
)
layer1 <- layer(data = data, mapping = mapping, stat = stat, geom = GeomPoint,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...))
layer2 <- layer(stat = StatEllipse, data = data, mapping = mapping, geom = GeomEllipse, position = position, show.legend = FALSE,
inherit.aes = inherit.aes, params = list(na.rm = na.rm, prop = prop, alpha = alpha, ...))
layer3 <- layer(data = data, mapping = mapping, stat = StatConline, geom = GeomPath,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(lineend = lineend, linejoin = linejoin,
linemitre = linemitre, arrow = arrow, na.rm = na.rm, ...))
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position)) {
stop("Specify either `position` or `nudge_x`/`nudge_y`",
call. = FALSE)
}
position <- position_nudge(nudge_x, nudge_y)
}
layer4 <- layer(data = data, mapping = mapping, stat = StatLabel, geom = GeomLabel,
position = position, show.legend = FALSE, inherit.aes = inherit.aes,
params = list(parse = parse, label.padding = label.padding,
label.r = label.r, label.size = label.size, na.rm = na.rm, ...))
return(list(layer1,layer2,layer3,layer4))
}
# data
data(Cars93, package = "MASS")
car_df <- Cars93[, c(3, 5, 13:15, 17, 19:25)]
car_df <- subset(car_df, Type == "Large" | Type == "Midsize" | Type == "Small")
x1 <- mean(car_df$Price) + 2 * sd(car_df$Price)
x2 <- mean(car_df$Price) - 2 * sd(car_df$Price)
car_df <- subset(car_df, Price > x2 | Price < x1)
car_df <- na.omit(car_df)
# Principal Component Analysis
car.pca <- prcomp(car_df[, -1], scale = T)
car.pca_pre <- cbind(as.data.frame(predict(car.pca)[, 1:2]), car_df[, 1])
colnames(car.pca_pre) <- c("PC1", "PC2", "Type")
xlab <- paste("PC1(", round(((car.pca$sdev[1])^2/sum((car.pca$sdev)^2)), 2) * 100, "%)", sep = "")
ylab <- paste("PC2(", round(((car.pca$sdev[2])^2/sum((car.pca$sdev)^2)), 2) * 100, "%)", sep = "")
head(car.pca_pre)
#plot
library(ggplot2)
p1 <- ggplot(car.pca_pre, aes(PC1, PC2, fill = Type , color= Type ,label = Type)) +
geom_enterotype()
p2 <- ggplot(car.pca_pre, aes(PC1, PC2, fill = Type , label = Type)) +
geom_enterotype()
You can manually change the colour scale to give it more emphasis against the background fill colour:
p3 <- ggplot(car.pca_pre, aes(PC1, PC2, fill = Type , color = Type, label = Type)) +
geom_enterotype() +
scale_colour_manual(values = c("red4", "green4", "blue4"))
p3
You can additionally adjust your fill colours by changing the alpha values, or assigning different colour values to give better contrast to your labels.
p4 <- ggplot(car.pca_pre, aes(PC1, PC2, label = Type, shape = Type, fill = Type, colour = Type)) +
geom_enterotype() +
scale_fill_manual(values = alpha(c("pink", "lightgreen", "skyblue"), 1)) +
scale_colour_manual(values = c("red4", "green4", "blue4"))
p4
Finally, if you want a background white colour to your labels, you have to remove the fill option. You can also additionally assign a shape value.
As you can observe, the background text colour is associated with the shape fill colour, while the text label colour is associated with the line colour, the the shape border colour.
p5 <- ggplot(car.pca_pre, aes(PC1, PC2, label = Type, shape = Type, colour = Type)) +
geom_enterotype() + scale_colour_manual(values = c("red4", "green4", "blue4"))
p5

In ggproto, coord$transform did not transform some columns to [0, 1]

I want to create a new Geom type: geom_ohlc(), which is something like Candlestick Charts, to plot the stock open-high-low-close data.
After learning this Hadley's article: I tried this:
GeomOHLC <- ggproto(`_class` = "GeomOHLC", `_inherit` = Geom,
required_aes = c("x", "op", "hi", "lo", "cl"),
draw_panel = function(data, panel_scales, coord){
coords <- coord$transform(data, panel_scales)
browser() # <<-- here is where I found the problem
grid::gList(
grid::rectGrob(
x = coords$x,
y = pmin(coords$op, coords$cl),
vjust = 0,
width = 0.01,
height = abs(coords$op - coords$cl),
gp = grid::gpar(col = coords$color, fill = "yellow")
),
grid::segmentsGrob(
x0 = coords$x,
y0 = coords$lo,
x1 = coords$x,
y1 = coords$hi
)
)
})
geom_ohlc <- function(data = NULL, mapping = NULL, stat = "identity", position = "identity", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
{
layer(
geom = GeomOHLC, mapping = mapping, data = data,
stat = stat, position = position, show.legend = show.legend,
inherit.aes = inherit.aes, params = list(na.rm = na.rm, ...)
)
}
dt <- data.table(x = 1:10, open = 1:10, high = 3:12, low = 0:9, close = 2:11)
p <- ggplot(dt, aes(x = x, op = open, hi = high, lo = low, cl = close)) +
geom_ohlc()
p
for simplicity, i just do not consider the color of bar.
The result plot is like this:
I add a browser() inside the ggproto function, and I found that the coord$transform did not transform the op, hi, lo, cl aesthetics into interverl [0,1]. How to fix this problem ?
Moreover, is there any other documents about how to create your own Geom type except that Hadley's article ?
As mentioned in the comments under the OP's question the problem is aes_to_scale() function inside transform_position(), which in turn is called by coord$transform. Transformations are limited to variables named x, xmin, xmax, xend, xintercept and the equivalents for y axis. This is mentioned in the help for transform_position:
Description
Convenience function to transform all position variables.
Usage
transform_position(df, trans_x = NULL, trans_y = NULL, ...) Arguments
trans_x, trans_y Transformation functions for x and y aesthetics.
(will transform x, xmin, xmax, xend etc) ... Additional arguments
passed to trans_x and trans_y.
A workaround would be to use those variable names instead of the variable names used by the OP. The following code works in transforming the variables but it fails at somewhere else (see at the end). I do not know the details of the intended plot, so didn't try to fix this error.
GeomOHLC <- ggproto(
`_class` = "GeomOHLC",
`_inherit` = Geom,
required_aes = c("x", "yintercept", "ymin", "ymax", "yend"),
draw_panel = function(data, panel_scales, coord) {
coords <- coord$transform(data, panel_scales)
#browser() # <<-- here is where I found the problem
grid::gList(
grid::rectGrob(
x = coords$x,
y = pmin(coords$yintercept, coords$yend),
vjust = 0,
width = 0.01,
height = abs(coords$op - coords$cl),
gp = grid::gpar(col = coords$color, fill = "yellow")
),
grid::segmentsGrob(
x0 = coords$x,
y0 = coords$ymin,
x1 = coords$x,
y1 = coords$ymax
)
)
}
)
geom_ohlc <-
function(data = NULL,
mapping = NULL,
stat = "identity",
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE,
...)
{
layer(
geom = GeomOHLC,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
dt <-
data.table(
x = 1:10,
open = 1:10,
high = 3:12,
low = 0:9,
close = 2:11
)
p <-
ggplot(dt, aes(
x = x,
yintercept = open,
ymin = high,
ymax = low,
yend = close
)) +
geom_ohlc()
p
This transforms the variables but produces the following error:
Error in unit(height, default.units) :
'x' and 'units' must have length > 0
But hopefully from here it can be made to work.
NOTE: I chose the mapping between the original variable names (op, hi, lo, cl) rather arbitrarily. Specially yintercept does not seem to fit well. Maybe there is need to support arbitrary scale variable names in ggplot2?

Resources