columnFormula: point errors at the culprit and warn about missing columns

R/columnFormula.R

@@ -10,6 +10,11 @@
 #'   The default, `NULL`, creates a one-sided formula.
 #' @param intercept A single logical value indicating whether to include an
 #'   intercept. Defaults to `TRUE`.
+#' @param checkColumns A single logical value. When `TRUE` (the default) and a
+#'   dataset is available as `data` or `filteredData` (as in the R Commander),
+#'   a warning points out every column that does not exist and suggests close
+#'   matches. The check is skipped when no dataset is available; use `FALSE`
+#'   to disable it entirely.
 #'
 #' @details Arguments are evaluated normally, so variables holding column names
 #'   and expressions such as `measurements[[i]]` can be used directly. Names are
@@ -31,24 +36,84 @@
 #' lapply(measurements, columnFormula)
 #'
 #' @export
-columnFormula <- function(..., dependent = NULL, intercept = TRUE) {
+columnFormula <- function(..., dependent = NULL, intercept = TRUE, checkColumns = TRUE) {
   columns <- list(...)
-  validColumns <- vapply(columns, function(x) {
-    is.character(x) && is.null(dim(x)) && !anyNA(x) && all(nzchar(x))
-  }, logical(1))
-  if (!all(validColumns))
-    stop("`...` must contain character vectors of non-empty column names without NA values.", call. = FALSE)
+
+  for (i in seq_along(columns)) {
+    column <- columns[[i]]
+
+    if (is.null(column))
+      stop(sprintf(paste0("Argument %d in `...` is NULL, but column names must be text.\n",
+                          "Did you mistype a column name? `data$Name` is NULL when the column does not exist."),
+                   i),
+           call. = FALSE)
+
+    if (is.character(column) && is.null(dim(column))) {
+      naIndexes <- which(is.na(column))
+      if (length(naIndexes))
+        stop(sprintf("Element%s %s of argument %d in `...` %s NA, but column names must be text.",
+                     if (length(naIndexes) == 1L) "" else "s",
+                     paste(naIndexes, collapse = ", "), i,
+                     if (length(naIndexes) == 1L) "is" else "are"),
+             call. = FALSE)
+
+      emptyIndexes <- which(!nzchar(column))
+      if (length(emptyIndexes))
+        stop(sprintf('Element%s %s of argument %d in `...` %s an empty string (""), but column names must not be empty.',
+                     if (length(emptyIndexes) == 1L) "" else "s",
+                     paste(emptyIndexes, collapse = ", "), i,
+                     if (length(emptyIndexes) == 1L) "is" else "are"),
+               call. = FALSE)
+    } else {
+      hint <- if (is.factor(column))
+        "Wrap it in as.character(), e.g. as.character(data[[\"LL.nominal\"]])."
+      else if (is.numeric(column))
+        "If these are column positions, use names(data)[...] to get their names."
+      else if (inherits(column, "formula"))
+        "This is already a formula: pass it directly instead."
+      else if (is.list(column))
+        "Use do.call(columnFormula, names) for one formula from a list of names, or lapply(names, columnFormula) for one formula per name."
+      else
+        "Column names must be text, e.g. columnFormula(\"part length\")."
+
+      stop(sprintf("Argument %d in `...` must be a character vector of column names, but it is %s.\n%s",
+                   i, .columnFormulaDescribed(column), hint),
+           call. = FALSE)
+    }
+  }
 
   if (!is.null(dependent) &&
       (!is.character(dependent) || !is.null(dim(dependent)) ||
-       length(dependent) != 1L || anyNA(dependent) || !nzchar(dependent)))
-    stop("`dependent` must be NULL or a single non-empty column name without an NA value.", call. = FALSE)
+       length(dependent) != 1L || is.na(dependent) || !nzchar(dependent))) {
+    hint <- if (is.factor(dependent))
+      "Wrap it in as.character()."
+    else if (is.numeric(dependent))
+      "If this is a column position, use names(data)[...] to get its name."
+    else
+      "It must be one column name, e.g. dependent = \"strength\"."
+
+    stop(sprintf("`dependent` must be a single column name, but it is %s.\n%s",
+                 .columnFormulaDescribed(dependent), hint),
+         call. = FALSE)
+  }
 
   if (!is.logical(intercept) || !is.null(dim(intercept)) ||
       length(intercept) != 1L || is.na(intercept))
