| # File src/library/base/R/sweep.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2012 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/ |
| |
| sweep <- function(x, MARGIN, STATS, FUN = "-", check.margin = TRUE, ...) |
| { |
| FUN <- match.fun(FUN) |
| dims <- dim(x) |
| if (check.margin) { |
| dimmargin <- dims[MARGIN] |
| dimstats <- dim(STATS) |
| lstats <- length(STATS) |
| if (lstats > prod(dimmargin)) { |
| warning("STATS is longer than the extent of 'dim(x)[MARGIN]'") |
| } else if (is.null(dimstats)) { # STATS is a vector |
| cumDim <- c(1L, cumprod(dimmargin)) |
| upper <- min(cumDim[cumDim >= lstats]) |
| lower <- max(cumDim[cumDim <= lstats]) |
| if (lstats && (upper %% lstats != 0L || lstats %% lower != 0L)) |
| warning("STATS does not recycle exactly across MARGIN") |
| } else { |
| dimmargin <- dimmargin[dimmargin > 1L] |
| dimstats <- dimstats[dimstats > 1L] |
| if (length(dimstats) != length(dimmargin) || |
| any(dimstats != dimmargin)) |
| warning("length(STATS) or dim(STATS) do not match dim(x)[MARGIN]") |
| } |
| } |
| perm <- c(MARGIN, seq_along(dims)[ - MARGIN]) |
| FUN(x, aperm(array(STATS, dims[perm]), order(perm)), ...) |
| } |