inst/doc/split_functions.R

In rtables: Reporting Tables

## -----------------------------------------------------------------------------
set.seed(0)
levs_type <- c("car", "truck", "suv", "sailboat", "cruiseliner")

vclass <- sample(c("auto", "boat"), 1000, replace = TRUE)
auto_inds <- which(vclass == "auto")
vtype <- rep(NA_character_, 1000)
vtype[auto_inds] <- sample(
  c("car", "truck"), ## suv missing on purpose
  length(auto_inds),
  replace = TRUE
)
vtype[-auto_inds] <- sample(
  c("sailboat", "cruiseliner"),
  1000 - length(auto_inds),
  replace = TRUE
)

vehic_data <- data.frame(
  vehicle_class = factor(vclass),
  vehicle_type = factor(vtype, levels = levs_type),
  color = sample(
    c("white", "black", "red"), 1000,
    prob = c(1, 2, 1),
    replace = TRUE
  ),
  cost = ifelse(
    vclass == "boat",
    rnorm(1000, 100000, sd = 5000),
    rnorm(1000, 40000, sd = 5000)
  )
)
head(vehic_data)

## ----examples, message=FALSE--------------------------------------------------
library(rtables)

lyt <- basic_table() %>%
  split_cols_by("color") %>%
  split_rows_by("vehicle_class") %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt, vehic_data)

## -----------------------------------------------------------------------------
lyt2 <- basic_table() %>%
  split_cols_by("color") %>%
  split_rows_by("vehicle_class", split_fun = trim_levels_in_group("vehicle_type")) %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt2, vehic_data)

## ----message = FALSE----------------------------------------------------------
library(tibble)
map <- tribble(
  ~vehicle_class, ~vehicle_type,
  "auto",         "truck",
  "auto",         "suv",
  "auto",         "car",
  "boat",         "sailboat",
  "boat",         "cruiseliner"
)

lyt3 <- basic_table() %>%
  split_cols_by("color") %>%
  split_rows_by("vehicle_class", split_fun = trim_levels_to_map(map)) %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt3, vehic_data)

## -----------------------------------------------------------------------------
lyt4 <- basic_table(show_colcounts = TRUE) %>%
  split_cols_by("color", split_fun = add_overall_level("allcolors", label = "All Colors")) %>%
  split_rows_by("vehicle_class", split_fun = trim_levels_to_map(map)) %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt4, vehic_data)

## -----------------------------------------------------------------------------
combodf <- tribble(
  ~valname, ~label, ~levelcombo, ~exargs,
  "non-white", "Non-White", c("black", "red"), list(),
  "blackwhite", "Black or White", c("black", "white"), list()
)


lyt5 <- basic_table(show_colcounts = TRUE) %>%
  split_cols_by("color", split_fun = add_combo_levels(combodf)) %>%
  split_rows_by("vehicle_class", split_fun = trim_levels_to_map(map)) %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt5, vehic_data)

## -----------------------------------------------------------------------------
## reverse order of levels

rev_lev <- function(df, spl, vals, labels, ...) {
  ## in the split_rows_by() and split_cols_by() cases,
  ## spl_variable() gives us the variable
  var <- spl_variable(spl)
  vec <- df[[var]]
  levs <- if (is.character(vec)) unique(vec) else levels(vec)
  df[[var]] <- factor(vec, levels = rev(levs))
  df
}

rem_lev_facet <- function(torem) {
  function(df, spl, vals, labels, ...) {
    var <- spl_variable(spl)
    vec <- df[[var]]
    bad <- vec == torem
    df <- df[!bad, ]
    levs <- if (is.character(vec)) unique(vec) else levels(vec)
    df[[var]] <- factor(as.character(vec[!bad]), levels = setdiff(levs, torem))
    df
  }
}

## -----------------------------------------------------------------------------
sort_them_facets <- function(splret, spl, fulldf, ...) {
  ord <- order(sapply(splret$datasplit, nrow))
  make_split_result(
    splret$values[ord],
    splret$datasplit[ord],
    splret$labels[ord]
  )
}

## -----------------------------------------------------------------------------
silly_splfun1 <- make_split_fun(
  pre = list(
    rev_lev,
    rem_lev_facet("white")
  ),
  post = list(sort_them_facets)
)

lyt6 <- basic_table(show_colcounts = TRUE) %>%
  split_cols_by("color", split_fun = silly_splfun1) %>%
  split_rows_by("vehicle_class", split_fun = trim_levels_to_map(map)) %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt6, vehic_data)

## -----------------------------------------------------------------------------
silly_core_split <- function(spl, df, vals, labels, .spl_context) {
  make_split_result(
    c("first", "lowmid", "highmid", "last"),
    datasplit = list(
      df[1:100, ],
      df[101:500, ],
      df[501:900, ],
      df[901:1000, ]
    ),
    labels = c(
      "first 100",
      "obs 101-500",
      "obs 501-900",
      "last 100"
    )
  )
}

## -----------------------------------------------------------------------------
even_sillier_splfun <- make_split_fun(core_split = silly_core_split)

lyt7 <- basic_table(show_colcounts = TRUE) %>%
  split_cols_by("color") %>%
  split_rows_by("vehicle_class", split_fun = even_sillier_splfun) %>%
  split_rows_by("vehicle_type") %>%
  analyze("cost")

build_table(lyt7, vehic_data)