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