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