Fix label and indentation processors

NEWS.md

@@ -1,5 +1,8 @@
 # tern 0.9.7.9000
 
+### Bug Fixes
+* Fixed bug in `a_count_patients_with_flags()` preventing select custom label and indentation specification formats from being applied.
+
 # tern 0.9.7
 
 ### Enhancements

R/analyze_variables.R

@@ -576,7 +576,7 @@ a_summary <- function(x,
   ) {
     stop(
       "For comparison (compare_with_ref_group = TRUE), the reference group must be specified.",
-      "\nSee split_fun in spit_cols_by()."
+      "\nSee ref_group in split_cols_by()."
     )
   }
 
@@ -602,10 +602,13 @@ a_summary <- function(x,
   )
 
   x_stats <- x_stats[.stats]
+
   if (is.character(x) || is.factor(x)) {
     levels_per_stats <- lapply(x_stats, names) # if there is a count is table() with levels
+    rep_lbl <- sapply(names(levels_per_stats), function(x) levels_per_stats[x] == x)
+    levels_per_stats[rep_lbl] <- list(NULL)
   } else {
-    levels_per_stats <- NULL
+    levels_per_stats <- names(x_stats)
   }
 
   # Formats checks

R/count_patients_with_flags.R

@@ -129,28 +129,23 @@ a_count_patients_with_flags <- function(df,
     df = df, .var = .var, flag_variables = flag_variables, flag_labels = flag_labels,
     .N_col = .N_col, .N_row = .N_row, denom = denom
   )
+  if (is.null(names(flag_variables))) flag_variables <- formatters::var_labels(df, fill = TRUE)[flag_variables]
+  if (is.null(flag_labels)) flag_labels <- flag_variables
 
   if (is.null(unlist(x_stats))) {
     return(NULL)
   }
 
   # Fill in with formatting defaults if needed
   .stats <- get_stats("count_patients_with_flags", stats_in = .stats)
-  x_stats <- x_stats[.stats]
-
   .formats <- get_formats_from_stats(.stats, .formats)
-
-  # label formatting
-  x_nms <- paste(rep(.stats, each = length(flag_variables)), flag_variables, sep = ".")
-  new_lbls <- if (!is.null(.labels)) .labels[names(.labels) %in% x_nms] else NULL
-  .labels <- .unlist_keep_nulls(get_labels_from_stats(.stats, .labels,
-    levels_per_stats = lapply(x_stats, names)
-  )) %>%
-    setNames(x_nms)
-
-  # indent mod formatting
   .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = flag_variables)
+  x_nms <- paste(rep(.stats, each = length(flag_variables)), names(flag_variables), sep = ".")
+  .labels <- .unlist_keep_nulls(
+    get_labels_from_stats(.stats, .labels, levels_per_stats = rep(flag_labels, length(.stats)) %>% setNames(x_nms))
+  )
 
+  x_stats <- x_stats[.stats]
 
   # Ungroup statistics with values for each level of x
   x_ungrp <- ungroup_stats(x_stats, .formats, list())

R/utils_default_stats_formats_labels.R

@@ -221,7 +221,7 @@ get_stat_names <- function(stat_results, stat_names_in = NULL) {
 #'   character vector from [formatters::list_valid_format_labels()] or a custom format function.
 #'
 #' @return
-#' * `get_formats_from_stats()` returns a named vector of formats (if present in either
+#' * `get_formats_from_stats()` returns a named list of formats (if present in either
 #'   `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from
 #'   [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).
 #'
@@ -252,21 +252,15 @@ get_formats_from_stats <- function(stats, formats_in = NULL) {
     checkmate::assert_character(formats_in, null.ok = TRUE)
   }
 
-  # Extract global defaults
-  which_fmt <- match(stats, names(tern_default_formats))
+  # Add dummy formats for each row
+  formats_stats <- rep(NA_character_, length(stats)) %>% setNames(stats)
 
-  # Select only needed formats from stats
-  ret <- vector("list", length = length(stats)) # Returning a list is simpler
-  ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]
+  # Apply custom formats
+  out <- .adjust_stats_desc_by_in_def(formats_stats, formats_in, tern_default_formats)
 
-  out <- setNames(ret, stats)
-
-  # Modify some with custom formats
-  if (!is.null(formats_in)) {
-    # Stats is the main
-    common_names <- intersect(names(out), names(formats_in))
-    out[common_names] <- formats_in[common_names]
-  }
+  # Set missing formats to NULL
+  null_stats <- sapply(out, is.na) %>% suppressWarnings()
+  out[null_stats] <- list(NULL)
 
   out
 }
