Djm/autoplot

DESCRIPTION

@@ -26,13 +26,15 @@ Description: This package introduces a common data structure for epidemiological
 License: MIT + file LICENSE
 Copyright: file inst/COPYRIGHTS
 Imports:
+    checkmate,
     cli,
     data.table,
     dplyr (>= 1.0.0),
     fabletools,
     feasts,
     generics,
     genlasso,
+    ggplot2,
     lifecycle (>= 1.0.1),
     lubridate,
     magrittr,
@@ -49,7 +51,6 @@ Imports:
 Suggests:
     covidcast,
     epidatr,
-    ggplot2,
     knitr,
     outbreaks,
     rmarkdown,
@@ -66,12 +67,13 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Depends:
     R (>= 2.10)
 URL: https://cmu-delphi.github.io/epiprocess/
 Collate:
     'archive.R'
+    'autoplot.R'
     'correlation.R'
     'data.R'
     'epi_df.R'
@@ -80,6 +82,7 @@ Collate:
     'methods-epi_archive.R'
     'grouped_epi_archive.R'
     'growth_rate.R'
+    'key_colnames.R'
     'methods-epi_df.R'
     'outliers.R'
     'reexports.R'

NAMESPACE

@@ -8,6 +8,7 @@ S3method(as_epi_df,tbl_df)
 S3method(as_epi_df,tbl_ts)
 S3method(as_tibble,epi_df)
 S3method(as_tsibble,epi_df)
+S3method(autoplot,epi_df)
 S3method(dplyr_col_modify,col_modify_recorder_df)
 S3method(dplyr_col_modify,epi_df)
 S3method(dplyr_reconstruct,epi_df)
@@ -20,6 +21,10 @@ S3method(group_by,grouped_epi_archive)
 S3method(group_by_drop_default,grouped_epi_archive)
 S3method(group_modify,epi_df)
 S3method(groups,grouped_epi_archive)
+S3method(key_colnames,data.frame)
+S3method(key_colnames,default)
+S3method(key_colnames,epi_archive)
+S3method(key_colnames,epi_df)
 S3method(next_after,Date)
 S3method(next_after,integer)
 S3method(print,epi_df)
@@ -34,6 +39,7 @@ export(arrange)
 export(as_epi_archive)
 export(as_epi_df)
 export(as_tsibble)
+export(autoplot)
 export(detect_outlr)
 export(detect_outlr_rm)
 export(detect_outlr_stl)
@@ -51,6 +57,7 @@ export(growth_rate)
 export(is_epi_archive)
 export(is_epi_df)
 export(is_grouped_epi_archive)
+export(key_colnames)
 export(max_version_with_row_in)
 export(mutate)
 export(new_epi_df)
@@ -61,6 +68,10 @@ export(slice)
 export(ungroup)
 export(unnest)
 importFrom(R6,R6Class)
+importFrom(checkmate,anyInfinite)
+importFrom(checkmate,assert)
+importFrom(checkmate,assert_character)
+importFrom(checkmate,assert_int)
 importFrom(cli,cli_inform)
 importFrom(data.table,":=")
 importFrom(data.table,address)
@@ -89,6 +100,7 @@ importFrom(dplyr,rename)
 importFrom(dplyr,select)
 importFrom(dplyr,slice)
 importFrom(dplyr,ungroup)
+importFrom(ggplot2,autoplot)
 importFrom(lubridate,days)
 importFrom(lubridate,weeks)
 importFrom(magrittr,"%>%")

R/autoplot.R

