BOT: Fix #922: Remove check_columns_present and test_columns_present

NAMESPACE

@@ -134,6 +134,7 @@ importFrom(checkmate,check_atomic_vector)
 importFrom(checkmate,check_function)
 importFrom(checkmate,check_matrix)
 importFrom(checkmate,check_numeric)
+importFrom(checkmate,check_subset)
 importFrom(checkmate,check_vector)
 importFrom(checkmate,test_atomic_vector)
 importFrom(checkmate,test_list)

R/check-input-helpers.R

@@ -63,51 +63,6 @@ check_try <- function(expr) {
 }
 
 
-#' Check column names are present in a data.frame
-#' @description
-#' The functions loops over the column names and checks whether they are
-#' present. If an issue is encountered, the function immediately stops
-#' and returns a message with the first issue encountered.
-#' @inherit document_check_functions params return
-#' @importFrom checkmate assert_character
-#' @keywords internal_input_check
-check_columns_present <- function(data, columns) {
-  if (is.null(columns)) {
-    return(TRUE)
-  }
-  assert_character(columns, min.len = 1)
-  colnames <- colnames(data)
-  missing <- list()
-  for (x in columns) {
-    if (!(x %in% colnames)) {
-      missing[[x]] <- x
-    }
-  }
-  missing <- unlist(missing)
-  if (length(missing) > 1) {
-    msg <- paste0(
-      "Columns '", paste(missing, collapse = "', '"), "' not found in data"
-    )
-    return(msg)
-  } else if (length(missing) == 1) {
-    msg <- paste0("Column '", missing, "' not found in data")
-    return(msg)
-  }
-  return(TRUE)
-}
-
-#' Test whether all column names are present in a data.frame
-#' @description The function checks whether all column names are present. If
-#' one or more columns are missing, the function returns FALSE. If all columns
-#' are present, the function returns TRUE.
-#' @inheritParams document_check_functions
-#' @returns Returns TRUE if all columns are present and FALSE otherwise
-#' @keywords internal_input_check
-test_columns_present <- function(data, columns) {
-  check <- check_columns_present(data, columns)
-  return(isTRUE(check))
-}
-
 #' Test whether column names are NOT present in a data.frame
 #' @description The function checks whether all column names are NOT present.
 #' If none of the columns are present, the function returns TRUE. If one or

R/class-forecast-multivariate-sample.R

