1#' Provide human-readable comparison of two objects 2#' 3#' @description 4#' `r lifecycle::badge("superseded")` 5#' 6#' `compare` is similar to [base::all.equal()], but somewhat buggy in its 7#' use of `tolerance`. Please use [waldo](https://waldo.r-lib.org/) instead. 8#' 9#' @export 10#' @param x,y Objects to compare 11#' @param ... Additional arguments used to control specifics of comparison 12#' @keywords internal 13#' @order 1 14compare <- function(x, y, ...) { 15 UseMethod("compare", x) 16} 17 18comparison <- function(equal = TRUE, message = "Equal") { 19 stopifnot(is.logical(equal), length(equal) == 1) 20 stopifnot(is.character(message)) 21 22 structure( 23 list( 24 equal = equal, 25 message = paste(message, collapse = "\n") 26 ), 27 class = "comparison" 28 ) 29} 30difference <- function(..., fmt = "%s") { 31 comparison(FALSE, sprintf(fmt, ...)) 32} 33no_difference <- function() { 34 comparison() 35} 36 37#' @export 38print.comparison <- function(x, ...) { 39 if (x$equal) { 40 cat("Equal\n") 41 return() 42 } 43 44 cat(x$message) 45} 46 47#' @export 48#' @rdname compare 49#' @order 2 50compare.default <- function(x, y, ..., max_diffs = 9) { 51 same <- all.equal(x, y, ...) 52 if (length(same) > max_diffs) { 53 same <- c(same[1:max_diffs], "...") 54 } 55 56 comparison(identical(same, TRUE), as.character(same)) 57} 58 59print_out <- function(x, ...) { 60 lines <- capture_output_lines(x, ..., print = TRUE) 61 paste0(lines, collapse = "\n") 62} 63 64# Common helpers --------------------------------------------------------------- 65 66same_length <- function(x, y) length(x) == length(y) 67diff_length <- function(x, y) difference(fmt = "Lengths differ: %i is not %i", length(x), length(y)) 68 69same_type <- function(x, y) identical(typeof(x), typeof(y)) 70diff_type <- function(x, y) difference(fmt = "Types not compatible: %s is not %s", typeof(x), typeof(y)) 71 72same_class <- function(x, y) { 73 if (!is.object(x) && !is.object(y)) { 74 return(TRUE) 75 } 76 identical(class(x), class(y)) 77} 78diff_class <- function(x, y) { 79 difference(fmt = "Classes differ: %s is not %s", format_class(class(x)), format_class(class(y))) 80} 81 82same_attr <- function(x, y) { 83 is.null(attr.all.equal(x, y)) 84} 85diff_attr <- function(x, y) { 86 out <- attr.all.equal(x, y) 87 difference(out) 88} 89 90vector_equal <- function(x, y) { 91 (is.na(x) & is.na(y)) | (!is.na(x) & !is.na(y) & x == y) 92} 93 94vector_equal_tol <- function(x, y, tolerance = .Machine$double.eps ^ 0.5) { 95 (is.na(x) & is.na(y)) | 96 (!is.na(x) & !is.na(y)) & (x == y | abs(x - y) < tolerance) 97 98} 99 100 101# character --------------------------------------------------------------- 102 103#' @param max_diffs Maximum number of differences to show 104#' @param max_lines Maximum number of lines to show from each difference 105#' @param check.attributes If `TRUE`, also checks values of attributes. 106#' @param width Width of output device 107#' @rdname compare 108#' @export 109#' @examples 110#' # Character ----------------------------------------------------------------- 111#' x <- c("abc", "def", "jih") 112#' compare(x, x) 113#' 114#' y <- paste0(x, "y") 115#' compare(x, y) 116#' 117#' compare(letters, paste0(letters, "-")) 118#' 119#' x <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Duis cursus 120#' tincidunt auctor. Vestibulum ac metus bibendum, facilisis nisi non, pulvinar 121#' dolor. Donec pretium iaculis nulla, ut interdum sapien ultricies a. " 122#' y <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Duis cursus 123#' tincidunt auctor. Vestibulum ac metus1 bibendum, facilisis nisi non, pulvinar 124#' dolor. Donec pretium iaculis nulla, ut interdum sapien ultricies a. " 125#' compare(x, y) 126#' compare(c(x, x), c(y, y)) 127#' 128compare.character <- function(x, y, check.attributes = TRUE, ..., 129 max_diffs = 5, max_lines = 5, 130 width = cli::console_width()) { 131 if (identical(x, y)) { 132 return(no_difference()) 133 } 134 135 if (!same_type(x, y)) { 136 return(diff_type(x, y)) 137 } 138 if (!same_class(x, y)) { 139 return(diff_class(x, y)) 140 } 141 if (!same_length(x, y)) { 142 return(diff_length(x, y)) 143 } 144 if (check.attributes && !same_attr(x, y)) { 145 return(diff_attr(x, y)) 146 } 147 148 diff <- !vector_equal(x, y) 149 150 if (!any(diff)) { 151 no_difference() 152 } else { 153 mismatches <- mismatch_character(x, y, diff) 154 difference(format( 155 mismatches, 156 max_diffs = max_diffs, 157 max_lines = max_lines, 158 width = width 159 )) 160 } 161} 162 163mismatch_character <- function(x, y, diff = !vector_equal(x, y)) { 164 structure( 165 list( 166 i = which(diff), 167 x = x[diff], 168 y = y[diff], 169 n = length(diff), 170 n_diff = sum(diff) 171 ), 172 class = "mismatch_character" 173 ) 174} 175 176#' @export 177format.mismatch_character <- function(x, ..., 178 max_diffs = 5, 179 max_lines = 5, 180 width = cli::console_width()) { 181 width <- width - 6 # allocate space for labels 182 n_show <- seq_len(min(x$n_diff, max_diffs)) 183 184 encode <- function(x) encodeString(x, quote = '"') 185 show_x <- str_trunc(encode(x$x[n_show]), width * max_lines) 186 show_y <- str_trunc(encode(x$y[n_show]), width * max_lines) 187 show_i <- x$i[n_show] 188 189 sidebyside <- Map(function(x, y, pos) { 190 x <- paste0("x[", pos, "]: ", str_chunk(x, width)) 191 y <- paste0("y[", pos, "]: ", str_chunk(y, width)) 192 paste(c(x, y), collapse = "\n") 193 }, show_x, show_y, show_i) 194 195 summary <- paste0(x$n_diff, "/", x$n, " mismatches") 196 paste0(summary, "\n", paste0(sidebyside, collapse = "\n\n")) 197} 198 199#' @export 200print.mismatch_character <- function(x, ...) { 201 cat(format(x, ...), "\n", sep = "") 202} 203 204str_trunc <- function(x, length) { 205 too_long <- nchar(x) > length 206 207 x[too_long] <- paste0(substr(x[too_long], 1, length - 3), "...") 208 x 209} 210str_chunk <- function(x, length) { 211 lines <- ceiling(nchar(x) / length) 212 start <- (seq_len(lines) - 1) * length + 1 213 214 substring(x, start, start + length - 1) 215} 216 217# compare.numeric --------------------------------------------------------- 218 219#' @export 220#' @rdname compare 221#' @param tolerance Numerical tolerance: any differences (in the sense of 222#' [base::all.equal()]) smaller than this value will be ignored. 223#' 224#' The default tolerance is `sqrt(.Machine$double.eps)`, unless long doubles 225#' are not available, in which case the test is skipped. 226#' @examples 227#' # Numeric ------------------------------------------------------------------- 228#' 229#' x <- y <- runif(100) 230#' y[sample(100, 10)] <- 5 231#' compare(x, y) 232#' 233#' x <- y <- 1:10 234#' x[5] <- NA 235#' x[6] <- 6.5 236#' compare(x, y) 237#' 238#' # Compare ignores minor numeric differences in the same way 239#' # as all.equal. 240#' compare(x, x + 1e-9) 241compare.numeric <- function(x, y, 242 tolerance = testthat_tolerance(), 243 check.attributes = TRUE, 244 ..., max_diffs = 9) { 245 all_equal <- all.equal( 246 x, y, tolerance = tolerance, 247 check.attributes = check.attributes, ... 248 ) 249 if (isTRUE(all_equal)) { 250 return(no_difference()) 251 } 252 253 if (!typeof(y) %in% c("integer", "double")) { 254 return(diff_type(x, y)) 255 } 256 if (!same_class(x, y)) { 257 return(diff_class(x, y)) 258 } 259 if (!same_length(x, y)) { 260 return(diff_length(x, y)) 261 } 262 if (check.attributes && !same_attr(x, y)) { 263 return(diff_attr(x, y)) 264 } 265 266 diff <- !vector_equal_tol(x, y, tolerance = tolerance) 267 268 if (!any(diff)) { 269 no_difference() 270 } else { 271 mismatches <- mismatch_numeric(x, y, diff) 272 difference(format(mismatches, max_diffs = max_diffs)) 273 } 274} 275 276#' @export 277#' @rdname compare 278testthat_tolerance <- function() { 279 if (identical(capabilities("long.double"), FALSE)) { 280 skip("Long doubles not available and `tolerance` not supplied") 281 } 282 283 .Machine$double.eps ^ 0.5 284} 285 286mismatch_numeric <- function(x, y, diff = !vector_equal(x, y)) { 287 structure( 288 list( 289 i = which(diff), 290 x = x[diff], 291 y = y[diff], 292 n = length(diff), 293 n_diff = sum(diff), 294 mu_diff = mean(abs(x[diff] - y[diff]), na.rm = TRUE) 295 ), 296 class = "mismatch_numeric" 297 ) 298} 299 300#' @export 301format.mismatch_numeric <- function(x, ..., max_diffs = 9, digits = 3) { 302 summary <- paste0(x$n_diff, "/", x$n, " mismatches") 303 if (x$n_diff > 1) { 304 mu <- format(x$mu_diff, digits = digits, trim = TRUE) 305 summary <- paste0(summary, " (average diff: ", mu, ")") 306 } 307 308 n_show <- seq_len(min(x$n_diff, max_diffs)) 309 310 diffs <- paste0( 311 format(paste0("[", x$i[n_show], "]")), " ", 312 format(x$x[n_show], digits = digits), 313 " - ", 314 format(x$y[n_show], digits = digits), 315 " == ", 316 format(x$x[n_show] - x$y[n_show], digits = digits) 317 ) 318 319 if (x$n_diff > length(n_show)) { 320 diffs <- c(diffs, "...") 321 } 322 323 paste0(summary, "\n", paste(diffs, collapse = "\n")) 324} 325 326#' @export 327print.mismatch_numeric <- function(x, ...) { 328 cat(format(x, ...), "\n", sep = "") 329} 330 331# compare.time ------------------------------------------------------------ 332 333#' @rdname compare 334#' @export 335compare.POSIXt <- function(x, y, tolerance = 0.001, ..., max_diffs = 9) { 336 if (!inherits(y, "POSIXt")) { 337 return(diff_class(x, y)) 338 } 339 if (!same_length(x, y)) { 340 return(diff_length(x, y)) 341 } 342 343 x <- standardise_tzone(as.POSIXct(x)) 344 y <- standardise_tzone(as.POSIXct(y)) 345 346 if (!same_attr(x, y)) { 347 return(diff_attr(x, y)) 348 } 349 350 diff <- !vector_equal_tol(x, y, tolerance = tolerance) 351 352 if (!any(diff)) { 353 no_difference() 354 } else { 355 mismatches <- mismatch_numeric(x, y, diff) 356 difference(format(mismatches, max_diffs = max_diffs)) 357 } 358} 359 360standardise_tzone <- function(x) { 361 if (is.null(attr(x, "tzone")) || identical(attr(x, "tzone"), Sys.timezone())) { 362 attr(x, "tzone") <- "" 363 } 364 365 x 366} 367 368