rtables to tinytable

rtables_examples.qmd

---
title: "Converting rtables to tinytable"
format: html
---

## Setup

```{r setup, message=FALSE, warning=FALSE}
library(tinytable)
library(rtables)

# Load the S3 method for rtables conversion
source("rtables_to_tinytable.R")
```

## Example 1: Basic Table with Styling

Let's start with a simple table and apply some visual styling to demonstrate tinytable's capabilities.

```{r example1}
# Create a basic rtables table
lyt1 <- basic_table(
  title = "Summary Statistics by Treatment Arm",
  main_footer = "Data from clinical trial") %>%
  split_cols_by("ARM") %>%
  analyze("AGE", function(x) {
    in_rows("Mean" = mean(x), "SD" = sd(x), "N" = length(x), .formats = c("xx.x", "xx.x", "xx"))
  })

tbl1 <- build_table(lyt1, ex_adsl)

# Convert to tinytable using tt() - S3 dispatch to tinytable.rtables()
tt(tbl1) %>%
  style_tt(i = 1, bold = TRUE, color = "white", background = "#2C5F8D", fontsize = 1.3) %>%
  style_tt(i = 2:3, background = c("lightgrey", "lightblue"))
```

## Example 2: Nested Column Splits

This example shows how multi-level column headers are preserved with spanning columns.

```{r example2}
lyt2 <- basic_table(
  title = "Age Summary by Treatment and Gender"
) %>%
  split_cols_by("ARM") %>%
  split_cols_by("SEX") %>%
  analyze("AGE", mean, format = "xx.x")

tbl2 <- build_table(lyt2, ex_adsl)

# Convert and display
tt2 <- tt(tbl2)
tt2
```

## Example 3: Row Groups with Indentation

This example demonstrates row grouping where variable names become section headers with indented data rows.

```{r example3}
lyt3 <- basic_table(
  title = "Demographics Table"
) %>%
  split_cols_by("ARM") %>%
  analyze("AGE", function(x) {
    in_rows(
      "Mean" = mean(x),
      "Median" = median(x),
      .formats = "xx.x"
    )
  }) %>%
  analyze("BMRKR1", function(x) {
    in_rows(
      "Mean" = mean(x),
      "SD" = sd(x),
      .formats = "xx.xx"
    )
  })

tbl3 <- build_table(lyt3, ex_adsl)

# Convert to tinytable
tt(tbl3) %>%
  style_tt(i = groupi, bold = TRUE, background = "#E8F4F8")
```

## Example 4: Row Splits with Summary Statistics

Tables with row splits show counts and nested analysis results with proper indentation.

```{r example4}
lyt4 <- basic_table(
  title = "Analysis by Gender"
) %>%
  split_cols_by("ARM") %>%
  split_rows_by("SEX", split_fun = drop_split_levels) %>%
  summarize_row_groups() %>%
  analyze("AGE", mean, format = "xx.x")

tbl4 <- build_table(lyt4, ex_adsl)

# Convert to tinytable
tt4 <- tt(tbl4)
tt4
```

## Example 5: Complex Nested Structure

This example demonstrates multiple levels of row nesting with proper hierarchical indentation.

```{r example5}
lyt5 <- basic_table(
  title = "Multi-Level Demographics",
  main_footer = "Nested splits by Gender and Stratum"
) %>%
  split_cols_by("ARM") %>%
  split_rows_by("SEX") %>%
  split_rows_by("STRATA1") %>%
  analyze("AGE", function(x) {
    in_rows(
      "n" = length(x),
      "Mean (SD)" = c(mean(x), sd(x)),
      .formats = c("xx", "xx.x (xx.x)")
    )
  })

tbl5 <- build_table(lyt5, ex_adsl)

# Convert to tinytable (first 20 rows for brevity)
tt(tbl5)
```

rtables_to_tinytable.R

