Nothing
#' Expands a vector
#'
#' Expands vector x by y
#'
#' @param x,y Vectors
#' @param expand Character switch to expand or keep only the values that
#' intersect, all values in x or y, or retain all values found.
#' @param sort Logical, if `TRUE` will sort by names in output
#'
#' @return A vector with expanded
#'
#' @examples
#' x <- letters[c(3:2, 5, 9)]
#' y <- letters[c(1:4, 8)]
#' expand_by(x, y, "x")
#' expand_by(x, y, "y")
#' expand_by(x, y, "intersect")
#' expand_by(x, y, "both")
#' @export
expand_by <- function(
x,
y,
expand = c("x", "y", "intersect", "both"),
sort = FALSE
) {
expand <- match_param(expand)
if (!is_named(x)) names(x) <- x
if (!is_named(y)) names(y) <- y
nx <- names(x)
ny <- names(y)
if (!unique_name_check(x)) {
stop("unique name check failed for x", call. = FALSE)
}
if (!unique_name_check(y)) {
stop("unique name check failed for y", call. = FALSE)
}
out <- switch(
expand,
intersect = {
x[match(ny, nx, 0L)]
},
x = {
mt <- nx %out% ny
out <- x
out[mt] <- NA
out[!mt] <- x[!mt]
out
},
y = {
mt <- ny %out% nx
out <- y
out[mt] <- NA
out[!mt] <- x[!mt]
nm <- names(out)
out2 <- x[nm]
names(out2) <- nm
out2
},
both = {
uq <- unique(c(nx, ny))
out <- x[uq]
ind <- uq %out% nx
names(out)[ind] <- uq[ind]
out
}
)
if (sort) {
return(sort_names(out))
}
out
}
#' Reindex a data.frame
#'
#' Reindexes a data.frame with a reference
#'
#' @param x A data.frame
#' @param index The column name or number of an index to use; if `NULL` will
#' assume the first column; a value of `row.names` will use `row.names(x)`
#' @param new_index A column vector of the new index value
#' @param expand Character switch to expand or keep only the values that
#' intersect (none), all values in x or index, or retain all values found.
#' @param sort Logical, if `TRUE` will sort the rows in output
#'
#' @return A `data.frame` with rows of `index`
#' @examples
#' iris1 <- head(iris, 5)
#' iris1$index <- 1:5
#' reindex(iris1, "index", seq(2, 8, 2))
#' reindex(iris1, "index", seq(2, 8, 2), expand = "both")
#'
#' # Using letters will show changes in rownames
#' iris1$index <- letters[1:5]
#' reindex(iris1, "index", letters[seq(2, 8, 2)])
#' reindex(iris1, "index", seq(2, 8, 2))
#' reindex(iris1, "index", seq(2, 8, 2), expand = "both")
#' @export
reindex <- function(
x,
index = NULL,
new_index,
expand = c("intersect", "both"),
sort = FALSE
) {
expand <- match_param(expand)
if (!inherits(x, "data.frame")) {
stop("`x` must be a data.frame", call. = FALSE)
}
if (no_length(new_index)) {
stop("new_index must not be NULL or 0 length", call. = FALSE)
}
xi <- if (is.null(index)) {
x[[1L]]
} else if (index == "row.names") {
attr(x, "row.names")
} else {
x[[index]]
}
if (anyNA(xi)) {
warning(cond_reindex_na())
}
if (is.null(xi)) {
stop(cond_reindex_index())
}
ro <- expand_by(xi, new_index, expand = expand, sort = sort)
nm <- names(ro)
out <- x[nm, ]
attr(out, "row.names") <- nm # nolint: object_name_linter
out
}
# FUNS --------------------------------------------------------------------
unique_name_check <- function(x) {
# Checks that names are unique in the vector
nm <- names(x) %||% x
lens <- counts(nm)
int <- lens > 1
if (any(int)) {
warning("These names are duplicated: ",
collapse0(names(lens[int]), sep = ", "),
call. = FALSE)
return(invisible(FALSE))
}
invisible(TRUE)
}
# conditions --------------------------------------------------------------
cond_reindex_na <- function() {
new_condition(
"NA values detected in index this may cause errors with expansion",
"reindex_na",
type = "warning"
)
}
cond_reindex_index <- function() {
new_condition("x[[index]] returned `NULL`", "reindex_index")
}
# terminal line
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.