1# File src/library/base/R/sweep.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2012 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19sweep <- function(x, MARGIN, STATS, FUN = "-", check.margin = TRUE, ...) 20{ 21 FUN <- match.fun(FUN) 22 dims <- dim(x) 23 24 ## Extract the margins and associated dimnames 25 26 if (is.character(MARGIN)) { 27 dn <- dimnames(x) # possibly NULL 28 if(is.null(dnn <- names(dn))) # names(NULL) is NULL 29 stop("'x' must have named dimnames") 30 MARGIN <- match(MARGIN, dnn) 31 if (anyNA(MARGIN)) 32 stop("not all elements of 'MARGIN' are names of dimensions") 33 } 34 35 if (check.margin) { 36 dimmargin <- dims[MARGIN] 37 dimstats <- dim(STATS) 38 lstats <- length(STATS) 39 if (lstats > prod(dimmargin)) { 40 warning("STATS is longer than the extent of 'dim(x)[MARGIN]'") 41 } else if (is.null(dimstats)) { # STATS is a vector 42 cumDim <- c(1L, cumprod(dimmargin)) 43 upper <- min(cumDim[cumDim >= lstats]) 44 lower <- max(cumDim[cumDim <= lstats]) 45 if (lstats && (upper %% lstats != 0L || lstats %% lower != 0L)) 46 warning("STATS does not recycle exactly across MARGIN") 47 } else { 48 dimmargin <- dimmargin[dimmargin > 1L] 49 dimstats <- dimstats[dimstats > 1L] 50 if (length(dimstats) != length(dimmargin) || 51 any(dimstats != dimmargin)) 52 warning("length(STATS) or dim(STATS) do not match dim(x)[MARGIN]") 53 } 54 } 55 perm <- c(MARGIN, seq_along(dims)[ - MARGIN]) 56 FUN(x, aperm(array(STATS, dims[perm]), order(perm)), ...) 57} 58