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