R/eq_geoms.R

In dtminnick/earthquake: NOAA Significant Earthquake Analysis

#' Add Timeline Plot
#'
#' \code{geom_timeline} plots a timeline with points showing the dates when
#' earthquakes occurred.  The color of the points corresponds to the number
#' of deaths associated with an event and the size of the point corresponds to
#' the magnitude of the earthquake (higher magnitude creates a larger point).
#'
#' This geom is designed to be used with the NOAA Significant Earthquake data set
#' but it can show any data with a data frame of valid date objects.
#'
#' @section Aesthetics:
#'     \code{geom_timeline} understands the following aesthetics (required aesthetics
#'     in bold):
#'     \itemize{
#'     \item \strong{\code{x}}
#'     \item \code{y}
#'     \item ]code{color}
#'     \item \code{fill}
#'     \item \code{size}
#'     \item \code{alpha}
#'     }
#'
#' @inheritParams ggplot2::geom_point
#'
#' @param xmin A Date object identifying the earliest date include
#' in the timeline plot.
#'
#' @param xmax A Date object identifying the latest date to include
#' in the timeline plot.
#'
#' @details Each earthquake event with an associated date will be plotted as a
#' circle on the timeline as long as the event occurs between \code{xmin} and
#' \code{xmax}.
#'
#' Additional optional aesthetics can make the geom more useful.  The \code{y}
#' aesthetic allows a comparison of two or more timelines over the same date range,
#' e.g. comparing events for two countries.  Size can be used to show the
#' magnitude of events and color, fill or alpha can convey number of deaths.
#'
#' @examples
#' \dontrun{
#' ggplot(data = earthquakes, aes(x = DATE)) +
#'      geom_timeline(xmin = "2000-01-01", xmax = "2018-12-31",
#'                    aes(color = TOTAL_DEATHS, size = EQ_PRIMARY))
#'
#' The following example includes the \code{y} aesthetic to plot timelines
#' for each country in the data frame.
#'
#' ggplot(data = earthquakes, aes(x = DATE, y = COUNTRY)) +
#'      geom_timeline(xmin = "2000-01-01", xmax = "2018-12-31",
#'                    aes(color = TOTAL_DEATHS, size = EQ_PRIMARY))
#' }
#'
#' @export

geom_timeline <- function(mapping = NULL,
                          data = NULL,
                          stat = "identity",
                          position = "identity",
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE,
                          xmin = NULL,
                          xmax = NULL, ...) {

      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,
                                   xmin = xmin,
                                   xmax = xmax, ...))

}

#' GeomTimeline ggproto Object
#'
#' This function creates the ggproto Geom object needed to plot the necessary
#' grid grob for the for \code{geom_timeline}.
#'

GeomTimeline <- ggplot2::ggproto("GeomTimeline", ggplot2::Geom,

      required_aes = c("x", "xmin", "xmax"),

      non_missing_aes = c("size", "colour"),

      default_aes = ggplot2::aes(shape = 19,
                                 alpha = 0.5,
                                 size = 1.5,
                                 colour = "black",
                                 fill = NA,
                                 stroke = 0.5,
                                 y = 0.2),

      draw_panel = function(data, panel_params, coord) {

            data$x <- as.Date(data$x, origin = "1970-01-01")

            data$xmin <- as.Date(data$xmin)

            data$xmax <- as.Date(data$xmax)

            data <- subset(data, x >= data$xmin & x <= data$xmax)

            coords <- coord$transform(data, panel_params)

            grid::pointsGrob(coords$x,
                             coords$y,
                             pch = coords$shape,
                             size = grid::unit(data$size, "mm"),
                             gp = grid::gpar(alpha = coords$alpha,
                                             col = coords$colour,
                                             lwd = coords$stroke * .stroke / 2))

      },

      draw_key = ggplot2::draw_key_point

)

#' Add Timeline Label
#'
#' \code{geom_timeline_label} adds labels to a timeline generated by
#' \code{geom_timeline} for a specified number of ranked events.  It draws
#' vertical lines above points on the timeline and adds a label for each event.
#'
#' \code{geom_timeline_label} provides one option to label the \code{n_max}
#' events sorted by a selected variable.
#'
#' @section Aesthetics:
#'     \code{geom_timeline_label} understands the following aesthetics (required are
#'     in bold):
#'     \itemize{
#'     \item \strong{\code{x}}
#'     \item \strong{\code{label}} Label to be added.
#'     \item \code{y}
#'     \item \code{magnitude} Feature used to sort events.
#'     \item \code{n_max}
#'     \item \code{color}
#'     \item \code{fill}
#'     \item \code{size}
#'     \item \code{alpha}
#'     }
#'
#' @inheritParams ggplot2::geom_point
#'
#' @inheritParams geom_timeline
#'
#' @param n_max The top \code{n_max} labels to plot as an integer, e.g. if you
#' want to label the top five earthquakes by magnitude, pass \code{5} to this
#' parameter.
#'
#' @examples
#' \dontrun{
#' ggplot(data = earthquakes, aes(x = DATE, y = COUNTRY)) +
#'     geom_timeline(xmin = "2000-01-01", xmax = "2018-12-31",
#'                   aes(color = TOTAL_DEATHS, size = EQ_PRIMARY)) +
#'     geom_timeline_label(n_max = 5,
#'                         aes(label = LOCATION_NAME,
#'                                     magnitude = EQ_PRIMARY))
#' }
#'
#' @export

geom_timeline_label <- function(mapping = NULL,
                                data = NULL,
                                na.rm = TRUE,
                                show.legend = NA,
                                stat = "identity",
                                position = "identity",
                                inherit.aes = TRUE,
                                n_max = NULL, ...) {

      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, ...))

}

#' GeomTimelineLabel ggproto Object
#'
#' This function creates the ggproto Geom object needed to plot the necessary
#' grid grob for the for \code{geom_timeline_label}.
#'

GeomTimelineLabel <- ggplot2::ggproto("GeomTimelineLabel", ggplot2::Geom,

      required_aes = c("x", "label", "magnitude"),

      default_aes = ggplot2::aes(colour = "black",
                                 size = 12,
                                 angle = 45,
                                 hjust = 0,
                                 vjust = 0,
                                 alpha = NA,
                                 family = "",
                                 n_max = 5,
                                 fontface = 1,
                                 lineheight = 1.2,
                                 y = 0.2),

      draw_key = ggplot2::draw_key_text,

      draw_panel = function(data, panel_params, coord) {

            data <- data[order(data$magnitude, decreasing = TRUE), ]

            data <- data[1:data$n_max[1], ]

            coords <- coord$transform(data, panel_params)

            timeline_segment <- grid::segmentsGrob(x0 = unit(coords$x, "npc"),
                                                    x1 = unit(coords$x, "npc"),
                                                    y0 = unit(coords$y, "npc"),
                                                    y1 = unit(coords$y + 0.06 / length(unique(coords$y)), "npc"),
                                                    default.units = "npc",
                                                    arrow = NULL,
                                                    name = NULL,
                                                    gp = grid::gpar(),
                                                    vp = NULL)

            timeline_label <- grid::textGrob(label = coords$label,
                                             x = unit(coords$x, "npc"),
                                             y = unit(coords$y + 0.06 / length(unique(coords$y)), "npc"),
                                             rot = 45,
                                             just = "left",
                                             gp = grid::gpar(col = alpha(data$colour, data$alpha),
                                                             fontsize = data$size,
                                                             fontfamily = data$family,
                                                             fontface = data$fontface,
                                                             lineheight = data$lineheight))

            grid::gList(timeline_segment, timeline_label)

      }

)