@@ -80,11 +80,12 @@ as_forecast_multivariate_sample.default <- function(data,
 #' @export
 #' @rdname assert_forecast
 #' @importFrom cli cli_abort qty
+#' @importFrom checkmate assert_subset
 #' @keywords validate-forecast-object
 assert_forecast.forecast_sample_multivariate <- function(
   forecast, forecast_type = NULL, verbose = TRUE, ...
 ) {
-  assert(check_columns_present(forecast, c("sample_id", ".mv_group_id")))
+  assert_subset(c("sample_id", ".mv_group_id"), colnames(forecast))
   forecast <- assert_forecast_generic(forecast, verbose)
 
   # make sure that for every .mv_group_id, the number of samples per

R/class-forecast-nominal.R

@@ -71,11 +71,11 @@ as_forecast_nominal.default <- function(data,
 
 #' @export
 #' @keywords check-forecasts
-#' @importFrom checkmate assert_names assert_set_equal test_set_equal
+#' @importFrom checkmate assert_names assert_set_equal test_set_equal assert_subset
 assert_forecast.forecast_nominal <- function(
   forecast, forecast_type = NULL, verbose = TRUE, ...
 ) {
-  assert(check_columns_present(forecast, "predicted_label"))
+  assert_subset("predicted_label", colnames(forecast))
   assert_names(
     colnames(forecast),
     disjunct.from = c("sample_id", "quantile_level")

R/class-forecast-ordinal.R

@@ -71,11 +71,11 @@ as_forecast_ordinal.default <- function(data,
 
 #' @export
 #' @keywords check-forecasts
-#' @importFrom checkmate assert_names assert_set_equal test_set_equal assert_factor
+#' @importFrom checkmate assert_names assert_set_equal test_set_equal assert_factor assert_subset
 assert_forecast.forecast_ordinal <- function(
   forecast, forecast_type = NULL, verbose = TRUE, ...
 ) {
-  assert(check_columns_present(forecast, "predicted_label"))
+  assert_subset("predicted_label", colnames(forecast))
   assert_names(
     colnames(forecast),
     disjunct.from = c("sample_id", "quantile_level")

R/class-forecast-quantile.R

@@ -77,11 +77,12 @@ as_forecast_quantile.default <- function(data,
 
 #' @export
 #' @rdname assert_forecast
+#' @importFrom checkmate assert_subset
 #' @keywords validate-forecast-object
 assert_forecast.forecast_quantile <- function(
   forecast, forecast_type = NULL, verbose = TRUE, ...
 ) {
-  assert(check_columns_present(forecast, "quantile_level"))
+  assert_subset("quantile_level", colnames(forecast))
   forecast <- assert_forecast_generic(forecast, verbose)
   assert_forecast_type(forecast, actual = "quantile", desired = forecast_type)
   assert_numeric(forecast$quantile_level, lower = 0, upper = 1)

R/class-forecast-sample.R

@@ -54,12 +54,13 @@ as_forecast_sample.default <- function(data,
 
 #' @export
 #' @rdname assert_forecast
+#' @importFrom checkmate assert_subset
 #' @keywords validate-forecast-object
 assert_forecast.forecast_sample <- function(
   forecast, forecast_type = NULL, verbose = TRUE, ...
 ) {
   forecast <- assert_forecast_generic(forecast, verbose)
-  assert(check_columns_present(forecast, "sample_id"))
+  assert_subset("sample_id", colnames(forecast))
   assert_forecast_type(forecast, actual = "sample", desired = forecast_type)
   return(invisible(NULL))
 }

R/class-forecast.R

@@ -106,14 +106,14 @@ assert_forecast.default <- function(
 #' @inheritParams assert_forecast
 #' @returns returns the input
 #' @importFrom data.table ':=' is.data.table
-#' @importFrom checkmate assert_data_table
+#' @importFrom checkmate assert_data_table assert_subset test_subset
 #' @importFrom cli cli_abort cli_inform cli_warn
 #' @keywords internal_input_check
 assert_forecast_generic <- function(data, verbose = TRUE) {
   # check that data is a data.table and that the columns look fine
   assert_data_table(data, min.rows = 1)
-  assert(check_columns_present(data, c("observed", "predicted")))
-  problem <- test_columns_present(data, c("sample_id", "quantile_level"))
+  assert_subset(c("observed", "predicted"), colnames(data))
+  problem <- test_subset(c("sample_id", "quantile_level"), colnames(data))
   if (problem) {
     cli_abort(
       c(

R/get-correlations.R

@@ -60,7 +60,7 @@ get_correlations <- function(scores,
 #' @importFrom ggplot2 ggplot geom_tile geom_text aes scale_fill_gradient2
 #' element_text labs coord_cartesian theme element_blank
 #' @importFrom data.table setDT melt
-#' @importFrom checkmate assert_data_frame
+#' @importFrom checkmate assert_data_frame check_subset
 #' @export
 #' @returns A ggplot object with a visualisation of correlations between metrics
 #' @examples
@@ -85,7 +85,7 @@ plot_correlations <- function(correlations, digits = NULL) {
 
 
   # check correlations is actually a matrix of correlations
-  col_present <- check_columns_present(correlations, "metric")
+  col_present <- check_subset("metric", colnames(correlations))
   if (any(lower_triangle > 1, na.rm = TRUE) || !isTRUE(col_present)) {
     #nolint start: keyword_quote_linter
     cli_abort(

R/pairwise-comparisons.R

@@ -87,7 +87,7 @@
 #' @importFrom data.table as.data.table data.table setnames copy
 #' @importFrom stats sd rbinom wilcox.test p.adjust
 #' @importFrom utils combn
-#' @importFrom checkmate assert_subset assert_character assert_disjunct
+#' @importFrom checkmate assert_subset assert_character assert_disjunct check_subset
 #' @importFrom cli cli_abort cli_inform cli_warn
 #' @export
 #' @author Nikos Bosse \email{nikosbosse@@gmail.com}
@@ -124,7 +124,7 @@ get_pairwise_comparisons <- function(
   # input checks ---------------------------------------------------------------
   scores <- ensure_data.table(scores)
   # check that column in 'compare' is present
-  assert(check_columns_present(scores, compare))
+  assert_subset(compare, colnames(scores))
   # check that column(s) in `by` ar not in `compare`
   assert_disjunct(by, compare)
 
@@ -139,7 +139,7 @@ get_pairwise_comparisons <- function(
   # check that columns in 'by' are present
   #nolint start: keyword_quote_linter object_usage_linter
   if (length(by) > 0) {
-    by_cols <- check_columns_present(scores, by)
+    by_cols <- check_subset(by, colnames(scores))
     if (!isTRUE(by_cols)) {
       cli_abort(
         c(

R/plot-wis.R

@@ -50,7 +50,7 @@ plot_wis <- function(scores,
   # input checks
   scores <- ensure_data.table(scores)
   wis_components <- c("overprediction", "underprediction", "dispersion")
-  assert(check_columns_present(scores, wis_components))
+  assert_subset(wis_components, colnames(scores))
   assert_subset(x, names(scores))
   assert_logical(relative_contributions, len = 1)
   assert_logical(flip, len = 1)

tests/testthat/test-check-input-helpers.R

@@ -11,31 +11,6 @@
 })
 
 
-test_that("check_columns_present works", {
-  expect_identical(
-    capture.output(
-      check_columns_present(example_binary, c("loc1", "loc2", "loc3"))
-    ),
-    paste(
-      "[1] \"Columns 'loc1', 'loc2', 'loc3' not found in data\""
-    )
-  )
-  expect_identical(
-    capture.output(
-      check_columns_present(example_binary, "loc1")
-    ),
-    paste(
-      "[1] \"Column 'loc1' not found in data\""
-    )
-  )
-  expect_true(
-    check_columns_present(example_binary, "location_name")
-  )
-  expect_true(
-    check_columns_present(example_binary, columns = NULL)
-  )
-})
-
 test_that("test_columns_not_present works", {
   expect_true(
     test_columns_not_present(example_binary, "sample_id")
@@ -44,13 +19,4 @@
     test_columns_not_present(example_binary, "location")
   )
 })
 
-test_that("check_columns_present() works", {
-  expect_identical(
-    check_columns_present(example_quantile, c("observed", "predicted", "nop")),
-    "Column 'nop' not found in data"
-  )
-  expect_true(
-    check_columns_present(example_quantile, c("observed", "predicted"))
-  )
-})

tests/testthat/test-class-forecast-multivariate-sample.R

@@ -213,7 +213,7 @@ test_that("as_forecast_multivariate_sample() handles errors appropriately", {
     as_forecast_multivariate_sample(
       data_bad, joint_across = c("location", "location_name")
     ),
-    "Assertion on 'forecast' failed: Column 'sample_id' not found in data."
+    "Must be a subset of"
   )
 
   # Test with inconsistent sample lengths within groups

tests/testthat/test-class-forecast-quantile.R

@@ -71,21 +71,21 @@ test_that("as_forecast_quantile() function throws an error when no predictions o
     suppressMessages(suppressWarnings(as_forecast_quantile(
       data.table::copy(example_quantile)[, predicted := NULL]
     ))),
-    "Assertion on 'data' failed: Column 'predicted' not found in data."
+    "Must be a subset of"
   )
 
   expect_error(
     suppressMessages(suppressWarnings(as_forecast_quantile(
       data.table::copy(example_quantile)[, observed := NULL]
     ))),
-    "Assertion on 'data' failed: Column 'observed' not found in data."
+    "Must be a subset of"
   )
 
   expect_error(
     suppressMessages(suppressWarnings(as_forecast_quantile(
       data.table::copy(example_quantile)[, c("observed", "predicted") := NULL]
     ))),
-    "Assertion on 'data' failed: Columns 'observed', 'predicted' not found in data."
+    "Must be a subset of"
   )
 })
 

tests/testthat/test-pairwise_comparison.R

@@ -360,7 +360,7 @@ test_that("Basic input checks for `add_relative_skill() work", {
       eval_nomodel,
       by = "target_type", metric = "crps"
     ),
-    "Assertion on 'scores' failed: Column 'model' not found in data."
+    "Must be a subset of"
   )
 
   # error if there isn't a metrics attribute
@@ -434,7 +434,7 @@ test_that("get_pairwise_comparisons() throws errors with wrong inputs", {
   # expect error if no model column is found
   expect_error(
     get_pairwise_comparisons(test, compare = "model", metric = "crps"),
-    "Assertion on 'scores' failed: Column 'model' not found in data."
+    "Must be a subset of"
   )
 })
 

tests/testthat/test-plot_wis.R

@@ -8,7 +8,7 @@ test_that("plot_wis() throws an error if WIS components are missing", {
 
   expect_error(
     plot_wis(ex_score),
-    "Columns 'overprediction', 'underprediction', 'dispersion' not found in data."
+    "Must be a subset of"
   )
 })