1# File src/library/stats/R/addmargins.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 2004-2020 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 19addmargins <- 20 function(A, margin = seq_along(dim(A)), FUN = sum, quiet = FALSE) 21{ 22 ## The workhorse for this margin-expansion is the function 23 ## expand.one, which is defined and called at the bottom. 24 ## 25 ## All this initial stuff is just to check consistency of 26 ## specifications, and form maximally sensible margin names 27 ## 28 ## BxC, August 2003 29 ## Sept 2003: Single margins caused crash. Fixed. 30 ## Duncan Murdoch, Feb 2004: Machinery to derive functionnames 31 ## from unnamed lists 32 ##------------------------------------------------------------- 33 34 if(is.null(dim(A))) stop("'A' must be an array or table") 35 ## How many dimensions of A, and how many sides do we touch? 36 n.sid <- length(margin) 37 38 ## Check if FUN was specified 39 ## 40 miss.FUN <- missing(FUN) 41 42 ## Check if FUN has the same length as margin, and if not, stop or 43 ## expand a single function specification to a list of the same 44 ## length as the margins vector. 45 if (length(FUN) == 1 && !is.list(FUN)) { 46 fname <- if (!miss.FUN) deparse1(substitute(FUN)) else "Sum" 47 FUN <- setNames(list(FUN), fname) 48 } 49 50 if (!miss.FUN) { 51 ## Recursive function to add names to unnamed list components 52 add.names <- function(thelist) 53 { 54 n <- names(thelist) %||% rep("", length(thelist)) 55 for (i in seq_along(thelist)[-1L]) { 56 if (!is.call(thelist[[i]])) { 57 if (n[i] == "") n[i] <- as.character(thelist[[i]]) 58 } else if (as.character(thelist[[i]][[1L]]) == "list") 59 thelist[[i]] <- add.names(thelist[[i]]) 60 } 61 names(thelist) <- n 62 thelist 63 } 64 ## this only makes sense if we were given an expression for FUN 65 ## which we can deparse. 66 if(mode(substitute(FUN)) == "call") 67 FUN <- eval.parent(add.names(substitute(FUN))) 68 if (is.null(names(FUN))) names(FUN) <- rep("", length(FUN)) 69 } 70 71 ## At this point FUN is a list with names wherever 72 ## we could figure them out, empty strings otherwise 73 74 if(length(FUN) != n.sid) { 75 if(length(FUN) == 1L) 76 FUN <- rep(FUN, n.sid) 77 else 78 stop(gettextf( 79 "length of FUN, %d,\n does not match the length of the margins, %d", 80 length(FUN), n.sid), domain = NA) 81 } 82 83 ## If FUN is not given the default sum is put in the margin 84 ## otherwise make a list to fill with names 85 ## 86 fnames <- vector("list", n.sid) 87 88 ## Use the names from FUN and also possibly the names from 89 ## sublists of FUN. Replace blanks with constructed names 90 91 for(i in seq_along(FUN)) { 92 fnames[[i]] <- names(FUN)[i] 93 if (is.list(FUN[[i]])) { 94 topname <- fnames[[i]] 95 fnames[[i]] <- names(FUN[[i]]) 96 blank <- fnames[[i]] == "" 97 fnames[[i]][blank] <- seq_along(blank)[blank] 98 if (topname == "") { 99 fnames[[i]][blank] <- 100 paste0("Margin ", margin[i], ".", fnames[[i]][blank]) 101 } else { 102 fnames[[i]] <- paste0(topname, ".", fnames[[i]]) 103 } 104 } else if (fnames[[i]] == "") 105 fnames[[i]] <- paste("Margin", margin[i]) 106 } 107 108 ## So finally we have the relevant form of FUN and fnames to pass 109 ## on to expand.one which expands over one factor at a time. 110 111 expand.one <- function(A, margin, FUN, fnames) 112 { 113 ## Function to expand a table with a set of margins over the 114 ## side <margin>, i.e. by a set of marginal tables classified by 115 ## all factors except <margin>. 116 ## 117 ## BxC, August 2003 118 119 ## Make sure that FUN is a list 120 if(!inherits(FUN, "list")) FUN <- list(FUN) 121 122 ## Useful constants 123 d <- dim(A) 124 n.dim <- length(d) # number of dimensions in the table 125 n.mar <- length(FUN) # number of margins to be added 126 127 ## Define the dimensions of the new table with the margins 128 newdim <- d 129 newdim[margin] <- newdim[margin] + n.mar 130 dnA <- dimnames(A) %||% vector("list", n.dim) 131 dnA[[margin]] <- 132 c(if(is.null(dnA[[margin]])) rep("", d[[margin]]) else dnA[[margin]], 133 fnames) 134 135 ## Number of elements in the expanded array 136 n.new <- prod(newdim) 137 138 ## The positions in the vector-version of the new table 139 ## where the original table values goes, as a logical vector 140 skip <- prod(d[1L:margin]) 141 runl <- skip / d[margin] 142 apos <- rep(c(rep_len(TRUE, skip), rep_len(FALSE, n.mar*runl)), 143 n.new/(skip+n.mar*runl)) 144 145 ## Define a vector to hold all the values of the new table 146 values <- double(length(apos)) 147 148 ## First fill in the body of the table 149 values[apos] <- as.vector(A) 150 151 ## Then sucessively compute and fill in the required margins 152 for(i in 1L:n.mar) { 153 mtab <- if(n.dim > 1) 154 apply(A, (1L:n.dim)[-margin], FUN[[i]]) 155 else 156 FUN[[i]](A) 157 ## Vector the same length as the number of margins 158 select <- rep_len(FALSE, n.mar) 159 ## The position of the current margin 160 select[i] <- TRUE 161 ## Expand that to a vector the same length as the entire new matrix 162 mpos <- rep(c(rep_len(FALSE, skip), rep(select, each=runl)), 163 prod(dim(A))/skip) 164 ## Fill the marginal table in there 165 values[mpos] <- as.vector(mtab) 166 } 167 168 ## the new table with contents and margins 169 array(values, dim=newdim, dimnames=dnA) 170 } 171 172 ## Once defined, we can use the expand.one function repeatedly 173 new.A <- A 174 for(i in 1L:n.sid) 175 new.A <- expand.one(A = new.A, margin = margin[i], FUN = FUN[[i]], 176 fnames = fnames[[i]]) 177 if(inherits(A, "table")) # result shall be table, too 178 class(new.A) <- c("table", class(new.A)) 179 180 ## Done! Now print it. 181 ## 182 if(!quiet && !miss.FUN && n.sid > 1) { 183 cat("Margins computed over dimensions\nin the following order:\n") 184 ## FIXME: what is paste(i) supposed to do? 185 for(i in seq_len(n.sid)) 186 cat(paste(i), ": ", names(dimnames(A))[margin[i]], "\n", sep = "") 187 } 188 new.A 189} 190