Use more informative check_arg

R/2_ci.R

@@ -73,7 +73,7 @@ ci.glm <- function(x,
                    vcov_args = NULL,
                    verbose = TRUE,
                    ...) {
-  method <- match.arg(method, choices = c("profile", "wald", "normal", "residual"))
+  method <- .check_arg(method, c("profile", "wald", "normal", "residual"))
 
   # No robust vcov for profile method
   if (method == "profile") {

R/bootstrap_model.R

@@ -75,7 +75,7 @@ bootstrap_model.default <- function(model,
 
   insight::check_if_installed("boot")
 
-  type <- match.arg(type, choices = c("ordinary", "parametric", "balanced", "permutation", "antithetic"))
+  type <- .check_arg(type, c("ordinary", "parametric", "balanced", "permutation", "antithetic"))
   parallel <- match.arg(parallel)
 
   model_data <- data <- insight::get_data(model, verbose = FALSE) # nolint
@@ -156,7 +156,7 @@ bootstrap_model.merMod <- function(model,
                                    ...) {
   insight::check_if_installed("lme4")
 
-  type <- match.arg(type, choices = c("parametric", "semiparametric"))
+  type <- .check_arg(type, c("parametric", "semiparametric"))
   parallel <- match.arg(parallel)
 
   boot_function <- function(model) {
@@ -228,7 +228,7 @@ bootstrap_model.nestedLogit <- function(model,
                                         ...) {
   insight::check_if_installed("boot")
 
-  type <- match.arg(type, choices = c("ordinary", "balanced", "permutation", "antithetic"))
+  type <- .check_arg(type, c("ordinary", "balanced", "permutation", "antithetic"))
   parallel <- match.arg(parallel)
 
   model_data <- data <- insight::get_data(model, verbose = FALSE) # nolint

R/ci_generic.R

@@ -17,11 +17,13 @@
   if (is.null(method)) {
     method <- "wald"
   }
-  method <- match.arg(tolower(method), choices = c(
-    "wald", "ml1", "betwithin", "kr",
-    "satterthwaite", "kenward", "boot",
-    "profile", "residual", "normal"
-  ))
+  method <- tolower(method)
+  method <- .check_arg(
+    method,
+    c("wald", "ml1", "betwithin", "kr", "satterthwaite", "kenward", "boot",
+      "profile", "residual", "normal"
+    )
+  )
 
   effects <- match.arg(effects)
   component <- match.arg(component)

R/extract_random_variances.R

@@ -28,7 +28,7 @@
 
   # check for errors
   if (is.null(out) && isTRUE(verbose)) {
     insight::format_warning("Something went wrong when calculating random effects parameters. Only showing model's fixed effects now. You may use `effects=\"fixed\"` to speed up the call to `model_parameters()`.")
   }
 
   out
@@ -45,7 +45,7 @@
                                               ci_random = NULL,
                                               verbose = FALSE,
                                               ...) {
-  component <- match.arg(component, choices = c("all", "conditional", "zero_inflated", "zi", "dispersion"))
+  component <- .check_arg(component, c("all", "conditional", "zero_inflated", "zi", "dispersion"))
 
   out <- suppressWarnings(
     .extract_random_variances_helper(
@@ -208,7 +208,7 @@
   )
 
   # fix names for uncorrelated slope-intercepts
   pattern <- paste0("(", paste0(insight::find_random(model, flatten = TRUE), collapse = "|"), ")\\.\\d+$")
   out$Group <- gsub(pattern, "\\1", out$Group)
 
   # remove non-used columns
@@ -336,7 +336,7 @@
 
 # extract CI for random SD ------------------------
 
 .random_sd_ci <- function(model,
                           out,
                           ci_method,
                           ci, ci_random,

R/methods_glmmTMB.R

@@ -7,7 +7,7 @@
 #' @inheritParams simulate_model
 #' @rdname model_parameters.merMod
 #' @export
 model_parameters.glmmTMB <- function(model,
                                      ci = 0.95,
                                      ci_method = "wald",
                                      ci_random = NULL,
@@ -47,8 +47,8 @@
   ci_method <- .check_df_method(ci_method)
 
   # which components to return?
-  effects <- match.arg(effects, choices = c("fixed", "random", "all"))
-  component <- match.arg(component, choices = c("all", "conditional", "zi", "zero_inflated", "dispersion"))
+  effects <- .check_arg(effects, c("fixed", "random", "all"))
+  component <- .check_arg(component, c("all", "conditional", "zi", "zero_inflated", "dispersion"))
 
   # standardize only works for fixed effects...
   if (!is.null(standardize) && standardize != "refit") {
@@ -268,8 +268,8 @@
                        verbose = TRUE,
                        ...) {
   method <- tolower(method)
-  method <- match.arg(method, choices = c("wald", "normal", "ml1", "betwithin", "profile", "uniroot", "robust"))
-  component <- match.arg(component, choices = c("all", "conditional", "zi", "zero_inflated", "dispersion"))
+  method <- .check_arg(method, c("wald", "normal", "ml1", "betwithin", "profile", "uniroot", "robust"))
+  component <- .check_arg(component, c("all", "conditional", "zi", "zero_inflated", "dispersion"))
 
   if (is.null(.check_component(x, component, verbose = verbose))) {
     return(NULL)
@@ -315,8 +315,8 @@
                                    component = "all",
                                    verbose = TRUE,
                                    ...) {
-  component <- match.arg(component, choices = c("all", "conditional", "zi", "zero_inflated", "dispersion"))
-  effects <- match.arg(effects, choices = c("fixed", "random"))
+  component <- .check_arg(component, c("all", "conditional", "zi", "zero_inflated", "dispersion"))
+  effects <- .check_arg(effects, c("fixed", "random"))
 
   dot_args <- .check_dots(
     dots = list(...),
@@ -374,10 +374,10 @@
 #' @export
 simulate_model.glmmTMB <- function(model,
                                    iterations = 1000,
-                                   component = c("all", "conditional", "zi", "zero_inflated", "dispersion"),
+                                   component = "all",
                                    verbose = FALSE,
                                    ...) {
-  component <- match.arg(component)
+  component <- .check_arg(component, c("all", "conditional", "zi", "zero_inflated", "dispersion"))
   info <- insight::model_info(model, verbose = FALSE)
 
   ## TODO remove is.list() when insight 0.8.3 on CRAN

R/methods_lme4.R

@@ -193,22 +193,22 @@ model_parameters.merMod <- function(model,
   ci_method <- tolower(ci_method)
 
   if (isTRUE(bootstrap)) {
-    ci_method <- match.arg(
+    ci_method <- .check_arg(
       ci_method,
-      choices = c("hdi", "quantile", "ci", "eti", "si", "bci", "bcai")
+      c("hdi", "quantile", "ci", "eti", "si", "bci", "bcai")
     )
   } else {
-    ci_method <- match.arg(
+    ci_method <- .check_arg(
       ci_method,
-      choices = c(
+      c(
         "wald", "normal", "residual", "ml1", "betwithin", "satterthwaite",
         "kenward", "kr", "boot", "profile", "uniroot"
       )
     )
   }
 
   # which component to return?
-  effects <- match.arg(effects, choices = c("fixed", "random", "all"))
+  effects <- .check_arg(effects, c("fixed", "random", "all"))
   params <- params_random <- params_variance <- NULL
 
   # post hoc standardize only works for fixed effects...
@@ -343,7 +343,7 @@ ci.merMod <- function(x,
                       iterations = 500,
                       ...) {
   method <- tolower(method)
-  method <- match.arg(method, choices = c(
+  method <- .check_arg(method, c(
     "wald", "ml1", "betwithin", "kr",
     "satterthwaite", "kenward", "boot",
     "profile", "residual", "normal"
@@ -379,7 +379,7 @@ standard_error.merMod <- function(model,
                                   vcov_args = NULL,
                                   ...) {
   dots <- list(...)
-  effects <- match.arg(effects, choices = c("fixed", "random"))
+  effects <- .check_arg(effects, c("fixed", "random"))
 
   if (effects == "random") {
     out <- .standard_errors_random(model)

R/utils.R

@@ -220,6 +220,7 @@
   ifnotfound
 }
 
+
 .deprecated_warning <- function(old, new, verbose = TRUE) {
   if (verbose) {
     insight::format_warning(paste0(
@@ -230,3 +231,74 @@
     ))
   }
 }
+
+
+# this is a wrapper around `match.arg()`, but provided clearer information on fail
+.check_arg <- function(argument, options) {
+  argument_name <- deparse(substitute(argument))
+  argument <- .safe(match.arg(argument, options))
+  if (is.null(argument)) {
+    suggestion <- .misspelled_string(options, argument_name)
+    msg <- sprintf("Invalid option for argument `%s`.", argument_name)
+    if (is.null(suggestion) || !length(suggestion) || !nzchar(suggestion)) {
+      msg <- paste(msg, "Please use one of the following options:")
+    } else {
+      msg <- paste(msg, suggestion, "Else, use one of the following options:")
+    }
+    msg <- paste(msg, datawizard::text_concatenate(options, last = " or ", enclose = "\""))
+    insight::format_error(msg)
+  }
+  argument
+}
+
+
+.misspelled_string <- function(source, searchterm, default_message = NULL) {
+  if (is.null(searchterm) || length(searchterm) < 1) {
+    return(default_message)
+  }
+  # used for many matches
+  more_found <- ""
+  # init default
+  msg <- ""
+  # remove matching strings
+  same <- intersect(source, searchterm)
+  searchterm <- setdiff(searchterm, same)
+  source <- setdiff(source, same)
+  # guess the misspelled string
+  possible_strings <- unlist(lapply(searchterm, function(s) {
+    source[.fuzzy_grep(source, s)] # nolint
+  }), use.names = FALSE)
+  if (length(possible_strings)) {
+    msg <- "Did you mean "
+    if (length(possible_strings) > 1) {
+      # make sure we don't print dozens of alternatives for larger data frames
+      if (length(possible_strings) > 5) {
+        more_found <- sprintf(
+          " We even found %i more possible matches, not shown here.",
+          length(possible_strings) - 5
+        )
+        possible_strings <- possible_strings[1:5]
+      }
+      msg <- paste0(msg, "one of ", datawizard::text_concatenate(possible_strings, last = " or ", enclose = "\""))
+    } else {
+      msg <- paste0(msg, "\"", possible_strings, "\"")
+    }
+    msg <- paste0(msg, "?", more_found)
+  } else {
+    msg <- default_message
+  }
+  # no double white space
+  insight::trim_ws(msg)
+}
+
+
+.fuzzy_grep <- function (x, pattern, precision = NULL) {
+  if (is.null(precision)) {
+    precision <- round(nchar(pattern) / 3)
+  }
+  if (precision > nchar(pattern)) {
+    return(NULL)
+  }
+  p <- sprintf("(%s){~%i}", pattern, precision)
+  grep(pattern = p, x = x, ignore.case = FALSE)
+}