@@ -0,0 +1,166 @@
+#' Automatically plot an epi_df
+#'
+#' @param object An `epi_df`
+#' @param ... <[`tidy-select`][dplyr_tidy_select]> One or more unquoted
+#'   expressions separated by commas. Variable names can be used as if they
+#'   were positions in the data frame, so expressions like `x:y` can
+#'   be used to select a range of variables.
+#' @param .color_by Which variables should determine the color(s) used to plot
+#'   lines. Options include:
+#'   * `all_keys` - the default uses the interaction of any key variables
+#'     including the `geo_value`
+#'   * `geo_value` - `geo_value` only
+#'   * `other_keys` - any available keys that are not `geo_value`
+#'   * `.response` - the numeric variables (same as the y-axis)
+#'   * `all` - uses the interaction of all keys and numeric variables
+#'   * `none` - no coloring aesthetic is applied
+#' @param .facet_by Similar to `.color_by` except that the default is to display
+#'   each numeric variable on a separate facet
+#' @param .base_color Lines will be shown with this color. For example, with a
+#'   single numeric variable and faceting by `geo_value`, all locations would
+#'   share the same color line.
+#' @param .max_facets Cut down of the number of facets displayed. Especially
+#'   useful for testing when there are many `geo_value`'s or keys.
+#'
+#' @return A ggplot object
+#' @export
+#'
+#' @examples
+#' autoplot(jhu_csse_daily_subset, cases, death_rate_7d_av)
+#' autoplot(jhu_csse_daily_subset, case_rate_7d_av, .facet_by = "geo_value")
+#' autoplot(jhu_csse_daily_subset, case_rate_7d_av,
+#'   .color_by = "none",
+#'   .facet_by = "geo_value"
+#' )
+#' autoplot(jhu_csse_daily_subset, case_rate_7d_av, .color_by = "none",
+#'   .base_color = "red", .facet_by = "geo_value")
+#'
+#' # .base_color specification won't have any effect due .color_by default
+#' autoplot(jhu_csse_daily_subset, case_rate_7d_av,
+#'   .base_color = "red", .facet_by = "geo_value")
+autoplot.epi_df <- function(
+    object, ...,
+    .color_by = c("all_keys", "geo_value", "other_keys", ".response", "all", "none"),
+    .facet_by = c(".response", "other_keys", "all_keys", "geo_value", "all", "none"),
+    .base_color = "#3A448F",
+    .max_facets = Inf) {
+  .color_by <- match.arg(.color_by)
+  .facet_by <- match.arg(.facet_by)
+
+  assert(anyInfinite(.max_facets), assert_int(.max_facets), combine = "or")
+  assert_character(.base_color, len = 1)
+
+  key_cols <- key_colnames(object)
+  non_key_cols <- setdiff(names(object), key_cols)
+  geo_and_other_keys <- kill_time_value(key_cols)
+
+  # --- check for numeric variables
+  allowed <- purrr::map_lgl(object[non_key_cols], is.numeric)
+  allowed <- allowed[allowed]
+  if (length(allowed) == 0 && rlang::dots_n(...) == 0L) {
+    cli::cli_abort("No numeric variables were available to plot automatically.",
+      class = "epiprocess__no_numeric_vars_available")
+  }
+  vars <- tidyselect::eval_select(rlang::expr(c(...)), object)
+  if (rlang::is_empty(vars)) { # find them automatically if unspecified
+    vars <- tidyselect::eval_select(names(allowed)[1], object)
+    cli::cli_warn(
+      "Plot variable was unspecified. Automatically selecting {.var {names(allowed)[1]}}.",
+      class = "epiprocess__unspecified_plot_var"
+    )
+  } else { # if variables were specified, ensure that they are numeric
+    ok <- names(vars) %in% names(allowed)
+    if (!any(ok)) {
+      cli::cli_abort(
+        "None of the requested variables {.var {names(vars)}} are numeric.",
+        class = "epiprocess__all_requested_vars_not_numeric"
+      )
+    } else if (!all(ok)) {
+      cli::cli_warn(c(
+        "Only the requested variables {.var {names(vars)[ok]}} are numeric.",
+        i = "`autoplot()` cannot display {.var {names(vars)[!ok]}}."
+      ),
+      class = "epiprocess__some_requested_vars_not_numeric")
+      vars <- vars[ok]
+    }
+  }
+
+  # --- create a viable df to plot
+  pos <- tidyselect::eval_select(
+    rlang::expr(c("time_value", tidyselect::all_of(geo_and_other_keys), names(vars))), object
+  )
+  if (length(vars) > 1) {
+    object <- tidyr::pivot_longer(
+      object[pos], tidyselect::all_of(names(vars)),
+      values_to = ".response",
+      names_to = ".response_name"
+    )
+  } else {
+    object <- dplyr::rename(object[pos], .response := !!names(vars))
+  }
+  all_keys <- rlang::syms(as.list(geo_and_other_keys))
+  other_keys <- rlang::syms(as.list(setdiff(geo_and_other_keys, "geo_value")))
+  all_avail <- rlang::syms(as.list(c(geo_and_other_keys, ".response_name")))
+
+  object <- object %>%
+    dplyr::mutate(
+      .colours = switch(.color_by,
+        all_keys = interaction(!!!all_keys, sep = "/"),
+        geo_value = geo_value,
+        other_keys = interaction(!!!other_keys, sep = "/"),
+        all = interaction(!!!all_avail, sep = "/"),
+        NULL
+      ),
+      .facets = switch(.facet_by,
+        all_keys = interaction(!!!all_keys, sep = "/"),
+        geo_value = as.factor(geo_value),
+        other_keys = interaction(!!!other_keys, sep = "/"),
+        all = interaction(!!!all_avail, sep = "/"),
+        NULL
+      )
+    )
+
+  if (.max_facets < Inf && ".facets" %in% names(object)) {
+    n_facets <- nlevels(object$.facets)
+    if (n_facets > .max_facets) {
+      top_n <- levels(as.factor(object$.facets))[seq_len(.max_facets)]
+      object <- dplyr::filter(object, .facets %in% top_n) %>%
+        dplyr::mutate(.facets = droplevels(.facets))
+      if (".colours" %in% names(object)) {
+        object <- dplyr::mutate(object, .colours = droplevels(.colours))
+      }
+    }
+  }
+
+  p <- ggplot2::ggplot(object, ggplot2::aes(x = .data$time_value)) +
+    ggplot2::theme_bw()
+
+  if (".colours" %in% names(object)) {
+    p <- p + ggplot2::geom_line(
+      ggplot2::aes(y = .data$.response, colour = .data$.colours),
+      key_glyph = "timeseries"
+    ) +
+      ggplot2::scale_colour_viridis_d(name = "")
+  } else if (length(vars) > 1 && .color_by == ".response") {
+    p <- p +
+      ggplot2::geom_line(ggplot2::aes(
+        y = .data$.response, colour = .data$.response_name
+      )) +
+      ggplot2::scale_colour_viridis_d(name = "")
+  } else { # none
+    p <- p +
+      ggplot2::geom_line(ggplot2::aes(y = .data$.response), color = .base_color)
+  }
+
+  if (".facets" %in% names(object)) {
+    p <- p + ggplot2::facet_wrap(~.facets, scales = "free_y") +
+      ggplot2::ylab(names(vars))
+    if (.facet_by == "all") p <- p + ggplot2::ylab("")
+  } else if ((length(vars) > 1 && .facet_by == ".response")) {
+    p <- p + ggplot2::facet_wrap(~.response_name, scales = "free_y") +
+      ggplot2::ylab("")
+  } else {
+    p <- p + ggplot2::ylab(names(vars))
+  }
+  p
+}

