Incidence of Treatment Emergent Adverse Events by Treatment Group

# ------------------------------------------------------------------------------
# t-ae-incidence — Incidence of Treatment Emergent Adverse Events by Treatment Group
# ------------------------------------------------------------------------------
# Target: Table 14-5.01 of the CDISCPILOT01 clinical study report (27 June 2006),
# sixteen pages. Safety population. For every system organ class and every
# preferred term within it: subjects with at least one event, the percentage of
# the arm, the number of events in brackets, and Fisher's exact test of placebo
# against each active arm. The first row is every event in one line.
#
# This is the report's shape, not the FDA-standard one: t-ae-overview (AET01)
# and t-ae-common (AET02) keep their identifiers and their layouts and are what
# the ICH E3 templates carried before v0.4.0; this display is what the CDISC
# pilot profile places (D0032, #62).
# ------------------------------------------------------------------------------
id: t-ae-incidence
title: "Incidence of Treatment Emergent Adverse Events by Treatment Group"
regulatory_id: AET03
type: table
dataset: adae
analysis_set: safety
denominator: adsl
group:
  - TRT01A
total: false
analyses:
  - name: any
    method: subject_count
    custom: ard_incidence_any
    reference_arm: Placebo
    label: "Any body system"
    variable: AEDECOD
    filter: "TRTEMFL == 'Y'"
  - name: by_soc_pt
    method: hierarchical_count
    custom: ard_incidence_hierarchy
    reference_arm: Placebo
    label: "Adverse events by system organ class and preferred term"
    hierarchy: [AEBODSYS, AEDECOD]
    filter: "TRTEMFL == 'Y'"

id: t-ae-incidence
title: "Incidence of Treatment Emergent Adverse Events by Treatment Group"
study: CDISCPILOT01
population_label: "Safety Analysis Set"
cutoff: "2014-07-01"
source: "Source: adae, adsl (CDISCPILOT01 ADaM package, phuse-org/phuse-scripts). Data cut-off: 2014-07-01."
footnotes:
  - "Treatment-emergent events are those flagged TRTEMFL = 'Y' in the study's ADAE: events that start on or after the start of treatment, as the reference report (Table 14-5.01) defines them. Adverse events are coded using MedDRA."
  - "Subjects are counted once per system organ class and once per preferred term; percentages are based on the number of subjects in the safety population within each treatment group. The bracketed figure is the total number of times an event was recorded."
  - "P-values are Fisher's exact test comparing placebo with each active treatment group on the number of subjects with the event. An asterisk is appended to p-values below 0.15, as in the reference report; a p-value that rounds to 1 prints as >0.99; where neither arm has a subject with the event there is no test and the cell is blank."
  - "System organ classes are in alphabetical order; preferred terms within a class are in descending order of high-dose subjects, then alphabetical — the order the reference report prints."
  - "Four of the 227 p-values the reference report prints differ from this display at the third decimal, each by one thousandth: vomiting (placebo vs high dose, 0.208 here, 0.209 there), salivary hypersecretion (0.057 here, 0.058 there), application site erythema (0.002 here, 0.003 there) and syncope (placebo vs low dose, 0.057 here, 0.058 there). The subject counts agree; R's exact two-sided test gives 0.2085, 0.0575, 0.0025 and 0.0575, and the 2006 program rounded each up. They are recorded and tracked in quality/data/reference-report-agreement.json."
columns:
  order: [Placebo, "Xanomeline Low Dose", "Xanomeline High Dose", "Placebo vs. Low Dose", "Placebo vs. High Dose"]
  patterns:
    "Placebo vs. Low Dose": pvalue
    "Placebo vs. High Dose": pvalue
format:
  n_pct_events: "{n} ({p}%) [{events}]"
  pvalue: "{p_value_fmt}"
  zero_count: "0"
  digits:
    p: 1
    events: 0
