diff --git a/DESCRIPTION b/DESCRIPTION index 61370f0f..1fc56c80 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,7 +34,7 @@ Suggests: learnr, lubridate, rmarkdown, - testthat, + testthat (>= 3.0.0), tibble VignetteBuilder: knitr @@ -44,3 +44,4 @@ Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.1.1 +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index f106448f..575cba68 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,13 @@ # Generated by roxygen2: do not edit by hand +S3method(format,tblcheck_problem) +S3method(print,tblcheck_problem) export("%>%") export(.result) export(.solution) +export(is_problem) +export(is_tblcheck_problem) +export(problem_type) export(tbl_check_class) export(tbl_check_column) export(tbl_check_dimensions) diff --git a/R/check_class.R b/R/check_class.R index 5ee06ec1..4c143aa5 100644 --- a/R/check_class.R +++ b/R/check_class.R @@ -35,10 +35,10 @@ tbl_check_class <- function( return( problem( "class", - # Object lengths are stored so the correct pluralization - # can be applied in tbl_message_class() exp_class, obj_class, + # Object lengths are stored so the correct pluralization + # can be applied in tbl_message.class_problem() expected_length = length(expected), actual_length = length(object) ) @@ -56,7 +56,7 @@ tbl_grade_class <- function( ) } -tbl_message_class <- function(problem, ...) { +tbl_message.class_problem <- function(problem, ...) { exp_class <- problem$expected obj_class <- problem$actual @@ -69,23 +69,70 @@ tbl_message_class <- function(problem, ...) { return_fail(hinted_class_message, problem = problem) } - column_name <- problem$column + exp_length <- problem$expected_length + obj_length <- problem$actual_length + + friendly_exp_class <- friendly_class(exp_class, exp_length) + friendly_obj_class <- friendly_class(obj_class, obj_length) - exp_length = problem$expected_length - obj_length = problem$actual_length + message <- glue::glue( + gettext( + "Your result should be {friendly_exp_class}, but it is {friendly_obj_class}." + ) + ) + + return_fail(message, problem = problem) +} + +tbl_message.column_class_problem <- function(problem, ...) { + exp_class <- problem$expected + obj_class <- problem$actual + + if (!has_meaningful_class_difference(exp_class, obj_class)) { + return() + } + + exp_length <- problem$expected_length + obj_length <- problem$actual_length friendly_exp_class <- friendly_class(exp_class, exp_length) friendly_obj_class <- friendly_class(obj_class, obj_length) - message <- if (!is.null(column_name)) { - "Your `{column_name}` column should be {friendly_exp_class}, but it is {friendly_obj_class}." - } else if (isTRUE(problem$table)) { - "Your table should be {friendly_exp_class}, but it is {friendly_obj_class}." - } else { - "Your result should be {friendly_exp_class}, but it is {friendly_obj_class}." + column_name <- problem$column + message <- glue::glue( + gettext( + "Your `{column_name}` column should be {friendly_exp_class}, but it is {friendly_obj_class}." + ) + ) + + return_fail(message, problem = problem) +} + +tbl_message.table_class_problem <- function(problem, ...) { + exp_class <- problem$expected + obj_class <- problem$actual + + if (!has_meaningful_class_difference(exp_class, obj_class)) { + return() + } + + hinted_class_message <- hinted_class_message(obj_class, exp_class) + if (!is.null(hinted_class_message)) { + return_fail(hinted_class_message, problem = problem) } - return_fail(glue::glue(message), problem = problem) + column_name <- problem$column + + friendly_exp_class <- friendly_class(exp_class, 1) + friendly_obj_class <- friendly_class(obj_class, 1) + + message <- glue::glue( + gettext( + "Your table should be {friendly_exp_class}, but it is {friendly_obj_class}." + ) + ) + + return_fail(message, problem = problem) } has_meaningful_class_difference <- function(exp_class, obj_class) { @@ -129,23 +176,33 @@ hinted_class_message_list <- function() { list( obj_class = "rowwise_df", exp_class = "grouped_df", - message = "Your table is a rowwise data frame, but I was expecting it to be grouped. Maybe you need to use `group_by()`?" + message = gettext( + "Your table is a rowwise data frame, but I was expecting it to be grouped. Maybe you need to use `group_by()`?" + ) ), list( exp_class = "grouped_df", - message = "Your table isn't a grouped data frame, but I was expecting it to be grouped. Maybe you need to use `group_by()`?" + message = gettext( + "Your table isn't a grouped data frame, but I was expecting it to be grouped. Maybe you need to use `group_by()`?" + ) ), list( obj_class = "grouped_df", - message = "Your table is a grouped data frame, but I wasn't expecting it to be grouped. Maybe you need to use `ungroup()`?" + message = gettext( + "Your table is a grouped data frame, but I wasn't expecting it to be grouped. Maybe you need to use `ungroup()`?" + ) ), list( exp_class = "rowwise_df", - message = "Your table isn't a rowwise data frame, but I was expecting it to be rowwise. Maybe you need to use `rowwise()`?" + message = gettext( + "Your table isn't a rowwise data frame, but I was expecting it to be rowwise. Maybe you need to use `rowwise()`?" + ) ), list( obj_class = "rowwise_df", - message = "Your table is a rowwise data frame, but I wasn't expecting it to be rowwise. Maybe you need to use `ungroup()`?" + message = gettext( + "Your table is a rowwise data frame, but I wasn't expecting it to be rowwise. Maybe you need to use `ungroup()`?" + ) ) ) } @@ -167,13 +224,13 @@ friendly_class <- function(class, length) { length > 1, ngettext( length(class), - "a vector with class {class_str}", - "a vector with classes {class_str}" + gettext("a vector with class {class_str}"), + gettext("a vector with classes {class_str}") ), ngettext( length(class), - "an object with class {class_str}", - "an object with classes {class_str}" + gettext("an object with class {class_str}"), + gettext("an object with classes {class_str}") ) ) ) @@ -183,72 +240,72 @@ friendly_class_list <- function() { list( list( class = "character", - single = "a text string (class `character`)", - multiple = "a vector of text (class `character`)" + single = gettext("a text string (class `character`)"), + multiple = gettext("a vector of text (class `character`)") ), list( class = "numeric", - single = "a number (class `numeric`)", - multiple = "a vector of numbers (class `numeric`)" + single = gettext("a number (class `numeric`)"), + multiple = gettext("a vector of numbers (class `numeric`)") ), list( class = "integer", - single = "an integer (class `integer`)", - multiple = "a vector of integers (class `integer`)" + single = gettext("an integer (class `integer`)"), + multiple = gettext("a vector of integers (class `integer`)") ), list( class = "logical", - single = "a TRUE/FALSE value (class `logical`)", - multiple = "a vector of TRUE/FALSE values (class `logical`)" + single = gettext("a TRUE/FALSE value (class `logical`)"), + multiple = gettext("a vector of TRUE/FALSE values (class `logical`)") ), list( class = "complex", - single = "a complex number (class `complex`)", - multiple = "a vector of complex numbers (class `complex`)" + single = gettext("a complex number (class `complex`)"), + multiple = gettext("a vector of complex numbers (class `complex`)") ), list( class = "raw", - single = "a raw byte value (class `raw`)", - multiple = "a vector of raw byte values (class `raw`)" + single = gettext("a raw byte value (class `raw`)"), + multiple = gettext("a vector of raw byte values (class `raw`)") ), list( class = "factor", - single = "a factor (class `factor`)", - multiple = "a vector of factors (class `factor`)" + single = gettext("a factor (class `factor`)"), + multiple = gettext("a vector of factors (class `factor`)") ), list( class = c("POSIXct", "POSIXt"), - single = "a date-time (class `POSIXct`)", - multiple = "a vector of date-times (class `POSIXct`)" + single = gettext("a date-time (class `POSIXct`)"), + multiple = gettext("a vector of date-times (class `POSIXct`)") ), list( class = c("POSIXlt", "POSIXt"), - single = "a date-time (class `POSIXlt`)", - multiple = "a vector of date-times (class `POSIXlt`)" + single = gettext("a date-time (class `POSIXlt`)"), + multiple = gettext("a vector of date-times (class `POSIXlt`)") ), list( class = c("tbl_df", "tbl", "data.frame"), - single = "a tibble (class `tbl_df`)" + single = gettext("a tibble (class `tbl_df`)") ), list( class = "data.frame", - single = "a data frame (class `data.frame`)" + single = gettext("a data frame (class `data.frame`)") ), list( class = "list", - single = "a list (class `list`)" + single = gettext("a list (class `list`)") ), list( class = "matrix", - single = "a matrix (class `matrix`)" + single = gettext("a matrix (class `matrix`)") ), list( class = c("matrix", "array"), - single = "a matrix (class `matrix`)" + single = gettext("a matrix (class `matrix`)") ), list( class = "array", - single = "an array (class `array`)" + single = gettext("an array (class `array`)") ) ) } diff --git a/R/check_column.R b/R/check_column.R index 28b99f98..43cc91d3 100644 --- a/R/check_column.R +++ b/R/check_column.R @@ -57,12 +57,14 @@ tbl_check_column <- function( }) if (!name %in% names(expected)) { - warning("`", name, "` is not a column in `expected`.") + warning(glue::glue("`{name}` is not a column in `expected`.")) return() } if (!name %in% names(object)) { - return_if_problem(problem("missing", name), column = name) + return_if_problem( + problem("missing", name), prefix = "column", column = name + ) } return_if_problem( @@ -75,6 +77,7 @@ tbl_check_column <- function( check_values = check_values, check_names = FALSE ), + prefix = "column", column = name ) } @@ -107,10 +110,12 @@ tbl_grade_column <- function( ) } -tbl_message_missing <- function(problem, ...) { +tbl_message.column_missing_problem <- function(problem, ...) { exp_column <- problem$expected - message <- glue::glue("Your table should have a column named `{exp_column}`.") + message <- glue::glue( + gettext("Your table should have a column named `{exp_column}`.") + ) return_fail(message, problem = problem) } diff --git a/R/check_dimensions.R b/R/check_dimensions.R index a64ab97b..38e5f8a2 100644 --- a/R/check_dimensions.R +++ b/R/check_dimensions.R @@ -48,12 +48,11 @@ tbl_grade_dimensions <- function( ) } -tbl_message_dimensions <- function(problem, ...) { +tbl_message.dimensions_problem <- function(problem, ...) { exp_dim <- problem$expected exp_n_dim <- length(exp_dim) obj_dim <- problem$actual obj_n_dim <- length(obj_dim) - column_name <- problem$column message <- if (!identical(obj_n_dim, exp_n_dim)) { glue::glue( @@ -69,33 +68,125 @@ tbl_message_dimensions <- function(problem, ...) { ) ) } else if (length(exp_dim) == 1) { - if (!is.null(column_name)) { + glue::glue( + ngettext( + exp_dim, + "Your result should contain {exp_dim} value, ", + "Your result should contain {exp_dim} values, " + ), + ngettext( + obj_dim, + "but it has {obj_dim} value.", + "but it has {obj_dim} values." + ) + ) + } else if (length(exp_dim) == 2) { + obj_rows <- obj_dim[[1]] + exp_rows <- exp_dim[[1]] + obj_cols <- obj_dim[[2]] + exp_cols <- exp_dim[[2]] + + if (!identical(obj_cols, exp_cols)) { glue::glue( ngettext( - exp_dim, - "Your `{column_name}` column should contain {exp_dim} value, ", - "Your `{column_name}` column should contain {exp_dim} values, " + exp_cols, + "Your table should have {exp_cols} column, ", + "Your table should have {exp_cols} columns, " ), ngettext( - obj_dim, - "but it has {obj_dim} value.", - "but it has {obj_dim} values." + obj_cols, + "but it has {obj_cols} column.", + "but it has {obj_cols} columns." ) ) - } else { + } else if (!identical(obj_rows, exp_rows)) { glue::glue( ngettext( - exp_dim, - "Your result should contain {exp_dim} value, ", - "Your result should contain {exp_dim} values, " + exp_rows, + "Your table should have {exp_rows} row, ", + "Your table should have {exp_rows} rows, " ), ngettext( - obj_dim, - "but it has {obj_dim} value.", - "but it has {obj_dim} values." + obj_rows, + "but it has {obj_rows} row.", + "but it has {obj_rows} rows." ) ) - } + } + } else { + obj_dim_str <- paste(obj_dim, collapse = " x ") + exp_dim_str <- paste(exp_dim, collapse = " x ") + + glue::glue( + gettext( + "Your result should be an array with dimensions {exp_dim_str}, but it has dimensions {obj_dim_str}." + ) + ) + } + + return_fail(message, problem = problem) +} + +tbl_message.vector_dimensions_problem <- function(problem, ...) { + exp_dim <- problem$expected + obj_dim <- problem$actual + + message <- glue::glue( + ngettext( + exp_dim, + "Your result should contain {exp_dim} value, ", + "Your result should contain {exp_dim} values, " + ), + ngettext( + obj_dim, + "but it has {obj_dim} value.", + "but it has {obj_dim} values." + ) + ) + + return_fail(message, problem = problem) +} + +tbl_message.column_dimensions_problem <- function(problem, ...) { + exp_dim <- problem$expected + obj_dim <- problem$actual + column_name <- problem$column + + message <- glue::glue( + ngettext( + exp_dim, + "Your `{column_name}` column should contain {exp_dim} value, ", + "Your `{column_name}` column should contain {exp_dim} values, " + ), + ngettext( + obj_dim, + "but it has {obj_dim} value.", + "but it has {obj_dim} values." + ) + ) + + return_fail(message, problem = problem) +} + +tbl_message.table_dimensions_problem <- function(problem, ...) { + exp_dim <- problem$expected + exp_n_dim <- length(exp_dim) + obj_dim <- problem$actual + obj_n_dim <- length(obj_dim) + + message <- if (!identical(obj_n_dim, exp_n_dim)) { + glue::glue( + ngettext( + exp_n_dim, + "Your table should have {exp_n_dim} dimension, ", + "Your table should have {exp_n_dim} dimensions, " + ), + ngettext( + obj_n_dim, + "but it has {obj_n_dim} dimension.", + "but it has {obj_n_dim} dimensions." + ) + ) } else if (length(exp_dim) == 2) { obj_rows <- obj_dim[[1]] exp_rows <- exp_dim[[1]] @@ -134,8 +225,7 @@ tbl_message_dimensions <- function(problem, ...) { exp_dim_str <- paste(exp_dim, collapse = " x ") glue::glue( - "Your table should be an arry with dimensions {exp_dim_str}, ", - "but it has dimensions {obj_dim_str}." + "Your table should be an arry with dimensions {exp_dim_str}, but it has dimensions {obj_dim_str}." ) } diff --git a/R/check_names.R b/R/check_names.R index fcecec8b..0d2d6ab6 100644 --- a/R/check_names.R +++ b/R/check_names.R @@ -43,7 +43,7 @@ tbl_check_names <- function( ) if (is.data.frame(object) && is.data.frame(expected)) { - problem$table <- TRUE + return_if_problem(problem, prefix = "table") } return(problem) @@ -66,32 +66,48 @@ tbl_grade_names <- function( ) } -tbl_message_names <- function(problem, max_diffs = 3, ...) { +tbl_message.names_problem <- function(problem, max_diffs = 3, ...) { + missing_names <- combine_words_with_more( + problem$missing, max_diffs + ) + missing_msg <- if (!is.null(missing_names)) { + ngettext( + length(problem$missing), + "Your result should have the name {missing_names}. ", + "Your result should have the names {missing_names}. " + ) + } else { + "" + } + + unexpected_names <- combine_words_with_more( + problem$unexpected, max_diffs, and = " or " + ) + unexpected_msg <- if (!is.null(unexpected_names)) { + ngettext( + length(problem$unexpected), + "Your result should not have the name {unexpected_names}.", + "Your result should not have the names {unexpected_names}." + ) + } else { + "" + } + + return_fail(glue::glue(missing_msg, unexpected_msg), problem = problem) +} + +tbl_message.column_names_problem <- function(problem, max_diffs = 3, ...) { column_name <- problem$column missing_names <- combine_words_with_more( problem$missing, max_diffs ) missing_msg <- if (!is.null(missing_names)) { - if (!is.null(column_name)) { - ngettext( - length(problem$missing), - "Your `{column_name}` column should have the name {missing_names}. ", - "Your `{column_name}` column should have the names {missing_names}. " - ) - } else if (isTRUE(problem$table)) { - ngettext( - length(problem$missing), - "Your table should have a column named {missing_names}. ", - "Your table should have columns named {missing_names}. " - ) - } else { - ngettext( - length(problem$missing), - "Your result should have the name {missing_names}. ", - "Your result should have the names {missing_names}. " - ) - } + ngettext( + length(problem$missing), + "Your `{column_name}` column should have the name {missing_names}. ", + "Your `{column_name}` column should have the names {missing_names}. " + ) } else { "" } @@ -100,33 +116,46 @@ tbl_message_names <- function(problem, max_diffs = 3, ...) { problem$unexpected, max_diffs, and = " or " ) unexpected_msg <- if (!is.null(unexpected_names)) { - if (!is.null(column_name)) { - ngettext( - length(problem$unexpected), - "Your `{column_name}` column should not have the name {unexpected_names}.", - "Your `{column_name}` column should not have the names {unexpected_names}." - ) - } else if (isTRUE(problem$table)) { - ngettext( - length(problem$unexpected), - "Your table should not have a column named {unexpected_names}.", - "Your table should not have columns named {unexpected_names}." - ) - } else { - ngettext( - length(problem$unexpected), - "Your result should not have the name {unexpected_names}.", - "Your result should not have the names {unexpected_names}." - ) - } + ngettext( + length(problem$unexpected), + "Your `{column_name}` column should not have the name {unexpected_names}.", + "Your `{column_name}` column should not have the names {unexpected_names}." + ) } else { "" } - return_fail( - glue::glue(missing_msg, unexpected_msg), - problem = problem + return_fail(glue::glue(missing_msg, unexpected_msg), problem = problem) +} + +tbl_message.table_names_problem <- function(problem, max_diffs = 3, ...) { + missing_names <- combine_words_with_more( + problem$missing, max_diffs ) + missing_msg <- if (!is.null(missing_names)) { + ngettext( + length(problem$missing), + "Your table should have a column named {missing_names}. ", + "Your table should have columns named {missing_names}. " + ) + } else { + "" + } + + unexpected_names <- combine_words_with_more( + problem$unexpected, max_diffs, and = " or " + ) + unexpected_msg <- if (!is.null(unexpected_names)) { + ngettext( + length(problem$unexpected), + "Your table should not have a column named {unexpected_names}.", + "Your table should not have columns named {unexpected_names}." + ) + } else { + "" + } + + return_fail(glue::glue(missing_msg, unexpected_msg), problem = problem) } combine_words_with_more <- function( diff --git a/R/check_table.R b/R/check_table.R index 4fab0691..c9b64502 100644 --- a/R/check_table.R +++ b/R/check_table.R @@ -78,7 +78,7 @@ tbl_check_table <- function( if (check_class) { return_if_problem( tbl_check_class(object, expected), - table = TRUE + prefix = "table" ) } @@ -86,7 +86,7 @@ tbl_check_table <- function( if (check_names) { return_if_problem( tbl_check_names(object, expected), - table = TRUE + prefix = "table" ) } @@ -94,7 +94,7 @@ tbl_check_table <- function( if (check_dimensions) { return_if_problem( tbl_check_dimensions(object, expected), - table = TRUE + prefix = "table" ) } diff --git a/R/check_vector.R b/R/check_vector.R index bc0c45a5..73a8f950 100644 --- a/R/check_vector.R +++ b/R/check_vector.R @@ -58,14 +58,14 @@ tbl_check_vector <- function( if (check_class) { return_if_problem( tbl_check_class(object, expected), - vector = TRUE + prefix = "vector" ) } if (check_length) { return_if_problem( tbl_check_dimensions(object, expected), - vector = TRUE + prefix = "vector" ) } @@ -77,18 +77,18 @@ tbl_check_vector <- function( first_n_values <- exp_values[seq_len(n_values)] if (!identical(obj_values[seq_len(n_values)], first_n_values)) { - return_if_problem(problem("values", first_n_values), vector = TRUE) + return_if_problem(problem("values", first_n_values), prefix = "vector") } if (!identical(obj_values, exp_values)) { - return_if_problem(problem("values"), vector = TRUE) + return_if_problem(problem("values"), prefix = "vector") } } if (check_names) { return_if_problem( tbl_check_names(object, expected), - vector = TRUE + prefix = "vector" ) } } @@ -122,31 +122,36 @@ tbl_grade_vector <- function( ) } -tbl_message_values <- function(problem, ...) { +tbl_message.values_problem <- function(problem, ...) { + n_values <- length(problem$expected) + exp_values <- knitr::combine_words(md_code(problem$expected)) + + message <- if (n_values != 0) { + ngettext( + n_values, + "The first value of your result should be {exp_values}.", + "The first {n_values} values of your result should be {exp_values}." + ) + } else { + gettext("Your result contains unexpected values.") + } + + return_fail(glue::glue(message), problem = problem) +} + +tbl_message.column_values_problem <- function(problem, ...) { n_values <- length(problem$expected) exp_values <- knitr::combine_words(md_code(problem$expected)) column_name <- problem$column message <- if (n_values != 0) { - if (!is.null(column_name)) { - ngettext( - n_values, - "The first value of your `{column_name}` column should be {exp_values}.", - "The first {n_values} values of your `{column_name}` column should be {exp_values}." - ) - } else { - ngettext( - n_values, - "The first value of your result should be {exp_values}.", - "The first {n_values} values of your result should be {exp_values}." - ) - } + ngettext( + n_values, + "The first value of your `{column_name}` column should be {exp_values}.", + "The first {n_values} values of your `{column_name}` column should be {exp_values}." + ) } else { - if (!is.null(column_name)) { - "Your `{column_name}` column contains unexpected values." - } else { - "Your result contains unexpected values." - } + gettext("Your `{column_name}` column contains unexpected values.") } return_fail(glue::glue(message), problem = problem) diff --git a/R/grade.R b/R/grade.R index 688b0446..a9105988 100644 --- a/R/grade.R +++ b/R/grade.R @@ -15,8 +15,9 @@ tbl_grade <- function(problem, max_diffs = 3) { checkmate::assert_number(max_diffs, lower = 1) }) - message_fn <- gsub("(.*_)?(.*)", "tbl_message_\\2", problem$type) - message_fn <- rlang::as_function(message_fn, rlang::fn_env(tbl_grade)) - - return_if_graded(message_fn(problem, max_diffs = max_diffs)) + tbl_message(problem, max_diffs = max_diffs) +} + +tbl_message <- function(problem, ...) { + UseMethod("tbl_message") } diff --git a/R/problem.R b/R/problem.R index 6cb4b93d..cae88c3b 100644 --- a/R/problem.R +++ b/R/problem.R @@ -24,12 +24,98 @@ problem <- function( ... ) - as.problem(purrr::compact(problem)) + structure( + purrr::compact(problem), + class = c( + paste0(type, "_problem"), "tblcheck_problem", "gradethis_problem", "list" + ) + ) } -as.problem <- function(list) { - structure( - list, - class = c("tblcheck_problem", "gradethis_problem", class(list)) +return_if_problem <- function( + problem, prefix = NULL, ..., envir = parent.frame() +) { + if (inherits(problem, "tblcheck_problem")) { + problem_class <- class(problem) + problem <- c(problem, ...) + class(problem) <- problem_class + + if (!is.null(prefix)) { + # Add trailing underscore to prefix if it doesn't already have one + prefix <- gsub("_?$", "_", prefix) + + custom_classes <- setdiff( + problem_class, c("tblcheck_problem", "gradethis_problem", "list") + ) + base_class <- custom_classes[length(custom_classes)] + class(problem) <- unique(c(paste0(prefix, base_class), problem_class)) + + problem$type <- gsub("^(.*_)?", prefix, problem$type) + } + + rlang::return_from(envir, problem) + } +} + +#' Problem helper functions +#' +#' - `problem_type()` returns a problem's type, or [`NULL`] if the input is +#' not a problem. +#' - `is_problem()` tests whether an object is a `gradethis` problem. +#' - `is_tblcheck_problem()` tests whether an object is a problem created +#' by `tblcheck`. +#' +#' If `type` is specified, `is_problem()` and `is_tblcheck_problem()` test +#' whether an object is a problem of the specified type. +#' +#' @param x An object +#' @param type `[character(1)]`\cr A `problem` type +#' +#' @return `is_problem()` and `is_tblcheck_problem()` return a [logical] +#' of length 1. +#' `problem_type()` returns a [character] of length 1. +#' @export +#' +#' @examples +#' problem_type(tbl_check_vector(1, "1")) +#' is_problem(tbl_check_vector(1, "1"), "vector_class") +#' is_tblcheck_problem(tbl_check_vector(1, "1"), "class") +problem_type <- function(x) { + if (is_problem(x)) { + return(x$type) + } + + NULL +} + +#' @rdname problem_type +#' @export +is_problem <- function(x, type = NULL) { + inherits(x, "gradethis_problem") && ( + is.null(type) || inherits(x, paste0(type, "_problem")) ) } + +#' @rdname problem_type +#' @export +is_tblcheck_problem <- function(x, type = NULL) { + inherits(x, "tblcheck_problem") && ( + is.null(type) || inherits(x, paste0(type, "_problem")) + ) +} + +#' @exportS3Method +print.tblcheck_problem <- function(x, ...) { + problem_list <- x + class(problem_list) <- "list" + cat( + "\n", format(x, ...), "\n\n", + sep = "" + ) + print(problem_list) +} + +#' @exportS3Method +format.tblcheck_problem <- function(x, ...) { + tbl_message(x, ...)$message +} diff --git a/R/tests-helpers.R b/R/tests-helpers.R index d267c9c7..298519ac 100644 --- a/R/tests-helpers.R +++ b/R/tests-helpers.R @@ -1,9 +1,15 @@ expect_internal_problem <- function(grade, message) { - testthat::expect_message(grade) - testthat::expect_equal(grade$correct, logical()) - testthat::expect_match(grade$message, "can't provide feedback") - testthat::expect_equal(grade$problem$type, "internal_feedback_error") - testthat::expect_match(as.character(grade$problem$error), message) + suppressMessages({ + testthat::expect_message(grade) + testthat::expect_equal(grade$correct, logical()) + testthat::expect_match(grade$message, "can't provide feedback") + testthat::expect_equal(grade$problem$type, "internal_feedback_error") + testthat::expect_match(as.character(grade$problem$error), message) + }) +} + +expect_warning <- function(...) { + suppressWarnings(testthat::expect_warning(...)) } expect_result_message <- function(result, expected, ...) { @@ -35,7 +41,7 @@ tblcheck_test_grade <- function(expr, return_all = FALSE) { } if (!grepl("^tbl_(check|grade)", final_call)) { - stop("tblcheck_test_grade() expected a {tblcheck} function as the final expression") + stop("tblcheck_test_grade() expected a tblcheck function as the final expression") } # Grade returned by check_*(), without calling handlers diff --git a/R/utils.R b/R/utils.R index eeaa370d..65360452 100644 --- a/R/utils.R +++ b/R/utils.R @@ -24,9 +24,8 @@ assert_internally <- function(expr, ..., error = internal_error) { internal_error <- function(err) { message("An error occurred in the grading code: ", err$message) gradethis::graded( - message = paste( - "Uh-oh! We can't provide feedback at this time. Don't worry, it's not", - "your fault! There's an issue behind-the-scenes with this exercise." + message = gettext( + "Uh-oh! We can't provide feedback at this time. Don't worry, it's not your fault! There's an issue behind-the-scenes with this exercise." ), correct = logical(0), type = "warning", @@ -56,20 +55,3 @@ return_fail <- function(..., env = parent.frame()) { rlang::return_from(env, grade) } } - -return_if_problem <- function(problem, ..., envir = parent.frame()) { - if (inherits(problem, "tblcheck_problem")) { - dots <- list(...) - - if (length(dots)) { - problem_prefix <- paste0(names(dots)[[length(dots)]], "_") - assert_internally(checkmate::assert_string(problem_prefix)) - problem$type <- gsub("^(.*_)?", problem_prefix, problem$type) - - dots <- dots[!names(dots) %in% names(problem)] - problem <- as.problem(c(problem, dots)) - } - - rlang::return_from(envir, problem) - } -} diff --git a/inst/po/es/LC_MESSAGES/R-tblcheck.mo b/inst/po/es/LC_MESSAGES/R-tblcheck.mo new file mode 100644 index 00000000..7825fd9f Binary files /dev/null and b/inst/po/es/LC_MESSAGES/R-tblcheck.mo differ diff --git a/man/problem_type.Rd b/man/problem_type.Rd new file mode 100644 index 00000000..b6fdf88f --- /dev/null +++ b/man/problem_type.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/problem.R +\name{problem_type} +\alias{problem_type} +\alias{is_problem} +\alias{is_tblcheck_problem} +\title{Problem helper functions} +\usage{ +problem_type(x) + +is_problem(x, type = NULL) + +is_tblcheck_problem(x, type = NULL) +} +\arguments{ +\item{x}{An object} + +\item{type}{\verb{[character(1)]}\cr A \code{problem} type} +} +\value{ +\code{is_problem()} and \code{is_tblcheck_problem()} return a \link{logical} +of length 1. +\code{problem_type()} returns a \link{character} of length 1. +} +\description{ +\itemize{ +\item \code{problem_type()} returns a problem's type, or \code{\link{NULL}} if the input is +not a problem. +\item \code{is_problem()} tests whether an object is a \code{gradethis} problem. +\item \code{is_tblcheck_problem()} tests whether an object is a problem created +by \code{tblcheck}. +} + +If \code{type} is specified, \code{is_problem()} and \code{is_tblcheck_problem()} test +whether an object is a problem of the specified type. +} +\examples{ +problem_type(tbl_check_vector(1, "1")) +is_problem(tbl_check_vector(1, "1"), "vector_class") +is_tblcheck_problem(tbl_check_vector(1, "1"), "class") +} diff --git a/po/R-es.po b/po/R-es.po new file mode 100644 index 00000000..8881d6a3 --- /dev/null +++ b/po/R-es.po @@ -0,0 +1,259 @@ +msgid "" +msgstr "" +"Project-Id-Version: tblcheck 0.0.0.9000\n" +"POT-Creation-Date: 2021-08-17 15:16\n" +"PO-Revision-Date: 2021-08-17 13:51\n" +"Last-Translator: Alex Rossell Hayes \n" +"Language-Team: Alex Rossell Hayes \n" +"Language: es\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=n != 1;\n" + +msgid "" +"Your result should be {friendly_exp_class}, but it is {friendly_obj_class}." +msgstr "" +"Su resultado debe ser {friendly_exp_class}, pero es {friendly_obj_class}." + +msgid "" +"Your `{column_name}` column should be {friendly_exp_class}, but it is " +"{friendly_obj_class}." +msgstr "" +"Su columna `{column_name}` debe ser {friendly_exp_class}, pero es " +"{friendly_obj_class}." + +msgid "" +"Your table should be {friendly_exp_class}, but it is {friendly_obj_class}." +msgstr "Su tabla debe ser {friendly_exp_class}, pero es {friendly_obj_class}." + +msgid "" +"Your table is a rowwise data frame, but I was expecting it to be grouped. " +"Maybe you need to use `group_by()`?" +msgstr "" + +msgid "" +"Your table isn't a grouped data frame, but I was expecting it to be grouped. " +"Maybe you need to use `group_by()`?" +msgstr "" + +msgid "" +"Your table is a grouped data frame, but I wasn't expecting it to be grouped. " +"Maybe you need to use `ungroup()`?" +msgstr "" + +msgid "" +"Your table isn't a rowwise data frame, but I was expecting it to be rowwise. " +"Maybe you need to use `rowwise()`?" +msgstr "" + +msgid "" +"Your table is a rowwise data frame, but I wasn't expecting it to be rowwise. " +"Maybe you need to use `ungroup()`?" +msgstr "" + +msgid "a vector with class {class_str}" +msgstr "un vector con clase {class_str}" + +msgid "a vector with classes {class_str}" +msgstr "un vector con clases {class_str}" + +msgid "an object with class {class_str}" +msgstr "" + +msgid "an object with classes {class_str}" +msgstr "" + +msgid "a text string (class `character`)" +msgstr "una cadena de texto (clase `character`)" + +msgid "a vector of text (class `character`)" +msgstr "un vector de texto (clase `character`)" + +msgid "a number (class `numeric`)" +msgstr "un número (clase `numeric`)" + +msgid "a vector of numbers (class `numeric`)" +msgstr "un vector de números (clase `numeric`)" + +msgid "an integer (class `integer`)" +msgstr "un número entero (clase `integer`)" + +msgid "a vector of integers (class `integer`)" +msgstr "un vector de números enteros (clase `integer`)" + +msgid "a TRUE/FALSE value (class `logical`)" +msgstr "" + +msgid "a vector of TRUE/FALSE values (class `logical`)" +msgstr "" + +msgid "a complex number (class `complex`)" +msgstr "" + +msgid "a vector of complex numbers (class `complex`)" +msgstr "" + +msgid "a raw byte value (class `raw`)" +msgstr "" + +msgid "a vector of raw byte values (class `raw`)" +msgstr "" + +msgid "a factor (class `factor`)" +msgstr "" + +msgid "a vector of factors (class `factor`)" +msgstr "" + +msgid "a date-time (class `POSIXct`)" +msgstr "" + +msgid "a vector of date-times (class `POSIXct`)" +msgstr "" + +msgid "a date-time (class `POSIXlt`)" +msgstr "" + +msgid "a vector of date-times (class `POSIXlt`)" +msgstr "" + +msgid "a tibble (class `tbl_df`)" +msgstr "" + +msgid "a data frame (class `data.frame`)" +msgstr "" + +msgid "a list (class `list`)" +msgstr "" + +msgid "a matrix (class `matrix`)" +msgstr "" + +msgid "an array (class `array`)" +msgstr "" + +msgid "`{name}` is not a column in `expected`." +msgstr "" + +msgid "Your table should have a column named `{exp_column}`." +msgstr "" + +msgid "" +"Your result should be an array with dimensions {exp_dim_str}, but it has " +"dimensions {obj_dim_str}." +msgstr "" + +msgid "Your result contains unexpected values." +msgstr "" + +msgid "Your `{column_name}` column contains unexpected values." +msgstr "" + +msgid "" +"tblcheck_test_grade() expected a tblcheck function as the final expression" +msgstr "" + +msgid "An error occurred in the grading code:" +msgstr "" + +msgid "" +"Uh-oh! We can't provide feedback at this time. Don't worry, it's not your " +"fault! There's an issue behind-the-scenes with this exercise." +msgstr "" + +msgid "Your result should have {exp_n_dim} dimension, " +msgid_plural "Your result should have {exp_n_dim} dimensions, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_n_dim} dimension." +msgid_plural "but it has {obj_n_dim} dimensions." +msgstr[0] "" +msgstr[1] "" + +msgid "Your result should contain {exp_dim} value, " +msgid_plural "Your result should contain {exp_dim} values, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_dim} value." +msgid_plural "but it has {obj_dim} values." +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have {exp_cols} column, " +msgid_plural "Your table should have {exp_cols} columns, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_cols} column." +msgid_plural "but it has {obj_cols} columns." +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have {exp_rows} row, " +msgid_plural "Your table should have {exp_rows} rows, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_rows} row." +msgid_plural "but it has {obj_rows} rows." +msgstr[0] "" +msgstr[1] "" + +msgid "Your `{column_name}` column should contain {exp_dim} value, " +msgid_plural "Your `{column_name}` column should contain {exp_dim} values, " +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have {exp_n_dim} dimension, " +msgid_plural "Your table should have {exp_n_dim} dimensions, " +msgstr[0] "" +msgstr[1] "" + +msgid "Your result should have the name {missing_names}. " +msgid_plural "Your result should have the names {missing_names}. " +msgstr[0] "" +msgstr[1] "" + +msgid "Your result should not have the name {unexpected_names}." +msgid_plural "Your result should not have the names {unexpected_names}." +msgstr[0] "" +msgstr[1] "" + +msgid "Your `{column_name}` column should have the name {missing_names}. " +msgid_plural "" +"Your `{column_name}` column should have the names {missing_names}. " +msgstr[0] "" +msgstr[1] "" + +msgid "" +"Your `{column_name}` column should not have the name {unexpected_names}." +msgid_plural "" +"Your `{column_name}` column should not have the names {unexpected_names}." +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have a column named {missing_names}. " +msgid_plural "Your table should have columns named {missing_names}. " +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should not have a column named {unexpected_names}." +msgid_plural "Your table should not have columns named {unexpected_names}." +msgstr[0] "" +msgstr[1] "" + +msgid "The first value of your result should be {exp_values}." +msgid_plural "" +"The first {n_values} values of your result should be {exp_values}." +msgstr[0] "" +msgstr[1] "" + +msgid "The first value of your `{column_name}` column should be {exp_values}." +msgid_plural "" +"The first {n_values} values of your `{column_name}` column should be " +"{exp_values}." +msgstr[0] "" +msgstr[1] "" diff --git a/po/R-tblcheck.pot b/po/R-tblcheck.pot new file mode 100644 index 00000000..7cf1d75f --- /dev/null +++ b/po/R-tblcheck.pot @@ -0,0 +1,230 @@ +msgid "" +msgstr "" +"Project-Id-Version: tblcheck 0.0.0.9000\n" +"POT-Creation-Date: 2021-08-17 15:16\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: 8bit\n" + + +msgid "Your result should be {friendly_exp_class}, but it is {friendly_obj_class}." +msgstr "" + +msgid "Your `{column_name}` column should be {friendly_exp_class}, but it is {friendly_obj_class}." +msgstr "" + +msgid "Your table should be {friendly_exp_class}, but it is {friendly_obj_class}." +msgstr "" + +msgid "Your table is a rowwise data frame, but I was expecting it to be grouped. Maybe you need to use `group_by()`?" +msgstr "" + +msgid "Your table isn't a grouped data frame, but I was expecting it to be grouped. Maybe you need to use `group_by()`?" +msgstr "" + +msgid "Your table is a grouped data frame, but I wasn't expecting it to be grouped. Maybe you need to use `ungroup()`?" +msgstr "" + +msgid "Your table isn't a rowwise data frame, but I was expecting it to be rowwise. Maybe you need to use `rowwise()`?" +msgstr "" + +msgid "Your table is a rowwise data frame, but I wasn't expecting it to be rowwise. Maybe you need to use `ungroup()`?" +msgstr "" + +msgid "a vector with class {class_str}" +msgstr "" + +msgid "a vector with classes {class_str}" +msgstr "" + +msgid "an object with class {class_str}" +msgstr "" + +msgid "an object with classes {class_str}" +msgstr "" + +msgid "a text string (class `character`)" +msgstr "" + +msgid "a vector of text (class `character`)" +msgstr "" + +msgid "a number (class `numeric`)" +msgstr "" + +msgid "a vector of numbers (class `numeric`)" +msgstr "" + +msgid "an integer (class `integer`)" +msgstr "" + +msgid "a vector of integers (class `integer`)" +msgstr "" + +msgid "a TRUE/FALSE value (class `logical`)" +msgstr "" + +msgid "a vector of TRUE/FALSE values (class `logical`)" +msgstr "" + +msgid "a complex number (class `complex`)" +msgstr "" + +msgid "a vector of complex numbers (class `complex`)" +msgstr "" + +msgid "a raw byte value (class `raw`)" +msgstr "" + +msgid "a vector of raw byte values (class `raw`)" +msgstr "" + +msgid "a factor (class `factor`)" +msgstr "" + +msgid "a vector of factors (class `factor`)" +msgstr "" + +msgid "a date-time (class `POSIXct`)" +msgstr "" + +msgid "a vector of date-times (class `POSIXct`)" +msgstr "" + +msgid "a date-time (class `POSIXlt`)" +msgstr "" + +msgid "a vector of date-times (class `POSIXlt`)" +msgstr "" + +msgid "a tibble (class `tbl_df`)" +msgstr "" + +msgid "a data frame (class `data.frame`)" +msgstr "" + +msgid "a list (class `list`)" +msgstr "" + +msgid "a matrix (class `matrix`)" +msgstr "" + +msgid "an array (class `array`)" +msgstr "" + +msgid "`{name}` is not a column in `expected`." +msgstr "" + +msgid "Your table should have a column named `{exp_column}`." +msgstr "" + +msgid "Your result should be an array with dimensions {exp_dim_str}, but it has dimensions {obj_dim_str}." +msgstr "" + +msgid "Your result contains unexpected values." +msgstr "" + +msgid "Your `{column_name}` column contains unexpected values." +msgstr "" + +msgid "tblcheck_test_grade() expected a tblcheck function as the final expression" +msgstr "" + +msgid "An error occurred in the grading code:" +msgstr "" + +msgid "Uh-oh! We can't provide feedback at this time. Don't worry, it's not your fault! There's an issue behind-the-scenes with this exercise." +msgstr "" + +msgid "Your result should have {exp_n_dim} dimension, " +msgid_plural "Your result should have {exp_n_dim} dimensions, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_n_dim} dimension." +msgid_plural "but it has {obj_n_dim} dimensions." +msgstr[0] "" +msgstr[1] "" + +msgid "Your result should contain {exp_dim} value, " +msgid_plural "Your result should contain {exp_dim} values, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_dim} value." +msgid_plural "but it has {obj_dim} values." +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have {exp_cols} column, " +msgid_plural "Your table should have {exp_cols} columns, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_cols} column." +msgid_plural "but it has {obj_cols} columns." +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have {exp_rows} row, " +msgid_plural "Your table should have {exp_rows} rows, " +msgstr[0] "" +msgstr[1] "" + +msgid "but it has {obj_rows} row." +msgid_plural "but it has {obj_rows} rows." +msgstr[0] "" +msgstr[1] "" + +msgid "Your `{column_name}` column should contain {exp_dim} value, " +msgid_plural "Your `{column_name}` column should contain {exp_dim} values, " +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have {exp_n_dim} dimension, " +msgid_plural "Your table should have {exp_n_dim} dimensions, " +msgstr[0] "" +msgstr[1] "" + +msgid "Your result should have the name {missing_names}. " +msgid_plural "Your result should have the names {missing_names}. " +msgstr[0] "" +msgstr[1] "" + +msgid "Your result should not have the name {unexpected_names}." +msgid_plural "Your result should not have the names {unexpected_names}." +msgstr[0] "" +msgstr[1] "" + +msgid "Your `{column_name}` column should have the name {missing_names}. " +msgid_plural "Your `{column_name}` column should have the names {missing_names}. " +msgstr[0] "" +msgstr[1] "" + +msgid "Your `{column_name}` column should not have the name {unexpected_names}." +msgid_plural "Your `{column_name}` column should not have the names {unexpected_names}." +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should have a column named {missing_names}. " +msgid_plural "Your table should have columns named {missing_names}. " +msgstr[0] "" +msgstr[1] "" + +msgid "Your table should not have a column named {unexpected_names}." +msgid_plural "Your table should not have columns named {unexpected_names}." +msgstr[0] "" +msgstr[1] "" + +msgid "The first value of your result should be {exp_values}." +msgid_plural "The first {n_values} values of your result should be {exp_values}." +msgstr[0] "" +msgstr[1] "" + +msgid "The first value of your `{column_name}` column should be {exp_values}." +msgid_plural "The first {n_values} values of your `{column_name}` column should be {exp_values}." +msgstr[0] "" +msgstr[1] "" diff --git a/tests/testthat/test-tbl_check_column.R b/tests/testthat/test-tbl_check_column.R index 61cece4c..7b3a9728 100644 --- a/tests/testthat/test-tbl_check_column.R +++ b/tests/testthat/test-tbl_check_column.R @@ -11,9 +11,9 @@ test_that("tbl_check_column() checks classes", { "character", expected_length = 3, actual_length = 26, - vector = TRUE, column = "a" - ) + ), + ignore_attr = "class" ) }) @@ -27,9 +27,9 @@ test_that("tbl_check_column() checks the first three values", { problem( "column_values", letters[1:3], - vector = TRUE, column = "a" - ) + ), + ignore_attr = "class" ) }) @@ -46,9 +46,9 @@ test_that("tbl_check_column() checks multiple classes", { actual = "data.frame", expected_length = 1, actual_length = 1, - vector = TRUE, column = "a" - ) + ), + ignore_attr = "class" ) }) @@ -59,7 +59,8 @@ test_that("tbl_check_column() checks for value differences beyond the first 3", expect_equal( problem, - problem("column_values", vector = TRUE, column = "a") + problem("column_values", column = "a"), + ignore_attr = "class" ) }) @@ -70,7 +71,8 @@ test_that("max_diffs modifies the number of values to print", { expect_equal( problem, - problem("column_values", letters[26:22], vector = TRUE, column = "a") + problem("column_values", letters[26:22], column = "a"), + ignore_attr = "class" ) }) @@ -81,7 +83,8 @@ test_that("max_diffs doesn't overflow", { expect_equal( problem, - problem("column_values", letters[2:1], vector = TRUE, column = "a") + problem("column_values", letters[2:1], column = "a"), + ignore_attr = "class" ) }) @@ -92,7 +95,8 @@ test_that("checks that columns have the same length", { expect_equal( problem, - problem("column_dimensions", 4, 3, vector = TRUE, column = "a") + problem("column_dimensions", 4, 3, column = "a"), + ignore_attr = "class" ) }) @@ -104,6 +108,7 @@ test_that("checks that the column is present in object", { expect_equal( problem, problem("column_missing", "a", column = "a"), + ignore_attr = "class" ) }) diff --git a/tests/testthat/test-tbl_check_names.R b/tests/testthat/test-tbl_check_names.R index b0db2e62..fd8a9547 100644 --- a/tests/testthat/test-tbl_check_names.R +++ b/tests/testthat/test-tbl_check_names.R @@ -5,9 +5,8 @@ test_that("check missing names", { expect_equal( problem, - problem( - "names", missing = "b", unexpected = character(0), table = TRUE - ) + problem("table_names", missing = "b", unexpected = character(0)), + ignore_attr = "class" ) .result <- tibble::tibble(a = letters[1:3]) @@ -16,9 +15,8 @@ test_that("check missing names", { expect_equal( problem, - problem( - "names", missing = c("b", "c"), unexpected = character(0), table = TRUE - ) + problem("table_names", missing = c("b", "c"), unexpected = character(0)), + ignore_attr = "class" ) }) @@ -29,9 +27,8 @@ test_that("check unexpected names", { expect_equal( problem, - problem( - "names", missing = character(0), unexpected = "b", table = TRUE - ) + problem("table_names", missing = character(0), unexpected = "b"), + ignore_attr = "class" ) .result <- tibble::tibble(a = letters[1:3], b = a, c = a) @@ -40,9 +37,8 @@ test_that("check unexpected names", { expect_equal( problem, - problem( - "names", missing = character(0), unexpected = c("b", "c"), table = TRUE - ) + problem("table_names", missing = character(0), unexpected = c("b", "c")), + ignore_attr = "class" ) }) @@ -53,9 +49,8 @@ test_that("check missing and unexpected names", { expect_equal( problem, - problem( - "names", missing = c("x", "y"), unexpected = c("a", "b"), table = TRUE - ) + problem("table_names", missing = c("x", "y"), unexpected = c("a", "b")), + ignore_attr = "class" ) }) diff --git a/tests/testthat/test-tbl_check_table.R b/tests/testthat/test-tbl_check_table.R index 0a97db58..e1fd3ffc 100644 --- a/tests/testthat/test-tbl_check_table.R +++ b/tests/testthat/test-tbl_check_table.R @@ -10,9 +10,9 @@ test_that("tbl_check_table() class", { c("tbl_df", "tbl", "data.frame"), "data.frame", expected_length = 2, - actual_length = 2, - table = TRUE - ) + actual_length = 2 + ), + ignore_attr = "class" ) .result <- tibble::tibble(a = 1:10, b = a) @@ -26,9 +26,9 @@ test_that("tbl_check_table() class", { c("grouped_df", "tbl_df", "tbl", "data.frame"), c("tbl_df", "tbl", "data.frame"), expected_length = 2, - actual_length = 2, - table = TRUE - ) + actual_length = 2 + ), + ignore_attr = "class" ) .result <- dplyr::rowwise(tibble::tibble(a = 1:10, b = a)) @@ -42,9 +42,9 @@ test_that("tbl_check_table() class", { c("tbl_df", "tbl", "data.frame"), c("rowwise_df", "tbl_df", "tbl", "data.frame"), expected_length = 2, - actual_length = 2, - table = TRUE - ) + actual_length = 2 + ), + ignore_attr = "class" ) .result <- dplyr::rowwise(tibble::tibble(a = 1:10, b = a)) @@ -58,9 +58,9 @@ test_that("tbl_check_table() class", { c("grouped_df", "tbl_df", "tbl", "data.frame"), c("rowwise_df", "tbl_df", "tbl", "data.frame"), expected_length = 2, - actual_length = 2, - table = TRUE - ) + actual_length = 2 + ), + ignore_attr = "class" ) }) @@ -71,7 +71,8 @@ test_that("tbl_check_table() rows", { expect_equal( problem, - problem("table_dimensions", c(25, 2), c(26, 2), table = TRUE) + problem("table_dimensions", c(25, 2), c(26, 2)), + ignore_attr = "class" ) .result <- tibble::tibble(a = letters, b = a) @@ -80,7 +81,8 @@ test_that("tbl_check_table() rows", { expect_equal( problem, - problem("table_dimensions", c(1, 2), c(26, 2), table = TRUE) + problem("table_dimensions", c(1, 2), c(26, 2)), + ignore_attr = "class" ) }) @@ -91,7 +93,8 @@ test_that("tbl_check_table() ncol", { expect_equal( problem, - problem("table_dimensions", c(26, 2), c(26, 3), table = TRUE) + problem("table_dimensions", c(26, 2), c(26, 3)), + ignore_attr = "class" ) .result <- tibble::tibble(a = letters, b = a, c = a) @@ -100,7 +103,8 @@ test_that("tbl_check_table() ncol", { expect_equal( problem, - problem("table_dimensions", c(26, 1), c(26, 3), table = TRUE) + problem("table_dimensions", c(26, 1), c(26, 3)), + ignore_attr = "class" ) }) @@ -114,9 +118,9 @@ test_that("tbl_check_table() names", { problem( "table_names", missing = c("x", "y"), - unexpected = c("a", "b"), - table = TRUE - ) + unexpected = c("a", "b") + ), + ignore_attr = "class" ) }) @@ -127,7 +131,8 @@ test_that("tbl_check_table() columns", { expect_equal( problem, - problem("column_values", letters[24:26], vector = TRUE, column = "a") + problem("column_values", letters[24:26], column = "a"), + ignore_attr = "class" ) }) @@ -190,7 +195,8 @@ test_that("tbl_check_table() returns grades with row problems", { expect_equal( problem, - problem("table_dimensions", c(25, 1), c(26, 1), table = TRUE) + problem("table_dimensions", c(25, 1), c(26, 1)), + ignore_attr = "class" ) .result <- tibble::tibble(a = letters) @@ -199,7 +205,8 @@ test_that("tbl_check_table() returns grades with row problems", { expect_equal( problem, - problem("table_dimensions", c(1, 1), c(26, 1), table = TRUE) + problem("table_dimensions", c(1, 1), c(26, 1)), + ignore_attr = "class" ) }) @@ -210,7 +217,8 @@ test_that("tbl_check_table() returns ncol feedback to learnr", { expect_equal( problem, - problem("table_dimensions", c(26, 2), c(26, 3), table = TRUE) + problem("table_dimensions", c(26, 2), c(26, 3)), + ignore_attr = "class" ) .result <- tibble::tibble(a = letters, b = letters, c = letters) @@ -219,7 +227,8 @@ test_that("tbl_check_table() returns ncol feedback to learnr", { expect_equal( problem, - problem("table_dimensions", c(26, 1), c(26, 3), table = TRUE) + problem("table_dimensions", c(26, 1), c(26, 3)), + ignore_attr = "class" ) }) @@ -233,9 +242,9 @@ test_that("tbl_check_table() returns names feedback to learnr", { problem( "table_names", missing = c("x", "y", "z", "w"), - unexpected = c("a", "b", "c", "d"), - table = TRUE - ) + unexpected = c("a", "b", "c", "d") + ), + ignore_attr = "class" ) # ---- with all diffs --- @@ -248,9 +257,9 @@ test_that("tbl_check_table() returns names feedback to learnr", { problem( "table_names", missing = c("x", "y", "z", "w"), - unexpected = c("a", "b", "c", "d"), - table = TRUE - ) + unexpected = c("a", "b", "c", "d") + ), + ignore_attr = "class" ) # ---- with one diff --- @@ -263,8 +272,8 @@ test_that("tbl_check_table() returns names feedback to learnr", { problem( "table_names", missing = c("x", "y", "z", "w"), - unexpected = c("a", "b", "c", "d"), - table = TRUE - ) + unexpected = c("a", "b", "c", "d") + ), + ignore_attr = "class" ) }) diff --git a/tests/testthat/test-tbl_check_vector.R b/tests/testthat/test-tbl_check_vector.R index 4da8c1e1..bfaaa42b 100644 --- a/tests/testthat/test-tbl_check_vector.R +++ b/tests/testthat/test-tbl_check_vector.R @@ -10,9 +10,9 @@ test_that("tbl_check_vector() checks classes", { "integer", "character", expected_length = 3, - actual_length = 26, - vector = TRUE - ) + actual_length = 26 + ), + ignore_attr = "class" ) }) @@ -21,7 +21,11 @@ test_that("tbl_check_vector() checks the first three values", { .solution <- letters problem <- tbl_check_vector() - expect_equal(problem, problem("vector_values", letters[1:3], vector = TRUE)) + expect_equal( + problem, + problem("vector_values", letters[1:3]), + ignore_attr = "class" + ) }) test_that("tbl_check_vector() checks multiple classes", { @@ -37,9 +41,9 @@ test_that("tbl_check_vector() checks multiple classes", { expected = c("test", "class", "integer"), actual = "integer", expected_length = 10, - actual_length = 10, - vector = TRUE - ) + actual_length = 10 + ), + ignore_attr = "class" ) }) @@ -48,7 +52,11 @@ test_that("tbl_check_vector() checks for value differences beyond the first 3", .solution <- c(rep(1, 3), 10:15) problem <- tbl_check_vector() - expect_equal(problem, problem("vector_values", vector = TRUE)) + expect_equal( + problem, + problem("vector_values"), + ignore_attr = "class" + ) }) test_that("max_diffs modifies the number of values to print", { @@ -56,7 +64,11 @@ test_that("max_diffs modifies the number of values to print", { .solution <- rev(letters) problem <- tbl_check_vector(max_diffs = 5) - expect_equal(problem, problem("vector_values", letters[26:22], vector = TRUE)) + expect_equal( + problem, + problem("vector_values", letters[26:22]), + ignore_attr = "class" + ) }) test_that("max_diffs doesn't overflow", { @@ -64,7 +76,11 @@ test_that("max_diffs doesn't overflow", { .solution <- letters[2:1] problem <- tbl_check_vector(max_diffs = 3) - expect_equal(problem, problem("vector_values", letters[2:1], vector = TRUE)) + expect_equal( + problem, + problem("vector_values", letters[2:1]), + ignore_attr = "class" + ) }) test_that("checks that vectors have the same length", { @@ -72,7 +88,11 @@ test_that("checks that vectors have the same length", { .solution <- letters[1:4] problem <- tbl_check_vector() - expect_equal(problem, problem("vector_dimensions", 4, 3, vector = TRUE)) + expect_equal( + problem, + problem("vector_dimensions", 4, 3), + ignore_attr = "class" + ) }) test_that("checks that vectors have the same names", { @@ -84,8 +104,9 @@ test_that("checks that vectors have the same names", { problem, problem( "vector_names", - missing = letters[1:3], unexpected = letters[24:26], vector = TRUE - ) + missing = letters[1:3], unexpected = letters[24:26] + ), + ignore_attr = "class" ) }) diff --git a/tests/testthat/test-tbl_grade_column.R b/tests/testthat/test-tbl_grade_column.R index 15c10b0f..10f948d5 100644 --- a/tests/testthat/test-tbl_grade_column.R +++ b/tests/testthat/test-tbl_grade_column.R @@ -143,8 +143,8 @@ test_that("checks that the column is present in object", { }) test_that("checks that the column is present in expected", { - grade <- expect_warning( - tblcheck_test_grade({ + expect_warning( + grade <- tblcheck_test_grade({ .result <- tibble::tibble(b = letters[1:3]) .solution <- tibble::tibble(a = letters[1:3]) tbl_grade_column("b")