| # File src/library/base/R/split.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| split <- function(x, f, drop = FALSE, ...) UseMethod("split") |
| |
| split.default <- function(x, f, drop = FALSE, sep = ".", lex.order = FALSE, ...) |
| { |
| if(!missing(...)) .NotYetUsed(deparse(...), error = FALSE) |
| |
| if (is.list(f)) |
| f <- interaction(f, drop = drop, sep = sep, lex.order = lex.order) |
| else if (!is.factor(f)) f <- as.factor(f) # docs say as.factor |
| else if (drop) f <- factor(f) # drop extraneous levels |
| storage.mode(f) <- "integer" # some factors have had double in the past |
| if (is.null(attr(x, "class"))) |
| return(.Internal(split(x, f))) |
| ## else |
| ind <- .Internal(split(seq_along(x), f)) |
| lapply(ind, function(i) x[i]) |
| } |
| |
| ## This is documented to work for matrices too |
| split.data.frame <- function(x, f, drop = FALSE, ...) |
| lapply(split(x = seq_len(nrow(x)), f = f, drop = drop, ...), |
| function(ind) x[ind, , drop = FALSE]) |
| |
| `split<-` <- function(x, f, drop = FALSE, ..., value) UseMethod("split<-") |
| |
| `split<-.default` <- function(x, f, drop = FALSE, ..., value) |
| { |
| ix <- split(seq_along(x), f, drop = drop, ...) |
| n <- length(value) |
| j <- 0 |
| for (i in ix) { |
| j <- j %% n + 1 |
| x[i] <- value[[j]] |
| } |
| x |
| } |
| |
| ## This is documented to work for matrices too |
| `split<-.data.frame` <- function(x, f, drop = FALSE, ..., value) |
| { |
| ix <- split(seq_len(nrow(x)), f, drop = drop, ...) |
| n <- length(value) |
| j <- 0 |
| for (i in ix) { |
| j <- j %% n + 1 |
| x[i,] <- value[[j]] |
| } |
| x |
| } |
| |
| unsplit <- function (value, f, drop = FALSE) |
| { |
| len <- length(if (is.list(f)) f[[1L]] else f) |
| if (is.data.frame(value[[1L]])) { |
| x <- value[[1L]][rep(NA, len),, drop = FALSE] |
| rownames(x) <- unsplit(lapply(value, rownames), f, drop = drop) |
| } else |
| x <- value[[1L]][rep(NA, len)] |
| split(x, f, drop = drop) <- value |
| x |
| } |