1percentages <- function(obj,...) UseMethod("percentages") 2 3percentages.table <- function(obj,by=NULL,which=NULL,se=FALSE,ci=FALSE,ci.level=.95,...){ 4 5 dn <- dimnames(obj) 6 ndn <- names(dn) 7 8 by <- unique(by) 9 which <- unique(which) 10 11 lby <- length(by) 12 lwi <- length(which) 13 14 if(!(lby||lwi)){ 15 margin <- NULL 16 } else if (lby && lwi) { 17 18 if(length(intersect(by,which))>0) 19 stop("duplicate variables") 20 21 all <- union(which,by) 22 ii <- match(all,ndn) 23 if(any(is.na(ii))) stop("undefined variables") 24 if(length(ii)<length(dn)){ 25 obj <- margin.table(obj,ii) 26 return(Recall(obj,by=by,which=which,se=se,ci=ci,ci.level=ci.level,...)) 27 } 28 else { 29 margin <- match(by,ndn) 30 } 31 } 32 else if(lby){ 33 margin <- match(by,ndn) 34 if(any(is.na(margin))) stop("undefined variables") 35 } 36 else if(lwi){ 37 margin <- match(setdiff(ndn,which),ndn) 38 if(any(is.na(margin))) stop("undefined variables") 39 } 40 41 tab <- obj # Just another name ... 42 ptab <- prop.table(tab,margin=margin) 43 if(!ci && !se){ 44 structure(100*ptab,class=c("percentage.table",class(obj))) 45 } else { 46 mtab <- margin.table(tab,margin=margin) 47 48 dd <- seq_along(dim(ptab)) 49 50 perm <- c(margin,setdiff(dd,margin)) 51 rev.perm <- seq_along(perm) 52 rev.perm[perm] <- rev.perm 53 54 mtab <- aperm(array(mtab,dim=dim(ptab)[perm]), 55 rev.perm) 56 dimnames(mtab) <- dimnames(ptab) 57 if(se){ 58 var.tab <- ptab*(1-ptab)/mtab 59 se.tab <- sqrt(var.tab) 60 } 61 if(ci){ 62 alpha <- (1-ci.level)/2 63 lower <- upper <- array(NA,dim=dim(ptab)) 64 isnull <- ptab == 0 | is.na(ptab) 65 isfull <- ptab == 1 | is.na(ptab) 66 lower[!isnull] <- qbeta(alpha,tab[!isnull],mtab[!isnull]-tab[!isnull]+1) 67 lower[isnull] <- 0 68 upper[!isfull] <- qbeta(1-alpha,tab[!isfull]+1,mtab[!isfull]-tab[!isfull]) 69 upper[isfull] <- 1 70 } 71 if(!ci){ 72 res <- 100*cbind(as.vector(ptab),as.vector(se.tab)) 73 res <- array(res,dim=c(dim(ptab),2), 74 dimnames=c( 75 dimnames(ptab), 76 list(Result=c("Percentage","SE")) 77 )) 78 } 79 else if(!se){ 80 res <- 100*cbind(as.vector(ptab),as.vector(lower),as.vector(upper)) 81 res <- array(res,dim=c(dim(ptab),3), 82 dimnames=c( 83 dimnames(ptab), 84 list(Result=c("Percentage","Lower bound","Upper bound")) 85 )) 86 } 87 else { 88 res <- 100*cbind(as.vector(ptab),as.vector(se.tab), 89 as.vector(lower),as.vector(upper)) 90 res <- array(res,dim=c(dim(ptab),4), 91 dimnames=c( 92 dimnames(ptab), 93 list(Result=c("Percentage","SE","Lower bound","Upper bound")) 94 )) 95 } 96 structure(res,class=c("xpercentage.table","percentage.table",class(obj))) 97 } 98} 99 100percentages.formula <- function(obj,data=parent.frame(),weights=NULL,...){ 101 102 if(is.table(data)) 103 tab <- data 104 else{ 105 106 allv <- all.vars(obj) 107 allv.formula <- obj 108 if(length(obj)==3) 109 allv.formula <- reformulate(allv) 110 else 111 allv.formula <- obj 112 113 if(!missing(weights)){ 114 weights <- deparse(substitute(weights)) 115 allv.formula <- reformulate(all.vars(allv.formula), 116 response=weights) 117 } 118 my.call <- match.call() 119 xtc <- my.call 120 ii <- match(names(formals(stats::xtabs)),names(xtc),0L) 121 xtc <- xtc[c(1L,ii)] 122 xtc[[1L]] <- quote(stats::xtabs) 123 xtc$formula <- allv.formula 124 if(is.environment(data)){ 125 mf <- model.frame(allv.formula,data=data) 126 xtc$data <- mf 127 } 128 tab <- eval(xtc,parent.frame()) 129 } 130 131 if(length(obj)==3){ 132 which <- all.vars(obj[-3]) 133 by <- all.vars(obj[-2]) 134 } 135 else { 136 which <- all.vars(obj) 137 by <- NULL 138 } 139 percentages.table(tab,by=by,which=which,...) 140} 141 142as.data.frame.percentage.table <- function(x,...){ 143 res <- NextMethod("as.data.frame") 144 rename(res,Freq="Percentage") 145} 146 147as.data.frame.xpercentage.table <- function(x,...){ 148 dx <- dim(x) 149 dn <- dimnames(x) 150 ld <- length(dx) 151 lst.d <- dx[ld] 152 xm <- array(x,dim=c(prod(dx[-ld]),dx[ld])) 153 tabs <- lapply(1:dx[ld],mcol2df, 154 x=xm, 155 dim=dx[-ld], 156 dimnames=dn[-ld], 157 slicenames=dn[[ld]] 158 ) 159 Freq.col <- which("Freq"==names(tabs[[1]])) 160 result.names <- dimnames(x)$Result 161 for(i in seq_along(tabs)) 162 names(tabs[[i]])[Freq.col] <- result.names[i] 163 Reduce(merge,tabs) 164} 165 166mcol2df <- function(i,x,dim,dimnames,slicenames){ 167 y <- structure(x[,i], 168 class="table", 169 dim=dim, 170 dimnames=dimnames) 171 y <- as.data.frame(y) 172 rename(y,Freq=slicenames[i]) 173} 174 175