rPkgNOAADataset: Visualizing NOAA Dataset

#######################################################################################################################
### WEEK 1 ############################################################################################################
#######################################################################################################################

## function: handle_negative_dates ---------------------------------------------

#' Handling negative dates (BC dates)
#'
#' \code{handle_negative_dates} takes negative dates
#'
#' @param y The year as a nummeric input
#' @param m The month as a nummeric input
#' @param d the day as a numeric input
#'
#' @return Date as a date class, and which is negative
#'
#' @examples
#' handle_negative_dates(-100, 1, 1)
#'
#' @export
#'
handle_negative_dates <- function(y, m, d) {

  origin_date <- base::as.numeric(as.Date("0 1 1", "%Y %m %d", origin = "1970-01-01"))

  mirror_date <- base::as.Date(paste(-y-1, 13-m, abs(27-d)+1, sep = '-'), '%Y-%m-%d', origin = '1970-01-01') # -y -1 (?)  # abs(27-d)+1

  mirror_date_num <- base::as.numeric(mirror_date)

  delta <- origin_date - mirror_date_num

  days_gone_by <- delta + origin_date

  date_new <- base::as.Date(days_gone_by, origin = "1970-01-01")

  return(date_new)

}

## function: handle_positive_dates ---------------------------------------------
#' Handling positive dates (BC dates)
#'
#' \code{handle_positive_dates} takes positive dates
#'
#' This function takes a positive date via an input of
#' year, month and day (seperately) and gives back the date
#' as a date class. very simple function.
#'
#' @param y The year as a nummeric input
#' @param m The month as a nummeric input
#' @param d the day as a numeric input
#'
#' @return Date as a date class, and which is positive
#'
#' @examples
#' handle_positive_dates(2010, 10, 10)
#'
#' @export
#'
handle_positive_dates <- function(y, m, d) {
  date_paste <- base::paste0(y, "-", m, "-", d)
  date_new <- base::as.Date(date_paste, format = "%Y-%m-%d")

  base::return(date_new)
} # END function handle_positive_dates

## function: eq_location_clean() ---------------------------------------------
#' Cleans the variable "LOCATION_NAME"
#'
#' \code{eq_location_clean} strips down from the LOCATION_NAME variable the
#' country. The function input is the whole earth quake data, of which it then
#' mutates the LOCATION_NAME.
#'
#' @param data A data frame of NOAA significant earthquake data
#'
#' @importFrom magrittr "%>%"
#' @importFrom purrr map2_chr
#' @importFrom stringr str_trim
#' @importFrom stringr str_to_title
#' @importFrom dplyr mutate
#'
#' @return it returns the data frame back, but with the mutated LOCATION_NAME
#'
#' @export
#'
eq_location_clean <- function(data){

  data <- data %>%
    dplyr::mutate(
      LOCATION_NAME = purrr::map2_chr(COUNTRY, LOCATION_NAME,
                                      function(COUNTRY, LOCATION_NAME) {gsub(paste0(COUNTRY, ":"),"",LOCATION_NAME)}),
      LOCATION_NAME = stringr::str_trim(LOCATION_NAME),
      LOCATION_NAME = stringr::str_to_title(LOCATION_NAME)
    )

}

## function: eq_clean_data() ---------------------------------------------
#' Loads and Cleans the Earth Quake data
#'
#' \code{eq_clean_data} loads the data, cleans the data (including the LOCATION_NAME variable)
#' and gives back the data frame. There is no input to this function
#'
#' @importFrom magrittr "%>%"
#' @importFrom readr read_tsv
#' @importFrom dplyr mutate
#'
#' @return it returns the data frame, cleaned and with correct dates (with date class)
#'
#' @export
eq_clean_data <- function() {

  data("NOAAearthquakesRAW")
  data <- NOAAearthquakesRAW %>%
    dplyr::mutate(MONTH = base::replace(MONTH, base::which(base::is.na(MONTH)), 1)) %>%

    dplyr::mutate(DAY = base::replace(DAY, base::which(base::is.na(DAY)), 1)) %>%
    dplyr::mutate(date = base::ifelse(YEAR < 0,
                                      handle_negative_dates(YEAR, MONTH, DAY),
                                      handle_positive_dates(YEAR, MONTH, DAY)
    )) %>%
    dplyr::mutate(date = base::as.Date(date, origin = "1970-01-01")) %>%
    dplyr::mutate(LATITUDE  = base::as.numeric(LATITUDE)) %>%
    dplyr::mutate(LONGITUDE = base::as.numeric(LONGITUDE))
  data <- eq_location_clean(data)

}


#######################################################################################################################
### WEEK 2 ############################################################################################################
#######################################################################################################################

