Using attributes of `ftable` for extracting data

Question

I sometimes use the ftable function purely for its presentation of hierarchical categories. However, sometimes, when the table is large, I would like to further sub

Answer 1

Once the data is aggregated to frequencies by combination of factors as is the case with the Titanic data set, it is arguably easier to subset the raw data and tabulate it for display rather than manipulating the output object.

I recognize that the OP asks for solutions using ftable, but with the back and forth in the comments section soliciting other ideas, I thought I'd post a different take on this question because it illustrates a way to simultaneously subset the data and generate the hierarchical structure of the contingency tables without custom functions.

Here is an approach using the tables package that preserves the hierarchical structure of the Titanic data, as well as eliminating cells that are empty when we subset the data frame.

First we cast the incoming table as a data frame so we can subset it during the tabular() function.

 library(titanic)
 df <- as.data.frame(Titanic)

Then we use tables::tabular() while subsetting the data in the data= argument with the extract operator [, and use DropEmpty() to avoid printing rows and columns where Freq == 0. We also use Heading() to suppress unwanted headings for Freq and sum.

tabular((Class * Sex) ~ (Age)*Survived*Heading()*Freq*Heading()*sum*DropEmpty(empty=0),
        data=df[df$Class %in% c("1st","3rd") & df$Age=="Child",])

...and the output:

> tabular((Class * Sex) ~ (Age)*Survived*Heading()*Freq*Heading()*sum*DropEmpty(empty=0),
+         data=df[df$Class %in% c("1st","3rd") & df$Age=="Child",])

              Age         
              Child       
              Survived    
 Class Sex    No       Yes
 1st   Male    0        5 
       Female  0        1 
 3rd   Male   35       13 
       Female 17       14

If we remove DropEmpty(), we replicate the entire tabular structure based on the factor variables in the table.

> # remove DropEmpty() to replicate entire factor structure
> tabular((Class * Sex) ~ (Age)*Survived*Heading()*Freq*Heading()*sum,
+         data=df[df$Class %in% c("1st","3rd") & df$Age=="Child",])

              Age                      
              Child        Adult       
              Survived     Survived    
 Class Sex    No       Yes No       Yes
 1st   Male    0        5  0        0  
       Female  0        1  0        0  
 2nd   Male    0        0  0        0  
       Female  0        0  0        0  
 3rd   Male   35       13  0        0  
       Female 17       14  0        0  
 Crew  Male    0        0  0        0  
       Female  0        0  0        0  
> 

Replicating the second and third examples from the OP is also straightforward.

> # second example from question
> tabular((Class * Sex * Age) ~ Survived*Heading()*Freq*Heading()*sum*DropEmpty(empty=0),
+         data=df[df$Class %in% c("1st","3rd") & df$Survived=="No",])

                    Survived
 Class Sex    Age   No      
 1st   Male   Child   0     
              Adult 118     
       Female Child   0     
              Adult   4     
 3rd   Male   Child  35     
              Adult 387     
       Female Child  17     
              Adult  89     
> # third example from question 
> tabular((Class * Sex) ~ (Age)*Survived*Heading()*Freq*Heading()*sum*DropEmpty(empty=0),
+         data=df[df$Class %in% c("1st","3rd"),])

              Age                      
              Child        Adult       
              Survived     Survived    
 Class Sex    No       Yes No       Yes
 1st   Male    0        5  118       57
       Female  0        1    4      140
 3rd   Male   35       13  387       75
       Female 17       14   89       76
> 

Answer 2

Here's what I was able to sort of hack together, with some help from Axeman:

replace_empty_arguments <- function(a) {
  empty_symbols <- vapply(a, function(x) {
    is.symbol(x) && identical("", as.character(x)), 0)
  } 
  a[!!empty_symbols] <- 0
  lapply(a, eval)
}

`[.ftable` <- function (inftable, ...) {
  if (!class(inftable) %in% "ftable") stop("input is not an ftable")
  tblatr <- attributes(inftable)[c("row.vars", "col.vars")]
  valslist <- replace_empty_arguments(as.list(match.call()[-(1:2)]))
  x <- sapply(valslist, function(x) identical(x, 0))
  TAB <- as.table(inftable)
  valslist[x] <- dimnames(TAB)[x]
  temp <- as.matrix(expand.grid(valslist))
  out <- ftable(
    `dimnames<-`(`dim<-`(TAB[temp], lengths(valslist)), valslist),
    row.vars = seq_along(tblatr[["row.vars"]]),
    col.vars = seq_along(tblatr[["col.vars"]]) + length(tblatr[["row.vars"]]))
  names(attributes(out)[["row.vars"]]) <- names(tblatr[["row.vars"]])
  names(attributes(out)[["col.vars"]]) <- names(tblatr[["col.vars"]])
  out
}

Try it out with the examples from the question:

mytable[c("1st", "3rd"), , "Child", ]
##                    Survived No Yes
## Class Sex    Age                  
## 1st   Male   Child           0   5
##       Female Child           0   1
## 3rd   Male   Child          35  13
##       Female Child          17  14

mytable[c("1st", "3rd"), , , "No"]
##                    Survived  No
## Class Sex    Age               
## 1st   Male   Child            0
##              Adult          118
##       Female Child            0
##              Adult            4
## 3rd   Male   Child           35
##              Adult          387
##       Female Child           17
##              Adult           89

tab2[c("1st", "3rd"), , , ]
##              Age      Child     Adult    
##              Survived    No Yes    No Yes
## Class Sex                                
## 1st   Male                0   5   118  57
##       Female              0   1     4 140
## 3rd   Male               35  13   387  75
##       Female             17  14    89  76