-    stop("`intercept` must be TRUE or FALSE.", call. = FALSE)
+    stop(sprintf("`intercept` must be TRUE or FALSE, but it is %s. To leave out the intercept use `intercept = FALSE`.",
+                 .columnFormulaDescribed(intercept)),
+         call. = FALSE)
+
+  if (!is.logical(checkColumns) || !is.null(dim(checkColumns)) ||
+      length(checkColumns) != 1L || is.na(checkColumns))
+    stop(sprintf("`checkColumns` must be TRUE or FALSE, but it is %s.",
+                 .columnFormulaDescribed(checkColumns)),
+         call. = FALSE)
+
+  allNames <- unlist(columns, use.names = FALSE)
+  if (checkColumns)
+    .columnFormulaCheckColumns(c(dependent, allNames), parent.frame())
 
-  symbols <- lapply(unlist(columns, use.names = FALSE), as.name)
+  symbols <- lapply(allNames, as.name)
   rhs <- if (length(symbols))
     Reduce(function(left, right) call("+", left, right), symbols)
   else
@@ -63,3 +128,68 @@ columnFormula <- function(..., dependent = NULL, intercept = TRUE) {
 
   stats::as.formula(result, env = parent.frame())
 }
+
+# Describe an object for use in the error messages above, e.g. `the string "x"` or `a factor`.
+.columnFormulaDescribed <- function(x) {
+  if (is.null(x))
+    return("NULL")
+  if (inherits(x, "formula"))
+    return(paste0("a formula (", paste(deparse(x), collapse = " "), ")"))
+  if (!is.null(dim(x)))
+    return(paste0("a ", class(x)[1L], " with dimensions ", paste(dim(x), collapse = "x")))
+  if (is.factor(x))
+    return("a factor")
+  if (is.list(x))
+    return("a list")
+  if (is.character(x)) {
+    preview <- paste0('"', head(x, 3L), '"', collapse = ", ")
+    if (length(x) == 1L)
+      return(paste0("the string ", preview))
+    return(paste0("a character vector of length ", length(x), " (", preview, ")"))
+  }
+  if (is.numeric(x) || is.logical(x)) {
+    preview <- paste(head(x, 3L), collapse = ", ")
+    kind <- if (is.numeric(x)) "number" else "logical value"
+    if (length(x) == 1L)
+      return(paste0("the ", kind, " ", preview))
+    return(paste0(length(x), " ", kind, "s (", preview, ")"))
+  }
+  paste0("a ", class(x)[1L])
+}
+
+# Warn about names that do not exist in the dataset visible to the caller. Pure feedback: it
+# never errors, and it stays silent when there is no dataset (no `data`/`filteredData` in
+# scope) or when the encoder helpers from the engine are unavailable.
+.columnFormulaCheckColumns <- function(names, callerEnv) {
+  dataset <- get0("data", envir = callerEnv, inherits = TRUE)
+  if (!is.data.frame(dataset) || ncol(dataset) == 0L) {
+    dataset <- get0("filteredData", envir = callerEnv, inherits = TRUE)
+    if (!is.data.frame(dataset) || ncol(dataset) == 0L)
+      return(invisible(NULL))
+  }
+
+  encodeStrict <- get0(".encodeColNamesStrict", envir = callerEnv, inherits = TRUE)
+  if (!is.function(encodeStrict))
+    return(invisible(NULL))
+
+  suggest <- get0(".suggestColumnNames", envir = callerEnv, inherits = TRUE)
+
+  for (name in unique(names)) {
+    encoded <- tryCatch(encodeStrict(name), error = function(e) NULL)
+    if (!is.null(encoded) && nzchar(encoded))
+      next
+
+    warningMessage <- sprintf('No column named "%s" in the dataset.', name)
+
+    suggestions <- if (is.function(suggest)) suggest(name) else character(0)
+    if (length(suggestions)) {
+      quoted <- paste0('"', suggestions, '"')
+      joined <- if (length(quoted) == 2L) paste(quoted, collapse = " or ") else paste(quoted, collapse = ", ")
+      warningMessage <- paste0(warningMessage, " Did you mean ", joined, "?")
+    }
+
+    warning(warningMessage, call. = FALSE)
+  }
+
+  invisible(NULL)
+}