## function: geom_timeline (building the layer)  --------------------------------
##     quite generic
##     builds the layer based on the geom specifications
##     geom specification is defined in the next function
##     next function is:

#' Function which builts the layer for the ggplot.
#'
#' @importFrom ggplot2 layer
#'
#' @param mapping See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param data See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param stat See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param position See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param na.rm See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param show.legend See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param inherit.aes See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param ... other arguments passed on to \code{\link[ggplot2]{layer}}
#'
#' @export
geom_timeline <- function(mapping = NULL, data = NULL, stat = "identity",
                          position = "identity", na.rm = FALSE,
                          show.legend = NA, inherit.aes = TRUE, ...) {
  ggplot2::layer(
    geom = geom_timeline_proto_class, # this here is important
    mapping = mapping,
    data = data, stat = stat, position = position,
    show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

## function: draw_panel_function  ------------------------------------------------
#' @importFrom ggplot2 ggproto
#' @importFrom grid pointsGrob
#' @importFrom grid gpar
#'
#' @param data earth quake data set
#' @param panel_scales I don't know what that is
#' @param coord transformed data set
#'
#' @export
draw_panel_function <- function(data, panel_scales, coord) {

  coords <- coord$transform(data, panel_scales)

  coords <- coords[!base::is.na(coords$size), ]

  # resizing the points
  max_size <- base::max(coords$size)
  coords$size <- coords$size / max_size * 1.3
  grid::pointsGrob(
    x = coords$x,
    y = coords$y,
    pch = coords$shape,
    gp = grid::gpar(
      col = coords$colour,
      alpha = coords$alpha,
      cex = coords$size
    )
  )
}

## function: geom_timeline_proto_class ---------------------------------------------
#' Function creates the new geom (geom_timeline).
#'
#' @format NULL
#' @usage NULL
#'
#' @export
geom_timeline_proto_class <- ggplot2::ggproto("geom_timeline_proto_class", ggplot2::Geom,
                                              required_aes = c("x"),
                                              default_aes = ggplot2::aes(y = 0,
                                                                         fill = NA,
                                                                         colour = "grey3",
                                                                         alpha = 0.4,
                                                                         shape = 19,
                                                                         stroke = 0.5,
                                                                         size = 1
                                              ),
                                              draw_key = ggplot2::draw_key_point,

                                              draw_panel = draw_panel_function
)


## function: geom_timeline_label (building the layer)  --------------------------------
#' Function which builts the layer for the ggplot
#'
#' @importFrom ggplot2 layer
#'
#' @param mapping See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param data See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param stat See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param position See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param na.rm See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param show.legend See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param inherit.aes See \code{ggplot2} \code{\link[ggplot2]{layer}}
#' @param ... other arguments passed on to \code{\link[ggplot2]{layer}}
#'
#' @export
geom_timeline_label <- function(mapping = NULL, data = NULL, stat = "identity",
                                position = "identity", na.rm = FALSE,
                                show.legend = NA, inherit.aes = TRUE, ...) {
  ggplot2::layer(
    geom = geom_timeline_label_proto_class, # this here is important
    mapping = mapping,
    data = data, stat = stat, position = position,
    show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}




#' @importFrom ggplot2 ggproto
#' @importFrom grid pointsGrob
#' @importFrom grid gpar
#' @param data earth quake data set
#' @param panel_scales I don't know what that is
#' @param coord transformed data set

#' Make catagory names friendly to ggplot2 (helper funtion)
#'
#' Changes a string so it is enclosed in back-ticks.
#' This can be used to make column names that have spaces (blanks)
#' or non-letter characters acceptable to ggplot2.
#' This version of the function is vectorized with sapply.
#'
#' @param x string to make acceptable to ggplot2
#' @return x string made acceptable to ggplot2
#'
ggname <- function(x) {
  if (class(x) != "character") {
    return(x)
  }
  y <- sapply(x, function(s) {
    if (!grepl("^`", s)) {
      s <- paste("`", s, sep="", collapse="")
    }
    if (!grepl("`$", s)) {
      s <- paste(s, "`", sep="", collapse="")
    }
  }
  )
  y
}

## function: draw_panel_function  ------------------------------------------------
#' Outsourced function which builts the plot
#'
#' @format NULL
#' @usage NULL
#'
#' @export
draw_panel_function_label <- function(data, panel_scales, coord) {

  coords <- coord$transform(data, panel_scales)

  n_max <- coords$n_max[1]

  data <- data %>%
    dplyr::group_by(group) %>%
    dplyr::top_n(n_max, magnitude)
  # vertical line
  data$xend <- data$x
  data$yend <- data$y + 0.08
  gg_vertical <- ggplot2::GeomSegment$draw_panel(data, panel_scales, coord)

  data$fill <- "black"
  data$stroke <- 1.6 # point size
  gg_point <- ggplot2::GeomPoint$draw_panel(data, panel_scales, coord)

  # text
  data$y <- data$yend + 0.01
  data$angle <- 30
  data$fontface <- 11 # fonts
  data$lineheight <- 1
  data$hjust <- "left"
  data$vjust <- "bottom"
  data$family <- "sans"
  data$size <- 4.5
  gg_text <- ggplot2::GeomText$draw_panel(data, panel_scales, coord)
  ggname("geom_timeline_label", grid::grobTree(gg_vertical, gg_text, gg_point))

}

## function: geom_timeline_label_proto_class ---------------------------------------------
#' @param required_aes necessary aes inputs for the geom
#' @param default_aes default values
#' @param draw_key function to draw the legend with the associated geom
#' @param draw_panel where the magic is happening

#' @importFrom ggplot2 ggproto
#' @importFrom ggplot2 Geom
#' @importFrom ggplot2 aes
#' @importFrom ggplot2 draw_key_point
#'
#' @export
geom_timeline_label_proto_class <- ggplot2::ggproto("geom_timeline_label_proto_class", ggplot2::Geom,
                                                    required_aes = c("x", "label", "magnitude"),
                                                    default_aes = ggplot2::aes(y = 0,
                                                                               n_max = 3,
                                                                               colour = "grey3",
                                                                               alpha = NA,
                                                                               shape = 19,
                                                                               linetype = 1,
                                                                               size = 0.3
                                                    ),
                                                    draw_key = ggplot2::draw_key_point,
                                                    draw_panel = draw_panel_function_label
)

#######################################################################################################################
### WEEK 3 ############################################################################################################
#######################################################################################################################

#' Visualization of Earth Quakes
#'
#' \code{eq_map} creates a Leaflet map, adds a polygon according to the chosen
#' country and adds the earthquakes as points (size according to magnitude)
#'
#' @param data_filtered A dataframe
#' @param annot_col Which column shall be displayed in the pop-up
#'
#' @importFrom magrittr "%>%"
#' @importFrom dplyr mutate_
#' @importFrom leaflet leaflet addTiles addProviderTiles addPolygons addCircleMarkers
#' @importFrom stringr str_to_title
#'
#' @return this function gives back a leaflet map. It includes various features.
#'
#' @examples
#' require(magrittr)
#' data("NOAAearthquakes")
#'
#' map_ex <- NOAAearthquakes %>%
#' dplyr::filter(COUNTRY == "MEXICO" & lubridate::year(date) >= 2000) %>%
#' eq_map(annot_col = "date")
#' map_ex
#'
#' @export
eq_map <- function(data_filtered, annot_col = "date") {

  data(world)
  involved_countries <- base::unique(data_filtered$COUNTRY)

  data_filtered <- data_filtered %>%
    dplyr::mutate_(popup_col = base::as.name(annot_col))

  m <- leaflet::leaflet(data_filtered) %>%
    leaflet::addTiles() %>%
    leaflet::addProviderTiles("OpenMapSurfer.Roads") %>%  # OpenTopoMap
    leaflet::addPolygons(data = base::subset(world, name %in% stringr::str_to_title(involved_countries)),
                         weight = 2,
                         opacity = 0.8,
                         fillOpacity = 0.3,
                         fillColor = "red") %>%
    leaflet::addCircleMarkers(
      lng = ~LONGITUDE,
      lat = ~LATITUDE,
      radius = ~EQ_PRIMARY^1.4, # 1.4: scale factor; only for visual effects
      weight = 3,
      color = c('maroon'),
      label = ~base::as.character(EQ_PRIMARY),
      popup = ~base::as.character(popup_col)
    )
  m
}

#' Creates Labes for the leaflet map
#' \code{eq_map} creates a string / character combining some information to display
#' in the pop-up
#'
#' @param data This data frame is the whole earth quake data
#'
#' @return this function gives back a vector with character strings
#'
#' @examples
#' require(magrittr)
#' data("NOAAearthquakes")
#'
#' map_example <- NOAAearthquakes %>%
#' dplyr::filter(COUNTRY == "MEXICO" & lubridate::year(date) >= 2000) %>%
#' dplyr::mutate(popup_text = eq_create_label(.)) %>%
#' eq_map(annot_col = "popup_text")
#' map_example
#'
#' @export
eq_create_label <- function(data) {

  txt <- base::paste0("<b>Country: </b>", data$COUNTRY, "<br/>",
                      "<b>Location: </b>", data$LOCATION_NAME,  "<br/>",
                      "<b>Magnitude: </b>", data$EQ_PRIMARY,  "<br/>",
                      "<b>Total Deaths: </b>", data$TOTAL_DEATHS, "<br/>",
                      "<b>Date: </b>", data$date)
}