Export problem() and problem_message()

.lintr

@@ -1,8 +1,8 @@
-linters: with_defaults(
+linters: linters_with_defaults(
     line_length_linter(120),
     T_and_F_symbol_linter,
     absolute_path_linter,
     nonportable_path_linter,
-    semicolon_terminator_linter,
+    semicolon_linter,
     undesirable_operator_linter
   )

NAMESPACE

@@ -2,27 +2,29 @@
 
 S3method(format,tblcheck_problem)
 S3method(print,tblcheck_problem)
-S3method(tblcheck_grade,default)
-S3method(tblcheck_grade,list)
-S3method(tblcheck_grade,tblcheck_internal_problem)
-S3method(tblcheck_grade,tblcheck_problem)
-S3method(tblcheck_message,class_problem)
-S3method(tblcheck_message,default)
-S3method(tblcheck_message,dimensions_n_problem)
-S3method(tblcheck_message,dimensions_problem)
-S3method(tblcheck_message,groups_problem)
-S3method(tblcheck_message,length_problem)
-S3method(tblcheck_message,levels_n_problem)
-S3method(tblcheck_message,levels_order_problem)
-S3method(tblcheck_message,levels_problem)
-S3method(tblcheck_message,levels_reversed_problem)
-S3method(tblcheck_message,names_order_problem)
-S3method(tblcheck_message,names_problem)
-S3method(tblcheck_message,ncol_problem)
-S3method(tblcheck_message,not_table_problem)
-S3method(tblcheck_message,nrow_problem)
-S3method(tblcheck_message,tblcheck_problem)
-S3method(tblcheck_message,values_problem)
+S3method(problem_grade,default)
+S3method(problem_grade,gradethis_problem)
+S3method(problem_grade,list)
+S3method(problem_grade,tblcheck_internal_problem)
+S3method(problem_grade,tblcheck_problem)
+S3method(problem_message,class_problem)
+S3method(problem_message,default)
+S3method(problem_message,dimensions_n_problem)
+S3method(problem_message,dimensions_problem)
+S3method(problem_message,gradethis_problem)
+S3method(problem_message,groups_problem)
+S3method(problem_message,length_problem)
+S3method(problem_message,levels_n_problem)
+S3method(problem_message,levels_order_problem)
+S3method(problem_message,levels_problem)
+S3method(problem_message,levels_reversed_problem)
+S3method(problem_message,names_order_problem)
+S3method(problem_message,names_problem)
+S3method(problem_message,ncol_problem)
+S3method(problem_message,not_table_problem)
+S3method(problem_message,nrow_problem)
+S3method(problem_message,tblcheck_problem)
+S3method(problem_message,values_problem)
 export("%>%")
 export(.result)
 export(.solution)
@@ -31,6 +33,9 @@ export(grade_this_table)
 export(grade_this_vector)
 export(is_problem)
 export(is_tblcheck_problem)
+export(problem)
+export(problem_grade)
+export(problem_message)
 export(problem_type)
 export(tbl_check)
 export(tbl_check_class)
@@ -49,6 +54,7 @@ export(tbl_grade_is_table)
 export(tbl_grade_names)
 export(tbl_grade_table)
 export(tblcheck_grade)
+export(tblcheck_message)
 export(vec_check)
 export(vec_check_class)
 export(vec_check_dimensions)

NEWS.md

@@ -4,6 +4,12 @@
   - Messages now only suggest using the functions `group_by()`, `ungroup()` and `rowwise()` if both `object` and `expected` are `data.frame`s (#119).
   - Messages now describe non-atomic variables with length > 1 as "objects", not "vectors" (#122).
 
+* `problem()` and `problem_message()` are now exported functions. The first helps other packages create problem objects and the second is a generic method that can be used to turn a problem object into a human readable description (#124).
+
+## Deprecated Functions
+
+* `tblcheck_grade()` is now called `problem_grade()`. The old function name will continue to work, but a deprecation warning will prompt you to update to `problem_grade()` (#124).
+
 # tblcheck 0.1.3
 
 * Add `tolerance` argument to `vec_*_values()` (#111).

R/assert.R

@@ -12,7 +12,7 @@ return_if_internal_problem <- function(expr, ..., env = parent.frame()) {
 }
 
 #' @export
-tblcheck_grade.tblcheck_internal_problem <- function(
+problem_grade.tblcheck_internal_problem <- function(
   problem, max_diffs = 3, env = parent.frame(), ...
 ) {
   # move error up to top-level of grade

R/check_class.R

@@ -101,7 +101,7 @@ tbl_check_class <- function(
       exp_class,
       obj_class,
       # Object lengths are stored so the correct pluralization
-      # can be applied in tblcheck_message.class_problem()
+      # can be applied in problem_message.class_problem()
       expected_length = length(expected),
       actual_length = length(object)
     )
@@ -121,7 +121,7 @@ tbl_grade_class <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check_class(object, expected, ignore_class, env),
     env = env,
     ...
@@ -133,7 +133,7 @@ tbl_grade_class <- function(
 vec_grade_class <- tbl_grade_class
 
 #' @export
-tblcheck_message.class_problem <- function(problem, ...) {
+problem_message.class_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$msg <- problem$msg %||%
       "Your `{column}` column should be {expected}, but it is {actual}."

R/check_column.R

@@ -140,7 +140,7 @@ tbl_grade_column <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check_column(
       column = column,
       object = object,

R/check_dimensions.R

@@ -113,7 +113,7 @@ tbl_grade_dimensions <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check_dimensions(object, expected, check_ncol = check_ncol, env = env),
     env = env,
     ...
@@ -129,7 +129,7 @@ vec_grade_dimensions <- tbl_grade_dimensions
 vec_grade_length <- tbl_grade_dimensions
 
 #' @export
-tblcheck_message.dimensions_n_problem <- function(problem, ...) {
+problem_message.dimensions_n_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$exp_msg <- problem$exp_msg %||%
       ngettext(
@@ -164,7 +164,7 @@ tblcheck_message.dimensions_n_problem <- function(problem, ...) {
 }
 
 #' @export
-tblcheck_message.length_problem <- function(problem, ...) {
+problem_message.length_problem <- function(problem, ...) {
   problem$value_msg <- ""
 
   if (is_problem(problem, "column")) {
@@ -225,7 +225,7 @@ tblcheck_message.length_problem <- function(problem, ...) {
 }
 
 #' @export
-tblcheck_message.ncol_problem <- function(problem, ...) {
+problem_message.ncol_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$exp_msg <- problem$exp_msg %||%
       ngettext(
@@ -260,7 +260,7 @@ tblcheck_message.ncol_problem <- function(problem, ...) {
 }
 
 #' @export
-tblcheck_message.nrow_problem <- function(problem, ...) {
+problem_message.nrow_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$exp_msg <- problem$exp_msg %||%
       ngettext(
@@ -295,7 +295,7 @@ tblcheck_message.nrow_problem <- function(problem, ...) {
 }
 
 #' @export
-tblcheck_message.dimensions_problem <- function(problem, ...) {
+problem_message.dimensions_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$msg <- problem$exp_msg %||%
       gettext("Your `{column}` column should be an array with dimensions {expected}, but it has dimensions {actual}.")

R/check_groups.R

@@ -69,7 +69,7 @@ tbl_grade_groups <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check_groups(object, expected, env = env),
     max_diffs = max_diffs,
     env = env,
@@ -78,7 +78,7 @@ tbl_grade_groups <- function(
 }
 
 #' @export
-tblcheck_message.groups_problem <- function(problem, max_diffs = 3, ...) {
+problem_message.groups_problem <- function(problem, max_diffs = 3, ...) {
   if (is_problem(problem, "table")) {
     problem$missing_msg <- problem$missing_msg %||%
       gettext("Your table should be grouped by {missing}. ")

R/check_is_table.R

@@ -55,15 +55,15 @@ tbl_grade_is_table <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check_is_table(object, env),
     env = env,
     ...
   )
 }
 
 #' @export
-tblcheck_message.not_table_problem <- function(problem, ...) {
+problem_message.not_table_problem <- function(problem, ...) {
   problem$msg <- problem$msg %||%
     "Your result should be a table, but it is {actual}."
 

R/check_levels.R

@@ -87,7 +87,7 @@ vec_grade_levels <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     vec_check_levels(object, expected, env = env),
     max_diffs = max_diffs,
     env = env,
@@ -96,7 +96,7 @@ vec_grade_levels <- function(
 }
 
 #' @export
-tblcheck_message.levels_problem <- function(problem, max_diffs = 3, ...) {
+problem_message.levels_problem <- function(problem, max_diffs = 3, ...) {
   if (is_problem(problem, "column")) {
     problem$missing_msg <- problem$missing_msg %||%
       ngettext(
@@ -143,7 +143,7 @@ tblcheck_message.levels_problem <- function(problem, max_diffs = 3, ...) {
 }
 
 #' @export
-tblcheck_message.levels_n_problem <- function(problem, ...) {
+problem_message.levels_n_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$exp_msg <- problem$exp_msg %||%
       ngettext(
@@ -171,7 +171,7 @@ tblcheck_message.levels_n_problem <- function(problem, ...) {
 }
 
 #' @export
-tblcheck_message.levels_reversed_problem <- function(problem, ...) {
+problem_message.levels_reversed_problem <- function(problem, ...) {
   if (is_problem(problem, "column")) {
     problem$msg <- problem$msg %||%
       gettext("The order of the levels in your `{column}` column are the reverse of the expected order.")
@@ -184,7 +184,7 @@ tblcheck_message.levels_reversed_problem <- function(problem, ...) {
 }
 
 #' @export
-tblcheck_message.levels_order_problem <- function(problem, max_diffs = 3, ...) {
+problem_message.levels_order_problem <- function(problem, max_diffs = 3, ...) {
   if (is_problem(problem, "column")) {
     problem$msg <- problem$msg %||%
       "Your `{column}` column's levels were not in the expected order. "

R/check_names.R

@@ -98,7 +98,7 @@ tbl_grade_names <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check_names(object, expected, check_order = check_order, env = env),
     max_diffs = max_diffs,
     env = env,
@@ -111,7 +111,7 @@ tbl_grade_names <- function(
 vec_grade_names <- tbl_grade_names
 
 #' @export
-tblcheck_message.names_problem <- function(problem, max_diffs = 3, ...) {
+problem_message.names_problem <- function(problem, max_diffs = 3, ...) {
   if (is_problem(problem, "column")) {
     problem$missing_msg <- problem$missing_msg %||%
       ngettext(
@@ -172,7 +172,7 @@ tblcheck_message.names_problem <- function(problem, max_diffs = 3, ...) {
 }
 
 #' @export
-tblcheck_message.names_order_problem <- function(problem, max_diffs = 3, ...) {
+problem_message.names_order_problem <- function(problem, max_diffs = 3, ...) {
   problem$n_values <- min(
     max(length(problem$expected), length(problem$actual)),
     max_diffs

R/check_table.R

@@ -235,7 +235,7 @@ tbl_grade <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     tbl_check(
       object = object,
       expected = expected,

R/check_values.R

@@ -87,7 +87,7 @@ vec_grade_values <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     vec_check_values(
       object = object,
       expected = expected,
@@ -101,7 +101,7 @@ vec_grade_values <- function(
 }
 
 #' @export
-tblcheck_message.values_problem <- function(problem, max_diffs = 3, ...) {
+problem_message.values_problem <- function(problem, max_diffs = 3, ...) {
   # If values problem is empty, return vague message
   if (is.null(problem$actual) && is.null(problem$expected)) {
     if (is_problem(problem, "column")) {
@@ -215,5 +215,5 @@ tblcheck_message.values_problem <- function(problem, max_diffs = 3, ...) {
   }
 
   # If all else fails, return vague message
-  tblcheck_message(problem("values"))
+  problem_message(problem("values"))
 }

R/check_vector.R

@@ -149,7 +149,7 @@ vec_grade <- function(
   env = parent.frame(),
   ...
 ) {
-  tblcheck_grade(
+  problem_grade(
     vec_check(
       object = object,
       expected = expected,

R/deprecated.R

@@ -134,3 +134,25 @@ vec_grade_vector <- function(
     ...
   )
 }
+
+#' Deprecated Generics
+#'
+#' These generics are now deprecated.
+#'
+#' @keywords internal
+#' @name deprecated-methods
+NULL
+
+#' @describeIn deprecated-methods is now [problem_grade()].
+#' @export
+tblcheck_grade <- function(problem, ...) {
+  lifecycle::deprecate_soft("0.2.0", "tblcheck_grade()", "problem_grade()")
+  problem_grade(problem, ...)
+}
+
+#' @describeIn deprecated-methods is now [problem_message()].
+#' @export
+tblcheck_message <- function(problem, ...) {
+  lifecycle::deprecate_soft("0.2.0", "tblcheck_message()", "problem_message()")
+  problem_message(problem, ...)
+}