Add check_row_order argument (#134)

Author: rossellhayes

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: tblcheck
 Title: Grade Tables in Learning Exercises
-Version: 0.3.0.9000
+Version: 0.3.1
 Authors@R: c(
     person("Alexander", "Rossell Hayes", , "alex.rossellhayes@rstudio.com", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9412-0457")),
@@ -19,19 +19,20 @@ URL: https://pkgs.rstudio.com/tblcheck,
 BugReports: https://github.com/rstudio/tblcheck/issues
 Imports:
     checkmate,
+    dplyr,
     ellipsis,
     glue,
     gradethis (>= 0.2.7.9000),
     knitr,
     lifecycle,
     magrittr,
     methods,
+    purrr,
     rlang,
     tidyselect,
     utils,
     vctrs
 Suggests:
-    dplyr,
     learnr,
     lubridate,
     mockery,

NEWS.md

@@ -1,4 +1,6 @@
-# tblcheck (development version)
+# tblcheck 0.3.1
+
+* Add `check_row_order` argument to `tbl_check()`, `tbl_grade()`, and `tbl_equal()`. When `check_row_order()` is set to false, `object` and `expected` are arranged so that their row orders match before checking for differences in column values.
 
 # tblcheck 0.3.0
 

R/grade_this.R

@@ -83,6 +83,7 @@ grade_this_table <- function(
 	check_column_levels = check_columns,
 	check_column_values = check_columns,
 	tolerance = sqrt(.Machine$double.eps),
+	check_row_order = check_columns,
 	hint = getOption("gradethis.fail.hint", FALSE),
 	encourage = getOption("gradethis.fail.encourage", FALSE),
 	# gradethis pass/fail options

R/tbl_check.R

@@ -61,6 +61,8 @@
 #'   column has the same [factor levels][levels()] in `object` and `expected`.
 #' @param check_column_values `[logical(1)]`\cr Whether to check that each
 #'   column has the same values in `object` and `expected`.
+#' @param check_row_order `[logical(1)]`\cr Whether to check that the values in
+#'   each column are in the same order in `object` and `expected`.
 #' @inheritParams vec_check_values
 #' @param env The environment in which to find `.result` and `.solution`.
 #' @inheritDotParams gradethis::fail -message
@@ -125,6 +127,7 @@ tbl_check <- function(
 	check_column_levels = check_columns,
 	check_column_values = check_columns,
 	tolerance = sqrt(.Machine$double.eps),
+	check_row_order = check_columns,
 	env = parent.frame()
 ) {
 	if (inherits(object, ".result")) {
@@ -141,7 +144,9 @@ tbl_check <- function(
 		checkmate::assert_logical(check_groups, any.missing = FALSE, len = 1)
 		checkmate::assert_logical(check_columns, any.missing = FALSE, len = 1)
 		checkmate::assert_logical(check_column_class, any.missing = FALSE, len = 1)
+		checkmate::assert_logical(check_column_levels, any.missing = FALSE, len = 1)
 		checkmate::assert_logical(check_column_values, any.missing = FALSE, len = 1)
+		checkmate::assert_logical(check_row_order, any.missing = FALSE, len = 1)
 		checkmate::assert_data_frame(expected)
 	})
 
@@ -199,9 +204,24 @@ tbl_check <- function(
 		)
 	}
 
+	columns_in_common <- intersect(names(object), names(expected))
+
+	# If we don't care about row order,
+	# arrange the rows in `object` and `expected` in the same way
+	if (!check_row_order) {
+		object <- dplyr::arrange(
+			object,
+			dplyr::across(tidyselect::all_of(columns_in_common))
+		)
+		expected <- dplyr::arrange(
+			expected,
+			dplyr::across(tidyselect::all_of(columns_in_common))
+		)
+	}
+
 	# check column contents ----
 	if (check_columns) {
-		for (column in names(expected)) {
+		for (column in columns_in_common) {
 			return_if_problem(
 				tbl_check_column(
 					column = column,
@@ -213,7 +233,8 @@ tbl_check <- function(
 					check_values = check_column_values,
 					tolerance = tolerance,
 					check_length = FALSE
-				)
+				),
+				check_order = check_row_order
 			)
 		}
 	}
@@ -237,6 +258,7 @@ tbl_grade <- function(
 	check_column_levels = check_columns,
 	check_column_values = check_columns,
 	tolerance = sqrt(.Machine$double.eps),
+	check_row_order = check_columns,
 	env = parent.frame(),
 	...
 ) {
@@ -255,6 +277,7 @@ tbl_grade <- function(
 			check_column_class = check_column_class,
 			check_column_levels = check_column_levels,
 			check_column_values = check_column_values,
+			check_row_order = check_row_order,
 			tolerance = tolerance,
 			env = env
 		),

R/tbl_equal.R

@@ -28,6 +28,7 @@ tbl_equal <- function(
 	check_column_levels = check_columns,
 	check_column_values = check_columns,
 	tolerance = sqrt(.Machine$double.eps),
+	check_row_order = check_columns,
 	env = parent.frame()
 ) {
 	is.null(
@@ -46,6 +47,7 @@ tbl_equal <- function(
 			check_column_levels = check_column_levels,
 			check_column_values = check_column_values,
 			tolerance = tolerance,
+			check_row_order = check_row_order,
 			env = env
 		)
 	)

R/tests-helpers.R

@@ -18,6 +18,19 @@ expect_warning <- function(...) {
 	suppressWarnings(testthat::expect_warning(...))
 }
 
+expect_problem <- function(object, type, expected, actual, ...) {
+	testthat::expect_s3_class(object, "tblcheck_problem")
+
+	if (!rlang::is_missing(type)) testthat::expect_equal(object$type, type)
+	if (!rlang::is_missing(expected)) testthat::expect_equal(object$expected, expected)
+	if (!rlang::is_missing(actual)) testthat::expect_equal(object$actual, actual)
+
+	purrr::iwalk(
+		list(...),
+		function(value, name) testthat::expect_equal(object[[name]], value)
+	)
+}
+
 tblcheck_test_grade <- function(expr, return_all = FALSE) {
 	expr <- rlang::enexpr(expr)
 

R/vec_check_values.R

@@ -116,47 +116,50 @@ problem_message.values_problem <- function(problem, max_diffs = 3, ...) {
 	}
 
 	# First, alert the user if the first `n` values do not match
-	problem$n_values <- min(
-		max(length(problem$expected), length(problem$actual)),
-		max_diffs
-	)
-
-	first_n_values_are_equal <-
-		vctrs::vec_equal(
-			problem$expected[seq_len(problem$n_values)],
-			problem$actual[seq_len(problem$n_values)],
-			na_equal = TRUE
-		)
-
-	if (!all(first_n_values_are_equal)) {
-		problem$expected <- knitr::combine_words(
-			md_code(problem$expected[seq_len(problem$n_values)])
+	# Skip this if order was not checked, since that would make "first" meaningless
+	if (!isFALSE(problem$check_order)) {
+		problem$n_values <- min(
+			max(length(problem$expected), length(problem$actual)),
+			max_diffs
 		)
-		problem$actual <- knitr::combine_words(
-			md_code(problem$actual[seq_len(problem$n_values)])
-		)
-
-		problem$expected_msg <- problem$expected_msg %||%
-			if (is_problem(problem, "column")) {
-				ngettext(
-					problem$n_values,
-					"The first value of your `{column}` column should be {expected}, not {actual},",
-					"The first {n_values} values of your `{column}` column should be {expected},"
-				)
-			} else {
-				ngettext(
-					problem$n_values,
-					"The first value of your result should be {expected},",
-					"The first {n_values} values of your result should be {expected},"
-				)
-			}
-
-		problem$actual_message <- problem$actual_message %||%
-			" not {actual}."
 
-		return(
-			glue::glue_data(problem, problem$expected_msg, problem$actual_message)
-		)
+		first_n_values_are_equal <-
+			vctrs::vec_equal(
+				problem$expected[seq_len(problem$n_values)],
+				problem$actual[seq_len(problem$n_values)],
+				na_equal = TRUE
+			)
+
+		if (!all(first_n_values_are_equal)) {
+			problem$expected <- knitr::combine_words(
+				md_code(problem$expected[seq_len(problem$n_values)])
+			)
+			problem$actual <- knitr::combine_words(
+				md_code(problem$actual[seq_len(problem$n_values)])
+			)
+
+			problem$expected_msg <- problem$expected_msg %||%
+				if (is_problem(problem, "column")) {
+					ngettext(
+						problem$n_values,
+						"The first value of your `{column}` column should be {expected}, not {actual},",
+						"The first {n_values} values of your `{column}` column should be {expected},"
+					)
+				} else {
+					ngettext(
+						problem$n_values,
+						"The first value of your result should be {expected},",
+						"The first {n_values} values of your result should be {expected},"
+					)
+				}
+
+			problem$actual_message <- problem$actual_message %||%
+				" not {actual}."
+
+			return(
+				glue::glue_data(problem, problem$expected_msg, problem$actual_message)
+			)
+		}
 	}
 
 	# Next, alert if there are values in `actual` that aren't in `expected`
@@ -215,5 +218,7 @@ problem_message.values_problem <- function(problem, max_diffs = 3, ...) {
 	}
 
 	# If all else fails, return vague message
-	problem_message(problem("values"))
+	problem$expected <- NULL
+	problem$actual <- NULL
+	problem_message(problem)
 }

man/grade_this_table.Rd

@@ -238,3 +238,12 @@
         by `a`.
       >
 
+# tbl_grade() ignoring row order
+
+    Code
+      grade_ignore_rows_values_diff
+    Output
+      <gradethis_graded: [Incorrect]
+        Your `b` column contains unexpected values.
+      >
+