Merge pull request #230 from cmu-delphi/enumerate-steps-layers-print

In printing of an `epi_workflow`, number steps and layers

Author: dajmcdon

NAMESPACE

@@ -52,6 +52,7 @@ S3method(print,alist)
 S3method(print,arx_class)
 S3method(print,arx_fcast)
 S3method(print,canned_epipred)
+S3method(print,epi_recipe)
 S3method(print,epi_workflow)
 S3method(print,flat_fcast)
 S3method(print,flatline)
@@ -71,6 +72,7 @@ S3method(print,step_epi_ahead)
 S3method(print,step_epi_lag)
 S3method(print,step_growth_rate)
 S3method(print,step_lag_difference)
+S3method(print,step_naomit)
 S3method(print,step_population_scaling)
 S3method(print,step_training_window)
 S3method(quantile,dist_quantiles)

R/epi_recipe.R

@@ -410,3 +410,132 @@ kill_levels <- function(x, keys) {
   for (i in which(names(x) %in% keys)) x[[i]] <- list(values = NA, ordered = NA)
   x
 }
+
+#' @export
+print.epi_recipe <- function(x, form_width = 30, ...) {
+  cli::cli_div(theme = list(.pkg = list("vec-trunc" = Inf, "vec-last" = ", ")))
+
+  cli::cli_h1("Epi Recipe")
+  cli::cli_h3("Inputs")
+
+  tab <- table(x$var_info$role, useNA = "ifany")
+  tab <- stats::setNames(tab, names(tab))
+  names(tab)[is.na(names(tab))] <- "undeclared role"
+
+  roles <- c("outcome", "predictor", "case_weights", "undeclared role")
+
+  tab <- c(
+    tab[names(tab) == roles[1]],
+    tab[names(tab) == roles[2]],
+    tab[names(tab) == roles[3]],
+    sort(tab[!names(tab) %in% roles], TRUE),
+    tab[names(tab) == roles[4]]
+  )
+
+  cli::cli_text("Number of variables by role")
+
+  spaces_needed <- max(nchar(names(tab))) - nchar(names(tab)) +
+    max(nchar(tab)) - nchar(tab)
+
+  cli::cli_verbatim(
+    glue::glue("{names(tab)}: {strrep('\ua0', spaces_needed)}{tab}")
+  )
+
+  if ("tr_info" %in% names(x)) {
+    cli::cli_h3("Training information")
+    nmiss <- x$tr_info$nrows - x$tr_info$ncomplete
+    nrows <- x$tr_info$nrows
+
+    cli::cli_text(
+      "Training data contained {nrows} data points and {cli::no(nmiss)} \\
+       incomplete row{?s}."
+    )
+  }
+
+  if (!is.null(x$steps)) {
+    cli::cli_h3("Operations")
+  }
+
+  i = 1
+  for (step in x$steps) {
+    cat(paste0(i, ". "))
+    print(step, form_width = form_width)
+    i = i + 1
+  }
+  cli::cli_end()
+
+  invisible(x)
+}
+
+# Currently only used in the workflow printing
+print_preprocessor_recipe <- function(x, ...) {
+
+  recipe <- workflows::extract_preprocessor(x)
+  steps <- recipe$steps
+  n_steps <- length(steps)
+  if (n_steps == 1L) {
+    step <- "Step"
+  }
+  else {
+    step <- "Steps"
+  }
+  n_steps_msg <- glue::glue("{n_steps} Recipe {step}")
+  cat_line(n_steps_msg)
+
+  if (n_steps == 0L) return(invisible(x))
+
+  cat_line("")
+
+  step_names <- map_chr(steps, workflows:::pull_step_name)
+
+  if (n_steps <= 10L) {
+    cli::cli_ol(step_names)
+    return(invisible(x))
+  }
+
+  extra_steps <- n_steps - 10L
+  step_names <- step_names[1:10]
+
+  if (extra_steps == 1L) {
+    step <- "step"
+  }
+  else {
+    step <- "steps"
+  }
+
+  extra_dots <- "..."
+  extra_msg <- glue::glue("and {extra_steps} more {step}.")
+
+  cli::cli_ol(step_names)
+  cli::cli_bullets(c(extra_dots, extra_msg))
+  invisible(x)
+}
+
+print_preprocessor <- function(x) {
+
+  has_preprocessor_formula <- workflows:::has_preprocessor_formula(x)
+  has_preprocessor_recipe <- workflows:::has_preprocessor_recipe(x)
+  has_preprocessor_variables <- workflows:::has_preprocessor_variables(x)
+
+  no_preprocessor <- !has_preprocessor_formula && !has_preprocessor_recipe &&
+    !has_preprocessor_variables
+
+  if (no_preprocessor) {
+    return(invisible(x))
+  }
+
+  cat_line("")
+  header <- cli::rule("Preprocessor")
+  cat_line(header)
+
+  if (has_preprocessor_formula) {
+    workflows:::print_preprocessor_formula(x)
+  }
+  if (has_preprocessor_recipe) {
+      print_preprocessor_recipe(x)
+  }
+  if (has_preprocessor_variables) {
+    workflows:::print_preprocessor_variables(x)
+  }
+  invisible(x)
+}

