Rv/refactor create metrics

.github/workflows/R-CMD-check.yaml

@@ -10,7 +10,7 @@ jobs:
       - uses: r-lib/actions/setup-r@master
       - name: Install dependencies
         run: |
-          install.packages(c("remotes", "rcmdcheck"))
+          install.packages(c("remotes", "rcmdcheck", "pillar"))
           remotes::install_deps(dependencies = TRUE)
         shell: Rscript {0}
       - name: Check

R/create-metrics.R

@@ -1,18 +1,46 @@
 #' Given a metric tbl and an Rmd file, turn into a named list of metric objects
 #'
-#' @param ... One or more metric tables in wide metric format: one column for each metric.
+#' @param ... One or more metric tables in wide metric format: one column for
+#'   each metric.
 #' @param rmd_file The Rmd file that generated the compact metrics, which has
-#' documentation for the metrics and dimensions stored in the YAML front matter.
-#' If no Rmd file is given, it uses the currently running one.
-#'
-#' @return A named list of metric objects. Each of these has both the data and the metadata
-#' (documentation, dimensions, owner, etc) to make an interactive visualization.
+#'   documentation for the metrics and dimensions stored in the YAML front
+#'   matter. If no Rmd file is given, it uses the currently running one.
+#' @param category A string indicating a category for the metric. It overrides
+#'   the values in the `rmd_file` and the default values.
+#' @param subcategory A string indicating a subcategory for the metric. It
+#'   overrides the values in the `rmd_file` and the default values.
+#' @param metrics A named list of metrics. Each item in the list should have a
+#'   title and a description. It overrides the values in the `rmd_file` and the
+#'   defaults values.
+#' @param dimensions A named list of dimensions. Each item in the list should
+#'   have a title and a description. It overrides the values in the `rmd_file`
+#'   and the defaults values.
+#' @param owner A string indicating an owner for the metric.  It overrides the
+#'   values in the `rmd_file` and the default values.
+#' @return A named list of metric objects. Each of these has both the data and
+#'   the metadata (documentation, dimensions, owner, etc) to make an interactive
+#'   visualization.
 #'
 #' @examples
 #'
 #' # TODO
 #' @export
