R/map-value-sets.R

In scrutiny: Error Detection in Science

#' Map a single-case function over its caller's arguments
#'
#' `map_value_sets()` applies `fn` once per value set, taking the arguments
#' of the function that calls it, such as `grim()`. That wrapper's signature
#' must mirror `fn`'s, minus `show_rec` and `show_reason`, plus any
#' deprecated argument it handles before calling `map_value_sets()`:
#'
#' ```
#' grim <- function(x, n, digits_x, items_averaged, data_type,
#'                  x_meaning = c("mean", "percentage"),
#'                  rounding = "up_or_down", threshold = 5, symmetric = FALSE,
#'                  percent = deprecated()) {
#'   if (lifecycle::is_present(percent)) {
#'     stop_percent("grim")
#'   }
#'   map_value_sets(
#'     grim_scalar,
#'     c("x", "n", "digits_x", "items_averaged", "data_type")
#'   )
#' }
#' ```
#'
#' @param fn The `*_scalar()` function to apply, e.g. `grim_scalar()`.
#' @param along String vector naming the arguments to vectorize over: the key
#'   arguments, their `digits_*` arguments, and the helper arguments
#'   `items_averaged` and `data_type` where the test has them. Every other
#'   argument must be length 1. This is the mapper tier's
#'   split: `along` is what `function_map()` takes from `data`, the rest is
#'   what it passes as constants for the whole call.
#' @param type String. The type of the return value: `"logical"` for the
#'   tests, `"list"` for `grim_values()` and the like, whose `fn` returns a
#'   tibble per value set, which `bind_cases()` then stacks.
#'
#' @return Vector of `type`, as long as the recycled `along` arguments.
#'
#' @noRd
map_value_sets <- function(fn, along, type = "logical") {
  frame <- parent.frame()
  formals_wrapper <- formals(sys.function(sys.parent()))
  args_all <- names(formals_wrapper)

  # A wrapper with no formals has no value sets to map over:
  if (length(args_all) == 0L) {
    return(vector(type, 0L))
  }

  # Arguments the caller left out are not forwarded, so `fn` applies its own
  # defaults, the same as the wrapper's, and raises its own error where it has
  # none: `digits_x` must arrive missing so that `error_digits_missing()` fires.
  #
  # Not `match.call()`: a wrapper reached through `lapply()` is called as
  # `FUN(X[[i]], ...)`, and matching that fails with "... used in a situation
  # where it does not exist".
  calls_missing <- missing_arg_calls(args_all)

  is_supplied <- !vapply(
    calls_missing,
    eval,
    logical(1L),
    envir = frame,
    USE.NAMES = FALSE
  )

  args_supplied <- args_all[is_supplied]
  vals <- mget(args_supplied, envir = frame)

  names_along <- along[along %in% args_supplied]
  names_scalar <- args_supplied[!args_supplied %in% along]

  for (name in names_along) {
    check_not_data_frame(vals[[name]], name)
    check_not_integer64(vals[[name]], name)
  }

  # Tested as the whole numbers they are accepted as; see `round_whole()`:
  for (name in intersect(ARGS_WHOLE, names_along)) {
    check_not_factor(vals[[name]], name)
    vals[[name]] <- round_whole(vals[[name]])
  }

  # An enum such as `sd_meaning` given as its whole default set is one string,
  # as in the mappers, before the length check below would reject it:
  vals <- resolve_enums(
    vals,
    eval_enum_defaults(formals_wrapper[names_scalar], frame)
  )

  # Arguments that say *how* to test rather than *what* describe the call as a
  # whole: one call cannot use two rounding methods, and `x` is either a
  # percentage or it isn't.
  # The mapper's name is only needed for the error, and finding it walks the
  # stack, which would take most of a call's time, so it's left unevaluated:
  for (name in names_scalar) {
    check_setting_length(
      name,
      vals[[name]],
      along,
      paste0(name_last_export(), "_map")
    )
  }

  # roundwork checks the rounding arguments once per value set, but its errors
  # would name the roundwork function instead of the wrapper:
  if ("rounding" %in% args_all) {
    spec <- lapply(
      c(
        rounding = "rounding",
        threshold = "threshold",
        symmetric = "symmetric"
      ),
      function(name) {
        if (name %in% args_supplied) {
          vals[[name]]
        } else {
          eval(formals_wrapper[[name]])
        }
      }
    )
    check_rounding_args(spec$rounding, spec$threshold, spec$symmetric)
  }

  # If a required argument is missing, let `fn` raise its error here rather
  # than inside the loop, so that it is raised once. With the first value set
  # only: `fn` takes single values, and a vector would fail its own checks
  # with R's message before it reached the missing argument:
  for (name in args_all[!args_all %in% args_supplied]) {
    if (identical(formals_wrapper[[name]], quote(expr = ))) {
      # `fn` has errors of its own for these, which say how to fix them. R's
      # error for any other would name `fn`, which the user never called:
      if (
        !startsWith(name, "digits_") &&
          !name %in% c("items_averaged", "data_type")
      ) {
        abort_in_export("Need to specify {.arg {name}}.")
      }
      vals_first <- vals
      for (name_along in names_along) {
        vals_first[name_along] <- list(vals[[name_along]][1L])
      }
      return(do.call(fn, vals_first))
    }
  }

  # A `NULL` is no value set; `digits_x = NULL` would silently return
  # `logical(0)`:
  for (name in names_along) {
    if (is.null(vals[[name]])) {
      abort_in_export("{.arg {name}} must not be `NULL`.")
    }
  }

  lengths_along <- lengths(vals[names_along])
  length_out <- recycle_length_common(lengths_along, names_along)

  if (length_out == 0L) {
    return(vector(type, 0L))
  }

  vals_along <- vals[names_along]

  for (name in names_along[lengths_along != length_out]) {
    vals_along[[name]] <- rep_len(vals_along[[name]], length_out)
  }

  # `.mapply()` is `mapply()` without the argument matching and the
  # `simplify2array()` that would turn a list return into a matrix:
  results <- .mapply(fn, vals_along, MoreArgs = vals[names_scalar])

  out <- if (type == "list") results else unlist(results, use.names = FALSE)

  # Anything but one value of `type` per value set is a bug in scrutiny:
  if (typeof(out) != type || length(out) != length_out) {
    cli::cli_abort(
      c(
        "Internal error: `fn` returned {length(out)} \\
      {.cls {typeof(out)}} value{?s} for {length_out} value set{?s}.",
        "i" = "It must return one {type} value per value set."
      ),
      .internal = TRUE
    )
  }

  out
}


