1#  File src/library/base/R/summary.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2018 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
19summary <- function (object, ...) UseMethod("summary")
20
21summary.default <- function(object, ..., digits, quantile.type = 7)
22{
23    if(is.factor(object))
24	return(summary.factor(object, ...))
25    else if(is.matrix(object)) {
26	if(missing(digits))
27	    return(summary.matrix(object,                  quantile.type=quantile.type, ...))
28	else
29	    return(summary.matrix(object, digits = digits, quantile.type=quantile.type, ...))
30    }
31
32    value <- if(is.logical(object)) # scalar or array!
33	c(Mode = "logical",
34          {tb <- table(object, exclude = NULL, useNA = "ifany") # incl. NA s
35           if(!is.null(n <- dimnames(tb)[[1L]]) && any(iN <- is.na(n)))
36               dimnames(tb)[[1L]][iN] <- "NA's"
37           tb
38           })
39    else if(is.numeric(object)) {
40	nas <- is.na(object)
41	object <- object[!nas]
42	qq <- stats::quantile(object, names = FALSE, type = quantile.type)
43        qq <- c(qq[1L:3L], mean(object), qq[4L:5L])
44	if(!missing(digits)) qq <- signif(qq, digits)
45	names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
46	if(any(nas))
47	    c(qq, "NA's" = sum(nas))
48	else qq
49    } else if(is.recursive(object) && !is.language(object) &&
50	      (n <- length(object))) { # do not allow long dims
51	sumry <- array("", c(n, 3L), list(names(object),
52                                          c("Length", "Class", "Mode")))
53	ll <- numeric(n)
54	for(i in 1L:n) {
55	    ii <- object[[i]]
56	    ll[i] <- length(ii)
57	    cls <- oldClass(ii)
58	    sumry[i, 2L] <- if(length(cls)) cls[1L] else "-none-"
59	    sumry[i, 3L] <- mode(ii)
60	}
61	sumry[, 1L] <- format(as.integer(ll))
62	sumry
63    }
64    else c(Length = length(object), Class = class(object), Mode = mode(object))
65    class(value) <- c("summaryDefault", "table")
66    value
67}
68
69format.summaryDefault <- function(x, digits = max(3L, getOption("digits") - 3L), ...)
70{
71    xx <- x
72    if(is.numeric(x) || is.complex(x)) {
73      finite <- is.finite(x)
74      xx[finite] <- zapsmall(x[finite])
75    }
76    class(xx) <- class(x)[-1]
77    m <- match("NA's", names(x), 0)
78    if(inherits(x, "Date") || inherits(x, "POSIXct")) {
79        if(length(a <- attr(x, "NAs")))
80            c(format(xx, digits=digits, ...), "NA's" = as.character(a))
81        else format(xx, digits=digits)
82    } else if(m && !is.character(x))
83        xx <- c(format(xx[-m], digits=digits, ...), "NA's" = as.character(xx[m]))
84    else format(xx, digits=digits, ...)
85}
86
87print.summaryDefault <- function(x, digits = max(3L, getOption("digits") - 3L), ...)
88{
89    xx <- x
90    if(is.numeric(x) || is.complex(x)) {
91      finite <- is.finite(x)
92      xx[finite] <- zapsmall(x[finite])
93    }
94    class(xx) <- class(x)[-1] # for format
95    m <- match("NA's", names(xx), 0)
96    if(inherits(x, "Date") || inherits(x, "POSIXct")) {
97        xx <- if(length(a <- attr(x, "NAs")))
98            c(format(xx, digits=digits), "NA's" = as.character(a))
99        else format(xx, digits=digits)
100        print(xx, digits=digits, ...)
101        return(invisible(x))
102    } else if(m && !is.character(x))
103        xx <- c(format(xx[-m], digits=digits), "NA's" = as.character(xx[m]))
104    print.table(xx, digits=digits, ...)
105    invisible(x)
106}
107
108summary.factor <- function(object, maxsum = 100L, ...)
109{
110    nas <- is.na(object)
111    ll <- levels(object)
112    if(ana <- any(nas)) maxsum <- maxsum - 1L
113    tbl <- table(object)
114    tt <- c(tbl) # names dropped ...
115    names(tt) <- dimnames(tbl)[[1L]]
116    if(length(ll) > maxsum) {
117	drop <- maxsum:length(ll)
118	o <- sort.list(tt, decreasing = TRUE)
119	tt <- c(tt[o[ - drop]], "(Other)" = sum(tt[o[drop]]))
120    }
121    if(ana) c(tt, "NA's" = sum(nas)) else tt
122}
123
124summary.matrix <- function(object, ...) {
125    ## we do want this changed into separate columns, so use data.frame method
126    summary.data.frame(as.data.frame.matrix(object), ...)
127}
128
129summary.data.frame <-
130    function(object, maxsum = 7L, digits = max(3L, getOption("digits") - 3L), ...)
131{
132    ncw <- function(x) {
133        z <- nchar(x, type="w")
134        if (any(na <- is.na(z))) {
135            # FIXME: can we do better
136            z[na] <- nchar(encodeString(z[na]), "b")
137        }
138        z
139    }
140    # compute results to full precision.
141    z <- lapply(X = as.list(object), FUN = summary,
142                maxsum = maxsum, digits = 12L, ...)
143    nv <- length(object)
144    nm <- names(object)
145    lw <- numeric(nv)
146    nr <- if (nv)
147	      max(vapply(z, function(x) NROW(x) + !is.null(attr(x, "NAs")), integer(1)))
148	  else 0
149    for(i in seq_len(nv)) {
150        sms <- z[[i]]
151        if(is.matrix(sms)) {
152            ## need to produce a single column, so collapse matrix
153            ## across rows
154            cn <- paste(nm[i], gsub("^ +", "", colnames(sms), useBytes = TRUE),
155                        sep=".")
156	    tmp <- format(sms)# <- digits = ??  --currently take getOption("digits") !!!
157            if(nrow(sms) < nr)
158                tmp <- rbind(tmp, matrix("", nr - nrow(sms), ncol(sms)))
159            sms <- apply(tmp, 1L, function(x) paste(x, collapse="  "))
160            ## produce a suitable colname: undoing padding
161            wid <- sapply(tmp[1L, ], nchar, type="w") # might be NA
162            blanks <- paste(character(max(wid)), collapse = " ")
163            wcn <- ncw(cn)
164            pad0 <- floor((wid - wcn)/2)
165            pad1 <- wid - wcn - pad0
166            cn <- paste0(substring(blanks, 1L, pad0), cn,
167                         substring(blanks, 1L, pad1))
168            nm[i] <- paste(cn, collapse="  ")
169        } else {
170            sms <- format(sms, digits = digits) # may add NAs row
171            lbs <- format(names(sms))
172            sms <- paste0(lbs, ":", sms, "  ")
173            lw[i] <- ncw(lbs[1L])
174            length(sms) <- nr
175        }
176	z[[i]] <- sms
177    }
178    if (nv) {
179	z <- unlist(z, use.names=TRUE)
180	dim(z) <- c(nr, nv)
181	if(anyNA(lw))
182	    warning("probably wrong encoding in names(.) of column ",
183		paste(which(is.na(lw)), collapse = ", "))
184	blanks <- paste(character(max(lw, na.rm=TRUE) + 2L), collapse = " ")
185	pad <- floor(lw - ncw(nm)/2)
186	nm <- paste0(substring(blanks, 1, pad), nm)
187	dimnames(z) <- list(rep.int("", nr), nm)
188    } else {
189	z <- character()
190	dim(z) <- c(nr, nv)
191    }
192    attr(z, "class") <- c("table") #, "matrix")
193    z
194}
195