1# File src/library/stats/R/ftable.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-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 19ftable <- function(x, ...) UseMethod("ftable") 20 21ftable.default <- function(..., exclude = c(NA, NaN), 22 row.vars = NULL, col.vars = NULL) { 23 args <- list(...) 24 if (length(args) == 0L) 25 stop("nothing to tabulate") 26 x <- args[[1L]] 27 if(is.list(x)) 28 x <- table(x, exclude = exclude) 29 else if(inherits(x, "ftable") || 30 (arr2 <- is.array(x) && (length(dim(x)) > 1L))) { 31 x <- as.table(x) # regularizes dimnames for (>=2)D-arrays 32 } 33 else if(!arr2 ) { 34 x <- table(..., exclude = exclude) 35 } 36 dn <- dimnames(x) 37 dx <- dim(x) 38 n <- length(dx) 39 if(!is.null(row.vars)) { 40 if(is.character(row.vars)) { 41 i <- pmatch(row.vars, names(dn)) 42 if(anyNA(i)) 43 stop("incorrect specification for 'row.vars'") 44 row.vars <- i 45 } else if(any((row.vars < 1) | (row.vars > n))) 46 stop("incorrect specification for 'row.vars'") 47 } 48 if(!is.null(col.vars)) { 49 if(is.character(col.vars)) { 50 i <- pmatch(col.vars, names(dn)) 51 if(anyNA(i)) 52 stop("incorrect specification for 'col.vars'") 53 col.vars <- i 54 } else if(any((col.vars < 1) | (col.vars > n))) 55 stop("incorrect specification for 'col.vars'") 56 } 57 i <- 1 : n 58 if(!is.null(row.vars) && !is.null(col.vars)) { 59 all.vars <- sort(c(row.vars, col.vars)) 60 if ((p <- length(all.vars)) < n) { 61 x <- if(p) apply(x, all.vars, sum) else sum(x) 62 row.vars <- match(row.vars, all.vars) 63 col.vars <- match(col.vars, all.vars) 64 dn <- dn[all.vars] 65 dx <- dx[all.vars] 66 } 67 } 68 else if(!is.null(row.vars)) 69 col.vars <- if(length(row.vars)) i[-row.vars] else i 70 else if(!is.null(col.vars)) 71 row.vars <- if(length(col.vars)) i[-col.vars] else i 72 else { 73 row.vars <- seq_len(n-1) 74 col.vars <- n 75 } 76 77 if(length(perm <- c(rev(row.vars), rev(col.vars))) > 1) 78 x <- aperm(x, perm) 79 dim(x) <- c(prod(dx[row.vars]), prod(dx[col.vars])) 80 attr(x, "row.vars") <- dn[row.vars] 81 attr(x, "col.vars") <- dn[col.vars] 82 class(x) <- "ftable" 83 x 84} 85 86ftable.formula <- function(formula, data = NULL, subset, na.action, ...) 87{ 88 if(missing(formula) || !inherits(formula, "formula")) 89 stop("'formula' missing or incorrect") 90 if(length(formula) != 3L) 91 stop("'formula' must have both left and right hand sides") 92 ## need to cope with '.' in formula 93 tt <- if(is.data.frame(data)) terms(formula, data=data) 94 else terms(formula, allowDotAsName=TRUE) 95 if(any(attr(tt, "order") > 1)) 96 stop("interactions are not allowed") 97 ## here we do NOT want '.' expanded 98 rvars <- attr(terms(formula[-2L], allowDotAsName=TRUE), "term.labels") 99 cvars <- attr(terms(formula[-3L], allowDotAsName=TRUE), "term.labels") 100 rhs.has.dot <- any(rvars == ".") 101 lhs.has.dot <- any(cvars == ".") 102 if(lhs.has.dot && rhs.has.dot) 103 stop("'formula' has '.' in both left and right hand sides") 104 m <- match.call(expand.dots = FALSE) 105 edata <- eval(m$data, parent.frame()) 106 if(inherits(edata, "ftable") 107 || inherits(edata, "table") 108 || length(dim(edata)) > 2L) { 109 if(inherits(edata, "ftable")) { 110 data <- as.table(data) 111 } 112 varnames <- names(dimnames(data)) 113 if(rhs.has.dot) 114 rvars <- NULL 115 else { 116 i <- pmatch(rvars, varnames) 117 if(anyNA(i)) 118 stop("incorrect variable names in rhs of formula") 119 rvars <- i 120 } 121 if(lhs.has.dot) 122 cvars <- NULL 123 else { 124 i <- pmatch(cvars, varnames) 125 if(anyNA(i)) 126 stop("incorrect variable names in lhs of formula") 127 cvars <- i 128 } 129 ftable(data, row.vars = rvars, col.vars = cvars) 130 } 131 else { 132 if(is.matrix(edata)) 133 m$data <- as.data.frame(data) 134 m$... <- NULL 135 if(!is.null(data) && is.environment(data)) { 136 varnames <- names(data) 137 if(rhs.has.dot) 138 rvars <- seq_along(varnames)[-cvars] 139 if(lhs.has.dot) 140 cvars <- seq_along(varnames)[-rvars] 141 } 142 else { 143 if(lhs.has.dot || rhs.has.dot) 144 stop("cannot use dots in formula with given data") 145 } 146 m$formula <- as.formula(paste("~", 147 paste(c(rvars, cvars), 148 collapse = "+")), 149 env = environment(formula)) 150 m[[1L]] <- quote(stats::model.frame) 151 mf <- eval(m, parent.frame()) 152 ftable(mf, row.vars = rvars, col.vars = cvars, ...) 153 } 154} 155 156as.table.ftable <- function(x, ...) 157{ 158 if(!inherits(x, "ftable")) 159 stop("'x' must be an \"ftable\" object") 160 xrv <- rev(attr(x, "row.vars")) 161 xcv <- rev(attr(x, "col.vars")) 162 x <- array(data = c(x), 163 dim = c(lengths(xrv), 164 lengths(xcv)), 165 dimnames = c(xrv, xcv)) 166 nrv <- length(xrv) 167 ncv <- length(xcv) 168 x <- aperm(x, c(rev(seq_len(nrv)), rev(seq_len(ncv) + nrv))) 169 class(x) <- "table" 170 x 171} 172 173format.ftable <- 174 function(x, quote=TRUE, digits=getOption("digits"), 175 method=c("non.compact", "row.compact", "col.compact", "compact"), 176 lsep = " | ", 177 justify = c("left", "right"), ...) 178{ 179 if(!inherits(x, "ftable")) 180 stop("'x' must be an \"ftable\" object") 181 charQuote <- function(s) if(quote && length(s)) paste0("\"", s, "\"") else s 182 makeLabels <- function(lst) { 183 lens <- lengths(lst) 184 cplensU <- c(1, cumprod(lens)) 185 cplensD <- rev(c(1, cumprod(rev(lens)))) 186 y <- NULL 187 for (i in rev(seq_along(lst))) { 188 ind <- 1 + seq.int(from = 0, to = lens[i] - 1) * cplensD[i + 1L] 189 tmp <- character(length = cplensD[i]) 190 tmp[ind] <- charQuote(lst[[i]]) 191 y <- cbind(rep(tmp, times = cplensU[i]), y) 192 } 193 y 194 } 195 makeNames <- function(x) names(x) %||% rep_len("", length(x)) 196 197 l.xrv <- length(xrv <- attr(x, "row.vars")) 198 l.xcv <- length(xcv <- attr(x, "col.vars")) 199 method <- match.arg(method) 200 ## deal with 'extreme' layouts (no col.vars, no row.vars) 201 if(l.xrv == 0) { 202 if(method=="col.compact") 203 method <- "non.compact" # already produces a 'col.compact' version 204 else if (method=="compact") 205 method <- "row.compact" # only need to 'row.compact'ify 206 } 207 if(l.xcv == 0) { 208 if(method=="row.compact") 209 method <- "non.compact" # already produces a 'row.compact' version 210 else if (method=="compact") 211 method <- "col.compact" # only need to 'col.compact'ify 212 } 213 LABS <- 214 switch(method, 215 "non.compact" = # current default 216 { 217 cbind(rbind(matrix("", nrow = length(xcv), ncol = length(xrv)), 218 charQuote(makeNames(xrv)), 219 makeLabels(xrv)), 220 c(charQuote(makeNames(xcv)), 221 rep("", times = nrow(x) + 1))) 222 }, 223 "row.compact" = # row-compact version 224 { 225 cbind(rbind(matrix("", nrow = length(xcv)-1, ncol = length(xrv)), 226 charQuote(makeNames(xrv)), 227 makeLabels(xrv)), 228 c(charQuote(makeNames(xcv)), 229 rep("", times = nrow(x)))) 230 }, 231 "col.compact" = # column-compact version 232 { 233 cbind(rbind(cbind(matrix("", nrow = length(xcv), ncol = length(xrv)-1), 234 charQuote(makeNames(xcv))), 235 charQuote(makeNames(xrv)), 236 makeLabels(xrv))) 237 }, 238 "compact" = # fully compact version 239 { 240 xrv.nms <- makeNames(xrv) 241 xcv.nms <- makeNames(xcv) 242 mat <- cbind(rbind(cbind(matrix("", nrow = l.xcv-1, ncol = l.xrv-1), 243 charQuote(makeNames(xcv[-l.xcv]))), 244 charQuote(xrv.nms), 245 makeLabels(xrv))) 246 mat[l.xcv, l.xrv] <- paste(tail(xrv.nms, 1), 247 tail(xcv.nms, 1), sep = lsep) 248 mat 249 }, 250 stop("wrong method")) 251 DATA <- rbind(if(length(xcv)) t(makeLabels(xcv)), 252 if(method %in% c("non.compact", "col.compact")) 253 rep("", times = ncol(x)), 254 format(unclass(x), digits = digits, ...)) 255 cbind(apply(LABS, 2L, format, justify = justify[[1]]), 256 apply(DATA, 2L, format, justify = justify[[min(2, length(justify))]])) 257} 258 259write.ftable <- function(x, file = "", quote = TRUE, append = FALSE, 260 digits = getOption("digits"), ...) 261{ 262 r <- format.ftable(x, quote = quote, digits = digits, ...) 263 cat(t(r), file = file, append = append, 264 sep = c(rep(" ", ncol(r) - 1), "\n")) 265 invisible(x) 266} 267 268print.ftable <- function(x, digits = getOption("digits"), ...) 269 write.ftable(x, quote = FALSE, digits = digits, ...) 270 271read.ftable <- function(file, sep = "", quote = "\"", row.var.names, 272 col.vars, skip = 0) 273{ 274 if(is.character(file)) { 275 file <- file(file, "r") 276 on.exit(close(file)) 277 } 278 if(!inherits(file, "connection")) 279 stop("'file' must be a character string or connection") 280 if(!isSeekable(file)) { 281 ## We really need something seekable, see below. If it is not, 282 ## the best we can do is write everything to a tempfile. 283 tmpf <- tempfile() 284 cat(readLines(file), file = tmpf, sep="\n") 285 file <- file(tmpf, "r") 286 on.exit({close(file);unlink(tmpf)}, add=TRUE) 287 } 288 289 z <- count.fields(file, sep, quote, skip) 290 n.row.vars <- z[max(which(z == max(z)))] - z[length(z)] + 1 291 292 seek(file, where = 0) 293 if(skip > 0) readLines(file, skip) 294 lines <- readLines(file) 295 seek(file, where = 0) 296 if(skip > 0) readLines(file, skip) 297 298 i <- which(z == n.row.vars) 299 ## For an ftable, we have 300 ## cv.1.nm cv.1.l1 ......... 301 ## cv.2.nm cv.2.l1 ......... 302 ## rv.1.nm ... rv.k.nm 303 ## rv.1.l1 ... rv.k.l1 ... ... 304 ## 305 ## so there is exactly one line which does not start with a space 306 ## and has n.row.vars fields (and it cannot be the first one). 307 j <- i[grep("^[^[:space:]]", lines[i])] 308 if((length(j) == 1L) && (j > 1)) { 309 ## An ftable: we can figure things out ourselves. 310 n.col.vars <- j - 1 311 col.vars <- vector("list", length = n.col.vars) 312 n <- c(1, z[1 : n.col.vars] - 1) 313 for(k in seq.int(from = 1, to = n.col.vars)) { 314 s <- scan(file, what = "", sep = sep, quote = quote, 315 nlines = 1, quiet = TRUE) 316 col.vars[[k]] <- s[-1L] 317 names(col.vars)[k] <- s[1L] 318 } 319 row.vars <- setNames(vector("list", length = n.row.vars), 320 scan(file, what = "", sep = sep, quote = quote, 321 nlines = 1, quiet = TRUE)) 322 z <- z[-(1 : (n.col.vars + 1))] 323 } 324 else { 325 ## This is not really an ftable. 326 if((z[1L] == 1) && z[2L] == max(z)) { 327 ## Case A. File looks like 328 ## 329 ## cvar.nam 330 ## rvar.1.nam ... rvar.k.nam cvar.lev.1 ... cvar.lev.l 331 ## rvar.1.lev.1 ... rvar.k.lev.1 ... ... ... 332 ## 333 n.col.vars <- 1 334 col.vars <- vector("list", length = n.col.vars) 335 s <- scan(file, what = "", sep = sep, quote = quote, 336 nlines = 2, quiet = TRUE) 337 names(col.vars) <- s[1L] 338 s <- s[-1L] 339 row.vars <- vector("list", length = n.row.vars) 340 i <- 1 : n.row.vars 341 names(row.vars) <- s[i] 342 col.vars[[1L]] <- s[-i] 343 z <- z[-(1 : 2)] 344 } 345 else { 346 ## Case B. 347 ## We cannot determine the names and levels of the column 348 ## variables, and also not the names of the row variables. 349 if(missing(row.var.names)) { 350 ## 'row.var.names' should be a character vector (or 351 ## factor) with the names of the row variables. 352 stop("'row.var.names' missing") 353 } 354 n.row.vars <- length(row.var.names) 355 row.vars <- setNames(vector("list", length = n.row.vars), 356 as.character(row.var.names)) 357 if(missing(col.vars) || !is.list(col.vars)) { 358 ## 'col.vars' should be a list. 359 stop("'col.vars' missing or incorrect") 360 } 361 col.vars <- lapply(col.vars, as.character) 362 n.col.vars <- length(col.vars) 363 if(is.null(names(col.vars))) 364 names(col.vars) <- 365 paste0("Factor.", seq_along(col.vars)) 366 else { 367 nam <- names(col.vars) 368 ind <- which(!nzchar(nam)) 369 names(col.vars)[ind] <- 370 paste0("Factor.", ind) 371 } 372 } 373 } 374 375 p <- 1 376 n <- integer(n.row.vars) 377 for(k in seq.int(from = 1, to = n.row.vars)) { 378 n[k] <- sum(z >= max(z) - k + 1) / p 379 p <- p * n[k] 380 } 381 is.row.lab <- rep(rep(c(TRUE, FALSE), length(z)), 382 c(rbind(z - min(z) + 1, min(z) - 1))) 383 s <- scan(file, what = "", sep = sep, quote = quote, quiet = TRUE) 384 values <- as.numeric(s[!is.row.lab]) 385 tmp <- s[is.row.lab] 386 len <- length(tmp) 387 for(k in seq.int(from = 1, to = n.row.vars)) { 388 i <- seq.int(from = 1, to = len, by = len / n[k]) 389 row.vars[[k]] <- unique(tmp[i]) 390 tmp <- tmp[seq.int(from = 2, to = len / n[k])] 391 len <- length(tmp) 392 } 393 values <- matrix(values, 394 nrow = prod(lengths(row.vars)), 395 ncol = prod(lengths(col.vars)), 396 byrow = TRUE) 397 structure(values, 398 row.vars = row.vars, 399 col.vars = col.vars, 400 class = "ftable") 401} 402 403as.data.frame.ftable <- 404function(x, row.names = NULL, optional = FALSE, ...) 405 as.data.frame(as.table(x), row.names, optional) 406 407as.matrix.ftable <- 408function(x, sep = "_", ...) 409{ 410 if(!inherits(x, "ftable")) 411 stop("'x' must be an \"ftable\" object") 412 413 make_dimnames <- function(vars) { 414 structure(list(do.call(paste, 415 c(rev(expand.grid(rev(vars))), 416 list(sep=sep)))), 417 names = paste(collapse=sep, names(vars))) 418 } 419 420 structure(unclass(x), 421 dimnames = c(make_dimnames(attr(x, "row.vars")), 422 make_dimnames(attr(x, "col.vars"))), 423 row.vars = NULL, 424 col.vars = NULL) 425} 426