#' Stack the tibbles of `map_value_sets(type = "list")` into one
#'
#' @param results List of tibbles, one per value set.
#' @param ptype Zero-row tibble with the output's columns, `case` first, for
#'   the case of no value sets at all.
#'
#' @return Tibble with a `case` column, the index of the value set, and the
#'   columns of `ptype` with its types, except that `n` and `items_averaged`
#'   are integer only where they fit, as in the mappers.
#'
#' @noRd
bind_cases <- function(results, ptype) {
  out <- purrr::list_rbind(results, names_to = "case")
  if (ncol(out) == 0L) {
    return(ptype)
  }
  for (col in colnames(ptype)) {
    out[[col]] <- if (col %in% ARGS_WHOLE) {
      as_integer_if_lossless(out[[col]])
    } else {
      # E.g. a `sum` from `seq()` is integer, one from `sum_range()` double:
      vctrs::vec_cast(out[[col]], ptype[[col]])
    }
  }
  out
}


#' `missing()` calls for a wrapper's formals
#'
#' Returns `list(quote(missing(x)), quote(missing(n)), ...)`, to be evaluated
#' in the wrapper's frame. The list depends only on the formals' names, so it
#' is cached by them. Building it per call costs about as much as evaluating
#' it, and a `grim()` called one value set at a time pays that on every call.
#'
#' @param args_all String vector. Names of the wrapper's formals.
#'
#' @return List of calls.
#'
#' @noRd
missing_arg_calls <- function(args_all) {
  key <- paste(args_all, collapse = ",")
  calls <- cache_missing_arg_calls[[key]]

  if (is.null(calls)) {
    calls <- lapply(args_all, function(name) call("missing", as.name(name)))
    cache_missing_arg_calls[[key]] <- calls
  }

  calls
}

cache_missing_arg_calls <- new.env(parent = emptyenv())


#' Common length of arguments that are recycled against each other
#'
#' Tidyverse recycling rules: a length-1 argument is recycled to the length of
#' the others, and everything else must already have that length.
#'
#' @param lengths_args Integer vector of argument lengths.
#' @param names_args String vector of the corresponding argument names.
#'
#' @return Integer (length 1).
#'
#' @noRd
recycle_length_common <- function(lengths_args, names_args) {
  lengths_free <- lengths_args[lengths_args != 1L]

  if (length(lengths_free) == 0L) {
    return(if (length(lengths_args) == 0L) 0L else 1L)
  }

  length_out <- max(lengths_free)
  is_offender <- lengths_args != 1L & lengths_args != length_out

  if (any(is_offender)) {
    name_first <- names_args[lengths_args == length_out][1L]
    names_offenders <- names_args[is_offender]
    abort_in_export(
      "Can't recycle {.arg {name_first}} (length {length_out}) to match \\
      {.arg {names_offenders}} (length {lengths_args[is_offender]}).",
      "i" = "Arguments that are tested for consistency with each other \\
      must have the same length, or length 1."
    )
  }

  as.integer(length_out)
}