R/plot.R

In frenkg/courseraeq: Clean and Plot NOAA's Earthquakes Database Information

#' 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
    )
}