#' Convert rtables to tinytable
#'
#' @description
#' S3 method to convert `rtables` table objects to `tinytable` format.
#' After sourcing this file, rtables objects can be passed directly to `tt()`
#' which will automatically dispatch to this method.
#'
#' @param x An rtables table object.
#' @param ... Additional arguments passed to `tt()`.
#'
#' @return A `tinytable` object with preserved structure including:
#'   - Multi-level column headers (spanning columns)
#'   - Row group headers (top-level splits)
#'   - Nested indentation (multi-level row splits)
#'   - Column alignment
#'   - Titles and footers
#'
#' @details
#' This function extracts the table structure from rtables using `matrix_form()` and
#' `make_row_df()`, then reconstructs it in tinytable format with appropriate styling.
#'
#' @examples
#' \dontrun{
#' library(tinytable)
#' library(rtables)
#' source("rtables_to_tinytable.R")
#'
#' # Create an rtables table
#' lyt <- basic_table(title = "Summary Statistics") %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", mean)
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' # Convert to tinytable (S3 method dispatch via tt())
#' tt_obj <- tt(tbl)
#' print(tt_obj)
#'
#' # Apply additional tinytable styling
#' tt_obj %>%
#'   style_tt(i = 1, bold = TRUE) %>%
#'   style_tt(j = 2, color = "blue")
#' }
#'
#' @export
tt.VTableTree <- function(x, ...) {
  # Extract all rtables metadata in one pass
  rt <- extract_rtables_structure(x)

  # Build body dataframe with explicit row mapping
  body <- build_body_df(rt)

  # Create base tinytable
  out <- tt(
    body$df,
    caption = rt$caption,
    notes   = rt$notes,
    ...
  )

  # Apply structural elements in order
  out <- apply_column_groups(out, rt)
  out <- apply_row_groups(out, rt, body$row_map)
  out <- apply_indentation(out, body$row_map)
  out <- apply_alignment(out, rt, body$row_map)

  out
}

# =============================================================================
# Extraction helpers - touch rtables/formatters once
# =============================================================================

#' Extract all rtables metadata in one pass
#'
#' @param x An rtables table object
#' @return List with all extracted metadata
extract_rtables_structure <- function(x) {
  mat <- rtables::matrix_form(x, indent_rownames = TRUE)

  body_matrix <- formatters::mf_strings(mat)
  hnum <- formatters::mf_nlheader(mat)

  list(
    mat         = mat,
    body_matrix = body_matrix,
    hnum        = hnum,
    colnames    = as.character(body_matrix[hnum, ]),
    spans       = formatters::mf_spans(mat),
    aligns      = formatters::mf_aligns(mat),
    rdf         = rtables::make_row_df(x),
    caption     = extract_caption(x),
    notes       = extract_notes(x)
  )
}

#' Extract caption from rtables titles
#'
#' @param x An rtables table object
#' @return Caption string or NULL
extract_caption <- function(x) {
  titles <- formatters::all_titles(x)
  if (length(titles) > 0 && any(nzchar(titles))) {
    paste(titles[nzchar(titles)], collapse = " - ")
  } else {
    NULL
  }
}

#' Extract notes from rtables footers
#'
#' @param x An rtables table object
#' @return List of notes or NULL
extract_notes <- function(x) {
  footers <- formatters::all_footers(x)
  if (length(footers) > 0 && any(nzchar(footers))) {
    as.list(footers[nzchar(footers)])
  } else {
    NULL
  }
}

# =============================================================================
# Transformation helpers - build data and row mapping
# =============================================================================

#' Build body dataframe with explicit row mapping
#'
#' @param rt Extracted rtables structure
#' @return List with df and row_map
build_body_df <- function(rt) {
  body <- rt$body_matrix[(rt$hnum + 1):nrow(rt$body_matrix), , drop = FALSE]
  rdf <- rt$rdf

  # Identify top-level label rows that will become row groups
  top_level <- which(rdf$node_class == "LabelRow" & rdf$indent == 0)

  # Keep all rows except top-level labels
  keep <- setdiff(seq_len(nrow(body)), top_level)

  # Build dataframe
  df <- as.data.frame(body[keep, , drop = FALSE], stringsAsFactors = FALSE)
  colnames(df) <- rt$colnames

  # Clean up first column (remove leading spaces, replace empty strings)
  if (ncol(df) > 0 && nrow(df) > 0) {
    df[[1]] <- trimws(df[[1]], which = "left")
  }
  df[df == ""] <- " "

  # Build explicit row mapping
  row_map <- build_row_map(rdf, top_level, body)

  list(df = df, row_map = row_map)
}

#' Build explicit row index mapping
#'
#' Maps original rtables rows to tinytable rows, accounting for filtered rows.
#'
#' @param rdf Row dataframe from rtables::make_row_df()
#' @param top_level Indices of top-level label rows (to be filtered)
#' @param body Body matrix from rtables
#' @return List with mapping information
build_row_map <- function(rdf, top_level, body) {
  n <- nrow(rdf)

  # Map original rtables row index to tinytable row index
  # NA for rows that are filtered out (top-level labels)
  original_to_body <- integer(n)
  body_idx <- 0

  for (i in seq_len(n)) {
    if (i %in% top_level) {
      original_to_body[i] <- NA_integer_
    } else {
      body_idx <- body_idx + 1
      original_to_body[i] <- body_idx
    }
  }

  # Store row group information for later insertion
  row_groups <- list()
  group_positions <- integer()

  if (length(top_level) > 0) {
    for (i in top_level) {
      label <- trimws(as.character(body[i, 1]))
      # Position where group header should be inserted (1-based for group_tt)
      # Count body rows before this position, then add 1 for group_tt indexing
      pos <- sum(seq_len(i) %in% setdiff(seq_len(i), top_level)) + 1
      row_groups[[label]] <- pos
      group_positions <- c(group_positions, pos)
    }
  }

  list(
    original_to_body = original_to_body,
    indent           = rdf$indent,
    node_class       = rdf$node_class,
    top_level        = top_level,
    row_groups       = row_groups,
    group_positions  = sort(group_positions)
  )
}