rows:
  - { analysis: any, label: "ANY BODY SYSTEM", pattern: n_pct_events, indent: 0 }
  - analysis: by_soc_pt
    type: hierarchical
    levels: [AEBODSYS, AEDECOD]
    pattern: n_pct_events
    sort:
      outer: alpha
      inner: { by_group: "Xanomeline High Dose" }
variants:
  post_text: {}
  # The report's in-text Table 12-1: preferred terms reported by at least 5% of
  # subjects in any arm, listed flat in title case, an asterisk on an active arm
  # whose placebo comparison has p < 0.15.
  in_text:
    title: "Most Common AE's (5% Subjects in any Treatment Group)"
    columns:
      order: [Placebo, "Xanomeline Low Dose", "Xanomeline High Dose"]
    format:
      n_pct_sig: "{n} ({p}%){sig}"
      zero_count: "0"
      digits:
        p: 1
    rows:
      - analysis: by_soc_pt
        type: hierarchical
        levels: [AEBODSYS, AEDECOD]
        pattern: n_pct_sig
        inner_only: true
        label_case: title
        sort:
          outer: alpha
          inner: { by_group: "Xanomeline High Dose" }
    filter:
      min_pct: 5
    footnotes:
      - "Preferred terms reported by at least 5% of subjects in at least one treatment group, as the reference report's Table 12-1; an asterisk marks an active-arm incidence whose Fisher's exact comparison with placebo has p < 0.15. The full display, by system organ class, is Section 14."

# Custom statistics for the reference report's adverse-event incidence tables —
# Table 14-5.01 (all treatment-emergent events) and Table 14-5.02 (serious
# ones), which share this file through t-sae-incidence's `custom_from`.
#
# Each row of those tables carries, per arm, the subjects with at least one
# event, the percentage of the arm, and in brackets the number of times the
# event was recorded; and, in two final columns, Fisher's exact test of placebo
# against each active arm on the subject incidence. The built-in
# `hierarchical_count` method gives the first two of those; the event count and
# the tests are this file's. The report prints an asterisk beside a p-value
# under 0.15, ">0.99" for one that rounds to 1, and nothing at all where both
# arms have no subjects with the event — there is no test to run.

`%||%` <- function(x, y) if (is.null(x)) y else x

half_up <- function(x, digits) {
  scale <- 10^digits
  sign(x) * floor(abs(x) * scale * (1 + 2 * .Machine$double.eps) + 0.5) / scale
}

