diff --git a/.Rbuildignore b/.Rbuildignore index 308cab0ce..d03a951be 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,5 @@ ^\.github/workflows/R\.yaml$ ^\.github/workflows/pr-commands\.yaml$ ^CRAN-SUBMISSION$ +^air.toml$ +^\.vscode$ diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 000000000..8252247f3 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,5 @@ +{ + "[r]": { + "editor.formatOnSave": true + } +} diff --git a/R/chop.R b/R/chop.R index 1b4119131..5720644ab 100644 --- a/R/chop.R +++ b/R/chop.R @@ -105,12 +105,14 @@ col_chop <- function(x, indices) { #' @export #' @rdname chop -unchop <- function(data, - cols, - ..., - keep_empty = FALSE, - ptype = NULL, - error_call = current_env()) { +unchop <- function( + data, + cols, + ..., + keep_empty = FALSE, + ptype = NULL, + error_call = current_env() +) { check_dots_empty0(...) check_data_frame(data, call = error_call) check_required(cols, call = error_call) @@ -168,7 +170,13 @@ unchop <- function(data, # used to slice the data frame `x` was subset from to align it with `val`. # - `val` the unchopped data frame. -df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE, error_call = caller_env()) { +df_unchop <- function( + x, + ..., + ptype = NULL, + keep_empty = FALSE, + error_call = caller_env() +) { check_dots_empty() ptype <- check_list_of_ptypes(ptype, names = names(x), call = error_call) @@ -271,7 +279,12 @@ df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE, error_call = cal col <- unname(col) row_recycle <- col_sizes != sizes - col[row_recycle] <- map2(col[row_recycle], sizes[row_recycle], vec_recycle, call = error_call) + col[row_recycle] <- map2( + col[row_recycle], + sizes[row_recycle], + vec_recycle, + call = error_call + ) col <- list_unchop( x = col, diff --git a/R/complete.R b/R/complete.R index dafcc3793..1f6591bf1 100644 --- a/R/complete.R +++ b/R/complete.R @@ -61,19 +61,12 @@ #' fill = list(value1 = 0, value2 = 99), #' explicit = FALSE #' ) -complete <- function(data, - ..., - fill = list(), - explicit = TRUE) { - +complete <- function(data, ..., fill = list(), explicit = TRUE) { UseMethod("complete") } #' @export -complete.data.frame <- function(data, - ..., - fill = list(), - explicit = TRUE) { +complete.data.frame <- function(data, ..., fill = list(), explicit = TRUE) { check_bool(explicit) out <- expand(data, ...) @@ -100,10 +93,7 @@ complete.data.frame <- function(data, } #' @export -complete.grouped_df <- function(data, - ..., - fill = list(), - explicit = TRUE) { +complete.grouped_df <- function(data, ..., fill = list(), explicit = TRUE) { out <- dplyr::reframe( data, complete( diff --git a/R/data.R b/R/data.R index a75d8c980..f9aa3df9a 100644 --- a/R/data.R +++ b/R/data.R @@ -185,7 +185,6 @@ #' (downloaded April 2008) "billboard" - #' Household data #' #' This dataset is based on an example in diff --git a/R/dep-extract.R b/R/dep-extract.R index 72ac6916e..7fcb56a1a 100644 --- a/R/dep-extract.R +++ b/R/dep-extract.R @@ -8,7 +8,9 @@ #' @keywords internal #' @export extract_numeric <- function(x) { - message("extract_numeric() is deprecated: please use readr::parse_number() instead") + message( + "extract_numeric() is deprecated: please use readr::parse_number() instead" + ) as.numeric(gsub("[^0-9.-]+", "", as.character(x))) } diff --git a/R/dep-lazyeval.R b/R/dep-lazyeval.R index 828e98413..cc361b83f 100644 --- a/R/dep-lazyeval.R +++ b/R/dep-lazyeval.R @@ -79,16 +79,31 @@ nesting_ <- function(x) { #' @rdname deprecated-se #' @inheritParams extract #' @export -extract_ <- function(data, col, into, regex = "([[:alnum:]]+)", remove = TRUE, - convert = FALSE, ...) { +extract_ <- function( + data, + col, + into, + regex = "([[:alnum:]]+)", + remove = TRUE, + convert = FALSE, + ... +) { lifecycle::deprecate_warn("1.0.0", "extract_()", "extract()", always = TRUE) UseMethod("extract_") } #' @export -extract_.data.frame <- function(data, col, into, regex = "([[:alnum:]]+)", - remove = TRUE, convert = FALSE, ...) { +extract_.data.frame <- function( + data, + col, + into, + regex = "([[:alnum:]]+)", + remove = TRUE, + convert = FALSE, + ... +) { col <- compat_lazy(col, caller_env()) - extract(data, + extract( + data, col = !!col, into = into, regex = regex, @@ -107,7 +122,11 @@ fill_ <- function(data, fill_cols, .direction = c("down", "up")) { UseMethod("fill_") } #' @export -fill_.data.frame <- function(data, fill_cols, .direction = c("down", "up", "downup", "updown")) { +fill_.data.frame <- function( + data, + fill_cols, + .direction = c("down", "up", "downup", "updown") +) { vars <- syms(fill_cols) fill(data, !!!vars, .direction = .direction) } @@ -120,20 +139,34 @@ fill_.data.frame <- function(data, fill_cols, .direction = c("down", "up", "down #' pair of key-value columns. #' @keywords internal #' @export -gather_ <- function(data, key_col, value_col, gather_cols, na.rm = FALSE, - convert = FALSE, factor_key = FALSE) { +gather_ <- function( + data, + key_col, + value_col, + gather_cols, + na.rm = FALSE, + convert = FALSE, + factor_key = FALSE +) { lifecycle::deprecate_warn("1.2.0", "gather_()", "gather()", always = TRUE) UseMethod("gather_") } #' @export -gather_.data.frame <- function(data, key_col, value_col, gather_cols, - na.rm = FALSE, convert = FALSE, - factor_key = FALSE) { +gather_.data.frame <- function( + data, + key_col, + value_col, + gather_cols, + na.rm = FALSE, + convert = FALSE, + factor_key = FALSE +) { key_col <- sym(key_col) value_col <- sym(value_col) gather_cols <- syms(gather_cols) - gather(data, + gather( + data, key = !!key_col, value = !!value_col, !!!gather_cols, @@ -154,14 +187,22 @@ nest_ <- function(...) { #' @rdname deprecated-se #' @inheritParams separate_rows #' @export -separate_rows_ <- function(data, cols, sep = "[^[:alnum:].]+", - convert = FALSE) { +separate_rows_ <- function( + data, + cols, + sep = "[^[:alnum:].]+", + convert = FALSE +) { lifecycle::deprecate_warn("1.2.0", "separate_rows_()", "separate_rows()") UseMethod("separate_rows_") } #' @export -separate_rows_.data.frame <- function(data, cols, sep = "[^[:alnum:].]+", - convert = FALSE) { +separate_rows_.data.frame <- function( + data, + cols, + sep = "[^[:alnum:].]+", + convert = FALSE +) { cols <- syms(cols) separate_rows(data, !!!cols, sep = sep, convert = convert) } @@ -169,17 +210,35 @@ separate_rows_.data.frame <- function(data, cols, sep = "[^[:alnum:].]+", #' @rdname deprecated-se #' @inheritParams separate #' @export -separate_ <- function(data, col, into, sep = "[^[:alnum:]]+", remove = TRUE, - convert = FALSE, extra = "warn", fill = "warn", ...) { +separate_ <- function( + data, + col, + into, + sep = "[^[:alnum:]]+", + remove = TRUE, + convert = FALSE, + extra = "warn", + fill = "warn", + ... +) { lifecycle::deprecate_warn("1.2.0", "separate_()", "separate()", always = TRUE) UseMethod("separate_") } #' @export -separate_.data.frame <- function(data, col, into, sep = "[^[:alnum:]]+", - remove = TRUE, convert = FALSE, - extra = "warn", fill = "warn", ...) { +separate_.data.frame <- function( + data, + col, + into, + sep = "[^[:alnum:]]+", + remove = TRUE, + convert = FALSE, + extra = "warn", + fill = "warn", + ... +) { col <- sym(col) - separate(data, + separate( + data, col = !!col, into = into, sep = sep, @@ -194,18 +253,33 @@ separate_.data.frame <- function(data, col, into, sep = "[^[:alnum:]]+", #' @inheritParams spread #' @param key_col,value_col Strings giving names of key and value cols. #' @export -spread_ <- function(data, key_col, value_col, fill = NA, convert = FALSE, - drop = TRUE, sep = NULL) { +spread_ <- function( + data, + key_col, + value_col, + fill = NA, + convert = FALSE, + drop = TRUE, + sep = NULL +) { lifecycle::deprecate_warn("1.2.0", "spread_()", "spread()", always = TRUE) UseMethod("spread_") } #' @export -spread_.data.frame <- function(data, key_col, value_col, fill = NA, - convert = FALSE, drop = TRUE, sep = NULL) { +spread_.data.frame <- function( + data, + key_col, + value_col, + fill = NA, + convert = FALSE, + drop = TRUE, + sep = NULL +) { key_col <- sym(key_col) value_col <- sym(value_col) - spread(data, + spread( + data, key = !!key_col, value = !!value_col, fill = fill, diff --git a/R/doc-params.R b/R/doc-params.R index 2f7088887..7a2618e3b 100644 --- a/R/doc-params.R +++ b/R/doc-params.R @@ -81,7 +81,6 @@ #' @name tidyr_data_masking NULL - #' Argument type: tidy-select #' #' @description diff --git a/R/drop-na.R b/R/drop-na.R index d5f9c83ea..17958710d 100644 --- a/R/drop-na.R +++ b/R/drop-na.R @@ -32,7 +32,11 @@ drop_na.data.frame <- function(data, ...) { # Use all columns if no `...` are supplied cols <- data } else { - vars <- tidyselect::eval_select(expr(c(!!!dots)), data, allow_rename = FALSE) + vars <- tidyselect::eval_select( + expr(c(!!!dots)), + data, + allow_rename = FALSE + ) cols <- data[vars] } diff --git a/R/expand.R b/R/expand.R index 8e31493c7..5d846bde6 100644 --- a/R/expand.R +++ b/R/expand.R @@ -223,7 +223,11 @@ expand_grid <- function(..., .name_repair = "check_unique", .vary = "slowest") { # Flattens unnamed data frames after grid expansion out <- tidyr_new_list(out) - out <- df_list(!!!out, .name_repair = .name_repair, .error_call = current_env()) + out <- df_list( + !!!out, + .name_repair = .name_repair, + .error_call = current_env() + ) out <- tibble::new_tibble(out, nrow = size) out diff --git a/R/extract.R b/R/extract.R index a08a1d9e2..f98a292bf 100644 --- a/R/extract.R +++ b/R/extract.R @@ -43,14 +43,28 @@ #' #' # If no match, NA: #' df %>% extract(x, c("A", "B"), "([a-d]+)-([a-d]+)") -extract <- function(data, col, into, regex = "([[:alnum:]]+)", - remove = TRUE, convert = FALSE, ...) { +extract <- function( + data, + col, + into, + regex = "([[:alnum:]]+)", + remove = TRUE, + convert = FALSE, + ... +) { check_dots_used() UseMethod("extract") } #' @export -extract.data.frame <- function(data, col, into, regex = "([[:alnum:]]+)", - remove = TRUE, convert = FALSE, ...) { +extract.data.frame <- function( + data, + col, + into, + regex = "([[:alnum:]]+)", + remove = TRUE, + convert = FALSE, + ... +) { check_required(col) var <- tidyselect::vars_pull(names(data), !!enquo(col)) @@ -61,7 +75,13 @@ extract.data.frame <- function(data, col, into, regex = "([[:alnum:]]+)", reconstruct_tibble(data, out, if (remove) var else chr()) } -str_extract <- function(x, into, regex, convert = FALSE, error_call = caller_env()) { +str_extract <- function( + x, + into, + regex, + convert = FALSE, + error_call = caller_env() +) { check_string(regex, call = error_call) check_not_stringr_pattern(regex, call = error_call) check_character(into, call = error_call) diff --git a/R/fill.R b/R/fill.R index 07b920549..d0926597d 100644 --- a/R/fill.R +++ b/R/fill.R @@ -98,19 +98,23 @@ #' dplyr::group_by(group) %>% #' fill(n_squirrels, .direction = "downup") %>% #' dplyr::ungroup() -fill <- function(data, - ..., - .by = NULL, - .direction = c("down", "up", "downup", "updown")) { +fill <- function( + data, + ..., + .by = NULL, + .direction = c("down", "up", "downup", "updown") +) { check_dots_unnamed() UseMethod("fill") } #' @export -fill.data.frame <- function(data, - ..., - .by = NULL, - .direction = c("down", "up", "downup", "updown")) { +fill.data.frame <- function( + data, + ..., + .by = NULL, + .direction = c("down", "up", "downup", "updown") +) { vars <- names(tidyselect::eval_select( expr = expr(c(...)), data = data, diff --git a/R/gather.R b/R/gather.R index 34b59b576..8be246b9c 100644 --- a/R/gather.R +++ b/R/gather.R @@ -78,15 +78,28 @@ #' Sepal.Length, Sepal.Width, Petal.Length, Petal.Width) #' # same result but less verbose #' gather(mini_iris, key = "flower_att", value = "measurement", -Species) -gather <- function(data, key = "key", value = "value", ..., - na.rm = FALSE, convert = FALSE, factor_key = FALSE) { +gather <- function( + data, + key = "key", + value = "value", + ..., + na.rm = FALSE, + convert = FALSE, + factor_key = FALSE +) { check_dots_unnamed() UseMethod("gather") } #' @export -gather.data.frame <- function(data, key = "key", value = "value", ..., - na.rm = FALSE, convert = FALSE, - factor_key = FALSE) { +gather.data.frame <- function( + data, + key = "key", + value = "value", + ..., + na.rm = FALSE, + convert = FALSE, + factor_key = FALSE +) { key_var <- as_string(ensym(key)) value_var <- as_string(ensym(value)) diff --git a/R/hoist.R b/R/hoist.R index 192833468..cc72eac53 100644 --- a/R/hoist.R +++ b/R/hoist.R @@ -74,14 +74,15 @@ #' ) #' @export hoist #' @family rectangling -hoist <- function(.data, - .col, - ..., - .remove = TRUE, - .simplify = TRUE, - .ptype = NULL, - .transform = NULL) { - +hoist <- function( + .data, + .col, + ..., + .remove = TRUE, + .simplify = TRUE, + .ptype = NULL, + .transform = NULL +) { check_data_frame(.data) check_required(.col) pluckers <- check_pluckers(...) @@ -195,4 +196,3 @@ strike <- function(x, indices) { x } - diff --git a/R/id.R b/R/id.R index bd17a6fe1..88253de39 100644 --- a/R/id.R +++ b/R/id.R @@ -29,7 +29,6 @@ id <- function(.variables, drop = FALSE) { } attr(res, "n") <- n - if (drop) { id_var(res, drop = TRUE) } else { diff --git a/R/nest-legacy.R b/R/nest-legacy.R index 56577be33..7adf58d1d 100644 --- a/R/nest-legacy.R +++ b/R/nest-legacy.R @@ -118,15 +118,27 @@ nest_legacy.data.frame <- function(data, ..., .key = "data") { nest_legacy.tbl_df(data, ..., .key = !!.key) } - #' @export #' @rdname nest_legacy -unnest_legacy <- function(data, ..., .drop = NA, .id = NULL, .sep = NULL, .preserve = NULL) { +unnest_legacy <- function( + data, + ..., + .drop = NA, + .id = NULL, + .sep = NULL, + .preserve = NULL +) { UseMethod("unnest_legacy") } #' @export -unnest_legacy.data.frame <- function(data, ..., .drop = NA, .id = NULL, - .sep = NULL, .preserve = NULL) { +unnest_legacy.data.frame <- function( + data, + ..., + .drop = NA, + .id = NULL, + .sep = NULL, + .preserve = NULL +) { preserve <- tidyselect::vars_select(names(data), !!enquo(.preserve)) quos <- quos(...) if (is_empty(quos)) { @@ -208,8 +220,11 @@ unnest_legacy.data.frame <- function(data, ..., .drop = NA, .id = NULL, } list_col_type <- function(x) { - is_data_frame <- is.data.frame(attr(x, "ptype", exact = TRUE)) || (is.list(x) && all(map_lgl(x, is.data.frame))) - is_atomic <- all(map_lgl(x, function(x) is_atomic(x) || (is_list(x) && !is.object(x)))) + is_data_frame <- is.data.frame(attr(x, "ptype", exact = TRUE)) || + (is.list(x) && all(map_lgl(x, is.data.frame))) + is_atomic <- all(map_lgl(x, function(x) { + is_atomic(x) || (is_list(x) && !is.object(x)) + })) if (is_data_frame) { "dataframe" diff --git a/R/nest.R b/R/nest.R index 4cc373b66..541097fda 100644 --- a/R/nest.R +++ b/R/nest.R @@ -117,11 +117,7 @@ #' mtcars %>% #' nest(.by = cyl) %>% #' dplyr::mutate(models = lapply(data, function(df) lm(mpg ~ wt, data = df))) -nest <- function(.data, - ..., - .by = NULL, - .key = NULL, - .names_sep = NULL) { +nest <- function(.data, ..., .by = NULL, .key = NULL, .names_sep = NULL) { cols <- enquos(...) empty <- names2(cols) == "" @@ -160,11 +156,13 @@ nest <- function(.data, } #' @export -nest.data.frame <- function(.data, - ..., - .by = NULL, - .key = NULL, - .names_sep = NULL) { +nest.data.frame <- function( + .data, + ..., + .by = NULL, + .key = NULL, + .names_sep = NULL +) { # The data frame print handles nested data frames poorly, so we want to # convert data frames (but not subclasses) to tibbles if (identical(class(.data), "data.frame")) { @@ -181,11 +179,13 @@ nest.data.frame <- function(.data, } #' @export -nest.tbl_df <- function(.data, - ..., - .by = NULL, - .key = NULL, - .names_sep = NULL) { +nest.tbl_df <- function( + .data, + ..., + .by = NULL, + .key = NULL, + .names_sep = NULL +) { error_call <- current_env() info <- nest_info(.data, ..., .by = {{ .by }}, .key = .key) @@ -194,10 +194,20 @@ nest.tbl_df <- function(.data, outer <- info$outer inner <- .data[inner] - inner <- pack(inner, !!!cols, .names_sep = .names_sep, .error_call = error_call) + inner <- pack( + inner, + !!!cols, + .names_sep = .names_sep, + .error_call = error_call + ) out <- .data[outer] - out <- vec_cbind(out, inner, .name_repair = "check_unique", .error_call = error_call) + out <- vec_cbind( + out, + inner, + .name_repair = "check_unique", + .error_call = error_call + ) out <- reconstruct_tibble(.data, out) out <- chop(out, cols = all_of(names(cols)), error_call = error_call) @@ -210,14 +220,18 @@ nest.tbl_df <- function(.data, } #' @export -nest.grouped_df <- function(.data, - ..., - .by = NULL, - .key = NULL, - .names_sep = NULL) { +nest.grouped_df <- function( + .data, + ..., + .by = NULL, + .key = NULL, + .names_sep = NULL +) { by <- enquo(.by) if (!quo_is_null(by)) { - cli::cli_abort("Can't supply {.arg .by} when {.arg .data} is a grouped data frame.") + cli::cli_abort( + "Can't supply {.arg .by} when {.arg .data} is a grouped data frame." + ) } if (missing(...)) { @@ -229,11 +243,13 @@ nest.grouped_df <- function(.data, } } -nest_info <- function(.data, - ..., - .by = NULL, - .key = NULL, - .error_call = caller_env()) { +nest_info <- function( + .data, + ..., + .by = NULL, + .key = NULL, + .error_call = caller_env() +) { by <- enquo(.by) cols <- enquos(...) diff --git a/R/pack.R b/R/pack.R index 1aca68d09..8d8d622f7 100644 --- a/R/pack.R +++ b/R/pack.R @@ -116,12 +116,14 @@ pack <- function(.data, ..., .names_sep = NULL, .error_call = current_env()) { #' #' See [vctrs::vec_as_names()] for more details on these terms and the #' strategies used to enforce them. -unpack <- function(data, - cols, - ..., - names_sep = NULL, - names_repair = "check_unique", - error_call = current_env()) { +unpack <- function( + data, + cols, + ..., + names_sep = NULL, + names_repair = "check_unique", + error_call = current_env() +) { check_dots_empty0(...) check_data_frame(data, call = error_call) check_required(cols, call = error_call) @@ -268,7 +270,11 @@ strip_names <- function(df, base, names_sep) { names <- names(df) has_prefix <- regexpr(base, names, fixed = TRUE) == 1L - names[has_prefix] <- substr(names[has_prefix], nchar(base) + 1, nchar(names[has_prefix])) + names[has_prefix] <- substr( + names[has_prefix], + nchar(base) + 1, + nchar(names[has_prefix]) + ) set_names(df, names) } diff --git a/R/pivot-long.R b/R/pivot-long.R index ebece08d8..d9542ff39 100644 --- a/R/pivot-long.R +++ b/R/pivot-long.R @@ -134,41 +134,45 @@ #' names_to = c(".value", "set"), #' names_pattern = "(.)(.)" #' ) -pivot_longer <- function(data, - cols, - ..., - cols_vary = "fastest", - names_to = "name", - names_prefix = NULL, - names_sep = NULL, - names_pattern = NULL, - names_ptypes = NULL, - names_transform = NULL, - names_repair = "check_unique", - values_to = "value", - values_drop_na = FALSE, - values_ptypes = NULL, - values_transform = NULL) { +pivot_longer <- function( + data, + cols, + ..., + cols_vary = "fastest", + names_to = "name", + names_prefix = NULL, + names_sep = NULL, + names_pattern = NULL, + names_ptypes = NULL, + names_transform = NULL, + names_repair = "check_unique", + values_to = "value", + values_drop_na = FALSE, + values_ptypes = NULL, + values_transform = NULL +) { check_dots_used() UseMethod("pivot_longer") } #' @export -pivot_longer.data.frame <- function(data, - cols, - ..., - cols_vary = "fastest", - names_to = "name", - names_prefix = NULL, - names_sep = NULL, - names_pattern = NULL, - names_ptypes = NULL, - names_transform = NULL, - names_repair = "check_unique", - values_to = "value", - values_drop_na = FALSE, - values_ptypes = NULL, - values_transform = NULL) { +pivot_longer.data.frame <- function( + data, + cols, + ..., + cols_vary = "fastest", + names_to = "name", + names_prefix = NULL, + names_sep = NULL, + names_pattern = NULL, + names_ptypes = NULL, + names_transform = NULL, + names_repair = "check_unique", + values_to = "value", + values_drop_na = FALSE, + values_ptypes = NULL, + values_transform = NULL +) { spec <- build_longer_spec( data = data, cols = {{ cols }}, @@ -194,7 +198,6 @@ pivot_longer.data.frame <- function(data, ) } - #' Pivot data from wide to long using a spec #' #' This is a low level interface to pivoting, inspired by the cdata package, @@ -236,15 +239,17 @@ pivot_longer.data.frame <- function(data, #' names_to = "income", #' values_to = "count" #' ) -pivot_longer_spec <- function(data, - spec, - ..., - cols_vary = "fastest", - names_repair = "check_unique", - values_drop_na = FALSE, - values_ptypes = NULL, - values_transform = NULL, - error_call = current_env()) { +pivot_longer_spec <- function( + data, + spec, + ..., + cols_vary = "fastest", + names_repair = "check_unique", + values_drop_na = FALSE, + values_ptypes = NULL, + values_transform = NULL, + error_call = current_env() +) { check_dots_empty0(...) spec <- check_pivot_spec(spec, call = error_call) @@ -263,8 +268,16 @@ pivot_longer_spec <- function(data, value_keys <- split(spec[-(1:2)], v_fct) keys <- vec_unique(spec[-(1:2)]) - values_ptypes <- check_list_of_ptypes(values_ptypes, value_names, call = error_call) - values_transform <- check_list_of_functions(values_transform, value_names, call = error_call) + values_ptypes <- check_list_of_ptypes( + values_ptypes, + value_names, + call = error_call + ) + values_transform <- check_list_of_functions( + values_transform, + value_names, + call = error_call + ) vals <- set_names(vec_init(list(), length(values)), value_names) for (value in value_names) { @@ -344,17 +357,19 @@ pivot_longer_spec <- function(data, #' @rdname pivot_longer_spec #' @export -build_longer_spec <- function(data, - cols, - ..., - names_to = "name", - values_to = "value", - names_prefix = NULL, - names_sep = NULL, - names_pattern = NULL, - names_ptypes = NULL, - names_transform = NULL, - error_call = current_env()) { +build_longer_spec <- function( + data, + cols, + ..., + names_to = "name", + values_to = "value", + names_prefix = NULL, + names_sep = NULL, + names_pattern = NULL, + names_ptypes = NULL, + names_transform = NULL, + error_call = current_env() +) { check_dots_empty0(...) check_data_frame(data, call = error_call) check_required(cols, call = error_call) @@ -369,7 +384,10 @@ build_longer_spec <- function(data, cols <- names(cols) if (length(cols) == 0) { - cli::cli_abort("{.arg cols} must select at least one column.", call = error_call) + cli::cli_abort( + "{.arg cols} must select at least one column.", + call = error_call + ) } if (is.null(names_prefix)) { @@ -396,22 +414,40 @@ build_longer_spec <- function(data, ) } if (has_names_pattern) { - names <- str_extract(names, names_to, regex = names_pattern, error_call = error_call)[[1]] + names <- str_extract( + names, + names_to, + regex = names_pattern, + error_call = error_call + )[[1]] } names <- tibble(!!names_to := names) } else { if (!xor(has_names_sep, has_names_pattern)) { - cli::cli_abort(paste0( - "If you supply multiple names in {.arg names_to} you must also supply one", - " of {.arg names_sep} or {.arg names_pattern}." - ), call = error_call) + cli::cli_abort( + paste0( + "If you supply multiple names in {.arg names_to} you must also supply one", + " of {.arg names_sep} or {.arg names_pattern}." + ), + call = error_call + ) } if (has_names_sep) { - names <- str_separate(names, names_to, sep = names_sep, error_call = error_call) + names <- str_separate( + names, + names_to, + sep = names_sep, + error_call = error_call + ) } else { - names <- str_extract(names, names_to, regex = names_pattern, error_call = error_call) + names <- str_extract( + names, + names_to, + regex = names_pattern, + error_call = error_call + ) } } @@ -421,8 +457,16 @@ build_longer_spec <- function(data, vec_assert(values_to, ptype = character(), size = 1, call = error_call) } - names_ptypes <- check_list_of_ptypes(names_ptypes, names(names), call = error_call) - names_transform <- check_list_of_functions(names_transform, names(names), call = error_call) + names_ptypes <- check_list_of_ptypes( + names_ptypes, + names(names), + call = error_call + ) + names_transform <- check_list_of_functions( + names_transform, + names(names), + call = error_call + ) # Optionally, transform cols for (col in names(names_transform)) { @@ -433,7 +477,12 @@ build_longer_spec <- function(data, # Optionally, cast variables generated from columns for (col in names(names_ptypes)) { ptype <- names_ptypes[[col]] - names[[col]] <- vec_cast(names[[col]], ptype, x_arg = col, call = error_call) + names[[col]] <- vec_cast( + names[[col]], + ptype, + x_arg = col, + call = error_call + ) } out <- tibble(.name = cols) @@ -455,7 +504,6 @@ drop_cols <- function(df, cols) { # Ensure that there's a one-to-one match from spec to data by adding # a special .seq variable which is automatically removed after pivoting. deduplicate_spec <- function(spec, df) { - # Ensure each .name has a unique output identifier key <- spec[setdiff(names(spec), ".name")] if (vec_duplicate_any(key)) { diff --git a/R/pivot-wide.R b/R/pivot-wide.R index 2ae59bbd9..511f29354 100644 --- a/R/pivot-wide.R +++ b/R/pivot-wide.R @@ -155,43 +155,47 @@ #' values_from = breaks, #' values_fn = ~ mean(.x, na.rm = TRUE) #' ) -pivot_wider <- function(data, - ..., - id_cols = NULL, - id_expand = FALSE, - names_from = name, - names_prefix = "", - names_sep = "_", - names_glue = NULL, - names_sort = FALSE, - names_vary = "fastest", - names_expand = FALSE, - names_repair = "check_unique", - values_from = value, - values_fill = NULL, - values_fn = NULL, - unused_fn = NULL) { +pivot_wider <- function( + data, + ..., + id_cols = NULL, + id_expand = FALSE, + names_from = name, + names_prefix = "", + names_sep = "_", + names_glue = NULL, + names_sort = FALSE, + names_vary = "fastest", + names_expand = FALSE, + names_repair = "check_unique", + values_from = value, + values_fill = NULL, + values_fn = NULL, + unused_fn = NULL +) { # TODO: Use `check_dots_used()` after removing the `id_cols` compat behavior UseMethod("pivot_wider") } #' @export -pivot_wider.data.frame <- function(data, - ..., - id_cols = NULL, - id_expand = FALSE, - names_from = name, - names_prefix = "", - names_sep = "_", - names_glue = NULL, - names_sort = FALSE, - names_vary = "fastest", - names_expand = FALSE, - names_repair = "check_unique", - values_from = value, - values_fill = NULL, - values_fn = NULL, - unused_fn = NULL) { +pivot_wider.data.frame <- function( + data, + ..., + id_cols = NULL, + id_expand = FALSE, + names_from = name, + names_prefix = "", + names_sep = "_", + names_glue = NULL, + names_sort = FALSE, + names_vary = "fastest", + names_expand = FALSE, + names_repair = "check_unique", + values_from = value, + values_fill = NULL, + values_fn = NULL, + unused_fn = NULL +) { names_from <- enquo(names_from) values_from <- enquo(values_from) @@ -287,16 +291,18 @@ pivot_wider.data.frame <- function(data, #' #' us_rent_income %>% #' pivot_wider_spec(spec2) -pivot_wider_spec <- function(data, - spec, - ..., - names_repair = "check_unique", - id_cols = NULL, - id_expand = FALSE, - values_fill = NULL, - values_fn = NULL, - unused_fn = NULL, - error_call = current_env()) { +pivot_wider_spec <- function( + data, + spec, + ..., + names_repair = "check_unique", + id_cols = NULL, + id_expand = FALSE, + values_fill = NULL, + values_fn = NULL, + unused_fn = NULL, + error_call = current_env() +) { check_dots_empty0(...) check_data_frame(data, call = error_call) @@ -314,10 +320,21 @@ pivot_wider_spec <- function(data, error_call = error_call ) - values_fn <- check_list_of_functions(values_fn, values_from_cols, call = error_call) + values_fn <- check_list_of_functions( + values_fn, + values_from_cols, + call = error_call + ) - unused_cols <- setdiff(names(data), c(id_cols, names_from_cols, values_from_cols)) - unused_fn <- check_list_of_functions(unused_fn, unused_cols, call = error_call) + unused_cols <- setdiff( + names(data), + c(id_cols, names_from_cols, values_from_cols) + ) + unused_fn <- check_list_of_functions( + unused_fn, + unused_cols, + call = error_call + ) unused_cols <- names(unused_fn) if (is.null(values_fill)) { @@ -337,10 +354,20 @@ pivot_wider_spec <- function(data, # zero cols are selected. Also want to avoid the grouped-df behavior # of `complete()`. data <- as_tibble(data) - data <- data[vec_unique(c(id_cols, names_from_cols, values_from_cols, unused_cols))] + data <- data[vec_unique(c( + id_cols, + names_from_cols, + values_from_cols, + unused_cols + ))] if (id_expand) { - data <- complete(data, !!!syms(id_cols), fill = values_fill, explicit = FALSE) + data <- complete( + data, + !!!syms(id_cols), + fill = values_fill, + explicit = FALSE + ) } # Figure out rows in output @@ -431,7 +458,11 @@ pivot_wider_spec <- function(data, if (length(duplicate_names) > 0L) { duplicate_names <- glue::backtick(duplicate_names) - duplicate_names <- glue::glue_collapse(duplicate_names, sep = ", ", last = " and ") + duplicate_names <- glue::glue_collapse( + duplicate_names, + sep = ", ", + last = " and " + ) group_cols <- c(id_cols, names_from_cols) group_cols <- backtick_if_not_syntactic(group_cols) @@ -468,17 +499,19 @@ pivot_wider_spec <- function(data, #' @export #' @rdname pivot_wider_spec #' @inheritParams pivot_wider -build_wider_spec <- function(data, - ..., - names_from = name, - values_from = value, - names_prefix = "", - names_sep = "_", - names_glue = NULL, - names_sort = FALSE, - names_vary = "fastest", - names_expand = FALSE, - error_call = current_env()) { +build_wider_spec <- function( + data, + ..., + names_from = name, + values_from = value, + names_prefix = "", + names_sep = "_", + names_glue = NULL, + names_sort = FALSE, + names_vary = "fastest", + names_expand = FALSE, + error_call = current_env() +) { check_dots_empty0(...) names_from <- tidyselect::eval_select( @@ -553,11 +586,13 @@ build_wider_spec <- function(data, out } -build_wider_id_cols_expr <- function(data, - id_cols = NULL, - names_from = name, - values_from = value, - error_call = caller_env()) { +build_wider_id_cols_expr <- function( + data, + id_cols = NULL, + names_from = name, + values_from = value, + error_call = caller_env() +) { names_from <- tidyselect::eval_select( enquo(names_from), data, @@ -583,11 +618,13 @@ build_wider_id_cols_expr <- function(data, expr(c(!!!out)) } -select_wider_id_cols <- function(data, - id_cols = NULL, - names_from_cols = character(), - values_from_cols = character(), - error_call = caller_env()) { +select_wider_id_cols <- function( + data, + id_cols = NULL, + names_from_cols = character(), + values_from_cols = character(), + error_call = caller_env() +) { id_cols <- enquo(id_cols) # Remove known non-id-cols so they are never selected @@ -639,11 +676,13 @@ stop_id_cols_oob <- function(i, arg, call) { ) } -compat_id_cols <- function(id_cols, - ..., - fn_call, - error_call = caller_env(), - user_env = caller_env(2)) { +compat_id_cols <- function( + id_cols, + ..., + fn_call, + error_call = caller_env(), + user_env = caller_env(2) +) { dots <- enquos(...) # If `id_cols` is specified by name by the user, it will show up in the call. @@ -687,7 +726,14 @@ warn_deprecated_unnamed_id_cols <- function(id_cols, user_env = caller_env(2)) { # Helpers ----------------------------------------------------------------- -value_summarize <- function(value, value_locs, value_name, fn, fn_name, error_call = caller_env()) { +value_summarize <- function( + value, + value_locs, + value_name, + fn, + fn_name, + error_call = caller_env() +) { value <- vec_chop(value, value_locs) if (identical(fn, list)) { diff --git a/R/replace_na.R b/R/replace_na.R index 05874c8f2..507baf175 100644 --- a/R/replace_na.R +++ b/R/replace_na.R @@ -40,7 +40,13 @@ replace_na.default <- function(data, replace = NA, ...) { if (vec_any_missing(data)) { missing <- vec_detect_missing(data) - data <- vec_assign(data, missing, replace, x_arg = "data", value_arg = "replace") + data <- vec_assign( + data, + missing, + replace, + x_arg = "data", + value_arg = "replace" + ) } data @@ -49,7 +55,9 @@ replace_na.default <- function(data, replace = NA, ...) { #' @export replace_na.data.frame <- function(data, replace = list(), ...) { if (!vec_is_list(replace)) { - cli::cli_abort("{.arg replace} must be a list, not {.obj_type_friendly {replace}}.") + cli::cli_abort( + "{.arg replace} must be a list, not {.obj_type_friendly {replace}}." + ) } names <- intersect(names(replace), names(data)) diff --git a/R/separate-longer.R b/R/separate-longer.R index 879c6c6b3..eb56e80d9 100644 --- a/R/separate-longer.R +++ b/R/separate-longer.R @@ -50,7 +50,13 @@ separate_longer_delim <- function(data, cols, delim, ...) { #' use `keep_empty = TRUE` to replace size-0 elements with a missing value. #' @rdname separate_longer_delim #' @export -separate_longer_position <- function(data, cols, width, ..., keep_empty = FALSE) { +separate_longer_position <- function( + data, + cols, + width, + ..., + keep_empty = FALSE +) { check_installed("stringr") check_data_frame(data) check_required(cols) @@ -81,7 +87,14 @@ str_split_length <- function(x, width = 1) { # helpers ----------------------------------------------------------------- -map_unchop <- function(data, cols, fun, ..., .keep_empty = FALSE, .error_call = caller_env()) { +map_unchop <- function( + data, + cols, + fun, + ..., + .keep_empty = FALSE, + .error_call = caller_env() +) { cols <- tidyselect::eval_select( enquo(cols), data = data, diff --git a/R/separate-rows.R b/R/separate-rows.R index ce9c2e07b..c15f18784 100644 --- a/R/separate-rows.R +++ b/R/separate-rows.R @@ -28,19 +28,18 @@ #' # Now recommended #' df %>% #' separate_longer_delim(c(y, z), delim = ",") -separate_rows <- function(data, - ..., - sep = "[^[:alnum:].]+", - convert = FALSE) { +separate_rows <- function(data, ..., sep = "[^[:alnum:].]+", convert = FALSE) { check_dots_unnamed() UseMethod("separate_rows") } #' @export -separate_rows.data.frame <- function(data, - ..., - sep = "[^[:alnum:].]+", - convert = FALSE) { +separate_rows.data.frame <- function( + data, + ..., + sep = "[^[:alnum:].]+", + convert = FALSE +) { check_string(sep) check_bool(convert) diff --git a/R/separate-wider.R b/R/separate-wider.R index a92074bbd..004ec714e 100644 --- a/R/separate-wider.R +++ b/R/separate-wider.R @@ -128,16 +128,16 @@ #' # Or choose to automatically name the columns, producing as many as needed #' df %>% separate_wider_delim(x, delim = " ", names_sep = "", too_few = "align_start") separate_wider_delim <- function( - data, - cols, - delim, - ..., - names = NULL, - names_sep = NULL, - names_repair = "check_unique", - too_few = c("error", "debug", "align_start", "align_end"), - too_many = c("error", "debug", "drop", "merge"), - cols_remove = TRUE + data, + cols, + delim, + ..., + names = NULL, + names_sep = NULL, + names_repair = "check_unique", + too_few = c("error", "debug", "align_start", "align_end"), + too_many = c("error", "debug", "drop", "merge"), + cols_remove = TRUE ) { check_installed("stringr") check_data_frame(data) @@ -145,7 +145,9 @@ separate_wider_delim <- function( check_dots_empty() check_string(delim, allow_empty = FALSE) if (is.null(names) && is.null(names_sep)) { - cli::cli_abort("Must specify at least one of {.arg names} or {.arg names_sep}.") + cli::cli_abort( + "Must specify at least one of {.arg names} or {.arg names_sep}." + ) } check_character(names, allow_null = TRUE) if (is_named(names)) { @@ -158,33 +160,37 @@ separate_wider_delim <- function( error_call %<~% current_env() map_unpack( - data, {{ cols }}, - function(x, col) str_separate_wider_delim(x, col, - names = names, - delim = delim, - names_sep = names_sep, - too_few = too_few, - too_many = too_many, - cols_remove = cols_remove, - error_call = error_call - ), + data, + {{ cols }}, + function(x, col) { + str_separate_wider_delim( + x, + col, + names = names, + delim = delim, + names_sep = names_sep, + too_few = too_few, + too_many = too_many, + cols_remove = cols_remove, + error_call = error_call + ) + }, names_sep = names_sep, names_repair = names_repair ) } str_separate_wider_delim <- function( - x, - col, - names, - delim, - names_sep = NULL, - too_few = "error", - too_many = "error", - cols_remove = TRUE, - error_call = caller_env() + x, + col, + names, + delim, + names_sep = NULL, + too_few = "error", + too_many = "error", + cols_remove = TRUE, + error_call = caller_env() ) { - if (is_bare_string(delim)) { delim <- stringr::fixed(delim) } @@ -208,7 +214,11 @@ str_separate_wider_delim <- function( names <- names %||% as.character(seq_len(int_max(lengths, 0))) p <- length(names) - check_df_alignment(col, p, "pieces", n_pieces, + check_df_alignment( + col, + p, + "pieces", + n_pieces, too_few = too_few, too_many = too_many, advice_short = c( @@ -239,10 +249,9 @@ str_separate_wider_delim <- function( remainder <- stringr::str_sub(x, sep_last) remainder[is.na(remainder) & !is.na(x)] <- "" - problem <- !is.na(x) & ( - (too_few == "debug" & n_pieces < p) | - (too_many == "debug" & n_pieces > p) - ) + problem <- !is.na(x) & + ((too_few == "debug" & n_pieces < p) | + (too_many == "debug" & n_pieces > p)) out[[debug_name(col, names_sep, "ok")]] <- !problem out[[debug_name(col, names_sep, "pieces")]] <- n_pieces @@ -258,16 +267,16 @@ str_separate_wider_delim <- function( #' but not be included in the output. #' @export separate_wider_position <- function( - data, - cols, - widths, - ..., - names_sep = NULL, - names_repair = "check_unique", - too_few = c("error", "debug", "align_start"), - too_many = c("error", "debug", "drop"), - cols_remove = TRUE - ) { + data, + cols, + widths, + ..., + names_sep = NULL, + names_repair = "check_unique", + too_few = c("error", "debug", "align_start"), + too_many = c("error", "debug", "drop"), + cols_remove = TRUE +) { check_installed("stringr") check_data_frame(data) check_required(cols) @@ -287,35 +296,44 @@ separate_wider_position <- function( error_call %<~% current_env() map_unpack( - data, {{ cols }}, - function(x, col) str_separate_wider_position(x, col, - widths = widths, - names_sep = names_sep, - too_few = too_few, - too_many = too_many, - cols_remove = cols_remove, - error_call = error_call - ), + data, + {{ cols }}, + function(x, col) { + str_separate_wider_position( + x, + col, + widths = widths, + names_sep = names_sep, + too_few = too_few, + too_many = too_many, + cols_remove = cols_remove, + error_call = error_call + ) + }, names_sep = names_sep, names_repair = names_repair ) } -str_separate_wider_position <- function(x, - col, - widths, - names_sep = NULL, - too_few = "error", - too_many = "error", - cols_remove = TRUE, - error_call = caller_env() - ) { - +str_separate_wider_position <- function( + x, + col, + widths, + names_sep = NULL, + too_few = "error", + too_many = "error", + cols_remove = TRUE, + error_call = caller_env() +) { breaks <- cumsum(c(1L, unname(widths)))[-(length(widths) + 1L)] expected_width <- sum(widths) width <- stringr::str_length(x) - check_df_alignment(col, expected_width, "characters", width, + check_df_alignment( + col, + expected_width, + "characters", + width, too_few = too_few, too_many = too_many, advice_short = c( @@ -348,17 +366,19 @@ str_separate_wider_position <- function(x, if (too_few == "debug" || too_many == "debug") { separate_warn_debug(col, names_sep, c("ok", "width", "remainder")) - problem <- !is.na(x) & ( - (too_few == "debug" & width < expected_width) | - (too_many == "debug" & width > expected_width) - ) + problem <- !is.na(x) & + ((too_few == "debug" & width < expected_width) | + (too_many == "debug" & width > expected_width)) out[[debug_name(col, names_sep, "width")]] <- width - out[[debug_name(col, names_sep, "remainder")]] <- stringr::str_sub(x, expected_width + 1, width) + out[[debug_name(col, names_sep, "remainder")]] <- stringr::str_sub( + x, + expected_width + 1, + width + ) out[[debug_name(col, names_sep, "ok")]] <- !problem } - out } @@ -368,15 +388,15 @@ str_separate_wider_position <- function(x, #' vector. Unnamed components will match, but not be included in the output. #' @export separate_wider_regex <- function( - data, - cols, - patterns, - ..., - names_sep = NULL, - names_repair = "check_unique", - too_few = c("error", "debug", "align_start"), - cols_remove = TRUE - ) { + data, + cols, + patterns, + ..., + names_sep = NULL, + names_repair = "check_unique", + too_few = c("error", "debug", "align_start"), + cols_remove = TRUE +) { check_installed("stringr") check_data_frame(data) check_required(cols) @@ -392,36 +412,50 @@ separate_wider_regex <- function( error_call %<~% current_env() map_unpack( - data, {{ cols }}, - function(x, col) str_separate_wider_regex(x, col, - patterns = patterns, - names_sep = names_sep, - too_few = too_few, - cols_remove = cols_remove, - error_call = error_call - ), + data, + {{ cols }}, + function(x, col) { + str_separate_wider_regex( + x, + col, + patterns = patterns, + names_sep = names_sep, + too_few = too_few, + cols_remove = cols_remove, + error_call = error_call + ) + }, names_sep = names_sep, names_repair = names_repair ) } -str_separate_wider_regex <- function(x, - col, - patterns, - names_sep = NULL, - too_few = "error", - cols_remove = TRUE, - error_call = caller_env()) { +str_separate_wider_regex <- function( + x, + col, + patterns, + names_sep = NULL, + too_few = "error", + cols_remove = TRUE, + error_call = caller_env() +) { has_name <- names2(patterns) != "" groups <- stringr::str_c("(", ifelse(has_name, "", "?:"), patterns, ")") - full_match <- stringr::str_c("^", stringr::str_flatten(groups, collapse = ""), "$") + full_match <- stringr::str_c( + "^", + stringr::str_flatten(groups, collapse = ""), + "$" + ) match <- stringr::str_match(x, full_match) if (ncol(match) != sum(has_name) + 1L) { - cli::cli_abort(c( - "Invalid number of groups.", - i = 'Did you use "()" instead of "(?:)" inside {.arg patterns}?' - ), call = error_call) + cli::cli_abort( + c( + "Invalid number of groups.", + i = 'Did you use "()" instead of "(?:)" inside {.arg patterns}?' + ), + call = error_call + ) } matches <- match[, -1, drop = FALSE] @@ -438,14 +472,16 @@ str_separate_wider_regex <- function(x, no_match <- which(problems) if (length(no_match) > 0) { - if (too_few == "error") { - cli::cli_abort(c( - "Expected each value of {.var {col}} to match the pattern, the whole pattern, and nothing but the pattern.", - "!" = "{length(no_match)} value{?s} {?has/have} problem{?s}.", - i = 'Use {.code too_few = "debug"} to diagnose the problem.', - i = 'Use {.code too_few = "align_start"} to silence this message.' - ), call = error_call) + cli::cli_abort( + c( + "Expected each value of {.var {col}} to match the pattern, the whole pattern, and nothing but the pattern.", + "!" = "{length(no_match)} value{?s} {?has/have} problem{?s}.", + i = 'Use {.code too_few = "debug"} to diagnose the problem.', + i = 'Use {.code too_few = "align_start"} to silence this message.' + ), + call = error_call + ) } # Progressively relax the matches @@ -458,7 +494,10 @@ str_separate_wider_regex <- function(x, next } - matches <- as_tibble(match[has_match, -1, drop = FALSE], .name_repair = "none") + matches <- as_tibble( + match[has_match, -1, drop = FALSE], + .name_repair = "none" + ) cols <- names2(patterns)[has_name][1:(ncol(matches) - 1)] out[match_idx, cols] <- matches[1:(ncol(matches) - 1)] remainder[match_idx] <- matches[[ncol(matches)]] @@ -476,7 +515,6 @@ str_separate_wider_regex <- function(x, } } - if (too_few == "debug") { separate_warn_debug(col, names_sep, c("ok", "matches", "remainder")) out[debug_name(col, names_sep, "ok")] <- !problems @@ -489,7 +527,14 @@ str_separate_wider_regex <- function(x, # helpers ----------------------------------------------------------------- -map_unpack <- function(data, cols, fun, names_sep, names_repair, error_call = caller_env()) { +map_unpack <- function( + data, + cols, + fun, + names_sep, + names_repair, + error_call = caller_env() +) { cols <- tidyselect::eval_select( enquo(cols), data = data, @@ -514,9 +559,9 @@ map_unpack <- function(data, cols, fun, names_sep, names_repair, error_call = ca # cf. df_simplify df_align <- function( - x, - names, - align_direction = c("start", "end") + x, + names, + align_direction = c("start", "end") ) { vec_check_list(x) if (length(x) == 0) { @@ -580,15 +625,16 @@ df_align_transpose <- function(x, p, align_direction = "start") { } check_df_alignment <- function( - col, - p, - type, - sizes, - too_few, - too_many, - advice_short = NULL, - advice_long = NULL, - call = caller_env()) { + col, + p, + type, + sizes, + too_few, + too_many, + advice_short = NULL, + advice_long = NULL, + call = caller_env() +) { n_short <- sum(sizes < p, na.rm = TRUE) n_long <- sum(sizes > p, na.rm = TRUE) @@ -599,16 +645,18 @@ check_df_alignment <- function( return() } - cli::cli_abort(c( - "Expected {p} {type} in each element of {.var {col}}.", - "!" = if (error_short) "{n_short} value{?s} {?was/were} too short.", - if (error_short) advice_short, - "!" = if (error_long) "{n_long} value{?s} {?was/were} too long.", - if (error_long) advice_long - ), call = call) + cli::cli_abort( + c( + "Expected {p} {type} in each element of {.var {col}}.", + "!" = if (error_short) "{n_short} value{?s} {?was/were} too short.", + if (error_short) advice_short, + "!" = if (error_long) "{n_long} value{?s} {?was/were} too long.", + if (error_long) advice_long + ), + call = call + ) } - separate_warn_debug <- function(col, names_sep, vars) { vars <- debug_name(col, names_sep, vars) @@ -618,4 +666,3 @@ separate_warn_debug <- function(col, names_sep, vars) { debug_name <- function(col, names_sep, var) { paste0(col, names_sep %||% "_", var) } - diff --git a/R/separate.R b/R/separate.R index f629ead0f..c6118d871 100644 --- a/R/separate.R +++ b/R/separate.R @@ -72,22 +72,40 @@ #' df <- tibble(x = c("x:1", "x:2", "y:4", "z", NA)) #' df %>% separate(x, c("key", "value"), ":") %>% str() #' df %>% separate(x, c("key", "value"), ":", convert = TRUE) %>% str() -separate <- function(data, col, into, sep = "[^[:alnum:]]+", remove = TRUE, - convert = FALSE, extra = "warn", fill = "warn", ...) { +separate <- function( + data, + col, + into, + sep = "[^[:alnum:]]+", + remove = TRUE, + convert = FALSE, + extra = "warn", + fill = "warn", + ... +) { check_dots_used() UseMethod("separate") } #' @export -separate.data.frame <- function(data, col, into, sep = "[^[:alnum:]]+", - remove = TRUE, convert = FALSE, - extra = "warn", fill = "warn", ...) { +separate.data.frame <- function( + data, + col, + into, + sep = "[^[:alnum:]]+", + remove = TRUE, + convert = FALSE, + extra = "warn", + fill = "warn", + ... +) { check_required(col) check_bool(remove) var <- tidyselect::vars_pull(names(data), !!enquo(col)) value <- as.character(data[[var]]) - new_cols <- str_separate(value, + new_cols <- str_separate( + value, into = into, sep = sep, convert = convert, @@ -98,7 +116,15 @@ separate.data.frame <- function(data, col, into, sep = "[^[:alnum:]]+", reconstruct_tibble(data, out, if (remove) var else NULL) } -str_separate <- function(x, into, sep, convert = FALSE, extra = "warn", fill = "warn", error_call = caller_env()) { +str_separate <- function( + x, + into, + sep, + convert = FALSE, + extra = "warn", + fill = "warn", + error_call = caller_env() +) { check_character(into, call = error_call) check_bool(convert, call = error_call) @@ -158,13 +184,17 @@ str_split_fixed <- function(value, sep, n, extra = "warn", fill = "warn") { n_big <- length(simp$too_big) if (extra == "warn" && n_big > 0) { idx <- list_indices(simp$too_big) - warn(glue("Expected {n} pieces. Additional pieces discarded in {n_big} rows [{idx}].")) + warn(glue( + "Expected {n} pieces. Additional pieces discarded in {n_big} rows [{idx}]." + )) } n_sml <- length(simp$too_sml) if (fill == "warn" && n_sml > 0) { idx <- list_indices(simp$too_sml) - warn(glue("Expected {n} pieces. Missing pieces filled with `NA` in {n_sml} rows [{idx}].")) + warn(glue( + "Expected {n} pieces. Missing pieces filled with `NA` in {n_sml} rows [{idx}]." + )) } simp$strings @@ -190,7 +220,6 @@ slice_match <- function(x, i) { ) } - list_indices <- function(x, max = 20) { if (length(x) > max) { x <- c(x[seq_len(max)], "...") @@ -199,8 +228,15 @@ list_indices <- function(x, max = 20) { paste(x, collapse = ", ") } -check_not_stringr_pattern <- function(x, arg = caller_arg(x), call = caller_env()) { +check_not_stringr_pattern <- function( + x, + arg = caller_arg(x), + call = caller_env() +) { if (inherits_any(x, c("pattern", "stringr_pattern"))) { - cli::cli_abort("{.arg {arg}} can't use modifiers from stringr.", call = call) + cli::cli_abort( + "{.arg {arg}} can't use modifiers from stringr.", + call = call + ) } } diff --git a/R/seq.R b/R/seq.R index 8761dc1fb..b1826db9c 100644 --- a/R/seq.R +++ b/R/seq.R @@ -21,8 +21,12 @@ full_seq.numeric <- function(x, period, tol = 1e-6) { check_number_decimal(tol, min = 0) rng <- range(x, na.rm = TRUE) - if (any(((x - rng[1]) %% period > tol) & - (period - (x - rng[1]) %% period > tol))) { + if ( + any( + ((x - rng[1]) %% period > tol) & + (period - (x - rng[1]) %% period > tol) + ) + ) { cli::cli_abort("{.arg x} is not a regular sequence.") } diff --git a/R/spread.R b/R/spread.R index 208210f0e..11bf0f995 100644 --- a/R/spread.R +++ b/R/spread.R @@ -55,13 +55,27 @@ #' ) #' df %>% spread(var, value) %>% str() #' df %>% spread(var, value, convert = TRUE) %>% str() -spread <- function(data, key, value, fill = NA, convert = FALSE, - drop = TRUE, sep = NULL) { +spread <- function( + data, + key, + value, + fill = NA, + convert = FALSE, + drop = TRUE, + sep = NULL +) { UseMethod("spread") } #' @export -spread.data.frame <- function(data, key, value, fill = NA, convert = FALSE, - drop = TRUE, sep = NULL) { +spread.data.frame <- function( + data, + key, + value, + fill = NA, + convert = FALSE, + drop = TRUE, + sep = NULL +) { key_var <- tidyselect::vars_pull(names(data), !!enquo(key)) value_var <- tidyselect::vars_pull(names(data), !!enquo(value)) diff --git a/R/tidyr.R b/R/tidyr.R index e0f95cdce..521131c32 100644 --- a/R/tidyr.R +++ b/R/tidyr.R @@ -30,7 +30,6 @@ tibble::tibble #' @export tibble::as_tibble - #' @aliases select_helpers #' @importFrom tidyselect all_of #' @export diff --git a/R/uncount.R b/R/uncount.R index 36b79973f..797f43805 100644 --- a/R/uncount.R +++ b/R/uncount.R @@ -35,7 +35,12 @@ uncount.data.frame <- function(data, weights, ..., .remove = TRUE, .id = NULL) { weights_quo <- enquo(weights) w <- dplyr::pull(dplyr::mutate(data, `_weight` = !!weights_quo)) - out <- vec_rep_each(data, w, error_call = current_env(), times_arg = "weights") + out <- vec_rep_each( + data, + w, + error_call = current_env(), + times_arg = "weights" + ) # NOTE it was decided to also remove grouping variables as there is no clear # best answer. See https://github.com/tidyverse/tidyr/pull/1070 diff --git a/R/unite.R b/R/unite.R index 35eb4f58b..dd61fcf2a 100644 --- a/R/unite.R +++ b/R/unite.R @@ -36,7 +36,14 @@ unite <- function(data, col, ..., sep = "_", remove = TRUE, na.rm = FALSE) { UseMethod("unite") } #' @export -unite.data.frame <- function(data, col, ..., sep = "_", remove = TRUE, na.rm = FALSE) { +unite.data.frame <- function( + data, + col, + ..., + sep = "_", + remove = TRUE, + na.rm = FALSE +) { check_required(col) check_string(sep) check_bool(remove) @@ -48,7 +55,11 @@ unite.data.frame <- function(data, col, ..., sep = "_", remove = TRUE, na.rm = F if (dots_n(...) == 0) { selection <- set_names(seq_along(data), names(data)) } else { - selection <- tidyselect::eval_select(expr(c(...)), data, allow_rename = FALSE) + selection <- tidyselect::eval_select( + expr(c(...)), + data, + allow_rename = FALSE + ) } empty_selection <- length(selection) == 0L diff --git a/R/unnest-auto.R b/R/unnest-auto.R index d0f06bcf4..3ee4b66d8 100644 --- a/R/unnest-auto.R +++ b/R/unnest-auto.R @@ -25,7 +25,8 @@ unnest_auto <- function(data, col) { x <- data[[col]] dir <- guess_dir(x, col) - switch(dir, + switch( + dir, longer = unnest_longer(data, {{ col }}, indices_include = FALSE), longer_idx = unnest_longer(data, {{ col }}, indices_include = TRUE), wider = unnest_wider(data, {{ col }}, names_repair = "unique") diff --git a/R/unnest-helper.R b/R/unnest-helper.R index 41b181a47..a9bd09c7c 100644 --- a/R/unnest-helper.R +++ b/R/unnest-helper.R @@ -1,12 +1,13 @@ - # Helpers ----------------------------------------------------------------- -df_simplify <- function(x, - ..., - ptype = NULL, - transform = NULL, - simplify = TRUE, - error_call = caller_env()) { +df_simplify <- function( + x, + ..., + ptype = NULL, + transform = NULL, + simplify = TRUE, + error_call = caller_env() +) { check_dots_empty() ptype <- check_list_of_ptypes(ptype, names(x), call = error_call) @@ -40,12 +41,14 @@ df_simplify <- function(x, new_data_frame(out, n = x_size) } -col_simplify <- function(x, - ..., - ptype = NULL, - transform = NULL, - simplify = TRUE, - error_call = caller_env()) { +col_simplify <- function( + x, + ..., + ptype = NULL, + transform = NULL, + simplify = TRUE, + error_call = caller_env() +) { check_dots_empty() if (!is.null(transform)) { diff --git a/R/unnest-longer.R b/R/unnest-longer.R index acb21e93d..5dcdc0c5a 100644 --- a/R/unnest-longer.R +++ b/R/unnest-longer.R @@ -70,17 +70,18 @@ #' df %>% #' unnest_longer(y) %>% #' unnest_longer(z) -unnest_longer <- function(data, - col, - values_to = NULL, - indices_to = NULL, - indices_include = NULL, - keep_empty = FALSE, - names_repair = "check_unique", - simplify = TRUE, - ptype = NULL, - transform = NULL) { - +unnest_longer <- function( + data, + col, + values_to = NULL, + indices_to = NULL, + indices_include = NULL, + keep_empty = FALSE, + names_repair = "check_unique", + simplify = TRUE, + ptype = NULL, + transform = NULL +) { check_data_frame(data) check_required(col) check_name(values_to, allow_null = TRUE) @@ -151,13 +152,15 @@ unnest_longer <- function(data, } # Converts a column of any type to a `list_of` -col_to_long <- function(col, - name, - values_to, - indices_to, - indices_include, - keep_empty, - error_call = caller_env()) { +col_to_long <- function( + col, + name, + values_to, + indices_to, + indices_include, + keep_empty, + error_call = caller_env() +) { if (vec_is_list(col)) { ptype <- list_of_ptype(col) } else { @@ -293,4 +296,3 @@ glue_col_names <- function(string, col_names) { out <- as.character(out) out } - diff --git a/R/unnest-wider.R b/R/unnest-wider.R index 0f2be7c8e..b07e26740 100644 --- a/R/unnest-wider.R +++ b/R/unnest-wider.R @@ -77,15 +77,16 @@ #' # To instead enforce strict vctrs typing rules, use `strict` #' df %>% #' unnest_wider(json, strict = TRUE) -unnest_wider <- function(data, - col, - names_sep = NULL, - simplify = TRUE, - strict = FALSE, - names_repair = "check_unique", - ptype = NULL, - transform = NULL) { - +unnest_wider <- function( + data, + col, + names_sep = NULL, + simplify = TRUE, + strict = FALSE, + names_repair = "check_unique", + ptype = NULL, + transform = NULL +) { check_data_frame(data) check_required(col) check_string(names_sep, allow_null = TRUE) @@ -130,7 +131,13 @@ unnest_wider <- function(data, } # Converts a column of any type to a `list_of` -col_to_wide <- function(col, name, strict, names_sep, error_call = caller_env()) { +col_to_wide <- function( + col, + name, + strict, + names_sep, + error_call = caller_env() +) { if (!vec_is_list(col)) { ptype <- vec_ptype(col) col <- vec_chop(col) @@ -140,7 +147,13 @@ col_to_wide <- function(col, name, strict, names_sep, error_call = caller_env()) # If we don't have a list_of, then a `NULL` `col_ptype` will get converted to # a 1 row, 0 col tibble for `elt_ptype` col_ptype <- list_of_ptype(col) - elt_ptype <- elt_to_wide(col_ptype, name = name, strict = strict, names_sep = names_sep, error_call = error_call) + elt_ptype <- elt_to_wide( + col_ptype, + name = name, + strict = strict, + names_sep = names_sep, + error_call = error_call + ) elt_ptype <- vec_ptype(elt_ptype) # Avoid expensive dispatch from `[[.list_of` @@ -149,13 +162,15 @@ col_to_wide <- function(col, name, strict, names_sep, error_call = caller_env()) out <- with_indexed_errors( map( out, - function(x) elt_to_wide( - x = x, - name = name, - strict = strict, - names_sep = names_sep, - error_call = NULL - ) + function(x) { + elt_to_wide( + x = x, + name = name, + strict = strict, + names_sep = names_sep, + error_call = NULL + ) + } ), message = function(cnd) { c( diff --git a/R/unnest.R b/R/unnest.R index fef793042..9e0594fba 100644 --- a/R/unnest.R +++ b/R/unnest.R @@ -70,17 +70,19 @@ #' df %>% #' unnest(y) %>% #' unnest(z) -unnest <- function(data, - cols, - ..., - keep_empty = FALSE, - ptype = NULL, - names_sep = NULL, - names_repair = "check_unique", - .drop = deprecated(), - .id = deprecated(), - .sep = deprecated(), - .preserve = deprecated()) { +unnest <- function( + data, + cols, + ..., + keep_empty = FALSE, + ptype = NULL, + names_sep = NULL, + names_repair = "check_unique", + .drop = deprecated(), + .id = deprecated(), + .sep = deprecated(), + .preserve = deprecated() +) { deprecated <- FALSE if (!missing(.preserve)) { lifecycle::deprecate_warn( @@ -143,7 +145,9 @@ unnest <- function(data, } if (!is_missing(.sep)) { - lifecycle::deprecate_warn("1.0.0", "unnest(.sep = )", + lifecycle::deprecate_warn( + "1.0.0", + "unnest(.sep = )", details = glue("Use `names_sep = '{.sep}'` instead.") ) deprecated <- TRUE @@ -165,17 +169,19 @@ unnest <- function(data, } #' @export -unnest.data.frame <- function(data, - cols, - ..., - keep_empty = FALSE, - ptype = NULL, - names_sep = NULL, - names_repair = "check_unique", - .drop = "DEPRECATED", - .id = "DEPRECATED", - .sep = "DEPRECATED", - .preserve = "DEPRECATED") { +unnest.data.frame <- function( + data, + cols, + ..., + keep_empty = FALSE, + ptype = NULL, + names_sep = NULL, + names_repair = "check_unique", + .drop = "DEPRECATED", + .id = "DEPRECATED", + .sep = "DEPRECATED", + .preserve = "DEPRECATED" +) { error_call <- current_env() cols <- tidyselect::eval_select( @@ -202,16 +208,19 @@ unnest.data.frame <- function(data, ) } - #' @export -unnest.rowwise_df <- function(data, - cols, - ..., - keep_empty = FALSE, - ptype = NULL, - names_sep = NULL, - names_repair = "check_unique") { - out <- unnest.data.frame(as_tibble(data), {{ cols }}, +unnest.rowwise_df <- function( + data, + cols, + ..., + keep_empty = FALSE, + ptype = NULL, + names_sep = NULL, + names_repair = "check_unique" +) { + out <- unnest.data.frame( + as_tibble(data), + {{ cols }}, keep_empty = keep_empty, ptype = ptype, names_sep = names_sep, diff --git a/R/utils.R b/R/utils.R index a962d51ed..9a07dba0a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -15,7 +15,11 @@ reconstruct_tibble <- function(input, output, ungrouped_vars = character()) { if (inherits(input, "grouped_df")) { old_groups <- dplyr::group_vars(input) new_groups <- intersect(setdiff(old_groups, ungrouped_vars), names(output)) - dplyr::grouped_df(output, new_groups, drop = dplyr::group_by_drop_default(input)) + dplyr::grouped_df( + output, + new_groups, + drop = dplyr::group_by_drop_default(input) + ) } else if (inherits(input, "tbl_df")) { # Assume name repair carried out elsewhere as_tibble(output, .name_repair = "minimal") @@ -29,7 +33,6 @@ seq_ncol <- function(x) seq_len(ncol(x)) last <- function(x) x[[length(x)]] - #' Legacy name repair #' #' Ensures all column names are unique using the approach found in @@ -67,7 +70,6 @@ tidyr_legacy <- function(nms, prefix = "V", sep = "") { nms } - tidyr_col_modify <- function(data, cols) { # Implement from first principles to avoid edge cases in # data frame methods for `[<-` and `[[<-`. @@ -78,7 +80,6 @@ tidyr_col_modify <- function(data, cols) { cli::cli_abort("`cols` must be a list.", .internal = TRUE) } - size <- vec_size(data) data <- tidyr_new_list(data) @@ -139,7 +140,10 @@ list_replace_null <- function(x, sizes, ..., ptype = NULL, size = 1L) { cli::cli_abort("`x` must be a list.", .internal = TRUE) } if (is_list_of(x)) { - cli::cli_abort("`x` can't be a list-of. Unclass first and provide `ptype`.", .internal = TRUE) + cli::cli_abort( + "`x` can't be a list-of. Unclass first and provide `ptype`.", + .internal = TRUE + ) } if (vec_any_missing(x)) { @@ -258,7 +262,11 @@ vec_paste0 <- function(...) { check_data_frame <- function(x, ..., arg = caller_arg(x), call = caller_env()) { if (!is.data.frame(x)) { - cli::cli_abort("{.arg {arg}} must be a data frame, not {.obj_type_friendly {x}}.", ..., call = call) + cli::cli_abort( + "{.arg {arg}} must be a data frame, not {.obj_type_friendly {x}}.", + ..., + call = call + ) } } @@ -271,7 +279,12 @@ check_unique_names <- function(x, arg = caller_arg(x), call = caller_env()) { } } -check_list_of_ptypes <- function(x, names, arg = caller_arg(x), call = caller_env()) { +check_list_of_ptypes <- function( + x, + names, + arg = caller_arg(x), + call = caller_env() +) { if (is.null(x)) { set_names(list(), character()) } else if (vec_is(x) && vec_is_empty(x)) { @@ -289,7 +302,12 @@ check_list_of_ptypes <- function(x, names, arg = caller_arg(x), call = caller_en } } -check_list_of_functions <- function(x, names, arg = caller_arg(x), call = caller_env()) { +check_list_of_functions <- function( + x, + names, + arg = caller_arg(x), + call = caller_env() +) { if (is.null(x)) { x <- set_names(list(), character()) } else if (is.function(x) || is_formula(x)) { @@ -305,7 +323,11 @@ check_list_of_functions <- function(x, names, arg = caller_arg(x), call = caller x_names <- names(x) for (i in seq_along(x)) { - x[[i]] <- as_function(x[[i]], arg = glue("{arg}${x_names[[i]]}"), call = call) + x[[i]] <- as_function( + x[[i]], + arg = glue("{arg}${x_names[[i]]}"), + call = call + ) } # Silently drop user supplied names not found in the data @@ -314,13 +336,18 @@ check_list_of_functions <- function(x, names, arg = caller_arg(x), call = caller x } -check_list_of_bool <- function(x, names, arg = caller_arg(x), call = caller_env()) { +check_list_of_bool <- function( + x, + names, + arg = caller_arg(x), + call = caller_env() +) { if (is_bool(x)) { rep_named(names, x) } else if (vec_is_list(x)) { check_unique_names(x, arg = arg, call = call) x[intersect(names(x), names)] - } else { + } else { cli::cli_abort( "{.arg {arg}} must be a list or a single `TRUE` or `FALSE`.", call = call @@ -328,16 +355,24 @@ check_list_of_bool <- function(x, names, arg = caller_arg(x), call = caller_env( } } -with_indexed_errors <- function(expr, - message, - ..., - .error_call = caller_env(), - .frame = caller_env()) { +with_indexed_errors <- function( + expr, + message, + ..., + .error_call = caller_env(), + .frame = caller_env() +) { try_fetch( expr, purrr_error_indexed = function(cnd) { message <- message(cnd) - abort(message, ..., call = .error_call, parent = cnd$parent, .frame = .frame) + abort( + message, + ..., + call = .error_call, + parent = cnd$parent, + .frame = .frame + ) } ) } diff --git a/air.toml b/air.toml new file mode 100644 index 000000000..e69de29bb diff --git a/data-raw/cms.R b/data-raw/cms.R index 78979d6fc..8ef084c8c 100644 --- a/data-raw/cms.R +++ b/data-raw/cms.R @@ -25,7 +25,6 @@ if (!file.exists(csv_path)) { usethis::use_data(cms_patient_experience, overwrite = TRUE) - # ------------------------------------------------------------------------- # Hospice - Provider Data @@ -41,6 +40,7 @@ if (!file.exists(csv_path)) { url <- "https://data.cms.gov/provider-data/api/1/datastore/query/252m-zfp9/0?limit=500&offset=0&count=true&results=true&schema=true&keys=true&format=json&rowIds=false" json <- jsonlite::read_json(url) + # fmt: skip abbr <- tribble( ~measure_name , ~measure_abbr, "Hospice and Palliative Care Treatment Preferences" , "treat_pref", @@ -56,7 +56,13 @@ if (!file.exists(csv_path)) { cms_patient_care <- json$results |> map_df(as_tibble) |> - select(ccn = cms_certification_number_ccn, facility_name, measure_name, measure_code, score) |> + select( + ccn = cms_certification_number_ccn, + facility_name, + measure_name, + measure_code, + score + ) |> mutate(measure_name = na_if(measure_name, "")) |> fill(measure_name, .direction = "up") |> filter(str_detect(measure_code, "^H")) |> diff --git a/data-raw/construction.R b/data-raw/construction.R index b9df3e4a0..ccf6b6fe9 100644 --- a/data-raw/construction.R +++ b/data-raw/construction.R @@ -1,7 +1,10 @@ library(readr) library(dplyr) -construction <- as_tibble(read_csv("data-raw/construction.csv", col_types = list())) +construction <- as_tibble(read_csv( + "data-raw/construction.csv", + col_types = list() +)) construction <- construction %>% select(-Total) %>% diff --git a/data-raw/household.R b/data-raw/household.R index cdc9771e3..27778bafe 100644 --- a/data-raw/household.R +++ b/data-raw/household.R @@ -1,5 +1,6 @@ library(dplyr) +# fmt: skip household <- tribble( ~family, ~dob_child1, ~dob_child2, ~name_child1, ~name_child2, 1, "1998-11-26", "2000-01-29", "Susan", "Jose", diff --git a/data-raw/population.R b/data-raw/population.R index 5e43de5e2..b61466c48 100644 --- a/data-raw/population.R +++ b/data-raw/population.R @@ -1,7 +1,8 @@ library(dplyr) library(readr) -pop <- as_tibble(read_csv("data-raw/TB_burden_countries_2014-11-07.csv", +pop <- as_tibble(read_csv( + "data-raw/TB_burden_countries_2014-11-07.csv", col_types = list( e_mort_tbhiv_num = col_double() ) diff --git a/data-raw/smiths.R b/data-raw/smiths.R index 047d77b52..d25147689 100644 --- a/data-raw/smiths.R +++ b/data-raw/smiths.R @@ -1,5 +1,6 @@ library(tibble) +# fmt: skip smiths <- tribble( ~subject, ~time, ~age, ~weight, ~height, "John Smith", 1, 33, 90, 1.87, diff --git a/data-raw/tables.R b/data-raw/tables.R index 68660b0fe..c2df92d72 100644 --- a/data-raw/tables.R +++ b/data-raw/tables.R @@ -13,7 +13,8 @@ table1 <- who %>% filter( country %in% c("Afghanistan", "Brazil", "China"), - year >= 1999, year <= 2000 + year >= 1999, + year <= 2000 ) %>% gather("code", "value", 5:60) %>% summarise(cases = sum(value, na.rm = TRUE), .by = c(country, year)) %>% diff --git a/data-raw/us_rent_income.R b/data-raw/us_rent_income.R index fb377213a..be6e378ad 100644 --- a/data-raw/us_rent_income.R +++ b/data-raw/us_rent_income.R @@ -3,8 +3,9 @@ library(readr) # Find a few variables v15 <- load_variables(2016, "acs5", cache = TRUE) -if (interactive()) +if (interactive()) { View(v15) +} vars <- c("income" = "B06011_001", "rent" = "B25064_001") # Retrieve the data diff --git a/data-raw/who.R b/data-raw/who.R index 77785426f..5c4924d97 100644 --- a/data-raw/who.R +++ b/data-raw/who.R @@ -9,9 +9,16 @@ who_raw <- as_tibble( who <- who_raw %>% select( - country:iso3, year, new_sp_m014:new_sp_m65, new_sp_f014:new_sp_f65, - new_sn_m014:new_sn_m65, new_sn_f014:new_sn_f65, new_ep_m014:new_ep_m65, - new_ep_f014:new_ep_f65, newrel_m014:newrel_m65, newrel_f014:newrel_f65 + country:iso3, + year, + new_sp_m014:new_sp_m65, + new_sp_f014:new_sp_f65, + new_sn_m014:new_sn_m65, + new_sn_f014:new_sn_f65, + new_ep_m014:new_ep_m65, + new_ep_f014:new_ep_f65, + newrel_m014:newrel_m65, + newrel_f014:newrel_f65 ) %>% mutate( country = iconv(country, from = "UTF-8", to = "ASCII//TRANSLIT"), diff --git a/data-raw/world_bank_pop.R b/data-raw/world_bank_pop.R index 20a72a2b0..3cc7aece1 100644 --- a/data-raw/world_bank_pop.R +++ b/data-raw/world_bank_pop.R @@ -20,7 +20,11 @@ ind <- c("SP.URB.TOTL", "SP.URB.GROW", "SP.POP.TOTL", "SP.POP.GROW") wb <- as_tibble(read_csv(out[[2]], skip = 4, col_types = list())) world_bank_pop <- wb %>% - select(country = `Country Code`, indicator = `Indicator Code`, `2000`:`2017`) %>% + select( + country = `Country Code`, + indicator = `Indicator Code`, + `2000`:`2017` + ) %>% filter(indicator %in% ind) write_csv(world_bank_pop, "data-raw/world_bank_pop.csv") diff --git a/tests/testthat/test-chop.R b/tests/testthat/test-chop.R index 95017c86d..f71a153a0 100644 --- a/tests/testthat/test-chop.R +++ b/tests/testthat/test-chop.R @@ -75,7 +75,11 @@ test_that("unchopping vectors is a no-op", { }) test_that("NULL inputs are automatically dropped", { - df <- tibble(x = 1:4, y = list(NULL, 1:2, 4, NULL), z = list(NULL, 1:2, NULL, 5)) + df <- tibble( + x = 1:4, + y = list(NULL, 1:2, 4, NULL), + z = list(NULL, 1:2, NULL, 5) + ) out <- df %>% unchop(c(y, z)) expect_equal(out$x, c(2, 2, 3, 4)) @@ -98,7 +102,11 @@ test_that("empty typed inputs are automatically dropped", { }) test_that("optionally keep empty rows", { - df <- tibble(x = 1:2, y = list(NULL, 1:2), z = list(tibble(x = integer()), tibble(x = 1:2))) + df <- tibble( + x = 1:2, + y = list(NULL, 1:2), + z = list(tibble(x = integer()), tibble(x = 1:2)) + ) out <- df %>% unchop(y, keep_empty = TRUE) expect_equal(out$x, c(1, 2, 2)) expect_equal(out$y, c(NA, 1, 2)) @@ -123,11 +131,17 @@ test_that("respects list_of types", { df <- tibble(x = integer(), y = list_of(.ptype = integer())) expect_equal(unchop(df, y), tibble(x = integer(), y = integer())) - expect_equal(unchop(df, y, keep_empty = TRUE), tibble(x = integer(), y = integer())) + expect_equal( + unchop(df, y, keep_empty = TRUE), + tibble(x = integer(), y = integer()) + ) df <- tibble(x = 1L, y = list_of(NULL, .ptype = integer())) expect_equal(unchop(df, y), tibble(x = integer(), y = integer())) - expect_equal(unchop(df, y, keep_empty = TRUE), tibble(x = 1L, y = NA_integer_)) + expect_equal( + unchop(df, y, keep_empty = TRUE), + tibble(x = 1L, y = NA_integer_) + ) }) test_that("grouping is preserved", { diff --git a/tests/testthat/test-complete.R b/tests/testthat/test-complete.R index 28ba26a3d..3e3d95116 100644 --- a/tests/testthat/test-complete.R +++ b/tests/testthat/test-complete.R @@ -196,7 +196,6 @@ test_that("if the completing variables have missings, `fill` will fill them afte ) }) - test_that("validates its inputs", { expect_snapshot(error = TRUE, { complete(mtcars, explicit = 1) diff --git a/tests/testthat/test-expand.R b/tests/testthat/test-expand.R index bf4caf70d..a790c0269 100644 --- a/tests/testthat/test-expand.R +++ b/tests/testthat/test-expand.R @@ -59,8 +59,14 @@ test_that("expand will expand within each group (#396)", { out <- nest(out, data = -g) - expect_identical(out$data[[1]], crossing(a = 1:2, b = factor(levels = c("a", "b", "c")))) - expect_identical(out$data[[2]], crossing(a = 1L, b = factor(levels = c("a", "b", "c")))) + expect_identical( + out$data[[1]], + crossing(a = 1:2, b = factor(levels = c("a", "b", "c"))) + ) + expect_identical( + out$data[[2]], + crossing(a = 1L, b = factor(levels = c("a", "b", "c"))) + ) }) test_that("expand does not allow expansion on grouping variable (#1299)", { @@ -350,7 +356,11 @@ test_that("unnamed data frames are flattened", { expect_identical( expand_grid(df, col), - tibble(x = c(1L, 1L, 2L, 2L), y = c(1L, 1L, 2L, 2L), col = c(3L, 4L, 3L, 4L)) + tibble( + x = c(1L, 1L, 2L, 2L), + y = c(1L, 1L, 2L, 2L), + col = c(3L, 4L, 3L, 4L) + ) ) }) @@ -371,8 +381,14 @@ test_that("expand_grid() works with unnamed inlined tibbles with long expression ) expect <- vec_cbind( - vec_slice(tibble(fruit = c("Apple", "Banana"), fruit_id = c("a", "b")), c(1, 1, 2, 2)), - vec_slice(tibble(status_id = c("c", "d"), status = c("cut_neatly", "devoured")), c(1, 2, 1, 2)) + vec_slice( + tibble(fruit = c("Apple", "Banana"), fruit_id = c("a", "b")), + c(1, 1, 2, 2) + ), + vec_slice( + tibble(status_id = c("c", "d"), status = c("cut_neatly", "devoured")), + c(1, 2, 1, 2) + ) ) expect_identical(df, expect) @@ -460,7 +476,7 @@ test_that("grid_dots() drops `NULL`s", { }) test_that("grid_dots() reject non-vector input", { - expect_snapshot(grid_dots(lm(1 ~ 1)), error = TRUE) + expect_snapshot(grid_dots(lm(1 ~ 1)), error = TRUE) }) # ------------------------------------------------------------------------------ diff --git a/tests/testthat/test-extract.R b/tests/testthat/test-extract.R index 6618d7282..10ff0b191 100644 --- a/tests/testthat/test-extract.R +++ b/tests/testthat/test-extract.R @@ -18,7 +18,6 @@ test_that("can drop groups", { expect_equal(out$y, c("e", "f", "g")) }) - test_that("match failures give NAs", { df <- data.frame(x = c("a.b", "a")) out <- df %>% extract(x, "a", "(b)") diff --git a/tests/testthat/test-gather.R b/tests/testthat/test-gather.R index 158f433ab..45e963643 100644 --- a/tests/testthat/test-gather.R +++ b/tests/testthat/test-gather.R @@ -155,7 +155,6 @@ test_that("gather throws error for weird objects", { }) }) - test_that("factors coerced to characters, not integers", { df <- data.frame( v1 = 1:3, @@ -174,7 +173,6 @@ test_that("attributes of id variables are preserved", { expect_equal(attributes(df$x), attributes(out$x)) }) - test_that("common attributes are preserved", { df <- data.frame(date1 = Sys.Date(), date2 = Sys.Date() + 10) out <- gather(df, k, v) diff --git a/tests/testthat/test-hoist.R b/tests/testthat/test-hoist.R index dc5fd3a22..9fd96e071 100644 --- a/tests/testthat/test-hoist.R +++ b/tests/testthat/test-hoist.R @@ -1,4 +1,3 @@ - test_that("hoist extracts named elements", { df <- tibble(x = list(list(1, b = "b"))) @@ -16,10 +15,12 @@ test_that("can hoist named non-list elements at the deepest level", { }) test_that("can check check/transform values", { - df <- tibble(x = list( - list(a = 1), - list(a = "a") - )) + df <- tibble( + x = list( + list(a = 1), + list(a = "a") + ) + ) expect_error( df %>% hoist(x, a = "a", .ptype = list(a = character())), @@ -57,30 +58,36 @@ test_that("a ptype generates a list-of if the col can't be simplified (#9 }) test_that("doesn't simplify uneven lengths", { - df <- tibble(x = list( - list(a = 1), - list(a = 2:3) - )) + df <- tibble( + x = list( + list(a = 1), + list(a = 2:3) + ) + ) out <- df %>% hoist(x, a = "a") expect_identical(out$a, list(1, 2:3)) }) test_that("doesn't simplify lists of lists", { - df <- tibble(x = list( - list(a = list(1)), - list(a = list(2)) - )) + df <- tibble( + x = list( + list(a = list(1)), + list(a = list(2)) + ) + ) out <- df %>% hoist(x, a = "a") expect_identical(out$a, list(list(1), list(2))) }) test_that("doesn't simplify non-vectors", { - df <- tibble(x = list( - list(a = quote(a)), - list(a = quote(b)) - )) + df <- tibble( + x = list( + list(a = quote(a)), + list(a = quote(b)) + ) + ) out <- df %>% hoist(x, a = "a") expect_identical(out$a, list(quote(a), quote(b))) diff --git a/tests/testthat/test-nest-legacy.R b/tests/testthat/test-nest-legacy.R index a865945eb..69ed52b94 100644 --- a/tests/testthat/test-nest-legacy.R +++ b/tests/testthat/test-nest-legacy.R @@ -111,10 +111,12 @@ test_that("vector unnest preserves names", { }) test_that("unnesting row binds data frames", { - df <- tibble(x = list( - tibble(x = 1:5), - tibble(x = 6:10) - )) + df <- tibble( + x = list( + tibble(x = 1:5), + tibble(x = 6:10) + ) + ) expect_equal(unnest_legacy(df)$x, 1:10) }) @@ -133,7 +135,10 @@ test_that("can unnest mixture of name and unnamed lists of same length", { y = list(y = 1:2), z = list(1:2) ) - expect_identical(unnest_legacy(df), tibble(x = c("a", "a"), y = c(1:2), z = c(1:2))) + expect_identical( + unnest_legacy(df), + tibble(x = c("a", "a"), y = c(1:2), z = c(1:2)) + ) }) test_that("elements must all be of same type", { @@ -185,20 +190,26 @@ test_that(".id creates vector of names for grouped vector unnest", { }) test_that(".id creates vector of names for data frame unnest", { - df <- tibble(x = 1:2, y = list( - a = tibble(y = 1), - b = tibble(y = 1:2) - )) + df <- tibble( + x = 1:2, + y = list( + a = tibble(y = 1), + b = tibble(y = 1:2) + ) + ) out <- unnest_legacy(df, .id = "name") expect_equal(out$name, c("a", "b", "b")) }) test_that(".id creates vector of names for grouped data frame unnest", { - df <- tibble(x = 1:2, y = list( - a = tibble(y = 1), - b = tibble(y = 1:2) - )) %>% + df <- tibble( + x = 1:2, + y = list( + a = tibble(y = 1), + b = tibble(y = 1:2) + ) + ) %>% dplyr::group_by(x) out <- unnest_legacy(df, .id = "name") @@ -257,7 +268,10 @@ test_that("unnest respects .drop_lists", { df <- tibble(x = 1:2, y = list(3, 4), z = list(5, 6:7)) expect_equal(df %>% unnest_legacy(y, .drop = TRUE) %>% names(), c("x", "y")) - expect_equal(df %>% unnest_legacy(z, .drop = FALSE) %>% names(), c("x", "y", "z")) + expect_equal( + df %>% unnest_legacy(z, .drop = FALSE) %>% names(), + c("x", "y", "z") + ) }) test_that("grouping is preserved", { @@ -271,7 +285,10 @@ test_that("grouping is preserved", { test_that("unnesting zero row column preserves names", { df <- tibble(a = character(), b = character()) - expect_equal(df %>% unnest_legacy(b), tibble(a = character(), b = character())) + expect_equal( + df %>% unnest_legacy(b), + tibble(a = character(), b = character()) + ) }) test_that("unnest_legacy() recognize ptype", { diff --git a/tests/testthat/test-nest.R b/tests/testthat/test-nest.R index 0e19dc0c8..851cb8393 100644 --- a/tests/testthat/test-nest.R +++ b/tests/testthat/test-nest.R @@ -245,7 +245,6 @@ test_that("`.by` isn't allowed for grouped data frames", { # Deprecated behaviours --------------------------------------------------- - test_that("warn about old style interface", { df <- tibble(x = c(1, 1, 1), y = 1:3) diff --git a/tests/testthat/test-pack.R b/tests/testthat/test-pack.R index 35d3b5377..b34933dd3 100644 --- a/tests/testthat/test-pack.R +++ b/tests/testthat/test-pack.R @@ -42,7 +42,7 @@ test_that("pack disallows renaming", { test_that("pack validates its inputs", { df <- tibble(a1 = 1, a2 = 2, b1 = 1, b2 = 2) - expect_snapshot(error = TRUE,{ + expect_snapshot(error = TRUE, { pack(1) pack(df, c(a1, a2), c(b1, b2)) pack(df, a = c(a1, a2), c(b1, b2)) diff --git a/tests/testthat/test-pivot-long.R b/tests/testthat/test-pivot-long.R index 04131344c..81c44a9b7 100644 --- a/tests/testthat/test-pivot-long.R +++ b/tests/testthat/test-pivot-long.R @@ -43,6 +43,7 @@ test_that("can drop missing values", { }) test_that("can handle missing combinations", { + # fmt: skip df <- tribble( ~id, ~x_1, ~x_2, ~y_2, "A", 1, 2, "a", @@ -70,6 +71,7 @@ test_that("can override default output column type", { test_that("can pivot to multiple measure cols", { df <- tibble(x = "x", y = 1) + # fmt: skip sp <- tribble( ~.name, ~.value, ~row, "x", "X", 1, @@ -83,6 +85,7 @@ test_that("can pivot to multiple measure cols", { }) test_that("original col order is preserved", { + # fmt: skip df <- tribble( ~id, ~z_1, ~y_1, ~x_1, ~z_2, ~y_2, ~x_2, "A", 1, 2, 3, 4, 5, 6, @@ -104,7 +107,12 @@ test_that("handles duplicated column names", { test_that("can pivot duplicated names to .value", { df <- tibble(x = 1, a_1 = 1, a_2 = 2, b_1 = 3, b_2 = 4) pv1 <- pivot_longer(df, -x, names_to = c(".value", NA), names_sep = "_") - pv2 <- pivot_longer(df, -x, names_to = c(".value", NA), names_pattern = "(.)_(.)") + pv2 <- pivot_longer( + df, + -x, + names_to = c(".value", NA), + names_pattern = "(.)_(.)" + ) pv3 <- pivot_longer(df, -x, names_to = ".value", names_pattern = "(.)_.") expect_named(pv1, c("x", "a", "b")) @@ -122,16 +130,27 @@ test_that(".value can be at any position in `names_to`", { z_t2 = rep(-2, 4), ) - value_first <- pivot_longer(samp, -i, - names_to = c(".value", "time"), names_sep = "_") + value_first <- pivot_longer( + samp, + -i, + names_to = c(".value", "time"), + names_sep = "_" + ) - samp2 <- dplyr::rename(samp, t1_y = y_t1, - t2_y = y_t2, - t1_z = z_t1, - t2_z = z_t2) + samp2 <- dplyr::rename( + samp, + t1_y = y_t1, + t2_y = y_t2, + t1_z = z_t1, + t2_z = z_t2 + ) - value_second <- pivot_longer(samp2, -i, - names_to = c("time", ".value"), names_sep = "_") + value_second <- pivot_longer( + samp2, + -i, + names_to = c("time", ".value"), + names_sep = "_" + ) expect_identical(value_first, value_second) }) @@ -241,7 +260,8 @@ test_that("adjusting `cols_vary` works fine with `values_drop_na`", { test_that("validates inputs", { df <- tibble(x = 1) - expect_error(build_longer_spec(df, x, values_to = letters[1:2]), + expect_error( + build_longer_spec(df, x, values_to = letters[1:2]), class = "vctrs_error_assert" ) }) @@ -295,7 +315,12 @@ test_that("names_sep fails with single name", { test_that("names_pattern generates correct spec", { df <- tibble(zx_y = 1) - sp <- build_longer_spec(df, zx_y, names_to = c("a", "b"), names_pattern = "z(.)_(.)") + sp <- build_longer_spec( + df, + zx_y, + names_to = c("a", "b"), + names_pattern = "z(.)_(.)" + ) expect_equal(sp$a, "x") expect_equal(sp$b, "y") @@ -319,7 +344,9 @@ test_that("names_prefix strips off from beginning", { test_that("can cast to custom type", { df <- tibble(w1 = 1) - sp <- build_longer_spec(df, w1, + sp <- build_longer_spec( + df, + w1, names_prefix = "w", names_transform = list(name = as.integer) ) @@ -450,7 +477,13 @@ test_that("`names_to` is validated", { build_longer_spec(df, x, names_to = c("x", "y")) }) expect_snapshot(error = TRUE, { - build_longer_spec(df, x, names_to = c("x", "y"), names_sep = "_", names_pattern = "x") + build_longer_spec( + df, + x, + names_to = c("x", "y"), + names_sep = "_", + names_pattern = "x" + ) }) }) diff --git a/tests/testthat/test-pivot-wide.R b/tests/testthat/test-pivot-wide.R index 1b8c8cd6c..ec2fe46b9 100644 --- a/tests/testthat/test-pivot-wide.R +++ b/tests/testthat/test-pivot-wide.R @@ -43,7 +43,12 @@ test_that("error when overwriting existing column", { }) expect_snapshot( - out <- pivot_wider(df, names_from = key, values_from = val, names_repair = "unique") + out <- pivot_wider( + df, + names_from = key, + values_from = val, + names_repair = "unique" + ) ) expect_named(out, c("a...1", "a...2", "b")) }) @@ -265,7 +270,8 @@ test_that("can sort column names", { int = c(1, 3, 2), fac = factor(int, levels = 1:3, labels = c("Mon", "Tue", "Wed")), ) - spec <- build_wider_spec(df, + spec <- build_wider_spec( + df, names_from = fac, values_from = int, names_sort = TRUE @@ -280,14 +286,23 @@ test_that("can vary `names_from` values slowest (#839)", { value2 = c(4, 5) ) - spec <- build_wider_spec(df, names_from = name, values_from = c(value1, value2)) + spec <- build_wider_spec( + df, + names_from = name, + values_from = c(value1, value2) + ) expect_identical( spec$.name, c("value1_name1", "value1_name2", "value2_name1", "value2_name2") ) - spec <- build_wider_spec(df, names_from = name, values_from = c(value1, value2), names_vary = "slowest") + spec <- build_wider_spec( + df, + names_from = name, + values_from = c(value1, value2), + names_vary = "slowest" + ) expect_identical( spec$.name, @@ -314,14 +329,22 @@ test_that("`names_expand` generates sorted column names even if no expansion is test_that("`names_expand` does a cartesian expansion of `names_from` columns (#770)", { df <- tibble(name1 = c("a", "b"), name2 = c("c", "d"), value = c(1, 2)) - spec <- build_wider_spec(df, names_from = c(name1, name2), names_expand = TRUE) + spec <- build_wider_spec( + df, + names_from = c(name1, name2), + names_expand = TRUE + ) expect_identical(spec$.name, c("a_c", "a_d", "b_c", "b_d")) }) test_that("`names_expand` expands all levels of a factor `names_from` column (#770)", { name1 <- factor(c(NA, "x"), levels = c("x", "y")) df <- tibble(name1 = name1, name2 = c("c", "d"), value = c(1, 2)) - spec <- build_wider_spec(df, names_from = c(name1, name2), names_expand = TRUE) + spec <- build_wider_spec( + df, + names_from = c(name1, name2), + names_expand = TRUE + ) expect_identical(spec$.name, c("x_c", "x_d", "y_c", "y_d", "NA_c", "NA_d")) }) @@ -339,6 +362,7 @@ test_that("`names_expand` is validated", { # keys --------------------------------------------------------- test_that("can override default keys", { + # fmt: skip df <- tribble( ~row, ~name, ~var, ~value, 1, "Sam", "age", 10, @@ -346,7 +370,8 @@ test_that("can override default keys", { 3, "Bob", "age", 20, ) - pv <- df %>% pivot_wider(id_cols = name, names_from = var, values_from = value) + pv <- df %>% + pivot_wider(id_cols = name, names_from = var, values_from = value) expect_equal(nrow(pv), 2) }) @@ -438,7 +463,12 @@ test_that("`id_expand` generates sorted rows even if no expansion is done", { }) test_that("`id_expand` does a cartesian expansion of `id_cols` columns (#770)", { - df <- tibble(id1 = c(1, 2), id2 = c(3, 4), name = c("a", "b"), value = c(1, 2)) + df <- tibble( + id1 = c(1, 2), + id2 = c(3, 4), + name = c("a", "b"), + value = c(1, 2) + ) expect_identical( pivot_wider(df, id_expand = TRUE), @@ -537,13 +567,16 @@ test_that("duplicated key warning backticks non-syntactic names", { val = 1:3 ) - expect_snapshot(pv <- pivot_wider(df, names_from = `the-key`, values_from = val)) + expect_snapshot( + pv <- pivot_wider(df, names_from = `the-key`, values_from = val) + ) }) test_that("warning suppressed by supplying values_fn", { df <- tibble(a = c(1, 1, 2), key = c("x", "x", "x"), val = 1:3) expect_no_warning( - pv <- pivot_wider(df, + pv <- pivot_wider( + df, names_from = key, values_from = val, values_fn = list(val = list) @@ -561,13 +594,19 @@ test_that("values_fn can be a single function", { test_that("values_fn can be an anonymous function (#1114)", { df <- tibble(a = c(1, 1, 2), key = c("x", "x", "x"), val = c(1, 10, 100)) - pv <- pivot_wider(df, names_from = key, values_from = val, values_fn = ~ sum(.x)) + pv <- pivot_wider( + df, + names_from = key, + values_from = val, + values_fn = ~ sum(.x) + ) expect_equal(pv$x, c(11, 100)) }) test_that("values_fn applied even when no-duplicates", { df <- tibble(a = c(1, 2), key = c("x", "x"), val = 1:2) - pv <- pivot_wider(df, + pv <- pivot_wider( + df, names_from = key, values_from = val, values_fn = list(val = list) @@ -600,7 +639,12 @@ test_that("can fill in missing cells", { test_that("values_fill only affects missing cells", { df <- tibble(g = c(1, 2), names = c("x", "y"), value = c(1, NA)) - out <- pivot_wider(df, names_from = names, values_from = value, values_fill = 0) + out <- pivot_wider( + df, + names_from = names, + values_from = value, + values_fill = 0 + ) expect_equal(out$y, c(0, NA)) }) @@ -640,6 +684,7 @@ test_that("can pivot from multiple measure cols using all keys", { }) test_that("column order in output matches spec", { + # fmt: skip df <- tribble( ~hw, ~name, ~mark, ~pr, "hw1", "anna", 95, "ok", @@ -647,6 +692,7 @@ test_that("column order in output matches spec", { ) # deliberately create weird order + # fmt: skip sp <- tribble( ~hw, ~.value, ~.name, "hw1", "mark", "hw1_mark", @@ -719,7 +765,12 @@ test_that("`unused_fn` works with expanded key from `id_expand`", { expect_identical(res$id, factor(1:3)) expect_identical(res$unused, c(2, 4, NA)) - res <- pivot_wider(df, id_cols = id, id_expand = TRUE, unused_fn = ~ sum(is.na(.x))) + res <- pivot_wider( + df, + id_cols = id, + id_expand = TRUE, + unused_fn = ~ sum(is.na(.x)) + ) expect_identical(res$unused, c(0L, 0L, 1L)) }) diff --git a/tests/testthat/test-separate-wider.R b/tests/testthat/test-separate-wider.R index ed02a603e..0018f0e43 100644 --- a/tests/testthat/test-separate-wider.R +++ b/tests/testthat/test-separate-wider.R @@ -9,26 +9,33 @@ test_that("separate_wider_delim() can create column names", { test_that("separate_wider_delim() errors about too few/too many values", { df <- tibble(x = c("x", "x y", "x y z")) - expect_snapshot(error = TRUE, + expect_snapshot( + error = TRUE, df %>% separate_wider_delim(x, " ", names = c("a", "b")) ) }) test_that("separate_wider_delim() can ignore problems", { df <- tibble(x = c("x", "x y", "x y z")) - out <- df %>% separate_wider_delim(x, " ", - names = c("a", "b"), - too_few = "align_start", - too_many = "drop", - ) + out <- df %>% + separate_wider_delim( + x, + " ", + names = c("a", "b"), + too_few = "align_start", + too_many = "drop", + ) expect_equal(out[1, ], tibble(a = "x", b = NA_character_)) expect_equal(out[3, ], tibble(a = "x", b = "y")) - out <- df %>% separate_wider_delim(x, " ", - names = c("a", "b"), - too_few = "align_end", - too_many = "merge", - ) + out <- df %>% + separate_wider_delim( + x, + " ", + names = c("a", "b"), + too_few = "align_end", + too_many = "merge", + ) expect_equal(out[1, ], tibble(a = NA_character_, b = "x")) expect_equal(out[3, ], tibble(a = "x", b = "y z")) }) @@ -36,11 +43,14 @@ test_that("separate_wider_delim() can ignore problems", { test_that("separate_wider_delim() can diagnose problems", { df <- tibble(x = c(NA, "x", "x y", "x y z")) expect_snapshot( - out <- df %>% separate_wider_delim(x, " ", - names = c("a", "b"), - too_few = "debug", - too_many = "debug", - ) + out <- df %>% + separate_wider_delim( + x, + " ", + names = c("a", "b"), + too_few = "debug", + too_many = "debug", + ) ) expect_equal(out$x, df$x) expect_equal(out$x_ok, c(TRUE, FALSE, TRUE, FALSE)) @@ -49,11 +59,14 @@ test_that("separate_wider_delim() can diagnose problems", { # And can do so selectively suppressWarnings( - out <- df %>% separate_wider_delim(x, " ", - names = c("a", "b"), - too_few = "align_start", - too_many = "debug", - ) + out <- df %>% + separate_wider_delim( + x, + " ", + names = c("a", "b"), + too_few = "align_start", + too_many = "debug", + ) ) expect_equal(out$x_ok, c(TRUE, TRUE, TRUE, FALSE)) }) @@ -107,7 +120,8 @@ test_that("separate_wider_delim() validates its inputs", { test_that("separate_wider_position() errors if lengths are inconsistent", { df <- tibble(x = c("ab", "abc", "abcd")) - expect_snapshot(error = TRUE, + expect_snapshot( + error = TRUE, df %>% separate_wider_position(x, widths = c("a" = 2, "b" = 1)) ) }) @@ -115,12 +129,13 @@ test_that("separate_wider_position() errors if lengths are inconsistent", { test_that("separate_wider_position() can ignore problems", { df <- tibble(x = c("ab", "abc", "abcd")) - out <- df %>% separate_wider_position( - x, - widths = c("a" = 2, "b" = 1), - too_few = "align_start", - too_many = "drop" - ) + out <- df %>% + separate_wider_position( + x, + widths = c("a" = 2, "b" = 1), + too_few = "align_start", + too_many = "drop" + ) expect_equal(out[1, ], tibble(a = "ab", b = NA_character_)) expect_equal(out[2, ], tibble(a = "ab", b = "c")) expect_equal(out[3, ], tibble(a = "ab", b = "c")) @@ -130,12 +145,13 @@ test_that("separate_wider_position() can diagnose problems", { df <- tibble(x = c(NA, "ab", "abc", "abcd")) expect_snapshot( - out <- df %>% separate_wider_position( - x, - widths = c("a" = 2, "b" = 1), - too_few = "debug", - too_many = "debug" - ) + out <- df %>% + separate_wider_position( + x, + widths = c("a" = 2, "b" = 1), + too_few = "debug", + too_many = "debug" + ) ) expect_equal(out$x, df$x) expect_equal(out$x_ok, c(TRUE, FALSE, TRUE, FALSE)) @@ -199,11 +215,12 @@ test_that("separate_wider_regex() errors if match fails", { test_that("separate_wider_regex() can silence errors", { df <- tibble(x = c("a-123", "b_123")) - out <- df %>% separate_wider_regex( - x, - c("a" = ".", "-", "b" = "\\d+"), - too_few = "align_start" - ) + out <- df %>% + separate_wider_regex( + x, + c("a" = ".", "-", "b" = "\\d+"), + too_few = "align_start" + ) expect_equal(out$a, c("a", "b")) expect_equal(out$b, c("123", NA)) }) @@ -211,11 +228,12 @@ test_that("separate_wider_regex() can silence errors", { test_that("separate_wider_regex() can diagnose errors", { df <- tibble(x = c(NA, "a-123", "b_123", "c-123x", "XXXX")) expect_snapshot({ - out <- df %>% separate_wider_regex( - x, - c("a" = "[a-z]", "-", "b" = "\\d+"), - too_few = "debug" - ) + out <- df %>% + separate_wider_regex( + x, + c("a" = "[a-z]", "-", "b" = "\\d+"), + too_few = "debug" + ) }) expect_equal(out$x, df$x) expect_equal(out$x_ok, c(TRUE, TRUE, FALSE, FALSE, FALSE)) diff --git a/tests/testthat/test-spread.R b/tests/testthat/test-spread.R index bfab97c5f..db78da737 100644 --- a/tests/testthat/test-spread.R +++ b/tests/testthat/test-spread.R @@ -108,8 +108,10 @@ test_that("spread can produce mixed variable types (#118)", { column = rep(1:3, each = 2), cell_contents = as.character(c( rep("Argentina", 2), - 62.485, 64.399, - 1952, 1957 + 62.485, + 64.399, + 1952, + 1957 )) ) out <- spread(df, column, cell_contents, convert = TRUE) @@ -144,7 +146,8 @@ test_that("dates can be used with convert = TRUE", { test_that("vars that are all NA are logical if convert = TRUE (#118)", { df <- tibble( - row = c(1, 2, 1, 2), column = c("f", "f", "g", "g"), + row = c(1, 2, 1, 2), + column = c("f", "f", "g", "g"), contents = c("aa", "bb", NA, NA) ) out <- df %>% spread(column, contents, convert = TRUE) @@ -192,7 +195,6 @@ test_that("spread gives one column when no existing non-spread vars", { expect_equal(df %>% spread(key, value), tibble(a = 1, b = 2, c = 3)) }) - test_that("grouping vars are kept where possible", { # Can keep df <- tibble(x = 1:2, key = factor(c("a", "b")), value = 1:2) @@ -209,7 +211,6 @@ test_that("grouping vars are kept where possible", { expect_equal(out, tibble(a = 1L, b = 2L)) }) - test_that("col names never contains NA", { df <- tibble(x = c(1, NA), y = 1:2) df %>% @@ -287,7 +288,7 @@ test_that("spread works when id column has names (#525)", { df <- tibble( key = factor(c("a", "b", "c"), levels = letters[1:5]), out = 1:3, - id = c(a = 1, b = 2, c = 3) + id = c(a = 1, b = 2, c = 3) ) res <- spread(df, key, out, drop = FALSE) expect_equal(names(res), c("id", letters[1:5])) diff --git a/tests/testthat/test-uncount.R b/tests/testthat/test-uncount.R index 66e622623..77c74ef70 100644 --- a/tests/testthat/test-uncount.R +++ b/tests/testthat/test-uncount.R @@ -20,7 +20,6 @@ test_that("expands constants and expressions", { expect_equal(uncount(df, 1 + 1), df[c(1, 1), ]) }) - test_that("works with groups", { df <- tibble(g = 1, x = 1, w = 1) %>% dplyr::group_by(g) expect_equal(uncount(df, w), df %>% dplyr::select(-w)) diff --git a/tests/testthat/test-unnest-auto.R b/tests/testthat/test-unnest-auto.R index c88f4f938..1ff82021b 100644 --- a/tests/testthat/test-unnest-auto.R +++ b/tests/testthat/test-unnest-auto.R @@ -1,4 +1,3 @@ - # unnest_auto ------------------------------------------------------------- test_that("unnamed becomes longer", { diff --git a/tests/testthat/test-unnest-longer.R b/tests/testthat/test-unnest-longer.R index ae052dac1..05a8378e1 100644 --- a/tests/testthat/test-unnest-longer.R +++ b/tests/testthat/test-unnest-longer.R @@ -336,7 +336,13 @@ test_that("names are preserved when simplification isn't done and a ptype is sup ptype <- list(x = integer()) # Explicit request not to simplify - out <- unnest_longer(df, x, indices_include = TRUE, ptype = ptype, simplify = FALSE) + out <- unnest_longer( + df, + x, + indices_include = TRUE, + ptype = ptype, + simplify = FALSE + ) expect_named(out$x, c("a", "b")) expect_identical(out$x_id, c("a", "b")) @@ -357,19 +363,31 @@ test_that("works with foreign lists recognized by `vec_is_list()` (#1327)", { # With empty types df <- tibble(x = new_foo(1:2, integer())) expect_identical(unnest_longer(df, x), tibble(x = 1:2)) - expect_identical(unnest_longer(df, x, keep_empty = TRUE), tibble(x = c(1:2, NA))) + expect_identical( + unnest_longer(df, x, keep_empty = TRUE), + tibble(x = c(1:2, NA)) + ) # With `NULL`s df <- tibble(x = new_foo(1:2, NULL)) expect_identical(unnest_longer(df, x), tibble(x = 1:2)) - expect_identical(unnest_longer(df, x, keep_empty = TRUE), tibble(x = c(1:2, NA))) + expect_identical( + unnest_longer(df, x, keep_empty = TRUE), + tibble(x = c(1:2, NA)) + ) }) test_that("can't currently retain names when simplification isn't done and a ptype is supplied if there is a mix of named/unnamed elements (#1212)", { df <- tibble(x = list(list(a = 1L), list(1L))) ptype <- list(x = integer()) - out <- unnest_longer(df, x, indices_include = TRUE, ptype = ptype, simplify = FALSE) + out <- unnest_longer( + df, + x, + indices_include = TRUE, + ptype = ptype, + simplify = FALSE + ) expect_named(out$x, c("a", "")) expect_identical(out$x_id, c("a", "")) diff --git a/tests/testthat/test-unnest-wider.R b/tests/testthat/test-unnest-wider.R index 41fe6c4ec..ba9b71d6e 100644 --- a/tests/testthat/test-unnest-wider.R +++ b/tests/testthat/test-unnest-wider.R @@ -1,4 +1,3 @@ - test_that("number of rows is preserved", { df <- tibble( x = 1:3, @@ -22,9 +21,7 @@ test_that("simplifies length-1 lists", { expect_equal(out$c, list(c(1, 2), NULL)) # Works when casting too - out <- df %>% unnest_wider(y, - ptype = list(a = integer(), b = integer()) - ) + out <- df %>% unnest_wider(y, ptype = list(a = integer(), b = integer())) expect_equal(out$a, c(1L, 3L)) expect_equal(out$b, c(2L, NA)) expect_equal(out$c, list(c(1, 2), NULL)) @@ -128,7 +125,10 @@ test_that("df-cols can be unnested (#1188)", { test_that("df-cols result in list-ofs when `simplify = FALSE`", { df <- tibble(a = 1:3, b = tibble(x = 1:3, y = 1:3)) out <- unnest_wider(df, b, simplify = FALSE) - expect_identical(out, tibble(a = 1:3, x = list_of(1L, 2L, 3L), y = list_of(1L, 2L, 3L))) + expect_identical( + out, + tibble(a = 1:3, x = list_of(1L, 2L, 3L), y = list_of(1L, 2L, 3L)) + ) }) test_that("unnesting mixed empty types retains the column (#1125)", { @@ -137,11 +137,13 @@ test_that("unnesting mixed empty types retains the column (#1125)", { }) test_that("can unnest mixed empty types with `strict = FALSE`", { - df <- tibble(col = list( - list(a = "x"), - list(a = list()), - list(a = integer()) - )) + df <- tibble( + col = list( + list(a = "x"), + list(a = list()), + list(a = integer()) + ) + ) expect_identical( unnest_wider(df, col)$a, @@ -209,10 +211,12 @@ test_that("integer names are generated for partially named vectors (#1367)", { out <- unnest_wider(df, col, names_sep = "_") expect_named(out, c("col_x", "col_2", "col_z", "col_4")) - df <- tibble(col = list( - set_names(1:4, c("x", "", "z", "")), - set_names(5:8, c("", "", "z", "")) - )) + df <- tibble( + col = list( + set_names(1:4, c("x", "", "z", "")), + set_names(5:8, c("", "", "z", "")) + ) + ) out <- unnest_wider(df, col, names_sep = "_") expect_named(out, c("col_x", "col_2", "col_z", "col_4", "col_1")) expect_identical(out$col_x, c(1L, NA)) @@ -298,7 +302,10 @@ test_that("unnest_wider() works with foreign lists recognized by `vec_is_list()` # With empty types df <- tibble(x = new_foo(new_foo(a = 1, b = integer()))) - expect_identical(unnest_wider(df, x, strict = TRUE), tibble(a = 1, b = NA_integer_)) + expect_identical( + unnest_wider(df, x, strict = TRUE), + tibble(a = 1, b = NA_integer_) + ) # With `NULL`s df <- tibble(x = new_foo(new_foo(a = 1, b = NULL)))