diff --git a/NAMESPACE b/NAMESPACE index 00d6d3a2c7..04fcf0b935 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -923,9 +923,14 @@ importFrom(pkgconfig,set_config_in) importFrom(rlang,"%||%") importFrom(rlang,.data) importFrom(rlang,.env) +importFrom(rlang,as_function) importFrom(rlang,check_dots_empty) importFrom(rlang,check_installed) +importFrom(rlang,global_env) importFrom(rlang,inject) +importFrom(rlang,is_logical) +importFrom(rlang,is_true) +importFrom(rlang,set_names) importFrom(rlang,warn) importFrom(stats,IQR) importFrom(stats,as.dendrogram) diff --git a/R/attributes.R b/R/attributes.R index 74f1197de8..425d709701 100644 --- a/R/attributes.R +++ b/R/attributes.R @@ -519,7 +519,8 @@ vertex.attributes <- function(graph, index = V(graph)) { res <- .Call(R_igraph_mybracket2_copy, graph, igraph_t_idx_attr, igraph_attr_idx_vertex) if (!missing(index)) { - index_is_natural_sequence <- (length(index) == vcount(graph) && all(index == V(graph))) + index_is_natural_sequence <- (length(index) == vcount(graph) && + identical(index, seq(1, vcount(graph)))) if (!index_is_natural_sequence) { for (i in seq_along(res)) { res[[i]] <- res[[i]][index] @@ -530,34 +531,34 @@ vertex.attributes <- function(graph, index = V(graph)) { res } +set_value_at <- function(value, idx, length_out) { + out <- value[NULL] + length(out) <- length_out + out[idx] <- value + unname(out) +} + #' @export "vertex.attributes<-" <- function(graph, index = V(graph), value) { ensure_igraph(graph) assert_named_list(value) - if (any(sapply(value, length) != length(index))) { + if (!all(lengths(value) == length(index))) { stop("Invalid attribute value length, must match number of vertices") } if (!missing(index)) { index <- as_igraph_vs(graph, index) - if (any(duplicated(index)) || any(is.na(index))) { + if (anyDuplicated(index) || anyNA(index)) { stop("Invalid vertices in index") } } - if (!missing(index) && - (length(index) != vcount(graph) || any(index != V(graph)))) { - vs <- V(graph) - for (i in seq_along(value)) { - tmp <- value[[i]] - length(tmp) <- 0 - length(tmp) <- length(vs) - tmp[index] <- value[[i]] - value[[i]] <- tmp - } + index_is_natural_sequence <- (length(index) == vcount(graph) && all(index == V(graph))) + if (!missing(index) && !index_is_natural_sequence) { + value <- map(value, set_value_at, idx = index, length_out = length(V(graph))) } .Call(R_igraph_mybracket2_set, graph, igraph_t_idx_attr, igraph_attr_idx_vertex, value) diff --git a/R/igraph-package.R b/R/igraph-package.R index a342371866..e5065a208e 100644 --- a/R/igraph-package.R +++ b/R/igraph-package.R @@ -10,6 +10,11 @@ #' @importFrom rlang inject #' @importFrom rlang warn #' @importFrom rlang %||% +#' @importFrom rlang as_function +#' @importFrom rlang global_env +#' @importFrom rlang set_names +#' @importFrom rlang is_logical +#' @importFrom rlang is_true ## usethis namespace: end NULL diff --git a/R/import-standalone-purrr.R b/R/import-standalone-purrr.R new file mode 100644 index 0000000000..623142a0eb --- /dev/null +++ b/R/import-standalone-purrr.R @@ -0,0 +1,240 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-purrr.R +# last-updated: 2023-02-23 +# license: https://unlicense.org +# imports: rlang +# --- +# +# This file provides a minimal shim to provide a purrr-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# +# 2023-02-23: +# * Added `list_c()` +# +# 2022-06-07: +# * `transpose()` is now more consistent with purrr when inner names +# are not congruent (#1346). +# +# 2021-12-15: +# * `transpose()` now supports empty lists. +# +# 2021-05-21: +# * Fixed "object `x` not found" error in `imap()` (@mgirlich) +# +# 2020-04-14: +# * Removed `pluck*()` functions +# * Removed `*_cpl()` functions +# * Used `as_function()` to allow use of `~` +# * Used `.` prefix for helpers +# +# nocov start + +map <- function(.x, .f, ...) { + .f <- as_function(.f, env = global_env()) + lapply(.x, .f, ...) +} +walk <- function(.x, .f, ...) { + map(.x, .f, ...) + invisible(.x) +} + +map_lgl <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, logical(1), ...) +} +map_int <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, integer(1), ...) +} +map_dbl <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, double(1), ...) +} +map_chr <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, character(1), ...) +} +.rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { + .f <- as_function(.f, env = global_env()) + out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) + names(out) <- names(.x) + out +} + +map2 <- function(.x, .y, .f, ...) { + .f <- as_function(.f, env = global_env()) + out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) + if (length(out) == length(.x)) { + set_names(out, names(.x)) + } else { + set_names(out, NULL) + } +} +map2_lgl <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "logical") +} +map2_int <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "integer") +} +map2_dbl <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "double") +} +map2_chr <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "character") +} +imap <- function(.x, .f, ...) { + map2(.x, names(.x) %||% seq_along(.x), .f, ...) +} + +pmap <- function(.l, .f, ...) { + .f <- as.function(.f) + args <- .rlang_purrr_args_recycle(.l) + do.call("mapply", c( + FUN = list(quote(.f)), + args, MoreArgs = quote(list(...)), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) +} +.rlang_purrr_args_recycle <- function(args) { + lengths <- map_int(args, length) + n <- max(lengths) + + stopifnot(all(lengths == 1L | lengths == n)) + to_recycle <- lengths == 1L + args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) + + args +} + +keep <- function(.x, .f, ...) { + .x[.rlang_purrr_probe(.x, .f, ...)] +} +discard <- function(.x, .p, ...) { + sel <- .rlang_purrr_probe(.x, .p, ...) + .x[is.na(sel) | !sel] +} +map_if <- function(.x, .p, .f, ...) { + matches <- .rlang_purrr_probe(.x, .p) + .x[matches] <- map(.x[matches], .f, ...) + .x +} +.rlang_purrr_probe <- function(.x, .p, ...) { + if (is_logical(.p)) { + stopifnot(length(.p) == length(.x)) + .p + } else { + .p <- as_function(.p, env = global_env()) + map_lgl(.x, .p, ...) + } +} + +compact <- function(.x) { + Filter(length, .x) +} + +transpose <- function(.l) { + if (!length(.l)) { + return(.l) + } + + inner_names <- names(.l[[1]]) + + if (is.null(inner_names)) { + fields <- seq_along(.l[[1]]) + } else { + fields <- set_names(inner_names) + .l <- map(.l, function(x) { + if (is.null(names(x))) { + set_names(x, inner_names) + } else { + x + } + }) + } + + # This way missing fields are subsetted as `NULL` instead of causing + # an error + .l <- map(.l, as.list) + + map(fields, function(i) { + map(.l, .subset2, i) + }) +} + +every <- function(.x, .p, ...) { + .p <- as_function(.p, env = global_env()) + + for (i in seq_along(.x)) { + if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) + } + TRUE +} +some <- function(.x, .p, ...) { + .p <- as_function(.p, env = global_env()) + + for (i in seq_along(.x)) { + if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) + } + FALSE +} +negate <- function(.p) { + .p <- as_function(.p, env = global_env()) + function(...) !.p(...) +} + +reduce <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(x, y, ...) + Reduce(f, .x, init = .init) +} +reduce_right <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(y, x, ...) + Reduce(f, .x, init = .init, right = TRUE) +} +accumulate <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(x, y, ...) + Reduce(f, .x, init = .init, accumulate = TRUE) +} +accumulate_right <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(y, x, ...) + Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) +} + +detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { + .p <- as_function(.p, env = global_env()) + .f <- as_function(.f, env = global_env()) + + for (i in .rlang_purrr_index(.x, .right)) { + if (.p(.f(.x[[i]], ...))) { + return(.x[[i]]) + } + } + NULL +} +detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { + .p <- as_function(.p, env = global_env()) + .f <- as_function(.f, env = global_env()) + + for (i in .rlang_purrr_index(.x, .right)) { + if (.p(.f(.x[[i]], ...))) { + return(i) + } + } + 0L +} +.rlang_purrr_index <- function(x, right = FALSE) { + idx <- seq_along(x) + if (right) { + idx <- rev(idx) + } + idx +} + +list_c <- function(x) { + inject(c(!!!x)) +} + +# nocov end