tests/testthat/test-columnFormula.R

@@ -62,4 +62,152 @@ testthat::test_that("invalid inputs produce clear errors", {
 
   for (intercept in list(NULL, NA, c(TRUE, FALSE), 1, "TRUE", matrix(TRUE)))
     testthat::expect_error(columnFormula("x", intercept = intercept), "`intercept`", fixed = TRUE)
+
+  for (checkColumns in list(NULL, NA, c(TRUE, FALSE), 1, "TRUE", matrix(TRUE)))
+    testthat::expect_error(columnFormula("x", checkColumns = checkColumns), "`checkColumns`", fixed = TRUE)
+})
+
+testthat::test_that("errors name the offending argument and suggest a fix", {
+  testthat::expect_error(columnFormula(NULL),
+                         "Argument 1 in `...` is NULL, but column names must be text.", fixed = TRUE)
+  testthat::expect_error(columnFormula(NULL),
+                         "`data$Name` is NULL when the column does not exist.", fixed = TRUE)
+  testthat::expect_error(columnFormula("x", NULL),
+                         "Argument 2 in `...` is NULL", fixed = TRUE)
+
+  testthat::expect_error(columnFormula(factor("x")),
+                         "Argument 1 in `...` must be a character vector of column names, but it is a factor.",
+                         fixed = TRUE)
+  testthat::expect_error(columnFormula(factor("x")),
+                         'as.character(data[["LL.nominal"]])', fixed = TRUE)
+
+  testthat::expect_error(columnFormula(1),
+                         "Argument 1 in `...` must be a character vector of column names, but it is the number 1.",
+                         fixed = TRUE)
+  testthat::expect_error(columnFormula(1:3),
+                         "If these are column positions, use names(data)[...]", fixed = TRUE)
+
+  testthat::expect_error(columnFormula(~ x),
+                         "but it is a formula (~", fixed = TRUE)
+  testthat::expect_error(columnFormula(~ x),
+                         "This is already a formula: pass it directly instead.", fixed = TRUE)
+
+  testthat::expect_error(columnFormula(list("x")), "but it is a list.", fixed = TRUE)
+  testthat::expect_error(columnFormula(list("x")),
+                         "do.call(columnFormula, names)", fixed = TRUE)
+  testthat::expect_error(columnFormula(list("x")),
+                         "lapply(names, columnFormula)", fixed = TRUE)
+
+  testthat::expect_error(columnFormula(c("x", NA_character_)),
+                         "Element 2 of argument 1 in `...` is NA", fixed = TRUE)
+  testthat::expect_error(columnFormula(c("x", NA_character_, NA_character_)),
+                         "Elements 2, 3 of argument 1 in `...` are NA", fixed = TRUE)
+  testthat::expect_error(columnFormula(c("x", "")),
+                         'Element 2 of argument 1 in `...` is an empty string ("")', fixed = TRUE)
+
+  testthat::expect_error(columnFormula("x", dependent = c("y1", "y2")),
+                         '`dependent` must be a single column name, but it is a character vector of length 2 ("y1", "y2").',
+                         fixed = TRUE)
+  testthat::expect_error(columnFormula("x", dependent = factor("y")),
+                         "`dependent` must be a single column name, but it is a factor.", fixed = TRUE)
+  testthat::expect_error(columnFormula("x", dependent = 3),
+                         "If this is a column position, use names(data)[...]", fixed = TRUE)
+
+  testthat::expect_error(columnFormula("x", intercept = "TRUE"),
+                         '`intercept` must be TRUE or FALSE, but it is the string "TRUE".', fixed = TRUE)
+  testthat::expect_error(columnFormula("x", intercept = "TRUE"),
+                         "To leave out the intercept use `intercept = FALSE`.", fixed = TRUE)
+
+  testthat::expect_error(columnFormula("x", checkColumns = NA),
+                         "`checkColumns` must be TRUE or FALSE, but it is the logical value NA.", fixed = TRUE)
+})
+
+# Stubs that stand in for the engine's encoder helpers so the typo check can be tested
+# outside JASP. The real `.encodeColNamesStrict()` errors for anything that is not a
+# column and `.suggestColumnNames()` returns close matches from ColumnEncoder.
+.stubEncodeStrict <- function(columns) {
+  function(name) if (name %in% columns) paste0("encoded:", name) else stop("not a column: ", name)
+}
+
+.stubSuggest <- function(columns) {
+  function(name) {
+    distance <- as.vector(utils::adist(tolower(name), tolower(columns)))
+    keep <- distance <= 2
+    columns[keep][order(distance[keep])]
+  }
+}
+
+# Install a fake dataset plus the stubs into the calling environment: columnFormula()'s
+# typo check looks up `data`, `.encodeColNamesStrict()` and `.suggestColumnNames()`
+# starting from its caller. test_that blocks get a fresh environment, so nothing leaks.
+.stubDataset <- function(columns) {
+  env <- parent.frame()
+  data <- data.frame(matrix(rep(1:2, length(columns)), nrow = 2), check.names = FALSE)
+  names(data) <- columns
+  assign("data", data, envir = env)
+  assign(".encodeColNamesStrict", .stubEncodeStrict(columns), envir = env)
+  assign(".suggestColumnNames", .stubSuggest(columns), envir = env)
+  invisible(NULL)
+}
+
+testthat::test_that("unknown columns get a did-you-mean warning when a dataset is visible", {
+  .stubDataset(c("part length", "temperature"))
+
+  testthat::expect_warning(columnFormula("Part length"),
+                           'No column named "Part length" in the dataset. Did you mean "part length"?',
+                           fixed = TRUE)
+  testthat::expect_warning(columnFormula("temprature"),
+                           'No column named "temprature" in the dataset. Did you mean "temperature"?',
+                           fixed = TRUE)
+
+  testthat::expect_no_warning(columnFormula("part length"))
+  testthat::expect_no_warning(columnFormula("part length", dependent = "temperature"))
+
+  testthat::expect_warning(columnFormula("part length", dependent = "Temprature"),
+                           'No column named "Temprature" in the dataset. Did you mean "temperature"?',
+                           fixed = TRUE)
+})
+
+testthat::test_that("each unknown column gets its own warning", {
+  .stubDataset(c("part length", "temperature"))
+
+  warningsCaught <- testthat::capture_warnings(columnFormula("Part length", "temprature"))
+  testthat::expect_length(warningsCaught, 2L)
+  testthat::expect_true(any(grepl('No column named "Part length"', warningsCaught, fixed = TRUE)))
+  testthat::expect_true(any(grepl('No column named "temprature"', warningsCaught, fixed = TRUE)))
+})
+
+testthat::test_that("the typo check stays silent without a dataset, and checkColumns = FALSE disables it", {
+  data <- NULL
+  filteredData <- NULL
+  testthat::expect_no_warning(columnFormula("Part length"))
+
+  data <- data.frame()
+  .encodeColNamesStrict <- .stubEncodeStrict(character(0))
+  .suggestColumnNames <- .stubSuggest(character(0))
+  testthat::expect_no_warning(columnFormula("Part length"))
+
+  testthat::expect_no_warning(columnFormula("Part length", checkColumns = FALSE))
+})
+
+testthat::test_that("without the suggest helper the warning names the column but suggests nothing", {
+  data <- data.frame(1:2, check.names = FALSE)
+  names(data) <- "part length"
+  .encodeColNamesStrict <- .stubEncodeStrict("part length")
+  .suggestColumnNames <- NULL
+
+  testthat::expect_warning(columnFormula("Part length"),
+                           'No column named "Part length" in the dataset.', fixed = TRUE)
+})
+
+testthat::test_that("filteredData is checked when data is not bound", {
+  data <- NULL
+  filteredData <- data.frame(1:2, check.names = FALSE)
+  names(filteredData) <- "part length"
+  .encodeColNamesStrict <- .stubEncodeStrict("part length")
+  .suggestColumnNames <- .stubSuggest("part length")
+
+  testthat::expect_warning(columnFormula("Part length"),
+                           'No column named "Part length" in the dataset. Did you mean "part length"?',
+                           fixed = TRUE)
 })