fmt_fisher <- function(p) {
  if (is.na(p)) return("")
  # the report prints a p-value under 0.0005 as 0.000, one that rounds to 1 as
  # >0.99, and drops a trailing zero at the third decimal (0.580 prints as 0.58)
  s <- if (p >= 0.995) ">0.99" else formatC(half_up(p, 3), format = "f", digits = 3)
  if (s != "0.000" && grepl("0{{content}}quot;, s)) s <- sub("0{{content}}quot;, "", s)
  if (p < 0.15) paste0(s, "*") else s
}

arm_levels <- function(denominator, group) {
  g <- denominator[[group]]
  if (is.factor(g)) levels(g) else sort(unique(as.character(g)))
}

# The per-arm statistics for one set of records (a SOC, a PT, or everything).
incidence_stats <- function(records, denominator, group, arms, id) {
  g_den <- as.character(denominator[[group]])
  g_rec <- as.character(records[[group]])
  lapply(arms, function(a) {
    N <- length(unique(denominator[[id]][g_den == a]))
    n <- length(unique(records[[id]][g_rec == a]))
    list(arm = a, N = N, n = n, p = if (N > 0) n / N else NA_real_, events = sum(g_rec == a))
  })
}

# Fisher's exact test of the reference arm against each other arm, on subjects.
fisher_rows <- function(stats, reference) {
  ref <- Filter(function(s) s$arm == reference, stats)[[1]]
  others <- Filter(function(s) s$arm != reference, stats)
  lapply(others, function(s) {
    p <- if (ref$n == 0 && s$n == 0) {
      NA_real_
    } else {
      stats::fisher.test(rbind(c(ref$n, s$n), c(ref$N - ref$n, s$N - s$n)))$p.value
    }
    list(level = paste(reference, "vs.", sub("^Xanomeline ", "", s$arm)), p = p)
  })
}

row_block <- function(stats, tests, variable, variable_level, group, group2 = NA_character_, group2_level = NA_character_, context = "hierarchical") {
  # `sig` is the report's in-text marker (Table 12-1): an asterisk on an active
  # arm whose comparison with placebo has p < 0.15, nothing on placebo itself.
  sig_for <- function(arm) {
    t <- Filter(function(x) endsWith(x$level, sub("^Xanomeline ", "", arm)), tests)
    if (!length(t) || is.na(t[[1]]$p)) "" else if (t[[1]]$p < 0.15) "*" else ""
  }
  arm_rows <- do.call(rbind, lapply(stats, function(s) {
    data.frame(
      group1 = group, group1_level = s$arm, group2 = group2, group2_level = group2_level,
      variable = variable, variable_level = variable_level, context = context,
      stat_name = c("n", "N", "p", "events", "sig"),
      stat_label = c("n", "N", "%", "Events", "Placebo comparison p < 0.15"),
      warning = NA_character_, error = NA_character_, stringsAsFactors = FALSE
    )
  }))
  arm_rows$stat <- unlist(lapply(stats, function(s) list(s$n, s$N, s$p, s$events, sig_for(s$arm))), recursive = FALSE)
  test_rows <- do.call(rbind, lapply(tests, function(t) {
    data.frame(
      group1 = "statistic", group1_level = t$level, group2 = group2, group2_level = group2_level,
      variable = variable, variable_level = variable_level, context = "hypothesis_test",
      stat_name = c("p_value", "p_value_fmt"),
      stat_label = c("Fisher's exact p-value", "Fisher's exact p-value (formatted)"),
      warning = NA_character_, error = NA_character_, stringsAsFactors = FALSE
    )
  }))
  test_rows$stat <- unlist(lapply(tests, function(t) list(t$p, fmt_fisher(t$p))), recursive = FALSE)
  rbind(arm_rows, test_rows)
}

#' The "ANY BODY SYSTEM" row: every record in the analysis data
ard_incidence_any <- function(data, spec, denominator) {
  group <- spec$group
  id <- spec$id %||% "USUBJID"
  arms <- arm_levels(denominator, group)
  stats <- incidence_stats(data, denominator, group, arms, id)
  tests <- fisher_rows(stats, spec$reference_arm %||% arms[[1]])
  row_block(stats, tests, variable = "ANY", variable_level = NA_character_, group = group, context = "subject_count")
}

#' One block per system organ class, then one per preferred term within it
ard_incidence_hierarchy <- function(data, spec, denominator) {
  group <- spec$group
  id <- spec$id %||% "USUBJID"
  hier <- spec$hierarchy
  arms <- arm_levels(denominator, group)
  reference <- spec$reference_arm %||% arms[[1]]
  out <- list()
  for (soc in sort(unique(as.character(data[[hier[1]]])))) {
    in_soc <- data[as.character(data[[hier[1]]]) == soc, , drop = FALSE]
    stats <- incidence_stats(in_soc, denominator, group, arms, id)
    out[[length(out) + 1]] <- row_block(stats, fisher_rows(stats, reference), hier[1], soc, group)
    for (pt in sort(unique(as.character(in_soc[[hier[2]]])))) {
      in_pt <- in_soc[as.character(in_soc[[hier[2]]]) == pt, , drop = FALSE]
      stats <- incidence_stats(in_pt, denominator, group, arms, id)
      out[[length(out) + 1]] <- row_block(stats, fisher_rows(stats, reference), hier[2], pt, group, group2 = hier[1], group2_level = soc)
    }
  }
  do.call(rbind, out)
}