@@ -276,8 +270,8 @@ get_formats_from_stats <- function(stats, formats_in = NULL) {
 #'   the statistics name will be used as label.
 #'
 #' @param labels_in (named `character`)\cr inserted labels to replace defaults.
-#' @param levels_per_stats (named `list` of `character` or `NULL`)\cr Levels of a `factor` or `character` variable, each
-#'   of which the statistics in `.stats` will be calculated for. If this parameter is set, these
+#' @param levels_per_stats (named `list`/`vector` of `character` or `NULL`)\cr Levels of a `factor` or `character`
+#'   variable, each of which the statistics in `.stats` will be calculated for. If this parameter is set, these
 #'   variable levels will be used as the defaults, and the names of the given custom values should
 #'   correspond to levels (or have format `statistic.level`) instead of statistics. Can also be
 #'   variable names if rows correspond to different variables instead of levels. Defaults to `NULL`.
@@ -301,7 +295,6 @@ get_formats_from_stats <- function(stats, formats_in = NULL) {
 #' @export
 get_labels_from_stats <- function(stats, labels_in = NULL, levels_per_stats = NULL) {
   checkmate::assert_character(stats, min.len = 1)
-  checkmate::assert_list(levels_per_stats, null.ok = TRUE)
   # It may be a list
   if (checkmate::test_list(labels_in, null.ok = TRUE)) {
     checkmate::assert_list(labels_in, null.ok = TRUE)
@@ -310,27 +303,23 @@ get_labels_from_stats <- function(stats, labels_in = NULL, levels_per_stats = NU
     checkmate::assert_character(labels_in, null.ok = TRUE)
   }
 
-  # Default for stats with sublevels (for factors or chrs) are the labels
+  # Apply default labels for each row
   if (!is.null(levels_per_stats)) {
-    out <- .adjust_stats_desc_by_in_def(levels_per_stats, labels_in, tern_default_labels)
-    # numeric case, where there are not other levels (list of stats)
+    if (is.null(names(levels_per_stats))) {
+      levels_per_stats <- rep(NA_character_, length(levels_per_stats)) %>% setNames(levels_per_stats)
+    }
   } else {
-    which_lbl <- match(stats, names(tern_default_labels))
-
-    ret <- stats # The default
-    ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]
+    levels_per_stats <- rep(NA_character_, length(stats)) %>% setNames(stats)
+  }
 
-    out <- setNames(ret, stats)
+  # Apply custom labels
+  out <- .adjust_stats_desc_by_in_def(levels_per_stats, labels_in, tern_default_labels)
 
-    # Modify some with custom labels
-    if (!is.null(labels_in)) {
-      # Stats is the main
-      common_names <- intersect(names(out), names(labels_in))
-      out[common_names] <- unlist(labels_in[common_names], recursive = FALSE)
-    }
-  }
+  # Set missing labels to stat name
+  no_label <- sapply(out, is.na) %>% suppressWarnings()
+  out[no_label] <- names(out[no_label])
 
-  out
+  out %>% unlist()
 }
 
 #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics.
@@ -362,88 +351,72 @@ get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
     checkmate::assert_integerish(indents_in, null.ok = TRUE)
   }
 
+  # Single indentation level for all rows
   if (is.null(names(indents_in)) && length(indents_in) == 1) {
     out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1)
     return(out)
   }
 
-  if (!is.null(row_nms)) {
-    ret <- rep(0L, length(stats) * length(row_nms))
-    out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = "."))
-
-    if (!is.null(indents_in)) {
-      lvl_lbls <- intersect(names(indents_in), row_nms)
-      for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]]
-    }
+  # Get default indentation
+  all_nms <- if (is.null(row_nms)) {
+    stats
   } else {
-    ret <- rep(0L, length(stats))
-    out <- setNames(ret, stats)
-  }
-
-  # Modify some with custom labels
-  if (!is.null(indents_in)) {
-    # Stats is the main
-    common_names <- intersect(names(out), names(indents_in))
-    out[common_names] <- indents_in[common_names]
+    paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = ".")
   }
+  def_indent <- rep(0L, length(all_nms)) %>% setNames(all_nms)
 
-  out
+  # Apply custom indentation
+  out <- .adjust_stats_desc_by_in_def(def_indent, indents_in, NULL)
+  out %>% unlist()
 }
 
 # Function to loop over each stat and levels to set correct values
