From ef84520e13f6423d2830efc0f7941b374a296afb Mon Sep 17 00:00:00 2001 From: Davis Vaughan Date: Thu, 16 Jan 2025 12:17:29 -0500 Subject: [PATCH] Reformat with air --- R/autoplot.R | 36 ++++-- R/bench_time.R | 8 +- R/bytes.R | 62 +++++++-- R/expression.R | 6 +- R/import-standalone-s3-register.R | 32 +++-- R/load.R | 1 - R/mark.R | 129 ++++++++++++------ R/press.R | 17 ++- R/time.R | 59 ++++++--- R/utils.R | 26 +++- R/workout.R | 6 +- air.toml | 0 tests/testthat/test-bench_process_memory.R | 8 +- tests/testthat/test-bench_time.R | 4 +- tests/testthat/test-bytes.R | 5 +- tests/testthat/test-expression.R | 5 +- tests/testthat/test-mark.R | 144 ++++++++++++++++----- tests/testthat/test-press.R | 3 +- tests/testthat/test-time.R | 5 +- tests/testthat/test-workout.R | 5 +- 20 files changed, 405 insertions(+), 156 deletions(-) create mode 100644 air.toml diff --git a/R/autoplot.R b/R/autoplot.R index 8843359..cde4793 100644 --- a/R/autoplot.R +++ b/R/autoplot.R @@ -46,9 +46,11 @@ #' } #' } # Lazily registered in `.onLoad()` -autoplot.bench_mark <- function(object, - type = c("beeswarm", "jitter", "ridge", "boxplot", "violin"),...) { - +autoplot.bench_mark <- function( + object, + type = c("beeswarm", "jitter", "ridge", "boxplot", "violin"), + ... +) { rlang::check_installed(c("ggplot2", "tidyr"), "for `autoplot()`.") type <- match.arg(type) @@ -69,8 +71,8 @@ autoplot.bench_mark <- function(object, } p <- ggplot2::ggplot(res) - - switch(type, + switch( + type, beeswarm = p <- p + ggplot2::aes(.data$expression, .data$time, color = .data$gc) + ggbeeswarm::geom_quasirandom(...) + @@ -93,21 +95,26 @@ autoplot.bench_mark <- function(object, violin = p <- p + ggplot2::aes(.data$expression, .data$time) + ggplot2::geom_violin(...) + - ggplot2::coord_flip()) + ggplot2::coord_flip() + ) parameters <- setdiff( colnames(object), - c("expression", summary_cols, data_cols, c("level0", "level1", "level2"))) + c("expression", summary_cols, data_cols, c("level0", "level1", "level2")) + ) if (length(parameters) == 0) { return(p) } if (length(parameters) == 2) { - return(p + - ggplot2::facet_grid( - paste0(parameters[[1]], "~", parameters[[2]]), - labeller = ggplot2::label_both)) + return( + p + + ggplot2::facet_grid( + paste0(parameters[[1]], "~", parameters[[2]]), + labeller = ggplot2::label_both + ) + ) } p + ggplot2::facet_wrap(parameters, labeller = ggplot2::label_both) @@ -117,7 +124,12 @@ autoplot.bench_mark <- function(object, #' @param x A `bench_mark` object. #' @param y Ignored, required for compatibility with the `plot()` generic. #' @export -plot.bench_mark <- function(x, ..., type = c("beeswarm", "jitter", "ridge", "boxplot", "violin"), y) { +plot.bench_mark <- function( + x, + ..., + type = c("beeswarm", "jitter", "ridge", "boxplot", "violin"), + y +) { type <- match.arg(type) ggplot2::autoplot(x, type = type, ...) } diff --git a/R/bench_time.R b/R/bench_time.R index 1610bf2..4c4f129 100644 --- a/R/bench_time.R +++ b/R/bench_time.R @@ -16,7 +16,8 @@ bench_time <- function(expr) { stats::setNames( as_bench_time(.Call(system_time_, substitute(expr), parent.frame())), - c("process", "real")) + c("process", "real") + ) } #' @export @@ -46,5 +47,8 @@ bench_memory <- function(expr) { memory <- parse_allocations(f) - tibble::tibble(mem_alloc = bench_bytes(sum(memory$bytes, na.rm = TRUE)), memory = list(memory)) + tibble::tibble( + mem_alloc = bench_bytes(sum(memory$bytes, na.rm = TRUE)), + memory = list(memory) + ) } diff --git a/R/bytes.R b/R/bytes.R index a2d07f6..a5e971f 100644 --- a/R/bytes.R +++ b/R/bytes.R @@ -1,7 +1,17 @@ # This is mostly a copy of https://github.com/r-lib/fs/blob/0f5b6191935fe4c862d2e5003655e6c1669f4afd/R/fs_bytes.R # If I end up needing this in a third package it should probably live in a package somewhere, maybe prettyunits? -byte_units <- c('B' = 1, 'K' = 1024, 'M' = 1024 ^ 2, 'G' = 1024 ^ 3, 'T' = 1024 ^ 4, 'P' = 1024 ^ 5, 'E' = 1024 ^ 6, 'Z' = 1024 ^ 7, 'Y' = 1024 ^ 8) +byte_units <- c( + 'B' = 1, + 'K' = 1024, + 'M' = 1024^2, + 'G' = 1024^3, + 'T' = 1024^4, + 'P' = 1024^5, + 'E' = 1024^6, + 'Z' = 1024^7, + 'Y' = 1024^8 +) #' Human readable memory sizes #' @@ -42,7 +52,14 @@ setOldClass(c("bench_bytes", "numeric"), numeric()) #' @export as_bench_bytes.default <- function(x) { x <- as.character(x) - m <- captures(x, regexpr("^(?[[:digit:].]+)\\s*(?[KMGTPEZY]?)i?[Bb]?$", x, perl = TRUE)) + m <- captures( + x, + regexpr( + "^(?[[:digit:].]+)\\s*(?[KMGTPEZY]?)i?[Bb]?$", + x, + perl = TRUE + ) + ) m$unit[m$unit == ""] <- "B" new_bench_bytes(unname(as.numeric(m$size) * byte_units[m$unit])) } @@ -59,7 +76,13 @@ as_bench_bytes.numeric <- function(x) { # Adapted from https://github.com/gaborcsardi/prettyunits #' @export -format.bench_bytes <- function(x, scientific = FALSE, digits = 3, drop0trailing = TRUE, ...) { +format.bench_bytes <- function( + x, + scientific = FALSE, + digits = 3, + drop0trailing = TRUE, + ... +) { nms <- names(x) bytes <- unclass(x) @@ -74,13 +97,19 @@ format.bench_bytes <- function(x, scientific = FALSE, digits = 3, drop0trailing ## NA and NaN bytes res[is.na(bytes)] <- NA_real_ res[is.nan(bytes)] <- NaN - unit[is.na(bytes)] <- "" # Includes NaN as well + unit[is.na(bytes)] <- "" # Includes NaN as well # Append an extra B to each unit large_units <- unit %in% names(byte_units)[-1] unit[large_units] <- paste0(unit[large_units], "B") - res <- format(res, scientific = scientific, digits = digits, drop0trailing = drop0trailing, ...) + res <- format( + res, + scientific = scientific, + digits = digits, + drop0trailing = drop0trailing, + ... + ) stats::setNames(paste0(res, unit), nms) } @@ -120,13 +149,16 @@ max.bench_bytes <- function(x, ...) { #' @export # Adapted from Ops.numeric_version -Ops.bench_bytes <- function (e1, e2) { +Ops.bench_bytes <- function(e1, e2) { if (nargs() == 1L) { - stop(sprintf("unary '%s' not defined for \"bench_bytes\" objects", .Generic), - call. = FALSE) + stop( + sprintf("unary '%s' not defined for \"bench_bytes\" objects", .Generic), + call. = FALSE + ) } - boolean <- switch(.Generic, + boolean <- switch( + .Generic, `+` = TRUE, `-` = TRUE, `*` = TRUE, @@ -138,10 +170,13 @@ Ops.bench_bytes <- function (e1, e2) { `!=` = TRUE, `<=` = TRUE, `>=` = TRUE, - FALSE) + FALSE + ) if (!boolean) { - stop(sprintf("'%s' not defined for \"bench_bytes\" objects", .Generic), - call. = FALSE) + stop( + sprintf("'%s' not defined for \"bench_bytes\" objects", .Generic), + call. = FALSE + ) } e1 <- as_bench_bytes(e1) e2 <- as_bench_bytes(e2) @@ -158,7 +193,6 @@ type_sum.bench_bytes <- function(x) { "bch:byt" } - #' Benchmark time transformation #' #' This both log transforms the times and formats the labels as a `bench_time` @@ -179,7 +213,7 @@ bench_bytes_trans <- function(base = 2) { ) } trans <- function(x) log(as.numeric(x), base) - inv <- function(x) as_bench_bytes(base ^ as.numeric(x)) + inv <- function(x) as_bench_bytes(base^as.numeric(x)) scales::trans_new( name = paste0("bch:byt-", format(base)), diff --git a/R/expression.R b/R/expression.R index 286fb3a..834c7d9 100644 --- a/R/expression.R +++ b/R/expression.R @@ -87,7 +87,11 @@ scale_y_bench_expr <- function(...) { #' @rdname scale_bench_expr #' @keywords internal #' @export -scale_colour_bench_expr <- function(palette = scales::hue_pal(...), ..., aesthetics = "colour") { +scale_colour_bench_expr <- function( + palette = scales::hue_pal(...), + ..., + aesthetics = "colour" +) { sc <- ggplot2::discrete_scale(aesthetics, "bench_expr", palette, ...) sc$transform <- as.character sc diff --git a/R/import-standalone-s3-register.R b/R/import-standalone-s3-register.R index 15c040b..848e157 100644 --- a/R/import-standalone-s3-register.R +++ b/R/import-standalone-s3-register.R @@ -101,22 +101,26 @@ s3_register <- function(generic, class, method = NULL) { method_fn <- get_method(method) stopifnot(is.function(method_fn)) - # Only register if generic can be accessed if (exists(generic, envir)) { registerS3method(generic, class, method_fn, envir = envir) } else if (identical(Sys.getenv("NOT_CRAN"), "true")) { warn <- .rlang_s3_register_compat("warn") - warn(c( - sprintf( - "Can't find generic `%s` in package %s to register S3 method.", - generic, - package - ), - "i" = "This message is only shown to developers using devtools.", - "i" = sprintf("Do you need to update %s to the latest version?", package) - )) + warn( + c( + sprintf( + "Can't find generic `%s` in package %s to register S3 method.", + generic, + package + ), + "i" = "This message is only shown to developers using devtools.", + "i" = sprintf( + "Do you need to update %s to the latest version?", + package + ) + ) + ) } } @@ -150,9 +154,11 @@ s3_register <- function(generic, class, method = NULL) { ) # Only use rlang if it is fully loaded (#1482) - if (try_rlang && - requireNamespace("rlang", quietly = TRUE) && - environmentIsLocked(asNamespace("rlang"))) { + if ( + try_rlang && + requireNamespace("rlang", quietly = TRUE) && + environmentIsLocked(asNamespace("rlang")) + ) { switch( fn, is_interactive = return(rlang::is_interactive) diff --git a/R/load.R b/R/load.R index f55939c..3958bb2 100644 --- a/R/load.R +++ b/R/load.R @@ -1,4 +1,3 @@ - #' Get system load averages #' #' Uses OS system APIs to return the load average for the past 1, 5 and 15 minutes. diff --git a/R/mark.R b/R/mark.R index 8bc0f8e..81af3c9 100644 --- a/R/mark.R +++ b/R/mark.R @@ -39,10 +39,20 @@ NULL #' dat[which(dat$x > 500), ], #' subset(dat, x > 500)) #' @export -mark <- function(..., min_time = .5, iterations = NULL, min_iterations = 1, - max_iterations = 10000, check = TRUE, memory = capabilities("profmem"), filter_gc = TRUE, - relative = FALSE, time_unit = NULL, exprs = NULL, env = parent.frame()) { - +mark <- function( + ..., + min_time = .5, + iterations = NULL, + min_iterations = 1, + max_iterations = 10000, + check = TRUE, + memory = capabilities("profmem"), + filter_gc = TRUE, + relative = FALSE, + time_unit = NULL, + exprs = NULL, + env = parent.frame() +) { if (!is.null(iterations)) { min_iterations <- iterations max_iterations <- iterations @@ -63,7 +73,13 @@ mark <- function(..., min_time = .5, iterations = NULL, min_iterations = 1, n_exprs <- length(exprs) - results <- list(expression = new_bench_expr(exprs), time = vector("list", n_exprs), gc = vector("list", n_exprs), memory = vector("list", n_exprs), result = vector("list", n_exprs)) + results <- list( + expression = new_bench_expr(exprs), + time = vector("list", n_exprs), + gc = vector("list", n_exprs), + memory = vector("list", n_exprs), + result = vector("list", n_exprs) + ) # Helper for evaluating with memory profiling eval_one <- function(e, profile_memory) { @@ -101,13 +117,15 @@ mark <- function(..., min_time = .5, iterations = NULL, min_iterations = 1, if (!isTRUE(comp)) { expressions <- as.character(results$expression) - stop(glue::glue(" + stop( + glue::glue( + " Each result must equal the first result: `{first}` does not equal `{current}` ", first = expressions[[1]], current = expressions[[i]] - ), + ), call. = FALSE ) } @@ -118,8 +136,20 @@ mark <- function(..., min_time = .5, iterations = NULL, min_iterations = 1, for (i in seq_len(length(exprs))) { error <- NULL gc_msg <- with_gcinfo({ - tryCatch(error = function(e) { e$call <- NULL; error <<- e}, - res <- .Call(mark_, exprs[[i]], env, min_time, as.integer(min_iterations), as.integer(max_iterations), TRUE) + tryCatch( + error = function(e) { + e$call <- NULL + error <<- e + }, + res <- .Call( + mark_, + exprs[[i]], + env, + min_time, + as.integer(min_iterations), + as.integer(max_iterations), + TRUE + ) ) }) if (!is.null(error)) { @@ -130,8 +160,12 @@ mark <- function(..., min_time = .5, iterations = NULL, min_iterations = 1, results$gc[[i]] <- parse_gc(gc_msg) } - out <- summary(bench_mark(tibble::as_tibble(results, .name_repair = "minimal")), - filter_gc = filter_gc, relative = relative, time_unit = time_unit) + out <- summary( + bench_mark(tibble::as_tibble(results, .name_repair = "minimal")), + filter_gc = filter_gc, + relative = relative, + time_unit = time_unit + ) out } @@ -217,19 +251,23 @@ time_cols <- c("min", "median", "total_time") #' # Or output relative times #' summary(results, relative = TRUE) #' @export -summary.bench_mark <- function(object, filter_gc = TRUE, relative = FALSE, time_unit = NULL, ...) { +summary.bench_mark <- function( + object, + filter_gc = TRUE, + relative = FALSE, + time_unit = NULL, + ... +) { nms <- colnames(object) parameters <- setdiff(nms, c("expression", summary_cols, data_cols)) - num_gc <- lapply(object$gc, - function(x) { - res <- rowSums(x) - if (length(res) == 0) { - res <- rep(0, length(x)) - } - res + num_gc <- lapply(object$gc, function(x) { + res <- rowSums(x) + if (length(res) == 0) { + res <- rep(0, length(x)) } - ) + res + }) if (isTRUE(filter_gc)) { no_gc <- lapply(num_gc, `==`, 0) times <- Map(`[`, object$time, no_gc) @@ -239,8 +277,9 @@ summary.bench_mark <- function(object, filter_gc = TRUE, relative = FALSE, time_ if (filter_gc && any(lengths(times) == 0)) { times <- object$time - warning(call. = FALSE, - "Some expressions had a GC in every iteration; so filtering is disabled." + warning( + call. = FALSE, + "Some expressions had a GC in every iteration; so filtering is disabled." ) } @@ -250,25 +289,38 @@ summary.bench_mark <- function(object, filter_gc = TRUE, relative = FALSE, time_ object$total_time <- new_bench_time(vdapply(times, sum)) object$n_itr <- viapply(times, length) - object$`itr/sec` <- as.numeric(object$n_itr / object$total_time) + object$`itr/sec` <- as.numeric(object$n_itr / object$total_time) object$n_gc <- vdapply(num_gc, sum) - object$`gc/sec` <- as.numeric(object$n_gc / object$total_time) + object$`gc/sec` <- as.numeric(object$n_gc / object$total_time) object$mem_alloc <- bench_bytes( - vdapply(object$memory, function(x) if (is.null(x)) NA else sum(x$bytes, na.rm = TRUE))) + vdapply( + object$memory, + function(x) if (is.null(x)) NA else sum(x$bytes, na.rm = TRUE) + ) + ) if (isTRUE(relative)) { - object[summary_cols] <- lapply(object[summary_cols], function(x) as.numeric(x / min(x))) + object[summary_cols] <- lapply( + object[summary_cols], + function(x) as.numeric(x / min(x)) + ) } if (!is.null(time_unit)) { time_unit <- match.arg(time_unit, names(time_units())) - object[time_cols] <- lapply(object[time_cols], function(x) as.numeric(x / time_units()[time_unit])) + object[time_cols] <- lapply( + object[time_cols], + function(x) as.numeric(x / time_units()[time_unit]) + ) } - to_keep <- intersect(c("expression", parameters, summary_cols, data_cols), names(object)) + to_keep <- intersect( + c("expression", parameters, summary_cols, data_cols), + names(object) + ) bench_mark(object[to_keep]) } @@ -278,14 +330,11 @@ summary.bench_mark <- function(object, filter_gc = TRUE, relative = FALSE, time_ } parse_allocations <- function(filename) { - if (!file.exists(filename)) { empty_Rprofmem <- structure( - list(what = character(), - bytes = integer(), - trace = list()), - class = c("Rprofmem", - "data.frame")) + list(what = character(), bytes = integer(), trace = list()), + class = c("Rprofmem", "data.frame") + ) return(empty_Rprofmem) } @@ -294,7 +343,10 @@ parse_allocations <- function(filename) { tryCatch( profmem::readRprofmem(filename), error = function(e) { - stop("Memory profiling failed.\n If you are benchmarking parallel code you must set `memory = FALSE`.", call. = FALSE) + stop( + "Memory profiling failed.\n If you are benchmarking parallel code you must set `memory = FALSE`.", + call. = FALSE + ) } ) } @@ -351,7 +403,9 @@ unnest.bench_mark <- function(data, ...) { if (tidyr_new_interface()) { data <- suppressWarnings(NextMethod(.Generic, data, ...)) } else { - data <- suppressWarnings(NextMethod(.Generic, data, time, gc, .drop = FALSE)) + data <- suppressWarnings( + NextMethod(.Generic, data, time, gc, .drop = FALSE) + ) } # Add bench_time class back to the time column @@ -363,7 +417,8 @@ unnest.bench_mark <- function(data, ...) { data$level2 > 0 ~ "level2", data$level1 > 0 ~ "level1", data$level0 > 0 ~ "level0", - TRUE ~ "none") + TRUE ~ "none" + ) data$gc <- factor(data$gc, c("none", "level0", "level1", "level2")) data diff --git a/R/press.R b/R/press.R index e27e324..7f962b9 100644 --- a/R/press.R +++ b/R/press.R @@ -57,11 +57,17 @@ press <- function(..., .grid = NULL) { if (!is.null(.grid)) { if (any(!unnamed)) { - stop("Must supply either `.grid` or named arguments, not both", call. = FALSE) + stop( + "Must supply either `.grid` or named arguments, not both", + call. = FALSE + ) } parameters <- .grid } else { - parameters <- expand.grid(lapply(args[!unnamed], rlang::eval_tidy), stringsAsFactors = FALSE) + parameters <- expand.grid( + lapply(args[!unnamed], rlang::eval_tidy), + stringsAsFactors = FALSE + ) } quiet <- bench_press_quiet() @@ -95,7 +101,11 @@ press <- function(..., .grid = NULL) { # TODO: print parameters / results that are unequal? } res <- do.call(rbind, res) - parameters <- parameters[rep(seq_len(nrow(parameters)), each = rows[[1]]), , drop = FALSE] + parameters <- parameters[ + rep(seq_len(nrow(parameters)), each = rows[[1]]), + , + drop = FALSE + ] bench_mark(tibble::as_tibble(cbind(res[1], parameters, res[-1]))) } @@ -107,4 +117,3 @@ bench_press_quiet <- function() { local_press_quiet <- function(frame = rlang::caller_env()) { rlang::local_options(bench.press_quiet = TRUE, .frame = frame) } - diff --git a/R/time.R b/R/time.R index 7a821a7..00e9370 100644 --- a/R/time.R +++ b/R/time.R @@ -1,6 +1,7 @@ time_units <- function() { stats::setNames( - c(1e-9, + c( + 1e-9, 1e-6, if (is_utf8_output()) 1e-6, 1e-3, @@ -8,8 +9,10 @@ time_units <- function() { 60, 60 * 60, 60 * 60 * 24, - 60 * 60 * 24 * 7), - c("ns", + 60 * 60 * 24 * 7 + ), + c( + "ns", "us", if (is_utf8_output()) "\U00B5s", "ms", @@ -17,7 +20,8 @@ time_units <- function() { "m", "h", "d", - "w") + "w" + ) ) } @@ -52,9 +56,10 @@ setOldClass(c("bench_time", "numeric"), numeric()) #' @export as_bench_time.default <- function(x) { x <- as.character(x) - re <- glue::glue(" - ^(?[[:digit:].]+)\\s*(?{nms}?)$ - ", nms = paste0(names(time_units()), collapse = "|")) + re <- glue::glue( + "^(?[[:digit:].]+)\\s*(?{nms}?)$", + nms = paste0(names(time_units()), collapse = "|") + ) m <- captures(x, regexpr(re, x, perl = TRUE)) m$unit[m$unit == ""] <- "s" @@ -80,14 +85,20 @@ find_unit <- function(x, units) { } epsilon <- 1 - (x * (1 / units)) names( - utils::tail(n = 1, - which(epsilon < tolerance))) + utils::tail(n = 1, which(epsilon < tolerance)) + ) } # Adapted from https://github.com/gaborcsardi/prettyunits # Aims to be consistent with ls -lh, so uses 1024 KiB units, 3 or less digits etc. #' @export -format.bench_time <- function(x, scientific = FALSE, digits = 3, drop0trailing = TRUE, ...) { +format.bench_time <- function( + x, + scientific = FALSE, + digits = 3, + drop0trailing = TRUE, + ... +) { nms <- names(x) # convert negative times to 1ns, this can happen if the minimum calculated @@ -110,7 +121,13 @@ format.bench_time <- function(x, scientific = FALSE, digits = 3, drop0trailing = res[is.infinite(seconds) & seconds < 0] <- -Inf unit[is.na(seconds) | is.infinite(seconds)] <- "" - res <- format(res, scientific = scientific, digits = digits, drop0trailing = drop0trailing, ...) + res <- format( + res, + scientific = scientific, + digits = digits, + drop0trailing = drop0trailing, + ... + ) stats::setNames(paste0(res, unit), nms) } @@ -152,11 +169,14 @@ max.bench_time <- function(x, ...) { # Adapted from Ops.numeric_version Ops.bench_time <- function(e1, e2, ...) { if (nargs() == 1L) { - stop(sprintf("unary '%s' not defined for \"bench_time\" objects", .Generic), - call. = FALSE) + stop( + sprintf("unary '%s' not defined for \"bench_time\" objects", .Generic), + call. = FALSE + ) } - boolean <- switch(.Generic, + boolean <- switch( + .Generic, `+` = TRUE, `-` = TRUE, `*` = TRUE, @@ -169,10 +189,13 @@ Ops.bench_time <- function(e1, e2, ...) { `<=` = TRUE, `>=` = TRUE, `%%` = TRUE, - FALSE) + FALSE + ) if (!boolean) { - stop(sprintf("'%s' not defined for \"bench_time\" objects", .Generic), - call. = FALSE) + stop( + sprintf("'%s' not defined for \"bench_time\" objects", .Generic), + call. = FALSE + ) } e1 <- as_bench_time(e1) e2 <- as_bench_time(e2) @@ -220,7 +243,7 @@ bench_time_trans <- function(base = 10) { } trans <- function(x) log(as.numeric(x), base) - inv <- function(x) as_bench_time(base ^ as.numeric(x)) + inv <- function(x) as_bench_time(base^as.numeric(x)) scales::trans_new( name = paste0("bch:tm-", format(base)), diff --git a/R/utils.R b/R/utils.R index a21063a..90fdeb9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -5,13 +5,26 @@ vlapply <- function(x, f, ...) vapply(x, f, logical(1), ...) captures <- function(x, m) { assert("`x` must be a character", is.character(x)) - assert("`m` must be a match object from `regexpr()`", + assert( + "`m` must be a match object from `regexpr()`", inherits(m, "integer") && - all(c("match.length", "capture.start", "capture.length", "capture.names") %in% names(attributes(m)))) + all( + c( + "match.length", + "capture.start", + "capture.length", + "capture.names" + ) %in% + names(attributes(m)) + ) + ) starts <- attr(m, "capture.start") strings <- substring(x, starts, starts + attr(m, "capture.length") - 1L) - res <- data.frame(matrix(strings, ncol = NCOL(starts)), stringsAsFactors = FALSE) + res <- data.frame( + matrix(strings, ncol = NCOL(starts)), + stringsAsFactors = FALSE + ) colnames(res) <- auto_name_vec(attr(m, "capture.names")) res[is.na(m) | m == -1, ] <- NA_character_ res @@ -26,7 +39,10 @@ assert <- function(msg, ..., class = "invalid_argument") { } bench_error <- function(msg, class = "invalid_argument") { - structure(class = c(class, "bench_error", "error", "condition"), list(message = msg)) + structure( + class = c(class, "bench_error", "error", "condition"), + list(message = msg) + ) } auto_name_vec <- function(names) { @@ -70,7 +86,7 @@ deparse_trunc <- function(x, width = getOption("width")) { # inlined from https://github.com/r-lib/cli/blob/master/R/utf8.R is_utf8_output <- function() { opt <- getOption("cli.unicode", NULL) - if (! is.null(opt)) { + if (!is.null(opt)) { isTRUE(opt) } else { l10n_info()$`UTF-8` && !is_latex_output() diff --git a/R/workout.R b/R/workout.R index ff3b450..14f24a7 100644 --- a/R/workout.R +++ b/R/workout.R @@ -36,7 +36,11 @@ workout <- function(expr, description = NULL) { #' @rdname workout #' @export -workout_expressions <- function(exprs, env = parent.frame(), description = NULL) { +workout_expressions <- function( + exprs, + env = parent.frame(), + description = NULL +) { if (is.null(description)) { description <- names(exprs) } diff --git a/air.toml b/air.toml new file mode 100644 index 0000000..e69de29 diff --git a/tests/testthat/test-bench_process_memory.R b/tests/testthat/test-bench_process_memory.R index ebe4172..45ea47e 100644 --- a/tests/testthat/test-bench_process_memory.R +++ b/tests/testthat/test-bench_process_memory.R @@ -9,9 +9,9 @@ describe("bench_process_memory", { # This test is unreliable due to when gcs happen when run repeatedly, so it # is commented out. #it("current memory increases when you allocate a medium size vector", { - #res1 <- bench_process_memory() - #x <- rep(1, 1e8) - #res2 <- bench_process_memory() - #expect_true(res2[["current"]] > res1[["current"]]) + #res1 <- bench_process_memory() + #x <- rep(1, 1e8) + #res2 <- bench_process_memory() + #expect_true(res2[["current"]] > res1[["current"]]) #}) }) diff --git a/tests/testthat/test-bench_time.R b/tests/testthat/test-bench_time.R index cce3c2c..d019c15 100644 --- a/tests/testthat/test-bench_time.R +++ b/tests/testthat/test-bench_time.R @@ -26,6 +26,6 @@ describe("bench_memory", { expect_equal(names(res), c("mem_alloc", "memory")) }) it("returns reasonable memory allocation", { - expect_true(res[["mem_alloc"]] > "10MB") - }) + expect_true(res[["mem_alloc"]] > "10MB") + }) }) diff --git a/tests/testthat/test-bytes.R b/tests/testthat/test-bytes.R index 2452513..9750435 100644 --- a/tests/testthat/test-bytes.R +++ b/tests/testthat/test-bytes.R @@ -40,7 +40,8 @@ describe("format.bench_bytes", { v <- c(NA, 1, 2^13, 2^20, NaN, 2^15) expect_equal( format(bench_bytes(v), trim = TRUE), - c("NA", "1B", "8KB", "1MB", "NaN", "32KB")) + c("NA", "1B", "8KB", "1MB", "NaN", "32KB") + ) expect_equal(format(bench_bytes(numeric())), character()) }) @@ -105,7 +106,7 @@ describe("Ops.bench_bytes", { expect_equal(x - 100, bench_bytes(c(0, 100, 200))) expect_equal(x * 100, bench_bytes(c(10000, 20000, 30000))) expect_equal(x / 2, bench_bytes(c(50, 100, 150))) - expect_equal(x ^ 2, bench_bytes(c(10000, 40000, 90000))) + expect_equal(x^2, bench_bytes(c(10000, 40000, 90000))) }) it("errors for other binary operators", { diff --git a/tests/testthat/test-expression.R b/tests/testthat/test-expression.R index 7e9e512..1e70716 100644 --- a/tests/testthat/test-expression.R +++ b/tests/testthat/test-expression.R @@ -13,5 +13,8 @@ test_that("`vec_slice()` slices `description` attribute", { x <- new_bench_expr(x, c("a", "b")) expect_identical(attr(vctrs::vec_slice(x, 2), "description"), "b") - expect_identical(attr(vctrs::vec_slice(x, c(2, 2, 1)), "description"), c("b", "b", "a")) + expect_identical( + attr(vctrs::vec_slice(x, c(2, 2, 1)), "description"), + c("b", "b", "a") + ) }) diff --git a/tests/testthat/test-mark.R b/tests/testthat/test-mark.R index 14a2bbb..cf27237 100644 --- a/tests/testthat/test-mark.R +++ b/tests/testthat/test-mark.R @@ -1,22 +1,65 @@ describe("mark_", { it("If min_time is Inf, runs for max_iterations", { - res <- .Call(mark_, quote(1), new.env(), Inf, as.integer(0), as.integer(10), FALSE) + res <- .Call( + mark_, + quote(1), + new.env(), + Inf, + as.integer(0), + as.integer(10), + FALSE + ) expect_length(res, 10) - res <- .Call(mark_, quote(1), new.env(), Inf, as.integer(0), as.integer(20), FALSE) + res <- .Call( + mark_, + quote(1), + new.env(), + Inf, + as.integer(0), + as.integer(20), + FALSE + ) expect_length(res, 20) }) it("If min_time is 0, runs for min_iterations", { - res <- .Call(mark_, quote(1), new.env(), 0, as.integer(1), as.integer(10), FALSE) + res <- .Call( + mark_, + quote(1), + new.env(), + 0, + as.integer(1), + as.integer(10), + FALSE + ) expect_length(res, 1) - res <- .Call(mark_, quote(1), new.env(), 0, as.integer(5), as.integer(10), FALSE) + res <- .Call( + mark_, + quote(1), + new.env(), + 0, + as.integer(5), + as.integer(10), + FALSE + ) expect_length(res, 5) }) it("If min_time is 0, runs for min_iterations", { - res <- .Call(mark_, quote({i <- 1; while(i < 10000) i <- i + 1}), new.env(), .1, as.integer(1), as.integer(1000), FALSE) + res <- .Call( + mark_, + quote({ + i <- 1 + while (i < 10000) i <- i + 1 + }), + new.env(), + .1, + as.integer(1), + as.integer(1000), + FALSE + ) expect_gte(length(res), 1) expect_lte(length(res), 1000) @@ -24,7 +67,17 @@ describe("mark_", { it("Evaluates code in the environment", { e <- new.env(parent = baseenv()) - res <- .Call(mark_, quote({a <- 42}), e, Inf, as.integer(1), as.integer(1), FALSE) + res <- .Call( + mark_, + quote({ + a <- 42 + }), + e, + Inf, + as.integer(1), + as.integer(1), + FALSE + ) expect_equal(e[["a"]], 42) }) }) @@ -37,14 +90,17 @@ describe("mark", { expect_true(all.equal(res$result[[1]], res$result[[2]])) }) it("Can use other functions to check results like identical to check results", { - # numerics and integers not identical - expect_error(regexp = "Each result must equal the first result", - mark(1 + 1, 1L + 1L, check = identical, iterations = 1)) + expect_error( + regexp = "Each result must equal the first result", + mark(1 + 1, 1L + 1L, check = identical, iterations = 1) + ) # Function that always returns false - expect_error(regexp = "Each result must equal the first result", - mark(1 + 1, 1 + 1, check = function(x, y) FALSE, iterations = 1)) + expect_error( + regexp = "Each result must equal the first result", + mark(1 + 1, 1 + 1, check = function(x, y) FALSE, iterations = 1) + ) # Function that always returns true res <- mark(1 + 1, 1 + 2, check = function(x, y) TRUE, iterations = 1) @@ -151,25 +207,32 @@ describe("summary.bench_mark", { memory = list(NULL), time = list( c( - 0.088492998, 0.109396977, 0.141906863, 0.005378346, 0.007563524, - 0.002439451, 0.079715252, 0.003022223, 0.005948069, 0.002276121 - ) - ), + 0.088492998, + 0.109396977, + 0.141906863, + 0.005378346, + 0.007563524, + 0.002439451, + 0.079715252, + 0.003022223, + 0.005948069, + 0.002276121 + ) + ), gc = list( tibble::tibble( level0 = c(1, 0, 0, 0, 1, 0, 0, 0, 1, 0), level1 = c(0, 1, 0, 0, 0, 0, 0, 0, 0, 0), level2 = c(0, 0, 1, 0, 0, 0, 1, 0, 0, 0) - ) ) ) ) + ) it("computes relative summaries if called with relative = TRUE", { # remove memory column, as there likely are no allocations or gc in these # benchmarks res1 <- summary(res) for (col in setdiff(summary_cols, "mem_alloc")) { - # Absolute values should always be positive expect_true(all(res1[[!!col]] >= 0)) } @@ -192,22 +255,34 @@ describe("summary.bench_mark", { # This is artificial, but it avoids differences in gc on different # platforms / memory loads, so we can ensure the first has no gcs, and the # second has all gcs - x <- bench_mark(tibble::tibble( - expression = c(1, 2), - result = list(1, 2), - time = list( - as_bench_time(c(0.166, 0.161, 0.162)), - as_bench_time(c(0.276, 0.4)) - ), - memory = list(NULL, NULL), - gc = list( - tibble::tibble(level0 = integer(0), level1 = integer(0), level2 = integer(0)), - tibble::tibble(level0 = c(1L, 1L), level1 = c(0L, 0L), level2 = c(0L, 0L)) + x <- bench_mark( + tibble::tibble( + expression = c(1, 2), + result = list(1, 2), + time = list( + as_bench_time(c(0.166, 0.161, 0.162)), + as_bench_time(c(0.276, 0.4)) + ), + memory = list(NULL, NULL), + gc = list( + tibble::tibble( + level0 = integer(0), + level1 = integer(0), + level2 = integer(0) + ), + tibble::tibble( + level0 = c(1L, 1L), + level1 = c(0L, 0L), + level2 = c(0L, 0L) + ) + ) ) - )) + ) - expect_warning(regexp = "Some expressions had a GC in every iteration", - res <- summary(x, filter_gc = TRUE)) + expect_warning( + regexp = "Some expressions had a GC in every iteration", + res <- summary(x, filter_gc = TRUE) + ) expect_equal(res$min, as_bench_time(c(.161, .276))) expect_equal(res$median, as_bench_time(c(.162, .338))) @@ -227,7 +302,7 @@ describe("summary.bench_mark", { describe("unnest.bench_mark", { it("does not contain result or memory columns", { skip_if_not_installed("tidyr") - bnch <- mark(1+1, 2+0) + bnch <- mark(1 + 1, 2 + 0) if (tidyr_new_interface()) { res <- tidyr::unnest(bnch, c(time, gc)) } else { @@ -236,7 +311,10 @@ describe("unnest.bench_mark", { gc_cols <- colnames(bnch$gc[[1]]) - expect_equal(colnames(res), c(head(colnames(bnch), n = -1), c(gc_cols, "gc"))) + expect_equal( + colnames(res), + c(head(colnames(bnch), n = -1), c(gc_cols, "gc")) + ) expect_equal(nrow(res), length(bnch$time[[1]]) + length(bnch$time[[2]])) }) diff --git a/tests/testthat/test-press.R b/tests/testthat/test-press.R index 91c8d4f..add9118 100644 --- a/tests/testthat/test-press.R +++ b/tests/testthat/test-press.R @@ -1,5 +1,4 @@ describe("press", { - it("Adds parameters to output", { local_press_quiet() @@ -64,7 +63,7 @@ describe("press", { local_press_quiet() res <- press( - .grid = data.frame(x = c(1, 2), y = c(1,3)), + .grid = data.frame(x = c(1, 2), y = c(1, 3)), mark(list(x, y), max_iterations = 10) ) diff --git a/tests/testthat/test-time.R b/tests/testthat/test-time.R index b3c9fe9..43de6ac 100644 --- a/tests/testthat/test-time.R +++ b/tests/testthat/test-time.R @@ -51,7 +51,8 @@ describe("format.as_bench_time", { v <- c(NA, .001, 60, 600, NaN, 6000) expect_equal( format(as_bench_time(v), trim = TRUE), - c("NA", "1ms", "1m", "10m", "NaN", "1.67h")) + c("NA", "1ms", "1m", "10m", "NaN", "1.67h") + ) expect_equal(format(as_bench_time(numeric())), character()) }) @@ -116,7 +117,7 @@ describe("Ops.as_bench_time", { expect_equal(x - 100, as_bench_time(c(0, 100, 200))) expect_equal(x * 100, as_bench_time(c(10000, 20000, 30000))) expect_equal(x / 2, as_bench_time(c(50, 100, 150))) - expect_equal(x ^ 2, as_bench_time(c(10000, 40000, 90000))) + expect_equal(x^2, as_bench_time(c(10000, 40000, 90000))) }) it("errors for other binary operators", { diff --git a/tests/testthat/test-workout.R b/tests/testthat/test-workout.R index 2cb6b61..b999757 100644 --- a/tests/testthat/test-workout.R +++ b/tests/testthat/test-workout.R @@ -1,6 +1,5 @@ describe("workout", { it("times each expression and names them", { - res <- workout( x <- 1:1000 ) @@ -22,7 +21,9 @@ describe("workout", { describe("workout_expressions", { it("times given expressions", { - res <- workout_expressions(as.list(parse(file = system.file("examples/exprs.R", package = "bench")))) + res <- workout_expressions( + as.list(parse(file = system.file("examples/exprs.R", package = "bench"))) + ) expect_named(res, c("exprs", "process", "real")) expect_true(nrow(res) == 6) })