#' geom_timeline ggplot2 geometry
#'
#' This function create an ad hoc geometry to visualize the timeline of earthquakes.
#' Each earthquake is represented by a point, with size and color aestethics
#' ready to be assigned a variable.
#'
#' @param data The data to be displayed in this layer.
#' @param mapping Set of aesthetic mappings created by \code{\link{aes}} or
#' \code{\link{aes_}}.
#' @param stat The statistical transformation to use on the data for this
#' layer, as a string.
#' @param position Position adjustment, either as a string, or the result of
#' a call to a position adjustment function.
#' @param show.legend logical. Should this layer be included in the legends?
#' \code{NA}, the default, includes if any aesthetics are mapped.
#' \code{FALSE} never includes, and \code{TRUE} always includes.
#' @param inherit.aes If \code{FALSE}, overrides the default aesthetics,
#' rather than combining with them. This is most useful for helper functions
#' that define both data and aesthetics and shouldn't inherit behaviour from
#' the default plot specification, e.g. \code{\link{borders}}.
#' @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.
#'
#' @return a ggplot2 geometry
#'
#' @importFrom ggplot2 layer
#'
#' @examples
#' \dontrun{
#' data %>%
#' dplyr::filter(COUNTRY == "USA" & YEAR > 2000) %>%
#' ggplot() +
#' geom_timeline(aes(x = DATE, y = COUNTRY, size = EQ_PRIMARY, color = DEATHS)) +
#' labs(size = "Richter Scale value:", color = "# of Deaths:")
#' }
#'
#' @export
geom_timeline <- function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
na.rm = TRUE,
show.legend = NA,
inherit.aes = TRUE,
...) {
ggplot2::layer(
geom = GeomTimeLine,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
#' GeomTimeline proto
#'
#' @importFrom ggplot2 ggproto
#' @importFrom ggplot2 aes
#' @importFrom ggplot2 draw_key_point
#' @importFrom grid pointsGrob
#' @importFrom grid segmentsGrob
#' @importFrom grid gpar
#' @importFrom grid gTree
#' @importFrom grid gList
#'
#' @export
GeomTimeLine <- ggplot2::ggproto("GeomTimeLine", ggplot2::Geom,
required_aes = c("x", "y"),
non_missing_aes = c("size", "shape", "colour"),
default_aes = ggplot2::aes(
y = 0.05,
size = 2,
shape = 19,
colour = "grey",
alpha = 0.4,
stroke = 0.5,
fill = NA),
draw_key = ggplot2::draw_key_point,
draw_group = function(data, panel_scales, coord) {
# transform data
coords <- coord$transform(data, panel_scales)
# build grid grob
eq_point <- grid::pointsGrob(
x = coords$x,
y = coords$y,
pch = coords$shape,
size = grid::unit(coords$size * 2, "mm"),
default.units = "native",
gp = grid::gpar(
#size = grid::unit(coords$size, "npc"),
col = scales::alpha(coords$colour, coords$alpha),
fill = scales::alpha(coords$colour, coords$alpha),
#fontsize = coords$size * .pt + coords$stroke * .stroke / 2,
lwd = coords$stroke * coords$stroke / 2 )
)
eq_line <- grid::segmentsGrob(
x0 = 0,
x1 = 1,
y0 = coords$y,
y1 = coords$y,
default.units = "native",
gp = grid::gpar(
size = 0.5,
alpha = coords$alpha * 0.5,
col = "grey")
)
timeline <- grid::gTree(children = grid::gList(
eq_line, eq_point))
}
)
#' geom_timeline_label ggplot2 geometry
#'
#' This function create an ad hoc geometry to visualize a label for the
#' timeline of earthquakes. The geometry is represented by a vertical line and
#' a text label.
#' The max number of labels is controlled by the parameter \code{n_max}.
#'
#' @param data The data to be displayed in this layer.
#' @param mapping Set of aesthetic mappings created by \code{\link{aes}} or
#' \code{\link{aes_}}.
#' @param stat The statistical transformation to use on the data for this
#' layer, as a string.
#' @param position Position adjustment, either as a string, or the result of
#' a call to a position adjustment function.
#' @param show.legend logical. Should this layer be included in the legends?
#' \code{NA}, the default, includes if any aesthetics are mapped.
#' \code{FALSE} never includes, and \code{TRUE} always includes.
#' @param inherit.aes If \code{FALSE}, overrides the default aesthetics,
#' rather than combining with them. This is most useful for helper functions
#' that define both data and aesthetics and shouldn't inherit behaviour from
#' the default plot specification, e.g. \code{\link{borders}}.
#' @param na.rm If \code{FALSE}, the default, missing values are removed with
#' a warning. If \code{TRUE}, missing values are silently removed.
#' @param fill Color to use for filling.
#' @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 xmin minimum date to be displayed
#' @param xmax maximum date to be displayed
#' @param n_max Max number of labels to display per each row. Default = 5.
#'
#' @return a ggplot2 geometry
#'
#' @importFrom ggplot2 layer
#'
#' @examples
#' \dontrun{
#' data %>%
#' dplyr::filter(COUNTRY == "USA" & YEAR > 2000) %>%
#' ggplot() +
#' geom_timeline(aes(x = DATE, y = COUNTRY, size = EQ_PRIMARY, color = DEATHS)) +
#' geom_timeline_label(aes(x = DATE, y = COUNTRY, label = LOCATION_NAME,
#' size = EQ_PRIMARY), n_max = 5) +
#' labs(size = "Richter Scale value:", color = "# of Deaths:")
#' }
#'
#' @export
geom_timeline_label <- function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
na.rm = TRUE,
show.legend = NA,
inherit.aes = TRUE,
xmin = NULL,
xmax = NULL,
n_max = 5,
fill = NA,
#var_order = NULL,
...) {
#datafiltered <- data #%>%
# dplyr::group_by_(~ COUNTRY) %>%
# dplyr::top_n(n_max, EQ_PRIMARY) #var_order)
ggplot2::layer(
geom = GeomTimeLineLabel,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
n_max = n_max,
#xmin = xmin,
#xmax = xmax,
...)
)
}
#' GeomTimelineLabel proto
#'
#' @importFrom dplyr group_by_
#' @importFrom dplyr top_n
#' @importFrom dplyr ungroup
#' @importFrom ggplot2 ggproto
#' @importFrom ggplot2 aes
#' @importFrom ggplot2 draw_key_label
#' @importFrom grid segmentsGrob
#' @importFrom grid textGrob
#' @importFrom grid gpar
#' @importFrom grid gTree
#' @importFrom grid gList
#'
#' @export
GeomTimeLineLabel <- ggplot2::ggproto("GeomTimeLineLabel", ggplot2::Geom,
required_aes = c("x", "y", "label"),
default_aes = ggplot2::aes(
y = 0.1,
colour = "grey",
size = 0.2,
linetype = 1,
alpha = 0.5,
angle = 45,
hjust = 0,
vjust = 0,
family = "",
fontface = 1,
pt = 4,
lineheight = 1.5,
n_max = 5,
fill = NA),
draw_key = ggplot2::draw_key_label,
setup_data = function(data, params) {
data <- data %>%
dplyr::group_by_("group") %>%
dplyr::top_n(params$n_max, size) %>%
dplyr::ungroup()
data
},
draw_group = function(data, panel_scales, coord) {
# transform data
coords <- coord$transform(data, panel_scales)
# build grid grob
line <- grid::segmentsGrob(
x0 = coords$x,
x1 = coords$x,
y0 = coords$y,
y1 = coords$y + 0.1,
default.units = "native",
gp = grid::gpar(
size = 0.5,
alpha = coords$alpha,
col = coords$color,
fill = NA)
)
text <- grid::textGrob(
label = coords$label,
x = coords$x,
y = coords$y + 0.1,
hjust = coords$hjust,
vjust = coords$vjust,
rot = coords$angle,
default.units = "native",
gp = grid::gpar(
col = coords$color,
alpha = coords$alpha,
fontsize = 3.5 * coords$pt,
size = 0.5,
fontfamily = coords$family,
fontface = coords$fontface,
lineheight = coords$lineheight,
fill = NA)
)
timeline_label <- grid::gTree(children = grid::gList(
line, text))
}
)
#' Timeline ad hoc Theme
#'
#' This is a modification of the Classic Theme to improve the visualization of
#' the \code{geom_timeline} geometry.
#' Y axis is removed and legend placed at the bottom of the plot.
#'
#' @param base_size base font size
#' @param base_family base font family
#'
#' @return ggplot theme
#'
#' @importFrom ggplot2 element_blank
#' @importFrom ggplot2 element_line
#' @importFrom ggplot2 '%+replace%'
#' @importFrom ggplot2 theme_classic
#' @importFrom ggplot2 theme
#' @importFrom ggplot2 rel
#'
#' @examples
#' \dontrun{
#' data %>%
#' dplyr::filter(COUNTRY == "USA" & YEAR > 2000) %>%
#' ggplot() +
#' geom_timeline(aes(x = DATE, y = COUNTRY, size = EQ_PRIMARY, color = DEATHS)) +
#' geom_timeline_label(aes(x = DATE, y = COUNTRY, label = LOCATION_NAME,
#' size = EQ_PRIMARY), n_max = 5) +
#' theme_thimeline() +
#' ggplot2::labs(size = "Richter Scale value:", color = "# of Deaths:")
#' }
#'
#' @export
theme_timeline <- function(base_size = 11, base_family = ""){
ggplot2::theme_classic(base_size = base_size, base_family = base_family) %+replace%
ggplot2::theme(
# show x.axis but not y.axis
axis.line.x = ggplot2::element_line(colour = "black", size = ggplot2::rel(1)),
axis.line.y = ggplot2::element_blank(),
axis.ticks.y = ggplot2::element_blank(),
# match legend key to panel.background
legend.key = ggplot2::element_blank(),
# locate legend at the bottom
legend.position = "bottom",
complete = TRUE
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.