# =============================================================================
# Styling helpers - column groups, row groups, indentation, alignment
# =============================================================================

#' Apply column groups from multi-level headers
#'
#' @param out Tinytable object
#' @param rt Extracted rtables structure
#' @return Modified tinytable object
apply_column_groups <- function(out, rt) {
  if (rt$hnum <= 1) {
    return(out)
  }

  # Process each header row except the last (which becomes colnames)
  for (h in seq_len(rt$hnum - 1)) {
    groups <- compute_col_groups(rt$body_matrix[h, ], rt$spans[h, ])

    if (length(groups) > 0) {
      out <- group_tt(out, j = groups)
    }
  }

  out
}

#' Compute column group specifications
#'
#' @param labels Header row labels
#' @param spans Column span values
#' @return Named list of column groups
compute_col_groups <- function(labels, spans) {
  groups <- list()
  col_idx <- 1

  while (col_idx <= length(spans)) {
    span_width <- spans[col_idx]
    label <- trimws(as.character(labels[col_idx]))

    # Add group if label is non-empty
    if (nzchar(label)) {
      if (span_width > 1) {
        groups[[label]] <- col_idx:(col_idx + span_width - 1)
      } else {
        groups[[label]] <- col_idx
      }
    }

    col_idx <- col_idx + span_width
  }

  groups
}

#' Apply row groups from top-level splits
#'
#' @param out Tinytable object
#' @param rt Extracted rtables structure
#' @param row_map Row mapping information
#' @return Modified tinytable object
apply_row_groups <- function(out, rt, row_map) {
  if (length(row_map$row_groups) == 0) {
    return(out)
  }

  # Row groups are already computed with correct positions
  out <- group_tt(out, i = row_map$row_groups)

  out
}

#' Apply indentation to nested rows
#'
#' Adjusts row indices to account for group headers inserted by group_tt().
#'
#' @param out Tinytable object (after row groups applied)
#' @param row_map Row mapping information
#' @return Modified tinytable object
apply_indentation <- function(out, row_map) {
  # Get unique indent levels (excluding 0)
  indent_levels <- sort(unique(row_map$indent[row_map$indent > 0]))

  if (length(indent_levels) == 0) {
    return(out)
  }

  # If we have row groups, need to adjust indices for inserted group headers
  has_groups <- length(row_map$row_groups) > 0

  for (lvl in indent_levels) {
    # Find original rows with this indent level
    original_rows <- which(row_map$indent == lvl)

    # Map to body rows (removing NAs from filtered rows)
    body_rows <- row_map$original_to_body[original_rows]
    body_rows <- body_rows[!is.na(body_rows)]

    if (length(body_rows) > 0) {
      if (has_groups) {
        # Adjust for group headers inserted before each row
        adjusted_rows <- sapply(body_rows, function(r) {
          r + sum(row_map$group_positions <= r)
        })
      } else {
        adjusted_rows <- body_rows
      }

      out <- style_tt(out, i = adjusted_rows, j = 1, indent = lvl * 2)
    }
  }

  out
}

#' Apply column alignment
#'
#' @param out Tinytable object
#' @param rt Extracted rtables structure
#' @param row_map Row mapping information
#' @return Modified tinytable object
apply_alignment <- function(out, rt, row_map) {
  # Extract body alignments (excluding header rows)
  body_aligns <- rt$aligns[(rt$hnum + 1):nrow(rt$aligns), , drop = FALSE]

  # Filter out top-level label rows
  if (length(row_map$top_level) > 0) {
    body_aligns <- body_aligns[-row_map$top_level, , drop = FALSE]
  }

  # Alignment mapping
  align_map <- c("left" = "l", "center" = "c", "right" = "r")

  # Apply most common alignment for each column
  for (j in seq_len(ncol(body_aligns))) {
    align_vals <- table(body_aligns[, j])
    most_common <- names(align_vals)[which.max(align_vals)]

    if (most_common %in% names(align_map)) {
      out <- style_tt(out, j = j, align = align_map[[most_common]])
    }
  }

  out
}