-create_metrics <- function(..., rmd_file = NULL) {
+create_metrics <- function(...,
+                           rmd_file = NULL,
+                           category = NULL,
+                           subcategory = NULL,
+                           metrics = NULL,
+                           dimensions = NULL,
+                           owner = NULL) {
+  # Get documentation
+  metric_docs <- get_metric_docs(
+    rmd_file,
+    category = category,
+    subcategory = subcategory, metrics = metrics,
+    dimensions = dimensions, owner = owner,
+    ...
+  )
+
   metrics <- list(...)
 
   if (length(metrics) == 0) {
@@ -30,20 +58,22 @@ create_metrics <- function(..., rmd_file = NULL) {
 
     return(all_metrics)
   }
+
   # Now there's just one metric dataset, so construct it
   data <- metrics[[1]]
 
-  metric_docs <- get_metric_docs(rmd_file)
-
   # an Rmd always has same category/subcategory
   category <- metric_docs[[1]]$category
   subcategory <- metric_docs[[1]]$subcategory
 
   data_nested <- data %>%
     gather_metrics() %>%
     filter(!is.na(value)) %>%
-    tidyr::nest_legacy(-metric) %>%
-    dplyr::mutate(metric_full = paste(category, subcategory, metric, sep = "_"))
+    tidyr::nest(data = -metric) %>%
+    dplyr::mutate(metric_full = purrr::map_chr(metric, ~ {
+      y <- c(category, subcategory, .x)
+      paste(y[y != ""], collapse = "_")
+    }))
 
   missing_metrics <- setdiff(data_nested$metric_full, names(metric_docs))
   if (length(missing_metrics) > 0) {
@@ -80,56 +110,59 @@ create_metrics <- function(..., rmd_file = NULL) {
   purrr::map(ret, prune_dimensions)
 }
 
-get_metric_docs <- function(rmd_file = NULL) {
+# Get metadata from an Rmd document
+get_rmd_metadata <- function(rmd_file = NULL) {
   if (!is.null(rmd_file)) {
-    metric_docs <- parse_metrics_header(rmarkdown::yaml_front_matter(rmd_file))
+    rmarkdown::yaml_front_matter(rmd_file)
   } else if (length(rmarkdown::metadata) > 0) {
-    metric_docs <- parse_metrics_header(rmarkdown::metadata)
-  } else {
-    # If running in RStudio, get the current document
+    rmarkdown::metadata
+  } else if (interactive()){
     rmd_file <- rstudioapi::getActiveDocumentContext()$path
-
-    if (!stringr::str_detect(rmd_file, "\\.Rmd$")) {
-      stop(
-        "create_metrics must either be given the path to an Rmd file, run in a rendered Rmd, ",
-        "or be run in RStudio as part of the Rmd (that is, by pressing CMD-RETURN with your ",
-        "cursor in the Rmd, not e.g. copy-pasted into the R terminal)."
-      )
-    }
-
-    metric_docs <- parse_metrics_header(rmarkdown::yaml_front_matter(rmd_file))
+    rmarkdown::yaml_front_matter(rmd_file)
+  } else {
+    list()
   }
-  return(metric_docs)
 }
 
+# Get metric documentation
+get_metric_docs <- function(rmd_file = NULL,
+                            category = NULL,
+                            subcategory = NULL,
+                            owner = NULL,
+                            metrics = NULL,
+                            dimensions = NULL,
+                            ...) {
+  y <- get_rmd_metadata(rmd_file)
+  `%||%` <- function(x, y) {
+    if (is.null(x)) y else x
+  }
 
-## Internal utility functions for create_metrics
-
-parse_metrics_header <- function(y) {
-  name_components <- stringr::str_split(y$name, "_")[[1]]
-
-  shared <- c(
-    list(
-      category = name_components[2],
-      subcategory = name_components[3]
-    ),
-    y[c("owner", "dimensions")]
+  name_components <- if (!is.null(y$name)) {
+    stringr::str_split(y$name, "_")[[1]]
+  } else {
+    c()
+  }
+  shared <- list(
+    category = category %||% y$category %||% name_components[2] %||% "",
+    subcategory = subcategory %||% y$subcategory %||% name_components[3] %||% "",
+    owner = owner %||% y$owner %||% "",
+    dimensions = dimensions %||% y$dimensions %||% doc_dimensions(...)
   )
+  metrics <- metrics %||% y$metrics %||% doc_metrics(...)
 
-  ret <- purrr::map(names(y$metrics), ~ c(
-    list(
-      metric = .,
-      metric_full = paste(name_components[2],
-        name_components[3],
-        .,
-        sep = "_"
+  docs <- names(metrics) %>%
+    purrr::map(~ {
+      y <- c(shared$category, shared$subcategory, .x)
+      c(
+        metrics[[.x]],
+        shared,
+        list(
+          metric = .x,
+          metric_full = paste(y[y != ""], collapse = "_")
+        )
       )
-    ),
-    y$metrics[[.]],
-    shared
-  ))
-  names(ret) <- purrr::map(ret, "metric_full")
-  ret
+    })
+  rlang::set_names(docs, purrr::map(docs, "metric_full"))
 }
 
 combine_metric <- function(data, metadata) {
@@ -144,10 +177,14 @@ combine_metric <- function(data, metadata) {
 
     if (!is.null(levs) && dimension_name %in% colnames(data)) {
       if (any(duplicated(levs))) {
-        stop(glue::glue("Duplicated levels in { dimension_name } in { metadata$metric }"))
+        stop(glue::glue(
+          "Duplicated levels in { dimension_name } in { metadata$metric }"
+        ))
       }
 
-      data[[dimension_name]] <- forcats::fct_relevel(data[[dimension_name]], c("All", levs))
+      data[[dimension_name]] <- forcats::fct_relevel(
+        data[[dimension_name]], c("All", levs)
+      )
     }
   }
 

R/cross-dimensions.R

@@ -94,9 +94,21 @@ cross_by_dimensions <- function(tbl, ..., add = TRUE, max_dimensions = NULL,
   }
 
   # Regroup
-  tbl %>%
-    group_by_at(vars(g_vars)) %>%
-    group_by(!!!columns, add = add)
+  # NOTE: dplyr 1.0.0 deprecates add in favor of .add
+  if (has_add()){
+    tbl %>%
+      group_by_at(vars(g_vars)) %>%
+      group_by(!!!columns, add = add)
+  } else {
+    tbl %>%
+      group_by_at(vars(g_vars)) %>%
+      group_by(!!!columns, .add = add)
+  }
+
+}
+
+has_add <- function(){
+  'add' %in% names(formals(dplyr::group_by))
 }
 
 cross_by_dimensions_limited <- function(tbl, column_symbols, max_dimensions,

R/cross-periods.R

@@ -128,10 +128,16 @@ cross_by_periods.tbl_df <- function(tbl,
     intervals = intervals
   )
 
-  tbl %>%
+  tbl <- tbl %>%
     rename(date_original = date) %>%
-    inner_join(date_periods, by = "date_original") %>%
-    group_by(period, date, add = TRUE)
+    inner_join(date_periods, by = "date_original")
+
+  if (has_add()){
+    group_by(tbl, period, date, add = TRUE)
+  } else {
+    group_by(tbl, period, date, .add = TRUE)
+  }
+
 }
 
 check_cross_by_tbl <- function(tbl) {

R/generate-date-periods.R

@@ -36,7 +36,8 @@ generate_date_periods <- function(start,
   if (length(windows) > 0) {
     window_offsets <- tibble::tibble(window_size = windows) %>%
       dplyr::mutate(period = paste0("rolling_", window_size, "d")) %>%
-      tidyr::unnest(offset = purrr::map(window_size, seq_len)) %>%
+      dplyr::mutate(offset = purrr::map(window_size, seq_len)) %>%
+      tidyr::unnest(offset) %>%
       dplyr::mutate(offset = offset - 1)
 
     window_periods <- tibble(date_original = dates) %>%

R/use-metrics-scaffold.R

@@ -30,7 +30,7 @@ use_metrics_scaffold <- function(tbl) {
 
   names_dimensions <- var_names_dimensions(tbl)
   dimensions <- names_dimensions %>%
-    purrr::map(~ list(title = "<TODO>", description = "<TODO>")) %>%
+    purrr::map(~ list(title = .x, description = .x)) %>%
     rlang::set_names(names_dimensions)
 
   if (length(dimensions) == 0) {
@@ -42,10 +42,49 @@ use_metrics_scaffold <- function(tbl) {
     colnames()
 
   metrics <- names_metrics %>%
-    purrr::map(~ list(title = "<TODO>", description = "<TODO>")) %>%
+    purrr::map(~ list(title = .x, description = .x)) %>%
     rlang::set_names(names_metrics)
 
   out <- list(metrics = metrics, dimensions = dimensions)
   cat(yaml::as.yaml(out))
   invisible(out)
 }
+
+doc_dimensions <- function(...) {
+  names_dimensions <- list(...) %>%
+    purrr::map(ungroup) %>%
+    purrr::map(var_names_dimensions) %>%
+    purrr::keep(~ length(.x) > 0) %>%
+    unlist()
+
+  ret <- names_dimensions %>%
+    purrr::map(~ list(title = .x, description = .x)) %>%
+    rlang::set_names(names_dimensions)
+  message(
+    "Using default docs for dimensions. ",
+    "Please copy to YAML frontmatter of Rmd and edit"
+  )
+  cat(yaml::as.yaml(list(dimensions = ret)))
+  invisible(ret)
+}
+
+doc_metrics <- function(...) {
+  names_metrics <- list(...) %>%
+    purrr::map(ungroup) %>%
+    purrr::map(~ {
+      names_metrics <- .x %>%
+        select_if(is.numeric) %>%
+        colnames()
+    }) %>%
+    rlang::squash_chr() %>%
+    unique()
+  ret <- names_metrics %>%
+    purrr::map(~ list(title = .x, description = .x)) %>%
+    rlang::set_names(names_metrics)
+  message(
+    "Using default docs for metrics. ",
+    "Please copy to YAML frontmatter of Rmd and edit"
+  )
+  cat(yaml::as.yaml(list(metrics = ret)))
+  invisible(ret)
+}

tests/spelling.R

@@ -1,3 +1,6 @@
-if(requireNamespace('spelling', quietly = TRUE))
-  spelling::spell_check_test(vignettes = TRUE, error = FALSE,
-                             skip_on_cran = TRUE)
+if (requireNamespace("spelling", quietly = TRUE)) {
+  spelling::spell_check_test(
+    vignettes = TRUE, error = FALSE,
+    skip_on_cran = TRUE
+  )
+}