+# levels_per_stats - every combo of statistic & level must be represented
+# tern_defaults - one per statistic (names are statistic names)
+# Order of precedence by info present in name: level and stat > level > stat > other defaults
 .adjust_stats_desc_by_in_def <- function(levels_per_stats, user_in, tern_defaults) {
+  single_stats <- any(names(levels_per_stats) %in% names(tern_defaults))
+  if (is.list(levels_per_stats)) {
+    if (any(names(levels_per_stats) %in% names(tern_defaults))) single_stats <- FALSE
+    null_stats <- sapply(levels_per_stats, is.null)
+    levels_per_stats[null_stats] <- ""
+    levels_per_stats <- lapply(levels_per_stats, function(x) x %>% setNames(x)) %>% unlist()
+    levels_per_stats[names(which(null_stats))] <- NA_character_
+  }
   out <- levels_per_stats
 
-  # Seq over the stats levels (can be also flat (stat$NULL))
-  for (stat_i in seq_along(levels_per_stats)) {
-    # If you want to change all factor levels at once by statistic
-    common_stat_names <- intersect(names(levels_per_stats), names(user_in))
-
-    # Levels for each statistic
-    nm_of_levs <- levels_per_stats[[stat_i]]
-    # Special case in which only stat$NULL
-    if (is.null(nm_of_levs)) {
-      nm_of_levs <- "a single NULL level"
-    }
-
-    # Loop over levels for each statistic
-    for (lev_i in seq_along(nm_of_levs)) {
-      # If there are no further names (stat$NULL) push label (stat) down to lowest level
-      if (is.null(levels_per_stats[[stat_i]])) {
-        lev_val <- names(levels_per_stats[stat_i])
-        out[[stat_i]] <- lev_val
-      } else {
-        lev_val <- levels_per_stats[[stat_i]][[lev_i]]
-      }
-
-      # Add default if it is a stat at last level
-      if (lev_val %in% names(tern_defaults)) {
-        out[[stat_i]][[lev_i]] <- tern_defaults[[lev_val]]
-      }
-
-      # If a general stat was added to the custom labels
-      if (names(levels_per_stats[stat_i]) %in% names(user_in)) {
-        out[[stat_i]][[lev_i]] <- user_in[[names(levels_per_stats[stat_i])]]
-      }
-
-      # If a stat level (e.g. if it is counts levels from table) was added to the custom labels
-      if (lev_val %in% names(user_in)) {
-        out[[stat_i]][[lev_i]] <- user_in[[lev_val]]
-      }
-
-      # If stat_i.lev_val is added to labels_in
-      composite_stat_lev_nm <- paste(
-        names(levels_per_stats[stat_i]),
-        lev_val,
-        sep = "."
-      )
-      if (composite_stat_lev_nm %in% names(user_in)) {
-        out[[stat_i]][[lev_i]] <- user_in[[composite_stat_lev_nm]]
+  if (!single_stats) { # One row per combination of variable level and statistic
+    out <- sapply(
+      names(levels_per_stats),
+      function(x) {
+        if (x %in% names(user_in)) {
+          user_in[[x]]
+        } else {
+          stat_lvl <- regmatches(x, regexpr("[.]", x), invert = TRUE)[[1]]
+          stat <- stat_lvl[1]
+          lvl <- stat_lvl[2]
+          if (lvl %in% names(user_in)) {
+            user_in[[lvl]]
+          } else if (stat %in% names(user_in)) {
+            user_in[[stat]]
+          } else { # fill in gaps with tern defaults
+            if ((is.null(out[[x]]) | is.na(out[[x]]))) {
+              if (stat %in% names(tern_defaults)) tern_defaults[[stat]] else x
+            } else {
+              out[[x]]
+            }
+          }
+        }
       }
-
-      # Used by the unlist (to avoid count_fraction1, count_fraction2, etc.)
-      names(out[[stat_i]])[lev_i] <- lev_val
+    )
+  } else { # One row per statistic
+    if (!is.null(user_in)) {
+      common_stats <- intersect(names(out), names(user_in))
+      out[common_stats] <- user_in[common_stats]
     }
+    # fill in gaps with tern defaults
+    common_stats <- intersect(names(out[is.null(out) | is.na(out)]), names(tern_defaults))
+    out[common_stats] <- tern_defaults[common_stats]
   }
 
   out