#' Geom class to support plotting geom_timeline
#' @format NULL
#' @usage NULL
GeomTimelinelabel <- ggplot2::ggproto("GeomTimelinelabel", ggplot2::Geom,
required_aes = c("x","label"),
default_aes = ggplot2::aes( y = 1, x_min = NA,
x_max = NA,
col = NA,
magnitude = NA),
draw_group = function(data, panel_params, coord) {
coords <- coord$transform(data, panel_params)
seg <- grid::segmentsGrob(
x0 = coords$x,
x1 = coords$x,
y0 = coords$y,
y1 = coords$y + 0.15
)
txt <- grid::textGrob(
label = coords$label,
x = coords$x,
y = coords$y + 0.15,
just = "left",
gp = grid::gpar(fontsize = 10),
rot = 45
)
grlist <- grid::gList(seg, txt)
lbl <- grid::gTree(children = grlist)
return(lbl)
}
)
#' Geom to annotate earthquake graph
#'
#' @inheritParams ggplot2::layer
#'
#' @param na.rm If \code{FALSE}, the default, missing values are removed with
#' a warning. If \code{TRUE}, missing values are silently removed.
#' @param ... other arguments passed on to \code{\link{layer}}. These are
#' often aesthetics, used to set an aesthetic to a fixed value, like
#' \code{color = "red"} or \code{size = 3}. They may also be parameters
#' to the paired geom/stat.
#'
#' @examples
#' require(ggplot2)
#' ggplot(eq_china_cleandata, aes( x = DATE, y = as.factor(COUNTRY))) +
#' geom_timeline( x_min = "1800-01-01", x_max = "2015-01-01") +
#' geom_timelinelabel(ggplot2::aes_(magnitude = quote(EQ_PRIMARY),
#' label = quote(LOCATION_NAME),
#' col = NULL),
#' x_min = "1800-01-01",
#' x_max = "2015-01-01",
#' n_max = 3)
#'
#' @export
geom_timelinelabel <- function(mapping = NULL, data = NULL,
stat = "timeline", position = "identity",
...,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
ggplot2::layer(
data = data,
mapping = mapping,
stat = "timelinelabel",
geom = GeomTimelinelabel,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
...
)
)
}
#' Stat class to support the GeomTimelinelabel class
#' @format NULL
#' @usage NULL
StatTimelinelabel <- ggplot2::ggproto("StatTimelinelabel", ggplot2::Stat,
default_aes = ggplot2::aes(y = 1),
required_aes = "x",
setup_data = function(data, params){
xmin_num <- as.numeric(as.Date(params$x_min))
xmax_num <- as.numeric(as.Date(params$x_max))
blflt <- data$x >= xmin_num & data$x <= xmax_num
data <- data[blflt,]
return(data)
},
compute_group = function(data, scales, x_min,
x_max,n_max) {
max_n <- min(n_max[[1]], nrow(data))
srtind <- sort(data$magnitude,
decreasing = TRUE,
index.return = TRUE)
tpind <- srtind$ix[1:max_n]
rtdat <- data[tpind,]
return(rtdat)
}
)
#' Stat function to support StatTimelinelabel class
#' @inheritParams ggplot2::layer
#'
#' @param na.rm If \code{FALSE}, the default, missing values are removed with
#' a warning. If \code{TRUE}, missing values are silently removed.
#' @param ... other arguments passed on to \code{\link{layer}}. These are
#' often aesthetics, used to set an aesthetic to a fixed value, like
#' \code{color = "red"} or \code{size = 3}. They may also be parameters
#' to the paired geom/stat.
#' @param x_min An atomic character representing the low of a date range.
#'
#' @param x_max An atomic character representing the high of a date range.
#'
#' @param n_max An atomic numeric holding the number of top earthquakes by
#' magnitude to label.
#'
#' @examples
#' require(ggplot2)
#' ggplot(eq_china_cleandata, aes( x = DATE, y = as.factor(COUNTRY))) +
#' geom_timeline( x_min = "1800-01-01", x_max = "2015-01-01") +
#' geom_timelinelabel(ggplot2::aes_(magnitude = quote(EQ_PRIMARY),
#' label = quote(LOCATION_NAME),
#' col = NULL),
#' x_min = "1800-01-01",
#' x_max = "2015-01-01",
#' n_max = 3)
stat_timelinelabel <- function(mapping = NULL, data = NULL, geom = "timelinelabel",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE,x_min = NA,
x_max = NA, n_max = NA, ...) {
ggplot2::layer(
stat = StatTimelinelabel,
data = data,
mapping = mapping,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, x_min = x_min, x_max = x_max,
n_max = n_max, ...)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.