R/epi_workflow.R

@@ -218,8 +218,8 @@ new_epi_workflow <- function(
 #' @export
 print.epi_workflow <- function(x, ...) {
   print_header(x)
-  workflows:::print_preprocessor(x)
-  # workflows:::print_case_weights(x)
+  print_preprocessor(x)
+  #workflows:::print_case_weights(x)
   workflows:::print_model(x)
   print_postprocessor(x)
   invisible(x)

R/frosting.R

@@ -294,7 +294,12 @@ print.frosting <- function(x, form_width = 30, ...) {
   cli::cli_h1("Frosting")
 
   if (!is.null(x$layers)) cli::cli_h3("Layers")
-  for (layer in x$layers) print(layer, form_width = form_width)
+  i = 1
+  for (layer in x$layers){
+    cat(paste0(i, ". "))
+    print(layer, form_width = form_width)
+    i = i + 1
+  }
   cli::cli_end()
   invisible(x)
 }
@@ -316,7 +321,7 @@ print_frosting <- function(x, ...) {
   layer_names <- map_chr(layers, pull_layer_name)
 
   if (n_layers <= 10L) {
-    cli::cat_bullet(layer_names)
+    cli::cli_ol(layer_names)
     return(invisible(x))
   }
 
@@ -328,9 +333,8 @@ print_frosting <- function(x, ...) {
   extra_dots <- "..."
   extra_msg <- glue::glue("and {extra_layers} more {layer}.")
 
-  layer_names <- c(layer_names, extra_dots, extra_msg)
-
-  cli::cat_bullet(layer_names)
+  cli::cli_ol(layer_names)
+  cli::cli_bullets(c(extra_dots, extra_msg))
   invisible(x)
 }
 

R/print_epi_step.R

@@ -44,8 +44,8 @@ print_epi_step <- function(
   )
   more_dots <- ifelse(first_line == length(elements), "", ", ...")
   cli::cli_bullets(
-    c(`*` = "\n    {title}: \\\n    {.pkg {cli::cli_vec(elements[seq_len(first_line)])}}\\\n    {more_dots} \\\n    {conjunction} \\\n    {.pkg {extra_text}} \\\n    {vline_seperator} \\\n    {.emph {trained_text}}\\\n    {comma_seperator} \\\n    {.emph {case_weights_text}}\n    ")
-  )
+    c("\n    {title}: \\\n    {.pkg {cli::cli_vec(elements[seq_len(first_line)])}}\\\n    {more_dots} \\\n    {conjunction} \\\n    {.pkg {extra_text}} \\\n    {vline_seperator} \\\n    {.emph {trained_text}}\\\n    {comma_seperator} \\\n    {.emph {case_weights_text}}\n    "))
+
   cli::cli_end(theme_div_id)
   invisible(NULL)
 }

R/print_layer.R

@@ -25,7 +25,7 @@ print_layer <- function(
   )
   more_dots <- ifelse(first_line == length(elements), "", ", ...")
   cli::cli_bullets(
-    c(`*` = "\n    {title}: \\\n    {.pkg {elements[seq_len(first_line)]}}\\\n    {more_dots} \\\n    {conjunction} \\\n    {.pkg {extra_text}}")
-  )
+    c("\n    {title}: \\\n    {.pkg {elements[seq_len(first_line)]}}\\\n    {more_dots} \\\n    {conjunction} \\\n    {.pkg {extra_text}}"))
+
   invisible(NULL)
 }

R/step_epi_naomit.R

@@ -17,3 +17,11 @@ step_epi_naomit <- function(recipe) {
     recipes::step_naomit(all_predictors(), skip = FALSE) %>%
     recipes::step_naomit(all_outcomes(), skip = TRUE)
 }
+
+#' @export
+print.step_naomit <- # not exported from recipes package
+  function(x, width = max(20, options()$width - 30), ...) {
+    title <- "Removing rows with NA values in "
+    print_step(x$columns, x$terms, x$trained, title, width)
+    invisible(x)
+  }