Extending atable

Methods for other classes

atable only support numeric, factor and ordered classes by default. If you want to use unsupported classes, e.g. Date or surv, you can define methods for them reasonably easily.

# statistics function
statistics.Date <- function(x, ...){
  out <- list(min = min(x, na.rm = TRUE),
              med = median(x, na.rm = TRUE),
              max = max(x, na.rm = TRUE))
  class(out) <- c("statistics_date", class(out))
  out
}

format_statistics.statistics_date <- function(x, ...){
  z <- c("Min ; Max", "Median")
  out <- data.frame(tag = factor(z, z),
                    value = c(paste(x$min, x$max, sep = " ; "),
                              as.character(x$med)),
                    stringsAsFactors = FALSE)
  return(out)
}

# add a date variable to mtcars
mtcars$date <- as.Date(runif(nrow(mtcars), 0, 365*10), "1990-01-01")
knitr::kable(atable(mtcars, "date"))

library(survival)
# add some survival data (use 'date' as the timepoint)
mtcars$date2 <- mtcars$date + round(rnorm(nrow(mtcars), 10, 4)) # end date
mtcars$time <- as.numeric(mtcars$date2 - mtcars$date) # time
mtcars$not_road_worthy <- rbinom(nrow(mtcars), 1, .2) # 'survived'?
mtcars$surv <- with(mtcars, Surv(time, not_road_worthy))

# statistics function
statistics.Surv <- function(x, ...){
  survfit_object <- survival::survfit(x ~ 1)
  # copied from survival::print.survfit
  out <- survival:::survmean(survfit_object, rmean = "common")
  return(list(mean_survival_time = out$matrix["*rmean"], 
              SE = out$matrix["*se(rmean)"]))
}
# testing function
two_sample_htest.Surv <- function(value, group, ...){
  survdiff_result <- survival::survdiff(value~group, rho=0)
  # copy from survival::print.survdiff
  etmp <- survdiff_result$exp
  df <- (sum(1 * (etmp > 0))) - 1
  p <- 1 - stats::pchisq(survdiff_result$chisq, df)
  return(list(p = p,stat = survdiff_result$chisq))
}

knitr::kable(atable(surv ~ am, mtcars))

Different statistics for variables of a single class

In the mtcars example, suppose we want to summarize hp by mean and SD and disp by median and quartiles. Mean and SD are the default statistics for numeric variables in atable so we only have to worry about disp. To accomplish this, we can use the same method as we used above for Date variables - we will define new functions for a new class. We will assign the new class, which we will call numeric2, to disp and define new functions to handle it.

# add numeric2 to the class of disp
class(mtcars$disp) <- c("numeric2", class(mtcars$disp))
# subsetting function for numeric2 class
'[.numeric2' <- function(x, i, j, ...){
  y <- unclass(x)[i, ...]
  class(y) <- c("numeric2", class(y))
  y
}

The subsetting function is used to retain the class of the variable (otherwise it reverts to a numeric in this case). We didn’t need to do this above as the relevant function for the Date and surv classes already exist.

Next we define functions to calculate the statistics that we want to use. These both have to return named lists.

# statistics function
statistics.numeric2 <- function(x, ...){
  statistics_out <- list(Median = median(x, na.rm = TRUE), 
                         p25 = quantile(x, 0.25, na.rm = TRUE),
                         p75 = quantile(x, 0.75, na.rm = TRUE))
  class(statistics_out) <- c("statistics_numeric2", class(statistics_out))
  # We will need this new class later to specify the format
  return(statistics_out)
}
# testing function
two_sample_htest.numeric2 <- function(value, group, ...){
  d <- data.frame(value = value, group = group)
  test_out <- stats::wilcox.test(value ~ group, d)
  return(test_out)
}

Now we can test to see if our new class has been identified and used correctly.

knitr::kable(atable(vs + cyl + hp + disp ~ am, mtcars))
#> Warning in wilcox.test.default(x = c(2, 3, 2, 3, 1, 1, 2, 2, 3, 3, 3, 3, : cannot compute exact p-
#> value with ties
#> Warning in stats::ks.test(x, y, alternative = c("two.sided"), ...): cannot compute exact p-value
#> with ties
#> Warning in wilcox.test.default(x = structure(c(258, 360, 225, 360, 146.7, : cannot compute exact p-
#> value with ties

We probably don’t want to have the quartiles beneath the median so we can also define a formatting function. The format_statistics function should return a dataframe with variable tag (as a factor to retain ordering) and value (most likely a string). The class is no longer numeric2 but statistics_numeric2 as defined in the statistics.numeric2 function.

format_statistics.statistics_numeric2 <- function(x, ...){
  out <- data.frame(tag = factor(c("Median [Quartiles]")),
                    value = sprintf("%2.1f [%2.1f ; %2.1f]", x$Median, x$p25, x$p75),
                    stringsAsFactors = FALSE)
  return(out)
}

a <- atable(vs + cyl + hp + disp ~ am, mtcars)
#> Warning in wilcox.test.default(x = c(2, 3, 2, 3, 1, 1, 2, 2, 3, 3, 3, 3, : cannot compute exact p-
#> value with ties
#> Warning in stats::ks.test(x, y, alternative = c("two.sided"), ...): cannot compute exact p-value
#> with ties
#> Warning in wilcox.test.default(x = structure(c(258, 360, 225, 360, 146.7, : cannot compute exact p-
#> value with ties
knitr::kable(a)

# a