R/epiprocess.R

@@ -4,7 +4,7 @@
 #' measured over space and time, and offers associated utilities to perform
 #' basic signal processing tasks.
 #'
-#' @docType package
+#' @importFrom checkmate assert assert_character assert_int anyInfinite
 #' @name epiprocess
-NULL
+"_PACKAGE"
 utils::globalVariables(c(".x", ".group_key", ".ref_time_value"))

R/key_colnames.R

@@ -0,0 +1,40 @@
+#' Grab any keys associated to an epi_df
+#'
+#' @param x a data.frame, tibble, or epi_df
+#' @param ... additional arguments passed on to methods
+#'
+#' @return If an `epi_df`, this returns all "keys". Otherwise `NULL`
+#' @keywords internal
+#' @export
+key_colnames <- function(x, ...) {
+  UseMethod("key_colnames")
+}
+
+#' @export
+key_colnames.default <- function(x, ...) {
+  character(0L)
+}
+
+#' @export
+key_colnames.data.frame <- function(x, other_keys = character(0L), ...) {
+  assert_character(other_keys)
+  nm <- c("time_value", "geo_value", other_keys)
+  intersect(nm, colnames(x))
+}
+
+#' @export
+key_colnames.epi_df <- function(x, ...) {
+  other_keys <- attr(x, "metadata")$other_keys
+  c("time_value", "geo_value", other_keys)
+}
+
+#' @export
+key_colnames.epi_archive <- function(x, ...) {
+  other_keys <- attr(x, "metadata")$other_keys
+  c("time_value", "geo_value", other_keys)
+}
+
+kill_time_value <- function(v) {
+  assert_character(v)
+  v[v != "time_value"]
+}

R/reexports.R

@@ -55,3 +55,10 @@ dplyr::slice
 #' @importFrom tidyr unnest
 #' @export
 tidyr::unnest
+
+
+# ggplot2 -----------------------------------------------------------------
+
+#' @importFrom ggplot2 autoplot
+#' @export
+ggplot2::autoplot

R/utils.R

@@ -478,13 +478,13 @@ quiet <- function(x) {
 
 # Create an auto-named list
 enlist <- function(...) {
-  x <- list(...)
-  n <- as.character(sys.call())[-1]
-  if (!is.null(n0 <- names(x))) {
-    n[n0 != ""] <- n0[n0 != ""]
-  }
-  names(x) <- n
-  return(x)
+  # converted to thin wrapper around
+  rlang::dots_list(
+    ...,
+    .homonyms = "error",
+    .named = TRUE,
+    .check_assign = TRUE
+  )
 }
 
 # Variable assignment from a list. NOT USED. Something is broken, this doesn't

_pkgdown.yml

@@ -80,9 +80,13 @@ reference:
           - archive_cases_dv_subset
           - incidence_num_outlier_example
           - contains("jhu_csse")
+    - title: Basic automatic plotting
+    - contents:
+          - autoplot.epi_df
     - title: internal
-      contents:
+    - contents:
           - epiprocess
           - max_version_with_row_in
           - next_after
           - guess_period
+          - key_colnames