#' Glyph plots for `tf` objects
#'
#' Plots a miniature glyph / sparkline for each entry of a `tf`-object.
#' (Capellini are tiny spaghetti -- *angel hair* pasta.) Aesthetics `x` and `y`
#' specify the location of the glyphs, the `tf` aesthetic defines their shapes.
#' To accommodate all my fellow idiots, `geom_cappelini`, `geom_cappellini` and
#' `geom_capelini` also work.
#'
#' @section `tf` aesthetic:
#' Mandatory. Used to designate a column of class `tf` to be visualized as glyphs.
#' @examples
#' \dontrun{
#' # takes a little too long for CRAN
#' library(ggplot2)
#' library(tidyverse)
#' weather <- fda::CanadianWeather
#' canada <- data.frame(
#' place = weather$place,
#' region = weather$region,
#' lat = weather$coordinates[, 1],
#' lon = -weather$coordinates[, 2],
#' region = weather$region
#' )
#' canada$temp <- tfd(t(weather$dailyAv[, , 1]), arg = 1:365)
#' canada$precipl10 <- tfd(t(weather$dailyAv[, , 3]), arg = 1:365) |> tf_smooth()
#' canada_map <-
#' data.frame(maps::map("world", "Canada", plot = FALSE)[c("x", "y")])
#' # map of canada with annual temperature averages in red, precipitation in blue:
#' ggplot(canada, aes(x = lon, y = lat)) +
#' geom_capellini(aes(tf = precipl10), width = 3, height = 5, colour = "blue") +
#' geom_capellini(aes(tf = temp), width = 3, height = 5, colour = "red") +
#' geom_path(data = canada_map, aes(x = x, y = y), alpha = 0.1) +
#' coord_quickmap()
#'
#' ggplot(canada, aes(x = lon, y = lat, colour = region)) +
#' geom_capellini(aes(tf = precipl10),
#' width = 5, height = 3,
#' line.linetype = 1, box.fill = "white", box.alpha = 0.5, box.colour = NA
#' )
#' }
#' @name ggcapellini
#' @family tidyfun visualization
#' @seealso [GGally::glyphs]
NULL
#' @export
#' @importFrom ggplot2 ggproto Stat Geom aes
#' @importFrom GGally rescale11 rescale01
#' @rdname ggcapellini
#' @usage NULL
#' @format NULL
StatCapellini <- ggplot2::ggproto("StatCapellini", ggplot2::Stat,
required_aes = c("x", "y", "tf"),
setup_params = function(data, params) {
if (is.null(params$arg)) {
params$arg <- list(tf_arg(pull(data, tf)))
}
if (is.null(params$width)) {
params$width <- ggplot2::resolution(data$x) / 1.5
}
if (is.null(params$height)) {
params$height <- ggplot2::resolution(data$y) / 1.5
}
params
},
compute_layer = function(self, data, params, layout) {
if (!is_tf(data$tf)) {
cli::cli_abort(
"tf must be a tf object, not {.obj_type_friendly {data$tf}}"
)
}
tf_eval <- suppressMessages(
data |>
mutate(tf___id = names(tf) %||% seq_along(tf)) |>
tf_unnest(tf, arg = params$arg, names_sep = "___")
) |>
select(-group) |>
rename(group = tf___id, arg = tf___arg, value = tf___value) |>
mutate(
xgrid = x, ygrid = y,
x = x + rescale11(arg) * params$width / 2,
y = y + rescale11(value) * params$height / 2,
width = params$width,
height = params$height,
lines = params$add_lines,
boxes = params$add_boxes
)
tf_eval
},
# need this so arg etc get recognized as valid parameters
# because layer() only checks compute_panel & compute_group
compute_panel = function(self, data, scales, arg,
add_lines, add_boxes, width, height) {
ggplot2::Stat$compute_panel(self, data, scales)
}
)
#' @export
#' @rdname ggcapellini
#' @inheritParams ggplot2::stat_identity
#' @param na.rm remove NAs? defaults to `TRUE`
stat_capellini <- function(mapping = NULL, data = NULL, geom = "capellini",
position = "identity", na.rm = TRUE, show.legend = NA,
inherit.aes = TRUE, arg = NULL, add_lines = FALSE,
add_boxes = TRUE, width = NULL, height = NULL, ...) {
ggplot2::layer(
stat = StatCapellini, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
na.rm = na.rm, arg = arg, add_lines = add_lines,
add_boxes = add_boxes, width = width, height = height, ...
)
)
}
# geom --------------------------------------------------------------------
#' @export
#' @rdname ggcapellini
#' @format NULL
#' @param stat that's "capellini"!
#' @param arg where to evaluate `tf` -- defaults to the default ;)
#' @param add_lines should a reference line in the middle of the range of the
#' functions' values be added to each glyph? defaults to TRUE
#' @param add_boxes should a box be added to frame each glyph? defaults to TRUE
#' @param width the width of the glyphs. Defaults to 2/3 of the [ggplot2::resolution()]
#' of the variable for the `x`-aesthetic, this will be too small if any values
#' are close together.
#' @param height the height of the glyphs. Defaults to 2/3 of the [ggplot2::resolution()]
#' of the variable for the `y`-aesthetic, this will be too small if any values
#' are close together.
#' @param box.colour aesthetic property of the box
#' @param box.linetype aesthetic property of the box
#' @param box.fill aesthetic property of the box
#' @param box.linewidth aesthetic property of the box
#' @param box.alpha aesthetic property of the box
#' @param line.colour aesthetic property of the reference line
#' @param line.linetype aesthetic property of the reference line
#' @param line.linewidth aesthetic property of of the reference line
#' @param line.alpha aesthetic property of the reference line
geom_capellini <-
function(mapping = NULL, data = NULL, stat = "capellini",
position = "identity", ..., na.rm = TRUE, show.legend = NA,
inherit.aes = TRUE, arg = NULL, add_lines = TRUE, add_boxes = TRUE,
width = NULL, height = NULL, box.colour = "#0000001A",
box.linetype = 1, box.fill = NA, box.linewidth = 0.1, box.alpha = 0.1,
line.colour = "black", line.linetype = 2, line.linewidth = 0.3,
line.alpha = 0.5) {
ggplot2::layer(
stat = StatCapellini, data = data, mapping = mapping, geom = "capellini",
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(
na.rm = na.rm, arg = arg, add_lines = add_lines,
add_boxes = add_boxes, width = width, height = height,
box.colour = box.colour, box.linetype = box.linetype,
box.fill = box.fill, box.linewidth = box.linewidth, box.alpha = box.alpha,
line.colour = line.colour, line.linetype = line.linetype,
line.linewidth = line.linewidth, line.alpha = line.alpha, ...
)
)
}
#' @export
#' @rdname ggcapellini
#' @usage NULL
geom_cappellini <- geom_capellini
#' @export
#' @usage NULL
#' @rdname ggcapellini
geom_capelini <- geom_capellini
#' @export
#' @usage NULL
#' @rdname ggcapellini
geom_cappelini <- geom_capellini
#' @export
#' @rdname ggcapellini
#' @usage NULL
#' @format NULL
GeomCapellini <- ggplot2::ggproto("GeomCapellini", ggplot2::Geom,
setup_data = function(data, params) {
GeomPath$setup_data(data, params)
},
draw_group = function(data, panel_params, coord,
box.colour = "#0000001A", box.linetype = 1,
box.fill = NA, box.linewidth = 0.1, box.alpha = 0.1,
line.colour = "black", line.linetype = 2,
line.linewidth = 0.3, line.alpha = 0.5) {
glyph_grob <- GeomPath$draw_panel(data, panel_params, coord)
if (data$lines[1]) {
lines <- data.frame(
x = data$xgrid[1] - data$width[1] / 2,
xend = data$xgrid[1] + data$width[1] / 2,
y = data$ygrid[1],
yend = data$ygrid[1],
colour = line.colour,
linetype = line.linetype,
linewidth = line.linewidth,
alpha = line.alpha
)
lines_grob <- GeomSegment$draw_panel(lines, panel_params, coord)
} else {
lines_grob <- NULL
}
if (data$boxes[1]) {
boxes <- data.frame(
xmin = data$xgrid[1] - data$width[1] / 2,
xmax = data$xgrid[1] + data$width[1] / 2,
ymin = data$ygrid[1] - data$height[1] / 2,
ymax = data$ygrid[1] + data$height[1] / 2,
colour = box.colour,
linetype = box.linetype,
fill = box.fill,
alpha = box.alpha,
linewidth = box.linewidth
)
boxes_grob <- GeomRect$draw_panel(boxes, panel_params, coord)
} else {
boxes_grob <- NULL
}
grid::gList(
lines_grob,
boxes_grob,
glyph_grob
)
},
default_aes = ggplot2::aes(
colour = "black", linewidth = 0.5,
linetype = 1, alpha = 0.5
),
draw_key = ggplot2::GeomPath$draw_key
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.