diff --git a/.Rbuildignore b/.Rbuildignore index bb9be55f..5d5136cd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -19,3 +19,4 @@ revdep ^CRAN-SUBMISSION$ ^\.lintr$ ^\.git$ +^air\.toml$ diff --git a/.Renviron b/.Renviron index dbb75028..3072645d 100644 --- a/.Renviron +++ b/.Renviron @@ -8,3 +8,4 @@ _R_CHECK_RD_EXAMPLES_T_AND_F_=TRUE _R_CHECK_INSTALL_DEPENDS_=TRUE _R_CHECK_DEPRECATED_DEFUNCT_=TRUE _R_CHECK_DONTTEST_EXAMPLES_=TRUE +TESTTHAT_CPUS=4 diff --git a/.Rprofile b/.Rprofile index cb190a25..f461b14d 100644 --- a/.Rprofile +++ b/.Rprofile @@ -2,10 +2,6 @@ if (file.exists(".Renviron")) { readRenviron(".Renviron") } -# Don't need anymore -Sys.setenv(TESTTHAT_CPUS = 4) -options(Ncpus = 4) - # Some issue where this was failing in tests Sys.setenv(TESTTHAT_PARALLEL = if (getRversion() < "4") "FALSE" else "TRUE") diff --git a/.lintr b/.lintr index 76531459..1f0227e4 100644 --- a/.lintr +++ b/.lintr @@ -3,5 +3,8 @@ linters: linters_with_defaults( ) encoding: "UTF-8" exclusions: list( - "tests/spelling.R" + "tests/spelling.R", + "R/array.R", + "R/time-report.R", + "R/mark-cnd-conditions.R" ) diff --git a/DESCRIPTION b/DESCRIPTION index 81755e5c..22bbc8ea 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: mark Type: Package Title: Multipurpose Aids for R Kit -Version: 0.8.3.9007 +Version: 0.8.3.9008 Authors@R: person(given = "Jordan Mark", family = "Barbone", @@ -20,17 +20,19 @@ BugReports: https://github.com/jmbarbone/mark/issues Encoding: UTF-8 LazyData: true Depends: - R (>= 3.6) + R (>= 4.1.0) Imports: cli, - fs (>= 1.6.2), - fuj (>= 0.2.1), + cnd, + fs (>= 0.2.0), + fuj, magrittr (>= 2.0.1), rlang, stats (>= 3.6), tools (>= 3.6), utils (>= 3.6) Suggests: + arrow (>= 16.1.0), bench (>= 1.1.1), bib2df (>= 1.1.1), clipr (>= 0.8.0), @@ -53,11 +55,15 @@ Suggests: waldo (>= 0.2.5), withr (>= 2.3.0), xopen, - yaml + yaml (>= 2.3.9), +Remotes: + github::jmbarbone/cnd@v0.1.1.9002, + github::jmbarbone/fuj@v0.2.2.9010 RoxygenNote: 7.3.3 Roxygen: list(markdown = TRUE) Config/testthat/edition: 3 Config/testthat/parallel: true +Config/testthat/start-first: clipboard, sourcing, write, directory Language: en-US Collate: 'aaa.R' @@ -81,7 +87,7 @@ Collate: 'environments.R' 'expand.R' 'fact.R' - 'fct_expand_seq.R' + 'fct-expand-seq.R' 'file.R' 'fizzbuzz.R' 'funs.R' @@ -95,6 +101,7 @@ Collate: 'lines-of-code.R' 'logic.R' 'map.R' + 'mark-cnd-conditions.R' 'not-available.R' 'mark-package.R' 'match-arg.R' @@ -132,3 +139,4 @@ Collate: 'utils.R' 'within.R' 'write.R' + 'zzz.R' diff --git a/NAMESPACE b/NAMESPACE index bcc1a932..4c88d97b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -296,7 +296,13 @@ export(write_clipboard) export(write_file_md5) export(wuffle) export(xnandr) +import(cnd) import(fuj) +importFrom(cnd,class_error) +importFrom(cnd,input_error) +importFrom(cnd,input_warning) +importFrom(cnd,type_error) +importFrom(cnd,value_error) importFrom(fuj,"%::%") importFrom(fuj,"%:::%") importFrom(fuj,"%colons%") diff --git a/NEWS.md b/NEWS.md index d33e4929..38f699b6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,18 @@ # mark (development version) +* substantial changes to _conditions_ + * all _conditions_ previously created with [`fuj::new_condition()`](https://jmbarbone.github.io/fuj/reference/new_condition.html) have been rewritten with [`cnd::condition()`](https://jmbarbone.github.io/cnd/reference/condition.html) [#259] + * all of these condition now use different class names, generated through [`cnd::condition()`](https://jmbarbone.github.io/cnd/reference/condition.html) + * for more information, see https://jmbarbone.github.io/cnd + * FIXME: ensure names: `{rd_name}_{thing}` -- and see about switching messages around: (`message = function(type, params)`) + +* the following arguments were deprecated and unused, and have now been removed completely: + * `list2df(show_NA)` + * `vector2df(show_NA)` + * `t_df(id)` + +* `merge_list(sort)` included to toggle name sorting in result + * `make_sf()` now uses `substitute()` to provide more information inside the function body when viewing [#129](https://github.com/jmbarbone/mark/issues/129) * `round_to()` added to round values to a set [#142](https://github.com/jmbarbone/mark/issues/142) * `is_true()`, `is_false()` now works as documented [#262](https://github.com/jmbarbone/mark/issues/262) diff --git a/R/aaa.R b/R/aaa.R index e69de29b..19016e46 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -0,0 +1,44 @@ +cnd_create_registry() + +# nolint next: line_length_linter. +# https://github.com/RConsortium/S7/blob/e430c9aab137cc6301d5e06922e4d8cf2c0a8270/tests/testthat/helper.R#L73-L79 +# modified from: +# https://github.com/RConsortium/S7/issues/466#issuecomment-2417642612 +walrus <- function(sym, val) { + sym <- substitute(sym) + sym <- as.character(sym) # `"sym" <- val` is fine + + val <- substitute(val) + val <- as.list(val) + val <- as.call(c(val[[1L]], sym, val[-1L])) + + eval.parent(call("<-", sym, val)) +} + +# https://adv-r.hadley.nz/quasiquotation.html +# := is like a vestigial organ: it’s recognised by R’s parser, but it doesn’t +# have any code associated with it. It looks like an = but allows expressions on +# either side, making it a more flexible alternative to =. It is used in +# data.table for similar reasons. +`:=` <- `%:=%` <- walrus + + +# standard conditions ----------------------------------------------------- + +#' @importFrom cnd input_error input_warning value_error type_error class_error + +internal_error := condition( + function(x) { + c( + x, + "\nThis is an internal `{mark}` error. If you encounter this, please", + " report an issue at " + ) + }, + type = "error", + help = c( + "Generic error to capture internal `{mark}` errors. If any of these are", + " encountered, please report an issue at", + " " + ) +) diff --git a/R/append.R b/R/append.R index 76a7db80..a85fe995 100644 --- a/R/append.R +++ b/R/append.R @@ -20,7 +20,7 @@ append0.list <- function(x, values, pos = NULL, expand = FALSE, ...) { n <- unique(lengths(x)) if (length(n) > 1) { - warning(cond_append_expand()) + warning(append_warning()) n <- max(n) } @@ -64,6 +64,10 @@ append0.default <- function(x, values, pos = NULL, ...) { # conditions -------------------------------------------------------------- -cond_append_expand <- function() { - new_condition("expanding to the largest n", "append0", type = "warning") -} +# TODO does this need to be it's own condition? +append_warning := condition( + message = "expanding to the largest n", + type = "warning", + package = "mark", + exports = "insert" +) diff --git a/R/apply.R b/R/apply.R index 5b132479..bad6ea4b 100644 --- a/R/apply.R +++ b/R/apply.R @@ -1,4 +1,4 @@ - +# TODO these will be deprecated by fuj::vap # vaps -------------------------------------------------------------------- @@ -12,12 +12,12 @@ #' Each function is designed to use specific vector types: #' #' \describe{ -#' \item{vap_int}{integer} -#' \item{vap_dbl}{double} -#' \item{vap_chr}{character} -#' \item{vap_lgl}{logical} -#' \item{vap_cplx}{complex} -#' \item{vap_date}{Date} +#' \item{[mark::vap_int()]}{integer} +#' \item{[mark::vap_dbl()]}{double} +#' \item{[mark::vap_chr()]}{character} +#' \item{[mark::vap_lgl()]}{logical} +#' \item{[mark::vap_cplx()]}{complex} +#' \item{[mark::vap_date()]}{Date} #' } #' #' @param .x A vector of values @@ -70,46 +70,6 @@ do_vap <- function(.x, .f, .value, ..., .nm) { vapply(X = .x, FUN = .f, FUN.VALUE = .value, ..., USE.NAMES = .nm) } -# This can take multiple elements, so can be a little dangerous -capply <- function(.x, .f, ..., .nm = FALSE) { - res <- do.call("c", lapply(X = .x, FUN = .f, ...)) - if (.nm) { - set_names(res, names(.x) %||% res) - } else { - remove_names(res) - } -} - -# A simplier implementation of sapply? -slapply <- function(x, fun, ..., .simplify = TRUE, .names = TRUE) { - res <- lapply(x, fun, ...) - - if (.simplify) { - res <- simplify2array(res, higher = FALSE) - } - - names(res) <- if (.names) { - if (is.null(nm <- names(x))) x else nm - } else { - NULL - } - - res -} - -if (FALSE) { - x <- 1:10 - y <- setNames(x, x) - lapply(x, sqrt) - lapply(y, sqrt) - sapply(x, sqrt) - sapply(y, sqrt) - sapply(y, sqrt, USE.NAMES = FALSE) - sapply(x, sqrt, USE.NAMES = TRUE) - sapply(y, sqrt, USE.NAMES = TRUE) - slapply(x, sqrt) - slapply(y, sqrt) - slapply(y, sqrt, .names = FALSE) - - lapply(setNames(nm = 1:10), sqrt) +capply <- function(x, f) { + do.call(base::c, lapply(x, f)) } diff --git a/R/array.R b/R/array.R index 7412f9f0..5d9389ff 100644 --- a/R/array.R +++ b/R/array.R @@ -1,3 +1,5 @@ +# nocov start + #' Array extract #' #' Extract dimensions from an array @@ -16,13 +18,20 @@ #' array_extract(x, `2` = 2, `3` = 3) array_extract <- function(.arr, ..., default = "1") { + # what was even the point of this? + .Deprecated( + msg = c( + "`array_extract()` is deprecated.", + " Please use standard R array indexing instead, e.g., `arr[1, 2, 3]`." + ) + ) stopifnot(is.array(.arr)) ls <- rlang::list2(...) nm <- wuffle(as.integer(names(ls) %||% seq_along(ls))) if (anyNA(nm)) { - stop(cond_arary_extract_names()) + stop(input_error("... must be fully named by integers or have no names")) } ds <- dim(.arr) @@ -52,11 +61,4 @@ array_extract <- function(.arr, ..., default = "1") { eval(str2expression(text), envir = parent.frame()) } -# conditions -------------------------------------------------------------- - -cond_arary_extract_names <- function() { - new_condition( - "... must be fully named by integers or have no names", - "array_extract_names" - ) -} +# nocov end diff --git a/R/base-conversion.R b/R/base-conversion.R index 273c3336..1934c12f 100644 --- a/R/base-conversion.R +++ b/R/base-conversion.R @@ -13,33 +13,29 @@ #' base_alpha("XFD") #' base_alpha(c("JMB", "Jordan Mark", "XKCD")) #' sum(base_alpha(c("x", "k", "c", "d"))) - -base_alpha <- function(x, base = 26) { - stopifnot(is.character(x)) - check_base_alpha(base, high = 26) +base_alpha <- function(x, base = 26L) { + if (!is.character(x)) { + stop(class_error("must_be", x, "character")) + } + check_base_alpha(base, high = 26L) vap_int(x, base_alpha_single, base = base) } -alpha_base <- function(x, base = 26) { - .Deprecated("base_alpha") - base_alpha(x, base = base) -} - base_alpha_single <- function(x, base) { a <- chr_split(tolower(x)) %wi% letters a <- match(a, letters[1:base], nomatch = NA_integer_) if (anyNA(a)) { - stop(cond_base_alpha_limit(base, x)) + stop(base_conversion_error("alpha_limit", base = base, x = x)) } n <- length(a) - if (n == 0) { + if (n == 0L) { return(NA_integer_) } - as.integer(sum(c(a[-n] * base^(1:(n - 1)), a[n]))) + as.integer(sum(c(a[-n] * base^(1:(n - 1L)), a[n]))) } #' Base N conversion @@ -54,15 +50,20 @@ base_alpha_single <- function(x, base) { #' @export #' @examples #' base_n(c(24, 22, 16), from = 7) -base_n <- function(x, from = 10, to = 10) { - stopifnot(is.numeric(x)) +base_n <- function(x, from = 10L, to = 10L) { + if (!is.numeric(x)) { + stop(class_error("must_be", x, "numeric")) + } + + from <- as.integer(from) + to <- as.integer(to) if (from == to) { return(x) } - if (to != 10) { - stop(cond_base_n_ten()) + if (to != 10L) { + stop(base_conversion_error("ten")) } check_base(from) @@ -73,19 +74,19 @@ base_n_single <- function(x, base) { ints <- as.integer(chr_split(x)) if (any(ints >= base, na.rm = TRUE)) { - stop(cond_base_n_single_limit(base, x)) + stop(base_conversion_error("single_limit", base = base, x = x)) } seqs <- (length(ints) - 1L):0L as.integer(sum(mapply(function(i, s) i * base^s, i = ints, s = seqs))) } -check_base_alpha <- function(b, high = 26) { +check_base_alpha <- function(b, high = 26L) { if (is.character(b)) { b <- chr_split(b) - if (length(b) != 1) { - stop(cond_check_base_alpha_length()) + if (length(b) != 1L) { + stop(base_conversion_error("alpha_length")) } b <- match(tolower(b), letters) @@ -94,68 +95,45 @@ check_base_alpha <- function(b, high = 26) { check_base(b, high = high) } -check_base <- function(b, high = 9) { - if (b %% 1 != 0) { - stop(cond_check_base_integer()) +check_base <- function(b, high = 9L) { + if (b %% 1L != 0L) { + stop(base_conversion_error("integer")) } - if (b > high || b <= 1) { - stop(cond_check_base_limit(high)) + if (b > high || b <= 1L) { + stop(base_conversion_error("limit", high = high)) } } # conditions -------------------------------------------------------------- -cond_base_alpha_limit <- function(base, x) { - new_condition( - sprintf( - 'Cannot calculate alpha base "%s" for "%s" which has letters beyond "%s"', - base, x, x[base] - ), - "base_alpha_limit" - ) -} - -cond_base_n_ten <- function() { - new_condition( - "base_n() is currently only valid for conversions to base 10", - "base_n_ten" - ) -} - -cond_base_n_single_limit <- function(base, x) { - new_condition( - sprintf( - paste0( - "Cannot caluclate base \"%s\" for \"%s\" which has numbers greater", - " than or equal to the base value" +base_conversion_error := condition( + function(s, base, x, high) { + switch( + s, + alpha_limit = sprintf( + 'Cannot calculate alpha base "%s" for "%s" which has letters beyond "%s"', # nolint: line_length_linter. + base, + x, + x[base] ), - base, x - ), - "base_n_single_limit" - ) -} - -cond_check_base_alpha_length <- function() { - new_condition( - "base must be of length 1", - "check_base_alpha_length" - ) -} - -cond_check_base_integer <- function() { - new_condition( - "base must be an integer", - "check_base_integer" - ) -} - -cond_check_base_limit <- function(high) { - new_condition( - paste("base must be between 1 and", high), - "check_base_limit" - ) -} - -# terminal line + ten = "base_n() is currently only valid for conversions to base 10", + single_limit = sprintf( + paste0( + "Cannot caluclate base \"%s\" for \"%s\" which has numbers greater", + " than or equal to the base value" + ), + base, + x + ), + alpha_length = "base must be of length 1", + integer = "base must be an integer", + limit = sprintf("base must be between 1 and %s", high), + stop(internal_error("Unknown base conversion error type: ", type)) + ) + }, + type = "error", + exports = c("base_alpha", "base_n") + # TODO include help +) diff --git a/R/bib.R b/R/bib.R index 21f20f23..171a0e76 100644 --- a/R/bib.R +++ b/R/bib.R @@ -14,7 +14,7 @@ #' @param file File or connection #' @param skip The lines to skip #' @param max_lines The maximum number of lines to read -#' @param encoding Assumed encoding of file (passed to [readLines()] +#' @param encoding Assumed encoding of file (passed to [base::readLines()] #' #' @return A `data.frame` with each row as a bib entry and each column as a #' field @@ -70,7 +70,7 @@ read_bib <- function(file, skip = 0L, max_lines = NULL, encoding = "UTF-8") { from <- grep("[@]", bib) if (!length(from)) { - stop(cond_read_bib_entries()) + stop(value_error("No entries detected in bib file")) } # shift over (may contain white space?) @@ -143,7 +143,7 @@ parse_bib_val <- function(x) { process_bib_dataframe <- function(categories, values, fields, keys) { # Determine all categories for missing values inside Map ucats <- unique(remove_na(unlist(categories))) - ucats_df <- quick_dfl( + ucats_df <- dataframe( category = ucats, value = rep(NA_character_, length(ucats)) ) @@ -160,7 +160,13 @@ process_bib_dataframe <- function(categories, values, fields, keys) { bad <- lens > 1L if (any(bad)) { - stop(cond_process_bib_dataframe_dupe(key, names(lens)[bad])) + stop(duplicate_error( + sprintf( + "The key `%s` has duplicate categories of `%s`", + key, + names(lens)[bad] + ) + )) } # Append vectors @@ -168,7 +174,7 @@ process_bib_dataframe <- function(categories, values, fields, keys) { vals <- c(key, field, vals) # Create data.frame - data <- quick_dfl(category = cats, value = vals) + data <- dataframe(category = cats, value = vals) # Check for missing categories toadd <- ucats %out% cats @@ -200,7 +206,6 @@ process_bib_list <- function(keys, fields, categories, values) { class = c("character", "mark_bib_entry"), names = c("key", "field", cats) ) - }, key = keys[valid], field = fields[valid], @@ -214,7 +219,7 @@ process_bib_list <- function(keys, fields, categories, values) { as_bib_list <- function(x, names = NULL) { if (!is.list(x)) { - stop(cond_as_bib_list_class()) + stop(type_error("must_be", x, "list")) } class(x) <- c("list", "mark_bib_list") @@ -223,7 +228,7 @@ as_bib_list <- function(x, names = NULL) { as_bib <- function(x, bib_list = NULL) { if (!is.data.frame(x)) { - stop(cond_as_bib_class()) + stop(class_error("must_be", x, "data.frame")) } class(x) <- c("mark_bib_df", "data.frame") @@ -300,38 +305,3 @@ print.mark_bib_df <- function(x, list = FALSE, ...) { invisible(x) } - - -# conditions -------------------------------------------------------------- - -cond_read_bib_entries <- function() { - new_condition( - "No entries detected", - "read_bib_entries" - ) -} - -cond_process_bib_dataframe_dupe <- function(key, categories) { # nolint: object_length_linter, line_length_linter. - new_condition( - sprintf( - "The key `%s` has duplicate categories of `%s`", - key, - categories - ), - "process_bib_dataframe_dupe" - ) -} - -cond_as_bib_list_class <- function() { - new_condition( - "`x` must be a list", - "as_bib_list_class" - ) -} - -cond_as_bib_class <- function() { - new_condition( - "`x` must be a data.frame", - "as_bib_class" - ) -} diff --git a/R/blank.R b/R/blank.R index 3abf97a0..b653a832 100644 --- a/R/blank.R +++ b/R/blank.R @@ -12,11 +12,11 @@ #' as blanks #' #' @returns -#' * `is_blank()` a `logical` vector indicating _blank_ elements in `x` -#' * `select_blank_cols()` `x` with only columns that are all _blank_ -#' * `remove_blank_cols()` `x` without columns of only _blank_ -#' * `is_blank_cols()` a logical vector: `TRUE` all rows of column are _blank_, -#' otherwise `FALSE` +#' - [mark::is_blank()] a `logical` vector indicating _blank_ elements in `x` +#' - [mark::select_blank_cols()] `x` with only columns that are all _blank_ +#' - [mark::remove_blank_cols()] `x` without columns of only _blank_ +#' - [mark::is_blank_cols()] a logical vector: `TRUE` all rows of column are +#' _blank_, otherwise `FALSE` #' @name blank_values NULL @@ -38,14 +38,16 @@ select_blank_cols <- function(x, na_blank = FALSE, ws = TRUE) { remove_blank_cols <- function(x, na_blank = FALSE, ws = TRUE) { x[, !is_blank_cols(x, na_blank = na_blank, ws = ws), drop = FALSE] } - #' @rdname blank_values #' @export is_blank_cols <- function(x, names = TRUE, na_blank = FALSE, ws = TRUE) { - stopifnot(is.data.frame(x)) - vap_lgl(x, function(i) { - all(is_blank(i, na_blank = na_blank, ws = ws)) - }, - .nm = names + if (!is.data.frame(x)) { + stop(class_error("must_be", x, "data.frame")) + } + + vap_lgl( + x, + function(i) all(is_blank(i, na_blank = na_blank, ws = ws)), + .nm = names ) } diff --git a/R/boolean.R b/R/boolean.R index b250355a..a0170509 100644 --- a/R/boolean.R +++ b/R/boolean.R @@ -30,25 +30,25 @@ to_boolean.logical <- function(x, ...) { #' @rdname to_boolean #' @export to_boolean.numeric <- function(x, true = 1, false = 0, na = NULL, ...) { - do_to_boolean(x, true, false, na, ...) + do_to_boolean(x, true, false, na) } #' @rdname to_boolean #' @export -to_boolean.integer <- function(x, true = 1L, false = 0L, ...) { - to_boolean.numeric(x, true, false, ...) +to_boolean.integer <- function(x, true = 1L, false = 0L, na = NULL, ...) { + do_to_boolean(x, true, false, na) } #' @rdname to_boolean #' @export to_boolean.character <- function( - x, - true = c("TRUE", "true", "T", "t", "YES", "yes", "Y", "y"), - false = c("FALSE", "false", "F", "f", "NO", "no", "N", "n"), - na = NULL, - ... + x, + true = c("TRUE", "true", "T", "t", "YES", "yes", "Y", "y"), + false = c("FALSE", "false", "F", "f", "NO", "no", "N", "n"), + na = NULL, + ... ) { - do_to_boolean(x, true, false, na, ...) + do_to_boolean(x, true, false, na) } #' @rdname to_boolean @@ -66,7 +66,7 @@ do_to_boolean <- function(x, true, false, na) { if (anyDuplicated(c(true, false, na))) { stop(cond( "Cannot convert to boolean/logical: overlapping `true`, `false`, or ", - "`na` values found", + "`na` values found", class = c("bad_bools_input", "error") )) } @@ -78,6 +78,7 @@ do_to_boolean <- function(x, true, false, na) { if (!is.null(na)) { m <- match(x, c(true, false, na)) if (anyNA(m)) { + # FIXME this issue error <- cond( "Cannot convert to boolean/logical: unmatched values found in `x`: ", collapse(unique(x[is.na(m)]), ", "), @@ -90,6 +91,7 @@ do_to_boolean <- function(x, true, false, na) { bool } +# TODO fix condition cond <- function(..., class = NULL, call = NULL) { struct( list(paste0(..., collapse = ""), call), diff --git a/R/char2fact.R b/R/char2fact.R index 3673d41c..eee4bacd 100644 --- a/R/char2fact.R +++ b/R/char2fact.R @@ -4,7 +4,7 @@ #' #' @param x A vector of characters #' @param n The limit to the number of unique values for the factor -#' @seealso [fact2char()] +#' @seealso [mark::fact2char()] #' @family factors #' @export char2fact <- function(x, n = 5) { @@ -14,7 +14,7 @@ char2fact <- function(x, n = 5) { #' @rdname char2fact #' @export char2fact.default <- function(x, n = 5) { - stop(cond_char2fact_class(x)) + stop(class_error("not_supported", x)) } #' @rdname char2fact @@ -53,22 +53,15 @@ char2fact.data.frame <- function(x, n = 5) { #' @param threshold A threshold for the number of levels to be met/exceeded for #' transforming into a character #' @returns The `data.frame` `data` with factors converted by the rule above -#' @seealso [char2fact()] +#' @seealso [mark::char2fact()] #' @family factors #' @export fact2char <- function(data, threshold = 10) { - stopifnot(is.data.frame(data)) + if (!is.data.frame(data)) { + stop(class_error("must_be", data, "data.frame")) + } # for factors with more than threshold levels, convert back to character bad <- lengths(lapply(data, levels)) >= threshold data[bad] <- lapply(data[bad], as.character) data } - -# conditions -------------------------------------------------------------- - -cond_char2fact_class <- function(x) { - new_condition( - paste("char2fact does not support class", toString(class(x))), - "char2fact_class" - ) -} diff --git a/R/clipboard.R b/R/clipboard.R index 39313100..c8408094 100644 --- a/R/clipboard.R +++ b/R/clipboard.R @@ -2,17 +2,19 @@ #' #' Wrappers for working with the clipboard #' -#' @details For copying and pasting floats, there may be some rounding that can -#' occur. +#' @details As these functions rely on [clipr::read_clip()] and +#' [utils::writeClipboard()] they are only available for Windows 10. For +#' copying and pasting floats, there may be some rounding that can occur. #' #' @param x An object to write to the clipboard #' @param method Method switch for loading the clipboard #' @param ... Additional arguments sent to methods or to [utils::write.table()] #' -#' @return [mark::write_clipboard()] None, called for side effects -#' [mark::read_clipboard()] Either a vector or `data.frame` (or `tibble`, if -#' depending on the `method` chosen. An empty clipboard value returns `NA` -#' (rather than `""`) +#' @return +#' - [mark::write_clipboard()] None, called for side effects +#' - [mark::read_clipboard()] Either a vector, `data.frame`, or `tibble` +#' depending on the `method` chosen. Unlike [utils::readClipboard()], an +#' empty clipboard value returns `NA` rather than `""` #' #' @name clipboard #' @examples diff --git a/R/counts.R b/R/counts.R index bd35e1b3..185bf740 100644 --- a/R/counts.R +++ b/R/counts.R @@ -1,16 +1,15 @@ #' Count observations by unique values #' #' Get counts or proportions of unique observations in a vector or columns in a -#' `data.frame` +#' `data.frame` #' -#' @description -#' Variables will be return by the order in which they appear. Even factors are -#' shown by their order of appearance in the vector. +#' @description Variables will be return by the order in which they appear. +#' Even factors are shown by their order of appearance in the vector. #' #' There are 2 methods for counting vectors. The `default` method uses -#' `base::tabulate()` (the workhorse for `base::table()` with a call to -#' `pseudo_id()` to transform all inputs into integers. The `logical` method -#' counts `TRUE`, `FALSE` and `NA` values, which is much quicker. +#' [base::tabulate()] (the workhorse for [base::table()] with a call to +#' [mark::pseudo_id()] to transform all inputs into integers. The `logical` +#' method counts `TRUE`, `FALSE` and `NA` values, which is much quicker. #' #' @param x A vector or `data.frame` #' @param ... Arguments passed to other methods @@ -29,11 +28,11 @@ #' counts(x) #' props(x) #' -#' x <- quick_df(list( +#' x <- data.frame( #' a = c("a", "c", "a", "c", "d", "b"), #' b = c("a", "a", "a", "c", "c", "b"), #' c = c("a", "a", "a", "c", "b", "b") -#' )) +#' ) #' #' counts(x, "a") #' counts(x, c("a", "b", "c")) @@ -107,7 +106,12 @@ props <- function(x, ...) { #' @rdname counts #' @export #' @param na.rm If `TRUE` will remove NA values from proportions -props.default <- function(x, sort = FALSE, na.rm = FALSE, ...) { # nolint: object_name_linter, line_length_linter. +props.default <- function( + x, + sort = FALSE, + na.rm = FALSE, # nolint: object_name_linter. + ... +) { res <- counts(x, sort = sort) n <- length(res) @@ -141,7 +145,9 @@ props.data.frame <- function( props_n(values, sort = sort, name = .name, na_ind = na_ind) } else { vector2df( - props(x[[cols]], sort = sort, na.rm = na.rm), cols, .name %||% "prop" + x = props(x[[cols]], sort = sort, na.rm = na.rm), + name = cols, + value = .name %||% "prop" ) } @@ -197,7 +203,13 @@ props_n <- function( } remake_df <- function(new, old) { - stopifnot(is.data.frame(new), is.data.frame(old)) + if (!is.data.frame(new)) { + stop(class_error("must_be", new, "data.frame")) + } + + if (!is.data.frame(old)) { + stop(class_error("must_be", old, "data.frame")) + } new_cn <- colnames(new) old_cn <- colnames(old) diff --git a/R/dataframes.R b/R/dataframes.R index 9f388c77..d8d24492 100644 --- a/R/dataframes.R +++ b/R/dataframes.R @@ -15,16 +15,13 @@ #' to_row_names(x) #' to_row_names(x, "b") #' @export - to_row_names <- function(data, row_names = 1L) { - col_to_rn(data, row_names = row_names) -} - -col_to_rn <- function(data, row_names = 1L) { - row_names0 <- row_names + if (!is.data.frame(data)) { + stop(class_error("must_be", data, "data.frame")) + } if (length(row_names) != 1) { - stop(cond_col_to_rn_rownames()) + stop(input_error("row_names must be a single element vector")) } if (is.character(row_names)) { @@ -32,7 +29,7 @@ col_to_rn <- function(data, row_names = 1L) { } if (is.na(row_names)) { - stop(cond_col_to_rn_rownames_na(row_names0)) + stop(input_error("`row_names` cannot be NA")) } x <- data[[row_names]] @@ -51,17 +48,12 @@ col_to_rn <- function(data, row_names = 1L) { #' #' @param x A vector of values. #' @param name,value Character strings for the name and value columns -#' @param show_NA Ignored; will trigger a warning if set #' @return A `data.frame` with `name` (optional) and `value` columns #' @export - -vector2df <- function(x, name = "name", value = "value", show_NA) { # nolint: object_name_linter, line_length_linter. - if (!missing(show_NA)) { - warning(cond_vector2df_show_na()) +vector2df <- function(x, name = "name", value = "value") { + if (is.list(x)) { + stop(class_error("not_supported", x)) } - - stopifnot(!is.list(x)) - ls <- list(names(x) %||% rep(NA, length(x)), remove_names(x)) ls <- ls[!vap_lgl(list(name, value), is.null)] names(ls) <- c(name, value) @@ -70,17 +62,15 @@ vector2df <- function(x, name = "name", value = "value", show_NA) { # nolint: ob #' List to data.frame #' -#' Converts a list object into a data.frame +#' Converts a list object into a `data.frame` #' -#' @details -#' Unlike `base::list2DF()`, `list2df()` tries to format the data.frame by using -#' the names of the list as values rather than variables. This creates a -#' longer form list that may be more tidy. +#' @details Unlike [base::list2DF()], [mark::list2df()] tries to format the +#' `data.frame` by using the names of the list as values rather than +#' variables. This creates a longer form list that may be more tidy. #' #' @param x A (preferably) named `list` with any number of values #' @param name,value Names of the new key and value columns, respectively -#' @param show_NA Ignored; if set will trigger a warning -#' @param warn Logical; if TRUE will show a warning when +#' @param warn Logical; if `TRUE` will show a warning when #' #' @return a `data.frame` object with columns `"name"` and `"value"` for the #' names of the `list` and the values in each @@ -90,26 +80,23 @@ vector2df <- function(x, name = "name", value = "value", show_NA) { # nolint: ob #' x <- list(a = 1, b = 2:4, c = letters[10:20], "unnamed", "unnamed2") #' list2df(x, "col1", "col2", warn = FALSE) #' -#' if (getRversion() >= as.package_version('4.0')) { #' # contrast with `base::list2DF()` and `base::as.data.frame()` -#' x <- list(a = 1:3, b = 2:4, c = letters[10:12]) -#' list2df(x, warn = FALSE) -#' list2DF(x) -#' as.data.frame(x) -#' } - -list2df <- function(x, name = "name", value = "value", show_NA, warn = TRUE) { # nolint: object_name_linter, line_length_linter. - stopifnot(is.list(x)) - - if (!missing(show_NA)) { - warning(cond_list2df_show_na()) +#' x <- list(a = 1:3, b = 2:4, c = letters[10:12]) +#' list2df(x, warn = FALSE) +#' list2DF(x) +#' as.data.frame(x) + +# nolint next: object_name_linter. +list2df <- function(x, name = "name", value = "value", warn = TRUE) { + if (!is.list(x)) { + stop(class_error("must_be", x, "list")) } cl <- lapply(x, class) n_cl <- length(unique(cl)) - if (n_cl > 1 && warn) { - warning(cond_list2df_classes(cl)) + if (n_cl > 1L && warn) { + warning(list2df_warning(cl)) } ulist <- unlist(x, use.names = FALSE) @@ -118,8 +105,7 @@ list2df <- function(x, name = "name", value = "value", show_NA, warn = TRUE) { # nm[blanks] <- which(blanks) out <- quick_df( - list(name = rep(make.unique(nm), lengths(x)), - value = unname(ulist)) + list(name = rep(make.unique(nm), lengths(x)), value = unname(ulist)) ) names(out) <- c(name, value) @@ -129,7 +115,13 @@ list2df <- function(x, name = "name", value = "value", show_NA, warn = TRUE) { # # base::list2DF() -- but this wasn't introduced until 4.0.0 # And an update prevents recycling list2df2 <- function(x = list(), nrow = NULL) { - stopifnot(is.list(x), is.null(nrow) || nrow >= 0L) + if (!is.list(x)) { + stop(class_error("must_be", x, "list")) + } + + if (!(is.null(nrow) || nrow >= 0L)) { + stop(input_error("`nrow` must be NULL or a non-negative integer")) + } if (n <- length(x)) { if (is.null(nrow)) { @@ -152,31 +144,26 @@ list2df2 <- function(x = list(), nrow = NULL) { #' Data frame transpose #' -#' Transposes a data.frame as a data.frame +#' Transposes a `data.frame` as a `data.frame` #' -#' @description -#' This transposes a data.frame with `t()` but transforms back into a data.frame -#' with column and row names cleaned up. Because the data types may be mixed -#' and reduced to characters, this may only be useful for a visual viewing of -#' the data.frame. +#' @description This transposes a data.frame with [base::t()] but transforms +#' back into a data.frame with column and row names cleaned up. Because the +#' data types may be mixed and reduced to characters, this may only be useful +#' for a visual viewing of the data.frame. #' #' @param x A data.frame -#' @param id No longer used -#' @return A transposed `data.frame` with columns (`"colname"`, `"row_1"`, ..., -#' for each row in `x`. +#' @return A transposed `data.frame` with columns (`"colname"`, `"row_1"`, +#' `...`, for each row in `x`. #' #' @examples #' x <- data.frame(col_a = Sys.Date() + 1:5, col_b = letters[1:5], col_c = 1:5) #' t_df(x) #' @export - -t_df <- function(x, id = NULL) { - if (!is.null(id)) { - warning(cond_t_df_id()) +t_df <- function(x) { + if (!is.data.frame(x)) { + stop(class_error("must_be", x, "data.frame")) } - stopifnot(is.data.frame(x)) - out <- as.data.frame( t(x), stringsAsFactors = FALSE, @@ -189,7 +176,9 @@ t_df <- function(x, id = NULL) { } rn_to_col <- function(data, name = "row.name") { - stopifnot(is.data.frame(data)) + if (!is.data.frame(data)) { + stop(class_error("must_be", data, "data.frame")) + } n <- length(data) + 1 data[[n]] <- attr(data, "row.names") data <- reset_rownames(data) @@ -201,7 +190,7 @@ rn_to_col <- function(data, name = "row.name") { #' #' Return completed cases of a data.frame #' -#' @param data A data.frame +#' @param data A `data.frame` #' @param cols Colnames or numbers to remove `NA` values from; `NULL` (default) #' will use all columns #' @param invert Logical, if `TRUE` will return incomplete cases @@ -221,11 +210,13 @@ rn_to_col <- function(data, name = "row.name") { #' complete_cases(x, "c") #' @export complete_cases <- function(data, cols = NULL, invert = FALSE) { - stopifnot(is.data.frame(data)) + if (!is.data.frame(data)) { + stop(class_error("must_be", data, "data.frame")) + } ds <- dim(data) if (ds[1L] == 0L || ds[2L] == 0L) { - stop(cond_complete_cases_rc()) + stop(input_error("`data` must have at least 1 row and 1 column")) } x <- data[, cols %||% 1:ds[2L], drop = FALSE] @@ -249,17 +240,19 @@ complete_cases <- function(data, cols = NULL, invert = FALSE) { #' @param invert If `TRUE` returns the duplicated rows #' @returns `data` will duplicates removes #' @examples -#' df <- quick_dfl( +#' df <- data.frame( #' i = 1:4, #' a = rep(1:2, 2L), -#' b = rep("a", 4L), +#' b = rep("a", 4L) #' ) #' #' unique_rows(df, 2:3) #' unique_rows(df, c("a", "b"), from_last = TRUE, invert = TRUE) #' @export unique_rows <- function(data, cols = NULL, from_last = FALSE, invert = FALSE) { - stopifnot(is.data.frame(data)) + if (!is.data.frame(data)) { + stop(class_error("must_be", data, "data.frame")) + } cn <- names(data) cols <- cols %||% cn @@ -276,67 +269,22 @@ unique_rows <- function(data, cols = NULL, from_last = FALSE, invert = FALSE) { reset_rownames(data[keep, ]) } - reset_rownames <- function(data, n = nrow(data)) { attr(data, "row.names") <- .set_row_names(n) data } - # conditions -------------------------------------------------------------- -cond_col_to_rn_rownames <- function() { - new_condition( - "`row_names` must be a single element vector", - "col_to_rn_rownames" - ) -} - -cond_col_to_rn_rownames_na <- function(x) { - new_condition( - sprintf("`row_names` of `%s` is invalid", x), - "col_to_rn_rownames_na" - ) -} - -cond_vector2df_show_na <- function() { - new_condition( - "`show_NA` is no longer in use", - "vector2df_show_na", - type = "warning" - ) -} - -cond_list2df_show_na <- function() { - new_condition( - "`show_NA` is no longer in use", "list2df_show_na", - type = "warning" - ) -} - -cond_list2df_classes <- function(x) { - new_condition( +list2df_warning := condition( + function(x) { ngettext( any(c("character", "factor") %in% x), "Not all values are the same class: converting to character", "Not all values are the same class" - ), - "list2df_classes", - type = "warning" - ) -} - -cond_t_df_id <- function() { - new_condition( - "Argument `id` is no longer valid", - "t_df_id", - type = "warning" - ) -} - -cond_complete_cases_rc <- function() { - new_condition( - "`data` must have at least 1 row and 1 column", - "completed_cases_rc" - ) -} + ) + }, + type = "warning", + classes = "class_warning", + exports = "list2df" +) diff --git a/R/dates.R b/R/dates.R index 7357de31..eb30349c 100644 --- a/R/dates.R +++ b/R/dates.R @@ -30,10 +30,10 @@ #' @export date_from_partial <- function( - x, - format = "ymd", - method = c("min", "max"), - year_replacement = NA_integer_ + x, + format = "ymd", + method = c("min", "max"), + year_replacement = NA_integer_ ) { x <- as.character(x) fmt <- verify_format(format) @@ -71,11 +71,11 @@ verify_format <- function(format) { m <- match(c("y", "m", "d"), s) if (length(unique(s)) != 3L) { - stop(cond_verify_format_chrs()) + stop(input_error("format must be 3 characters")) } if (anyNA(m)) { - stop(cond_verify_format_ymd()) + stop(input_error('format must contain "y", "m", and "d"')) } s @@ -154,7 +154,6 @@ parse_date_strings <- function(.x, fmt, method, year_replacement) { } if (method == "min") { - if (x["d"] == 0L) { x["d"] <- 1L } @@ -164,7 +163,6 @@ parse_date_strings <- function(.x, fmt, method, year_replacement) { } if (x["y"] == 0L) { - if (is.na(year_replacement)) { return(ints) } @@ -248,19 +246,3 @@ strp_format <- function(fmt) { fmt[fmt == "y"] <- "Y" sprintf("%%%s-%%%s-%%%s", fmt[1], fmt[2], fmt[3]) } - -# conditions -------------------------------------------------------------- - -cond_verify_format_chrs <- function() { - new_condition( - "format must be 3 characters", - "verify_format_chrs" - ) -} - -cond_verify_format_ymd <- function() { - new_condition( - "format must contain \"y\", \"m\", and \"d\"", - "verify_format_ymd" - ) -} diff --git a/R/depth.R b/R/depth.R index 479ea308..be2b1063 100644 --- a/R/depth.R +++ b/R/depth.R @@ -2,9 +2,8 @@ #' #' Functions to extract the 'depth' of an object #' -#' @details -#' This function does not count an empty lists (`list()`) as a level or `NULL` -#' objects. +#' @details This function does not count an empty lists ([base::list()]) as a +#' level or `NULL` objects. #' #' @param x An object #' @param ... Possible additional arguments passed to methods (not in use) @@ -26,11 +25,7 @@ depth <- function(x, ...) { #' @export #' @rdname depth depth.default <- function(x, ...) { - if (is.null(x)) { - 0L - } else { - 1L - } + if (is.null(x)) 0L else 1L } #' @export diff --git a/R/description.R b/R/description.R index 7fa0527b..ca8c0f1f 100644 --- a/R/description.R +++ b/R/description.R @@ -1,4 +1,4 @@ -#' Add author to DESCRIPTION +#' Add author to `DESCRIPTION` #' #' Adds author to description #' @@ -8,24 +8,30 @@ #' @param author_info Author information as a named list #' @return None, called for side effects #' @export - use_author <- function(author_info = find_author()) { - stopifnot( - is.list(author_info), + # TODO allow for `person()` class? + # fmt: skip + if (!( + is.list(author_info) && !inherits(author_info, "person") - ) + )) { + stop(type_error("must_be", author_info, "list")) + } lines <- readLines("DESCRIPTION") start <- grep("^[Aa]uthor", lines) if (!length(start)) { - stop("Jordan needs to review this, sorry") + warning( + "No Author field found; adding Authors@R at the top of the file", + call. = FALSE + ) start <- grep("^[Vv]ersion", lines) - lines <- c(lines[1:start], "Author: ", lines[(start + 1):length(lines)]) + lines <- c(lines[1:start], "Author@R: ", lines[(start + 1L):length(lines)]) } spaces <- grepl("^\\s", lines) - end <- which.max(!spaces[-c(1:start)]) + start - 1 + end <- which.max(!spaces[-c(1:start)]) + start - 1L names(author_info) <- tolower(names(author_info)) valid_names <- c("given", "family", "middle", "email", "role", "comment") @@ -34,15 +40,20 @@ use_author <- function(author_info = find_author()) { body <- author_info_to_text(author_info) n <- length(body) - new_body <- c("Authors@R:", + + # TODO maybe some expression() handling here? + new_body <- c( + "Authors@R:", paste0(" person(", trimws(body[1], "left")), - if (n > 2) paste0(" ", body[2:(n - 1)]) else NULL, - paste0(" ", sub("[,]$", "", body[n]), ")")) + if (n > 2) paste0(" ", body[2:(n - 1L)]) else NULL, + paste0(" ", sub("[,]$", "", body[n]), ")") + ) - out <- c(lines[1:(start - 1)], + out <- c( + lines[1:(start - 1L)], new_body, - lines[(end + 1):length(lines)]) - + lines[(end + 1L):length(lines)] + ) writeLines(out, "DESCRIPTION") } @@ -59,18 +70,22 @@ author_info_to_text <- function(x) { ind <- !comment & len x[ind] <- paste0('"', x[ind], '"') - x[comment] <- paste0( + x[comment] <- paste0( "c(", names(x[comment][[1]]), " = ", - paste0('"', x[comment][1], '"'), ")" + paste0('"', x[comment][1], '"'), + ")" ) paste0(format(nm, width = width), " = ", x, ",") } find_author <- function() { - getOption("mark.author", stop(cond_find_author())) + getOption( + "mark.author", + stop(value_error("Author information not found in options.")) + ) } # Version ----------------------------------------------------------------- @@ -80,20 +95,20 @@ find_author <- function() { #' Get and bump package version for dates #' #' @description Will read the `DESCRIPTION` file and to get and adjust the -#' version +#' version #' -#' `bump_date_version()` will not check if the version is actually a date. When -#' the current version is the same as today's date(equal by character strings) -#' it will append a `.1`. +#' [mark::bump_date_version()] will not check if the version is actually a +#' date. When the current version is the same as today's date (equal by +#' character strings) it will append a `.1`. #' #' @param version A new version to be added; default of `NULL` will #' automatically update. #' @param date If `TRUE` will use a date as a version. #' @return -#' * `get_version()`: A package_version -#' * `bump_version()`: None, called for its side-effects -#' * `bump_date_version()`: None, called for its side-effects -#' * `update_version()`: None, called for its side-effects +#' - [mark::get_version()]: A package_version +#' - [mark::bump_version()]: None, called for its side-effects +#' - [mark::bump_date_version()]: None, called for its side-effects +#' - [mark::update_version()]`: None, called for its side-effects #' #' @export get_version <- function() { @@ -101,7 +116,7 @@ get_version <- function() { line <- grep("^[Vv]ersion.*[[:punct:][:digit:]]+$", description) if (length(line) != 1L) { - stop(cond_version_lines()) + stop(description_version_error()) } as.package_version(gsub("[Vv]ersion|[:]|[[:space:]]", "", description[line])) @@ -129,7 +144,7 @@ update_version <- function(version = NULL, date = FALSE) { line <- grep("^[Vv]ersion.*[[:punct:][:digit:]]+$", description) if (length(line) != 1L) { - stop(cond_version_lines()) + stop(description_version_error()) } # Get the old version @@ -207,29 +222,18 @@ today_as_version <- function(zero = FALSE) { char <- if (zero) { paste(0, x[["year"]] + 1900, x[["mon"]] + 1, x[["mday"]], sep = ".") } else { - paste( x[["year"]] + 1900, x[["mon"]] + 1, x[["mday"]], sep = ".") # nolint: spaces_inside_linter, line_length_linter. + # fmt: skip + # nolint next: spaces_inside_linter. + paste( x[["year"]] + 1900, x[["mon"]] + 1, x[["mday"]], sep = ".") } as.package_version(char) } # conditions -------------------------------------------------------------- -cond_find_author <- function() { - new_condition( - paste0( - "Author information not found in options.\n", - "You can set the author information with options(mark.author = .)\n", - " probably within an .Rprofile" - ), - "find_author" - ) -} - -cond_version_lines <- function() { - new_condition( - "multiple versions found", - "get_version_lines" - ) -} - -# terminal line +description_version_error := condition( + "Multiple version lines found in DESCRIPTION", + type = "error", + classes = "value_error", + exports = c("get_version", "update_version") +) diff --git a/R/detail.R b/R/detail.R index b5a12764..5a687993 100644 --- a/R/detail.R +++ b/R/detail.R @@ -8,11 +8,11 @@ #' x <- sample(letters[1:4], 10, TRUE) #' detail(x) #' -#' df <- quick_df(list( +#' df <- data.frame( #' x = x, #' y = round(runif(10), 2), #' z = Sys.Date() + runif(10) * 100 -#' )) +#' ) #' #' detail(df) #' @export @@ -27,7 +27,9 @@ detail <- function(x, ...) { #' setting as `NA` will ignore this #' @export detail.default <- function(x, factor_n = 5L, ...) { - stopifnot(!is.list(x)) + if (is.list(x)) { + stop(type_error("not_supported", x)) + } op <- options(stringsAsFactors = FALSE) on.exit(options(op), add = TRUE) @@ -62,12 +64,12 @@ detail.default <- function(x, factor_n = 5L, ...) { facts <- TRUE } - res <- quick_dfl( + res <- dataframe( class = collapse0(class(x), sep = "; "), - type = collapse0(typeof(x), sep = "; "), + type = collapse0(typeof(x), sep = "; "), label = exattr(x, "label") %||% NA_character_, - n = length(x2), - na = sum(nas), + n = length(x2), + na = sum(nas), # These are a little funky min_c = as.character(min(if (quants) x2 else nc)), max_c = as.character(max(if (quants) x2 else nc)) @@ -80,7 +82,8 @@ detail.default <- function(x, factor_n = 5L, ...) { res$level_n <- NA_integer_ } - text <- quick_dfl( + # fmt: skip + text <- dataframe( note = note(x) %||% NA_character_, comment = comment(x) %||% NA_character_ ) @@ -98,24 +101,15 @@ detail.data.frame <- function(x, factor_n = 5L, ...) { x <- x[, !vap_lgl(x, is.list), drop = FALSE] if (!ncol(x)) { - stop(cond_detail_data_frame_list()) + stop(input_error("`x` does not have any non-list columns")) } details <- lapply(x, detail, factor_n = factor_n) reps <- vap_int(details, nrow) cbind( - quick_dfl(i = rep(seq_along(x), reps)), - quick_dfl(col = rep(names(x), reps)), + dataframe(i = rep(seq_along(x), reps)), + dataframe(col = rep(names(x), reps)), Reduce(rbind, details) ) } - -# conditions -------------------------------------------------------------- - -cond_detail_data_frame_list <- function() { - new_condition( - "x does not have any non-list columns", - "detail_data_frame_list" - ) -} diff --git a/R/diff-time.R b/R/diff-time.R index 9eb3508e..fcb553c1 100644 --- a/R/diff-time.R +++ b/R/diff-time.R @@ -14,12 +14,11 @@ #' passed to the `tz` parameter as a character vector #' #' @section Units: Units can be used beyond those available in -#' `base::difftime()`. Some of these use assumptions in how units of time +#' [base::difftime()]. Some of these use assumptions in how units of time #' should be standardized and can be changed in the corresponding options. Any -#' of these can be calculated with `base::difftime()` through using `units = -#' "days"` but the `dtime` class will print out with these specifications into -#' the console for less potential confusion. -#' +#' of these can be calculated with [base::difftime()] through using +#' `units = "days"` but the `dtime` class will print out with these +#' specifications into the console for less potential confusion. #' #' \describe{ #' \item{months}{Months by number of days `mark.days_in_month` (defaults: `30`)} @@ -31,7 +30,7 @@ #' #' @section Time zones: Time zones can be passed as either a numeric vector of #' GMT/UTC offsets (the number of seconds from GMT) or as a character vector. -#' If the letter, these need to conform with values from `base::OlsonNames()`. +#' If the letter, these need to conform with values from [base::OlsonNames()]. #' #' A default timezone can be set with `options(mark.default_tz = .)`. The #' value can either be a numeric @@ -40,20 +39,27 @@ #' @param method A method to report the difference in units of time (see #' **Units** section) #' @param tzx,tzy time zones (see **Time zones** section) -#' @param ... Additional arguments passed to `diff_time()` +#' @param ... Additional arguments passed to [mark::diff_time()] #' @return A `diff_time` vector, object #' #' @export #' @name diff_time - -# nolint end: lien_length_linter. - +# nolint end: line_length_linter. diff_time <- function( x, y, - method = c("secs", "mins", "hours", - "days", "weeks", "months", - "years", "dyears", "wyears", "myears"), + method = c( + "secs", + "mins", + "hours", + "days", + "weeks", + "months", + "years", + "dyears", + "wyears", + "myears" + ), tzx = NULL, tzy = tzx ) { @@ -68,6 +74,7 @@ diff_time <- function( # NB: This is time from X to Y z <- uy - ux + # fmt: skip out <- switch( method, secs = z, @@ -75,11 +82,12 @@ diff_time <- function( hours = z / 3600, days = z / 86400, weeks = z / 604800, - months = z / getOption("mark.days_in_month", 30) / 86400, - years = z / getOption("mark.days_in_year", 365) / 86400, - dyears = z / getOption("mark.days_in_year", 365) / 86400, + months = z / getOption("mark.days_in_month", 30) / 86400, + years = z / getOption("mark.days_in_year", 365) / 86400, + dyears = z / getOption("mark.days_in_year", 365) / 86400, myears = z / getOption("mark.days_in_month", 30) / 1036800, - wyears = z / getOption("mark.weeks_in_year", 52) / 604800 + wyears = z / getOption("mark.weeks_in_year", 52) / 604800, + stop(internal_error()) # nocov ) struct(out, c("numeric", "diff_time"), units = method) @@ -92,7 +100,7 @@ extract_numeric_time <- function(x, tz) { if (is.null(tz)) { if (is.numeric(x)) { - stop(cond_extract_numeric_time_numeric()) + stop(numeric_datetime_tz_error()) } gmt <- NULL @@ -136,7 +144,7 @@ to_numeric_with_tz <- function(x, tz) { nas <- is.na(tz) if (any(nas)) { - warning(cond_to_numeric_with_tz_na()) + warning(na_timezone_found_warning()) tz[nas] <- default_tz() } @@ -171,7 +179,7 @@ check_tz <- function(x) { bad <- ux %out% OlsonNames() if (any(bad)) { - stop(cond_check_tz_timezones(ux[bad])) + stop(timezone_not_found_error(ux[bad])) } invisible(NULL) @@ -180,10 +188,11 @@ check_tz <- function(x) { #' @export print.diff_time <- function(x, digits = getOption("digits"), ...) { xu <- attr(x, "units") + # fmt: skip u <- switch( xu, - secs = "seconds", - mins = "minutes", + secs = "seconds", + mins = "minutes", # nolint start: line_length_linter. months = sprintf("months (%s days)", getOption("mark.days_in_month", 30)), years = sprintf("years (%s days)", getOption("mark.days_in_year", 365)), @@ -273,13 +282,15 @@ diff_time_myears <- function(x, y, ...) { #' @seealso [mark::diff_time] #' @name time_inherits #' @noRd -is_POSIXlt <- function(x) { # nolint: object_name_linter. +# nolint next: object_name_linter. +is_POSIXlt <- function(x) { inherits(x, "POSIXlt") } #' @rdname time_inherits #' @noRd -is_POSIXct <- function(x) { # nolint: object_name_linter. +# nolint next: object_name_linter. +is_POSIXct <- function(x) { inherits(x, "POSIXct") } @@ -293,9 +304,9 @@ is_diff_time <- function(x) { default_tz <- function() { # op.mark contains default_tz - tz <- getOption("mark.default_tz", "UTC") + tz <- getOption("mark.default_tz") - if (identical(tz, "UTC")) { + if (is.null(tz) || identical(tz, "UTC")) { return("UTC") } @@ -309,7 +320,7 @@ default_tz <- function() { } if (!is.character(tz) || length(tz) != 1L) { - stop(cond_default_tz_tz()) + stop(value_error("Invalid value for options('mark.default_tz')")) } tz @@ -337,42 +348,41 @@ sys_tz <- function(method = 1) { # conditions -------------------------------------------------------------- -cond_extract_numeric_time_numeric <- function() { # nolint: object_length_linter, line_length_linter. - new_condition( - "Date times cannot be numeric when tz is NULL", - "extract_numeric_time_numeric" - ) -} - -cond_to_numeric_with_tz_na <- function() { - new_condition( - paste("NA found in timezones; setting to", default_tz()), - "to_numeric_with_tz_na", - type = "warning" - ) -} - -cond_check_tz_timezones <- function(x) { - msg <- sprintf( - paste0( - "Timezone(s) not found: %s\n", - "Please check timezones in `OlsonNames()`" - ), - collapse(x, sep = ", ") +# TODO too many different condititons -- simplify + +numeric_datetime_tz_error := condition( + "Date times cannot be numeric when tz is NULL", + type = "error", + exports = "diff_time", + classes = "type_error", + help = "```r +# Instead of this: +diff_time(100, 200, tz = NULL) + +# do this: +diff_time(100, 200, tz = 'America/New_York') + +# or: +diff_time(100, 200, tz = 0) +```" +) + +na_timezone_found_warning := condition( + function() { + paste("NA found in timezones; setting to default timezone:", default_tz()) + }, + type = "warning", + classes = "value_warning", + exports = "diff_time" +) + +timezone_not_found_error := condition( + function(x) paste0("Timezone(s) not found: ", collapse(x, sep = ", "), "\n"), + type = "error", + exports = "diff_time", + classes = "value_error", + help = c( + "When using a string for a timezone, this value must be found within", + " `OlsonNames()`" ) - - new_condition(msg, "check_tz_timezone_olson") -} - -cond_default_tz_tz <- function() { - new_condition( - paste0( - "option(mark.default_tz) must be", - " a character vector of length 1L,", - " a function that returns a character vector of length 1L,", - " NULL (defaults to UTC),", - ' or "system" to set to system timezone' - ), - "default_tz_tz" - ) -} +) diff --git a/R/directory.R b/R/directory.R index 21bb8a0c..e89b4f90 100644 --- a/R/directory.R +++ b/R/directory.R @@ -6,9 +6,10 @@ #' @param ... Additional arguments passed to [mark::list_dirs()] #' @return The full path of the most recent directory #' @export - -get_recent_dir <- function(x = ".", ...) { - stopifnot(dir.exists(x)) +get_recent_dir <- function(x = ".", ...) { + if (!dir.exists(x)) { + stop(input_error("`x` must be an existing directory")) + } dirs <- list_dirs(x, ...) newest_dir(dirs) } @@ -23,12 +24,11 @@ get_recent_dir <- function(x = ".", ...) { #' @param all Logical, if `TRUE` will recursively search for directories #' @return A full path to a directory #' @export - get_dir_recent_date <- function( - x = ".", - dt_pattern = NULL, - dt_format = NULL, - all = FALSE + x = ".", + dt_pattern = NULL, + dt_format = NULL, + all = FALSE ) { dt_pattern <- dt_pattern %||% .default_dt_pattern dt_format <- dt_format %||% .default_dt_format @@ -54,7 +54,7 @@ get_dir_recent_date <- function( "%Y %m %d %H%M%S", "%Y%m%d %H %M %S", "%Y%m%d %H%M%S" - ) +) #' Get recent directory by number name #' @@ -81,9 +81,10 @@ get_dir_max_number <- function(x) { #' @return The full name of the most recent file from the stated directory #' #' @export - get_recent_file <- function(x, exclude_temp = TRUE, ...) { - stopifnot(is_dir(x)) + if (!is_dir(x)) { + stop(input_error("`x` must be a directory")) + } files <- list_files(x, ...) @@ -92,7 +93,7 @@ get_recent_file <- function(x, exclude_temp = TRUE, ...) { } if (no_length(files)) { - stop(cond_get_recent_file_none()) + stop(path_error()) } newest_file(files) @@ -107,22 +108,23 @@ remove_temp_files <- function(x) { #' Normalize and check a vector of paths #' #' @param x A character vector of paths -#' @param check Logical, if TRUE will check if the path exists and output a +#' @param check Logical, if `TRUE` will check if the path exists and output a #' warning if it does not. -#' @param remove Logical, if TRUE will remove paths that are not found +#' @param remove Logical, if `TRUE` will remove paths that are not found #' @param ... Character vectors for creating a path #' @return A vector of full file paths #' #' @export - norm_path <- function(x = ".", check = FALSE, remove = check) { - stopifnot(is.character(x)) + if (!is.character(x)) { + stop(type_error("must_be", x, "character")) + } x <- fs::path_abs(x) ind <- !fs::file_exists(x) if (check && any(ind)) { - warning(cond_norm_path_found(x[ind])) + warning(path_warning("not_found", x[ind])) } if (remove) { @@ -199,34 +201,37 @@ smallest_file <- function(x) { x[which.min(file.size(x))] } +# NOTE Using link for [base::shell.exec()] will fail on non-Windows + #' Open a file using windows file associations #' #' Opens the given files(s) #' -#' @details `open_file` is an alternative to `shell.exec()` that can take take -#' multiple files. `list_files` and `list_dirs` are mostly wrappers for -#' [fs::dir_ls()] with preferred defaults and pattern searching on the full file -#' path. +#' @details [mark::open_file()] is an alternative to `base::shell.exec()` that +#' can take take multiple files. [mark::list_files()] and [mark::list_dirs()] +#' are mostly wrappers for [fs::dir_ls()] with preferred defaults and pattern +#' searching on the full file path. #' -#' `file_open` is simply an alias. +#' [mark::file_open()] is simply an alias. #' #' @inheritParams norm_path #' @inheritParams fs::dir_ls #' @param pattern,glob Pattern to search for files. `glob` is absorbed into #' `pattern`, through [utils::glob2rx()]. #' @param ignore_case logical. Should pattern-matching be case-insensitive? -#' @param all a logical value. If FALSE, only the names of visible files are +#' @param all a logical value. If `FALSE`, only the names of visible files are #' returned (following Unix-style visibility, that is files whose name does -#' not start with a dot). If TRUE, all file names will be returned. +#' not start with a dot). If `TRUE`, all file names will be returned. #' @param basename If `TRUE` only searches pattern on the basename, otherwise on #' the entire path #' @param negate Logical, if `TRUE` will inversely select files that do not #' match the provided pattern #' #' @return -#' * `open_file()`, `shell_exec()`: A logical vector where `TRUE` successfully -#' opened, `FALSE` did not and `NA` did not try to open (file not found) -#' * `list_files()`, `list_dirs()`: A vector of full paths +#' - [mark::open_file()], [mark::shell_exec()]: A logical vector where `TRUE` +#' successfully opened, `FALSE` did not and `NA` did not try to open (file not +#' found) +#' - [mark::list_files()], [mark::list_dirs()]: A vector of full paths #' @name file_utils NULL @@ -247,7 +252,8 @@ file_open <- open_file #' @export shell_exec <- function(x) { if (is_windows()) { - open_fun <- function(path) shell.exec(file = path) # nolint: object_usage_linter, line_length_linter. + # nolint next: object_usage_linter. + open_fun <- function(path) shell.exec(file = path) } else { require_namespace("xopen") open_fun <- function(path) xopen::xopen(target = path) @@ -273,7 +279,6 @@ list_files <- function( negate = FALSE, basename = FALSE ) { - pattern <- force(pattern) %|||% NULL path <- norm_path(x, check = TRUE) @@ -285,21 +290,21 @@ list_files <- function( if (basename) { # default behavior fs::dir_ls( - path = path, - regexp = pattern, - all = all, - recurse = all, + path = path, + regexp = pattern, + all = all, + recurse = all, ignore.case = ignore_case, - invert = negate, - type = "file" + invert = negate, + type = "file" ) } else { # If we want the regular expression applied to the entire file fs::dir_ls( - path = path, - all = all, + path = path, + all = all, recurse = all, - type = "file" + type = "file" ) } @@ -331,12 +336,12 @@ list_files <- function( #' @rdname file_utils #' @export list_dirs <- function( - x = ".", - pattern = NULL, - ignore_case = FALSE, - all = FALSE, - basename = FALSE, - negate = FALSE + x = ".", + pattern = NULL, + ignore_case = FALSE, + all = FALSE, + basename = FALSE, + negate = FALSE ) { path <- norm_path(x, check = TRUE) @@ -382,7 +387,9 @@ list_dirs <- function( #' @export is_dir <- function(x) { - stopifnot(!no_length(x), is.character(x)) + if (no_length(x) || !is.character(x)) { + stop(input_error("`x` must be a non-zero length character vector")) + } dir.exists(x) } @@ -390,15 +397,18 @@ is_dir <- function(x) { #' @rdname is_dir #' @export is_file <- function(x) { - stopifnot(!no_length(x), is.character(x)) + if (no_length(x) || !is.character(x)) { + stop(input_error("`x` must be a non-zero length character vector")) + } isdir <- file.info(x, extra_cols = FALSE)[["isdir"]] !is.na(isdir) & !isdir } +# FIXME remove -- unused, unexported file_create <- function(x, overwrite = FALSE) { dirs <- is_dir(x) if (any(dirs)) { - warning(cond_file_create_dir(x[dirs])) + warning(path_warning("directories", x[dirs])) x <- x[!dirs] } @@ -438,7 +448,8 @@ file_name <- function(x, compression = FALSE) { #' Adds a timestamp to a file #' #' @param x A vector of files -#' @param ts A single timestamp or vector of timestamps (default: `Sys.time()`) +#' @param ts A single timestamp or vector of timestamps (default: +#' [base::Sys.time()]) #' @param format A format to be applied to the times; set to `NULL` to skip #' formatting #' @param sep A `character` vector of length 1 to separate the timestamp from @@ -454,10 +465,10 @@ file_name <- function(x, compression = FALSE) { #' #' file.remove(file1, file2) add_file_timestamp <- function( - x, - ts = Sys.time(), - format = "%Y-%m-%d %H%M%S", - sep = " " + x, + ts = Sys.time(), + format = "%Y-%m-%d %H%M%S", + sep = " " ) { if (!is.null(format)) { ts <- format(ts, format = format) @@ -475,27 +486,46 @@ add_file_timestamp <- function( # conditions -------------------------------------------------------------- -cond_get_recent_file_none <- function() { - new_condition("No files found", "get_recent_file_none") -} - -cond_norm_path_found <- function(paths) { - new_condition( - paste0("Paths not found:\n '", collapse(paths, sep = "'\n '"), "'"), - "norm_path_found", - type = "warning" - ) -} +# TODO use value_error() -cond_file_create_dir <- function(x) { - new_condition( - paste0( - "Cannot create files that are directories:", - paste0("\n ", norm_path(x)) - ), - "file_create_dir", - type = "warning" - ) -} +path_error := condition( + "No recent file found", + type = "error", + classes = "value_error", + exports = "get_recent_file" +) -# terminal line +path_warning := condition( + function(s, x) { + switch( + s, + not_found = function(x) { + ngettext( + length(x), + paste("Path not found:", norm_path(x)), + paste0( + "Paths not found:", + paste0("\n ", norm_path(x), collapse = "\n") + ) + ) + }, + directories = function(x) { + ngettext( + length(x), + paste("File is a directory:", norm_path(x)), + paste0( + "Files are directories:", + paste0("\n ", norm_path(x), collapse = "\n") + ) + ) + }, + stop(internal_error()) + ) + }, + type = "warning", + classes = "value_warning", + exports = c("get_recent_file", "norm_path"), + help = { + "File creation cannot be performed when the path is an existing directory" + } +) diff --git a/R/environments.R b/R/environments.R index 7a759a97..2cb7018c 100644 --- a/R/environments.R +++ b/R/environments.R @@ -2,18 +2,19 @@ #' #' Functions to list out all environments and objects #' -#' @details -#' `environments()` is basically a printing wrapper for `base::search()` +#' @details [mark::environments()] is basically a printing wrapper for +#' [base::search()] #' -#' `ls_all()` and `objects_all()` can be used retrieved all objects from all -#' environments in the `search()` path, which may print out a large result -#' into the console. +#' [mark::ls_all()] and [mark::objects_all()] can be used retrieved all +#' objects from all environments in the [base::search()] path, which may print +#' out a large result into the console. #' #' @inheritParams base::ls #' #' @export #' @return -#' * `environments()`: Invisibly, a `character` vector of environment names +#' - [mark::environments()]: Invisibly, a `character` vector of environment +#' names #' @name list_environments environments <- function() { struct(search(), c("character", "mark_environments")) @@ -30,9 +31,11 @@ print.mark_environments <- function(x, ...) { #' @export #' @rdname list_environments #' @return -#' * `ls_all()`, `objects_all()`: A named list for each of the environments -#' the `search()` path with all the objects found in that environment -ls_all <- function(all.names = FALSE) { # nolint: object_name_linter, line_length_linter. +#' - [mark::ls_all()], [mark::objects_all()]: A named list for each of the +#' environments the [base::search()] path with all the objects found in that +#' environment +# nolint next: object_name_linter. +ls_all <- function(all.names = FALSE) { sapply(search(), function(s) ls(as.environment(s), all.names = all.names)) } @@ -47,13 +50,26 @@ objects_all <- ls_all #' @name ls_ext NULL -# nolint start: object_name_linter. -make_do_ls <- function(FUN) { - FUN <- match.fun(FUN) - function(pattern, all.names = FALSE, envir = parent.frame()) { - # nolint end: object_name_linter. - do_ls(FUN, pattern = pattern, all.names = all.names, envir = envir) - } +make_do_ls <- function(fun) { + fun <- substitute(fun) + # nolint next: object_usage_linter. False positive + expr <- substitute( + do_ls(..fun.., pattern = pattern, all.names = all.names, envir = envir), + list(..fun.. = fun) + ) + + eval( + substitute( + as.function( + alist( + pattern = , + all.names = FALSE, + envir = parent.frame(), + expr + ) + ) + ) + ) } #' @export @@ -68,7 +84,8 @@ ls_function <- make_do_ls(is.function) #' @rdname ls_ext ls_object <- make_do_ls(is.object) -do_ls <- function(FUN, pattern, all.names = FALSE, envir = parent.frame()) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +do_ls <- function(FUN, pattern, all.names = FALSE, envir = parent.frame()) { .ls <- ls(envir = envir, pattern = pattern, all.names = all.names) .ls[vap_lgl(.ls, function(x) FUN(get0(x, envir = envir)))] } diff --git a/R/expand.R b/R/expand.R index 32dc4c9e..970ae869 100644 --- a/R/expand.R +++ b/R/expand.R @@ -4,7 +4,7 @@ #' #' @param x,y Vectors #' @param expand Character switch to expand or keep only the values that -#' intersect, all values in x or y, or retain all values found. +#' intersect, all values in `x` or `y`, or retain all values found. #' @param sort Logical, if `TRUE` will sort by names in output #' #' @return A vector with expanded @@ -18,13 +18,15 @@ #' expand_by(x, y, "both") #' @export expand_by <- function( - x, - y, - expand = c("x", "y", "intersect", "both"), - sort = FALSE + x, + y, + expand = c("x", "y", "intersect", "both"), + sort = FALSE ) { expand <- match_param(expand) + # fmt: skip if (!is_named(x)) names(x) <- x + # fmt: skip if (!is_named(y)) names(y) <- y nx <- names(x) @@ -102,20 +104,20 @@ expand_by <- function( #' reindex(iris1, "index", seq(2, 8, 2), expand = "both") #' @export reindex <- function( - x, - index = NULL, - new_index, - expand = c("intersect", "both"), - sort = FALSE + x, + index = NULL, + new_index, + expand = c("intersect", "both"), + sort = FALSE ) { expand <- match_param(expand) if (!inherits(x, "data.frame")) { - stop("`x` must be a data.frame", call. = FALSE) + stop(class_error("must_be", x, "data.frame")) } if (no_length(new_index)) { - stop("new_index must not be NULL or 0 length", call. = FALSE) + stop(input_error("`new_index` cannot be NULL or 0 length")) } xi <- if (is.null(index)) { @@ -127,11 +129,11 @@ reindex <- function( } if (anyNA(xi)) { - warning(cond_reindex_na()) + warning(reindex_warning(which(is.na(xi)))) } if (is.null(xi)) { - stop(cond_reindex_index()) + stop(reindex_error()) } ro <- expand_by(xi, new_index, expand = expand, sort = sort) @@ -142,36 +144,64 @@ reindex <- function( out } -# FUNS -------------------------------------------------------------------- +# helpers ----------------------------------------------------------------- unique_name_check <- function(x) { # Checks that names are unique in the vector nm <- names(x) %||% x - lens <- counts(nm) - int <- lens > 1 - - if (any(int)) { - warning("These names are duplicated: ", - collapse0(names(lens[int]), sep = ", "), - call. = FALSE) - return(invisible(FALSE)) - } + dupes <- duplicated(nm) - invisible(TRUE) + if (any(dupes)) { + warning(duplicate_warning(x = nm, name = "names")) + FALSE + } else { + TRUE + } } # conditions -------------------------------------------------------------- -cond_reindex_na <- function() { - new_condition( - "NA values detected in index this may cause errors with expansion", - "reindex_na", - type = "warning" - ) -} - -cond_reindex_index <- function() { - new_condition("x[[index]] returned `NULL`", "reindex_index") -} +# TODO use na_warning(); move information to function docs +reindex_warning := condition( + function(x) { + paste( + ngettext( + length(x), + "NA value detected in index at position:", + "NA values detected in index at positions:" + ), + collapse(x, sep = ", ") + ) + }, + type = "warning", + exports = "reindex", + help = "NA values in index may cause errors with expansion + +`reindex()` will not match on NA values but instead will return a row of NAs + +```r +x <- data.frame(index = c(1:2, NA, 4:5), values = letters[1:5]) +reindex(x, 'index', c(1, 2, 5)) +#> index values +#> 1 1 a +#> 2 2 b +#> 5 5 e + +reindex(x, 'index', c(1, 2, 5, NA)) +#> index values +#> 1 1 a +#> 2 2 b +#> 5 5 e +#> NA +``` +" +) + +reindex_error := condition( + "x[[index]] returned `NULL`", + type = "error", + classes = "value_error", + exports = "reindex" +) # terminal line diff --git a/R/fact.R b/R/fact.R index e0545a3a..d41b622c 100644 --- a/R/fact.R +++ b/R/fact.R @@ -1,3 +1,4 @@ +# NOTE I'll eventually replace these with jmbarbone/facts (or jmbarbone/fctrs) # fact -------------------------------------------------------------------- @@ -5,19 +6,19 @@ #' #' Quickly create a factor #' -#' @details `fact()` can be about 5 times quicker than `factor()` or -#' `as.factor()` as it doesn't bother sorting the levels for non-numeric data -#' or have other checks or features. It simply converts a vector to a factor -#' with all unique values as levels with `NA`s included. +#' @details [mark::fact()] can be about 5 times quicker than [base::factor()] or +#' [base::as.factor()] as it doesn't bother sorting the levels for non-numeric +#' data or have other checks or features. It simply converts a vector to a +#' factor with all unique values as levels with `NA`s included. #' -#' `fact.factor()` will perform several checks on a factor to include `NA` -#' levels and to check if the levels should be reordered to conform with the -#' other methods. The `fact.fact()` method simple returns `x`. +#' [mark::fact.factor()] will perform several checks on a factor to include +#' `NA` levels and to check if the levels should be reordered to conform with +#' the other methods. The [mark::fact.fact()] method simple returns `x`. #' #' @section level orders: #' -#' The order of the levels may be adjusted to these rules depending on the class -#' of `x`: +#' The order of the levels may be adjusted to these rules depending on the +#' class of `x`: #' \describe{ #' \item{`character`}{The order of appearance} #' \item{`numeric`/`integer`/`Date`/`POSIXt`}{By the numeric order} @@ -30,7 +31,7 @@ #' @return A vector of equal length of `x` with class `fact` and `factor`. If #' `x` was `ordered`, that class is added in between. #' -#' @seealso [as_ordered()] +#' @seealso [mark::as_ordered()] #' @family factors #' @export fact <- function(x) { @@ -206,7 +207,7 @@ print.fact <- function( T0 <- "Levels: " # nolint: object_name_linter. if (is.logical(max_levels)) { max_levels <- { - width <- width - (nchar(T0, "w") + 3L + 1L + 3L) + width <- width - (nchar(T0, "w") + 3L + 1L + 3L) lenl <- cumsum(nchar(lev, "w") + nchar(colsep, "w")) if (n <= 1L || lenl[n] <= width) { @@ -222,7 +223,7 @@ print.fact <- function( T0, paste( if (drop) { - c(lev[1L:max(1, max_levels - 1)], "...", if (max_levels > 1) lev[n]) + c(lev[1:max(1L, max_levels - 1L)], "...", if (max_levels > 1L) lev[n]) } else { lev }, @@ -249,13 +250,13 @@ print.fact <- function( #' As ordered #' #' @details Simple implementation of `ordered`. If `x` is `ordered` it is -#' simply returned. If `x` is a `factor` the `ordered` class is added. -#' Otherwise, `x` is made into a `factor` with [mark::fact()] and then the -#' `ordered` class is added. Unlike just `fact`, `ordered` will replace the `NA` -#' levels with `NA_integer_` to work appropriately with other functions. +#' simply returned. If `x` is a `factor` the `ordered` class is added. +#' Otherwise, `x` is made into a `factor` with [mark::fact()] and then the +#' `ordered` class is added. Unlike just `fact`, `ordered` will replace the +#' `NA` levels with `NA_integer_` to work appropriately with other functions. #' #' @inheritParams fact -#' @seealso [fact()] +#' @seealso [mark::fact()] #' @family factors #' @export #' @returns An `ordered` vector @@ -284,10 +285,10 @@ as_ordered.default <- function(x) { res <- fact_na(x, remove = TRUE) if (!is.ordered(x)) { - res <- add_class(res, "ordered", 2L) + add_class(res, "ordered", 2L) + } else { + res } - - res } @@ -361,7 +362,7 @@ fact_na <- function(x, remove = FALSE) { } if (remove) { - attr(x, "levels") <- attr(x, "levels")[-na] + attr(x, "levels") <- attr(x, "levels")[-na] attr(x, "uniques") <- attr(x, "uniques")[-na] } @@ -379,8 +380,8 @@ fact_na <- function(x, remove = FALSE) { #' #' Reverse the levels of a `fact` #' -#' @param x A `fact` object (or passed to [fact()]) -fact_reverse <- function(x) { +#' @param x A `fact` object (or passed to [mark::fact()]) +fact_reverse <- function(x) { x <- fact(x) lvls <- flip(attr(x, "uniques")) seq <- flip(seq_along(lvls)) @@ -436,7 +437,7 @@ as.Date.fact <- function(x, ...) { } #' @export -`[.fact` <- function(x, ...) { +`[.fact` <- function(x, ...) { y <- NextMethod("[") attributes(y) <- attributes(x) y @@ -501,12 +502,11 @@ fact_coerce_levels <- function(x) { numbers <- as.numeric(x[!nas]) dates <- as.Date(x[!nas], optional = TRUE) posix <- as.POSIXct( - x = x[!nas], + x = x[!nas], tryFormats = try_formats(), - tz = tz, - optional = TRUE + tz = tz, + optional = TRUE ) - }) n <- length(x) @@ -516,12 +516,14 @@ fact_coerce_levels <- function(x) { x[!nas] <- dates } else if (!anyNA(posix)) { x <- rep(NA_real_, n) - stopifnot(all(!nas)) + if (any(nas)) { + stop() + } x[] <- as.double(posix) x <- as.POSIXct( - x = x, - origin = "1970-01-01", - tz = tz + x = x, + origin = "1970-01-01", + tz = tz ) } else if (!anyNA(numbers)) { x <- rep(NA_real_, n) @@ -538,6 +540,7 @@ fact_coerce_levels <- function(x) { new_fact(match(levels, value)[x], value, is.ordered(x)) } -is.fact <- function(x) { # nolint: object_name_linter. +# nolint next: object_name_linter. +is.fact <- function(x) { inherits(x, "fact") } diff --git a/R/fct_expand_seq.R b/R/fct-expand-seq.R similarity index 68% rename from R/fct_expand_seq.R rename to R/fct-expand-seq.R index b0b5042d..c4c5bbf8 100644 --- a/R/fct_expand_seq.R +++ b/R/fct-expand-seq.R @@ -20,17 +20,22 @@ #' # from the first inherit level to the last observed #' fct_expand_seq(x, min(levels(x))) #' @export - fct_expand_seq <- function( - x, - min_lvl = min(x, na.rm = TRUE), - max_lvl = max(x, na.rm = TRUE), - by = 1L + x, + min_lvl = min(x, na.rm = TRUE), + max_lvl = max(x, na.rm = TRUE), + by = 1L ) { - stopifnot( - inherits(x, "ordered"), - is.integer(by) || by < 1L - ) + if (!inherits(x, "ordered")) { + stop(class_error("must_be", x, "ordered")) + } + + by <- as.integer(by) + + if (!isTRUE(by >= 0L)) { + stop(input_error("`by` must be a positive integer")) + } + lvls <- levels(x) if (is.character(min_lvl) || inherits(min_lvl, "factor")) { @@ -42,11 +47,11 @@ fct_expand_seq <- function( } if (is.na(min_lvl)) { - stop(cond_fct_expand_seq_na("min_lvl")) + stop(fct_expand_seq_error("min")) } if (is.na(max_lvl)) { - stop(cond_fct_expand_seq_na("max_lvl")) + stop(fct_expand_seq_error("max")) } int <- seq(from = min_lvl, to = max_lvl, by = by) @@ -55,7 +60,10 @@ fct_expand_seq <- function( # condition --------------------------------------------------------------- -cond_fct_expand_seq_na <- function(x = c("min_lvl", "max_lvl")) { - x <- match_param(x) - new_condition(paste(x, "cannot be `NA`"), "fct_expand_seq_na") -} +# TODO use na_error() +fct_expand_seq_error := condition( + function(x = c("min", "max")) paste0(match_param(x), "_lvl cannot be `NA`"), + type = "error", + classes = "na_error", + exports = "fct_expand_seq" +) diff --git a/R/file.R b/R/file.R index 8f725a9c..fccc76c7 100644 --- a/R/file.R +++ b/R/file.R @@ -1,4 +1,3 @@ - #' File copy with md5 hash check #' #' @inheritParams fs::file_copy @@ -15,13 +14,16 @@ file_copy_md5 <- function(path, new_path, overwrite = NA, quiet = FALSE) { msg <- if (quiet) { function(...) invisible() } else if (utils::packageVersion("fuj") < "0.2.2") { - function(...) message(...) + function(...) cat(..., "\n") } else { - function(...) message(cond_file_copy_md5(...)) + function(...) cnd(md5_condition(...)) } # not as pretty, but pretty reasonable - stopifnot(length(path) == length(new_path)) + if (length(path) != length(new_path)) { + stop(input_error("`length(path)` must be equal to `length(new_path)`")) + } + # md5sum(nonexisting_file) produces NA md_old <- unname(tools::md5sum(path)) md_new <- unname(tools::md5sum(new_path)) @@ -48,10 +50,15 @@ file_copy_md5 <- function(path, new_path, overwrite = NA, quiet = FALSE) { invisible(new_path) } -cond_file_copy_md5 <- function(...) { - fuj::new_condition( - .makeMessage(...), - class = "file_copy_md5", - type = "message" - ) -} +md5_condition := condition( + function(...) paste(..., collapse = ""), + type = "condition", + exports = "file_copy_md5", + # nolint start: line_length_linter. + help = " +Produces messages on md5 checks when `file_copy_md5(quiet = FALSE)`. +The message will indicate whether the file was new, or if the md5 hash was the same or different. +When `quiet = TRUE`, no messages will be produced. +" + # nolint ends: line_length_linter. +) diff --git a/R/fizzbuzz.R b/R/fizzbuzz.R index 073abe2d..2ba5aafb 100644 --- a/R/fizzbuzz.R +++ b/R/fizzbuzz.R @@ -4,11 +4,10 @@ #' that the quickest way to do it is to just take the work someone else did and #' utilize that. No reason to reinvent the wheel. #' -#' @details -#' Multiples of `3` are shown as `"Fizz"`; multiples of `5` as `"Buzz"`; -#' multiple of both (i.e., `15`) are `"FizzBuzz"`. -#' `fizzbuzz_lazy()` subsets the `.fizzbuzz_vector` object, which is a solution -#' with default parameters up to `1e6` +#' @details Multiples of `3` are shown as `"Fizz"`; multiples of `5` as +#' `"Buzz"`; multiple of both (i.e., `15`) are `"FizzBuzz"`. +#' [mark::fizzbuzz_lazy()] subsets the `.fizzbuzz_vector` object, which is a +#' solution with default parameters up to `1e6` #' #' @param n The number of numbers #' @param show_numbers If `TRUE` shows no diff --git a/R/funs.R b/R/funs.R index d50076ae..9d223b00 100644 --- a/R/funs.R +++ b/R/funs.R @@ -38,13 +38,13 @@ rn <- function(namespace) { #' Check if package is available #' -#' A wrapped requireNamespace +#' A wrapped [base::requireNamespace()] #' #' @param namespace One or more packages to to require. #' @export #' @return -#' * `require_namespace()`: None, called for side effects -#' * `package_available()`: Visibly, `TRUE` or `FALSE` +#' - [mark::require_namespace()]: None, called for side effects +#' - [mark::package_available()]: Visibly, `TRUE` or `FALSE` #' @export package_available <- function(namespace) { vap_lgl(namespace, requireNamespace, quietly = TRUE) @@ -58,7 +58,7 @@ rn_soft <- function(namespace) { #' Quiet stop #' -#' Quietly calls stop +#' Quietly calls [base::stop()] #' #' @return None, called for side effects #' @export @@ -66,5 +66,5 @@ quiet_stop <- function() { op <- options() options(show.error.messages = FALSE) on.exit(options(op), add = TRUE) - stop() + stop(condition("quiet_stop", "quiet stop", type = "error")()) } diff --git a/R/glob.R b/R/glob.R index b7555191..7d66d30c 100644 --- a/R/glob.R +++ b/R/glob.R @@ -4,8 +4,9 @@ #' #' @param x A vector of characters #' @param pattern Wildcard globbing pattern -#' @param value,... Additional parameters passed to `grep`. Note: `value` is by -#' default `TRUE`; when `NA`, `...` is passed to `grepl`. +#' @param value,... Additional parameters passed to [base::grep()]. Note: +#' `value` is by default `TRUE`; when `NA`, `...` is passed to +#' [base::grep()]`. #' @examples #' x <- c("apple", "banana", "peach", "pear", "orange") #' glob(x, "*e") diff --git a/R/handlers.R b/R/handlers.R index 23e544c9..e9c664dc 100644 --- a/R/handlers.R +++ b/R/handlers.R @@ -45,41 +45,48 @@ NULL #' @export #' @rdname handlers -has_warning <- function(x, FUN, ...) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +has_warning <- function(x, FUN, ...) { has_catch(x, FUN, ..., type = "warning") } #' @export #' @rdname handlers -has_error <- function(x, FUN, ...) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +has_error <- function(x, FUN, ...) { has_catch(x, FUN, ..., type = "error") } #' @export #' @rdname handlers -has_message <- function(x, FUN, ...) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +has_message <- function(x, FUN, ...) { has_catch(x, FUN, ..., type = "message") } #' @export #' @rdname handlers -get_warning <- function(x, FUN, ..., .null = TRUE) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +get_warning <- function(x, FUN, ..., .null = TRUE) { get_catch(x, FUN, type = "warning", null = .null) } #' @export #' @rdname handlers -get_message <- function(x, FUN, ..., .null = TRUE) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +get_message <- function(x, FUN, ..., .null = TRUE) { get_catch(x, FUN, type = "message", null = .null) } #' @export #' @rdname handlers -get_error <- function(x, FUN, ..., .null = TRUE) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +get_error <- function(x, FUN, ..., .null = TRUE) { get_catch(x, FUN, type = "error", null = .null) } -has_catch <- function(x, FUN, ..., type = c("error", "warning", "message")) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +has_catch <- function(x, FUN, ..., type = c("error", "warning", "message")) { type <- match_param(type) FUN <- match.fun(FUN) # nolint: object_name_linter. res <- sapply(x, catch(FUN), ..., USE.NAMES = TRUE, simplify = FALSE) @@ -95,7 +102,8 @@ print.has_catch <- function(x, ...) { invisible(x) } -get_catch <- function(x, FUN, type, ..., null = TRUE) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter +get_catch <- function(x, FUN, type, ..., null = TRUE) { res <- sapply(x, catch(FUN), ..., USE.NAMES = TRUE, simplify = FALSE) out <- sapply(res, function(i) i[[type]], USE.NAMES = TRUE, simplify = FALSE) out <- set_names(out, x) @@ -108,14 +116,14 @@ get_catch <- function(x, FUN, type, ..., null = TRUE) { # nolint: object_name_li } # Adapted from https://stackoverflow.com/a/4952908/12126576 -catch <- function(FUN) { # nolint: object_name_linter. - FUN <- match.fun(FUN) # nolint: object_name_linter. +catch <- function(fun) { + fun <- match.fun(fun) function(...) { env <- list2env(list(error = NULL, warning = NULL, message = NULL)) res <- withCallingHandlers( tryCatch( - FUN(...), + fun(...), error = function(e) { env$error <- c(env$error, e$message) NULL diff --git a/R/identical.R b/R/identical.R index 36c5e295..96346330 100644 --- a/R/identical.R +++ b/R/identical.R @@ -1,6 +1,6 @@ #' Identical extensions #' -#' Extensions for the use of `base::identical()` +#' Extensions for the use of [base::identical()] #' #' @param ... Vectors of values to compare, element-wise of equal length #' @param params Additional params (as a named list of arguments for @@ -18,21 +18,18 @@ #' are_identical(x, y) # element-wise #' are_identical(x, y, z) # 3 or more vectors #' @export - are_identical <- function(..., params = NULL) { x <- rlang::list2(...) n <- length(x) - if (length(unique(lengths(x))) != 1L) { - stop(cond_are_identical_none()) - } - - if (n < 2L) { - stop(cond_are_identical_two()) + if (length(unique(lengths(x))) != 1L || n < 2L) { + stop(input_error( + "... must have at least two arguments and be equal length vectors" + )) } if (n == 2L) { - return(do_map_identical(x[[1]], x[[2]], params)) + return(do_map_identical(x[[1L]], x[[2L]], params)) } res <- list() @@ -41,33 +38,15 @@ are_identical <- function(..., params = NULL) { res[[i]] <- do_map_identical(x[[i]], x[[i + 1L]], params) } - apply(Reduce(cbind, res), 1, all) + apply(Reduce(cbind, res), 1L, all) } do_map_identical <- function(x, y, params = NULL) { mapply( - function(.x, .y) { - do.call(identical, c(list(x = .x, y = .y), params)) - }, - x, - y, + function(.x, .y) do.call(identical, c(list(x = .x, y = .y), params)), + .x = x, + .y = y, USE.NAMES = FALSE, SIMPLIFY = TRUE ) } - -# conditions -------------------------------------------------------------- - -cond_are_identical_none <- function() { - new_condition( - "... must have equal length vectors", - "are_identical_none" - ) -} - -cond_are_identical_two <- function() { - new_condition( - "... must have length of 2 or more", - "are_identical_two" - ) -} diff --git a/R/import.R b/R/import.R index 23366b1f..15284834 100644 --- a/R/import.R +++ b/R/import.R @@ -4,7 +4,7 @@ #' #' @param pkg String, name of the package #' @param fun String, fun name of the function -#' @param overwrite Logical, if TRUE and `fun` is also found in the current +#' @param overwrite Logical, if `TRUE` and `fun` is also found in the current #' environment, will overwrite assignment #' @return None, called for side effects #' @export @@ -12,29 +12,39 @@ #' @examples #' # assigns `add` -- test with caution #' import("magrittr", "add") - import <- function(pkg, fun, overwrite = FALSE) { e <- parent.frame() require_namespace(pkg) if (!overwrite && fun %in% ls(envir = e)) { - stop(cond_import_assigned(fun)) + stop(import_error(fun)) } - assign(fun, pkg %colons% fun, envir = e) + assign(fun, pkg %::% fun, envir = e) } # conditions -------------------------------------------------------------- -cond_import_assigned <- function(fun) { - new_condition( - sprintf( - paste( - "`%s` has already been assigned.", - "Use `overwite = TRUE` to overwrite assignment." - ), - fun - ), - "import_assigned" - ) -} +# nolint start: line_length_linter. +import_error := condition( + message = function(fun) sprintf("'%s' has already been assigned", fun), + type = "error", + exports = "import", + classes = "value_error", # NOTE maybe assign_error()? + help = " +The object you are trying to import has already been assigned in the environment you are importing to. Use the `overwrite` option to replace the object. + +For example: + +```r +# instead of +foo <- NULL +import('package', 'foo') + +# do this +foo <- NULL +import('package', 'foo', overwrite = TRUE) +``` +" +) +# nolint end: line_length_linter. diff --git a/R/insert.R b/R/insert.R index 476faf33..abf94fea 100644 --- a/R/insert.R +++ b/R/insert.R @@ -13,16 +13,19 @@ #' #' @export insert <- function(x, positions, values) { - stopifnot(!anyNA(positions)) + if (anyNA(positions)) { + stop(input_error("positions cannot contain NA values")) + } + positions <- as.integer(positions) + if (any(positions < 1L)) { + stop(input_error("positions must be positive integers")) + } + nval <- length(values) npos <- length(positions) - if (npos == 0L) { - stop(cond_insert_npos()) - } - if (nval == 1L && !is.list(values)) { values <- rep.int(values, npos) } else if (nval == npos) { @@ -30,7 +33,7 @@ insert <- function(x, positions, values) { positions <- positions[o] values <- values[o] } else { - stop(cond_insert_length()) + stop(input_error("lengths of positions and values are unequal")) } seqs <- seq_along(positions) @@ -42,20 +45,3 @@ insert <- function(x, positions, values) { x } - - -# conditions -------------------------------------------------------------- - -cond_insert_npos <- function() { - new_condition( - "positions has no length", - "insert_npos" - ) -} - -cond_insert_length <- function() { - new_condition( - "length(values) must be equal to length(positions) or 1", - "insert_length" - ) -} diff --git a/R/labels.R b/R/labels.R index 9123e9f2..280951b3 100644 --- a/R/labels.R +++ b/R/labels.R @@ -2,16 +2,15 @@ #' #' Assign labels to a vector or data.frame. #' -#' @details -#' When labels are assigned to a data.frame they can make viewing the object -#' (with `View()` inside Rstudio). The `view_labels()` has a call to `View()` -#' inside and will retrieve the labels and show them in the viewer as a -#' data.frame. +#' @details When labels are assigned to a data.frame they can make viewing the +#' object (with `View()` inside Rstudio). [mark::view_labels()] has a call to +#' `View()` inside and will retrieve the labels and show them in the viewer as a +#' data.frame. #' #' @param x A vector of data.frame #' @param ... One or more unquoted expressed separated by commas. If assigning #' to a data.frame, `...` can be replaced with a `data.frame` where the first -#' column is the targeted colname and the second is the desired label. +#' column is the targeted column name and the second is the desired label. #' @param label A single length string of a label to be assigned #' @param cols A character vector of column names; if missing will remove the #' label attribute across all columns @@ -45,39 +44,43 @@ assign_labels <- function(x, ...) { #' @export #' @rdname labels assign_labels.default <- function(x, label, ...) { - stopifnot(length(label) == 1) + if (length(label) != 1L) { + stop(input_error("`label` must be a single length vector")) + } attr(x, "label") <- label x } #' @export #' @rdname labels -#' @param .missing A control setting for dealing missing columns in a list; -#' can be set to `error` to `stop()` the call, `warn` to provide a warning, or -#' `skip` to silently skip those labels. +#' @param .missing A control setting for dealing missing columns in a list; can +#' be set to `"error"` to [base::stop()] the call, `"warn"` to provide a +#' warning, or `"skip"` to silently skip those labels. #' @param .ls A named list of columns and labels to be set if `...` is empty assign_labels.data.frame <- function( - x, - ..., - .missing = c("error", "warn", "skip"), - .ls = rlang::list2(...) + x, + ..., + .missing = c("error", "warn", "skip"), + .ls = rlang::list2(...) ) { - stopifnot(!identical(.ls, list())) - - if (...length() && !identical(rlang::list2(...), .ls)) { - stop(cond_assign_labels_dataframe_dots()) - } - .missing <- match_param(.missing) - if (is.null(.ls) || any(vap_lgl(.ls, is.null))) { - stop(cond_assign_labels_dataframe_names()) + # fmt: skip + if ( + identical(.ls, list()) || + (...length() && !identical(rlang::list2(...), .ls)) || + is.null(.ls) || + any(vap_lgl(.ls, is.null)) + ) { + stop(assign_labels_error("dots", dots = rlang::list2(...), ls = .ls)) } - if (inherits(.ls[[1]], "data.frame")) { - lsx <- as.vector(.ls[[1]][[2]], "list") - names(lsx) <- .ls[[1]][[1]] - .ls <- lsx + if (inherits(.ls[[1L]], "data.frame")) { + .ls <- struct( + as.vector(.ls[[1L]][[2L]], "list"), + class = "list", + names = .ls[[1L]][[1L]] + ) } nm <- names(.ls) @@ -85,18 +88,18 @@ assign_labels.data.frame <- function( if (anyNA(ma)) { nas <- is.na(ma) - text <- paste0("Columns not found: ", collapse0(nm[nas], sep = ", ")) - if (.missing == "error") { - stop(cond_assign_labels_dataframe_missing(text, "error")) - } - - if (.missing == "warn") { - warning(cond_assign_labels_dataframe_missing(text, "warning")) - } - - nm <- nm[!nas] - ma <- ma[!nas] + switch( + .missing, + error = stop, + warn = warning, + skip = function(cond) NULL + )( + assign_labels_error("columns", cols = nm[nas]) + ) + + nm <- nm[!nas] + ma <- ma[!nas] .ls <- .ls[!nas] } @@ -135,14 +138,20 @@ view_labels <- function(x, title) { title <- paste0(cesx, " - Labels") } - pf <- parent.frame() - view_fun <- get0("View", envir = pf, ifnotfound = "utils" %colons% "View") - - if (!is.function(view_fun)) { - stop(cond_view_labels_something(cesx, title)) + if (!interactive()) { + view <- function(x, title) print(x) + } else if ("tools:rstudio" %in% search()) { + view <- get("View", as.environment("tools:rstudio")) + } else { + view <- utils::View } - view_fun(x = get_labels(x), title = title) + tryCatch( + view(x = get_labels(x), title = title), + error = function(cond) { + stop(view_labels_error()) + } + ) } #' @export @@ -164,15 +173,15 @@ remove_labels.data.frame <- function(x, cols, ...) { if (missing(cols)) { cols <- seq_along(x) } else { - bad <- cols %out% colnames(x) + bad <- cols %wo% colnames(x) - if (any(bad)) { - stop(cond_remove_labels_dataframe_bad(cols[bad])) + if (length(bad)) { + stop(assign_labels_error(bad)) } } for (i in cols) { - x[[i]] <- remove_labels(x[[i]]) + x[[i]] <- remove_labels(x[, i]) } x @@ -180,45 +189,73 @@ remove_labels.data.frame <- function(x, cols, ...) { # conditions -------------------------------------------------------------- -cond_assign_labels_dataframe_dots <- function() { # nolint: object_length_linter, line_length_linter. - new_condition( - "... was set separately from `.ls`. Only set one", - "assign_labels_dataframe_dots" +assign_labels_error := condition( + function(s, ..., cols, dots, ls) { + switch( + s, + columns = sprintf( + ngettext( + length(cols), + "Columns not found: %s", + "Column not found: %s" + ), + toString(cols) + ), + dots = if (identical(dots, ls)) { + sprintf("labels provided are malformed: %s", toString(dots)) + } else { + sprintf( + "`.ls` and `...` were both set and/or malformed\n ... %s\n .ls %s", + toString(dots), + toString(ls) + ) + }, + stop(internal_error()) + ) + }, + type = "error", + exports = c("assign_labels", "remove_labels"), + classes = "value_error", # NOTE maybe assign_error()? + # nolint start: line_length_linter. + help = r"( +`assign_labels_error` + +**Columns not found** +You can set `.missing` to `warn` to get a warning instead of an error, or `skip` to silently skip those labels. + +**Malformed labels** +If passing labels as `.ls`, `...` must be empty. Columns in `...` must be entered as `name = value`; `column = label`. + +```r +# instead of this: +assign_labels(df, a = 'AAA', .ls = list(b = 'BBB')) + +# do this: +assign_labels(df, a = 'AAA', b = 'BBB') +# or this: +assign_labels(df, .ls = list(a = 'AAA', b = 'BBB')) +``` +Labels must not be null; to remove labels, use `remove_labels()`. + +```r +# instead of this +assign_labels(df, a = 'AAA', b = NULL) + +# do this +df <- assign_labels(df, a = 'AAA') +df <- remove_labels(df, 'b') +```)" +) +# nolint end: line_length_linter. + +view_labels_error := condition( + "Cannot use `View()`", + type = "error", + exports = "view_labels", + help = c( + "This may be because you are using RStudio :", + " https://community.rstudio.com/t/view-is-causing-an-error/75297/4 ", + "You can try :", + ' `utils::View(get_labels(x), title = "Labels")`' ) -} - -cond_assign_labels_dataframe_names <- function() { # nolint: object_length_linter, line_length_linter. - new_condition("... must not have NULLs", "assign_labels_dataframe_names") -} - -cond_assign_labels_dataframe_missing <- function( # nolint: object_length_linter, line_length_linter. - x, - type = c("error", "warning") -) { - type <- match_param(type) - new_condition( - x, - "assign_labels_dataframe_missing", - type = type - ) -} - -cond_view_labels_something <- function(x, title) { - new_condition( - paste0( - "Something went wrong trying to use `View()`", - "\nThis may be because you are using Rstudio :", - "\n https://community.rstudio.com/t/view-is-causing-an-error/75297/4", - "\nYou can try :\n ", - sprintf('`View(get_labels(%s), title = "%s")`', x, title) - ), - "view_labels_something" - ) -} - -cond_remove_labels_dataframe_bad <- function(x) { # nolint: object_length_linter, line_length_linter. - new_condition( - paste0("Column not found in data.frame:\n ", toString(x)), - "remove_labels_dataframe_bad" - ) -} +) diff --git a/R/limit.R b/R/limit.R index ea765e51..4a6ad97f 100644 --- a/R/limit.R +++ b/R/limit.R @@ -11,13 +11,15 @@ #' #' @export limit <- function(x, lower = min(x), upper = max(x)) { - stopifnot( - length(lower) == 1L, - length(upper) == 1L, - is.numeric(lower), - is.numeric(upper), - lower <= upper - ) + if (!(is.numeric(lower) && is.numeric(upper))) { + stop(class_error("must_be", c(lower, upper), "numeric")) + } + + if (!(length(lower) == 1L && length(upper) == 1L && lower <= upper)) { + stop(input_error( + "`lower` and `upper` must be single numeric values with `lower <= upper`" + )) + } x[x < lower] <- lower x[x > upper] <- upper diff --git a/R/lines-of-code.R b/R/lines-of-code.R index 349553a5..7241f2ad 100644 --- a/R/lines-of-code.R +++ b/R/lines-of-code.R @@ -1,13 +1,12 @@ -#' Lines of R code +#' Lines of **R** code #' -#' Find the total number of lines of R code +#' Find the total number of lines of **R** code #' -#' @details -#' Tries to read each file in the directory that ends in .R or .r and sums -#' together. Files that fail to read are not counted. +#' @details Tries to read each file in the directory that ends in `.R` or `.r` +#' and sums together. Files that fail to read are not counted. #' #' @param x Directory to search for files -#' @param skip_empty Logical, if TRUE will not count lines that are empty or +#' @param skip_empty Logical, if `TRUE` will not count lines that are empty or #' only contain a bracket or quotation mark. #' #' @returns An `integer` for the number of lines in all applicable files @@ -18,7 +17,6 @@ #' lines_of_r_code(system.file()) #' lines_of_r_code(system.file(), skip_empty = FALSE) #' } - lines_of_r_code <- function(x = ".", skip_empty = TRUE) { if (dir.exists(x)) { x <- list_r_files(x) diff --git a/R/logic.R b/R/logic.R index 2eb3c400..f883ad36 100644 --- a/R/logic.R +++ b/R/logic.R @@ -2,19 +2,19 @@ #' #' Logical operations, extended #' -#' @description All functions take logical or logical-like (i.e., 1, 0, or NA as -#' integer or doubles) and return logical values. +#' @description All functions take logical or logical-like (i.e., `1`, `0`, or +#' `NA` as integer or doubles) and return logical values. #' -#' Extensions to the base logical operations to account for `NA` values. +#' Extensions to the base logical operations to account for `NA` values. #' -#' [base::isTRUE()] and [base::isFALSE()] will only return single length `TRUE` -#' or `FALSE` as it checks for valid lengths in the evaluation. When needing to -#' check over a vector for the presence of `TRUE` or `FALSE` and not being held -#' back by `NA` values, `is_true` and `is_false` will always provide a `TRUE` -#' `FALSE` when the vector is logical or return `NA` is the vector `x` is not -#' logical. +#' [base::isTRUE()] and [base::isFALSE()] will only return single length +#' `TRUE` or `FALSE` as it checks for valid lengths in the evaluation. When +#' needing to check over a vector for the presence of `TRUE` or `FALSE` and +#' not being held back by `NA` values, [mark::is_true()] and +#' [mark::is_false()] will always provide a `TRUE` `FALSE` when the vector is +#' logical or return `NA` is the vector `x` is not logical. #' -#' `%xor%` is just a wrapper for [base::xor()] +#' [mark::%xor%] is just a wrapper for [base::xor()] #' #' @param x,y A vector of values. `%xor`, `nor`, `nand`, and `xnandr` #' @param ... Vectors or a list of logical values @@ -46,10 +46,11 @@ #' is_boolean(c(1L, NA_integer_, 0L)) #' is_boolean(c(1.01, 0, -1)) #' @return -#' * `is_true()`, `is_false()`, `either()`, `%or%`, `nor`, `nand`, `xandr`, -#' `AND()`, `OR()`: A `logical` vector, equal length of `x` (or `y` or of all -#' `...` lengths) -#' * `is_boolean()`, `isNA()`, `none()`: A single `logical` value +#' - [mark::is_true()], [mark::is_false()], [mark::either()], [mark::%xor%], +#' [mark::AND()], [mark::OR()]: A `logical` vector, equal length of `x` (or `y` +#' or of all `...` lengths) +#' - [mark::is_boolean()]: `TRUE` or `FALSE` +#' - [mark::none()]: `TRUE`, `FALSE`, or `NA` #' #' @name logic_ext NULL @@ -163,9 +164,17 @@ isNA <- function(x) { # FUNS -------------------------------------------------------------------- +check_null <- function(x) { + if (no_length(x)) { + stop(input_error("`x` cannot be `NULL` or 0 length values")) + } +} + # nolint next: object_name_linter. apply_logical_matrix <- function(mat, FUN, na.rm) { - stopifnot(is.matrix(mat), is_boolean(mat)) + if (!(is.matrix(mat) && is_boolean(mat))) { + stop(input_error("`...` must be logical or logical-like matrix")) + } na_val <- if (na.rm) { switch(FUN, `|` = FALSE, `&` = TRUE) diff --git a/R/map.R b/R/map.R index 98331142..511b0ec0 100644 --- a/R/map.R +++ b/R/map.R @@ -1,3 +1,5 @@ +# TODO just remove this; no longer needed + #' mapply with NULLs #' #' mapply (basically) but with NULLs @@ -17,19 +19,21 @@ #' x <- list(a = 1:2, b = NULL, c = 3) #' mark:::mapply0(foo, x) #' @noRd -mapply0 <- function(FUN, params = NULL, ...) { # nolint: object_name_linter. - params <- c(params, rlang::list2(...)) +# nolint next: object_name_linter. +mapply0 <- function(FUN, params = NULL, ...) { + params <- c(params, rlang::list2(...)) FUN <- match.fun(FUN) # nolint: object_name_linter. n <- max(lengths(params)) p_list <- lapply( params, - function(x) { + function(x) { lx <- as.list(x) names(lx) <- x rep_len(lx, n) - }) + } + ) result <- rep_len(list(), n) diff --git a/R/mark-cnd-conditions.R b/R/mark-cnd-conditions.R new file mode 100644 index 00000000..a0fe0d7c --- /dev/null +++ b/R/mark-cnd-conditions.R @@ -0,0 +1,271 @@ +# % Generated by cnd: do not edit by hand + +#' @name mark-cnd-conditions +#' @aliases mark-cnd-conditions mark:append_warning mark:assign_labels_error mark:base_conversion_error mark:description_version_error mark:fct_expand_seq_error mark:import_error mark:internal_error mark:list2df_warning mark:match_arg_error mark:match_param_error mark:md5_condition mark:na_timezone_found_warning mark:not_available_error mark:numeric_datetime_tz_error mark:options_error mark:path_error mark:path_warning mark:reindex_error mark:reindex_warning mark:source_error mark:switch_error mark:timezone_not_found_error mark:view_labels_error append_warning assign_labels_error base_conversion_error description_version_error fct_expand_seq_error import_error internal_error list2df_warning match_arg_error match_param_error md5_condition na_timezone_found_warning not_available_error numeric_datetime_tz_error options_error path_error path_warning reindex_error reindex_warning source_error switch_error timezone_not_found_error view_labels_error mark:append_warning/warning mark:assign_labels_error/error mark:base_conversion_error/error mark:description_version_error/error mark:fct_expand_seq_error/error mark:import_error/error mark:internal_error/error mark:list2df_warning/warning mark:match_arg_error/error mark:match_param_error/error mark:md5_condition/condition mark:na_timezone_found_warning/warning mark:not_available_error/error mark:numeric_datetime_tz_error/error mark:options_error/error mark:path_error/error mark:path_warning/warning mark:reindex_error/error mark:reindex_warning/warning mark:source_error/error mark:switch_error/condition mark:timezone_not_found_error/error mark:view_labels_error/error +#' @title Conditions for `mark` +#' +#' @details +#' The following conditions are defined in the `{mark}` package. +#' +#' @section `{cnd}`: +#' These conditions are made with the [`{cnd}`][cnd-package] package though the +#' use of [cnd::condition()]. +#' +#' @section `{mark}` conditions: +#' +#' \subsection{`mark:append_warning/warning`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:append_warning`} +#' \item{type}{**warning**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:assign_labels_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:assign_labels_error`} +#' \item{type}{**error**} +#' } +#' `assign_labels_error` +#' +#' **Columns not found** +#' You can set `.missing` to `warn` to get a warning instead of an error, or `skip` to silently skip those labels. +#' +#' **Malformed labels** +#' If passing labels as `.ls`, `...` must be empty. Columns in `...` must be entered as `name = value`; `column = label`. +#' +#' ```r +#' # instead of this: +#' assign_labels(df, a = 'AAA', .ls = list(b = 'BBB')) +#' +#' # do this: +#' assign_labels(df, a = 'AAA', b = 'BBB') +#' # or this: +#' assign_labels(df, .ls = list(a = 'AAA', b = 'BBB')) +#' ``` +#' Labels must not be null; to remove labels, use `remove_labels()`. +#' +#' ```r +#' # instead of this +#' assign_labels(df, a = 'AAA', b = NULL) +#' +#' # do this +#' df <- assign_labels(df, a = 'AAA') +#' df <- remove_labels(df, 'b') +#' ``` +#' } +#' \subsection{`mark:base_conversion_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:base_conversion_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:description_version_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:description_version_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:fct_expand_seq_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:fct_expand_seq_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:import_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:import_error`} +#' \item{type}{**error**} +#' } +#' The object you are trying to import has already been assigned in the environment you are importing to. Use the `overwrite` option to replace the object. +#' +#' For example: +#' +#' ```r +#' # instead of +#' foo <- NULL +#' import('package', 'foo') +#' +#' # do this +#' foo <- NULL +#' import('package', 'foo', overwrite = TRUE) +#' ``` +#' } +#' \subsection{`mark:internal_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:internal_error`} +#' \item{type}{**error**} +#' } +#' Generic error to capture internal `{mark}` errors. If any of these are encountered, please report an issue at +#' } +#' \subsection{`mark:list2df_warning/warning`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:list2df_warning`} +#' \item{type}{**warning**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:match_arg_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:match_arg_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:match_param_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:match_param_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:md5_condition/condition`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:md5_condition`} +#' \item{type}{**condition**} +#' } +#' Produces messages on md5 checks when `file_copy_md5(quiet = FALSE)`. +#' The message will indicate whether the file was new, or if the md5 hash was the same or different. +#' When `quiet = TRUE`, no messages will be produced. +#' } +#' \subsection{`mark:na_timezone_found_warning/warning`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:na_timezone_found_warning`} +#' \item{type}{**warning**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:not_available_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:not_available_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:numeric_datetime_tz_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:numeric_datetime_tz_error`} +#' \item{type}{**error**} +#' } +#' ```r +#' # Instead of this: +#' diff_time(100, 200, tz = NULL) +#' +#' # do this: +#' diff_time(100, 200, tz = 'America/New_York') +#' +#' # or: +#' diff_time(100, 200, tz = 0) +#' ``` +#' } +#' \subsection{`mark:options_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:options_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:path_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:path_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:path_warning/warning`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:path_warning`} +#' \item{type}{**warning**} +#' } +#' File creation cannot be performed when the path is an existing directory +#' } +#' \subsection{`mark:reindex_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:reindex_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:reindex_warning/warning`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:reindex_warning`} +#' \item{type}{**warning**} +#' } +#' NA values in index may cause errors with expansion +#' +#' `reindex()` will not match on NA values but instead will return a row of NAs +#' +#' ```r +#' x <- data.frame(index = c(1:2, NA, 4:5), values = letters[1:5]) +#' reindex(x, 'index', c(1, 2, 5)) +#' #> index values +#' #> 1 1 a +#' #> 2 2 b +#' #> 5 5 e +#' +#' reindex(x, 'index', c(1, 2, 5, NA)) +#' #> index values +#' #> 1 1 a +#' #> 2 2 b +#' #> 5 5 e +#' #> NA +#' ``` +#' } +#' \subsection{`mark:source_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:source_error`} +#' \item{type}{**error**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:switch_error/condition`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:switch_error`} +#' \item{type}{**condition**} +#' } +#' _no help documentation provided_ +#' } +#' \subsection{`mark:timezone_not_found_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:timezone_not_found_error`} +#' \item{type}{**error**} +#' } +#' When using a string for a timezone, this value must be found within `OlsonNames()` +#' } +#' \subsection{`mark:view_labels_error/error`}{ +#' \describe{ +#' \item{package}{`{mark}`} +#' \item{class}{`mark:view_labels_error`} +#' \item{type}{**error**} +#' } +#' This may be because you are using RStudio : https://community.rstudio.com/t/view-is-causing-an-error/75297/4 You can try : `utils::View(get_labels(x), title = "Labels")` +#' } +#' +#' @seealso [cnd::cnd-package] [cnd::condition] +#' @keywords internal +#' +NULL diff --git a/R/mark-package.R b/R/mark-package.R index 506e2dc3..6ba74655 100644 --- a/R/mark-package.R +++ b/R/mark-package.R @@ -5,6 +5,7 @@ #' Miscellaneous, Analytic R Kernels #' #' @import fuj +#' @import cnd #' @docType package #' @name mark "_PACKAGE" @@ -38,9 +39,5 @@ op.mark <- list( ) .onLoad <- function(libname, pkgname) { - options(op.mark[!names(op.mark) %in% names(options())]) -} - -.onDetach <- function(libpath) { - invisible() + options(op.mark[!names(op.mark) %in% names(options())]) # nocov } diff --git a/R/match-arg.R b/R/match-arg.R index 00a3cafb..878d5837 100644 --- a/R/match-arg.R +++ b/R/match-arg.R @@ -11,16 +11,16 @@ #' @param table A table of choices #' @return A single value from `x` matched on `table` #' -#' @seealso [match_param()] +#' @seealso [mark::match_param()] #' @examples #' x <- c("apple", "banana", "orange") -#' match_arg("b", x) +#' suppressWarnings(match_arg("b", x), "deprecatedWarning") #' #' # Produces error -#' try(match_arg("pear", x)) +#' suppressWarnings(try(match_arg("pear", x)), "deprecatedWarning") #' #' foo <- function(x, op = c(1, 2, 3)) { -#' op <- match_arg(op) +#' op <- suppressWarnings(match_arg(op), "deprecatedWarning") #' x / op #' } #' @@ -30,6 +30,12 @@ #' try(foo(1, 0)) #' @export match_arg <- function(x, table) { + warning(deprecated_warning( + deprecated = "mark::match_arg()", + replacement = "mark::match_param()", + version = "0.10.0" + )) + if (is.null(x)) { return(NULL) } @@ -44,7 +50,7 @@ match_arg <- function(x, table) { if (!length(out)) { csx <- as.character(substitute(x)) - stop(cond_match_arg(csx, x, table)) + stop(match_arg_error(csx, x, table)) } out @@ -64,12 +70,15 @@ match_arg <- function(x, table) { #' of formula objects (preferred) retains the LHS of the formula as the return #' value when matched to the RHS of the formula. #' @param null If `TRUE` allows `NULL` to be passed a `param` -#' @param partial If `TRUE` allows partial matching via [pmatch()] +#' @param partial If `TRUE` allows partial matching via [base::pmatch()] #' @param multiple If `TRUE` allows multiple values to be returned #' @param simplify If `TRUE` will simplify the output to a single value #' @return A single value from `param` matched on `choices` #' -#' @seealso [match_arg()] +#' @section Conditions: +#' `r cnd::cnd_section("match_param")` +#' +#' @seealso [mark::match_arg()] #' @examples #' fruits <- function(x = c("apple", "banana", "orange")) { #' match_param(x) @@ -105,12 +114,12 @@ match_arg <- function(x, table) { #' sapply(0:5, match_param, choices = ls) #' @export match_param <- function( - param, - choices, - null = TRUE, - partial = getOption("mark.match_param.partial", FALSE), - multiple = FALSE, - simplify = TRUE + param, + choices, + null = TRUE, + partial = getOption("mark.match_param.partial", FALSE), + multiple = FALSE, + simplify = TRUE ) { param_c <- charexpr(substitute(param)) force(param) @@ -120,7 +129,7 @@ match_param <- function( return(NULL) } - stop(cond_match_param_null()) + stop(input_error("match_param() requires non-NULL params")) } missing_choices <- missing(choices) @@ -134,8 +143,7 @@ match_param <- function( mchoices <- cleanup_param_list(choices) if (anyDuplicated(unlist(mchoices$choices))) { - # TODO implement cond_match_param_dupes() - stop(cond_match_param_dupes(choices)) + stop(duplicate_error(x = choices)) } fun <- if (partial) pmatch else match @@ -151,7 +159,7 @@ match_param <- function( param <- deparse(param) } - stop(cond_match_param_match( + stop(match_param_error( input = param_c, argument = ocall, param = param, @@ -195,110 +203,72 @@ cleanup_param_list <- function(x) { # conditions -------------------------------------------------------------- -cond_match_arg <- function(csx, x, table) { - table <- collapse(table, sep = "\', \'") - new_condition( +# TODO remove +match_arg_error := condition( + message = function(csx, x, table) { sprintf( "%s : '%s' did not match of of the following:\n '%s'", - csx, x, table - ), - "cond_match_arg" - ) -} - -cond_match_param_null <- function() { - new_condition( - "match_param() requires non-NULL params", - "cond_match_param_null" - ) -} - -cond_match_param_match <- function( - input, - argument, - param, - choices -) { - to_value <- function(x) { - if (all(names(x) == as.character(x))) { - return(toString(x)) - } - - nms <- names(x) - if (is.null(nms)) { - return(toString(x)) - } - - ok <- nzchar(nms) - nms[ok] <- paste(nms[ok], "= ") - toString(paste0(nms, x)) - } - - to_options <- function(x) { - if (all(names(x) == as.character(x))) { - return(toString(x)) + csx, + x, + table + ) + }, + type = "error", + classes = "input_error" +) + +match_param_error := condition( + message = function(input, argument, param, choices) { + to_value <- function(x) { + if (all(names(x) == as.character(x))) { + return(toString(x)) + } + + nms <- names(x) + if (is.null(nms)) { + return(toString(x)) + } + + ok <- nzchar(nms) + nms[ok] <- paste(nms[ok], "= ") + toString(paste0(nms, x)) } - collapse(mapply( - function(x, nm) { - if (nzchar(nm)) { - sprintf("%s = %s", nm, toString(x)) - } else { - toString(x) - } - }, - x = x, - nm = names(x), - USE.NAMES = FALSE - ), sep = " | ") - } - - msg <- sprintf( - paste0( - "`match_param(%s)` failed in `%s`:\n", - " param %s\n", - " choices %s" - ), - input, - argument, - to_value(param), - to_options(choices) - ) - - new_condition(msg, "match_param_match") -} - -cond_match_param_dupes <- function(choices) { - to_choices <- function(x) { - if (all(names(x) == as.character(x))) { - dupe <- duplicated(x) - x[dupe] <- paste0(x[dupe], "*") - return(toString(x)) + to_options <- function(x) { + if (all(names(x) == as.character(x))) { + return(toString(x)) + } + + collapse( + mapply( + function(x, nm) { + if (nzchar(nm)) { + sprintf("%s = %s", nm, toString(x)) + } else { + toString(x) + } + }, + x = x, + nm = names(x), + USE.NAMES = FALSE + ), + sep = " | " + ) } - collapse(mapply( - function(x, nm, d) { - sprintf( - "%s = %s", - nm, - toString(paste0(x, ifelse(d, "*", ""))) - ) - }, - x = x, - nm = names(x), - d = split( - duplicated(unlist(x)), - rep(seq_along(x), lengths(x)) + sprintf( + paste0( + "`match_param(%s)` failed in `%s`:\n", + " param %s\n", + " choices %s" ), - USE.NAMES = FALSE - ), sep = "\n ") - } - - new_condition( - msg = paste0( - "duplicate values found in `choices`:\n ", - to_choices(choices) - ), - class = "match_param_dupes" - ) -} + input, + argument, + to_value(param), + to_options(choices) + ) + }, + type = "error", + classes = "input_error", + exports = "match_param" +) diff --git a/R/merge-list.R b/R/merge-list.R index 94572194..cc824ba8 100644 --- a/R/merge-list.R +++ b/R/merge-list.R @@ -15,6 +15,8 @@ #' output. #' * `"keep"`: `NULL` values are retained in the output and can override other #' values. +#' @param sort When `TRUE` (default) will sort the output by names; otherwise +#' will retain the order of `x` and `y` with `x` values first. #' @examples #' x <- list(a = 1, b = 2, c = NULL, d = NULL) #' y <- list(a = 2, b = NULL, c = 3) @@ -28,44 +30,60 @@ #' merge_list(x, y, null = "drop") #' @export merge_list <- function( - x, - y, - keep = c("x", "y"), - null = c("ignore", "drop", "keep")[1:2] + x, + y, + keep = c("x", "y"), + null = c("ignore", "drop", "keep")[1:2], + sort = TRUE ) { - if (length(null) == 1L) { - null <- c(null, null) - } + switch( + length(null), + null <- c(null, null), + null + ) %||% + stop(input_error("`length(null)` must be 1L or 2L")) - stopifnot(length(null) == 2) keep <- match_param(keep) x <- x %||% list() y <- y %||% list() + + # TODO report `x` vs `y` + if (!is.list(x) || !is.list(y)) { + stop(class_error("must_be", x = if (!is.list(x)) x else y, "list")) + } + xx <- x - stopifnot(is.list(x), is.list(y)) + x <- switch( - null[1], + null[1L], keep = x, ignore = remove_null(x), - drop = remove_null(x) + drop = remove_null(x), + stop(internal_error()) # nocov ) y <- switch( - null[2], + null[2L], keep = y, ignore = remove_null(y), - drop = remove_null(y) + drop = remove_null(y), + stop(internal_error()) # nocov ) res <- c(x, y)[!duplicated(c(names(x), names(y)), fromLast = keep == "y")] - if (null[1] == "ignore") { + if (null[1L] == "ignore") { return(merge_list( x = xx[names(xx) %out% names(res)], y = res, - null = c("keep", "ignore") + null = c("keep", "ignore"), + sort = sort )) } - res[order(names(res))] + if (sort) { + res <- res[order(names(res))] + } + + res } diff --git a/R/na-assignment.R b/R/na-assignment.R index 2a1fc324..3bbbcf44 100644 --- a/R/na-assignment.R +++ b/R/na-assignment.R @@ -33,7 +33,8 @@ NULL #' @rdname na_assignments #' @export -NA_at <- function(x, y, ...) { # nolint: object_name_linter. +# nolint next: object_name_linter. +NA_at <- function(x, y, ...) { nx <- length(x) if (nx == 0L) { @@ -41,20 +42,19 @@ NA_at <- function(x, y, ...) { # nolint: object_name_linter. } if (is.function(y)) { - FUN <- match.fun(y) # nolint: object_name_linter. - y <- FUN(x, ...) + y <- y(x, ...) } - if (any(y %% 1 > 0, na.rm = TRUE)) { - stop(cond_na_at_integer()) + if (any(y %% 1L > 0, na.rm = TRUE)) { + stop(value_error("`y` must be a vector of integers")) } if (!isTRUE(max(y, na.rm = TRUE) <= nx)) { - stop(cond_na_at_max()) + stop(value_error("`max(y)` cannot be greater than `length(x)`")) } if (!isTRUE(length(y) <= nx)) { - stop(cond_na_at_length()) + stop(value_error("`length(y)` cannot be greater than `length(x)`")) } x[y] <- NA @@ -63,7 +63,8 @@ NA_at <- function(x, y, ...) { # nolint: object_name_linter. #' @rdname na_assignments #' @export -NA_if <- function(x, y, ...) { # nolint: object_name_linter. +# nolint next: object_name_linter. +NA_if <- function(x, y, ...) { nx <- length(x) if (nx == 0L) { @@ -71,16 +72,16 @@ NA_if <- function(x, y, ...) { # nolint: object_name_linter. } if (is.function(y)) { - FUN <- match.fun(y) # nolint: object_name_linter. - y <- FUN(x, ...) + y <- y(x, ...) } + # FIXME replace with a single condition if (length(y) != nx) { - stop(cond_na_if_length()) + stop(value_error("`length(y)` cannot be greater than `length(x)`")) } if (!is.logical(y)) { - stop(cond_na_if_logical()) + stop(value_error("`y` must be logical")) } x[y] <- NA @@ -89,14 +90,14 @@ NA_if <- function(x, y, ...) { # nolint: object_name_linter. #' @rdname na_assignments #' @export -NA_in <- function(x, y, ...) { # nolint: object_name_linter. +# nolint next: object_name_linter. +NA_in <- function(x, y, ...) { if (length(x) == 0L) { return(x) } if (is.function(y)) { - FUN <- match.fun(y) # nolint: object_name_linter. - y <- FUN(x, ...) + y <- y(x, ...) } x[x %in% y] <- NA @@ -105,44 +106,16 @@ NA_in <- function(x, y, ...) { # nolint: object_name_linter. #' @rdname na_assignments #' @export -NA_out <- function(x, y, ...) { # nolint: object_name_linter. +# nolint next: object_name_linter. +NA_out <- function(x, y, ...) { if (length(x) == 0L) { return(x) } if (is.function(y)) { - FUN <- match.fun(y) # nolint: object_name_linter. - y <- FUN(x, ...) + y <- y(x, ...) } x[x %out% y] <- NA x } - - -# conditions -------------------------------------------------------------- - -cond_na_at_integer <- function() { - new_condition("y must be a vector of integers", "na_at_integer") -} - -cond_na_at_max <- function() { - new_condition("values of y must not be greater than length of x", "na_at_max") -} - -cond_na_at_length <- function() { - new_condition( - "length of y must not be greater than length of x", - "na_at_length" - ) -} - -cond_na_if_length <- function() { - new_condition("y must be the same length as x", "na_if_length") -} - -cond_na_if_logical <- function() { - new_condition("y must be logical", "na_if_logical") -} - -# terminal line diff --git a/R/names.R b/R/names.R index d6c7503b..7394d5b5 100644 --- a/R/names.R +++ b/R/names.R @@ -1,4 +1,3 @@ - is_named <- function(x) { !is.null(names(x)) } diff --git a/R/nas.R b/R/nas.R index 2b2223c3..b4562c72 100644 --- a/R/nas.R +++ b/R/nas.R @@ -92,7 +92,9 @@ omit_na <- function(x) { #' remove_null(x) #' @export remove_null <- function(x) { - stopifnot(inherits(x, "list")) + if (!inherits(x, "list")) { + stop(type_error("must_be", x, "list")) + } x[!vap_lgl(x, is.null)] } @@ -127,7 +129,9 @@ remove_na_cols <- function(x) { #' @rdname na_cols #' @export is_na_cols <- function(x, names = TRUE) { - stopifnot(is.data.frame(x)) + if (!is.data.frame(x)) { + stop(class_error("must_be", x, "data.frame")) + } vap_lgl(x, function(xx) all(is.na(xx)), .nm = names) } @@ -153,7 +157,8 @@ is_na_cols <- function(x, names = TRUE) { #' tableNA(x[1], x[2]) #' tableNA(x[1], x[2], x[3]) # equivalent ot tableNA(x, .list = TRUE) -tableNA <- function(..., .list = FALSE) { # nolint: object_name_linter +# nolint next: object_name_linter. +tableNA <- function(..., .list = FALSE) { ls <- if (.list) { as.list(...) } else { diff --git a/R/normalize.R b/R/normalize.R index c7ce0a05..b82cba96 100644 --- a/R/normalize.R +++ b/R/normalize.R @@ -7,9 +7,9 @@ #' minimum/maximum values and lower/upper bounds. This allows for a vector of #' more than two values to be passed. #' -#' The current implementation of `normalize.data.frame()` allows for `list` of -#' parameters passed for each column. However, it is probably best suited for -#' default values. +#' The current implementation of [mark::normalize.data.frame()] allows for +#' `list` of parameters passed for each column. However, it is probably best +#' suited for default values. #' #' @param x An object that is (coercible to) `double`; `data.frames` are #' transformed @@ -45,28 +45,32 @@ normalize <- function(x, ...) { #' @rdname normalize #' @export normalize.default <- function( - x, - range = base::range(x, na.rm = TRUE), - bounds = 0:1, - ... + x, + range = base::range(x, na.rm = TRUE), + bounds = 0:1, + ... ) { x[] <- as.double(x) range <- wuffle(base::range(range, na.rm = TRUE)) bounds <- wuffle(base::range(bounds, na.rm = TRUE)) - min <- range[1] - max <- range[2] - lower <- bounds[1] - upper <- bounds[2] + min <- range[1L] + max <- range[2L] + lower <- bounds[1L] + upper <- bounds[2L] - # these probably won't trigger unless there's a weird range method + # fmt: skip # nocov start - stopifnot( - length(range) == 2, - length(bounds) == 2, - min <= max, + # these probably won't trigger unless there's a weird range method + if (!( + length(range) == 2L && + length(bounds) == 2L && + min <= max && lower <= upper - ) + )) { + stop(value_error("invalid `range` or `bounds` supplied")) + } + # nocov end x[] <- lower + (x - min) * (upper - lower) / (max - min) diff --git a/R/not-available.R b/R/not-available.R index cad8945c..d58b6d55 100644 --- a/R/not-available.R +++ b/R/not-available.R @@ -40,25 +40,25 @@ get_not_available <- function(type = NULL) { out <- get_na_list()[[type]] if (is.null(out)) { - stop(cond_get_not_available(type)) + stop(not_available_error(type)) } if (is.function(out) || is.call(out)) { - stop(cond_get_not_available_type()) + stop(class_error(sprintf( + "Type '%s' cannot be set to class 'function' or 'call'", + type + ))) } out } get_na_list <- function() { - ls <- getOption("mark.na_list", list()) - - if (identical(ls, list())) { - options(mark.na_list = na_list) - ls <- na_list - } - - ls + merge_list( + op.mark$mark.na_list, + getOption("mark.na_list"), + sort = FALSE + ) } #' @export @@ -79,19 +79,16 @@ delayedAssign("NA_POSIXlt_", not_available("logical", 1L)) # conditions -------------------------------------------------------------- -cond_get_not_available <- function(x) { - msg <- sprintf( - paste0( - "\"%s\" not found\n", - "Can be set with `mark::set_not_available(%s, value = .)`" - ), - x, - x - ) - - new_condition(msg, "get_not_available") -} - -cond_get_not_available_type <- function() { - new_condition("type is not valid", "get_not_available_type") -} +not_available_error := condition( + function(x) { + sprintf( + paste0( + "\"%1$s\" not found\n", + "Can be set with `mark::set_not_available(%1$s, value = .)`" + ), + x + ) + }, + type = "error", + classes = "value_error" +) diff --git a/R/note.R b/R/note.R index b5db7cd3..5aab0bab 100644 --- a/R/note.R +++ b/R/note.R @@ -82,12 +82,14 @@ print.note <- function(x, ...) { } print_note <- function(x, ...) { - stopifnot(inherits(x, "noted")) + if (!inherits(x, "noted")) { + stop(class_error("must_be", x, "noted")) + } the_note <- note(x) if (!inherits(the_note, "note")) { - stop(cond_print_note_note()) + stop(class_error("must_be", the_note, "note", "x")) } if (!check_interactive()) { @@ -106,9 +108,3 @@ print.noted <- function(x, ...) { print(set_note(x, NULL), ...) invisible(x) } - -# conditions -------------------------------------------------------------- - -cond_print_note_note <- function() { - new_condition("note(x) must be class note", "print_note_noted") -} diff --git a/R/options.R b/R/options.R index 3f694972..ce6c9517 100644 --- a/R/options.R +++ b/R/options.R @@ -19,12 +19,15 @@ #' #' options(op) #' @export -checkOptions <- function(x) { # nolint: object_name_linter. - stopifnot(is.list(x)) +# nolint next: object_name_linter. +checkOptions <- function(x) { + if (!is.list(x)) { + stop(type_error("must_be", x, "list")) + } nm <- names(x) if (is.null(nm) || any(nm == "")) { - stop(cond_check_options_names()) + stop(input_error("all values of `x` must be named")) } msg <- NULL @@ -41,12 +44,15 @@ checkOptions <- function(x) { # nolint: object_name_linter. msg <- "Option(s) updated :" } - msg <- c(msg, sprintf( - '\n "%s"\n old : %s\n new : %s', - nm[i], - go, - x[[i]] - )) + msg <- c( + msg, + sprintf( + '\n "%s"\n old : %s\n new : %s', + nm[i], + go, + x[[i]] + ) + ) } } @@ -56,11 +62,3 @@ checkOptions <- function(x) { # nolint: object_name_linter. invisible(op) } - -# conditions -------------------------------------------------------------- - -cond_check_options_names <- function() { - new_condition("All options must be named", "check_options_names") -} - -# terminal line diff --git a/R/paste.R b/R/paste.R index 084f6e05..0f8f8b00 100644 --- a/R/paste.R +++ b/R/paste.R @@ -35,7 +35,7 @@ paste_combine <- function(..., collate = TRUE, sep = "") { n <- length(ls) if (n < 2) { - stop(cond_paste_combine_length()) + stop(input_error("length(...) must be at least 2L")) } out <- do_paste_combine(ls[[1]], ls[[2]], collate = collate, sep = sep) @@ -78,9 +78,3 @@ do_paste_combine <- function(x, y, collate = TRUE, sep = "") { dim(out) <- c(xn, yn) as.vector(apply(out, 1, c), "character") } - -# conditions -------------------------------------------------------------- - -cond_paste_combine_length <- function() { - new_condition("length of ... must be at least 2", "paste_combine_length") -} diff --git a/R/percentile-rank.R b/R/percentile-rank.R index 25d116a7..3a7ad5b6 100644 --- a/R/percentile-rank.R +++ b/R/percentile-rank.R @@ -79,7 +79,7 @@ do_percentile_rank <- function(u, w) { res <- (cumsum(p) - 0.5) / n } else { if (length(w) != length(u)) { - stop(cond_do_percentile_rank_weights()) + stop(input_error("length(weights) must be 1L or equal to length(x)")) } ok <- stats::complete.cases(u, w) @@ -93,12 +93,3 @@ do_percentile_rank <- function(u, w) { out[ok] <- res out } - -# conditions -------------------------------------------------------------- - -cond_do_percentile_rank_weights <- function() { # nolint: object_length_linter. - new_condition( - "length(weights) must be 1L or equal to length(x)", - "do_percentile_rank_weights" - ) -} diff --git a/R/pseudo-id.R b/R/pseudo-id.R index 576878ed..c1f4e40c 100644 --- a/R/pseudo-id.R +++ b/R/pseudo-id.R @@ -46,12 +46,12 @@ pseudo_id.factor <- function(x, ...) { #' Print `pseudo_id` #' @export -#' @param x An object of class [pseudo_id] +#' @param x An object of class `pseudo_id` #' @param ... Not implemented #' @param all if `TRUE` will print all uniques. This is not recommend for many #' uniques as it will crowd the console output #' @returns `x`, invisibly. Called for its side effects. -#' @seealso [pseudo_id()] +#' @seealso [mark::pseudo_id()] print.pseudo_id <- function(x, ..., all = FALSE) { print(as.integer(x)) out <- collapse0("Uniques: ", paste0(attr(x, "uniques"), sep = " "), sep = "") diff --git a/R/recode.R b/R/recode.R index 5b0de21f..e11fa999 100644 --- a/R/recode.R +++ b/R/recode.R @@ -53,7 +53,7 @@ recode_by <- function(x, by, vals = NULL, mode = "any") { vals <- vals %||% names(by) if (is.null(vals)) { - stop(cond_recode_values()) + stop(input_error("`vals` must be set if `by` has no names")) } if (length(vals) == 1) { @@ -66,7 +66,6 @@ recode_by <- function(x, by, vals = NULL, mode = "any") { #' @export #' @rdname recode_by recode_only <- function(x, by, vals = NULL) { - if (is.factor(x)) { levels(x) <- recode_only(levels(x), by = by, vals = vals) return(x) @@ -79,7 +78,7 @@ recode_only <- function(x, by, vals = NULL) { vals <- vals %||% names(by) if (is.null(vals)) { - stop(cond_recode_values()) + stop(input_error("`vals` must be set if `by` has no names")) } if (is.list(vals)) { @@ -121,13 +120,3 @@ clean_na_coercion <- function(expr) { res } - - -# conditions -------------------------------------------------------------- - -cond_recode_values <- function() { - new_condition( - "values to recode by were not properly set", - "recode_values" - ) -} diff --git a/R/reexports-magrittr.R b/R/reexports-magrittr.R index ce0b79ed..6195b9bf 100644 --- a/R/reexports-magrittr.R +++ b/R/reexports-magrittr.R @@ -1,3 +1,5 @@ +# TODO remove + #' @importFrom magrittr %>% #' @export magrittr::`%>%` diff --git a/R/round-by.R b/R/round-by.R index 89b30743..710c8357 100644 --- a/R/round-by.R +++ b/R/round-by.R @@ -22,10 +22,10 @@ #' ) round_by <- function( - x, - by = 1, - method = c("round", "ceiling", "floor"), - include0 = TRUE + x, + by = 1, + method = c("round", "ceiling", "floor"), + include0 = TRUE ) { res <- do.call(match_param(method), list(x / by)) * by diff --git a/R/row-bind.R b/R/row-bind.R index c780d096..02d34032 100644 --- a/R/row-bind.R +++ b/R/row-bind.R @@ -17,7 +17,7 @@ row_bind <- function(...) { } if (!all(vap_lgl(ls, is.data.frame))) { - stop(cond_row_bind_dataframes()) + stop(value_error("all elements of `...` must be of class data.frame")) } names <- lapply(ls, names) @@ -60,9 +60,3 @@ rbind2 <- function(...) { quick_df(set_names(res, names(ls[[1]]))) } - -# conditions -------------------------------------------------------------- - -cond_row_bind_dataframes <- function() { - new_condition("... must only be data.frames", "row_bind_dataframes") -} diff --git a/R/sort-by.R b/R/sort-by.R index 45a86a5b..f10a18b2 100644 --- a/R/sort-by.R +++ b/R/sort-by.R @@ -18,12 +18,8 @@ #' @export sort_by <- function(x, by, ...) { if (!is_atomic0(x) || !is_atomic0(by)) { - stop(cond_sort_by_atomic()) + stop(input_error("`x` and `by` must be atomic vectors")) } x[order(by, ...)] } - -cond_sort_by_atomic <- function() { - new_condition("`x` and `by` must be atomic vectors", "sort_by_atomic") -} diff --git a/R/sourcing.R b/R/sourcing.R index f20b29a6..82017bc7 100644 --- a/R/sourcing.R +++ b/R/sourcing.R @@ -6,30 +6,32 @@ #' #' @param file An R or Rmd file. #' @param quiet Logical; Determines whether to apply silence to [knitr::purl()] -#' @param cd Logical; if TRUE, the R working directory is temporarily +#' @param cd Logical; if `TRUE`, the **R** working directory is temporarily #' changed to the directory containing file for evaluating #' @param env An environment determining where the parsed expressions are #' evaluated #' @param ... Additional arguments passed to [base::source()] #' -#' @details -#' `try_source()` will output an error message rather than completely preventing -#' the execution. -#' This can be useful for when a script calls on multiple, independent files to -#' be sourced and a single failure shouldn't prevent the entire run to fail as -#' well. +#' @details [mark::try_source()] will output an error message rather than +#' completely preventing the execution. This can be useful for when a script +#' calls on multiple, independent files to be sourced and a single failure +#' shouldn't prevent the entire run to fail as well. #' #' @name sourcing #' @return -#' * `ksource()`: Invisibly, the result of calling `source()` on the `.R` file conversion of `file` -#' * `try_source()`, `try_ksource()`: attempts of `source()` and `ksource()` but converts errors to warnings +#' - [mark::ksource()]: Invisibly, the result of calling [base::source()] on +#' the `.R` file conversion of `file` +#' - [mark::try_source()], [mark::try_ksource()]: attempts of [base::source()] +#' and [mark::ksource()] but converts errors to warnings #' @export # nolint end: line_length_linter. ksource <- function(file, ..., quiet = TRUE, cd = FALSE, env = parent.frame()) { require_namespace("knitr") - stopifnot(is.environment(env)) + if (!is.environment(env)) { + stop(class_error("must_be", env, "environment")) + } o <- mark_temp("R") on.exit(fs::file_delete(o), add = TRUE) source(knitr::purl(file, output = o, quiet = quiet), chdir = cd, local = env) @@ -40,12 +42,9 @@ ksource <- function(file, ..., quiet = TRUE, cd = FALSE, env = parent.frame()) { try_source <- function(file, cd = FALSE, ...) { tryCatch( source(file, chdir = cd), - error = function(e) { - warning(e, call. = FALSE) - }, - simpleWarning = function(e) { - warning(e, call. = FALSE) - }) + error = function(e) warning(e, call. = FALSE), + simpleWarning = function(e) warning(e, call. = FALSE) + ) } #' @rdname sourcing @@ -53,12 +52,9 @@ try_source <- function(file, cd = FALSE, ...) { try_ksource <- function(file, ...) { tryCatch( ksource(file = file, ...), - error = function(e) { - warning(e, call. = FALSE) - }, - simpleWarning = function(e) { - warning(e, call. = FALSE) - }) + error = function(e) warning(e, call. = FALSE), + simpleWarning = function(e) warning(e, call. = FALSE) + ) } # nolint start: commented_code_linter. @@ -105,14 +101,14 @@ try_ksource <- function(file, ...) { eval_named_chunk <- function(rmd_file, label_name) { if (!grepl("\\.[Rr][Mm][Dd]$", rmd_file)) { - stop(cond_eval_named_chunk_rmd()) + stop(input_error("rmd_file does not appear to be an rmd file: ", rmd_file)) } lines <- readLines(rmd_file) label_line <- grep(paste0("\\{r ", label_name), lines)[1] if (is.na(label_line)) { - stop(cond_eval_named_chunk_label()) + stop(source_error("chunk")) } lines <- lines[(label_line + 1):length(lines)] @@ -145,23 +141,24 @@ source_r_dir <- function(dir, echo = FALSE, quiet = FALSE, ...) { #' @inheritParams source_files source_r_file <- function(path, echo = FALSE, quiet = FALSE, ...) { if (!grepl("\\.[rR]$", path)) { - stop(cond_source_r_file_r()) + stop(input_error("`path` must be an R script with .R extension")) } - stopifnot(is_file(path)) + if (!is_file(path)) { + stop(input_error("`path` must be a valid file location")) + } st <- system.time( tryCatch( source(path, echo = echo, ..., chdir = FALSE), - error = function(e) { - stop("Error in ", path, "\n", e, call. = FALSE) - } + error = function(e) stop("Error in ", path, "\n", e, call. = FALSE) ) ) if (!quiet) { message( - sprintf("Successfully sourced: %s [%s]", + sprintf( + "Successfully sourced: %s [%s]", basename(path), round(st[["elapsed"]], 2) ) @@ -182,15 +179,15 @@ source_r_file <- function(path, echo = FALSE, quiet = FALSE, ...) { #' Source an R script to an environment #' #' @param x An R script -#' @param ops Options to be passed to [mark::rscript] +#' @param ops Options to be passed to [mark::rscript()] #' @return Invisibly, and environment variable of the objects/results created #' from `x` #' @export source_to_env <- function(x, ops = NULL) { rds_file <- mark_temp("Rds") - r_temp <- mark_temp("R") - std_out <- mark_temp("md") - std_err <- mark_temp("md") + r_temp <- mark_temp("R") + std_out <- mark_temp("md") + std_err <- mark_temp("md") file.copy(x, r_temp) @@ -204,32 +201,38 @@ source_to_env <- function(x, ops = NULL) { rscript(r_temp, ops, wait = TRUE, stdout = std_out, stderr = std_err) if (!is_file(rds_file)) { - stop(cond_source_to_env_fail( - file = rds_file, - err = std_err, - out = std_out + stop(source_error( + "source", + list( + file = rds_file, + err = std_err, + out = std_out + ) )) } con <- file(rds_file) res <- readRDS(con) - on.exit({ - close(con) - file.remove(r_temp, rds_file, std_out, std_err) - }, add = TRUE) + on.exit( + { + close(con) + file.remove(r_temp, rds_file, std_out, std_err) + }, + add = TRUE + ) invisible(res) } #' Rscript #' -#' Implements `Rscript` with `system2` +#' Implements `Rscript` with [base::system2()] #' #' @param x An R file to run #' @param ops A character vector of options (`"--"` is added to each) #' @param args A character vector of other arguments to pass -#' @param ... Additional arguments passed to `system2` +#' @param ... Additional arguments passed to [base::system2()] #' @return A `character` vector of the result from calling `Rscript` via #' `system2()` #' @@ -241,7 +244,8 @@ rscript <- function(x, ops = NULL, args = NULL, ...) { } rs <- file_path( - R.home("bin"), if (is_windows()) "Rscript.exe" else "Rscript", + R.home("bin"), + if (is_windows()) "Rscript.exe" else "Rscript", check = TRUE ) @@ -260,9 +264,9 @@ rscript <- function(x, ops = NULL, args = NULL, ...) { #' #' @export save_source <- function( - env = parent.frame(), - file = mark_temp("Rds"), - name = NULL + env = parent.frame(), + file = mark_temp("Rds"), + name = NULL ) { ls <- ls(envir = env, all.name = TRUE) out <- lapply(ls, get, envir = env) @@ -270,17 +274,16 @@ save_source <- function( res <- struct( list2env(out, parent = baseenv()), - class = c("source_env", "environment"), + class = c("source_env", "environment"), sessionInfo = utils::sessionInfo(), - search = search(), - options = options(), - file = file, - env = env, - name = name %||% file_name(file) + search = search(), + options = options(), + file = file, + env = env, + name = name %||% file_name(file) ) if (!is.null(file)) { - if (!is_dir(dirname(file))) { dir.create(dirname(file), recursive = TRUE) } @@ -297,8 +300,14 @@ save_source <- function( print.source_env <- function(x, ...) { a <- attributes(x) cat( - "<", crayon_green("sourced env: "), a$name, ">\n", - "<", crayon_green("parent env: "), environmentName(a$env), ">\n", + "<", + crayon_green("sourced env: "), + a$name, + ">\n", + "<", + crayon_green("parent env: "), + environmentName(a$env), + ">\n", sep = "" ) invisible(x) @@ -306,34 +315,35 @@ print.source_env <- function(x, ...) { # conditions -------------------------------------------------------------- -cond_eval_named_chunk_rmd <- function() { - new_condition( - "rmd_file does not appear to be an rmd file", - "eval_named_chunk_rmd" - ) -} - -cond_eval_named_chunk_label <- function() { - new_condition("label not found in .Rmd file", "eval_named_chunk_label") -} - -cond_source_r_file_r <- function() { - new_condition("Must be a .R file", "source_r_file_r") -} - -cond_source_to_env_fail <- function(file, err, out) { - msg <- paste0( - "RDS file not succesfully saved here:\n ", file, - "\n", - "\nRscript stderr:\n", - collapse0(readLines(err), sep = "\n"), - "\n", - "\nRscript stdout:\n", - collapse0(readLines(out), sep = "\n"), - "\n" +source_error := condition( + function(x, params = NULL) { + switch( + x, + label = "label not found in .Rmd file", + # NOTE maybe 'source' is a different type of error + source = paste0( + "RDS file not succesfully saved here:\n ", + params$file, + "\n", + "\nRscript stderr:\n", + collapse0(readLines(params$err), sep = "\n"), + "\n", + "\nRscript stdout:\n", + collapse0(readLines(params$out), sep = "\n"), + "\n" + ), + stop(internal_error()) + ) + }, + type = "error", + classes = "value_error", + package = "mark", + exports = c( + "source_to_env", + "eval_named_chunk" ) - new_condition(msg, "source_to_env_fail") -} + # TODO include help +) # globalVariables --------------------------------------------------------- diff --git a/R/stats.R b/R/stats.R index ccff35d6..efe55a67 100644 --- a/R/stats.R +++ b/R/stats.R @@ -6,7 +6,7 @@ #' `q50` is an alias for `median2` #' #' @inheritParams stats::quantile -#' @return See `stats::quantile()` +#' @return See [stats::quantile()] #' #' @examples #' set.seed(42) @@ -18,7 +18,8 @@ #' @export #' @seealso [stats::quantile()] -median2 <- function(x, type = 7, na.rm = FALSE) { # nolint: object_name_linter. +# nolint next: object_name_linter. +median2 <- function(x, type = 7, na.rm = FALSE) { stats::quantile(x, probs = .5, type = type, na.rm = na.rm, names = FALSE) } @@ -28,8 +29,8 @@ q50 <- median2 #' Range 2 #' -#' Employs `min()` and `max()`. However, [base::range()], there is no argument -#' for removing `Inf` values. +#' Employs [base::min()] and [base::max()]. However, [base::range()], there is +#' no argument for removing `Inf` values. #' #' @param x A numeric (or character) vector (see Note in [base::min]) #' @param na.rm Logical, if `TRUE` removes missing values @@ -47,6 +48,7 @@ q50 <- median2 #' system.time(rep(range2(x, na.rm = TRUE), 100)) #' } #' @export -range2 <- function(x, na.rm = FALSE) { # nolint: object_name_linter. +# nolint next: object_name_linter. +range2 <- function(x, na.rm = FALSE) { c(min(x, na.rm = na.rm), max(x, na.rm = na.rm)) } diff --git a/R/strings.R b/R/strings.R index d78dbe7a..798da747 100644 --- a/R/strings.R +++ b/R/strings.R @@ -104,7 +104,6 @@ str_extract_datetime <- function(x, format = "%Y-%m-%d %H%M%S") { # nolint next: object_name_linter. string_extract <- function(x, pattern, perl = FALSE, ignore.case = FALSE) { - # nolint: object_name_linter, line_length_linter. re <- regexpr(pattern, x, perl = perl, ignore.case = ignore.case) starts <- as.vector(re, "integer") substr(x, starts, starts + attr(re, "match.length") - 1L) @@ -113,7 +112,7 @@ string_extract <- function(x, pattern, perl = FALSE, ignore.case = FALSE) { #' Format string to a regular expression #' #' @param x A date or datetime format, assuming that entries follow the formats -#' described in [base::strptime] +#' described in [base::strptime()] #' #' @examples #' mark:::format_to_regex("%Y-%m-%d") @@ -157,23 +156,25 @@ month_name_regex <- sprintf("(%s)", paste(month.name, collapse = "|")) #' chr_split("split this") #' @export chr_split <- function(x) { - stopifnot(length(x) == 1L) - strsplit(as.character(x), "")[[1]] + if (length(x) != 1L) { + stop(input_error("`x` must be a single length character")) + } + strsplit(as.character(x), "")[[1L]] } #' Print as c #' #' Prints a vector to paste into an R script #' -#' @details -#' This sorts (if set) and provides unique values for each element in `x` and -#' prints then as a call to `c`. This can be useful for copying data that you -#' want to save as a vector in an R script. -#' The result is both called in `cat()` as well as copied to the clipboard. +#' @details This sorts (if set) and provides unique values for each element in +#' `x` and prints then as a call to [base::c()]. This can be useful for +#' copying data that you want to save as a vector in an **R** script. The +#' result is both called in [base::cat()] as well as copied to the clipboard. #' #' @param x A vector (defaults to reading the clipboard) -#' @param sorted If `TRUE` (default) applies `sort()` to `x` -#' @param null If `TRUE` (default) adds `NULL` at the end of the `c()` print +#' @param sorted If `TRUE` (default) applies [base::sort()] to `x` +#' @param null If `TRUE` (default) adds `NULL` at the end of the [base::c()] +#' print #' @return Invisibly, as a `character` vector, the object printed to the console #' @examples #' print_c(1:10) @@ -183,7 +184,6 @@ chr_split <- function(x) { #' @export print_c <- function(x = read_clipboard(), sorted = TRUE, null = TRUE) { check_is_vector(x) - x <- unique(unlist(x)) if (sorted) { diff --git a/R/switch.R b/R/switch.R index 87aae98f..dc8ce03a 100644 --- a/R/switch.R +++ b/R/switch.R @@ -2,17 +2,21 @@ #' #' Switch with a list of params #' -#' @description -#' `switch_params()` is a vectorized version of `switch` -#' `switch_case()` uses a formula syntax to return the value to the right of the -#' tilde (`~`) when `x` is `TRUE` -#' `switch_in_case()` is a special case of `switch_case()` for `match()`-ing `x` -#' in the values on the left to return the value on the right. +#' @description [mark::switch_params()] is a vectorized version of +#' [base::switch()] #' -#' @return A named vector of values of same length `x`; or for `switch_case`, -#' an unnamed vector of values matching the rhs of `...` +#' [mark::switch_case()] uses a formula syntax to return the value to the +#' right of the tilde (`~`) when `x` is `TRUE` #' -#' Inspired from: +#' [mark::switch_in_case()] is a special case of [mark::switch_case()] for +#' [base::match()]-ing `x` in the values on the left to return the value on +#' the right. +#' +#' @return A named vector of values of same length `x`; or for +#' [mark::switch_case()], an unnamed vector of values matching the rhs of +#' `...` +#' +#' Inspired from: #' * https://stackoverflow.com/a/32835930/12126576 #' * https://github.com/tidyverse/dplyr/issues/5811 #' @@ -82,7 +86,7 @@ NULL #' @param x A vector of values -#' @param ... Case evaluations (named for `switch_params`) +#' @param ... Case evaluations (named for [mark::switch_params()]) #' @rdname switch-ext #' @export switch_params <- function(x, ...) { @@ -96,7 +100,7 @@ switch_params <- function(x, ...) { #' @param .default The default value if no matches are found in `...` #' (default: `NULL` produces an `NA` value derived from `...`) #' @param .envir The environment in which to evaluate the LHS of `...` (default: -#' `parent.frame()`) +#' [base::parent.frame()]) #' @rdname switch-ext #' @export switch_in_case <- function(x, ..., .default = NULL, .envir = parent.frame()) { @@ -114,7 +118,7 @@ switch_in_case <- function(x, ..., .default = NULL, .envir = parent.frame()) { ) } - rhs <- lapply(splits, function(i) { + rhs <- lapply(splits, function(i) { eval(parse(text = i[2L]), envir = parent.frame()) }) @@ -128,20 +132,20 @@ switch_in_case <- function(x, ..., .default = NULL, .envir = parent.frame()) { cres <- as.character(res) if (cres[1L] == ":") { if (!exists("xrange")) { - stop(cond_switch_in_case_numeric()) + stop(switch_error("numeric")) } cres[cres == "-Inf"] <- xrange[1L] cres[cres == "Inf"] <- xrange[2L] if (any(cres %in% c("-Inf", "inf"))) { - stop(cond_switch_in_case_ambiguous()) + stop(switch_error("ambiguous_infinity")) } } tryCatch( do.call(cres[1L], as.list(cres[-1L])), error = function(e) { - stop(cond_switch_in_case_evaluate(e$message)) + stop(switch_error("evaluate", e$message)) } ) }) @@ -170,7 +174,9 @@ switch_in_case <- function(x, ..., .default = NULL, .envir = parent.frame()) { } res <- lapply(x, do_switches) - stopifnot(lengths(res) == 1L) + if (all(lengths(res) != 1L)) { + stop(switch_error("result")) + } res <- unlist(res) mode(res) <- mode(res[[1]]) class(res) <- class(res[[1]]) @@ -205,7 +211,7 @@ switch_case <- function(..., .default = NULL, .envir = parent.frame()) { rmat[inds] } else { rmat[inds[, 2, drop = FALSE]] - } + } out[rowSums(lmat) == 0L] <- res0 as.vector(out, mode(res0)) } @@ -231,12 +237,10 @@ switch_length_check <- function(ls) { switch( length(u), return(ls), - { - if (u[1L] == 0L) { - stop(cond_switch_length_check_0()) - } - - if (u[1L] == 1L) { + switch( + u[1L] + 1L, + stop(switch_error("lengths_check_0")), + { ind <- which(lens == 1L) for (i in ind) { @@ -245,11 +249,12 @@ switch_length_check <- function(ls) { return(ls) } - stop(cond_switch_length_check_2()) - }, - stop(cond_switch_length_check_3()) + ), + stop(switch_error("lengths_check_2")), + stop(switch_error("lengths_check_3")), + NULL ) - stop(cond_switch_length_check_bad()) + stop(internal_error("Unexpected lengths found")) } switch_lengths_check <- function(lhs, rhs) { @@ -261,7 +266,7 @@ switch_lengths_check <- function(lhs, rhs) { } if (!identical(llens, rlens)) { - stop(cond_switch_lengths_check()) + stop(switch_error("lengths_check")) } invisible(NULL) @@ -269,48 +274,21 @@ switch_lengths_check <- function(lhs, rhs) { # conditions -------------------------------------------------------------- -cond_switch_in_case_numeric <- function() { - new_condition( - "x did not appear to be numeric, cannot continue evaluating lhs", - "switch_in_case_numeric" - ) -} - -cond_switch_in_case_ambiguous <- function() { - new_condition( - "Ambiguous infinity, cannot calculate", - "switch_in_case_ambiguous" - ) -} - -cond_switch_in_case_evaluate <- function(x) { - new_condition( - paste0("Could not evaluate lhs\n", x), - "switch_in_case_evaluate" - ) -} - -cond_switch_lengths_check <- function() { - new_condition("statements have different lengths", "switch_lengths_check") -} - -cond_switch_length_check_0 <- function() { - new_condition("Cannot have 0 length rhs", "switch_length_check_0") -} - -cond_switch_length_check_2 <- function() { - new_condition( - "2 lengths found, one of which was not 1", - "switch_length_check_1" - ) -} - -cond_switch_length_check_3 <- function() { - new_condition("3 or more lengths found, stopping", "switch_length_check_3") -} - -cond_switch_length_check_bad <- function() { - new_condition("Something really went wrong", "switch_length_check_bad") -} - -# terminal line +# TODO review of these can be simplified +switch_error := condition( + function(x, params = NULL) { + switch( + x, + numeric = "`x` did not appear to be numeric, cannot continue evaluating lhs", # nolint: line_length_linter. + ambiguous_infinity = "Ambiguous infinity, cannot calculate", + evaluate = paste0("Could not evaluate lhs\n", params), + lengths_check = "statements have different lengths", + lengths_check_0 = "Cannot have 0 length rhs", + lengths_check_2 = "2 lengths found, one of which was not 1", + lengths_check_3 = "3 or more lengths found, stopping", + result = "results must be of length 1L", + stop(internal_error()), + ) + }, + classes = "value_error" +) diff --git a/R/system-file.R b/R/system-file.R index eca0f027..9c8dfd1c 100644 --- a/R/system-file.R +++ b/R/system-file.R @@ -4,13 +4,13 @@ #' #' @param package The name of the package #' -#' @returns A `function` wrapping [system.file()] which will always use the +#' @returns A `function` wrapping `system.file()` which will always use the #' package name provided in `package` #' @export #' @examples #' make_sf("mark")() make_sf <- function(package) { - fun <- function(..., check = FALSE) { } + fun <- function(..., check = FALSE) {} body(fun) <- substitute( match.fun("system.file")(..., package = package, mustWork = check) ) diff --git a/R/time-report.R b/R/time-report.R index 8c0ae230..d3de7ccc 100644 --- a/R/time-report.R +++ b/R/time-report.R @@ -1,3 +1,5 @@ +# nocov start + #' Time reports #' #' Evaluate code and report on the time difference @@ -25,7 +27,6 @@ #' }) #' @export -# nolint next: object_name_linter. simpleTimeReport <- function(title = NULL, expr, envir = parent.frame()) { mc <- match.call() cat0(trimws(title), "\n", rep("-", getOption("width")), "\n") @@ -137,7 +138,7 @@ simpleTimeReport <- function(title = NULL, expr, envir = parent.frame()) { #' @param threshold A threshold for reporting the difference, if `stop - start` #' is less than this, a empty character vector (`""`) is returned #' @noRd -formatTimeDiff <- function(start, stop = Sys.time(), threshold = .1) { # nolint: object_name_linter, line_length_linter. +formatTimeDiff <- function(start, stop = Sys.time(), threshold = .1) { difference <- stop - start threshold <- as.difftime(threshold, units = "secs") @@ -186,3 +187,5 @@ split_expression <- function(expr) { x <- strsplit(x, "\\s{0,}\n\\s{0,}")[[1]] str2expression(x) } + +# nocov end diff --git a/R/todos.R b/R/todos.R index 5f2d4c79..bd3c2a90 100644 --- a/R/todos.R +++ b/R/todos.R @@ -44,12 +44,12 @@ NULL #' @rdname todos #' @export todos <- function( - pattern = NULL, - path = ".", - force = getOption("mark.todos.force"), - ext = getOption("mark.todos.ext"), - ignore = NULL, - ... + pattern = NULL, + path = ".", + force = getOption("mark.todos.force"), + ext = getOption("mark.todos.ext"), + ignore = NULL, + ... ) { do_todo( "todo", @@ -65,12 +65,12 @@ todos <- function( #' @rdname todos #' @export fixmes <- function( - pattern = NULL, - path = ".", - force = getOption("mark.todos.force"), - ext = getOption("mark.todos.ext"), - ignore = NULL, - ... + pattern = NULL, + path = ".", + force = getOption("mark.todos.force"), + ext = getOption("mark.todos.ext"), + ignore = NULL, + ... ) { do_todo( "fixme", @@ -84,24 +84,27 @@ fixmes <- function( } do_todo <- function( - text = c("todo", "fixme"), - pattern = NULL, - path = ".", - force = getOption("mark.todos.force"), - ext = getOption("mark.todos.ext"), - ignore = NULL, - ... + text = c("todo", "fixme"), + pattern = NULL, + path = ".", + force = getOption("mark.todos.force"), + ext = getOption("mark.todos.ext"), + ignore = NULL, + ... ) { text <- match_param(text) + # fmt: skip if ( missing(path) || length(path) != 1 || !is.character(path) ) { - stop(cond_do_todo_path()) + stop(input_error("`path` must be a character vector of length 1L")) } - stopifnot(fs::file_exists(path)) + if (!fs::file_exists(path)) { + stop(input_error("`path` does not exist: ", path)) + } ls <- rlang::list2(...) @@ -144,7 +147,7 @@ do_todo <- function( function(x, regex) { x <- enc2utf8(x) ind <- grep(pattern = regex, x = x) - quick_dfl(ind = ind, todo = x[ind]) + dataframe(ind = ind, todo = x[ind]) }, regex = sprintf("[#]\\s+%s[:]?\\s+", toupper(text)) ) @@ -207,11 +210,12 @@ print.todos_df <- function(x, ...) { if (!isFALSE(getOption("mark.todos..norm_path"))) { # perform action on chunks as not to modify x - for (i in seq_along(chunks)) - chunks <- lapply(chunks, function(chunk) { - chunk[["file"]] <- norm_path(chunk[["file"]]) - chunk - }) + for (i in seq_along(chunks)) { + chunks <- lapply(chunks, function(chunk) { + chunk[["file"]] <- norm_path(chunk[["file"]]) + chunk + }) + } } for (i in seq_along(nms)) { @@ -247,13 +251,3 @@ string_dots <- function(x, width = getOption("width")) { x[long] <- paste(strtrim(x[long], width - 5), "[...]") x } - -# conditions -------------------------------------------------------------- - -cond_do_todo_path <- function() { - new_condition("path must be a character vector of length 1L", "do_todo_path") -} - -cond_do_todo_path_r <- function() { - new_condition("path is not a .R or .Rmd file", "do_todo_path_r") -} diff --git a/R/unlist.R b/R/unlist.R index e6b386e7..4ffee60d 100644 --- a/R/unlist.R +++ b/R/unlist.R @@ -3,9 +3,9 @@ #' Unlist without unique names; combine names for unique values #' #' @details -#' * [unlist0()] is much like [unlist()] expect that name are not made to be -#' unique. -#' * [squash_vec()] works differently +#' - [mark::unlist0()] is much like [base::unlist()] expect that name are not +#' made to be unique. +#' - [mark::squash_vec()] works differently #' #' @param x A vector of values #' @examples @@ -22,8 +22,8 @@ #' squash_vec(y) #' @export #' @returns -#' * [unlist0()]: a vector with the possibility of non-unique names -#' * [squash_vec()]: A vector of unique values and names +#' * [mark::unlist0()]: a vector with the possibility of non-unique names +#' * [mark::squash_vec()]: A vector of unique values and names unlist0 <- function(x) { if (!is.list(x)) { return(x) diff --git a/R/utils.R b/R/utils.R index eb8f92f2..4f05034e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,16 +1,24 @@ - which0 <- function(x) { which(x) %len% 0L } +# isTRUE, isFALSE, ... +# nolint next: object_name_linter. +isNA <- function(x) { + is.logical(x) && length(x) == 1L && is.na(x) +} + # modified from https://github.com/tidyverse/purrr/blob/5aca9df41452f272fcef792dbc6d584be8be7167/R/utils.R # nolint: line_length_linter. use_color <- function() { rn("crayon") && crayon::has_color() } # nolint start: brace_linter. +# fmt: skip crayon_blue <- function(x) { if (use_color()) crayon::blue(x) else x } +# fmt: skip crayon_green <- function(x) { if (use_color()) crayon::green(x) else x } +# fmt: skip crayon_cyan <- function(x) { if (use_color()) crayon::cyan(x) else x } # nolint end: brace_linter. @@ -43,7 +51,8 @@ print_no_attr <- function(x, ...) { #' #' @export #' @seealso [base::which()] -that <- function(x, arr.ind = FALSE, useNames = TRUE) { # nolint: object_name_linter, line_length_linter. +# nolint next: object_name_linter. +that <- function(x, arr.ind = FALSE, useNames = TRUE) { # TODO consider that() as #seq_along(x)[x]? which(x, arr.ind = arr.ind, useNames = useNames) } @@ -84,15 +93,24 @@ is_unique <- function(x) { anyDuplicated(x) == 0L } -is_atomic0 <- function(x) { - is.atomic(x) && !is.null(x) +# since 4.4.0 is.atomic(NULL) returns FALSE +is_atomic0 <- if (getRversion() < "4.4.0") { + function(x) is.atomic(x) && !is.null(x) +} else { + base::is.atomic } -# nolint start: brace_linter. -cat0 <- function(...) { cat(..., sep = "") } -catln <- function(...) { cat(..., sep = "\n") } -charexpr <- function(x) { as.character(as.expression(x)) } -# nolint end: brace_linter. +cat0 <- function(...) { + cat(..., sep = "") +} + +catln <- function(...) { + cat(..., sep = "\n") +} + +charexpr <- function(x) { + as.character(as.expression(x)) +} mark_temp <- function(ext = "") { if (!grepl("^[.]", ext) && !identical(ext, "") && !is.na(ext)) { @@ -110,26 +128,25 @@ mark_temp <- function(ext = "") { } check_is_vector <- function(x, mode = "any") { + nm <- deparse1(substitute(x)) + # fmt: skip if ( isS4(x) || inherits(x, c("data.frame", "matrix", "array")) || !is.vector(remove_attributes(x), mode) ) { - x <- deparse1(substitute(x)) - stop(cond_check_is_vector_mode(x, mode)) + stop( + input_error( + switch( + mode, + any = sprintf("`%s` must be a vector", nm), + sprintf("`%s` must be a vector of mode '%s'", nm, mode) + ) + ) + ) } - - invisible() } -cond_check_is_vector_mode <- function(x, mode) { - new_condition( - paste(x, "must be a vector of mode", mode), - "check_is_vector_mode" - ) -} - - add_attributes <- function(x, ...) { attributes(x) <- c(attributes(x), rlang::list2(...)) x @@ -174,15 +191,21 @@ check_interactive <- function() { return(FALSE) } - stop(cond_check_interactive()) + stop(options_error("interactive")) } -cond_check_interactive <- function() { - new_condition( - "mark.check_interactive must be TRUE, FALSE, or NA", - "check_interactive" - ) -} +# TODO is this even needed? Maybe if options were active bindings +options_error := condition( + function(x) { + switch( + x, + interactive = "mark.check_interactive must be TRUE, FALSE, or NA", + stop(internal_error(paste("bad value:", x))) + ) + }, + classes = "input_error", + type = "error" +) try_formats <- function(date = FALSE) { x <- c( @@ -210,25 +233,15 @@ has_char <- function(x) { dupe_check <- function(x, n = getOption("mark.dupe.n", 5)) { n <- as.integer(n) + dupes <- duplicated(x) - dupes <- which(duplicated(x)) - n_dupes <- length(dupes) - dupes <- utils::head(dupes, n) - - if (n_dupes) { - stop(cond_dupe_check(x, dupes, n_dupes, n)) + if (any(dupes)) { + stop(duplicate_error(x = x, positions = which(dupes))) } invisible(NULL) } -cond_dupe_check <- function(x, dupes, n_dupes, n) { - msg <- paste0( - "Duplicate values found in ", n_dupes, " location(s) :\n", - if (n_dupes > n) sprintf("(first %i)\n", n), - paste0(" > ", sprintf("[%s] %s", format(dupes), format(x[dupes])), "\n"), - if (n_dupes > n) "... and ", n_dupes - n, " more" - ) - - new_condition(msg, "dupe_check") +dataframe <- function(...) { + fuj::quick_df(list(...)) } diff --git a/R/within.R b/R/within.R index f26c4048..3691ce16 100644 --- a/R/within.R +++ b/R/within.R @@ -3,21 +3,21 @@ #' Compare a vector within (between) other values #' #' @param x A numeric vector of values -#' @param left,right Boundary values. For [within()], when `NULL` no +#' @param left,right Boundary values. For [mark::within()], when `NULL` no #' comparison is made for that boundary. When both are `NULL`, `x` is just #' returned. #' -#' @details `type``, `bounds`` can be one of the below: +#' @details `type`, `bounds` can be one of the below: #' #' \describe{ -#' \item{g,(}{is greater than (>)} -#' \item{ge,[}{greater than or equal to (>=)} -#' \item{l,))}{less than (<)} -#' \item{le,[]}{less than or equal to (<=)} +#' \item{`"g"`, `(`}{is greater than (`>`)} +#' \item{`"ge"`, `[`}{greater than or equal to (`>=`)} +#' \item{`"l"`, `)`}{less than (`<`)} +#' \item{`"le"`, `]`}{less than or equal to (`<=`)} #' } #' -#' Note: [between_more()] may be deprecated in the future in favor of just -#' [within()] +#' Note: [mark::between_more()] may be deprecated in the future in favor of +#' just [mark::within()] #' #' @returns A logical vector #' @@ -29,7 +29,7 @@ #' within(2:10, bounds = "(]") #' within(1:5, c(3, 3, 2, 2, 1), 5) #' @name within -#' @aliases between betwee_more +#' @aliases between between_more NULL # TODO consider deprecating `between_more()` in favor of `within()`` @@ -42,15 +42,15 @@ between_more <- function(x, left, right, type = c("gele", "gel", "gle", "gl")) { type <- match_param(type) if (any(left > right, na.rm = TRUE)) { - warning(cond_between_more_lr()) + warning(input_warning("`left` should be less than or equal to `right`")) } switch( type, gele = x >= left & x <= right, - gel = x >= left & x < right, - gle = x > left & x <= right, - gl = x > left & x < right + gel = x >= left & x < right, + gle = x > left & x <= right, + gl = x > left & x < right ) } @@ -58,10 +58,10 @@ between_more <- function(x, left, right, type = c("gele", "gel", "gle", "gl")) { #' @export #' @param bounds Boundaries for comparisons of `left` and `right` (see details) within <- function( - x, - left = NULL, - right = NULL, - bounds = c("[]", "[)", "(]", "()") + x, + left = NULL, + right = NULL, + bounds = c("[]", "[)", "(]", "()") ) { left_null <- is.null(left) right_null <- is.null(right) @@ -71,7 +71,7 @@ within <- function( } if (any(left > right, na.rm = TRUE)) { - warning(cond_within_lr()) + warning(input_warning("`left` should be less than or equal to `right`")) } funs <- switch( @@ -96,21 +96,3 @@ within <- function( left & right } - -# conditions -------------------------------------------------------------- - -cond_between_more_lr <- function() { - new_condition( - "`left` > `right`", - "between_more_lr", - type = "warning" - ) -} - -cond_within_lr <- function() { - new_condition( - "`left` > `right`", - "within_lr", - type = "warning" - ) -} diff --git a/R/write.R b/R/write.R index a01cd24c..d35f9ad1 100644 --- a/R/write.R +++ b/R/write.R @@ -1,29 +1,29 @@ #' Write file with md5 hash check #' -#' @section `options()`: +#' @section Options: #' #' - `mark.compress.method`: compression method to use when writing files #' - `mark.list.hook`: when a `data.frame` contains a `list` column, this -#' function is applied to each element of the list. The default `"auto"` -#' uses `toJSON()` if the package `jsonlite` is available, otherwise -#' +#' function is applied to each element of the list. The default `"auto"` uses +#' `jsonlite::toJSON()` if the package `jsonlite` is available, otherwise #' #' @param x An object to write to file #' @param path The file or connection to write to (dependent on part by method) #' @param method The method of saving the file. When `default`, the method is #' determined by file extension of `path`, if present, otherwise by the type #' of object of `x`. -#' @inheritParams file_copy_md5 #' @param encoding The encoding to use when writing the file. #' @param compression The compression method to use when writing the file. #' @param ... Additional arguments passed to the write function. +#' @inheritParams file_copy_md5 #' @returns -#' - [write_file_md5()]: `x`, invisibly. When `path` is not the `stdout()`, `x` -#' is returned with the attribute `"path"` set to the result of -#' [file_copy_md5()]. -#' - [mark_write_methods()]: A list of applicable methods and their aliases -#' - [mark_compress_methods()]: A character vector of applicable compression -#' methods +#' - [mark::write_file_md5()]: `x`, invisibly. When `path` is not the +#' [base::stdout()], `x` is returned with the attribute `"path"` set to the +#' result of [mark::file_copy_md5()]. +#' - [mark::mark_write_methods()]: A list of applicable methods and their +#' aliases +#' - [mark::mark_compress_methods()]: A character vector of applicable +#' compression methods #' @examples #' # just writes to stdout() #' df <- data.frame(a = 1, b = 2) @@ -54,6 +54,7 @@ write_file_md5 <- function( ) on.exit(options(op), add = TRUE) + # fmt: skip if ( !isTRUE(nzchar(path, keepNA = TRUE)) || inherits(path, "terminal") @@ -125,6 +126,7 @@ write_file_md5 <- function( temp <- hook(temp) %||% temp if (!is.null(attr(x, "path"))) { + # NOTE this should be fairly rare, right? warning("attr(x, \"path\") is being overwritten") } @@ -245,10 +247,8 @@ mark_write_table <- function( eol = "\n", na = "", dec = ".", - # nolint next: object_name_linter. - row.names = FALSE, - # nolint next: object_name_linter. - col.names = NA, + row.names = FALSE, # nolint: object_name_linter. + col.names = NA, # nolint: object_name_linter. qmethod = "escape", list_hook = getOption("mark.list.hook", "auto") ) { @@ -306,9 +306,8 @@ get_list_hook <- function(hook) { none = NULL, # nolint next: brace_linter. na = function(x) { - stop(new_condition( - "options(mark.list.hook) is NA but list columns detected", - class = "writeFileMd5ListHook" + stop(value_error( + "options(mark.list.hook) is NA but list columns detected" )) }, match.fun(hook) @@ -318,12 +317,10 @@ get_list_hook <- function(hook) { mark_write_dcf <- function( x, con = "", - # nolint next: object_name_linter. - useBytes = FALSE, + useBytes = FALSE, # nolint: object_name_linter. indent = 4, width = Inf, - # nolint next: object_name_linter. - keep.white = NULL + keep.white = NULL # nolint: object_name_linter. ) { write.dcf( x = x, @@ -357,17 +354,7 @@ mark_write_yaml <- function( unicode = unicode, precision = digits, indent.mapping.sequence = FALSE, - handlers = list( - boolean = function(x) { - # nocov start - if (x %in% c("n", "y")) { - x - } else { - tolower(x) == "true" - } - # nocov end - } - ) + handlers = list(logical = yaml::verbatim_logical) ) mark_write_lines(string, con) } @@ -435,6 +422,56 @@ mark_write_arrow <- function( do.call(write, c(args, list(...))) } +mark_write_md <- function( + x, + con, + format = c("default", "compact"), + na = NA_character_, + ... +) { + format <- match_param(format) + m <- rbind(NA, NA, unname(as.matrix(x))) + n <- ncol(x) + numeric <- vap_lgl(x, is.numeric) + align <- rep("left", n) + align[numeric] <- "right" + m[is.na(m)] <- na + + for (i in seq_along(x)) { + m[, i] <- base::format( + c(colnames(x)[i], "", m[-(1:2), i]), + trim = format == "compact", + justify = align[i] + ) + } + + m[2L, ] <- strrep( + "-", + switch( + format, + default = nchar(m[1L, ]) - 1L, + compact = rep(2L, n) + ) + ) + + m[2L, numeric] <- paste0(m[2L, numeric], ":") + m[2L, !numeric] <- paste0(":", m[2L, !numeric]) + + if (format == "compact") { + m <- trimws(m) + } + + cat( + paste0( + "|", + apply(m, 1L, paste0, collapse = "|"), + "|", + collapse = "\n" + ), + file = con + ) +} + # helpers ----------------------------------------------------------------- mark_to_json <- function(x) { @@ -478,10 +515,9 @@ compress <- function( if (identical(attr(path, "extra"), "tar")) { if (method == "zip") { - stop( - "'zip' is not a valid method when writing to a tar archive", - call. = FALSE - ) + stop(input_error( + "'zip' is not a valid method when writing to a tar archive" + )) } # tar() can do the compression for us, so we move this to a temporary # option. this is always cleaned up because it shouldn't be set manually diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 00000000..1ad4b8d1 --- /dev/null +++ b/R/zzz.R @@ -0,0 +1,3 @@ +# FIXME include: +cnd_exports() +cnd_document() diff --git a/air.toml b/air.toml new file mode 100644 index 00000000..4ca6496b --- /dev/null +++ b/air.toml @@ -0,0 +1,15 @@ +[format] +line-width = 80 +indent-width = 2 +indent-style = "space" +line-ending = "lf" +persistent-line-breaks = true +exclude = [] +default-exclude = true +skip = [ + "crayon_blue", + "crayon_green", + "crayon_cyan", +] +table = [] +default-table = true diff --git a/bench/bench-counts.R b/bench/bench-counts.R index 3f8c3230..100617bf 100644 --- a/bench/bench-counts.R +++ b/bench/bench-counts.R @@ -3,7 +3,7 @@ library(mark, warn.conflicts = TRUE) n <- 1e4 -x <- quick_df(list( +x <- dataframe( a = sample(letters, n, TRUE), b = sample(letters, n, TRUE), c = sample(letters, n, TRUE) diff --git a/man/add_file_timestamp.Rd b/man/add_file_timestamp.Rd index 4d5a1b84..20149f3c 100644 --- a/man/add_file_timestamp.Rd +++ b/man/add_file_timestamp.Rd @@ -14,7 +14,8 @@ add_file_timestamp( \arguments{ \item{x}{A vector of files} -\item{ts}{A single timestamp or vector of timestamps (default: \code{Sys.time()})} +\item{ts}{A single timestamp or vector of timestamps (default: +\code{\link[base:Sys.time]{base::Sys.time()}})} \item{format}{A format to be applied to the times; set to \code{NULL} to skip formatting} diff --git a/man/are_identical.Rd b/man/are_identical.Rd index c5896686..7637065f 100644 --- a/man/are_identical.Rd +++ b/man/are_identical.Rd @@ -17,7 +17,7 @@ A \code{logical} vector of \code{TRUE}/\code{FALSE} of equal length of each \cod vector } \description{ -Extensions for the use of \code{base::identical()} +Extensions for the use of \code{\link[base:identical]{base::identical()}} } \examples{ x <- y <- z <- 1:5 diff --git a/man/as_ordered.Rd b/man/as_ordered.Rd index 97b65ad0..69707684 100644 --- a/man/as_ordered.Rd +++ b/man/as_ordered.Rd @@ -22,8 +22,8 @@ As ordered Simple implementation of \code{ordered}. If \code{x} is \code{ordered} it is simply returned. If \code{x} is a \code{factor} the \code{ordered} class is added. Otherwise, \code{x} is made into a \code{factor} with \code{\link[=fact]{fact()}} and then the -\code{ordered} class is added. Unlike just \code{fact}, \code{ordered} will replace the \code{NA} -levels with \code{NA_integer_} to work appropriately with other functions. +\code{ordered} class is added. Unlike just \code{fact}, \code{ordered} will replace the +\code{NA} levels with \code{NA_integer_} to work appropriately with other functions. } \examples{ x <- c("a", NA, "b") diff --git a/man/base_alpha.Rd b/man/base_alpha.Rd index a6e5d0f2..305ed0d6 100644 --- a/man/base_alpha.Rd +++ b/man/base_alpha.Rd @@ -4,7 +4,7 @@ \alias{base_alpha} \title{Alpha base} \usage{ -base_alpha(x, base = 26) +base_alpha(x, base = 26L) } \arguments{ \item{x}{A string of letters. Non characters are removed.} diff --git a/man/base_n.Rd b/man/base_n.Rd index db3607c5..1b3c2a10 100644 --- a/man/base_n.Rd +++ b/man/base_n.Rd @@ -4,7 +4,7 @@ \alias{base_n} \title{Base N conversion} \usage{ -base_n(x, from = 10, to = 10) +base_n(x, from = 10L, to = 10L) } \arguments{ \item{x}{A vector of integers} diff --git a/man/blank_values.Rd b/man/blank_values.Rd index 546b435c..91f320aa 100644 --- a/man/blank_values.Rd +++ b/man/blank_values.Rd @@ -29,11 +29,11 @@ of vector} } \value{ \itemize{ -\item \code{is_blank()} a \code{logical} vector indicating \emph{blank} elements in \code{x} -\item \code{select_blank_cols()} \code{x} with only columns that are all \emph{blank} -\item \code{remove_blank_cols()} \code{x} without columns of only \emph{blank} -\item \code{is_blank_cols()} a logical vector: \code{TRUE} all rows of column are \emph{blank}, -otherwise \code{FALSE} +\item \code{\link[=is_blank]{is_blank()}} a \code{logical} vector indicating \emph{blank} elements in \code{x} +\item \code{\link[=select_blank_cols]{select_blank_cols()}} \code{x} with only columns that are all \emph{blank} +\item \code{\link[=remove_blank_cols]{remove_blank_cols()}} \code{x} without columns of only \emph{blank} +\item \code{\link[=is_blank_cols]{is_blank_cols()}} a logical vector: \code{TRUE} all rows of column are +\emph{blank}, otherwise \code{FALSE} } } \description{ diff --git a/man/clipboard.Rd b/man/clipboard.Rd index ec0fe3d2..0220579d 100644 --- a/man/clipboard.Rd +++ b/man/clipboard.Rd @@ -40,17 +40,20 @@ read_clipboard_methods() \item{method}{Method switch for loading the clipboard} } \value{ -\code{\link[=write_clipboard]{write_clipboard()}} None, called for side effects -\code{\link[=read_clipboard]{read_clipboard()}} Either a vector or \code{data.frame} (or \code{tibble}, if -depending on the \code{method} chosen. An empty clipboard value returns \code{NA} -(rather than \code{""}) +\itemize{ +\item \code{\link[=write_clipboard]{write_clipboard()}} None, called for side effects +\item \code{\link[=read_clipboard]{read_clipboard()}} Either a vector, \code{data.frame}, or \code{tibble} +depending on the \code{method} chosen. Unlike \code{\link[utils:clipboard]{utils::readClipboard()}}, an +empty clipboard value returns \code{NA} rather than \code{""} +} } \description{ Wrappers for working with the clipboard } \details{ -For copying and pasting floats, there may be some rounding that can -occur. +As these functions rely on \code{\link[clipr:read_clip]{clipr::read_clip()}} and +\code{\link[utils:clipboard]{utils::writeClipboard()}} they are only available for Windows 10. For +copying and pasting floats, there may be some rounding that can occur. } \examples{ # Will only run on windows diff --git a/man/complete_cases.Rd b/man/complete_cases.Rd index 10d0dc35..adbe2581 100644 --- a/man/complete_cases.Rd +++ b/man/complete_cases.Rd @@ -7,7 +7,7 @@ complete_cases(data, cols = NULL, invert = FALSE) } \arguments{ -\item{data}{A data.frame} +\item{data}{A \code{data.frame}} \item{cols}{Colnames or numbers to remove \code{NA} values from; \code{NULL} (default) will use all columns} diff --git a/man/counts.Rd b/man/counts.Rd index 8aeb4291..e3dcdca6 100644 --- a/man/counts.Rd +++ b/man/counts.Rd @@ -40,13 +40,13 @@ respectively) or \code{data.frame} with columns for each column chosen and the \code{.name} chosen for the summary } \description{ -Variables will be return by the order in which they appear. Even factors are -shown by their order of appearance in the vector. +Variables will be return by the order in which they appear. +Even factors are shown by their order of appearance in the vector. There are 2 methods for counting vectors. The \code{default} method uses -\code{base::tabulate()} (the workhorse for \code{base::table()} with a call to -\code{pseudo_id()} to transform all inputs into integers. The \code{logical} method -counts \code{TRUE}, \code{FALSE} and \code{NA} values, which is much quicker. +\code{\link[base:tabulate]{base::tabulate()}} (the workhorse for \code{\link[base:table]{base::table()}} with a call to +\code{\link[=pseudo_id]{pseudo_id()}} to transform all inputs into integers. The \code{logical} +method counts \code{TRUE}, \code{FALSE} and \code{NA} values, which is much quicker. } \details{ Get counts or proportions of unique observations in a vector or columns in a @@ -57,11 +57,11 @@ x <- sample(1:5, 10, TRUE) counts(x) props(x) -x <- quick_df(list( +x <- data.frame( a = c("a", "c", "a", "c", "d", "b"), b = c("a", "a", "a", "c", "c", "b"), c = c("a", "a", "a", "c", "b", "b") -)) +) counts(x, "a") counts(x, c("a", "b", "c")) diff --git a/man/depth.Rd b/man/depth.Rd index 79a733ff..42fc5da8 100644 --- a/man/depth.Rd +++ b/man/depth.Rd @@ -24,8 +24,8 @@ A single \code{integer} Functions to extract the 'depth' of an object } \details{ -This function does not count an empty lists (\code{list()}) as a level or \code{NULL} -objects. +This function does not count an empty lists (\code{\link[base:list]{base::list()}}) as a +level or \code{NULL} objects. } \examples{ a <- c(1, 2, 3) diff --git a/man/detail.Rd b/man/detail.Rd index fc0f5af0..983f69d4 100644 --- a/man/detail.Rd +++ b/man/detail.Rd @@ -28,11 +28,11 @@ Provides details about an object x <- sample(letters[1:4], 10, TRUE) detail(x) -df <- quick_df(list( +df <- data.frame( x = x, y = round(runif(10), 2), z = Sys.Date() + runif(10) * 100 -)) +) detail(df) } diff --git a/man/diff_time.Rd b/man/diff_time.Rd index 42876979..d99e284f 100644 --- a/man/diff_time.Rd +++ b/man/diff_time.Rd @@ -51,7 +51,7 @@ diff_time_myears(x, y, ...) \item{tzx, tzy}{time zones (see \strong{Time zones} section)} -\item{...}{Additional arguments passed to \code{diff_time()}} +\item{...}{Additional arguments passed to \code{\link[=diff_time]{diff_time()}}} } \value{ A \code{diff_time} vector, object @@ -71,10 +71,11 @@ passed to the \code{tz} parameter as a character vector } \section{Units}{ Units can be used beyond those available in -\code{base::difftime()}. Some of these use assumptions in how units of time +\code{\link[base:difftime]{base::difftime()}}. Some of these use assumptions in how units of time should be standardized and can be changed in the corresponding options. Any -of these can be calculated with \code{base::difftime()} through using \code{units = "days"} but the \code{dtime} class will print out with these specifications into -the console for less potential confusion. +of these can be calculated with \code{\link[base:difftime]{base::difftime()}} through using +\code{units = "days"} but the \code{dtime} class will print out with these +specifications into the console for less potential confusion. \describe{ \item{months}{Months by number of days \code{mark.days_in_month} (defaults: \code{30})} @@ -88,7 +89,7 @@ the console for less potential confusion. \section{Time zones}{ Time zones can be passed as either a numeric vector of GMT/UTC offsets (the number of seconds from GMT) or as a character vector. -If the letter, these need to conform with values from \code{base::OlsonNames()}. +If the letter, these need to conform with values from \code{\link[base:timezones]{base::OlsonNames()}}. A default timezone can be set with \code{options(mark.default_tz = .)}. The value can either be a numeric diff --git a/man/expand_by.Rd b/man/expand_by.Rd index dd753dfd..4db0c329 100644 --- a/man/expand_by.Rd +++ b/man/expand_by.Rd @@ -10,7 +10,7 @@ expand_by(x, y, expand = c("x", "y", "intersect", "both"), sort = FALSE) \item{x, y}{Vectors} \item{expand}{Character switch to expand or keep only the values that -intersect, all values in x or y, or retain all values found.} +intersect, all values in \code{x} or \code{y}, or retain all values found.} \item{sort}{Logical, if \code{TRUE} will sort by names in output} } diff --git a/man/fact.Rd b/man/fact.Rd index 241a2370..3567df6c 100644 --- a/man/fact.Rd +++ b/man/fact.Rd @@ -50,20 +50,20 @@ A vector of equal length of \code{x} with class \code{fact} and \code{factor}. Quickly create a factor } \details{ -\code{fact()} can be about 5 times quicker than \code{factor()} or -\code{as.factor()} as it doesn't bother sorting the levels for non-numeric data -or have other checks or features. It simply converts a vector to a factor -with all unique values as levels with \code{NA}s included. - -\code{fact.factor()} will perform several checks on a factor to include \code{NA} -levels and to check if the levels should be reordered to conform with the -other methods. The \code{fact.fact()} method simple returns \code{x}. +\code{\link[=fact]{fact()}} can be about 5 times quicker than \code{\link[base:factor]{base::factor()}} or +\code{\link[base:factor]{base::as.factor()}} as it doesn't bother sorting the levels for non-numeric +data or have other checks or features. It simply converts a vector to a +factor with all unique values as levels with \code{NA}s included. + +\code{\link[=fact.factor]{fact.factor()}} will perform several checks on a factor to include +\code{NA} levels and to check if the levels should be reordered to conform with +the other methods. The \code{\link[=fact.fact]{fact.fact()}} method simple returns \code{x}. } \section{level orders}{ -The order of the levels may be adjusted to these rules depending on the class -of \code{x}: +The order of the levels may be adjusted to these rules depending on the +class of \code{x}: \describe{ \item{\code{character}}{The order of appearance} \item{\code{numeric}/\code{integer}/\code{Date}/\code{POSIXt}}{By the numeric order} diff --git a/man/fct_expand_seq.Rd b/man/fct_expand_seq.Rd index 9f3b538e..748de045 100644 --- a/man/fct_expand_seq.Rd +++ b/man/fct_expand_seq.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_expand_seq.R +% Please edit documentation in R/fct-expand-seq.R \name{fct_expand_seq} \alias{fct_expand_seq} \title{Factor Expand by Sequence} diff --git a/man/file_utils.Rd b/man/file_utils.Rd index f9b60d6e..f70a2925 100644 --- a/man/file_utils.Rd +++ b/man/file_utils.Rd @@ -42,9 +42,9 @@ list_dirs( \item{ignore_case}{logical. Should pattern-matching be case-insensitive?} -\item{all}{a logical value. If FALSE, only the names of visible files are +\item{all}{a logical value. If \code{FALSE}, only the names of visible files are returned (following Unix-style visibility, that is files whose name does -not start with a dot). If TRUE, all file names will be returned.} +not start with a dot). If \code{TRUE}, all file names will be returned.} \item{negate}{Logical, if \code{TRUE} will inversely select files that do not match the provided pattern} @@ -54,19 +54,20 @@ the entire path} } \value{ \itemize{ -\item \code{open_file()}, \code{shell_exec()}: A logical vector where \code{TRUE} successfully -opened, \code{FALSE} did not and \code{NA} did not try to open (file not found) -\item \code{list_files()}, \code{list_dirs()}: A vector of full paths +\item \code{\link[=open_file]{open_file()}}, \code{\link[=shell_exec]{shell_exec()}}: A logical vector where \code{TRUE} +successfully opened, \code{FALSE} did not and \code{NA} did not try to open (file not +found) +\item \code{\link[=list_files]{list_files()}}, \code{\link[=list_dirs]{list_dirs()}}: A vector of full paths } } \description{ Opens the given files(s) } \details{ -\code{open_file} is an alternative to \code{shell.exec()} that can take take -multiple files. \code{list_files} and \code{list_dirs} are mostly wrappers for -\code{\link[fs:dir_ls]{fs::dir_ls()}} with preferred defaults and pattern searching on the full file -path. +\code{\link[=open_file]{open_file()}} is an alternative to \code{base::shell.exec()} that +can take take multiple files. \code{\link[=list_files]{list_files()}} and \code{\link[=list_dirs]{list_dirs()}} +are mostly wrappers for \code{\link[fs:dir_ls]{fs::dir_ls()}} with preferred defaults and pattern +searching on the full file path. -\code{file_open} is simply an alias. +\code{\link[=file_open]{file_open()}} is simply an alias. } diff --git a/man/fizzbuzz.Rd b/man/fizzbuzz.Rd index 3e4fd656..60f9da16 100644 --- a/man/fizzbuzz.Rd +++ b/man/fizzbuzz.Rd @@ -30,10 +30,10 @@ that the quickest way to do it is to just take the work someone else did and utilize that. No reason to reinvent the wheel. } \details{ -Multiples of \code{3} are shown as \code{"Fizz"}; multiples of \code{5} as \code{"Buzz"}; -multiple of both (i.e., \code{15}) are \code{"FizzBuzz"}. -\code{fizzbuzz_lazy()} subsets the \code{.fizzbuzz_vector} object, which is a solution -with default parameters up to \code{1e6} +Multiples of \code{3} are shown as \code{"Fizz"}; multiples of \code{5} as +\code{"Buzz"}; multiple of both (i.e., \code{15}) are \code{"FizzBuzz"}. +\code{\link[=fizzbuzz_lazy]{fizzbuzz_lazy()}} subsets the \code{.fizzbuzz_vector} object, which is a +solution with default parameters up to \code{1e6} } \examples{ fizzbuzz(15) diff --git a/man/get_version.Rd b/man/get_version.Rd index 8c8e7179..06de5122 100644 --- a/man/get_version.Rd +++ b/man/get_version.Rd @@ -23,19 +23,19 @@ automatically update.} } \value{ \itemize{ -\item \code{get_version()}: A package_version -\item \code{bump_version()}: None, called for its side-effects -\item \code{bump_date_version()}: None, called for its side-effects -\item \code{update_version()}: None, called for its side-effects +\item \code{\link[=get_version]{get_version()}}: A package_version +\item \code{\link[=bump_version]{bump_version()}}: None, called for its side-effects +\item \code{\link[=bump_date_version]{bump_date_version()}}: None, called for its side-effects +\item \code{\link[=update_version]{update_version()}}`: None, called for its side-effects } } \description{ Will read the \code{DESCRIPTION} file and to get and adjust the version -\code{bump_date_version()} will not check if the version is actually a date. When -the current version is the same as today's date(equal by character strings) -it will append a \code{.1}. +\code{\link[=bump_date_version]{bump_date_version()}} will not check if the version is actually a +date. When the current version is the same as today's date (equal by +character strings) it will append a \code{.1}. } \details{ Get and bump package version for dates diff --git a/man/glob.Rd b/man/glob.Rd index 565eac8d..8a5c9f61 100644 --- a/man/glob.Rd +++ b/man/glob.Rd @@ -11,8 +11,9 @@ glob(x, pattern = NULL, value = TRUE, ...) \item{pattern}{Wildcard globbing pattern} -\item{value, ...}{Additional parameters passed to \code{grep}. Note: \code{value} is by -default \code{TRUE}; when \code{NA}, \code{...} is passed to \code{grepl}.} +\item{value, ...}{Additional parameters passed to \code{\link[base:grep]{base::grep()}}. Note: +\code{value} is by default \code{TRUE}; when \code{NA}, \code{...} is passed to +\code{\link[base:grep]{base::grep()}}`.} } \description{ Helper function for globbing character vectors diff --git a/man/import.Rd b/man/import.Rd index a0608245..cb07384a 100644 --- a/man/import.Rd +++ b/man/import.Rd @@ -11,7 +11,7 @@ import(pkg, fun, overwrite = FALSE) \item{fun}{String, fun name of the function} -\item{overwrite}{Logical, if TRUE and \code{fun} is also found in the current +\item{overwrite}{Logical, if \code{TRUE} and \code{fun} is also found in the current environment, will overwrite assignment} } \value{ diff --git a/man/labels.Rd b/man/labels.Rd index df4a0e0c..30c3ff7d 100644 --- a/man/labels.Rd +++ b/man/labels.Rd @@ -44,13 +44,13 @@ remove_labels(x, ...) \item{...}{One or more unquoted expressed separated by commas. If assigning to a data.frame, \code{...} can be replaced with a \code{data.frame} where the first -column is the targeted colname and the second is the desired label.} +column is the targeted column name and the second is the desired label.} \item{label}{A single length string of a label to be assigned} -\item{.missing}{A control setting for dealing missing columns in a list; -can be set to \code{error} to \code{stop()} the call, \code{warn} to provide a warning, or -\code{skip} to silently skip those labels.} +\item{.missing}{A control setting for dealing missing columns in a list; can +be set to \code{"error"} to \code{\link[base:stop]{base::stop()}} the call, \code{"warn"} to provide a +warning, or \code{"skip"} to silently skip those labels.} \item{.ls}{A named list of columns and labels to be set if \code{...} is empty} @@ -67,9 +67,9 @@ A labelled vector or \code{data.frame} Assign labels to a vector or data.frame. } \details{ -When labels are assigned to a data.frame they can make viewing the object -(with \code{View()} inside Rstudio). The \code{view_labels()} has a call to \code{View()} -inside and will retrieve the labels and show them in the viewer as a +When labels are assigned to a data.frame they can make viewing the +object (with \code{View()} inside Rstudio). \code{\link[=view_labels]{view_labels()}} has a call to +\code{View()} inside and will retrieve the labels and show them in the viewer as a data.frame. } \examples{ diff --git a/man/lines_of_r_code.Rd b/man/lines_of_r_code.Rd index dfd5576f..9baa5238 100644 --- a/man/lines_of_r_code.Rd +++ b/man/lines_of_r_code.Rd @@ -2,25 +2,25 @@ % Please edit documentation in R/lines-of-code.R \name{lines_of_r_code} \alias{lines_of_r_code} -\title{Lines of R code} +\title{Lines of \strong{R} code} \usage{ lines_of_r_code(x = ".", skip_empty = TRUE) } \arguments{ \item{x}{Directory to search for files} -\item{skip_empty}{Logical, if TRUE will not count lines that are empty or +\item{skip_empty}{Logical, if \code{TRUE} will not count lines that are empty or only contain a bracket or quotation mark.} } \value{ An \code{integer} for the number of lines in all applicable files } \description{ -Find the total number of lines of R code +Find the total number of lines of \strong{R} code } \details{ -Tries to read each file in the directory that ends in .R or .r and sums -together. Files that fail to read are not counted. +Tries to read each file in the directory that ends in \code{.R} or \code{.r} +and sums together. Files that fail to read are not counted. } \examples{ \donttest{ diff --git a/man/list2df.Rd b/man/list2df.Rd index a3575823..b83251d1 100644 --- a/man/list2df.Rd +++ b/man/list2df.Rd @@ -4,38 +4,34 @@ \alias{list2df} \title{List to data.frame} \usage{ -list2df(x, name = "name", value = "value", show_NA, warn = TRUE) +list2df(x, name = "name", value = "value", warn = TRUE) } \arguments{ \item{x}{A (preferably) named \code{list} with any number of values} \item{name, value}{Names of the new key and value columns, respectively} -\item{show_NA}{Ignored; if set will trigger a warning} - -\item{warn}{Logical; if TRUE will show a warning when} +\item{warn}{Logical; if \code{TRUE} will show a warning when} } \value{ a \code{data.frame} object with columns \code{"name"} and \code{"value"} for the names of the \code{list} and the values in each } \description{ -Converts a list object into a data.frame +Converts a list object into a \code{data.frame} } \details{ -Unlike \code{base::list2DF()}, \code{list2df()} tries to format the data.frame by using -the names of the list as values rather than variables. This creates a -longer form list that may be more tidy. +Unlike \code{\link[base:list2DF]{base::list2DF()}}, \code{\link[=list2df]{list2df()}} tries to format the +\code{data.frame} by using the names of the list as values rather than +variables. This creates a longer form list that may be more tidy. } \examples{ x <- list(a = 1, b = 2:4, c = letters[10:20], "unnamed", "unnamed2") list2df(x, "col1", "col2", warn = FALSE) -if (getRversion() >= as.package_version('4.0')) { # contrast with `base::list2DF()` and `base::as.data.frame()` - x <- list(a = 1:3, b = 2:4, c = letters[10:12]) - list2df(x, warn = FALSE) - list2DF(x) - as.data.frame(x) -} +x <- list(a = 1:3, b = 2:4, c = letters[10:12]) +list2df(x, warn = FALSE) +list2DF(x) +as.data.frame(x) } diff --git a/man/list_environments.Rd b/man/list_environments.Rd index fe061c91..83eae7b3 100644 --- a/man/list_environments.Rd +++ b/man/list_environments.Rd @@ -20,21 +20,24 @@ objects_all(all.names = FALSE) } \value{ \itemize{ -\item \code{environments()}: Invisibly, a \code{character} vector of environment names +\item \code{\link[=environments]{environments()}}: Invisibly, a \code{character} vector of environment +names } \itemize{ -\item \code{ls_all()}, \code{objects_all()}: A named list for each of the environments -the \code{search()} path with all the objects found in that environment +\item \code{\link[=ls_all]{ls_all()}}, \code{\link[=objects_all]{objects_all()}}: A named list for each of the +environments the \code{\link[base:search]{base::search()}} path with all the objects found in that +environment } } \description{ Functions to list out all environments and objects } \details{ -\code{environments()} is basically a printing wrapper for \code{base::search()} +\code{\link[=environments]{environments()}} is basically a printing wrapper for +\code{\link[base:search]{base::search()}} -\code{ls_all()} and \code{objects_all()} can be used retrieved all objects from all -environments in the \code{search()} path, which may print out a large result -into the console. +\code{\link[=ls_all]{ls_all()}} and \code{\link[=objects_all]{objects_all()}} can be used retrieved all +objects from all environments in the \code{\link[base:search]{base::search()}} path, which may print +out a large result into the console. } diff --git a/man/logic_ext.Rd b/man/logic_ext.Rd index a974c201..707d434a 100644 --- a/man/logic_ext.Rd +++ b/man/logic_ext.Rd @@ -61,26 +61,27 @@ isNA(x) } \value{ \itemize{ -\item \code{is_true()}, \code{is_false()}, \code{either()}, \verb{\%or\%}, \code{nor}, \code{nand}, \code{xandr}, -\code{AND()}, \code{OR()}: A \code{logical} vector, equal length of \code{x} (or \code{y} or of all -\code{...} lengths) -\item \code{is_boolean()}, \code{isNA()}, \code{none()}: A single \code{logical} value +\item \code{\link[=is_true]{is_true()}}, \code{\link[=is_false]{is_false()}}, \code{\link[=either]{either()}}, \link{\%xor\%}, +\code{\link[=AND]{AND()}}, \code{\link[=OR]{OR()}}: A \code{logical} vector, equal length of \code{x} (or \code{y} +or of all \code{...} lengths) +\item \code{\link[=is_boolean]{is_boolean()}}: \code{TRUE} or \code{FALSE} +\item \code{\link[=none]{none()}}: \code{TRUE}, \code{FALSE}, or \code{NA} } } \description{ -All functions take logical or logical-like (i.e., 1, 0, or NA as -integer or doubles) and return logical values. +All functions take logical or logical-like (i.e., \code{1}, \code{0}, or +\code{NA} as integer or doubles) and return logical values. Extensions to the base logical operations to account for \code{NA} values. -\code{\link[base:Logic]{base::isTRUE()}} and \code{\link[base:Logic]{base::isFALSE()}} will only return single length \code{TRUE} -or \code{FALSE} as it checks for valid lengths in the evaluation. When needing to -check over a vector for the presence of \code{TRUE} or \code{FALSE} and not being held -back by \code{NA} values, \code{is_true} and \code{is_false} will always provide a \code{TRUE} -\code{FALSE} when the vector is logical or return \code{NA} is the vector \code{x} is not -logical. +\code{\link[base:Logic]{base::isTRUE()}} and \code{\link[base:Logic]{base::isFALSE()}} will only return single length +\code{TRUE} or \code{FALSE} as it checks for valid lengths in the evaluation. When +needing to check over a vector for the presence of \code{TRUE} or \code{FALSE} and +not being held back by \code{NA} values, \code{\link[=is_true]{is_true()}} and +\code{\link[=is_false]{is_false()}} will always provide a \code{TRUE} \code{FALSE} when the vector is +logical or return \code{NA} is the vector \code{x} is not logical. -\verb{\%xor\%} is just a wrapper for \code{\link[base:Logic]{base::xor()}} +\link{\%xor\%} is just a wrapper for \code{\link[base:Logic]{base::xor()}} } \details{ Logical operations, extended diff --git a/man/make_sf.Rd b/man/make_sf.Rd index bf2940bc..b5b452e8 100644 --- a/man/make_sf.Rd +++ b/man/make_sf.Rd @@ -10,7 +10,7 @@ make_sf(package) \item{package}{The name of the package} } \value{ -A \code{function} wrapping \code{\link[=system.file]{system.file()}} which will always use the +A \code{function} wrapping \code{system.file()} which will always use the package name provided in \code{package} } \description{ diff --git a/man/mark-cnd-conditions.Rd b/man/mark-cnd-conditions.Rd new file mode 100644 index 00000000..e201fb29 --- /dev/null +++ b/man/mark-cnd-conditions.Rd @@ -0,0 +1,347 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mark-cnd-conditions.R +\name{mark-cnd-conditions} +\alias{mark-cnd-conditions} +\alias{mark:append_warning} +\alias{mark:assign_labels_error} +\alias{mark:base_conversion_error} +\alias{mark:description_version_error} +\alias{mark:fct_expand_seq_error} +\alias{mark:import_error} +\alias{mark:internal_error} +\alias{mark:list2df_warning} +\alias{mark:match_arg_error} +\alias{mark:match_param_error} +\alias{mark:md5_condition} +\alias{mark:na_timezone_found_warning} +\alias{mark:not_available_error} +\alias{mark:numeric_datetime_tz_error} +\alias{mark:options_error} +\alias{mark:path_error} +\alias{mark:path_warning} +\alias{mark:reindex_error} +\alias{mark:reindex_warning} +\alias{mark:source_error} +\alias{mark:switch_error} +\alias{mark:timezone_not_found_error} +\alias{mark:view_labels_error} +\alias{append_warning} +\alias{assign_labels_error} +\alias{base_conversion_error} +\alias{description_version_error} +\alias{fct_expand_seq_error} +\alias{import_error} +\alias{internal_error} +\alias{list2df_warning} +\alias{match_arg_error} +\alias{match_param_error} +\alias{md5_condition} +\alias{na_timezone_found_warning} +\alias{not_available_error} +\alias{numeric_datetime_tz_error} +\alias{options_error} +\alias{path_error} +\alias{path_warning} +\alias{reindex_error} +\alias{reindex_warning} +\alias{source_error} +\alias{switch_error} +\alias{timezone_not_found_error} +\alias{view_labels_error} +\alias{mark:append_warning/warning} +\alias{mark:assign_labels_error/error} +\alias{mark:base_conversion_error/error} +\alias{mark:description_version_error/error} +\alias{mark:fct_expand_seq_error/error} +\alias{mark:import_error/error} +\alias{mark:internal_error/error} +\alias{mark:list2df_warning/warning} +\alias{mark:match_arg_error/error} +\alias{mark:match_param_error/error} +\alias{mark:md5_condition/condition} +\alias{mark:na_timezone_found_warning/warning} +\alias{mark:not_available_error/error} +\alias{mark:numeric_datetime_tz_error/error} +\alias{mark:options_error/error} +\alias{mark:path_error/error} +\alias{mark:path_warning/warning} +\alias{mark:reindex_error/error} +\alias{mark:reindex_warning/warning} +\alias{mark:source_error/error} +\alias{mark:switch_error/condition} +\alias{mark:timezone_not_found_error/error} +\alias{mark:view_labels_error/error} +\title{Conditions for \code{mark}} +\description{ +Conditions for \code{mark} +} +\details{ +The following conditions are defined in the \code{{mark}} package. +} +\section{\code{{cnd}}}{ + +These conditions are made with the \code{\link[cnd:cnd-package]{\{cnd\}}} package though the +use of \code{\link[cnd:condition]{cnd::condition()}}. +} + +\section{\code{{mark}} conditions}{ + + +\subsection{\code{mark:append_warning/warning}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:append_warning}} +\item{type}{\strong{warning}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:assign_labels_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:assign_labels_error}} +\item{type}{\strong{error}} +} +\code{assign_labels_error} + +\strong{Columns not found} +You can set \code{.missing} to \code{warn} to get a warning instead of an error, or \code{skip} to silently skip those labels. + +\strong{Malformed labels} +If passing labels as \code{.ls}, \code{...} must be empty. Columns in \code{...} must be entered as \code{name = value}; \code{column = label}. + +\if{html}{\out{
}}\preformatted{# instead of this: +assign_labels(df, a = 'AAA', .ls = list(b = 'BBB')) + +# do this: +assign_labels(df, a = 'AAA', b = 'BBB') +# or this: +assign_labels(df, .ls = list(a = 'AAA', b = 'BBB')) +}\if{html}{\out{
}} + +Labels must not be null; to remove labels, use \code{remove_labels()}. + +\if{html}{\out{
}}\preformatted{# instead of this +assign_labels(df, a = 'AAA', b = NULL) + +# do this +df <- assign_labels(df, a = 'AAA') +df <- remove_labels(df, 'b') +}\if{html}{\out{
}} + +} +\subsection{\code{mark:base_conversion_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:base_conversion_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:description_version_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:description_version_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:fct_expand_seq_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:fct_expand_seq_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:import_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:import_error}} +\item{type}{\strong{error}} +} +The object you are trying to import has already been assigned in the environment you are importing to. Use the \code{overwrite} option to replace the object. + +For example: + +\if{html}{\out{
}}\preformatted{# instead of +foo <- NULL +import('package', 'foo') + +# do this +foo <- NULL +import('package', 'foo', overwrite = TRUE) +}\if{html}{\out{
}} + +} +\subsection{\code{mark:internal_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:internal_error}} +\item{type}{\strong{error}} +} +Generic error to capture internal \code{{mark}} errors. If any of these are encountered, please report an issue at \url{https://github.com/jmbarbone/mark/issues} +} +\subsection{\code{mark:list2df_warning/warning}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:list2df_warning}} +\item{type}{\strong{warning}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:match_arg_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:match_arg_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:match_param_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:match_param_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:md5_condition/condition}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:md5_condition}} +\item{type}{\strong{condition}} +} +Produces messages on md5 checks when \code{file_copy_md5(quiet = FALSE)}. +The message will indicate whether the file was new, or if the md5 hash was the same or different. +When \code{quiet = TRUE}, no messages will be produced. +} +\subsection{\code{mark:na_timezone_found_warning/warning}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:na_timezone_found_warning}} +\item{type}{\strong{warning}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:not_available_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:not_available_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:numeric_datetime_tz_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:numeric_datetime_tz_error}} +\item{type}{\strong{error}} +} + +\if{html}{\out{
}}\preformatted{# Instead of this: +diff_time(100, 200, tz = NULL) + +# do this: +diff_time(100, 200, tz = 'America/New_York') + +# or: +diff_time(100, 200, tz = 0) +}\if{html}{\out{
}} + +} +\subsection{\code{mark:options_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:options_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:path_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:path_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:path_warning/warning}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:path_warning}} +\item{type}{\strong{warning}} +} +File creation cannot be performed when the path is an existing directory +} +\subsection{\code{mark:reindex_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:reindex_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:reindex_warning/warning}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:reindex_warning}} +\item{type}{\strong{warning}} +} +NA values in index may cause errors with expansion + +\code{reindex()} will not match on NA values but instead will return a row of NAs + +\if{html}{\out{
}}\preformatted{x <- data.frame(index = c(1:2, NA, 4:5), values = letters[1:5]) +reindex(x, 'index', c(1, 2, 5)) +#> index values +#> 1 1 a +#> 2 2 b +#> 5 5 e + +reindex(x, 'index', c(1, 2, 5, NA)) +#> index values +#> 1 1 a +#> 2 2 b +#> 5 5 e +#> NA +}\if{html}{\out{
}} + +} +\subsection{\code{mark:source_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:source_error}} +\item{type}{\strong{error}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:switch_error/condition}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:switch_error}} +\item{type}{\strong{condition}} +} +\emph{no help documentation provided} +} +\subsection{\code{mark:timezone_not_found_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:timezone_not_found_error}} +\item{type}{\strong{error}} +} +When using a string for a timezone, this value must be found within \code{OlsonNames()} +} +\subsection{\code{mark:view_labels_error/error}}{ +\describe{ +\item{package}{\code{{mark}}} +\item{class}{\code{mark:view_labels_error}} +\item{type}{\strong{error}} +} +This may be because you are using RStudio : https://community.rstudio.com/t/view-is-causing-an-error/75297/4 You can try : \code{utils::View(get_labels(x), title = "Labels")} +} +} + +\seealso{ +\link[cnd:cnd-package]{cnd::cnd-package} \link[cnd:condition]{cnd::condition} +} +\keyword{internal} diff --git a/man/match_arg.Rd b/man/match_arg.Rd index 7f9ea93b..07e82600 100644 --- a/man/match_arg.Rd +++ b/man/match_arg.Rd @@ -24,13 +24,13 @@ Match arguments } \examples{ x <- c("apple", "banana", "orange") -match_arg("b", x) +suppressWarnings(match_arg("b", x), "deprecatedWarning") # Produces error -try(match_arg("pear", x)) +suppressWarnings(try(match_arg("pear", x)), "deprecatedWarning") foo <- function(x, op = c(1, 2, 3)) { - op <- match_arg(op) + op <- suppressWarnings(match_arg(op), "deprecatedWarning") x / op } diff --git a/man/match_param.Rd b/man/match_param.Rd index 7d27a355..674b8f19 100644 --- a/man/match_param.Rd +++ b/man/match_param.Rd @@ -23,7 +23,7 @@ value when matched to the RHS of the formula.} \item{null}{If \code{TRUE} allows \code{NULL} to be passed a \code{param}} -\item{partial}{If \code{TRUE} allows partial matching via \code{\link[=pmatch]{pmatch()}}} +\item{partial}{If \code{TRUE} allows partial matching via \code{\link[base:pmatch]{base::pmatch()}}} \item{multiple}{If \code{TRUE} allows multiple values to be returned} @@ -42,6 +42,23 @@ Much like \code{\link[base:match.arg]{base::match.arg()}} with a few key differe \details{ Param matching for an argument } +\section{Conditions}{ + + +Conditions are generated through the \code{\link[cnd:cnd-package]{\{cnd\}}} package. +The following conditions are associated with this function: + +\describe{ + +\item{\code{\link[=mark-cnd-conditions]{mark:match_param_error/error}}}{ + +} + +} + +For more conditions, see: \link{mark-cnd-conditions} +} + \examples{ fruits <- function(x = c("apple", "banana", "orange")) { match_param(x) diff --git a/man/median2.Rd b/man/median2.Rd index e6015cc8..90ebddfb 100644 --- a/man/median2.Rd +++ b/man/median2.Rd @@ -22,7 +22,7 @@ q50(x, type = 7, na.rm = FALSE) are removed from \code{x} before the quantiles are computed.} } \value{ -See \code{stats::quantile()} +See \code{\link[stats:quantile]{stats::quantile()}} } \description{ Median as the 50th quantile with an option to select quantile algorithm diff --git a/man/merge_list.Rd b/man/merge_list.Rd index 51a5651c..32ded4b4 100644 --- a/man/merge_list.Rd +++ b/man/merge_list.Rd @@ -4,7 +4,13 @@ \alias{merge_list} \title{Merge lists} \usage{ -merge_list(x, y, keep = c("x", "y"), null = c("ignore", "drop", "keep")[1:2]) +merge_list( + x, + y, + keep = c("x", "y"), + null = c("ignore", "drop", "keep")[1:2], + sort = TRUE +) } \arguments{ \item{x, y}{Lists to merge} @@ -24,6 +30,9 @@ output. \item \code{"keep"}: \code{NULL} values are retained in the output and can override other values. }} + +\item{sort}{When \code{TRUE} (default) will sort the output by names; otherwise +will retain the order of \code{x} and \code{y} with \code{x} values first.} } \description{ Merge lists with different or intersecting names diff --git a/man/norm_path.Rd b/man/norm_path.Rd index 034c6ce7..ea47ce50 100644 --- a/man/norm_path.Rd +++ b/man/norm_path.Rd @@ -15,10 +15,10 @@ user_file(..., check = FALSE, remove = check) \arguments{ \item{x}{A character vector of paths} -\item{check}{Logical, if TRUE will check if the path exists and output a +\item{check}{Logical, if \code{TRUE} will check if the path exists and output a warning if it does not.} -\item{remove}{Logical, if TRUE will remove paths that are not found} +\item{remove}{Logical, if \code{TRUE} will remove paths that are not found} \item{...}{Character vectors for creating a path} } diff --git a/man/normalize.Rd b/man/normalize.Rd index 06039cbe..dc7c091e 100644 --- a/man/normalize.Rd +++ b/man/normalize.Rd @@ -37,9 +37,9 @@ The largest and smallest values are then used to determine the minimum/maximum values and lower/upper bounds. This allows for a vector of more than two values to be passed. -The current implementation of \code{normalize.data.frame()} allows for \code{list} of -parameters passed for each column. However, it is probably best suited for -default values. +The current implementation of \code{\link[=normalize.data.frame]{normalize.data.frame()}} allows for +\code{list} of parameters passed for each column. However, it is probably best +suited for default values. } \examples{ x <- c(0.23, 0.32, 0.12, 0.61, 0.26, 0.24, 0.23, 0.32, 0.29, 0.27) diff --git a/man/package_available.Rd b/man/package_available.Rd index dda89bb7..08243da1 100644 --- a/man/package_available.Rd +++ b/man/package_available.Rd @@ -11,10 +11,10 @@ package_available(namespace) } \value{ \itemize{ -\item \code{require_namespace()}: None, called for side effects -\item \code{package_available()}: Visibly, \code{TRUE} or \code{FALSE} +\item \code{\link[=require_namespace]{require_namespace()}}: None, called for side effects +\item \code{\link[=package_available]{package_available()}}: Visibly, \code{TRUE} or \code{FALSE} } } \description{ -A wrapped requireNamespace +A wrapped \code{\link[base:ns-load]{base::requireNamespace()}} } diff --git a/man/print.pseudo_id.Rd b/man/print.pseudo_id.Rd index d1ee9912..c88d6df6 100644 --- a/man/print.pseudo_id.Rd +++ b/man/print.pseudo_id.Rd @@ -7,7 +7,7 @@ \method{print}{pseudo_id}(x, ..., all = FALSE) } \arguments{ -\item{x}{An object of class \link{pseudo_id}} +\item{x}{An object of class \code{pseudo_id}} \item{...}{Not implemented} diff --git a/man/print_c.Rd b/man/print_c.Rd index 8077d92b..72301bb0 100644 --- a/man/print_c.Rd +++ b/man/print_c.Rd @@ -9,9 +9,10 @@ print_c(x = read_clipboard(), sorted = TRUE, null = TRUE) \arguments{ \item{x}{A vector (defaults to reading the clipboard)} -\item{sorted}{If \code{TRUE} (default) applies \code{sort()} to \code{x}} +\item{sorted}{If \code{TRUE} (default) applies \code{\link[base:sort]{base::sort()}} to \code{x}} -\item{null}{If \code{TRUE} (default) adds \code{NULL} at the end of the \code{c()} print} +\item{null}{If \code{TRUE} (default) adds \code{NULL} at the end of the \code{\link[base:c]{base::c()}} +print} } \value{ Invisibly, as a \code{character} vector, the object printed to the console @@ -20,10 +21,10 @@ Invisibly, as a \code{character} vector, the object printed to the console Prints a vector to paste into an R script } \details{ -This sorts (if set) and provides unique values for each element in \code{x} and -prints then as a call to \code{c}. This can be useful for copying data that you -want to save as a vector in an R script. -The result is both called in \code{cat()} as well as copied to the clipboard. +This sorts (if set) and provides unique values for each element in +\code{x} and prints then as a call to \code{\link[base:c]{base::c()}}. This can be useful for +copying data that you want to save as a vector in an \strong{R} script. The +result is both called in \code{\link[base:cat]{base::cat()}} as well as copied to the clipboard. } \examples{ print_c(1:10) diff --git a/man/quiet_stop.Rd b/man/quiet_stop.Rd index bdfa6d8e..c2dc7ac8 100644 --- a/man/quiet_stop.Rd +++ b/man/quiet_stop.Rd @@ -10,5 +10,5 @@ quiet_stop() None, called for side effects } \description{ -Quietly calls stop +Quietly calls \code{\link[base:stop]{base::stop()}} } diff --git a/man/range2.Rd b/man/range2.Rd index 40f42444..49060112 100644 --- a/man/range2.Rd +++ b/man/range2.Rd @@ -16,8 +16,8 @@ A \code{numeric} vector of length 2 of the minimum and maximum values, respectively } \description{ -Employs \code{min()} and \code{max()}. However, \code{\link[base:range]{base::range()}}, there is no argument -for removing \code{Inf} values. +Employs \code{\link[base:Extremes]{base::min()}} and \code{\link[base:Extremes]{base::max()}}. However, \code{\link[base:range]{base::range()}}, there is +no argument for removing \code{Inf} values. } \examples{ \donttest{ diff --git a/man/read_bib.Rd b/man/read_bib.Rd index c4dca3ab..edb684e1 100644 --- a/man/read_bib.Rd +++ b/man/read_bib.Rd @@ -13,7 +13,7 @@ read_bib(file, skip = 0L, max_lines = NULL, encoding = "UTF-8") \item{max_lines}{The maximum number of lines to read} -\item{encoding}{Assumed encoding of file (passed to \code{\link[=readLines]{readLines()}}} +\item{encoding}{Assumed encoding of file (passed to \code{\link[base:readLines]{base::readLines()}}} } \value{ A \code{data.frame} with each row as a bib entry and each column as a diff --git a/man/reexports.Rd b/man/reexports.Rd index eb1029f6..e31cd8b3 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -36,7 +36,7 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{fuj}{\code{\link[fuj:colons]{\%:::\%}}, \code{\link[fuj:colons]{\%::\%}}, \code{\link[fuj:if_null]{\%||\%}}, \code{\link[fuj:colons]{\%colons\%}}, \code{\link[fuj:if_null]{\%len\%}}, \code{\link[fuj:names]{\%names\%}}, \code{\link[fuj:match_ext]{\%out\%}}, \code{\link[fuj:match_ext]{\%wi\%}}, \code{\link[fuj:match_ext]{\%wo\%}}, \code{\link[fuj:match_ext]{any_match}}, \code{\link[fuj]{exattr}}, \code{\link[fuj]{flip}}, \code{\link[fuj:os]{is_linux}}, \code{\link[fuj:os]{is_macos}}, \code{\link[fuj:names]{is_named}}, \code{\link[fuj:os]{is_windows}}, \code{\link[fuj]{muffle}}, \code{\link[fuj:match_ext]{no_match}}, \code{\link[fuj]{quick_df}}, \code{\link[fuj:quick_df]{quick_dfl}}, \code{\link[fuj:names]{remove_names}}, \code{\link[fuj]{require_namespace}}, \code{\link[fuj:names]{set_names}}, \code{\link[fuj]{struct}}, \code{\link[fuj:muffle]{wuffle}}} + \item{fuj}{\code{\link[fuj:colons]{\%::\%}}, \code{\link[fuj:colons]{\%:::\%}}, \code{\link[fuj:colons]{\%colons\%}}, \code{\link[fuj:if_null]{\%len\%}}, \code{\link[fuj:names]{\%names\%}}, \code{\link[fuj:match_ext]{\%out\%}}, \code{\link[fuj:match_ext]{\%wi\%}}, \code{\link[fuj:match_ext]{\%wo\%}}, \code{\link[fuj:if_null]{\%||\%}}, \code{\link[fuj:match_ext]{any_match}}, \code{\link[fuj]{exattr}}, \code{\link[fuj]{flip}}, \code{\link[fuj:os]{is_linux}}, \code{\link[fuj:os]{is_macos}}, \code{\link[fuj:names]{is_named}}, \code{\link[fuj:os]{is_windows}}, \code{\link[fuj]{muffle}}, \code{\link[fuj:match_ext]{no_match}}, \code{\link[fuj]{quick_df}}, \code{\link[fuj:quick_df]{quick_dfl}}, \code{\link[fuj:names]{remove_names}}, \code{\link[fuj]{require_namespace}}, \code{\link[fuj:names]{set_names}}, \code{\link[fuj]{struct}}, \code{\link[fuj:muffle]{wuffle}}} \item{magrittr}{\code{\link[magrittr:pipe]{\%>\%}}} }} diff --git a/man/rscript.Rd b/man/rscript.Rd index 64a4a9e3..620b1bb0 100644 --- a/man/rscript.Rd +++ b/man/rscript.Rd @@ -13,14 +13,14 @@ rscript(x, ops = NULL, args = NULL, ...) \item{args}{A character vector of other arguments to pass} -\item{...}{Additional arguments passed to \code{system2}} +\item{...}{Additional arguments passed to \code{\link[base:system2]{base::system2()}}} } \value{ A \code{character} vector of the result from calling \code{Rscript} via \code{system2()} } \description{ -Implements \code{Rscript} with \code{system2} +Implements \code{Rscript} with \code{\link[base:system2]{base::system2()}} } \seealso{ \link{source_to_env} diff --git a/man/source_to_env.Rd b/man/source_to_env.Rd index daeb20e4..d8a655dc 100644 --- a/man/source_to_env.Rd +++ b/man/source_to_env.Rd @@ -9,7 +9,7 @@ source_to_env(x, ops = NULL) \arguments{ \item{x}{An R script} -\item{ops}{Options to be passed to \link{rscript}} +\item{ops}{Options to be passed to \code{\link[=rscript]{rscript()}}} } \value{ Invisibly, and environment variable of the objects/results created diff --git a/man/sourcing.Rd b/man/sourcing.Rd index 9d474f78..bce399b6 100644 --- a/man/sourcing.Rd +++ b/man/sourcing.Rd @@ -20,7 +20,7 @@ try_ksource(file, ...) \item{quiet}{Logical; Determines whether to apply silence to \code{\link[knitr:knit]{knitr::purl()}}} -\item{cd}{Logical; if TRUE, the R working directory is temporarily +\item{cd}{Logical; if \code{TRUE}, the \strong{R} working directory is temporarily changed to the directory containing file for evaluating} \item{env}{An environment determining where the parsed expressions are @@ -28,17 +28,18 @@ evaluated} } \value{ \itemize{ -\item \code{ksource()}: Invisibly, the result of calling \code{source()} on the \code{.R} file conversion of \code{file} -\item \code{try_source()}, \code{try_ksource()}: attempts of \code{source()} and \code{ksource()} but converts errors to warnings +\item \code{\link[=ksource]{ksource()}}: Invisibly, the result of calling \code{\link[base:source]{base::source()}} on +the \code{.R} file conversion of \code{file} +\item \code{\link[=try_source]{try_source()}}, \code{\link[=try_ksource]{try_ksource()}}: attempts of \code{\link[base:source]{base::source()}} +and \code{\link[=ksource]{ksource()}} but converts errors to warnings } } \description{ Functions for extending sourcing features } \details{ -\code{try_source()} will output an error message rather than completely preventing -the execution. -This can be useful for when a script calls on multiple, independent files to -be sourced and a single failure shouldn't prevent the entire run to fail as -well. +\code{\link[=try_source]{try_source()}} will output an error message rather than +completely preventing the execution. This can be useful for when a script +calls on multiple, independent files to be sourced and a single failure +shouldn't prevent the entire run to fail as well. } diff --git a/man/switch-ext.Rd b/man/switch-ext.Rd index 3777c041..5a9e182a 100644 --- a/man/switch-ext.Rd +++ b/man/switch-ext.Rd @@ -16,17 +16,18 @@ switch_case(..., .default = NULL, .envir = parent.frame()) \arguments{ \item{x}{A vector of values} -\item{...}{Case evaluations (named for \code{switch_params})} +\item{...}{Case evaluations (named for \code{\link[=switch_params]{switch_params()}})} \item{.default}{The default value if no matches are found in \code{...} (default: \code{NULL} produces an \code{NA} value derived from \code{...})} \item{.envir}{The environment in which to evaluate the LHS of \code{...} (default: -\code{parent.frame()})} +\code{\link[base:sys.parent]{base::parent.frame()}})} } \value{ -A named vector of values of same length \code{x}; or for \code{switch_case}, -an unnamed vector of values matching the rhs of \code{...} +A named vector of values of same length \code{x}; or for +\code{\link[=switch_case]{switch_case()}}, an unnamed vector of values matching the rhs of +\code{...} Inspired from: \itemize{ @@ -35,11 +36,15 @@ Inspired from: } } \description{ -\code{switch_params()} is a vectorized version of \code{switch} -\code{switch_case()} uses a formula syntax to return the value to the right of the -tilde (\code{~}) when \code{x} is \code{TRUE} -\code{switch_in_case()} is a special case of \code{switch_case()} for \code{match()}-ing \code{x} -in the values on the left to return the value on the right. +\code{\link[=switch_params]{switch_params()}} is a vectorized version of +\code{\link[base:switch]{base::switch()}} + +\code{\link[=switch_case]{switch_case()}} uses a formula syntax to return the value to the +right of the tilde (\code{~}) when \code{x} is \code{TRUE} + +\code{\link[=switch_in_case]{switch_in_case()}} is a special case of \code{\link[=switch_case]{switch_case()}} for +\code{\link[base:match]{base::match()}}-ing \code{x} in the values on the left to return the value on +the right. } \details{ Switch with a list of params diff --git a/man/t_df.Rd b/man/t_df.Rd index 86d6a2f5..f512acd9 100644 --- a/man/t_df.Rd +++ b/man/t_df.Rd @@ -4,25 +4,23 @@ \alias{t_df} \title{Data frame transpose} \usage{ -t_df(x, id = NULL) +t_df(x) } \arguments{ \item{x}{A data.frame} - -\item{id}{No longer used} } \value{ -A transposed \code{data.frame} with columns (\code{"colname"}, \code{"row_1"}, ..., -for each row in \code{x}. +A transposed \code{data.frame} with columns (\code{"colname"}, \code{"row_1"}, +\code{...}, for each row in \code{x}. } \description{ -This transposes a data.frame with \code{t()} but transforms back into a data.frame -with column and row names cleaned up. Because the data types may be mixed -and reduced to characters, this may only be useful for a visual viewing of -the data.frame. +This transposes a data.frame with \code{\link[base:t]{base::t()}} but transforms +back into a data.frame with column and row names cleaned up. Because the +data types may be mixed and reduced to characters, this may only be useful +for a visual viewing of the data.frame. } \details{ -Transposes a data.frame as a data.frame +Transposes a \code{data.frame} as a \code{data.frame} } \examples{ x <- data.frame(col_a = Sys.Date() + 1:5, col_b = letters[1:5], col_c = 1:5) diff --git a/man/to_boolean.Rd b/man/to_boolean.Rd index 0d4c7822..2a153be9 100644 --- a/man/to_boolean.Rd +++ b/man/to_boolean.Rd @@ -15,7 +15,7 @@ to_boolean(x, ...) \method{to_boolean}{numeric}(x, true = 1, false = 0, na = NULL, ...) -\method{to_boolean}{integer}(x, true = 1L, false = 0L, ...) +\method{to_boolean}{integer}(x, true = 1L, false = 0L, na = NULL, ...) \method{to_boolean}{character}( x, diff --git a/man/unique_rows.Rd b/man/unique_rows.Rd index 7f4d9b78..c73a390b 100644 --- a/man/unique_rows.Rd +++ b/man/unique_rows.Rd @@ -23,10 +23,10 @@ rather than the first} Drops duplicated rows } \examples{ -df <- quick_dfl( +df <- data.frame( i = 1:4, a = rep(1:2, 2L), - b = rep("a", 4L), + b = rep("a", 4L) ) unique_rows(df, 2:3) diff --git a/man/unlist0.Rd b/man/unlist0.Rd index 7d3ad22b..6f220d3b 100644 --- a/man/unlist0.Rd +++ b/man/unlist0.Rd @@ -25,8 +25,8 @@ Unlist without unique names; combine names for unique values } \details{ \itemize{ -\item \code{\link[=unlist0]{unlist0()}} is much like \code{\link[=unlist]{unlist()}} expect that name are not made to be -unique. +\item \code{\link[=unlist0]{unlist0()}} is much like \code{\link[base:unlist]{base::unlist()}} expect that name are not +made to be unique. \item \code{\link[=squash_vec]{squash_vec()}} works differently } } diff --git a/man/use_author.Rd b/man/use_author.Rd index 4a03a550..485b5bc9 100644 --- a/man/use_author.Rd +++ b/man/use_author.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/description.R \name{use_author} \alias{use_author} -\title{Add author to DESCRIPTION} +\title{Add author to \code{DESCRIPTION}} \usage{ use_author(author_info = find_author()) } diff --git a/man/vap.Rd b/man/vap.Rd index b03eddc8..3b6ffaad 100644 --- a/man/vap.Rd +++ b/man/vap.Rd @@ -44,12 +44,12 @@ These are simply wrappers for \code{\link[base:lapply]{base::vapply()}} to short Each function is designed to use specific vector types: \describe{ -\item{vap_int}{integer} -\item{vap_dbl}{double} -\item{vap_chr}{character} -\item{vap_lgl}{logical} -\item{vap_cplx}{complex} -\item{vap_date}{Date} +\item{\code{\link[=vap_int]{vap_int()}}}{integer} +\item{\code{\link[=vap_dbl]{vap_dbl()}}}{double} +\item{\code{\link[=vap_chr]{vap_chr()}}}{character} +\item{\code{\link[=vap_lgl]{vap_lgl()}}}{logical} +\item{\code{\link[=vap_cplx]{vap_cplx()}}}{complex} +\item{\code{\link[=vap_date]{vap_date()}}}{Date} } } \seealso{ diff --git a/man/vector2df.Rd b/man/vector2df.Rd index e6d3040a..bbf3c241 100644 --- a/man/vector2df.Rd +++ b/man/vector2df.Rd @@ -4,14 +4,12 @@ \alias{vector2df} \title{Vector to data.frame} \usage{ -vector2df(x, name = "name", value = "value", show_NA) +vector2df(x, name = "name", value = "value") } \arguments{ \item{x}{A vector of values.} \item{name, value}{Character strings for the name and value columns} - -\item{show_NA}{Ignored; will trigger a warning if set} } \value{ A \code{data.frame} with \code{name} (optional) and \code{value} columns diff --git a/man/within.Rd b/man/within.Rd index 002edd27..7e59fc5a 100644 --- a/man/within.Rd +++ b/man/within.Rd @@ -3,7 +3,6 @@ \name{within} \alias{within} \alias{between} -\alias{betwee_more} \alias{between_more} \title{within boundaries} \usage{ @@ -30,17 +29,21 @@ A logical vector Compare a vector within (between) other values } \details{ -\verb{type``, }bounds`` can be one of the below: +\code{type}, \code{bounds} can be one of the below: \describe{ -\item{g,(}{is greater than (>)} -\item{ge,[}{greater than or equal to (>=)} -\item{l,))}{less than (<)} -\item{le,[]}{less than or equal to (<=)} +\item{\code{"g"}, \code{(}}{is greater than (\code{>})} +\item{\code{"ge"}, \code{[}}{greater than or equal to (\code{>=})} +\item{\code{"l"}, \verb{)}}{less than (\code{<})} +\item{\code{"le"}, \verb{]}}{less than or equal to (\code{<=})} } -Note: \code{\link[=between_more]{between_more()}} may be deprecated in the future in favor of just -\code{\link[=within]{within()}} +Note: [mark::between_more()] may be deprecated in the future in favor of +just [mark::within()] + +[\verb{\}\{greater than or equal to (}>=\verb{)\} \\item\{}"l"\verb{, })\verb{\}\{less than (}<\verb{)\} \\item\{}"le"\verb{, }]: R:\%60\%7D\%7Bgreater\%20than\%20or\%20equal\%20to\%20(\%60\%3E=\%60)\%7D\%0A\%20\%5C\%5Citem\%7B\%60\%22l\%22\%60,\%20\%60)\%60\%7D\%7Bless\%20than\%20(\%60\%3C\%60)\%7D\%0A\%20\%5C\%5Citem\%7B\%60\%22le\%22\%60,\%20\%60 +[mark::between_more()]: R:mark::between_more() +[mark::within()]: R:mark::within() } \examples{ diff --git a/man/write_file_md5.Rd b/man/write_file_md5.Rd index 66355b9c..c4230055 100644 --- a/man/write_file_md5.Rd +++ b/man/write_file_md5.Rd @@ -43,24 +43,25 @@ Otherwise, see \code{\link[fs:copy]{fs::file_copy()}}.} } \value{ \itemize{ -\item \code{\link[=write_file_md5]{write_file_md5()}}: \code{x}, invisibly. When \code{path} is not the \code{stdout()}, \code{x} -is returned with the attribute \code{"path"} set to the result of -\code{\link[=file_copy_md5]{file_copy_md5()}}. -\item \code{\link[=mark_write_methods]{mark_write_methods()}}: A list of applicable methods and their aliases -\item \code{\link[=mark_compress_methods]{mark_compress_methods()}}: A character vector of applicable compression -methods +\item \code{\link[=write_file_md5]{write_file_md5()}}: \code{x}, invisibly. When \code{path} is not the +\code{\link[base:showConnections]{base::stdout()}}, \code{x} is returned with the attribute \code{"path"} set to the +result of \code{\link[=file_copy_md5]{file_copy_md5()}}. +\item \code{\link[=mark_write_methods]{mark_write_methods()}}: A list of applicable methods and their +aliases +\item \code{\link[=mark_compress_methods]{mark_compress_methods()}}: A character vector of applicable +compression methods } } \description{ Write file with md5 hash check } -\section{\code{options()}}{ +\section{Options}{ \itemize{ \item \code{mark.compress.method}: compression method to use when writing files \item \code{mark.list.hook}: when a \code{data.frame} contains a \code{list} column, this -function is applied to each element of the list. The default \code{"auto"} -uses \code{toJSON()} if the package \code{jsonlite} is available, otherwise +function is applied to each element of the list. The default \code{"auto"} uses +\code{jsonlite::toJSON()} if the package \code{jsonlite} is available, otherwise } } diff --git a/mark.Rproj b/mark.Rproj index 64021161..1b223aa8 100644 --- a/mark.Rproj +++ b/mark.Rproj @@ -13,9 +13,15 @@ Encoding: UTF-8 RnwWeave: Sweave LaTeX: pdfLaTeX +AutoAppendNewline: Yes StripTrailingWhitespace: Yes +LineEndingConversion: Posix BuildType: Package PackageUseDevtools: Yes PackageInstallArgs: --no-multiarch --with-keep.source PackageRoxygenize: rd,collate,namespace + +UseNativePipeOperator: Yes + +QuitChildProcessesOnExit: Yes diff --git a/tests/spelling.R b/tests/spelling.R index 6713838f..d60e024c 100644 --- a/tests/spelling.R +++ b/tests/spelling.R @@ -1,3 +1,7 @@ -if(requireNamespace('spelling', quietly = TRUE)) - spelling::spell_check_test(vignettes = TRUE, error = FALSE, - skip_on_cran = TRUE) +if (requireNamespace("spelling", quietly = TRUE)) { + spelling::spell_check_test( + vignettes = TRUE, + error = FALSE, + skip_on_cran = TRUE + ) +} diff --git a/tests/testthat/_snaps/md5.md b/tests/testthat/_snaps/md5.md index d1b5985e..22764696 100644 --- a/tests/testthat/_snaps/md5.md +++ b/tests/testthat/_snaps/md5.md @@ -15,7 +15,7 @@ --- Code - md5(quick_dfl(a = 1)) + md5(dataframe(a = 1)) Output - 34e2f3ac0f1ba4794d0cd0160fe80c6e + f16311aa3f99060be519c8e9b38101e6 diff --git a/tests/testthat/_snaps/write.md b/tests/testthat/_snaps/write.md index 3e13f938..6b3add41 100644 --- a/tests/testthat/_snaps/write.md +++ b/tests/testthat/_snaps/write.md @@ -1,7 +1,7 @@ # arrow prints something to stdout() Code - write_file_md5(quick_dfl(a = 1), method = "feather") + write_file_md5(dataframe(a = 1), method = "feather") Output Table 1 rows x 1 columns @@ -10,7 +10,7 @@ --- Code - write_file_md5(quick_dfl(a = 1), method = "parquet") + write_file_md5(dataframe(a = 1), method = "parquet") Output # A data frame: 2 x 12 file_name name r_type type type_length repetition_type converted_type diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index df256dc0..9ba020e5 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -1,5 +1,63 @@ -fuj_message <- function() { - if (packageVersion("fuj") >= "2.2.0") { - "mark:fileCopyMd5Message" - } +library(testthat) + +muffle_cnd_conditions <- function(expr) { + withCallingHandlers( + expr, + "cnd::condition" = function(cond) tryInvokeRestart("muffleCondition") + ) +} + +need_clipr <- function() { + testthat::skip_if_not_installed("clipr") + + # not sure if this is needed + withr::with_envvar(c(CLIPR_ALLOW = TRUE), { + testthat::skip_if_not(clipr::clipr_available()) + }) + + testthat::skip_on_cran() +} + +with_clip <- function(code) { + need_clipr() + withr::with_envvar( + c(CLIPR_ALLOW = TRUE), + (function() { + old <- clipr::read_clip() + clear_clipboard() + on.exit(clipr::write_clip(old), add = TRUE) + force(code) + })() + ) +} + +test_clipboard <- function(x, ...) { + with_clip({ + expect_error(write_clipboard(x), NA) + expect_equal(read_clipboard(), x, ...) + }) +} + +expect_clip <- function(input, method) { + with_clip({ + write_clipboard(input) + res <- if (package_available("tibble")) { + tibble::tibble(a = 1L, b = 2L, c = 3L) + } else { + fuj::dataframe(a = 1L, b = 2L, c = 3L) + } + expect_identical(read_clipboard(method), res) + }) +} + +simple_tbl <- function(delim) { + paste( + paste(letters[1:3], collapse = delim), + paste(1:3, collapse = delim), + sep = "\n" + ) +} + +expect_deprecated <- function(expr) { + expect_warning(expr, class = "deprecatedWarning") } diff --git a/tests/testthat/test-append.R b/tests/testthat/test-append.R index f2d2b3a8..94ba302a 100644 --- a/tests/testthat/test-append.R +++ b/tests/testthat/test-append.R @@ -25,12 +25,12 @@ test_that("append0.list() works", { }) test_that("append.data.frame() works", { - x <- quick_dfl(a = 1:2, b = 0:1) + x <- dataframe(a = 1:2, b = 0:1) res <- append0(x, list(c = c(TRUE, FALSE))) - exp <- quick_dfl(a = 1:2, b = 0:1, c = c(TRUE, FALSE)) + exp <- dataframe(a = 1:2, b = 0:1, c = c(TRUE, FALSE)) expect_identical(res, exp) res <- append0(x, list(c = c(TRUE, FALSE)), 2) - exp <- quick_dfl(a = 1:2, c = c(TRUE, FALSE), b = 0:1) + exp <- dataframe(a = 1:2, c = c(TRUE, FALSE), b = 0:1) expect_identical(res, exp) }) diff --git a/tests/testthat/test-apply.R b/tests/testthat/test-apply.R index b87b5ad6..b35baecf 100644 --- a/tests/testthat/test-apply.R +++ b/tests/testthat/test-apply.R @@ -146,37 +146,8 @@ test_that("capply()", { res1 <- set_names(res0, nm) foo <- function(x) x^2 - # Should appropriately set names - expect_equal(capply(x, foo, .nm = FALSE), res0) - expect_equal(capply(x, foo, .nm = TRUE), res1) - # Combines full lists x <- list(c(1:3), NA_real_, 4, 5, NULL, 6:7) res <- c(1, 4, 9, NA, 16, 25, 36, 49) expect_equal(capply(x, foo), res) }) - - -# slappy ------------------------------------------------------------------ - -test_that("slapply()", { - x <- 1:10 - foo <- function(i) i^i - - res <- slapply(x, foo, .names = FALSE) - exp <- foo(x) - expect_identical(res, exp) - - res <- slapply(x, foo) - exp <- set_names(x^x, x) - expect_identical(res, exp) - - res <- slapply(x, foo, .simplify = TRUE) - exp <- simplify2array(exp) - expect_identical(res, exp) - - x <- set_names(x) - res <- slapply(x, foo) - exp <- set_names(x^x, x) - expect_identical(res, exp) -}) diff --git a/tests/testthat/test-array.R b/tests/testthat/test-array.R deleted file mode 100644 index ccd7595e..00000000 --- a/tests/testthat/test-array.R +++ /dev/null @@ -1,22 +0,0 @@ -test_that("array_extract() works", { - x <- array(rep(NA, 27), dim = c(3, 3, 3)) - x[1, 2, 3] <- TRUE - expect_true(array_extract(x, `2` = 2, `3` = 3)) - val <- x - expect_true(array_extract(val, `2` = 2, `3` = 3)) - - x <- array(1:9, dim = c(3, 3)) - dimnames(x) <- list(one = LETTERS[1:3], two = letters[1:3]) - - expect_identical(array_extract(x, 1, 2), x[1, 2]) - expect_identical(array_extract(x, "A", "b"), array_extract(x, 1, 2)) - y <- fact(c("A", "b")) - expect_identical(array_extract(x, y[1], y[2]), array_extract(x, 1, 2)) -}) - -test_that("array_extract() errors", { - x <- array(1:9, dim = c(3, 3)) - expect_error(array_extract(1), class = "simpleError") - expect_error(array_extract(x, 2, 3), NA) - expect_error(array_extract(x, a = 2, b = 3), class = "arrayExtractNamesError") -}) diff --git a/tests/testthat/test-base-conversion.R b/tests/testthat/test-base-conversion.R index fee3e249..57e31068 100644 --- a/tests/testthat/test-base-conversion.R +++ b/tests/testthat/test-base-conversion.R @@ -6,8 +6,10 @@ test_that("base_alpha() works as expected", { letter_vec <- paste_combine(c("", letters), letters, collate = TRUE) expect_equal(base_alpha(letter_vec), 1:702) - expect_error(base_alpha(letters[1:10], 9), class = "baseAlphaLimitError") - expect_warning(alpha_base(letters), "deprecated") + expect_error( + base_alpha(letters[1:10], 9), + class = "mark:base_conversion_error" + ) expect_identical(base_alpha_single("a", 26), 1L) expect_identical(base_alpha_single("j", 26), 10L) @@ -17,23 +19,23 @@ test_that("base_alpha() works as expected", { test_that("base_n() works as expected", { expect_equal(base_n(120, 9), 99) - expect_error(base_n(62, 2), class = "baseNSingleLimitError") + expect_error(base_n(62, 2), class = "mark:base_conversion_error") x <- c(2L, 1L, 3L, 3L, 6L, 5L, 1L, 4L, 4L, 2L, 2L, 6L, 7L, 4L, 4L, 3L, 1L, 1L) expect_identical(base_n(x, 5, 5), x) }) test_that("base_alpha(), base_n() fails", { - expect_error(base_alpha(1), class = "simpleError") - expect_error(base_n("a"), class = "simpleError") - expect_error(base_n(1, 10, 12), class = "baseNTenError") + expect_error(base_alpha(1), class = "class_error") + expect_error(base_n("a"), class = "class_error") + expect_error(base_n(1, 10, 12), class = "mark:base_conversion_error") }) test_that("check_base(), check_base_alpha() works", { - expect_error(check_base(1.1), class = "checkBaseIntegerError") - expect_error(check_base(-1, 9), class = "checkBaseLimitError") - expect_error(check_base(10, 9), class = "checkBaseLimitError") + expect_error(check_base(1.1), class = "mark:base_conversion_error") + expect_error(check_base(-1, 9), class = "mark:base_conversion_error") + expect_error(check_base(10, 9), class = "mark:base_conversion_error") expect_null(check_base_alpha("j")) - expect_error(check_base_alpha("ab"), class = "checkBaseAlphaLengthError") + expect_error(check_base_alpha("ab"), class = "mark:base_conversion_error") }) diff --git a/tests/testthat/test-bib.R b/tests/testthat/test-bib.R index 6daad1d4..8b734ac3 100644 --- a/tests/testthat/test-bib.R +++ b/tests/testthat/test-bib.R @@ -12,12 +12,12 @@ test_that("read_bib()", { exp <- utils::head(exp, -1L) expect_identical(res, exp, ignore_attr = TRUE) - temp <- tempfile() + temp <- withr::local_tempfile() writeLines("bad", temp) - expect_error(read_bib(temp), class = "readBibEntriesError") + expect_error(read_bib(temp), class = "value_error") - expect_error(as_bib(1:3), "data.frame", class = "asBibClassError") - expect_error(as_bib_list(1:3), "list", class = "asBibListClassError") + expect_error(as_bib(1:3), class = "class_error") + expect_error(as_bib_list(1:3), class = "type_error") expect_error( process_bib_dataframe( @@ -26,7 +26,7 @@ test_that("read_bib()", { fields = "this", keys = "key" ), - class = "processBibDataframeDupeError" + class = "duplicate_error" ) }) @@ -41,14 +41,16 @@ test_that("snapshots()", { }) test_that("= inside text [#117]", { - res <- read_bib(textConnection(" + res <- read_bib(textConnection( + " @article{key, author = {Barbone, Jordan Mark}, title = {I wrote a cool article}, year = {2020}, month = {Mar}, note = {This has an = and it's bad}, - }")) + }" + )) exp <- structure( list( diff --git a/tests/testthat/test-blank.R b/tests/testthat/test-blank.R index 60831d54..0948ffd1 100644 --- a/tests/testthat/test-blank.R +++ b/tests/testthat/test-blank.R @@ -12,7 +12,7 @@ test_that("is_blank() works", { exp <- c(TRUE, FALSE, FALSE, FALSE) expect_identical(obj, exp) - df <- quick_dfl( + df <- dataframe( x = x, i = 1:4, na = rep(NA, 4L), diff --git a/tests/testthat/test-char2fact.R b/tests/testthat/test-char2fact.R index 908543fa..d0542684 100644 --- a/tests/testthat/test-char2fact.R +++ b/tests/testthat/test-char2fact.R @@ -15,7 +15,7 @@ test_that("char2fact() works", { }) test_that("char2fact.data.frame() works", { - x <- quick_dfl( + x <- dataframe( a = letters[c(1, 2, 2, 2, 3, 4, 4, 5, 5)], b = letters[c(1, 2, 3, 4, 5, 6, 7, 8, 9)] ) @@ -27,9 +27,9 @@ test_that("char2fact.data.frame() works", { }) test_that("fact2char() works", { - expect_error(fact2char(letters), class = "simpleError") + expect_error(fact2char(letters), class = "class_error") - df <- quick_dfl( + df <- dataframe( a = 1:5, b = factor(1:5), c = letters[1:5], diff --git a/tests/testthat/test-clipboard.R b/tests/testthat/test-clipboard.R index d47104a9..ee489b0a 100644 --- a/tests/testthat/test-clipboard.R +++ b/tests/testthat/test-clipboard.R @@ -1,71 +1,42 @@ -need_clipr <- function() { - testthat::skip_if_not_installed("clipr") - - # not sure if this is needed - withr::with_envvar(c(CLIPR_ALLOW = TRUE), { - testthat::skip_if_not(clipr::clipr_available()) - }) - - testthat::skip_on_cran() -} - test_that("clipboard", { need_clipr() - clear_clipboard() - - test_clipboard <- function(x, ...) { - expect_error(write_clipboard(x), NA) - expect_equal(read_clipboard(), x, ...) - } - test_clipboard(c(TRUE, FALSE, NA)) test_clipboard(c(0.1234, -0.1586, 0.0001200)) test_clipboard(-1:4) test_clipboard(as.Date("2020-01-02") + 0:4) test_clipboard(runif(1e4)) - expect_error(clear_clipboard(), NA) - expect_equal(read_clipboard(), NULL) # previously "" + with_clip({ + expect_error(clear_clipboard(), NA) + expect_equal(read_clipboard(), NULL) # previously "" + }) + + with_clip({ + x <- dataframe( + var1 = 1:3, + var2 = letters[1:3], + var3 = as.Date("2020-01-03") + 1:3, + var4 = c(TRUE, FALSE, NA) + ) + + write_clipboard(x) - x <- quick_dfl( - var1 = 1:3, - var2 = letters[1:3], - var3 = as.Date("2020-01-03") + 1:3, - var4 = c(TRUE, FALSE, NA) - ) + res <- read_clipboard("data.frame") - expect_error(write_clipboard(x), NA) - res <- read_clipboard("data.frame") - expect_s3_class(res, "data.frame") - if (package_available("tibble")) - expect_equal(as.data.frame(res), x) + expect_s3_class(res, "data.frame") + if (package_available("tibble")) { + expect_equal(as.data.frame(res), x) + } - # finally test tibble - skip_if_not_installed("tibble") - expect_s3_class(res, "tbl_df") - expect_equal(read_clipboard("tibble"), tibble::as_tibble(x)) + # finally test tibble + skip_if_not_installed("tibble") + expect_s3_class(res, "tbl_df") + expect_equal(read_clipboard("tibble"), tibble::as_tibble(x)) + }) }) test_that("clipboard methods", { need_clipr() - expect_clip <- function(input, method) { - write_clipboard(input) - res <- if (package_available("tibble")) { - tibble::tibble(a = 1L, b = 2L, c = 3L) - } else { - fuj::quick_dfl(a = 1L, b = 2L, c = 3L) - } - expect_identical(read_clipboard(method), res) - } - - simple_tbl <- function(delim) { - paste( - paste(letters[1:3], collapse = delim), - paste(1:3, collapse = delim), - sep = "\n" - ) - } - expect_clip(simple_tbl("\t"), "data.frame") expect_clip(simple_tbl("\t"), "excel") expect_clip(simple_tbl("\t"), "calc") diff --git a/tests/testthat/test-counts.R b/tests/testthat/test-counts.R index 768282d5..83bf6905 100644 --- a/tests/testthat/test-counts.R +++ b/tests/testthat/test-counts.R @@ -36,7 +36,7 @@ test_that("counts() works with NAs", { test_that("counts.data.frame() adds new name", { - df <- quick_dfl(a = 1, b = 2) + df <- dataframe(a = 1, b = 2) res <- counts(df, 1) expect_equal(colnames(res), c("a", "freq")) @@ -81,23 +81,23 @@ test_that("counts() NAs are last", { }) test_that("counts.data.frame() works", { - df <- quick_dfl(a = rep("x", 3), b = fact(c("a", "a", "b"))) + df <- dataframe(a = rep("x", 3), b = fact(c("a", "a", "b"))) res <- counts(df, 1) - exp <- quick_dfl(a = "x", freq = 3) + exp <- dataframe(a = "x", freq = 3) expect_equal(res, exp) res <- counts(df, 2) - exp <- quick_dfl(b = fact(c("a", "b")), freq = 2:1) + exp <- dataframe(b = fact(c("a", "b")), freq = 2:1) expect_equal(res, exp) res <- counts(df, 1:2) - exp <- quick_dfl(a = rep("x", 2), b = fact(c("a", "b")), freq = 2:1) + exp <- dataframe(a = rep("x", 2), b = fact(c("a", "b")), freq = 2:1) expect_equal(res, exp) df[["b"]] <- as_ordered(df[["b"]]) res <- counts(df, 1:2) - exp <- quick_dfl(a = rep("x", 2), b = as_ordered(c("a", "b")), freq = 2:1) + exp <- dataframe(a = rep("x", 2), b = as_ordered(c("a", "b")), freq = 2:1) expect_equal(res, exp) }) @@ -120,19 +120,19 @@ test_that("props() handles NA", { # data frame x <- c(1, 2, 2, 3, NA) y <- flip(x) - df <- quick_dfl(x = x, y = y) + df <- dataframe(x = x, y = y) - res_x1 <- quick_dfl(x = c(1, 2, 3, NA), prop = c(.20, .40, .20, .20)) - res_x2 <- quick_dfl(x = c(1, 2, 3, NA), prop = c(.25, .50, .25, NA)) + res_x1 <- dataframe(x = c(1, 2, 3, NA), prop = c(.20, .40, .20, .20)) + res_x2 <- dataframe(x = c(1, 2, 3, NA), prop = c(.25, .50, .25, NA)) expect_identical(props(df, "x"), res_x1) expect_identical(props(df, "x", na.rm = TRUE), res_x2) - res_xy1 <- quick_dfl( + res_xy1 <- dataframe( x = c(1, 2, 2, 3, NA), y = c(NA, 3, 2, 2, 1), prop = rep(.2, 5) ) - res_xy2 <- quick_dfl( + res_xy2 <- dataframe( x = c(1, 2, 2, 3, NA), y = c(NA, 3, 2, 2, 1), prop = c(NA, 1, 1, 1, NA) / 3 diff --git a/tests/testthat/test-dataframes.R b/tests/testthat/test-dataframes.R index 32633880..96e42267 100644 --- a/tests/testthat/test-dataframes.R +++ b/tests/testthat/test-dataframes.R @@ -1,9 +1,9 @@ test_that("to_row_names()", { - x <- quick_dfl(a = 1:4, b = letters[1:4]) + x <- dataframe(a = 1:4, b = letters[1:4]) expect_equal( to_row_names(x), - quick_dfl(b = letters[1:4]) + dataframe(b = letters[1:4]) ) expect_equal( @@ -18,7 +18,7 @@ test_that("to_row_names()", { # non-integers to character foo <- function(x) { - out <- to_row_names(quick_dfl(a = 1, b = x), "b") + out <- to_row_names(dataframe(a = 1, b = x), "b") class(attr(out, "row.names")) } @@ -29,55 +29,45 @@ test_that("to_row_names()", { test_that("col_to_rn()", { - expect_error(col_to_rn(data.frame(), 1:2), class = "colToRnRownamesError") - expect_error(col_to_rn(data.frame(), NA), class = "colToRnRownamesNaError") + expect_error(to_row_names(data.frame(), 1:2), class = "input_error") + expect_error(to_row_names(data.frame(), NA), class = "input_error") }) test_that("vector2df()", { x <- c(1.0, 3.1, 8.2) - df <- quick_dfl(name = c(NA, NA, NA), value = x) + df <- dataframe(name = c(NA, NA, NA), value = x) expect_equal(vector2df(x), df) df$name <- as.character(x) expect_equal(vector2df(set_names(x)), df) expect_named(vector2df(x, "one", "two"), c("one", "two")) - expect_warning( - vector2df(x, show_NA = NULL), - class = "vector2dfShowNaWarning" - ) - - expect_error(vector2df(list(a = 1)), class = "simpleError") + expect_error(vector2df(list(a = 1)), class = "class_error") }) test_that("list2df()", { x <- list(a = 1, b = 2:4, c = letters[10:20]) - exp <- quick_dfl( + exp <- dataframe( name = letters[c(1, rep(2, 3), rep(3, 11))], value = c(1, 2:4, letters[10:20]) ) - expect_warning(list2df(x), class = "list2dfClassesWarning") + expect_warning(list2df(x), class = "mark:list2df_warning") expect_warning(list2df(x, warn = FALSE), NA) expect_equal(list2df(x, warn = FALSE), exp) x <- list(a = 1, b = seq(2, 9, 1.0), c = 20) - exp <- quick_df(list(name = c("a", rep("b", 8), "c"), - value = c(1:9, 20))) + exp <- quick_df(list(name = c("a", rep("b", 8), "c"), value = c(1:9, 20))) expect_warning(list2df(x), NA) expect_equal(list2df(x), exp) expect_named(list2df(x, "hello", "world"), c("hello", "world")) - expect_warning( - list2df(x, show_NA = NULL), - class = "list2dfShowNaWarning" - ) # Unnamed x <- list(a = 1, 0, 2) - res <- quick_dfl(name = c("a", 2, 3), value = c(1, 0, 2)) + res <- dataframe(name = c("a", 2, 3), value = c(1, 0, 2)) expect_equal(list2df(x), res) - expect_error(list2df(1), class = "simpleError") + expect_error(list2df(1), class = "class_error") # Not sure this will continue to be the case expect_identical(quick_df(NULL), data.frame()) @@ -95,21 +85,20 @@ test_that("list2df2()", { }) test_that("t_df()", { - x <- quick_dfl(a = 1:5, b = letters[1:5]) + x <- dataframe(a = 1:5, b = letters[1:5]) - y <- quick_dfl( + y <- dataframe( colname = c("a", "b"), # nolint start: spaces_inside_linter. - row_1 = c( 1, "a"), - row_2 = c( 2, "b"), - row_3 = c( 3, "c"), - row_4 = c( 4, "d"), - row_5 = c( 5, "e") + row_1 = c(1, "a"), + row_2 = c(2, "b"), + row_3 = c(3, "c"), + row_4 = c(4, "d"), + row_5 = c(5, "e") # nolint end: spaces_inside_linter. ) expect_equal(t_df(x), y) - expect_warning(t_df(x, id = 1)) expect_error(t_df(1L)) }) @@ -123,9 +112,9 @@ test_that("complete_cases()", { expect_error(complete_cases(1L)) expect_error(complete_cases(quick_df(NULL))) - df <- quick_dfl(a = c(1, 2, NA, 4), b = c(NA, 2, 3, NA)) - res1 <- quick_dfl(a = c(1, 2, 4), b = c(NA, 2, NA)) - res2 <- quick_dfl(a = 2, b = 2) + df <- dataframe(a = c(1, 2, NA, 4), b = c(NA, 2, 3, NA)) + res1 <- dataframe(a = c(1, 2, 4), b = c(NA, 2, NA)) + res2 <- dataframe(a = 2, b = 2) expect_identical(complete_cases(df, "a"), res1) expect_identical(complete_cases(df), res2) @@ -134,7 +123,7 @@ test_that("complete_cases()", { test_that("unique_rows()", { expect_error(unique_rows(1L)) - df <- quick_dfl( + df <- dataframe( id = 1:4, a = rep(1:2, 2L), b = rep("a", 4L) diff --git a/tests/testthat/test-dates.R b/tests/testthat/test-dates.R index a0e4587b..993bc0fe 100644 --- a/tests/testthat/test-dates.R +++ b/tests/testthat/test-dates.R @@ -19,18 +19,18 @@ test_that("dates - utils", { test_that("leap years", { # nolint start: spaces_inside_linter. expect_false(is_leap_year(1500)) - expect_true( is_leap_year(1600)) + expect_true(is_leap_year(1600)) expect_false(is_leap_year(1700)) expect_false(is_leap_year(1800)) expect_false(is_leap_year(1900)) - expect_true( is_leap_year(2000)) - expect_true( is_leap_year(2400)) - expect_true( is_leap_year(4000)) - expect_true( is_leap_year(0)) + expect_true(is_leap_year(2000)) + expect_true(is_leap_year(2400)) + expect_true(is_leap_year(4000)) + expect_true(is_leap_year(0)) expect_false(is_leap_year(100)) expect_false(is_leap_year(102)) - expect_true( is_leap_year(400)) - expect_true( is_leap_year(as.POSIXct("2020-01-01"))) + expect_true(is_leap_year(400)) + expect_true(is_leap_year(as.POSIXct("2020-01-01"))) # nolint end: spaces_inside_litner. }) @@ -65,15 +65,21 @@ test_that("Some examples", { }) test_that("Bad date: Earliest", { - dates <- c("3 UNK 2019", "UN JUN 2004", "Feb 2000", "UK UNK UNKN") - exp <- c("2019-01-03", "2004-06-01", "2000-02-01", NA_character_) + dates <- c("3 UNK 2019", "UN JUN 2004", "Feb 2000", "UK UNK UNKN") + exp <- c("2019-01-03", "2004-06-01", "2000-02-01", NA_character_) expect_equal(foo(dates, format = "dmy"), exp) }) test_that("Bad date: Latest", { # nolint start: line_length_linter. - dates <- c("3 UNK 2019", "UN JUN 2004", "Feb 2000", "Feb 2100", "UK UNK UNKN") - exp <- c("2019-12-03", "2004-06-30", "2000-02-29", "2100-02-28", NA_character_) + dates <- c("3 UNK 2019", "UN JUN 2004", "Feb 2000", "Feb 2100", "UK UNK UNKN") + exp <- c( + "2019-12-03", + "2004-06-30", + "2000-02-29", + "2100-02-28", + NA_character_ + ) expect_equal(foo(dates, format = "dmy", method = "max"), exp) # nolint end: line_length_linter. }) @@ -87,9 +93,9 @@ test_that("'Empty' dates don't cause errors", { }) test_that("date errors", { - expect_error(verify_format("ymda"), class = "verifyFormatChrsError") - expect_error(verify_format("abc"), class = "verifyFormatYmdError") - expect_error(verify_format("aaa"), class = "verifyFormatChrsError") + expect_error(verify_format("ymda"), class = "input_error") + expect_error(verify_format("abc"), class = "input_error") + expect_error(verify_format("aaa"), class = "input_error") expect_error(verify_format("ymd"), NA) expect_error(verify_format("dmy"), NA) expect_error(verify_format("mdy"), NA) diff --git a/tests/testthat/test-depth.R b/tests/testthat/test-depth.R index 1130afa2..3efe3ebb 100644 --- a/tests/testthat/test-depth.R +++ b/tests/testthat/test-depth.R @@ -1,6 +1,6 @@ test_that("depth", { expect_equal(depth(NA), 1L) - expect_equal(depth(quick_dfl(a = 1)), 1L) + expect_equal(depth(dataframe(a = 1)), 1L) expect_equal(depth(list()), 0L) expect_equal(depth(NULL), 0L) expect_equal(depth(list(1)), 1L) diff --git a/tests/testthat/test-description.R b/tests/testthat/test-description.R index df26447a..c5d7260f 100644 --- a/tests/testthat/test-description.R +++ b/tests/testthat/test-description.R @@ -1,6 +1,6 @@ test_that("find_author() works", { withr::local_options(list(mark.author = NULL)) - expect_error(find_author(), class = "findAuthorError") + expect_error(find_author(), class = "value_error") }) test_that("use_author() works", { @@ -46,6 +46,6 @@ test_that("use_author() works", { writeLines(original, "DESCRIPTION") - expect_error(use_author(NULL), "list", class = "simpleError") - expect_error(use_author(person()), "person", class = "simpleError") + expect_error(use_author(NULL), class = "type_error") + expect_error(use_author(person()), class = "type_error") }) diff --git a/tests/testthat/test-detail.R b/tests/testthat/test-detail.R index bfbc01cb..b74a38c7 100644 --- a/tests/testthat/test-detail.R +++ b/tests/testthat/test-detail.R @@ -3,23 +3,23 @@ test_that("details() works", { y <- factor(letters[1:3]) z <- c("x", NA_character_, "z") attr(z, "label") <- "information" - df <- quick_dfl(x = x, y = factor(letters[1:3])) + df <- dataframe(x = x, y = factor(letters[1:3])) expect_error(detail(x), NA) expect_error(detail(df), NA) - expect_error(detail(data.frame()), class = "detailDataFrameListError") + expect_error(detail(data.frame()), class = "input_error") - exp <- quick_dfl( - class = "logical", - type = "logical", - label = NA_character_, - n = 0L, - na = 1L, - min_c = NA_character_, - max_c = NA_character_, - level = NA_character_, + exp <- dataframe( + class = "logical", + type = "logical", + label = NA_character_, + n = 0L, + na = 1L, + min_c = NA_character_, + max_c = NA_character_, + level = NA_character_, level_n = NA_integer_, - note = NA_character_, + note = NA_character_, comment = NA_character_ ) # also no warnings @@ -38,10 +38,10 @@ test_that("details() and tibbles", { expect_error(detail(tibble::tibble(a = 1, b = list(1:3))), NA) expect_error( detail(tibble::tibble(a = NULL, b = list(1:3))), - class = "detailDataFrameListError" + class = "input_error" ) }) test_that("details.data.frame() passes with single column [48]", { - expect_error(quick_dfl(a = 1), NA) + expect_error(dataframe(a = 1), NA) }) diff --git a/tests/testthat/test-diff-time.R b/tests/testthat/test-diff-time.R index cb1b4ce7..1de6fb6e 100644 --- a/tests/testthat/test-diff-time.R +++ b/tests/testthat/test-diff-time.R @@ -59,10 +59,9 @@ test_that("diff_time_*() identical to difftime()", { }) test_that("Timezones", { - st <- as.POSIXct("2021-04-06 11:12:45", tz = "America/Chicago") - dftz <- quick_dfl( + dftz <- dataframe( a = rep(st, 4), b = rep(st, 4), tza = c("GMT", "UTC", "America/New_York", "Pacific/Auckland"), @@ -72,7 +71,8 @@ test_that("Timezones", { # No difference expect_identical( - with(dftz, diff_time_hours(a, b)), rep(0, 4), + with(dftz, diff_time_hours(a, b)), + rep(0, 4), ignore_attr = TRUE ) @@ -153,19 +153,19 @@ test_that("Timezones", { expect_warning( diff_time(Sys.Date(), Sys.Date(), tzx = NA, tzy = "GMT"), - "NA found in timezones" + class = "mark:na_timezone_found_warning" ) }) test_that("Error checking", { expect_error( diff_time_secs(1:10, 1:10), - class = "extractNumericTimeNumericError" + class = "mark:numeric_datetime_tz_error" ) expect_error( diff_time_secs(st, st, "Not good"), - class = "checkTzTimezoneOlsonError" + class = "mark:timezone_not_found_error" ) # Don't throw error because of NA tz @@ -177,7 +177,6 @@ test_that("Error checking", { }) test_that("class coehersion", { - expect_identical( diff_time(as.Date("2021-07-26"), "2021-07-26"), diff_time(as.Date("2021-07-26"), as.Date("2021-07-26")) @@ -191,8 +190,7 @@ test_that("class coehersion", { expect_warning( to_numeric_with_tz("2021-01-01", NA), - "NA found in timezones", - class = "toNumericWithTzNaWarning" + class = "mark:na_timezone_found_warning" ) expect_identical(check_tz(NULL), NULL) diff --git a/tests/testthat/test-directory.R b/tests/testthat/test-directory.R index d7bcee8a..ec44604f 100644 --- a/tests/testthat/test-directory.R +++ b/tests/testthat/test-directory.R @@ -1,4 +1,3 @@ - test_that("tests with temp dir", { expect_equal_path <- function(x, y) { x_short <- fs::path(basename(dirname(x)), basename(x)) @@ -11,57 +10,46 @@ test_that("tests with temp dir", { td <- tempdir(check = TRUE) skip_if_not(rn("withr")) - withr::with_tempdir({ - dates <- as.character(as.POSIXct("2021-01-02 15:57:25") + 1:3) - dates <- gsub(":", "", dates) - - dirs <- c( - dates, - c(0, 100, 300, Inf) - ) - - files <- c( - "no_ext" - ) - - invisible( - sapply(dirs, function(x) { - dir_create(file_path(td, x), overwrite = TRUE) - }) - ) - - # Add a second so times are unique - Sys.sleep(1) - most_recent_dir <- file_path(td, "most_recent_dir") - dir_create(most_recent_dir, overwrite = TRUE) - - invisible( - sapply(files, function(x) { - file_create(file_path(td, x), overwrite = TRUE) - }) - ) - - # Add a second so times are unique - Sys.sleep(1) - most_recent_file <- file_path(td, "most_recent_file") - # Should be able to create a file with the same name as a directory - file_create(most_recent_file) - - expect_equal_path(get_recent_dir(td), most_recent_dir) - expect_equal_path(get_dir_recent_date(td), file_path(td, dates[3])) - expect_equal_path(get_dir_max_number(td), file_path(td, 300)) - expect_false(is_dir(file_path(td, "no_ext"))) - expect_equal_path(get_recent_file(td), most_recent_file) - }, - tmpdir = td - ) + td <- withr::local_tempdir() + dates <- as.character(as.POSIXct("2021-01-02 15:57:25") + 1:3) + dates <- gsub(":", "", dates) + + dirs <- c(dates, c(0, 100, 300, Inf)) + + invisible(sapply( + dirs, + function(x) dir_create(file_path(td, x), overwrite = TRUE) + )) + + # Add a second so times are unique + Sys.sleep(1) + most_recent_dir <- file_path(td, "most_recent_dir") + dir_create(most_recent_dir, overwrite = TRUE) + + invisible(sapply( + "no_ext", + function(x) file_create(file_path(td, x), overwrite = TRUE) + )) + + # Add a second so times are unique + Sys.sleep(1) + most_recent_file <- file_path(td, "most_recent_file") + # Should be able to create a file with the same name as a directory + file_create(most_recent_file) + + expect_equal_path(get_recent_dir(td), most_recent_dir) + expect_equal_path(get_dir_recent_date(td), file_path(td, dates[3])) + expect_equal_path(get_dir_max_number(td), file_path(td, 300)) + expect_false(is_dir(file_path(td, "no_ext"))) + expect_equal_path(get_recent_file(td), most_recent_file) }) +# fmt: skip test_that("errors", { - expect_error(is_file(NULL), class = "simpleError") - expect_error(is_file(character()), class = "simpleError") - expect_error(is_file(TRUE), class = "simpleError") - expect_error(is_dir(NULL), class = "simpleError") - expect_error(is_dir(character()), class = "simpleError") - expect_error(is_dir(TRUE), class = "simpleError") + expect_error(is_file(NULL), class = "input_error") + expect_error(is_file(character()), class = "input_error") + expect_error(is_file(TRUE), class = "input_error") + expect_error(is_dir(NULL), class = "input_error") + expect_error(is_dir(character()), class = "input_error") + expect_error(is_dir(TRUE), class = "input_error") }) diff --git a/tests/testthat/test-environments.R b/tests/testthat/test-environments.R index 2a17cf30..a75d60e6 100644 --- a/tests/testthat/test-environments.R +++ b/tests/testthat/test-environments.R @@ -6,26 +6,23 @@ test_that("environments() and friends works", { ne <- new.env() - local({ - foo_obj <- structure(list(), class = "foo") - foo_fun <- function() NULL - foo_df <- quick_dfl(a = 1) - }, envir = ne) + local( + { + foo_obj <- structure(list(), class = "foo") + foo_fun <- function() NULL + foo_df <- dataframe(a = 1) + }, + envir = ne + ) # these are failing...? expect_identical(ls_function(envir = ne), "foo_fun") expect_identical(ls_object(envir = ne), c("foo_df", "foo_obj")) expect_identical(ls_dataframe(envir = ne), "foo_df") - - expect_identical( - make_do_ls("is.object"), - ls_object, - ignore_function_env = TRUE - ) }) test_that("snapshots", { - expect_error(print(environments()), NA) + expect_output(expect_error(print(environments()), NA)) skip("not static") expect_snapshot(environments()) }) diff --git a/tests/testthat/test-expand.R b/tests/testthat/test-expand.R index bbeb116b..2b25a522 100644 --- a/tests/testthat/test-expand.R +++ b/tests/testthat/test-expand.R @@ -26,8 +26,14 @@ test_that("expand_by() work", { expect_equal(exp, res) # nolint start: line_length_linter. - expect_error(expect_warning(expand_by(c(a = 1, a = 1), c(a = 1))), class = "simpleError") - expect_error(expect_warning(expand_by(c(a = 1), c(a = 1, a = 1))), class = "simpleError") + expect_error( + expect_warning(expand_by(c(a = 1, a = 1), c(a = 1))), + class = "simpleError" + ) + expect_error( + expect_warning(expand_by(c(a = 1), c(a = 1, a = 1))), + class = "simpleError" + ) # nolint end: line_length_linter. }) @@ -50,13 +56,16 @@ test_that("reindex() work", { reindex(iris1, "index", seq(2, 8, 2)) reindex(iris1, "index", seq(2, 8, 2), expand = "both") - expect_error(reindex(1), "data.frame", class = "simpleError") + expect_error(reindex(1), class = "class_error") expect_error( - reindex(quick_dfl(a = 1), index = integer()), - "new_index" + reindex(dataframe(a = 1), index = integer()), + class = if (getRversion() >= "4.5") "missingArgError" else "simpleError", ) }) test_that("expand helpers work", { - expect_warning(unique_name_check(c(a = 1, a = 2))) + expect_warning( + unique_name_check(c(a = 1, a = 2)), + class = "duplicate_warning" + ) }) diff --git a/tests/testthat/test-fact.R b/tests/testthat/test-fact.R index 6221242e..4e720445 100644 --- a/tests/testthat/test-fact.R +++ b/tests/testthat/test-fact.R @@ -260,8 +260,8 @@ test_that("drop_levels() works", { exp <- factor(1, 1) expect_equal(drop_levels(x), exp) - df <- quick_dfl(x = x, y = 1) - df_exp <- quick_dfl(x = exp, y = 1) + df <- dataframe(x = x, y = 1) + df_exp <- dataframe(x = exp, y = 1) expect_equal(drop_levels(df), df_exp) # facts and ordered diff --git a/tests/testthat/test-fct-expand-seq.R b/tests/testthat/test-fct-expand-seq.R index 9de459f6..d8cf35de 100644 --- a/tests/testthat/test-fct-expand-seq.R +++ b/tests/testthat/test-fct-expand-seq.R @@ -1,29 +1,41 @@ x <- ordered(letters[c(5:15, 2)], levels = letters) test_that("Sequences correctly", { - expect_equal(fct_expand_seq(x), - ordered(letters[2:15], levels = letters)) + expect_identical( + fct_expand_seq(x), + ordered(letters[2:15], levels = letters) + ) + + expect_identical( + fct_expand_seq(x, "g", "s", 3L), + ordered(letters[seq(7, 19, 3)], levels = letters) + ) - expect_equal(fct_expand_seq(x, "g", "s", 3L), - ordered(letters[seq(7, 19, 3)], levels = letters)) + expect_identical( + fct_expand_seq(x, "g", "s", 3L), + fct_expand_seq(x, "g", "t", 3L) + ) - expect_equal(fct_expand_seq(x, "g", "s", 3L), - fct_expand_seq(x, "g", "t", 3L)) - expect_equal(fct_expand_seq(x, 1), - ordered(letters[1:15], levels = letters)) + expect_identical( + fct_expand_seq(x, 1), + ordered(letters[1:15], levels = letters) + ) }) test_that("fct_expand_seq() fails", { - expect_error(fct_expand_seq("a"), class = "simpleError") - expect_error(fct_expand_seq(as.ordered("a"), by = NA), class = "simpleError") + expect_error(fct_expand_seq("a"), class = "class_error") + expect_error( + fct_expand_seq(as.ordered("a"), by = NA), + class = "input_error" + ) expect_error( fct_expand_seq(as.ordered("a"), min_lvl = NA), - class = "fctExpandSeqNaError" + class = "mark:fct_expand_seq_error" ) expect_error( fct_expand_seq(as.ordered("a"), max_lvl = NA), - class = "fctExpandSeqNaError" + class = "mark:fct_expand_seq_error" ) }) diff --git a/tests/testthat/test-file.R b/tests/testthat/test-file.R index de41a66a..3c64210d 100644 --- a/tests/testthat/test-file.R +++ b/tests/testthat/test-file.R @@ -1,4 +1,4 @@ -test_that("file_copy_md5() works", { +muffle_cnd_conditions(test_that("file_copy_md5() works", { x <- c(tempfile("one"), tempfile("two"), tempfile("three")) y <- c(tempfile("one"), tempfile("two"), tempfile("three")) on.exit(fs::file_delete(c(x, y))) @@ -8,36 +8,42 @@ test_that("file_copy_md5() works", { writeLines("three", x[3L]) # none of y exists - expect_message( + expect_condition( file_copy_md5(x, y, overwrite = FALSE), - class = fuj_message() + class = "mark:md5_condition" ) - expect_message( + + expect_condition( file_copy_md5(x, y, overwrite = FALSE), - class = fuj_message() + class = "mark:md5_condition" ) # all of y exists - expect_message( + expect_condition( file_copy_md5(x, y, overwrite = TRUE), - class = fuj_message() + class = "mark:md5_condition" ) # mix writeLines("twotwo", y[2L]) fs::file_delete(y[3L]) - expect_message( + expect_condition( expect_identical( attr(file_copy_md5(x, y), "changed"), c(FALSE, TRUE, NA) ), - class = fuj_message(), + class = "mark:md5_condition", regexp = paste( - "one", "md5 same", "two", "md5 change", "three", "new file", + "one", + "md5 same", + "two", + "md5 change", + "three", + "new file", sep = ".*" ) ) - expect_message(file_copy_md5(x, y, quiet = TRUE), NA) -}) + expect_condition(file_copy_md5(x, y, quiet = TRUE), NA) +})) diff --git a/tests/testthat/test-funs.R b/tests/testthat/test-funs.R index 0cf03d00..b82f0e7a 100644 --- a/tests/testthat/test-funs.R +++ b/tests/testthat/test-funs.R @@ -26,7 +26,7 @@ test_that("outer_*()", { test_that("require_namespace()", { expect_error( require_namespace("impossible package"), - class = "namespaceError" + class = "packageNotFoundError" ) foo <- function() { @@ -37,12 +37,12 @@ test_that("require_namespace()", { foo() } - expect_error(foo(), class = "namespaceError") - expect_error(bar(), class = "namespaceError") + expect_error(foo(), class = "packageNotFoundError") + expect_error(bar(), class = "packageNotFoundError") expect_error( require_namespace("this_one", "that_thing"), - class = "namespaceError" + class = "packageNotFoundError" ) }) @@ -50,17 +50,15 @@ test_that("quiet_stop()", { expect_error(quiet_stop(), NULL) foo <- function(x) { - tryCatch(quiet_stop(), - error = function(e) { - !is.null(e$message) - }) + tryCatch(quiet_stop(), error = function(e) { + !is.null(e$message) + }) } bar <- function(x) { - tryCatch(quiet_stop(), - error = function(e) { - warning(e$message) - }) + tryCatch(quiet_stop(), error = function(e) { + warning(e$message) + }) } # Message exists diff --git a/tests/testthat/test-identical.R b/tests/testthat/test-identical.R index 58a8236e..0cd826bc 100644 --- a/tests/testthat/test-identical.R +++ b/tests/testthat/test-identical.R @@ -3,7 +3,6 @@ test_that("are_identical() works", { y[2] <- 3L z[5] <- NA_integer_ - res <- are_identical(x, y) exp <- c(TRUE, FALSE, TRUE, TRUE, TRUE) expect_identical(res, exp) @@ -14,8 +13,8 @@ test_that("are_identical() works", { }) test_that("are_identical() fails", { - expect_error(are_identical(1, 1:3), class = "areIdenticalNoneError") - expect_error(are_identical(NULL), class = "areIdenticalTwoError") + expect_error(are_identical(1, 1:3), class = "input_error") + expect_error(are_identical(NULL), class = "input_error") }) # lintr things there isn't a terminal line here? diff --git a/tests/testthat/test-import.R b/tests/testthat/test-import.R index 3b1c3c46..df6db907 100644 --- a/tests/testthat/test-import.R +++ b/tests/testthat/test-import.R @@ -1,6 +1,6 @@ test_that("import() works", { import("tools", "file_ext") expect_identical(file_ext, tools::file_ext) - expect_error(import("tools", "file_ext"), class = "importAssignedError") + expect_error(import("tools", "file_ext"), class = "mark:import_error") expect_error(import("tools", "file_ext", overwrite = TRUE), NA) }) diff --git a/tests/testthat/test-insert.R b/tests/testthat/test-insert.R index 7fc941ae..6fe41962 100644 --- a/tests/testthat/test-insert.R +++ b/tests/testthat/test-insert.R @@ -1,4 +1,3 @@ - test_that("insert.default() works", { res <- insert(letters[1:5], c(2, 4), c("X", "Y")) exp <- c("a", "X", "b", "c", "Y", "d", "e") @@ -8,19 +7,20 @@ test_that("insert.default() works", { exp <- c("z", "a", "b", "z", "c", "d") expect_identical(res, exp) - expect_error(insert(1, NA, 1), class = "simpleError") - expect_error(insert(1, integer(), 1), class = "insertNposError") - expect_error(insert(1, 1, integer()), class = "insertLengthError") + expect_error(insert(1, NA, 1), class = "input_error") + expect_error(insert(1, integer(), 1), NA) # this is actually fine + expect_error(insert(1, integer(), integer()), NA) # this is actually fine + expect_error(insert(1, 1, integer()), class = "input_error") }) test_that("insert.data.frame() works", { - x <- quick_dfl( + x <- dataframe( a = c(1, 2, 3), b = c("a", "b", "c"), c = c(-1.5, 0, 1.5) ) - exp <- quick_dfl( + exp <- dataframe( a = c(1, 2, 3), x = 1:3, b = c("a", "b", "c"), diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index d9d3e294..e02c4710 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -17,7 +17,7 @@ test_that("data.frame assignment", { x0 <- head(iris) x <- assign_labels(x0, Sepal.Length = "a", Species = "b") - exp <- quick_dfl( + exp <- dataframe( column = colnames(x0), label = c("a", NA, NA, NA, "b") ) @@ -31,13 +31,14 @@ test_that("data.frame assignment", { expect_error( assign_labels(x0, a = "x", b = "y", `1` = 2), - "Columns not found: a, b, 1", - class = "assignLabelsDataframeMissingError" + "not found", + class = "mark:assign_labels_error" ) expect_error( assign_labels(x0, NULL), - class = "assignLabelsDataframeNamesError" + "malformed", + class = "mark:assign_labels_error" ) expect_true(is.null(attr(exp0[["Species"]], "label"))) @@ -45,18 +46,35 @@ test_that("data.frame assignment", { expect_equal(x0, exp2) expect_equal(exp1, exp2) - expect_error(assign_labels(x0, .ls = list()), class = "simpleError") + expect_error( + assign_labels(x0, .ls = list()), + "malformed", + class = "mark:assign_labels_error" + ) expect_error( assign_labels(x0, a = 1, .ls = list(b = 2)), - class = "assignLabelsDataframeDotsError" + "set", + class = "mark:assign_labels_error" + ) + + df <- dataframe(a = 1, b = 2, c = 3) + expect_error( + assign_labels(df, c = "c", d = "d", .missing = "error"), + "not found", + class = "mark:assign_labels_error" ) - df <- quick_dfl(a = 1, b = 2, c = 3) - # nolint start: line_length_linter. - expect_error(assign_labels(df, c = "c", d = "d", .missing = "error"), class = "assignLabelsDataframeMissingError") - expect_warning(assign_labels(df, c = "c", d = "d", .missing = "warn"), class = "assignLabelsDataframeMissingWarning") - expect_warning(assign_labels(df, c = "c", d = "d", .missing = "skip"), NA) - # nolint end: line_length_linter. + # error is raised as a warning + expect_error( + assign_labels(df, c = "c", d = "d", .missing = "warn"), + "not found", + class = "mark:assign_labels_error" + ) + + expect_warning( + assign_labels(df, c = "c", d = "d", .missing = "skip"), + NA + ) }) test_that("data.frame assign with data.frame", { @@ -64,29 +82,28 @@ test_that("data.frame assign with data.frame", { x <- assign_labels(iris, Sepal.Length = "a", Species = "b") - labels <- quick_dfl( + labels <- dataframe( name = c("Sepal.Length", "Species"), label = c("a", "b") ) y <- assign_labels(iris, labels) - exp <- quick_dfl( + exp <- dataframe( column = colnames(iris), label = c("a", NA, NA, NA, "b") ) expect_equal(get_labels(y), get_labels(y)) - bad_labels <- quick_dfl( + bad_labels <- dataframe( v1 = c("a", "b", 1), v2 = c("x", "y", 2) ) expect_error( assign_labels(iris, bad_labels), - "Columns not found: a, b, 1", - class = "assignLabelsDataframeMissingError" + class = "mark:assign_labels_error" ) options(op) @@ -95,13 +112,12 @@ test_that("data.frame assign with data.frame", { test_that("view_labels() works", { df <- data.frame(a = 1, b = 2) df <- assign_labels(df, a = "a", b = "b") - - # redefine "View" - View <- function(x, ...) identity(x) # nolint: object_name_linter. - expect_error(view_labels(df), NA) - - View <- NA # nolint: object_name_linter. - expect_error(view_labels(df), class = "viewLabelsSomethingError") + if (interactive()) { + skip("interactive session open new view") + expect_no_error(view_labels(df)) # opens a viewer + } else { + expect_output(view_labels(df), "a", fixed = TRUE) + } }) test_that("exact match [141]", { diff --git a/tests/testthat/test-limit.R b/tests/testthat/test-limit.R index 9543a0a4..58930c90 100644 --- a/tests/testthat/test-limit.R +++ b/tests/testthat/test-limit.R @@ -4,9 +4,9 @@ test_that("limit() works", { }) test_that("limit() errors", { - expect_error(limit(1, "a", 1), class = "simpleError") - expect_error(limit(1, 1:2, 1), class = "simpleError") - expect_error(limit(1, 1, "a"), class = "simpleError") - expect_error(limit(1, 1, 1:2), class = "simpleError") - expect_error(limit(1, 2, 1), class = "simpleError") + expect_error(limit(1, "a", 1), class = "class_error") + expect_error(limit(1, 1, "a"), class = "class_error") + expect_error(limit(1, 1:2, 1), class = "input_error") + expect_error(limit(1, 1, 1:2), class = "input_error") + expect_error(limit(1, 2, 1), class = "input_error") }) diff --git a/tests/testthat/test-logic.R b/tests/testthat/test-logic.R index b8db1d70..df46dc6c 100644 --- a/tests/testthat/test-logic.R +++ b/tests/testthat/test-logic.R @@ -1,19 +1,19 @@ +# fmt: skip test_that("Logical extension work", { - x <- c(TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, NA, NA, NA) - y <- c(TRUE, FALSE, NA, TRUE, FALSE, NA, TRUE, FALSE, NA) - z <- c(TRUE, TRUE, FALSE, FALSE, NA, NA, TRUE, FALSE, NA) + # nolint start: spaces_inside_linter. + x <- c(TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, NA, NA, NA) + y <- c(TRUE, FALSE, NA, TRUE, FALSE, NA, TRUE, FALSE, NA) + z <- c(TRUE, TRUE, FALSE, FALSE, NA, NA, TRUE, FALSE, NA) - # nolint start: object_name_linter. - xL <- as.integer(x) - xD <- as.double(x) - # nolint end: object_name_linter. + xL <- as.integer(x) # nolint: object_name_linter. + xD <- as.double(x) # nolint: object_name_linter. res_n <- logical(length(x)) - res_xy_and <- res_n - res_xy_and_na <- res_n - res_xy_or <- res_n - res_xy_or_na <- res_n + res_xy_and <- res_n + res_xy_and_na <- res_n + res_xy_or <- res_n + res_xy_or_na <- res_n res_xyz_and <- res_n res_xyz_and_na <- res_n @@ -28,34 +28,54 @@ test_that("Logical extension work", { res_xyz_or[i] <- x[i] | y[i] | z[i] res_xy_and_na[i] <- all(x[i], y[i], na.rm = TRUE) - res_xy_or_na[i] <- any(x[i], y[i], na.rm = TRUE) + res_xy_or_na[i] <- any(x[i], y[i], na.rm = TRUE) res_xyz_and_na[i] <- all(x[i], y[i], z[i], na.rm = TRUE) - res_xyz_or_na[i] <- any(x[i], y[i], z[i], na.rm = TRUE) + res_xyz_or_na[i] <- any(x[i], y[i], z[i], na.rm = TRUE) } - expect_equal(is_true(x), sapply(x, isTRUE, USE.NAMES = FALSE)) + expect_equal(is_true(x), sapply(x, isTRUE, USE.NAMES = FALSE)) expect_equal(is_false(x), sapply(x, isFALSE, USE.NAMES = FALSE)) - # nolint next: spaces_inside_linter. - expect_identical(is_true(c( TRUE, FALSE, NA)), c(TRUE, FALSE, FALSE)) - expect_identical(is_false(c(TRUE, FALSE, NA)), c(FALSE, TRUE, FALSE)) + expect_identical(is_true( c(TRUE, FALSE, NA)), c(TRUE, FALSE, FALSE)) + expect_identical(is_false(c(TRUE, FALSE, NA)), c(FALSE, TRUE, FALSE)) expect_true(is_boolean(x)) expect_true(is_boolean(xL)) expect_true(is_boolean(xD)) - expect_equal(AND(x, y), res_xy_and) + expect_equal(AND(x, y), res_xy_and) expect_equal(AND(x, y, na.rm = TRUE), res_xy_and_na) - expect_equal(AND(x, y, z), res_xyz_and) + expect_equal(AND(x, y, z), res_xyz_and) expect_equal(AND(x, y, z, na.rm = TRUE), res_xyz_and_na) - expect_equal(OR(x, y), res_xy_or) + expect_equal(OR(x, y), res_xy_or) expect_equal(OR(x, y, na.rm = TRUE), res_xy_or_na) - expect_equal(OR(x, y, na.rm = TRUE), res_xy_or_na) + expect_equal(OR(x, y, na.rm = TRUE), res_xy_or_na) expect_equal(OR(x, y, z, na.rm = TRUE), res_xyz_or_na) + # nolint end: spaces_inside_linter. +}) + +test_that("logical helpers", { + expect_error(check_null(NULL), class = "input_error") + expect_error(check_null(integer()), class = "input_error") + + expect_error( + apply_logical_matrix(1L, mean, TRUE), + class = "input_error" + ) + + expect_error( + apply_logical_matrix(matrix("a"), mean, TRUE), + class = "input_error" + ) + + expect_error( + apply_logical_matrix(matrix(3L), mean, TRUE), + class = "input_error" + ) }) test_that("is_true()/is_false()", { @@ -113,9 +133,13 @@ test_that("none() works", { }) test_that("logical helpers", { - expect_error(apply_logical_matrix(1L, mean, TRUE), class = "simpleError") - # nolint start: line_length_linter. - expect_error(apply_logical_matrix(matrix("a"), mean, TRUE), class = "simpleError") - expect_error(apply_logical_matrix(matrix(3L), mean, TRUE), class = "simpleError") - # nolint end: line_length_linter. + expect_error(apply_logical_matrix(1L, mean, TRUE), class = "input_error") + expect_error( + apply_logical_matrix(matrix("a"), mean, TRUE), + class = "input_error" + ) + expect_error( + apply_logical_matrix(matrix(3L), mean, TRUE), + class = "input_error" + ) }) diff --git a/tests/testthat/test-match-arg.R b/tests/testthat/test-match-arg.R index ccaa5ffb..76c6b1b9 100644 --- a/tests/testthat/test-match-arg.R +++ b/tests/testthat/test-match-arg.R @@ -15,16 +15,16 @@ test_that("match_param() works", { sep = "\n" ), fixed = TRUE, - class = "matchParamMatchError" + class = "mark:match_param_error" ) foo2 <- function(y = 1:3) { match_param(y) } - expect_equal(foo2(1), 1) - expect_equal(foo2(1L), 1L) - expect_equal(foo2("1"), 1) + expect_identical(foo2(1), 1L) + expect_identical(foo2(1L), 1L) + expect_identical(foo2("1"), 1L) foo <- function(x = NULL) { match_param(tolower(x), c("a", "b", "c")) @@ -38,7 +38,7 @@ test_that("match_param() works", { " choices a, b, c", sep = "\n" ), - class = "matchParamMatchError", + class = "mark:match_param_error", fixed = TRUE ) @@ -46,7 +46,7 @@ test_that("match_param() works", { match_param(x, null = null) } - expect_error(foo(NULL), class = "condMatchParamNullError") + expect_error(foo(NULL), class = "input_error") expect_null(foo(NULL, null = TRUE)) }) @@ -56,7 +56,7 @@ test_that("match_param() can partialy match", { } expect_identical(fruits(), "apple") - expect_error(fruits("a"), class = "matchParamMatchError") + expect_error(fruits("a"), class = "mark:match_param_error") expect_identical(fruits("app"), "apple") fruits <- function(x = list("apple" = 1:2, "apricot" = 3, "banana" = 4)) { @@ -64,7 +64,7 @@ test_that("match_param() can partialy match", { } expect_identical(fruits(), "apple") - expect_error(fruits(c(a = 0)), class = "matchParamMatchError") + expect_error(fruits(c(a = 0)), class = "mark:match_param_error") expect_identical(fruits(1), "apple") }) @@ -78,13 +78,13 @@ test_that("match_param() accepts can return multiple", { test_that("match_arg() works", { foo <- function(x = c("a", "b"), table) { - match_arg(x, table) + suppressWarnings(match_arg(x, table), "deprecated_warning") } expect_null(foo(NULL)) expect_identical(foo(), "a") expect_identical(foo(table = "a"), "a") - expect_error(foo(table = "c"), class = "condMatchArgError") + expect_error(foo(table = "c"), class = "mark:match_arg_error") }) test_that("match_param() accepts multiple [#104]", { @@ -115,11 +115,11 @@ test_that("match_param() accepts formula lists", { test_that("match_param() finds duplicate choices", { expect_error( match_param("a", c("a", "a")), - class = "matchParamDupesError" + class = "duplicate_error" ) expect_error( match_param(1, c(a = 1:2, b = 3:4, c = c(1, 3))), - class = "matchParamDupesError" + class = "duplicate_error" ) }) diff --git a/tests/testthat/test-md5.R b/tests/testthat/test-md5.R index 0584d8fb..11622e5e 100644 --- a/tests/testthat/test-md5.R +++ b/tests/testthat/test-md5.R @@ -12,8 +12,8 @@ test_that("md5() works", { ) expect_identical( - md5(quick_dfl(a = 1)), - "34e2f3ac0f1ba4794d0cd0160fe80c6e", + md5(quick_df(list(a = 1))), + "f16311aa3f99060be519c8e9b38101e6", ignore_attr = "class" ) }) @@ -29,5 +29,5 @@ test_that("md5(btyes) return the same", { test_that("snapshots", { expect_snapshot(md5(letters)) expect_snapshot(md5(1:100)) - expect_snapshot(md5(quick_dfl(a = 1))) + expect_snapshot(md5(dataframe(a = 1))) }) diff --git a/tests/testthat/test-na-assignment.R b/tests/testthat/test-na-assignment.R index 7b2b19e3..e8c4bfb6 100644 --- a/tests/testthat/test-na-assignment.R +++ b/tests/testthat/test-na-assignment.R @@ -14,7 +14,7 @@ test_that("NA_at() and NA_if() work as expected", { expect_equal(NA_if(-1:3, foo), c(-1, 0, NA, NA, NA)) # y cannot be longer than x - expect_error(NA_at(x, 1:10), class = "naAtMaxError") + expect_error(NA_at(x, 1:10), class = "value_error") res <- NA_at(1:4, function(i) which(i %% 2 == 0)) exp <- c(1L, NA, 3L, NA) @@ -36,10 +36,10 @@ test_that("NA_in() and NA_at() work as expected", { } # nolint start: commas_linter. - expect_equal(NA_in(x, foo), c(NA , NA , "c", NA , "d")) - expect_equal(NA_out(x, foo), c("a", "b", NA , "b", NA)) - expect_equal(NA_in(x, foo, d = TRUE), c("a", "b", NA , "b", NA)) - expect_equal(NA_out(x, foo, d = TRUE), c(NA , NA , "c", NA , "d")) + expect_equal(NA_in(x, foo), c(NA, NA, "c", NA, "d")) + expect_equal(NA_out(x, foo), c("a", "b", NA, "b", NA)) + expect_equal(NA_in(x, foo, d = TRUE), c("a", "b", NA, "b", NA)) + expect_equal(NA_out(x, foo, d = TRUE), c(NA, NA, "c", NA, "d")) # nolint end: commas_linter. # No error if y is longer @@ -48,16 +48,16 @@ test_that("NA_in() and NA_at() work as expected", { }) test_that("NA_*() 0 length", { - expect_identical(NA_at(integer()), integer()) - expect_identical(NA_at(double()), double()) - expect_identical(NA_at(character()), character()) - expect_identical(NA_if(integer()), integer()) - expect_identical(NA_if(double()), double()) - expect_identical(NA_if(character()), character()) - expect_identical(NA_in(integer()), integer()) - expect_identical(NA_in(double()), double()) - expect_identical(NA_in(character()), character()) - expect_identical(NA_out(integer()), integer()) - expect_identical(NA_out(double()), double()) + expect_identical(NA_at(integer()), integer()) + expect_identical(NA_at(double()), double()) + expect_identical(NA_at(character()), character()) + expect_identical(NA_if(integer()), integer()) + expect_identical(NA_if(double()), double()) + expect_identical(NA_if(character()), character()) + expect_identical(NA_in(integer()), integer()) + expect_identical(NA_in(double()), double()) + expect_identical(NA_in(character()), character()) + expect_identical(NA_out(integer()), integer()) + expect_identical(NA_out(double()), double()) expect_identical(NA_out(character()), character()) }) diff --git a/tests/testthat/test-names.R b/tests/testthat/test-names.R index 122a4748..2fc35792 100644 --- a/tests/testthat/test-names.R +++ b/tests/testthat/test-names.R @@ -28,7 +28,7 @@ test_that("names_sort() works", { set_names(rep(NA, 3), c(-1, 2, 10)) ) - expect_error(sort_names(list(a = 1)), class = "sortByAtomicError") + expect_error(sort_names(list(a = 1)), class = "input_error") expect_error(sort_names(NA), class = "simpleError") }) diff --git a/tests/testthat/test-nas.R b/tests/testthat/test-nas.R index 81ee60ab..c90f39a2 100644 --- a/tests/testthat/test-nas.R +++ b/tests/testthat/test-nas.R @@ -2,7 +2,7 @@ test_that("remove_na()", { x <- c(1, 2, NA, 3, NaN) expect_equal(remove_na(x), c(1, 2, 3)) expect_equal(remove_na(as.list(x)), list(1, 2, numeric(), 3, numeric())) - expect_error(remove_na(quick_dfl(x = 1)), class = "checkIsVectorModeError") + expect_error(remove_na(dataframe(x = 1)), class = "input_error") res <- remove_na(fact(x)) exp <- struct( @@ -24,12 +24,12 @@ test_that("remove_null()", { x <- list(a = 1, b = NULL, c = 1) expect_equal(remove_null(x), list(a = 1, c = 1)) - expect_error(remove_null(c(1, 2)), class = "simpleError") - expect_error(remove_null(quick_dfl(x = NULL)), class = "simpleError") + expect_error(remove_null(c(1, 2)), class = "type_error") + expect_error(remove_null(dataframe(x = NULL)), class = "type_error") }) test_that("*_na_cols() works", { - x <- quick_dfl( + x <- dataframe( first = c(NA, 2, 3, 4), second = c(1, NA, 3, 4), all = not_available(length = 4), @@ -50,11 +50,11 @@ test_that("*_na_cols() works", { expect_equal( is_na_cols(x), c(first = FALSE, second = FALSE, all = TRUE, last = FALSE, all2 = TRUE) - ) + ) - expect_error(select_na_cols(1), class = "simpleError") - expect_error(remove_na_cols(1), class = "simpleError") - expect_error(is_na_cols(1), class = "simpleError") + expect_error(select_na_cols(1), class = "class_error") + expect_error(remove_na_cols(1), class = "class_error") + expect_error(is_na_cols(1), class = "class_error") }) test_that("tableNA() works", { diff --git a/tests/testthat/test-not-available.R b/tests/testthat/test-not-available.R index 4278247f..1f45d30c 100644 --- a/tests/testthat/test-not-available.R +++ b/tests/testthat/test-not-available.R @@ -1,6 +1,9 @@ test_that("not_available() works", { expect_error(get_not_available(), NA) - expect_error(get_not_available("foo"), class = "getNotAvailableError") + expect_error( + get_not_available("foo"), + class = "mark:not_available_error" + ) val <- struct(NA, "foo") set_not_available("foo", val) @@ -13,9 +16,12 @@ test_that("not_available() works", { set_not_available("foo", NULL) set_not_available("foo_fun", function() NULL) - expect_error(get_not_available("foo_fun"), class = "getNotAvailableTypeError") + expect_error( + get_not_available("foo_fun"), + class = "class_error" + ) # reset list options(mark.na_list = NULL) - expect_identical(get_na_list(), na_list) + expect_identical(get_na_list(), op.mark$mark.na_list) }) diff --git a/tests/testthat/test-note.R b/tests/testthat/test-note.R index 4d71cff5..269bd518 100644 --- a/tests/testthat/test-note.R +++ b/tests/testthat/test-note.R @@ -36,7 +36,7 @@ test_that("note() work", { }) test_that("print.noted() passes to next methods [67] (data.frame)", { - x <- quick_dfl(a = 1:50) + x <- dataframe(a = 1:50) original <- capture.output(print(x, max = 5)) note(x) <- "note" @@ -68,20 +68,20 @@ test_that("print.noted() passes to next methods [67] (tibble)", { test_that("print_note() works with data.frame", { withr::local_options(list(mark.check_interactive = NA)) - x <- quick_dfl(a = 1:2, b = 1:2) + x <- dataframe(a = 1:2, b = 1:2) note(x) <- "This should work" expect_identical(print_note(x), x) - x <- list(a = 1:3, b = 2, c = quick_dfl(a = 1)) + x <- list(a = 1:3, b = 2, c = dataframe(a = 1)) note(x) <- "This is a list" expect_identical(print_note(x), x) }) test_that("note() errors", { withr::local_options(list(mark.check_interactive = NA)) - expect_error(print_note(1L), class = "simpleError") + expect_error(print_note(1L), class = "class_error") x <- struct(1L, "noted", note = struct("hi", "note_a_note")) - expect_error(print_note(x), class = "printNoteNotedError") + expect_error(print_note(x), class = "class_error") }) test_that("note() snapshots", { @@ -91,11 +91,11 @@ test_that("note() snapshots", { note(x) <- "snapshot vector" expect_snapshot(x) - x <- quick_dfl(a = 1:2, b = 1:2) + x <- dataframe(a = 1:2, b = 1:2) note(x) <- "snapshot data.frame" expect_snapshot(x) - x <- list(a = 1:2, b = 1:2, c = quick_dfl(a = 1, b = 2)) + x <- list(a = 1:2, b = 1:2, c = dataframe(a = 1, b = 2)) note(x) <- "snapshot list" expect_snapshot(x) diff --git a/tests/testthat/test-options.R b/tests/testthat/test-options.R index 9e93002f..17f53a0d 100644 --- a/tests/testthat/test-options.R +++ b/tests/testthat/test-options.R @@ -9,5 +9,5 @@ test_that("checkOptions() works", { expect_identical(getOption("mark.test.option2"), 2L) expect_error(checkOptions(1), info = "is.list(x)") - expect_error(checkOptions(list(1)), class = "checkOptionsNamesError") + expect_error(checkOptions(list(1)), class = "input_error") }) diff --git a/tests/testthat/test-paste.R b/tests/testthat/test-paste.R index b0e0d98b..15bec2fe 100644 --- a/tests/testthat/test-paste.R +++ b/tests/testthat/test-paste.R @@ -10,14 +10,21 @@ test_that("paste_combine() works", { expect_equal( paste_combine(x, y, z), - c("a1Jan", "a1Feb", "a2Jan", "a2Feb", - "b1Jan", "b1Feb", "b2Jan", "b2Feb") + c("a1Jan", "a1Feb", "a2Jan", "a2Feb", "b1Jan", "b1Feb", "b2Jan", "b2Feb") ) expect_equal( paste_combine(x, y, z, sep = "."), - c("a.1.Jan", "a.1.Feb", "a.2.Jan", "a.2.Feb", - "b.1.Jan", "b.1.Feb", "b.2.Jan", "b.2.Feb") + c( + "a.1.Jan", + "a.1.Feb", + "a.2.Jan", + "a.2.Feb", + "b.1.Jan", + "b.1.Feb", + "b.2.Jan", + "b.2.Feb" + ) ) expect_equal( @@ -32,13 +39,12 @@ test_that("paste_combine() works", { expect_equal( paste_combine(x, y, z, collate = FALSE), - c("a1Jan", "b1Jan", "a2Jan", "b2Jan", - "a1Feb", "b1Feb", "a2Feb", "b2Feb") + c("a1Jan", "b1Jan", "a2Jan", "b2Jan", "a1Feb", "b1Feb", "a2Feb", "b2Feb") ) }) test_that("paste_combine() fails", { - expect_error(paste_combine(1), class = "pasteCombineLengthError") + expect_error(paste_combine(1), class = "input_error") }) test_that("collapse0()", { @@ -54,5 +60,5 @@ test_that("collapse0()", { }) test_that("deprecated", { - expect_warning(paste_c(1, 2), "deprecated") + expect_warning(paste_c(1, 2), class = "deprecatedWarning") }) diff --git a/tests/testthat/test-percentile-rank.R b/tests/testthat/test-percentile-rank.R index a4cb29fa..76f6b6d3 100644 --- a/tests/testthat/test-percentile-rank.R +++ b/tests/testthat/test-percentile-rank.R @@ -15,5 +15,5 @@ test_that("percentile_rank() works", { test_that("percentile_rank_weighted() handles decimals [92]", { x <- c(1, 3.120000000001, 3.120000000001, 4) w <- 1:4 - expect_error(percentile_rank(x, w), class = "dupeCheckError") + expect_error(percentile_rank(x, w), class = "duplicate_error") }) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index fe7c999f..c2d4b8b9 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -4,7 +4,7 @@ test_that("with_par() works", { par0 <- graphics::par("mfrow") set.seed(42) - df <- quick_dfl(a = stats::rnorm(100), b = stats::rnorm(100)) + df <- dataframe(a = stats::rnorm(100), b = stats::rnorm(100)) # not testing for plot grDevices::dev.off() wuffle(with_par( diff --git a/tests/testthat/test-recode.R b/tests/testthat/test-recode.R index 90a33850..56d51492 100644 --- a/tests/testthat/test-recode.R +++ b/tests/testthat/test-recode.R @@ -4,7 +4,7 @@ test_that("recode_by() examples works", { expect_identical(res, exp) res <- recode_by(letters[1:3], c(`1` = "a", `2` = "b")) - exp <- c("1", "2", NA_character_) + exp <- c("1", "2", NA_character_) expect_identical(res, exp) res <- recode_by(letters[1:3], c(`1` = "a", `2` = "b"), mode = "integer") @@ -36,9 +36,8 @@ test_that("clean_na_coercion() works", { }) test_that("errors", { - txt <- "values to recode by were not properly set" - expect_error(recode_by(1, 1), class = "recodeValuesError") - expect_error(recode_only(1, 1), class = "recodeValuesError") + expect_error(recode_by(1, 1), class = "input_error") + expect_error(recode_only(1, 1), class = "input_error") }) test_that("single value", { diff --git a/tests/testthat/test-row-bind.R b/tests/testthat/test-row-bind.R index 42bfc2c1..50cb5d51 100644 --- a/tests/testthat/test-row-bind.R +++ b/tests/testthat/test-row-bind.R @@ -1,7 +1,7 @@ test_that("row_bind() works", { - res1 <- row_bind(quick_dfl(a = 1, b = 2), quick_dfl(b = 2, c = 3)) - res2 <- row_bind(list(quick_dfl(a = 1, b = 2), quick_dfl(b = 2, c = 3))) - exp <- quick_dfl(a = c(1L, NA), b = c(2L, 2L), c = c(NA, 3L)) + res1 <- row_bind(dataframe(a = 1, b = 2), dataframe(b = 2, c = 3)) + res2 <- row_bind(list(dataframe(a = 1, b = 2), dataframe(b = 2, c = 3))) + exp <- dataframe(a = c(1L, NA), b = c(2L, 2L), c = c(NA, 3L)) expect_identical(res1, exp) expect_identical(res2, exp) @@ -10,8 +10,8 @@ test_that("row_bind() works", { }) test_that("row_bind() actually works [66]", { - x <- list(quick_dfl(a = 1:2, b = 1:2), quick_dfl(b = 3, c = 4)) + x <- list(dataframe(a = 1:2, b = 1:2), dataframe(b = 3, c = 4)) res <- row_bind(x) - exp <- quick_dfl(a = c(1:2, NA), b = 1:3, c = c(NA, NA, 4L)) + exp <- dataframe(a = c(1:2, NA), b = 1:3, c = c(NA, NA, 4L)) expect_identical(res, exp) }) diff --git a/tests/testthat/test-sourcing.R b/tests/testthat/test-sourcing.R index 16a8b344..301a61c3 100644 --- a/tests/testthat/test-sourcing.R +++ b/tests/testthat/test-sourcing.R @@ -24,7 +24,7 @@ test_that("eval_named_chunk()", { ) file.remove(temp_rmd) - expect_error(eval_named_chunk(tempfile()), class = "evalNamedChunkRmdError") + expect_error(eval_named_chunk(tempfile()), class = "input_error") file <- tempfile(fileext = ".Rmd") file.create(file) expect_error(eval_named_chunk(file), "\"label_name\" is missing") diff --git a/tests/testthat/test-strings.R b/tests/testthat/test-strings.R index cf4344dc..e09adbd6 100644 --- a/tests/testthat/test-strings.R +++ b/tests/testthat/test-strings.R @@ -24,7 +24,7 @@ test_that("string slices", { ) xx <- c(x, x) - expect_error(str_slice_by_word(xx, 80), class = "simpleError") + expect_error(str_slice_by_word(xx, 80), class = "input_error") }) # Better outputs @@ -40,7 +40,7 @@ expect_my_date <- function(res, exp_char, ...) { expect_my_datetime <- function(res, exp_char, ...) { testthat::expect_equal( str_extract_datetime(res, ...), - capply(exp_char, \(x) strptime(x, format = "%Y-%m-%d %H%M%S", tz = "")), + capply(exp_char, \(ec) strptime(ec, format = "%Y-%m-%d %H%M%S", tz = "")), label = as.character(res), expected.label = exp_char ) diff --git a/tests/testthat/test-time-report.R b/tests/testthat/test-time-report.R deleted file mode 100644 index 941913b0..00000000 --- a/tests/testthat/test-time-report.R +++ /dev/null @@ -1,15 +0,0 @@ -test_that("simpleTimeReport() works", { - expect_error( - expect_warning( - simpleTimeReport("title goes here", { - 1 + 2 - foo_warn <- function() warning("this is a warning") - foo_msg <- function() message("this is a message") - foo_warn() - foo_msg() - cat("this is a cat\n") - quick_dfl(a = 1, b = 2) - }) - ), - NA) -}) diff --git a/tests/testthat/test-todos.R b/tests/testthat/test-todos.R index 4ce4ae69..1bd78658 100644 --- a/tests/testthat/test-todos.R +++ b/tests/testthat/test-todos.R @@ -63,8 +63,8 @@ test_that("todos() errors and messages", { path <- test_path("scripts") err <- "path must be a character vector of length 1L" - expect_error(todos(path = 1), class = "doTodoPathError") - expect_error(todos(path = c("a", "b")), class = "doTodoPathError") + expect_error(todos(path = 1), class = "input_error") + expect_error(todos(path = c("a", "b")), class = "input_error") expect_error(todos(path = "zzz")) expect_error(do_todo(c("todo", "fixme"), path = "."), NA) diff --git a/tests/testthat/test-within.R b/tests/testthat/test-within.R index db9d8dbc..e6361fd0 100644 --- a/tests/testthat/test-within.R +++ b/tests/testthat/test-within.R @@ -6,14 +6,14 @@ test_that("Examples are accurate", { test_that("between_more() works", { x <- 1:20 gele <- x >= 5 & x <= 10 - gel <- x >= 5 & x < 10 - gle <- x > 5 & x <= 10 - gl <- x > 5 & x < 10 + gel <- x >= 5 & x < 10 + gle <- x > 5 & x <= 10 + gl <- x > 5 & x < 10 expect_equal(between_more(x, 5, 10, "gele"), gele) - expect_equal(between_more(x, 5, 10, "gel"), gel) - expect_equal(between_more(x, 5, 10, "gle"), gle) - expect_equal(between_more(x, 5, 10, "gl"), gl) + expect_equal(between_more(x, 5, 10, "gel"), gel) + expect_equal(between_more(x, 5, 10, "gle"), gle) + expect_equal(between_more(x, 5, 10, "gl"), gl) # vectors for left or right @@ -30,20 +30,16 @@ test_that("between_more() works", { res <- c(FALSE, TRUE, TRUE, FALSE, FALSE) expect_identical(between_more(x, left, right), res) - expect_warning( - between_more(1:2, 3, 2), - "`left` > `right`", - class = "betweenMoreLrWarning" - ) + expect_warning(between_more(1:2, 3, 2), class = "input_warning") }) test_that("within()", { x <- 1:20 ss <- x >= 5 & x <= 10 - sr <- x >= 5 & x < 10 - rs <- x > 5 & x <= 10 - rr <- x > 5 & x < 10 + sr <- x >= 5 & x < 10 + rs <- x > 5 & x <= 10 + rr <- x > 5 & x < 10 expect_equal(within(x, 5, 10, "[]"), ss) expect_equal(within(x, 5, 10, "[)"), sr) @@ -67,9 +63,5 @@ test_that("within()", { expect_identical(within(x), x) - expect_warning( - within(1:2, 3, 2), - "`left` > `right`", - class = "withinLrWarning" - ) + expect_warning(within(1:2, 3, 2), class = "input_warning") }) diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index c2d40756..ffa1364e 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -1,9 +1,11 @@ test_that("write_file_md5() works", { - df <- quick_dfl(a = 1, b = 2) + df <- dataframe(a = 1, b = 2) temp <- withr::local_tempfile() expect_output(write_file_md5(df)) - expect_message(write_file_md5(df, temp), class = fuj_message()) - expect_message(write_file_md5(df, temp), class = fuj_message()) + muffle_cnd_conditions({ + expect_condition(write_file_md5(df, temp), class = "mark:md5_condition") + expect_condition(write_file_md5(df, temp), class = "mark:md5_condition") + }) # atomic expect_output(write_file_md5("lines")) @@ -14,15 +16,18 @@ test_that("write_file_md5() works", { test_that("write_file_md5() types", { foo <- function(method) { temp <- withr::local_tempfile() - x <- if (method %in% c(mark_write_methods()$lines, "write")) { - letters - } else { - quick_dfl(a = 1, b = "n", c = TRUE) - } - - expect_message( - write_file_md5(x, temp, method = !!method), - class = fuj_message() + x <- + if (method %in% c(mark_write_methods()$lines, "write")) { + letters + } else { + dataframe(a = 1, b = "n", c = TRUE) + } + + muffle_cnd_conditions( + expect_condition( + write_file_md5(x, temp, method = !!method), + class = "mark:md5_condition" + ) ) } @@ -33,22 +38,24 @@ test_that("write_file_md5() types", { test_that("path warning", { temp <- withr::local_tempfile() - x <- structure(quick_dfl(a = 1), path = temp) - expect_message( - expect_warning( - write_file_md5(x, temp), - "attr(x, \"path\") is being overwritten", - fixed = TRUE - ), - class = fuj_message() + x <- structure(dataframe(a = 1), path = temp) + muffle_cnd_conditions( + expect_condition( + expect_warning( + write_file_md5(x, temp), + "attr(x, \"path\") is being overwritten", + fixed = TRUE + ), + class = "mark:md5_condition" + ) ) }) test_that("write_file_md5() errors", { - df <- quick_dfl(a = 1) + df <- dataframe(a = 1) expect_error( write_file_md5(df, method = "foo"), - class = "matchParamMatchError" + class = "mark:match_param_error" ) }) @@ -56,7 +63,7 @@ test_that("compression works", { foo <- function(ext = "") { file <- tempfile(fileext = ext) on.exit(unlink(file, recursive = TRUE)) - df <- quick_dfl(a = 1) + df <- dataframe(a = 1) write_file_md5(df, file, quiet = TRUE) } @@ -82,7 +89,7 @@ test_that("list columns", { op <- options(mark.list.hook = method) on.exit(options(op)) - df <- quick_dfl(x = c("a", "b")) + df <- dataframe(x = c("a", "b")) df$y <- list(1:2, 2) write_file_md5(df, temp, quiet = TRUE) @@ -104,7 +111,7 @@ test_that("list columns", { "unimplemented type 'list' in 'EncodeElement'", fixed = TRUE ) - expect_error(foo(NA), class = "writeFileMd5ListHookError") + expect_error(foo(NA), class = "value_error") }) test_that("arrow prints something to stdout()", { @@ -116,11 +123,11 @@ test_that("arrow prints something to stdout()", { } expect_snapshot( - write_file_md5(quick_dfl(a = 1), method = "feather"), + write_file_md5(dataframe(a = 1), method = "feather"), transform = function(x) censor(x) ) expect_snapshot( - write_file_md5(quick_dfl(a = 1), method = "parquet"), + write_file_md5(dataframe(a = 1), method = "parquet"), transform = function(x) censor(x) ) })