From 6ada0fef3db3562e252d50e04b864c99a5217739 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 28 Apr 2025 09:53:59 +0200 Subject: [PATCH 1/8] usethis::pr_init("upkeep-2025-04") --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 80fd188e..c3ba43fe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,3 +35,4 @@ Config/testthat/edition: 3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 +Config/usethis/last-upkeep: 2025-04-28 From 5f634c3107dfc2432d076bb3e2ef12ca20ffc70f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 28 Apr 2025 09:58:35 +0200 Subject: [PATCH 2/8] usethis::use_air() --- .Rbuildignore | 2 + .vscode/extensions.json | 5 + .vscode/settings.json | 6 + R/cleancall.R | 1 - R/compat-vctrs.R | 987 +++++++++++++------------ R/disk.R | 12 +- R/errno.R | 1 - R/error.R | 4 +- R/glob.R | 17 +- R/iso-date.R | 45 +- R/kill-tree.R | 5 +- R/linux.R | 119 +-- R/low-level.R | 147 ++-- R/macos.R | 36 +- R/memoize.R | 3 +- R/memory.R | 68 +- R/os.R | 13 +- R/package.R | 7 +- R/posix.R | 6 +- R/ps.R | 185 +++-- R/rematch2.R | 14 +- R/string.R | 36 +- R/system.R | 51 +- R/testthat-reporter.R | 114 ++- R/utils.R | 68 +- air.toml | 0 inst/tools/error-codes.R | 23 +- inst/tools/winver.R | 1 - src/install.libs.R | 9 +- tests/testthat.R | 7 +- tests/testthat/helpers.R | 17 +- tests/testthat/test-cleanup-reporter.R | 155 ++-- tests/testthat/test-common.R | 14 +- tests/testthat/test-connections.R | 130 +++- tests/testthat/test-finished.R | 1 - tests/testthat/test-kill-tree.R | 73 +- tests/testthat/test-linux.R | 8 +- tests/testthat/test-macos.R | 1 - tests/testthat/test-pid-reuse.R | 1 - tests/testthat/test-posix-zombie.R | 1 - tests/testthat/test-posix.R | 5 +- tests/testthat/test-ps.R | 1 - tests/testthat/test-system.R | 4 +- tests/testthat/test-utils.R | 3 +- tests/testthat/test-windows.R | 1 - tests/testthat/test-winver.R | 18 +- 46 files changed, 1370 insertions(+), 1055 deletions(-) create mode 100644 .vscode/extensions.json create mode 100644 .vscode/settings.json create mode 100644 air.toml diff --git a/.Rbuildignore b/.Rbuildignore index dee6f734..ce808bcd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -20,3 +20,5 @@ ^.*\.Rproj$ ^pkgdown$ ^LICENSE\.md$ +^[\.]?air\.toml$ +^\.vscode$ diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000..344f76eb --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "Posit.air-vscode" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000..f2d0b79d --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,6 @@ +{ + "[r]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "Posit.air-vscode" + } +} diff --git a/R/cleancall.R b/R/cleancall.R index 944cfd3c..12c41cee 100644 --- a/R/cleancall.R +++ b/R/cleancall.R @@ -1,4 +1,3 @@ - call_with_cleanup <- function(ptr, ...) { .Call(cleancall_call, pairlist(ptr, ...), parent.frame()) } diff --git a/R/compat-vctrs.R b/R/compat-vctrs.R index 34860cf4..4bb7bbae 100644 --- a/R/compat-vctrs.R +++ b/R/compat-vctrs.R @@ -1,627 +1,630 @@ - compat_vctrs <- local({ + # Modified from https://github.com/r-lib/rlang/blob/master/R/compat-vctrs.R -# Modified from https://github.com/r-lib/rlang/blob/master/R/compat-vctrs.R - -# Construction ------------------------------------------------------------ - -# Constructs data frames inheriting from `"tbl"`. This allows the -# pillar package to take over printing as soon as it is loaded. -# The data frame otherwise behaves like a base data frame. -data_frame <- function(...) { - new_data_frame(df_list(...), .class = "tbl") -} + # Construction ------------------------------------------------------------ -new_data_frame <- function(.x = list(), - ..., - .size = NULL, - .class = NULL) { - n_cols <- length(.x) - if (n_cols != 0 && is.null(names(.x))) { - stop("Columns must be named.", call. = FALSE) + # Constructs data frames inheriting from `"tbl"`. This allows the + # pillar package to take over printing as soon as it is loaded. + # The data frame otherwise behaves like a base data frame. + data_frame <- function(...) { + new_data_frame(df_list(...), .class = "tbl") } - if (is.null(.size)) { - if (n_cols == 0) { - .size <- 0 - } else { - .size <- vec_size(.x[[1]]) + new_data_frame <- function(.x = list(), ..., .size = NULL, .class = NULL) { + n_cols <- length(.x) + if (n_cols != 0 && is.null(names(.x))) { + stop("Columns must be named.", call. = FALSE) } - } - - structure( - .x, - class = c(.class, "data.frame"), - row.names = .set_row_names(.size), - ... - ) -} -df_list <- function(..., .size = NULL) { - vec_recycle_common(list(...), size = .size) -} - - -# Binding ----------------------------------------------------------------- + if (is.null(.size)) { + if (n_cols == 0) { + .size <- 0 + } else { + .size <- vec_size(.x[[1]]) + } + } -vec_rbind <- function(...) { - xs <- vec_cast_common(list(...)) - do.call(base::rbind, xs) -} + structure( + .x, + class = c(.class, "data.frame"), + row.names = .set_row_names(.size), + ... + ) + } -vec_cbind <- function(...) { - xs <- list(...) + df_list <- function(..., .size = NULL) { + vec_recycle_common(list(...), size = .size) + } - ptype <- vec_ptype_common(lapply(xs, `[`, 0)) - class <- setdiff(class(ptype), "data.frame") + # Binding ----------------------------------------------------------------- - xs <- vec_recycle_common(xs) - out <- do.call(base::cbind, xs) - new_data_frame(out, .class = class) -} + vec_rbind <- function(...) { + xs <- vec_cast_common(list(...)) + do.call(base::rbind, xs) + } + vec_cbind <- function(...) { + xs <- list(...) -# Slicing ----------------------------------------------------------------- + ptype <- vec_ptype_common(lapply(xs, `[`, 0)) + class <- setdiff(class(ptype), "data.frame") -vec_size <- function(x) { - if (is.data.frame(x)) { - nrow(x) - } else { - length(x) + xs <- vec_recycle_common(xs) + out <- do.call(base::cbind, xs) + new_data_frame(out, .class = class) } -} -vec_rep <- function(x, times) { - i <- rep.int(seq_len(vec_size(x)), times) - vec_slice(x, i) -} - -vec_recycle_common <- function(xs, size = NULL) { - sizes <- vapply(xs, vec_size, integer(1)) + # Slicing ----------------------------------------------------------------- - n <- unique(sizes) + vec_size <- function(x) { + if (is.data.frame(x)) { + nrow(x) + } else { + length(x) + } + } - if (length(n) == 1 && is.null(size)) { - return(xs) + vec_rep <- function(x, times) { + i <- rep.int(seq_len(vec_size(x)), times) + vec_slice(x, i) } - n <- setdiff(n, 1L) - ns <- length(n) + vec_recycle_common <- function(xs, size = NULL) { + sizes <- vapply(xs, vec_size, integer(1)) + + n <- unique(sizes) - if (ns == 0) { - if (is.null(size)) { + if (length(n) == 1 && is.null(size)) { return(xs) } - } else if (ns == 1) { - if (is.null(size)) { - size <- n - } else if (ns != size) { - stop("Inputs can't be recycled to `size`.", call. = FALSE) + n <- setdiff(n, 1L) + + ns <- length(n) + + if (ns == 0) { + if (is.null(size)) { + return(xs) + } + } else if (ns == 1) { + if (is.null(size)) { + size <- n + } else if (ns != size) { + stop("Inputs can't be recycled to `size`.", call. = FALSE) + } + } else { + stop("Inputs can't be recycled to a common size.", call. = FALSE) } - } else { - stop("Inputs can't be recycled to a common size.", call. = FALSE) + + to_recycle <- sizes == 1L + xs[to_recycle] <- lapply(xs[to_recycle], vec_rep, size) + + xs } - to_recycle <- sizes == 1L - xs[to_recycle] <- lapply(xs[to_recycle], vec_rep, size) + vec_slice <- function(x, i) { + if (is.logical(i)) { + i <- which(i) + } + stopifnot(is.numeric(i) || is.character(i)) - xs -} + if (is.null(x)) { + return(NULL) + } -vec_slice <- function(x, i) { - if (is.logical(i)) { - i <- which(i) - } - stopifnot(is.numeric(i) || is.character(i)) + if (is.data.frame(x)) { + # We need to be a bit careful to be generic. First empty all + # columns and expand the df to final size. + out <- x[i, 0, drop = FALSE] - if (is.null(x)) { - return(NULL) - } + # Then fill in with sliced columns + out[seq_along(x)] <- lapply(x, vec_slice, i) - if (is.data.frame(x)) { - # We need to be a bit careful to be generic. First empty all - # columns and expand the df to final size. - out <- x[i, 0, drop = FALSE] + # Reset automatic row names to work around `[` weirdness + if (is.numeric(attr(x, "row.names"))) { + row_names <- .set_row_names(nrow(out)) + } else { + row_names <- attr(out, "row.names") + } - # Then fill in with sliced columns - out[seq_along(x)] <- lapply(x, vec_slice, i) + return(out) + } - # Reset automatic row names to work around `[` weirdness - if (is.numeric(attr(x, "row.names"))) { - row_names <- .set_row_names(nrow(out)) + d <- vec_dims(x) + if (d == 1) { + if (is.object(x)) { + out <- x[i] + } else { + out <- x[i, drop = FALSE] + } + } else if (d == 2) { + out <- x[i, , drop = FALSE] } else { - row_names <- attr(out, "row.names") + j <- rep(list(quote(expr = )), d - 1) + out <- eval(as.call(list( + quote(`[`), + quote(x), + quote(i), + j, + drop = FALSE + ))) } - return(out) + out } - - d <- vec_dims(x) - if (d == 1) { - if (is.object(x)) { - out <- x[i] + vec_dims <- function(x) { + d <- dim(x) + if (is.null(d)) { + 1L } else { - out <- x[i, drop = FALSE] + length(d) } - } else if (d == 2) { - out <- x[i, , drop = FALSE] - } else { - j <- rep(list(quote(expr = )), d - 1) - out <- eval(as.call(list(quote(`[`), quote(x), quote(i), j, drop = FALSE))) } - out -} -vec_dims <- function(x) { - d <- dim(x) - if (is.null(d)) { - 1L - } else { - length(d) - } -} + vec_as_location <- function(i, n, names = NULL) { + out <- seq_len(n) + names(out) <- names -vec_as_location <- function(i, n, names = NULL) { - out <- seq_len(n) - names(out) <- names + # Special-case recycling to size 0 + if (is_logical(i, n = 1) && !length(out)) { + return(out) + } - # Special-case recycling to size 0 - if (is_logical(i, n = 1) && !length(out)) { - return(out) + unname(out[i]) } - unname(out[i]) -} + vec_init <- function(x, n = 1L) { + vec_slice(x, rep_len(NA_integer_, n)) + } -vec_init <- function(x, n = 1L) { - vec_slice(x, rep_len(NA_integer_, n)) -} + vec_assign <- function(x, i, value) { + if (is.null(x)) { + return(NULL) + } -vec_assign <- function(x, i, value) { - if (is.null(x)) { - return(NULL) - } + if (is.logical(i)) { + i <- which(i) + } + stopifnot( + is.numeric(i) || is.character(i) + ) - if (is.logical(i)) { - i <- which(i) - } - stopifnot( - is.numeric(i) || is.character(i) - ) + value <- vec_recycle(value, vec_size(i)) + value <- vec_cast(value, to = x) - value <- vec_recycle(value, vec_size(i)) - value <- vec_cast(value, to = x) + d <- vec_dims(x) - d <- vec_dims(x) + if (d == 1) { + x[i] <- value + } else if (d == 2) { + x[i, ] <- value + } else { + stop("Can't slice-assign arrays.", call. = FALSE) + } - if (d == 1) { - x[i] <- value - } else if (d == 2) { - x[i, ] <- value - } else { - stop("Can't slice-assign arrays.", call. = FALSE) + x } - x -} + vec_recycle <- function(x, size) { + if (is.null(x) || is.null(size)) { + return(NULL) + } + + n_x <- vec_size(x) -vec_recycle <- function(x, size) { - if (is.null(x) || is.null(size)) { - return(NULL) + if (n_x == size) { + x + } else if (size == 0L) { + vec_slice(x, 0L) + } else if (n_x == 1L) { + vec_slice(x, rep(1L, size)) + } else { + stop("Incompatible lengths: ", n_x, ", ", size, call. = FALSE) + } } - n_x <- vec_size(x) + # Coercion ---------------------------------------------------------------- - if (n_x == size) { - x - } else if (size == 0L) { - vec_slice(x, 0L) - } else if (n_x == 1L) { - vec_slice(x, rep(1L, size)) - } else { - stop("Incompatible lengths: ", n_x, ", ", size, call. = FALSE) + vec_cast_common <- function(xs, to = NULL) { + ptype <- vec_ptype_common(xs, ptype = to) + lapply(xs, vec_cast, to = ptype) } -} + vec_cast <- function(x, to) { + if (is.null(x)) { + return(NULL) + } + if (is.null(to)) { + return(x) + } -# Coercion ---------------------------------------------------------------- + if (vec_is_unspecified(x)) { + return(vec_init(to, vec_size(x))) + } -vec_cast_common <- function(xs, to = NULL) { - ptype <- vec_ptype_common(xs, ptype = to) - lapply(xs, vec_cast, to = ptype) -} + stop_incompatible_cast <- function(x, to) { + stop( + sprintf( + "Can't convert <%s> to <%s>.", + .rlang_vctrs_typeof(x), + .rlang_vctrs_typeof(to) + ), + call. = FALSE + ) + } -vec_cast <- function(x, to) { - if (is.null(x)) { - return(NULL) - } - if (is.null(to)) { - return(x) - } + lgl_cast <- function(x, to) { + lgl_cast_from_num <- function(x) { + if (any(!x %in% c(0L, 1L))) { + stop_incompatible_cast(x, to) + } + as.logical(x) + } - if (vec_is_unspecified(x)) { - return(vec_init(to, vec_size(x))) - } + switch( + .rlang_vctrs_typeof(x), + logical = x, + integer = , + double = lgl_cast_from_num(x), + stop_incompatible_cast(x, to) + ) + } + + int_cast <- function(x, to) { + int_cast_from_dbl <- function(x) { + out <- suppressWarnings(as.integer(x)) + if (any((out != x) | xor(is.na(x), is.na(out)))) { + stop_incompatible_cast(x, to) + } else { + out + } + } - stop_incompatible_cast <- function(x, to) { - stop( - sprintf("Can't convert <%s> to <%s>.", + switch( .rlang_vctrs_typeof(x), - .rlang_vctrs_typeof(to) - ), - call. = FALSE - ) - } + logical = as.integer(x), + integer = x, + double = int_cast_from_dbl(x), + stop_incompatible_cast(x, to) + ) + } - lgl_cast <- function(x, to) { - lgl_cast_from_num <- function(x) { - if (any(!x %in% c(0L, 1L))) { + dbl_cast <- function(x, to) { + switch( + .rlang_vctrs_typeof(x), + logical = , + integer = as.double(x), + double = x, stop_incompatible_cast(x, to) - } - as.logical(x) + ) } - switch( - .rlang_vctrs_typeof(x), - logical = x, - integer = , - double = lgl_cast_from_num(x), - stop_incompatible_cast(x, to) - ) - } + chr_cast <- function(x, to) { + switch( + .rlang_vctrs_typeof(x), + character = x, + stop_incompatible_cast(x, to) + ) + } - int_cast <- function(x, to) { - int_cast_from_dbl <- function(x) { - out <- suppressWarnings(as.integer(x)) - if (any((out != x) | xor(is.na(x), is.na(out)))) { + list_cast <- function(x, to) { + switch( + .rlang_vctrs_typeof(x), + list = x, stop_incompatible_cast(x, to) - } else { - out - } + ) } - switch( - .rlang_vctrs_typeof(x), - logical = as.integer(x), - integer = x, - double = int_cast_from_dbl(x), - stop_incompatible_cast(x, to) - ) - } + df_cast <- function(x, to) { + # Check for extra columns + if (length(setdiff(names(x), names(to))) > 0) { + stop( + "Can't convert data frame because of missing columns.", + call. = FALSE + ) + } - dbl_cast <- function(x, to) { - switch( - .rlang_vctrs_typeof(x), - logical = , - integer = as.double(x), - double = x, - stop_incompatible_cast(x, to) - ) - } + # Avoid expensive [.data.frame method + out <- as.list(x) - chr_cast <- function(x, to) { - switch( - .rlang_vctrs_typeof(x), - character = x, - stop_incompatible_cast(x, to) - ) - } + # Coerce common columns + common <- intersect(names(x), names(to)) + out[common] <- Map(vec_cast, out[common], to[common]) - list_cast <- function(x, to) { - switch( - .rlang_vctrs_typeof(x), - list = x, - stop_incompatible_cast(x, to) - ) - } + # Add new columns + from_type <- setdiff(names(to), names(x)) + out[from_type] <- lapply(to[from_type], vec_init, n = vec_size(x)) - df_cast <- function(x, to) { - # Check for extra columns - if (length(setdiff(names(x), names(to))) > 0 ) { - stop("Can't convert data frame because of missing columns.", call. = FALSE) - } + # Ensure columns are ordered according to `to` + out <- out[names(to)] - # Avoid expensive [.data.frame method - out <- as.list(x) + new_data_frame(out) + } - # Coerce common columns - common <- intersect(names(x), names(to)) - out[common] <- Map(vec_cast, out[common], to[common]) + rlib_df_cast <- function(x, to) { + new_data_frame(df_cast(x, to), .class = "tbl") + } + tib_cast <- function(x, to) { + new_data_frame(df_cast(x, to), .class = c("tbl_df", "tbl")) + } - # Add new columns - from_type <- setdiff(names(to), names(x)) - out[from_type] <- lapply(to[from_type], vec_init, n = vec_size(x)) + switch( + .rlang_vctrs_typeof(to), + logical = lgl_cast(x, to), + integer = int_cast(x, to), + double = dbl_cast(x, to), + character = chr_cast(x, to), + list = list_cast(x, to), - # Ensure columns are ordered according to `to` - out <- out[names(to)] + base_data_frame = df_cast(x, to), + rlib_data_frame = rlib_df_cast(x, to), + tibble = tib_cast(x, to), - new_data_frame(out) + stop_incompatible_cast(x, to) + ) } - rlib_df_cast <- function(x, to) { - new_data_frame(df_cast(x, to), .class = "tbl") - } - tib_cast <- function(x, to) { - new_data_frame(df_cast(x, to), .class = c("tbl_df", "tbl")) - } + vec_ptype_common <- function(xs, ptype = NULL) { + if (!is.null(ptype)) { + return(vec_ptype(ptype)) + } - switch( - .rlang_vctrs_typeof(to), - logical = lgl_cast(x, to), - integer = int_cast(x, to), - double = dbl_cast(x, to), - character = chr_cast(x, to), - list = list_cast(x, to), + xs <- Filter(function(x) !is.null(x), xs) - base_data_frame = df_cast(x, to), - rlib_data_frame = rlib_df_cast(x, to), - tibble = tib_cast(x, to), + if (length(xs) == 0) { + return(NULL) + } - stop_incompatible_cast(x, to) - ) -} + if (length(xs) == 1) { + out <- vec_ptype(xs[[1]]) + } else { + xs <- map(xs, vec_ptype) + out <- Reduce(vec_ptype2, xs) + } -vec_ptype_common <- function(xs, ptype = NULL) { - if (!is.null(ptype)) { - return(vec_ptype(ptype)) + vec_ptype_finalise(out) } - xs <- Filter(function(x) !is.null(x), xs) + vec_ptype_finalise <- function(x) { + if (is.data.frame(x)) { + x[] <- lapply(x, vec_ptype_finalise) + return(x) + } - if (length(xs) == 0) { - return(NULL) + if (inherits(x, "rlang_unspecified")) { + logical() + } else { + x + } } - if (length(xs) == 1) { - out <- vec_ptype(xs[[1]]) - } else { - xs <- map(xs, vec_ptype) - out <- Reduce(vec_ptype2, xs) - } + vec_ptype <- function(x) { + if (vec_is_unspecified(x)) { + return(.rlang_vctrs_unspecified()) + } - vec_ptype_finalise(out) -} + if (is.data.frame(x)) { + out <- new_data_frame(lapply(x, vec_ptype)) -vec_ptype_finalise <- function(x) { - if (is.data.frame(x)) { - x[] <- lapply(x, vec_ptype_finalise) - return(x) - } + attrib <- attributes(x) + attrib$row.names <- attr(out, "row.names") + attributes(out) <- attrib - if (inherits(x, "rlang_unspecified")) { - logical() - } else { - x - } -} + return(out) + } -vec_ptype <- function(x) { - if (vec_is_unspecified(x)) { - return(.rlang_vctrs_unspecified()) + vec_slice(x, 0) } - if (is.data.frame(x)) { - out <- new_data_frame(lapply(x, vec_ptype)) + vec_ptype2 <- function(x, y) { + stop_incompatible_type <- function(x, y) { + stop( + sprintf( + "Can't combine types <%s> and <%s>.", + .rlang_vctrs_typeof(x), + .rlang_vctrs_typeof(y) + ), + call. = FALSE + ) + } - attrib <- attributes(x) - attrib$row.names <- attr(out, "row.names") - attributes(out) <- attrib + x_type <- .rlang_vctrs_typeof(x) + y_type <- .rlang_vctrs_typeof(y) - return(out) - } + if (x_type == "unspecified" && y_type == "unspecified") { + return(.rlang_vctrs_unspecified()) + } + if (x_type == "unspecified") { + return(y) + } + if (y_type == "unspecified") { + return(x) + } - vec_slice(x, 0) -} + df_ptype2 <- function(x, y) { + set_partition <- function(x, y) { + list( + both = intersect(x, y), + only_x = setdiff(x, y), + only_y = setdiff(y, x) + ) + } -vec_ptype2 <- function(x, y) { - stop_incompatible_type <- function(x, y) { - stop( - sprintf("Can't combine types <%s> and <%s>.", - .rlang_vctrs_typeof(x), - .rlang_vctrs_typeof(y)), - call. = FALSE - ) - } + # Avoid expensive [.data.frame + x <- as.list(vec_slice(x, 0)) + y <- as.list(vec_slice(y, 0)) - x_type <- .rlang_vctrs_typeof(x) - y_type <- .rlang_vctrs_typeof(y) + # Find column types + names <- set_partition(names(x), names(y)) + if (length(names$both) > 0) { + common_types <- Map(vec_ptype2, x[names$both], y[names$both]) + } else { + common_types <- list() + } + only_x_types <- x[names$only_x] + only_y_types <- y[names$only_y] - if (x_type == "unspecified" && y_type == "unspecified") { - return(.rlang_vctrs_unspecified()) - } - if (x_type == "unspecified") { - return(y) - } - if (y_type == "unspecified") { - return(x) - } + # Combine and construct + out <- c(common_types, only_x_types, only_y_types) + out <- out[c(names(x), names$only_y)] + new_data_frame(out) + } - df_ptype2 <- function(x, y) { - set_partition <- function(x, y) { - list( - both = intersect(x, y), - only_x = setdiff(x, y), - only_y = setdiff(y, x) - ) + rlib_df_ptype2 <- function(x, y) { + new_data_frame(df_ptype2(x, y), .class = "tbl") + } + tib_ptype2 <- function(x, y) { + new_data_frame(df_ptype2(x, y), .class = c("tbl_df", "tbl")) } - # Avoid expensive [.data.frame - x <- as.list(vec_slice(x, 0)) - y <- as.list(vec_slice(y, 0)) + ptype <- switch( + x_type, - # Find column types - names <- set_partition(names(x), names(y)) - if (length(names$both) > 0) { - common_types <- Map(vec_ptype2, x[names$both], y[names$both]) - } else { - common_types <- list() - } - only_x_types <- x[names$only_x] - only_y_types <- y[names$only_y] + logical = switch( + y_type, + logical = x, + integer = y, + double = y, + stop_incompatible_type(x, y) + ), - # Combine and construct - out <- c(common_types, only_x_types, only_y_types) - out <- out[c(names(x), names$only_y)] - new_data_frame(out) - } + integer = switch( + .rlang_vctrs_typeof(y), + logical = x, + integer = x, + double = y, + stop_incompatible_type(x, y) + ), - rlib_df_ptype2 <- function(x, y) { - new_data_frame(df_ptype2(x, y), .class = "tbl") - } - tib_ptype2 <- function(x, y) { - new_data_frame(df_ptype2(x, y), .class = c("tbl_df", "tbl")) - } + double = switch( + .rlang_vctrs_typeof(y), + logical = x, + integer = x, + double = x, + stop_incompatible_type(x, y) + ), - ptype <- switch( - x_type, + character = switch( + .rlang_vctrs_typeof(y), + character = x, + stop_incompatible_type(x, y) + ), - logical = switch( - y_type, - logical = x, - integer = y, - double = y, - stop_incompatible_type(x, y) - ), + list = switch( + .rlang_vctrs_typeof(y), + list = x, + stop_incompatible_type(x, y) + ), - integer = switch( - .rlang_vctrs_typeof(y), - logical = x, - integer = x, - double = y, - stop_incompatible_type(x, y) - ), + base_data_frame = switch( + .rlang_vctrs_typeof(y), + base_data_frame = , + s3_data_frame = df_ptype2(x, y), + rlib_data_frame = rlib_df_ptype2(x, y), + tibble = tib_ptype2(x, y), + stop_incompatible_type(x, y) + ), - double = switch( - .rlang_vctrs_typeof(y), - logical = x, - integer = x, - double = x, - stop_incompatible_type(x, y) - ), + rlib_data_frame = switch( + .rlang_vctrs_typeof(y), + base_data_frame = , + rlib_data_frame = , + s3_data_frame = rlib_df_ptype2(x, y), + tibble = tib_ptype2(x, y), + stop_incompatible_type(x, y) + ), - character = switch( - .rlang_vctrs_typeof(y), - character = x, - stop_incompatible_type(x, y) - ), + tibble = switch( + .rlang_vctrs_typeof(y), + base_data_frame = , + rlib_data_frame = , + tibble = , + s3_data_frame = tib_ptype2(x, y), + stop_incompatible_type(x, y) + ), - list = switch( - .rlang_vctrs_typeof(y), - list = x, - stop_incompatible_type(x, y) - ), - - base_data_frame = switch( - .rlang_vctrs_typeof(y), - base_data_frame = , - s3_data_frame = df_ptype2(x, y), - rlib_data_frame = rlib_df_ptype2(x, y), - tibble = tib_ptype2(x, y), stop_incompatible_type(x, y) - ), - - rlib_data_frame = switch( - .rlang_vctrs_typeof(y), - base_data_frame = , - rlib_data_frame = , - s3_data_frame = rlib_df_ptype2(x, y), - tibble = tib_ptype2(x, y), - stop_incompatible_type(x, y) - ), - - tibble = switch( - .rlang_vctrs_typeof(y), - base_data_frame = , - rlib_data_frame = , - tibble = , - s3_data_frame = tib_ptype2(x, y), - stop_incompatible_type(x, y) - ), + ) - stop_incompatible_type(x, y) - ) + vec_slice(ptype, 0) + } - vec_slice(ptype, 0) -} + .rlang_vctrs_typeof <- function(x) { + if (is.object(x)) { + class <- class(x) -.rlang_vctrs_typeof <- function(x) { - if (is.object(x)) { - class <- class(x) + if (identical(class, "rlang_unspecified")) { + return("unspecified") + } + if (identical(class, "data.frame")) { + return("base_data_frame") + } + if (identical(class, c("tbl", "data.frame"))) { + return("rlib_data_frame") + } + if (identical(class, c("tbl_df", "tbl", "data.frame"))) { + return("tibble") + } + if (inherits(x, "data.frame")) { + return("s3_data_frame") + } - if (identical(class, "rlang_unspecified")) { - return("unspecified") - } - if (identical(class, "data.frame")) { - return("base_data_frame") - } - if (identical(class, c("tbl", "data.frame"))) { - return("rlib_data_frame") - } - if (identical(class, c("tbl_df", "tbl", "data.frame"))) { - return("tibble") - } - if (inherits(x, "data.frame")) { - return("s3_data_frame") + class <- paste0(class, collapse = "/") + stop(sprintf("Unimplemented class <%s>.", class), call. = FALSE) } - class <- paste0(class, collapse = "/") - stop(sprintf("Unimplemented class <%s>.", class), call. = FALSE) - } + type <- typeof(x) + switch( + type, + NULL = return("null"), + logical = if (vec_is_unspecified(x)) { + return("unspecified") + } else { + return(type) + }, + integer = , + double = , + character = , + raw = , + list = return(type) + ) - type <- typeof(x) - switch( - type, - NULL = return("null"), - logical = if (vec_is_unspecified(x)) { - return("unspecified") - } else { - return(type) - }, - integer = , - double = , - character = , - raw = , - list = return(type) - ) - - stop(sprintf("Unimplemented type <%s>.", type), call. = FALSE) -} + stop(sprintf("Unimplemented type <%s>.", type), call. = FALSE) + } -vec_is_unspecified <- function(x) { - !is.object(x) && - typeof(x) == "logical" && - length(x) && - all(vapply(x, identical, logical(1), NA)) -} + vec_is_unspecified <- function(x) { + !is.object(x) && + typeof(x) == "logical" && + length(x) && + all(vapply(x, identical, logical(1), NA)) + } -.rlang_vctrs_unspecified <- function(x = NULL) { - structure( - rep(NA, length(x)), - class = "rlang_unspecified" - ) -} + .rlang_vctrs_unspecified <- function(x = NULL) { + structure( + rep(NA, length(x)), + class = "rlang_unspecified" + ) + } -.rlang_vctrs_s3_method <- function(generic, class, env = parent.frame()) { - fn <- get(generic, envir = env) + .rlang_vctrs_s3_method <- function(generic, class, env = parent.frame()) { + fn <- get(generic, envir = env) - ns <- asNamespace(topenv(fn)) - tbl <- ns$.__S3MethodsTable__. + ns <- asNamespace(topenv(fn)) + tbl <- ns$.__S3MethodsTable__. - for (c in class) { - name <- paste0(generic, ".", c) - if (exists(name, envir = tbl, inherits = FALSE)) { - return(get(name, envir = tbl)) - } - if (exists(name, envir = globalenv(), inherits = FALSE)) { - return(get(name, envir = globalenv())) + for (c in class) { + name <- paste0(generic, ".", c) + if (exists(name, envir = tbl, inherits = FALSE)) { + return(get(name, envir = tbl)) + } + if (exists(name, envir = globalenv(), inherits = FALSE)) { + return(get(name, envir = globalenv())) + } } - } - NULL -} - -environment() + NULL + } + environment() }) data_frame <- compat_vctrs$data_frame diff --git a/R/disk.R b/R/disk.R index b6bc362d..3eff869a 100644 --- a/R/disk.R +++ b/R/disk.R @@ -1,4 +1,3 @@ - #' List all mounted partitions #' #' The output is similar the Unix `mount` and `df` commands. @@ -42,7 +41,6 @@ ps__disk_partitions_filter <- function(pt) { ok <- pt$device != "none" & file.exists(pt$device) & pt$fstype %in% goodfs ok <- ok | pt$device %in% c("overlay", "grpcfuse") pt <- pt[ok, , drop = FALSE] - } else if (os == "MACOS") { ok <- substr(pt$device, 1, 1) == "/" & file.exists(pt$device) pt <- pt[ok, , drop = FALSE] @@ -70,7 +68,6 @@ ps__disk_partitions_filter <- function(pt) { #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' ps_disk_usage() - ps_disk_usage <- function(paths = ps_disk_partitions()$mountpoint) { assert_character(paths) l <- .Call(ps__disk_usage, paths) @@ -104,7 +101,7 @@ ps__disk_usage_format_posix <- function(paths, l) { total <- fs[[5]] * fs[[1]] avail_to_root <- fs[[6]] * fs[[1]] avail = fs[[7]] * fs[[1]] - used <- total - avail_to_root + used <- total - avail_to_root total_user <- used + avail usage_percent <- used / total_user list(total = total, used = used, free = avail, percent = usage_percent) @@ -176,7 +173,7 @@ ps__disk_io_counters_windows <- function() { busy_time = NA ) - disk_info[disk_info$name != "",] + disk_info[disk_info$name != "", ] } ps__disk_io_counters_macos <- function() { @@ -338,7 +335,10 @@ ps_fs_info <- function(paths = "/") { # this should not happen in practice, but just in case if (ps_os_type()[["LINUX"]] && any(is.na(df$type))) { miss <- which(is.na(df$type)) - df$type[miss] <- linux_fs_types$name[match(df$type_code[miss], linux_fs_types$id)] + df$type[miss] <- linux_fs_types$name[match( + df$type_code[miss], + linux_fs_types$id + )] } df diff --git a/R/errno.R b/R/errno.R index f07896b6..d2a71c44 100644 --- a/R/errno.R +++ b/R/errno.R @@ -1,4 +1,3 @@ - #' List of 'errno' error codes #' #' For the errors that are not used on the current platform, `value` is diff --git a/R/error.R b/R/error.R index c7a153c3..d5abcdcd 100644 --- a/R/error.R +++ b/R/error.R @@ -1,7 +1,7 @@ - ps__invalid_argument <- function(arg, ...) { msg <- paste0(encodeString(arg, quote = "`"), ...) structure( list(message = msg), - class = c("invalid_argument", "error", "condition")) + class = c("invalid_argument", "error", "condition") + ) } diff --git a/R/glob.R b/R/glob.R index 06a5350c..92d30032 100644 --- a/R/glob.R +++ b/R/glob.R @@ -1,6 +1,4 @@ - glob <- local({ - to_regex <- function(glob) { restr <- new.env(parent = emptyenv(), size = 1003) idx <- 0L @@ -11,33 +9,26 @@ glob <- local({ if (c %in% c("/", "$", "^", "+", ".", "(", ")", "=", "!", "|")) { idx <- idx + 1L restr[[as.character(idx)]] <- paste0("\\", c) - } else if (c == "?") { idx <- idx + 1L restr[[as.character(idx)]] <- "." - } else if (c == "[" || c == "]") { idx <- idx + 1L restr[[as.character(idx)]] <- c - } else if (c == "{") { idx <- idx + 1L restr[[as.character(idx)]] <- "(" in_group <- TRUE - } else if (c == "}") { idx <- idx + 1L restr[[as.character(idx)]] <- ")" in_group <- FALSE - - } else if (c ==",") { + } else if (c == ",") { idx <- idx + 1L restr[[as.character(idx)]] <- if (in_group) "|" else paste0("\\", c) - } else if (c == "*") { idx <- idx + 1L restr[[as.character(idx)]] <- ".*" - } else { idx <- idx + 1L restr[[as.character(idx)]] <- c @@ -47,7 +38,8 @@ glob <- local({ paste0( "^", paste(mget(as.character(seq_len(idx)), restr), collapse = ""), - "$") + "$" + ) } test <- function(glob, paths) { @@ -60,7 +52,8 @@ glob <- local({ res <- vapply(globs, to_regex, character(1)) m <- matrix( as.logical(unlist(lapply(res, grepl, x = paths))), - nrow = length(paths)) + nrow = length(paths) + ) apply(m, 1, any) } diff --git a/R/iso-date.R b/R/iso-date.R index 687af22a..8736e156 100644 --- a/R/iso-date.R +++ b/R/iso-date.R @@ -1,4 +1,3 @@ - milliseconds <- function(x) as.difftime(as.numeric(x) / 1000, units = "secs") seconds <- function(x) as.difftime(as.numeric(x), units = "secs") minutes <- function(x) as.difftime(as.numeric(x), units = "mins") @@ -22,7 +21,6 @@ parse_iso_8601 <- function(dates, default_tz = "UTC") { } parse_iso_parts <- function(mm, default_tz) { - num <- nrow(mm) ## ----------------------------------------------------------------- @@ -104,8 +102,11 @@ parse_iso_parts <- function(mm, default_tz) { if (default_tz != "UTC") { ftna <- mm$tzpm == "" & mm$tz == "" if (any(ftna)) { - dd <- as.POSIXct(format_iso_8601(date[ftna]), - "%Y-%m-%dT%H:%M:%S+00:00", tz = default_tz) + dd <- as.POSIXct( + format_iso_8601(date[ftna]), + "%Y-%m-%dT%H:%M:%S+00:00", + tz = default_tz + ) date[ftna] <- dd } } @@ -117,25 +118,29 @@ iso_regex <- paste0( "^\\s*", "(?[\\+-]?\\d{4}(?!\\d{2}\\b))", "(?:(?-?)", - "(?:(?0[1-9]|1[0-2])", - "(?:\\g{dash}(?[12]\\d|0[1-9]|3[01]))?", - "|W(?[0-4]\\d|5[0-3])(?:-?(?[1-7]))?", - "|(?00[1-9]|0[1-9]\\d|[12]\\d{2}|3", - "(?:[0-5]\\d|6[1-6])))", - "(?