junco coverage - 90.99%

Files
Source

#' @title Create TableTree as DataFrame via gentlg
#'
#' @param tt (`TableTree`)\cr TableTree object to convert to a data frame
#' @param fontspec (`font_spec`)\cr Font specification object
#' @param string_map (`list`)\cr Unicode mapping for special characters
#' @param markup_df (`data.frame`)\cr Data frame containing markup information
#' @param round_type (`character(1)`)\cr the type of rounding to perform.
#' See [formatters::format_value()] for more details.
#' @param validate logical(1). Whether to validate the table structure using
#'   `rtables::validate_table_struct()`. Defaults to `TRUE`. If `FALSE`, a message
#'   will be displayed instead of stopping with an error when validation fails.
#' @return `tt` represented as a `tbl` data.frame suitable for passing
#'   to [tidytlg::gentlg] via the `huxme` argument.
#' @export
tt_to_tbldf <- function(
  tt,
  fontspec = font_spec("Times", 9L, 1),

  string_map = default_str_map,
  markup_df = dps_markup_df,
  round_type = obj_round_type(tt),
  validate = TRUE
) {
  if (validate) {
    if (!validate_table_struct(tt)) {
      stop(
        "Invalid table structure detected. summarize_row_groups without ",
        "analyze below it in layout structure?"
      )
    }
  } else {
    if (!validate_table_struct(tt)) {
      message(
        "Invalid table structure detected. This may cause issues in the output. ",
        "The validation process failed, proceed with caution."
      )
    } else {
      message(
        "Table structure validation succeeded. You should not need to set validate=FALSE."
      )
    }
  }
  mpf <- matrix_form(
    tt,
    indent_rownames = FALSE,
    expand_newlines = FALSE,
    fontspec = fontspec,
    round_type = round_type
  )

  strmat <- mf_strings(mpf)
  strmat[, 1] <- gsub("^[[:space:]]+", "", strmat[, 1])
  nhl <- mf_nlheader(mpf)
  strbody <- strmat[-(1:nhl), , drop = FALSE]
  row_type <- apply(
    strbody,
    1,
    function(x) {
      nonempty <- nzchar(x)
      if (all(!nonempty)) {
        ## shouldn't ever happen
        "EMPTY"
      } else if (nonempty[1] && all(!nonempty[-1])) {
        # only 1st cell nonempty
        "HEADER"
      } else {
        if (x[1] == "N") {
          "N"
        } else {
          "VALUE"
        }
      }
    }
  )
  rowdf <- mf_rinfo(mpf)
  rinds <- mf_lgrouping(mpf)[-(1:nhl)] -
    mf_nrheader(mpf)
  indentme <- rowdf$indent[rinds]
  anbr <- cumsum(!is.na(c(0, utils::head(rowdf$trailing_sep, -1))))[rinds] + 1 ## so it starts at 1
  roworder <- seq_len(NROW(rowdf)) - (anbr - 1)
  newrows <- c(0, ifelse(utils::tail(anbr, -1) == utils::head(anbr, -1), 0, 1))

  strbody <- prep_strs_for_rtf(strbody, string_map, markup_df)
  tbldf <- as.data.frame(strbody)

  names(tbldf) <- c("label", paste("col", seq_len(ncol(tbldf) - 1)))
  emptycols <- tbldf[1, ]
  emptycols[1, ] <- ""

  tbldf <- cbind(
    tbldf,
    data.frame(
      row_type = row_type,
      anbr = anbr,
      indentme = indentme,
      roworder = roworder,
      newrows = newrows,
      stringsAsFactors = FALSE
    )
  )
  tbldf
}


gutter_width <- .12 # inches

## this is for Times New Roman 9
mar_plus_gutters <- 2 + gutter_width

pg_width_by_orient <- function(landscape = FALSE) {
  fullpg <- ifelse(landscape, 11, 8.5)
  fullpg - mar_plus_gutters
}

get_colwidths_as_proportions <- function(colwidths, tlgtype, label_width_ins, pg_width) {
  if (tlgtype == "Table") {
    colwidths <- cwidths_final_adj(
      labwidth_ins = label_width_ins,
      total_width = pg_width,
      colwidths = colwidths[-1]
    )
  }
  colwidths <- colwidths / sum(colwidths)
  if (sum(colwidths) > 1) {
    colwidths <- colwidths - .Machine$double.eps ## much smaller than a twip = 1/20 printing point
  }
  return(colwidths)
}

get_output_csv_filename <- function(output_csv_directory, fpath, fname) {
  if (is.null(output_csv_directory)) {
    output_csv_filename <- file.path(fpath, paste0(tolower(fname), ".csv"))
  } else if (!dir.exists(output_csv_directory)) {
    output_csv_filename <- file.path(fpath, paste0(tolower(fname), ".csv"))
    message("Output dir for csv ", output_csv_directory,
            " does not exist; csv will be saved as ",
            output_csv_filename)
  } else {
    output_csv_filename <- file.path(output_csv_directory,
                                     paste0(tolower(fname), ".csv"))
    message("Saving csv as ", output_csv_filename)
  }
  return(output_csv_filename)
}

tlg_type <- function(tt) {
  if (methods::is(tt, "list") && !methods::is(tt, "listing_df")) {
    tt <- tt[[1]]
  }
  if (methods::is(tt, "ggplot")) {
    ret <- "Figure"
  } else if (methods::is(tt, "VTableTree")) {
    ret <- "Table"
  } else if (methods::is(tt, "listing_df")) {
    ret <- "Listing"
  } else {
    stop(
      "unable to determine tlg type for object of class: ",
      paste(class(tt), collapse = ",")
    )
  }
  ret
}

mpf_to_colspan <- function(
  mpf,
  string_map = default_str_map,
  markup_df = dps_markup_df
) {
  if (!methods::is(mpf, "MatrixPrintForm")) {
    stop("figure out how to make this an mpf (MatrixPrintForm) first.")
  }
  strmat <- mf_strings(mpf)
  ## spaces in column header will get underlines, but we dont' want them to
  nhl <- mf_nlheader(mpf)
  strmat[seq_len(nhl - 1), ] <- gsub(
    "^[[:space:]]+$",
    "",
    strmat[seq_len(nhl - 1), ]
  )
  strmat[nhl, ] <- ifelse(nzchar(strmat[nhl, ]), strmat[nhl, ], " ")
  strmat <- prep_strs_for_rtf(strmat, string_map, markup_df)
  nspancols <- nhl - 1L
  if (nspancols > 0) {
    csph <- lapply(seq_len(nspancols), function(ii) {
      spns <- mf_spans(mpf)[ii, ]
      vals <- strmat[ii, ]
      jj <- 1 ## could start at 2 cause 1 is row label/topleft space but why complicate things
      ind <- 1
      myrle <- rle(vals)
      while (jj < length(vals)) {
        if (myrle$lengths[ind] == 1) {
          jj <- jj + 1
          ind <- ind + 1
        } else {
          sq <- seq(jj, jj + myrle$lengths[ind] - 1)
          valspns <- spns[sq]
          if (valspns[1] != length(sq)) {
            vals[sq] <- split_val_spans(vals[jj], valspns)
          }
          jj <- tail(sq, 1) + 1
          ind <- ind + 1
        }
      }
      vals
    })
  } else {
    csph <- NULL
  }

  list(colspan = csph, colheader = strmat[nhl, ])
}

split_val_spans <- function(val, spns) {
  if (val == "") {
    return(rep(val, length(spns)))
  }
  padvec <- rep("", length(spns))
  j <- 1
  padnum <- 0
  while (j < length(spns)) {
    onespn <- spns[j]
    if (padnum > 0) {
      padvec[j:(j + onespn - 1)] <- strrep(" ", padnum)
    }
    padnum <- padnum + 1
    j <- j + onespn
  }
  paste0(padvec, val, padvec)
}

partmpf_to_colinds <- function(fullmpf, partmpf) {
  stopifnot(
    mf_nlheader(fullmpf) == mf_nlheader(partmpf),
    mf_ncol(fullmpf) >= mf_ncol(partmpf)
  )
  nlh <- mf_nlheader(fullmpf)
  fullhdr <- mf_strings(fullmpf)[1:nlh, , drop = FALSE]
  parthdr <- mf_strings(partmpf)[1:nlh, , drop = FALSE]
  fullkeys <- apply(fullhdr, 2, paste, collapse = "", simplify = TRUE)
  ## hack to force first key to match uniquely
  fullkeys[1] <- paste(c("xxx", fullkeys[-1]), collapse = "")
  stopifnot(length(fullkeys) == length(unique(fullkeys)))
  partkeys <- apply(parthdr, 2, paste, collapse = "", simplify = TRUE)
  partkeys[1] <- fullkeys[1]
  match(partkeys, fullkeys)
}

subset_border_mat <- function(full_brdr, full_mpf, part_mpf) {
  if (is.null(full_brdr)) {
    return(NULL)
  }
  inds <- partmpf_to_colinds(full_mpf, part_mpf)
  full_brdr[, inds, drop = FALSE]
}


get_ncol <- function(tt) {
  if (is(tt, "listing_df") || is(tt, "VTableTree")) {
    ncol(tt)
  } else if (is(tt, "MatrixPrintForm")) {
    mf_ncol(tt)
  } else if (is.list(tt)) {
    if (is(tt[[1]], "MatrixPrintForm")) {
      mf_ncol(tt[[1]])
    } else {
      ncol(tt[[1]])
    }
  }
}

# apply format and round_type to columns of a listing_df object and return as a dataframe
# only for usage as input to gentlg
listingdf_dataframe_formats <- function(df, round_type = obj_round_type(df)) {
  if (!is(df, "listing_df")) {
    return(df)
  } else {
    cols <- listing_dispcols(df)
    df[cols] <- lapply(names(df), function(col) {
      fmt <- obj_format(df[[col]])
      if (!is.null(fmt)) {
        na_str <- obj_na_str(df[[col]])
        lbl <- obj_label(df[[col]])

        df[[col]] <- sapply(df[[col]], FUN = function(x) {
          format_value(x, format = fmt, na_str = na_str, round_type = round_type)
        })

        obj_label(df[[col]]) <- lbl
      }
      df[[col]]
    })
  }

  class(df) <- "data.frame"
  df
}

#' @name tt_to_tlgrtf
#' @title TableTree to .rtf Conversion
#' @description
#' A function to convert TableTree to .rtf
#' @details
#' This function aids in converting the rtables TableTree into the desired .rtf file.
#'
#' @param tt (`TableTree`)\cr TableTree object to convert to RTF
#' @param file (`character(1)`)\cr File to create, including path, but excluding
#' .rtf extension.
#' @param orientation (`character`)\cr Orientation of the output ("portrait" or "landscape")
#' @param colwidths (`numeric` vector)\cr Column widths for the table
#' @param label_width_ins (`numeric`)\cr Label width in inches
#' @param pagenum (`logical`)\cr Whether to add page numbers to the output.
#' Only applicable to listings (i.e. it is ignored for tables and figures).
#' @param fontspec (`font_spec`)\cr Font specification object
#' @param pg_width (`numeric`)\cr Page width in inches
#' @param margins (`numeric` vector)\cr Margins in inches (top, right, bottom, left)
#' @param paginate (`logical`)\cr Whether to paginate the output
#' @param col_gap (`numeric`)\cr Column gap in spaces
#' @param verbose (`logical`)\cr Whether to print verbose output
#' @param tlgtype (`character`)\cr Type of the output (Table, Listing, or Figure)
#' @param string_map (`data.frame`)\cr Unicode mapping for special characters
#' @param markup_df (`data.frame`)\cr Data frame containing markup information
#' @param ... Additional arguments passed to gentlg
#' @inheritParams tidytlg::gentlg
#' @param nosplitin (`list`)\cr list(row=, col=). Path elements whose children should not be paginated within
#' if it can be avoided. e.g., list(col="TRT01A") means don't split within treatment arms unless
#' all the associated columns don't fit on a single page.
#' @param combined_rtf (`logical(1)`)\cr In the case where the result is broken up into multiple
#' parts due to width, should a combined rtf file also be created. Defaults to `FALSE`.
#' @param one_table (`logical(1)`)\cr If `tt` is a (non-`MatrixPrintForm`) list,
#' should the parts be added to the rtf within a single table (`TRUE`, the
#' default) or as separate tables. End users will not generally need to set this.
#' @param border_mat (`matrix`)\cr A `m x k` matrix where m is the number of columns of `tt`
#'  and k is the number of lines the header takes up. See [tidytlg::add_bottom_borders]
#'  for what the matrix should contain. Users should only specify this when the
#'  default behavior does not meet their needs.
#' @param alignments (`list`)\cr List of named lists. Vectorized.
#' (Default = `list()`) Used to specify individual column or cell alignments.
#' Each named list contains `row`, `col`, and `value`, which are passed to
#' [huxtable::set_align()] to set the alignments.
#' @param round_type (`character(1)`)\cr the type of rounding to perform.
#' See [formatters::format_value()] for more details.
#' @param validate (`logical(1)`)\cr Whether to validate the table structure using
#'  `rtables::validate_table_struct()`. Defaults to `TRUE`. If `FALSE`, a message
#'  will be displayed when validation fails.
#' @param export_csv (`logical(1)`)\cr Whether to export the object as a csv representation.
#' Default = FALSE.
#' @param output_csv_directory (`character(1)`)\cr the directory to export the csv.
#' Default = NULL. Ignored if export_csv = FALSE.
#' If NULL or attempting to export in a non-existent directory, the csv will be exported
#' in the same directory as the .rtf file.
#' @import rlistings
#' @rdname tt_to_tlgrtf
#' @export
#' @note `file` should always include path. Path will be extracted
#' and passed separately to `gentlg`.
#' @note When `one_table` is `FALSE`, only the width of the row label
#'   pseudocolumn can be directly controlled due to a limitation in
#'   `tidytlg::gentlg`. The proportion of the full page that the first value
#'   in colwidths would take up is preserved and all other columns equally
#'   split the remaining available width. This will cause, e.g., the
#'   elements within the allparts rtf generated when `combined_rtf` is `TRUE`
#'   to differ visually from the content of the individual part rtfs.
#' @return If `file` is non-NULL, this is called for the side-effect of writing
#'   one or more RTF files. Otherwise, returns a list of `huxtable` objects.
tt_to_tlgrtf <- function(
  tt,
  file = NULL,
  orientation = c("portrait", "landscape"),
  colwidths = def_colwidths(
    tt,
    fontspec,
    col_gap = col_gap,
    label_width_ins = label_width_ins,
    type = tlgtype
  ),
  label_width_ins = 2,
  watermark = NULL,
  pagenum = ifelse(tlgtype == "Listing", TRUE, FALSE),
  fontspec = font_spec("Times", 9L, 1.2),
  pg_width = pg_width_by_orient(orientation == "landscape"),
  margins = c(0, 0, 0, 0),
  paginate = tlg_type(tt) == "Table",
  col_gap = ifelse(tlgtype == "Listing", .5, 3),
  nosplitin = list(
    row = character(),
    col = character()
  ),
  verbose = FALSE,
  tlgtype = tlg_type(tt),
  string_map = default_str_map,
  markup_df = dps_markup_df,
  combined_rtf = FALSE,
  one_table = TRUE,
  border_mat = make_header_bordmat(obj = tt),
  round_type = obj_round_type(tt),
  alignments = list(),
  validate = TRUE,
  export_csv = FALSE,
  output_csv_directory = NULL,
  ...
) {

  checkmate::assert_flag(export_csv)
  checkmate::assert_character(output_csv_directory, null.ok = TRUE, len = 1)

  if (validate && tlgtype == "Table" && methods::is(tt, "VTableTree")) {
    if (!rtables::validate_table_struct(tt)) {
      message(
        "Invalid table structure detected. This may cause issues in the output. ",
        "The validation process failed, proceed with caution."
      )
    }
  } else if (!validate && tlgtype == "Table" && methods::is(tt, "VTableTree")) {
    if (rtables::validate_table_struct(tt)) {
      message(
        "Table structure validation succeeded. You should not need to set validate=FALSE."
      )
    }
  }

  if (tlgtype != "Listing") {
    pagenum <- FALSE
  }
  orientation <- match.arg(orientation)
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }

  if (tlgtype == "Listing" && nrow(tt) == 0) {
    dat <- as.list(c("No data to report", rep("", ncol(tt) - 1)))
    names(dat) <- names(tt)
    df <- as.data.frame(dat)
    var_labels(df) <- var_labels(tt)

    tt <- as_listing(
      df,
      key_cols = get_keycols(tt),
      disp_cols = listing_dispcols(tt),
      main_title = attr(tt, "main_title"),
      main_footer = attr(tt, "main_footer")
    )
  }

  if (tlgtype == "Table" && fontspec$size == 8) {
    opts <- options(
      tidytlg.fontsize.table.footnote = 8,
      tidytlg.fontsize.table = 8
    )
    on.exit(options(opts), add = TRUE)
  }

  if (length(colwidths) == 1) {
    nc <- get_ncol(tt)
    tot_width <- page_lcpp(
      pg_width = pg_width,
      pg_height = 20, # don't care about this,
      font_family = fontspec$family,
      font_size = fontspec$size,
      lineheight = fontspec$lineheight,
      margins = c(0, 0, 0, 0),
      landscape = orientation == "landscape"
    )$cpp
    wdth_left <- tot_width - colwidths
    colwidths <- c(colwidths, rep(floor(wdth_left / nc), nc))
  }

  max_lwidth <- inches_to_spaces(label_width_ins, fontspec)
  if (colwidths[1] > max_lwidth) {
    colwidths[1] <- max_lwidth
  }

  if (!requireNamespace("tidytlg")) {
    stop("tidytlg not installed, cannot go out to rtf.")
  }

  if (paginate) {
    ## implies type Table
    if (tlgtype != "Table") {
      stop(
        "pagination is not currently supported for tlg types other than Table."
      )
    }
    if (methods::is(tt, "VTableTree")) {
      hdrmpf <- matrix_form(tt[1, , keep_topleft = TRUE], round_type = round_type)
    } else if (methods::is(tt, "list") && methods::is(tt[[1]], "MatrixPrintForm")) {
      hdrmpf <- tt[[1]]
    } else {
      hdrmpf <- tt
    }

    pags <- paginate_to_mpfs(
      tt,
      fontspec = fontspec,
      landscape = orientation == "landscape",
      colwidths = colwidths,
      col_gap = col_gap,
      pg_width = pg_width,
      pg_height = NULL,
      margins = margins,
      lpp = NULL,
      nosplitin = nosplitin,
      verbose = verbose,
      round_type = round_type
    ) ##
    if (has_force_pag(tt)) {
      nslices <- which(
        cumsum(vapply(pags, mf_ncol, 1L)) == ncol(tt)
      )
      oldpags <- pags
      pags <- lapply(
        seq_len(nslices),
        function(ii) {
          inds <- seq(ii, by = nslices, length.out = length(oldpags) / nslices)
          oldpags[inds]
        }
      )
    }
    pag_bord_mats <- lapply(
      seq_along(pags),
      function(i) {
        if (methods::is(pags[[i]], "MatrixPrintForm")) {
          partmpf <- pags[[i]]
        } else {
          partmpf <- pags[[i]][[1]]
        }
        subset_border_mat(border_mat, hdrmpf, partmpf)
      }
    )
    ret <- lapply(
      seq_along(pags),
      function(i) {
        if (!is.null(file) && length(pags) > 1) {
          fmti <- paste0("%0", ceiling(log(length(pags), base = 10)), "d")
          fname <- paste0(file, "part", sprintf(fmti, i), "of", length(pags))
        } else {
          fname <- file
        }
        full_pag_i <- pags[[i]]
        if (
          is.list(full_pag_i) &&
            !methods::is(full_pag_i, "MatrixPrintForm")
        ) {
          pgi_for_cw <- full_pag_i[[1]]
        } else {
          pgi_for_cw <- full_pag_i
        }
        tt_to_tlgrtf(
          full_pag_i,
          file = fname,
          orientation = orientation,
          colwidths = formatters::mf_col_widths(pgi_for_cw),
          fontspec = fontspec,
          watermark = watermark,
          col_gap = col_gap,
          paginate = FALSE,
          tlgtype = tlgtype,
          string_map = string_map,
          markup_df = markup_df,
          border_mat = pag_bord_mats[[i]],
          round_type = round_type,
          alignments = alignments,
          export_csv = export_csv,
          output_csv_directory = output_csv_directory,
          label_width_ins = label_width_ins,
          ...
        )
      }
    )
    if (combined_rtf) {
      if (length(pags) > 1) {
        tt_to_tlgrtf(
          pags,
          file = paste0(file, "allparts"),
          orientation = orientation,
          fontspec = fontspec,
          watermark = watermark,
          col_gap = col_gap,
          paginate = FALSE,
          tlgtype = "Table",
          string_map = string_map,
          markup_df = markup_df,
          one_table = FALSE,
          ## gentlg isn't vectorized on column widths so we're SOL here...
          colwidths = colwidths, ## this is largely ignored see note in docs
          # colwidths are already on the pags since they are mpfs
          border_mat = pag_bord_mats,
          round_type = round_type,
          alignments = alignments,
          export_csv = export_csv,
          output_csv_directory = output_csv_directory,
          label_width_ins = label_width_ins,
          ...
        )
      } else if (!is.null(file)) { # only one page after pagination
        message(
          "Table ",
          basename(file),
          ": No combined RTF created, output fit within one part."
        )
      }
    }
    if (is.null(file) && length(pags) > 1) {
      ret <- unlist(ret, recursive = FALSE)
    }
    return(ret)
  }

  if (tlgtype == "Table") {
    if (is.list(tt) && !methods::is(tt, "MatrixPrintForm")) {
      df <- lapply(
        tt,
        tt_to_tbldf,
        fontspec = fontspec,
        string_map = string_map,
        markup_df = markup_df,
        round_type = round_type
      )
      if (one_table) {
        df <- do.call(
          rbind,
          lapply(
            seq_along(df),
            function(ii) {
              dfii <- df[[ii]]
              dfii$newpage <- 0
              if (ii > 1) {
                dfii$newpage[1] <- 1
              }
              dfii$indentme <- ifelse(dfii$indentme <= 1, 0, dfii$indentme - 1)
              dfii
            }
          )
        )
      }
    } else {
      df <- tt_to_tbldf(
        tt,
        fontspec = fontspec,
        string_map = string_map,
        markup_df = markup_df,
        round_type = round_type
      )
    }
  } else {
    df <- tt[, listing_dispcols(tt)]
    # apply formats and round_type and return df as a dataframe to input in gentlg
    df <- listingdf_dataframe_formats(df, round_type = round_type)
  }

  ## we only care about the col labels here...
  if (tlgtype == "Table" && is.list(tt) && !methods::is(tt, "MatrixPrintForm")) {
    mpf <- tt[[1]]
    if (!one_table) {
      colinfo <- lapply(
        tt,
        mpf_to_colspan,
        markup_df = markup_df,
        string_map = string_map
      )
      csph <- lapply(colinfo, function(x) x$colspan)
      colheader <- lapply(colinfo, function(x) x$colheader)
    } else {
      colinfo <- mpf_to_colspan(
        mpf,
        markup_df = markup_df,
        string_map = string_map
      )
      csph <- colinfo$colspan
      colheader <- colinfo$colheader
    }
  } else if (methods::is(tt, "MatrixPrintForm")) {
    mpf <- tt
    colinfo <- mpf_to_colspan(
      mpf,
      markup_df = markup_df,
      string_map = string_map
    )
    csph <- colinfo$colspan
    colheader <- colinfo$colheader
  } else {
    mpf <- matrix_form(
      rtables::head(tt, 1),
      indent_rownames = FALSE,
      expand_newlines = FALSE,
      fontspec = fontspec,
      round_type = round_type
    )
    colinfo <- mpf_to_colspan(
      mpf,
      markup_df = markup_df,
      string_map = string_map
    )
    csph <- colinfo$colspan
    colheader <- colinfo$colheader
  }

  if (is.null(file)) {
    fname <- NULL
    fpath <- tempdir()
  } else {
    fname <- basename(file)
    ## dirname on "table" returns "." so we're good using
    ## this unconditionally as opath
    fpath <- dirname(file)
  }

  if (!one_table && # nolint start
    is.list(tt) && !is(tt, "MatrixPrintForm")) {
    # this should be technically always 1 but just in case
    num_repeated_cols <- ncol(tt[[1]]$strings) - ncol(tt[[1]])
    # the following lines will listify the vector colwidths, this is, convert it
    # to a list of vectors (one vector per page)
    l_colwidths <- list()
    j <- num_repeated_cols + 1
    for (i in seq_along(tt)) {
      subt_col_idxs <- j - 1 + seq(ncol(tt[[i]]))
      colwidths_subt <- colwidths[c(1:num_repeated_cols, subt_col_idxs)]
      ## jump current col position to first column on next page
      j <- tail(subt_col_idxs, 1) + 1
      l_colwidths[[i]] <- get_colwidths_as_proportions(colwidths_subt,
                                                       tlgtype,
                                                       label_width_ins,
                                                       pg_width)
    }
    colwidths <- l_colwidths
  } else {  # nolint end
    colwidths <- get_colwidths_as_proportions(colwidths,
                                              tlgtype,
                                              label_width_ins,
                                              pg_width)
  }


  footer_val <- prep_strs_for_rtf(
    c(
      main_footer(mpf),
      prov_footer(mpf)
    ),
    string_map,
    markup_df
  )
  if (length(footer_val) == 0) {
    footer_val <- NULL
  }

  if (!is.null(fname) && tlgtype == "Table" && is.data.frame(df) && export_csv) {

    output_csv_filename <- get_output_csv_filename(output_csv_directory, fpath, fname)

    utils::write.csv(
      df,
      file = output_csv_filename,
      row.names = FALSE
    )
  }

  tidytlg::gentlg(
    df,
    tlf = tlgtype,
    format = "rtf",
    idvars = if (tlgtype == "Listing") get_keycols(tt) else NULL,
    colspan = csph,
    file = fname,
    opath = fpath,
    colheader = colheader,
    title = prep_strs_for_rtf(
      main_title(mpf),
      string_map,
      markup_df
    ),
    footers = footer_val,
    orientation = orientation,
    wcol = colwidths,
    watermark = watermark,
    pagenum = pagenum,
    bottom_borders = border_mat,
    print.hux = !is.null(fname),
    alignments = alignments,
    footers_one_row = TRUE,
    ...
  )
}

## NB x/(x+sum(colwidths)) = labwidth_ins/total_width
cwidths_final_adj <- function(labwidth_ins, total_width, colwidths) {
  prop <- labwidth_ins / total_width
  lwidth <- floor(prop / (1 - prop) * sum(colwidths))
  c(lwidth, colwidths)
}

make_bordmat_row <- function(rowspns) {
  havespn <- rowspns > 1
  if (!any(havespn)) {
    return(rep(0, times = length(rowspns)))
  }

  pos <- 1
  ngrp <- 1
  ret <- numeric(length(rowspns))
  while (pos < length(rowspns)) {
    spnval <- rowspns[pos]
    if (spnval > 1) {
      multipos <- seq(pos, pos + spnval - 1)
      val <- ngrp
    } else {
      multipos <- pos
      val <- 0
    }
    ret[multipos] <- val
    pos <- pos + spnval
    ngrp <- ngrp + 1
  }
  ret
}

fixup_bord_mat <- function(brdmat, hstrs) {
  ## no lines between labels and their counts
  countcells <- matrix(
    grepl("N=", hstrs, fixed = TRUE),
    nrow = nrow(hstrs),
    ncol = ncol(hstrs)
  )

  countcoords <- which(countcells, arr.ind = TRUE)
  for (i in seq_len(nrow(countcoords))) {
    brdmat[countcoords[i, "row"] - 1, countcoords[i, "col"]] <- 0
  }

  brdmat[!nzchar(hstrs) | hstrs == " "] <- 0
  brdmat[nrow(brdmat), ] <- 1
  brdmat[seq_len(nrow(brdmat) - 1), 1] <- 0
  brdmat
}

.make_header_bordmat <- function(
  obj,
  mpf = matrix_form(utils::head(obj, 1), expand_newlines = FALSE)
) {
  spns <- mf_spans(mpf)
  nlh <- mf_nlheader(mpf)
  nrh <- mf_nrheader(mpf)
  stopifnot(nlh == nrh)

  hstrs <- mf_strings(mpf)[seq_len(nrh), , drop = FALSE]
  spns <- mf_spans(mpf)[seq_len(nrh), , drop = FALSE]

  brdmat <- do.call(
    rbind,
    lapply(
      seq_len(nrh),
      function(i) make_bordmat_row(spns[i, ])
    )
  )

  brdmat <- fixup_bord_mat(brdmat, hstrs)
  brdmat
}

setGeneric(
  "make_header_bordmat",
  function(obj,
           mpf = matrix_form(utils::head(obj, 1), expand_newlines = FALSE)) {
    standardGeneric("make_header_bordmat")
  }
)

setMethod(
  "make_header_bordmat",
  c(obj = "ANY", mpf = "MatrixPrintForm"),
  .make_header_bordmat
)

setMethod(
  "make_header_bordmat",
  c(obj = "listing_df"),
  function(obj, mpf) matrix(1, nrow = 1, ncol = length(listing_dispcols(obj)))
)

setMethod(
  "make_header_bordmat",
  c(obj = "VTableTree", mpf = "missing"),
  function(obj, mpf) {
    make_header_bordmat(
      mpf = matrix_form(
        utils::head(obj, 1),
        expand_newlines = FALSE
      )
    )
  }
)

# Proportion Difference ----

#' @name proportion_diff_mf
#'
#' @title Proportion Difference with Method Selection Based on the Mantel-Fleiss
#'   Criterion
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Performs an adaptive analysis of the difference in response proportions
#' between a non-reference group and a reference group for stratified data, with
#' the method selected based on the Mantel-Fleiss (MF) criterion.
#'
#' When the Mantel-Fleiss criterion is satisfied, a Cochran-Mantel-Haenszel
#' (CMH) analysis is performed using the method specified by `mf_method`.
#' When the criterion is not satisfied, an unconditional exact method is used
#' instead.
#'
#' @details
#' The data are prepared by [tern::h_prepare_rsp_table()], which constructs the
#' response vector, group indicator, optional strata variable, and the
#' corresponding 2 x 2 contingency table(s). When multiple strata variables are
#' supplied, the cross-combinations of their levels define the analysis strata.
#'
#' The response variable is converted to a binary response according to `val`.
#' The analysis compares the response proportion in the non-reference group with
#' that in the reference group. The difference is calculated as the
#' non-reference group minus the reference group.
#'
#' When strata are provided and the Mantel-Fleiss criterion is satisfied, the
#' selected CMH method [tern::prop_diff_cmh()] is used to obtain the point
#' estimate and confidence interval for the difference in response proportions.
#' The available Cochran-Mantel-Haenszel-type methods for estimating the
#' difference in response proportions and its confidence interval are:
#'
#' * `"cmh"`: CMH method.
#' * `"cmh_sato"`: CMH method using the Sato variance estimator.
#' * `"cmh_mn"`: CMH method using the Miettinen-Nurminen method.
#'
#' See [tern::prop_diff_cmh()] for more details and references.
#'
#' When strata are not specified, or when strata are specified but the
#' Mantel-Fleiss criterion is not satisfied or cannot be evaluated (e.g., when
#' all strata contain no observed values), the unconditional exact method
#' [tern::prop_diff_uncond_exact()] is used to obtain the point estimate and
#' confidence interval.
#'
#' The Mantel-Fleiss criterion is evaluated using [tern::mantel_fleiss_crit()].
#'
#' The statistics function `s_proportion_diff_mf()` follows the usage and output
#' of [tern::s_proportion_diff()] but removes the `method` argument and selects
#' internally between a Cochran-Mantel-Haenszel-type method and an unconditional
#' exact method based on the Mantel-Fleiss criterion.
#'
#' @inheritParams proposal_argument_convention
#' @param df (`data.frame`) \cr
#'   The data containing all analysis variables for the non-reference group.
#' @param .var (`character(1)`) \cr
#'   The column name in `df` (and, if supplied, `.ref_group`) specifying the
#'   response variable. The response is converted to a logical vector by
#'   comparing its values with `val`. `df[[var]]` (and `.ref_group[[var]]`, if
#'   supplied) must be an atomic vector as defined by
#'   `checkmate::check_atomic_vector()`, of one of the following types:
#'   `logical`, `integer`, `numeric`, or `character`.
#' @param .in_ref_col (`logical(1)` or `NULL`) \cr
#'   Indicates whether the function is being evaluated for the reference
#'   column. Set to `TRUE` for the reference column and to `FALSE` or `NULL`
#'   otherwise.
#'   For the statistics function, `TRUE` or `NULL` results in empty statistics,
#'   while for the analysis function, the result is a `RowsVerticalSection` with
#'   a `NULL` value for all selected statistics.
#' @param .ref_group (`data.frame` or `NULL`) \cr
#'   The data corresponding to the reference group.
#' @param val (`logical(1)` or `integer(1)` or `numeric(1)` or `character(1)`) \cr
#'   The value used to identify the response of interest. An observation is
#'   considered a response of interest when `df[[.var]] == val` (and, if the
#'   the reference group is supplied, `.ref_group[[.var]] == val`).
#'   If `df[[.var]]` is a `factor`, `val` must be a `character` value matching
#'   one of its levels. Otherwise, `val` must have the same class as `df[[.var]]`.
#' @param variables (`list` or `NULL`) \cr
#'   Optional strata variables specified as `list(strata = <strata_vars>)`,
#'   where `<strata_vars>` is a character vector containing column names in
#'   `df` (and, if supplied, `.ref_group`). All specified strata variables
#'   must be factors.
#' @param na.rm (`logical(1)`) \cr
#'   Whether to remove incomplete rows from `df` (and, if supplied, `.ref_group`)
#'   before constructing the response, group, and strata vectors.
#'   Completeness is assessed only for `.var` and the strata columns (if supplied).
#'   If `na.rm = TRUE`, rows containing missing values in any of these columns
#'   are removed. If `na.rm = FALSE`, the function fails if any of these columns
#'   contain missing values, rather than returning results containing `NA`
#'   values.
#'
#'   This argument is passed unchanged to the `complete_cases` argument of
#'   [tern::h_prepare_rsp_table()].
#' @param mf_method (`character(1)`) \cr
#'   The method used for estimating the difference in response proportions and
#'   its confidence interval when strata are provided and the Mantel-Fleiss
#'   criterion is satisfied. Available choices are: `"cmh"`, `"cmh_sato"`, and
#'   `"cmh_mn"`. See **Details** for more information.
#' @param mf_threshold (`numeric(1)` or `NULL`) \cr
#'   Threshold for the Mantel-Fleiss criterion.
#'   If `NULL`, the default from [tern::mantel_fleiss_crit()] is used.
#' @param .stats (`character`) \cr
#'   Statistics to select. Available choices are `"diff"`, `"diff_ci"`, and
#'   `"diff_est_ci"`. This parameter affects only the formatted analysis
#'   function and has no effect on the statistics function.
#' @param .formats (named `character` or `list`) \cr
#'   Formats for the statistics.
#'
#' @seealso [cond_proportion_j()]
#' @order 1
#' @author WW
#' @examples
#' n <- 100 # Number of observations.
#' set.seed(123)
#' dta <- data.frame(
#'   "rsp" = sample(c("Y", "N"), n, TRUE),
#'   "grp" = c(
#'     sample(c("A", "Placebo"), round(n - 0.1 * n), TRUE),
#'     rep("C", round(0.1 * n))
#'   ),
#'   "f1" = sample(c("a1", "a2"), n, TRUE),
#'   "f2" = sample(c("x", "y", "z"), n, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
NULL

#' @describeIn proportion_diff_mf Statistics function estimating the difference
#'   in response proportions and its confidence interval.
#'   When strata variables are provided and the Mantel-Fleiss criterion is
#'   satisfied, the CMH method [tern::prop_diff_cmh()] is used, with the
#'   `diff_se` argument determined by `mf_method`. Otherwise, i.e., when strata
#'   variables are not provided, or when strata variables are provided but the
#'   Mantel-Fleiss criterion is not satisfied or cannot be evaluated,
#'   the unconditional exact method [tern::prop_diff_uncond_exact()] is used.
#'
#' @return
#' * `s_proportion_diff_mf()` returns a list containing:
#'  \describe{
#'    \item{`diff` (`numeric(1)` or `numeric(0)`)}{Point estimate of the
#'    difference in response proportions, or `numeric(0)` when the function is
#'    evaluated for the reference column (`.in_ref_col` is NULL or `.in_ref_col`
#'    is `TRUE`).}
#'    \item{`diff_ci` (`numeric(2)` or `numeric(0)`)}{Confidence interval for
#'    the difference in response proportions, or `numeric(0)` when the function
#'    is evaluated for the reference column (`.in_ref_col` is NULL or
#'    `.in_ref_col` is `TRUE`).}
#'    \item{`diff_est_ci` (`numeric(3)` or `numeric(0)`)}{Point estimate and
#'    confidence interval for the difference in response proportions, or
#'    `numeric(0)` when the function is evaluated for the reference column
#'    (`.in_ref_col` is NULL or `.in_ref_col` is `TRUE`).}
#'    \item{`executed_method` (`character(1)`)}{Name of the method actually used
#'    for the analysis. Takes the value `NA_character_` when the function is
#'    evaluated for the reference column (`.in_ref_col` is `NULL` or
#'    `.in_ref_col` is `TRUE`). Otherwise, identifies the method used:
#'    `"cmh"`, `"cmh_sato"`, `"cmh_mn"`, or `"uncond_exact_diff"`.
#'    Formatted analysis functions can use this value to determine whether an
#'    appropriate footnote should be added.}
#'  }
#'
#' @order 3
#' @export
#' @examples
#' prop_d <- s_proportion_diff_mf(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "Placebo"),
#'   .in_ref_col = FALSE,
#'   val = "Y",
#'   variables = list(strata = c("f1", "f2")),
#'   conf_level = 0.90,
#'   mf_method = "cmh_mn"
#' )
#' prop_d
#'
s_proportion_diff_mf <- function(df,
                                 .var,
                                 .in_ref_col = NULL,
                                 .ref_group = NULL,
                                 val = TRUE,
                                 variables = list(strata = NULL),
                                 na.rm = FALSE,
                                 conf_level = 0.95,
                                 mf_method = c("cmh", "cmh_sato", "cmh_mn"),
                                 mf_threshold = NULL) {
  assert_flag(.in_ref_col, null.ok = TRUE)
  assert_data_frame(.ref_group)
  assert_list(variables)
  assert_flag(na.rm)

  mf_method <- match.arg(mf_method)

  if (is.null(.in_ref_col) || .in_ref_col) {
    y <- list(
      diff = numeric(),
      diff_ci = numeric(),
      diff_est_ci = numeric(),
      executed_method = NA_character_
    )
  } else {
    assert_false(is.null(.ref_group))

    rsp_data <- h_prepare_rsp_table(
      df = df,
      df_ref = .ref_group,
      var = .var,
      val = val,
      strata_vars = variables$strata,
      complete_cases = na.rm
    )

    # Check the Mantel-Fleiss criterion for stratified data.
    is_mf_satisfied <- if (is.null(variables$strata)) {
      warning(
        "No strata variables were supplied; the Mantel-Fleiss criterion ",
        "cannot be checked. Falling back to unconditional exact analysis."
      )
      FALSE
    } else if (is.null(mf_threshold)) {
      # Note: mantel_fleiss_crit() can return NA.
      isTRUE(mantel_fleiss_crit(rsp_data$tbl))
    } else {
      isTRUE(mantel_fleiss_crit(rsp_data$tbl, threshold = mf_threshold))
    }

    y <- if (is_mf_satisfied) {
      executed_method <- mf_method
      diff_se <- switch(mf_method,
        cmh = "standard",
        cmh_sato = "sato",
        cmh_mn = "miettinen_nurminen"
      )
      prop_diff_cmh(
        rsp = rsp_data$rsp,
        grp = rsp_data$grp,
        strata = rsp_data$strata,
        conf_level = conf_level,
        diff_se = diff_se
      )
    } else {
      executed_method <- "uncond_exact_diff"
      prop_diff_uncond_exact(
        rsp = rsp_data$rsp, grp = rsp_data$grp, conf_level = conf_level
      )
    }

    assert_subset(c("diff", "diff_ci"), names(y))
    y <- y[c("diff", "diff_ci")]
    y$diff <- setNames(y$diff * 100, paste0("diff_", executed_method))
    y$diff_ci <- setNames(y$diff_ci * 100, paste0("diff_ci_", executed_method, c("_l", "_u")))
    y$diff_est_ci <- c(y$diff, y$diff_ci)
    y$executed_method <- executed_method
  }

  h_set_labels_prop_diff_mf(y, mf_method = mf_method, conf_level = conf_level)
}

#' @describeIn proportion_diff_mf Formatted analysis function used as `afun`
#'   for the difference in response proportions with method selection based on
#'   the Mantel-Fleiss criterion.
#'
#' @param exact_footnote (`character(1)` or `RefFootnote`) \cr
#'   Footnote used to indicate that the unconditional exact method was actually
#'   used for the analysis.
#'
#' @return
#' * `a_proportion_diff_mf()` returns the corresponding `RowsVerticalSection`
#' object with formatted results.
#'
#' @order 2
#' @export
#' @examples
#' lyt <- basic_table() |>
#'   split_cols_by(var = "grp", ref_group = "Placebo") |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_proportion_diff_mf,
#'     extra_args = list(
#'       val = "Y",
#'       variables = list(strata = c("f1", "f2")),
#'       conf_level = 0.90,
#'       mf_method = "cmh_mn",
#'       .stats = "diff_est_ci"
#'     )
#'   )
#'
#' build_table(lyt, df = dta)
#'
a_proportion_diff_mf <- function(df,
                                 .var,
                                 .in_ref_col = NULL,
                                 .ref_group = NULL,
                                 val = TRUE,
                                 variables = list(strata = NULL),
                                 na.rm = FALSE,
                                 conf_level = 0.95,
                                 mf_method = c("cmh", "cmh_sato", "cmh_mn"),
                                 mf_threshold = NULL,
                                 ...,
                                 .stats = NULL,
                                 .formats = NULL,
                                 .labels = NULL,
                                 .indent_mods = NULL,
                                 exact_footnote = rtables::RefFootnote(
                                   note = tern::d_proportion_diff(
                                     method = "uncond_exact_diff", method_only = TRUE
                                   ),
                                   index = 1L,
                                   symbol = "+"
                                 )) {
  assert_scalar(.var)
  assert_scalar(.in_ref_col, null.ok = TRUE)
  assert_scalar(val)
  assert_scalar(na.rm)
  assert_scalar(conf_level)
  assert_true(
    identical(class(exact_footnote), structure("RefFootnote", package = "rtables")) ||
      test_string(exact_footnote)
  )

  dots_extra_args <- list(...)

  # It supports only default stats, not custom stats.
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_proportion_diff_mf,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .in_ref_col = .in_ref_col,
      .ref_group = list(.ref_group),
      val = val,
      variables = list(variables),
      na.rm = na.rm,
      conf_level = conf_level,
      mf_method = list(mf_method),
      mf_threshold = mf_threshold,
      dots_extra_args
    )
  )

  method <- x_stats$executed_method
  x_stats$executed_method <- NULL

  cell_footnotes <- if (identical(method, "uncond_exact_diff")) { # method can be NA.
    fn <- list(list(exact_footnote))
    setNames(rep(fn, length(x_stats)), names(x_stats))
  } else {
    list(NULL)
  }

  format_stats(
    x_stats,
    method_groups = "proportion_diff",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods,
    .cell_footnotes = cell_footnotes
  )
}

#' @title Helper function to set labels for `s_proportion_diff_mf()` statistics
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Sets descriptive labels on the statistics returned by `s_proportion_diff_mf()`.
#'
#' The label includes the detailed names of the two methods that may be selected
#' according to the Mantel-Fleiss criterion: `mf_method` is selected when the
#' criterion is satisfied, while `non_mf_method` is selected when the criterion
#' is not satisfied or cannot be evaluated.
#'
#' Specifically, the method part of the label has the form
#' `"(mf_method_label / non_mf_method_label)"`, where `mf_method_label` and
#' `non_mf_method_label` are the corresponding detailed method names.
#'
#' @inheritParams proportion_diff_mf conf_level
#' @param y (`list`) \cr
#'   The list of statistics returned by `s_proportion_diff_mf()` for which
#'   labels should be set. Must contain the named elements `"diff"`, `"diff_ci"`,
#'   and `"diff_est_ci"`.
#' @param mf_method (`character(1)`) \cr
#'   The method specified for the Mantel-Fleiss-based analysis.
#'   Available choices are those accepted by the `method` argument of
#'   [tern::d_proportion_diff()].
#' @param non_mf_method (`character(1)`) \cr
#'   The method used when the Mantel-Fleiss criterion is not satisfied or cannot
#'   be evaluated.
#'   Available choices are those accepted by the method argument of
#'   [tern::d_proportion_diff()].
#'
#' @return
#'   The input `y` with descriptive label attributes added to the `"diff"`,
#'   `"diff_ci"`, and `"diff_est_ci"` elements.
#'
#' @keywords internal
h_set_labels_prop_diff_mf <- function(y,
                                      mf_method,
                                      non_mf_method = "uncond_exact_diff",
                                      conf_level) {
  assert_list(y)
  assert_subset(c("diff", "diff_ci", "diff_est_ci"), choices = names(y))

  label_prefix <- "Difference in Response rate (%)"
  mf_method_label <- d_proportion_diff(method = mf_method, method_only = TRUE)
  non_mf_method_label <- d_proportion_diff(method = non_mf_method, method_only = TRUE)
  method_label <- paste0("(", mf_method_label, " / ", non_mf_method_label, ")")

  # Set labels.
  attr(y$diff, "label") <- paste(label_prefix, method_label)
  attr(y$diff_ci, "label") <- paste(
    label_prefix, tern::f_conf_level(conf_level), method_label
  )
  attr(y$diff_est_ci, "label") <- paste(
    label_prefix, "and", tern::f_conf_level(conf_level), method_label
  )
  y
}

# Test Proportion Difference ----

#' @name test_proportion_diff_mf
#'
#' @title Test of Proportion Difference with Method Selection Based on the
#'   Mantel-Fleiss Criterion
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tests the difference in response proportions between a non-reference group
#' and a reference group for stratified data. The test method is selected based
#' on the Mantel-Fleiss (MF) criterion.
#'
#' When the Mantel-Fleiss criterion is satisfied, a Cochran-Mantel-Haenszel
#' (CMH)-type test is performed using the method specified by `mf_method`.
#' When the criterion is not satisfied, Fisher's exact test is used instead.
#'
#' @details
#' The data are prepared by [tern::h_prepare_rsp_table()], which constructs the
#' response vector, group indicator, optional strata variable, and the
#' corresponding 2 x 2 contingency table(s). When multiple strata variables are
#' supplied, the cross-combinations of their levels define the analysis strata.
#'
#' The response variable is converted to a binary response according to `val`.
#' The analysis compares the response proportion in the non-reference group with
#' that in the reference group. The difference is calculated as the
#' non-reference group minus the reference group.
#'
#' When strata are provided and the Mantel-Fleiss criterion is satisfied, the
#' selected CMH test [tern::prop_cmh()] is used to obtain the p-value for the
#' test of the difference in response proportions. The available
#' Cochran-Mantel-Haenszel tests are:
#'
#' * `"cmh"`: Stratified Cochran-Mantel-Haenszel test.
#' * `"cmh_sato"`: Stratified CMH test using the Sato variance estimator.
#' * `"cmh_wh"`: Stratified CMH test using the Wilson-Hilferty transformation.
#'
#' See [tern::prop_cmh()] for more details and references.
#'
#' When strata are not specified, or when strata are specified but the
#' Mantel-Fleiss criterion is not satisfied or cannot be evaluated (e.g., when
#' none of the strata contain any observed values), Fisher's exact test
#' [tern::prop_fisher()] is used instead.
#'
#' The Mantel-Fleiss criterion is evaluated using [tern::mantel_fleiss_crit()].
#'
#' The statistics function `s_test_proportion_diff_mf()` follows the usage and
#' output of [tern::s_test_proportion_diff()] but removes the `method` argument
#' and selects internally between a Cochran-Mantel-Haenszel-type test and
#' Fisher's exact test based on the Mantel-Fleiss criterion.
#'
#' @inheritParams proportion_diff_mf
#' @inheritParams proposal_argument_convention alternative
#' @param mf_method (`character(1)`) \cr
#'   The method used for testing the difference in response proportions when
#'   strata are provided and the Mantel-Fleiss criterion is satisfied.
#'   Available choices are `"cmh"`, `"cmh_sato"`, and `"cmh_wh"`.
#'   See **Details** for more information.
#' @param .stats (character) \cr
#'   Statistics to select. The only available choice is `"pval"`.
#'   This parameter affects only the formatted analysis function and has no
#'   effect on the statistics function.
#'
#' @seealso [proportion_diff_mf], [cond_proportion_j()]
#' @order 1
#' @author WW
#' @examples
#' n <- 100 # Number of observations.
#' set.seed(123)
#' dta <- data.frame(
#'   "rsp" = sample(c("Y", "N"), n, TRUE),
#'   "grp" = c(
#'     sample(c("A", "Placebo"), round(n - 0.1 * n), TRUE),
#'     rep("C", round(0.1 * n))
#'   ),
#'   "f1" = sample(c("a1", "a2"), n, TRUE),
#'   "f2" = sample(c("x", "y", "z"), n, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
NULL

#' @describeIn test_proportion_diff_mf Statistics function testing the
#'   difference in response proportions.
#'   When strata variables are provided and the Mantel-Fleiss criterion is
#'   satisfied, the CMH test [tern::prop_cmh()] is used, with the values of the
#'   `diff_se` and `transform` arguments determined by `mf_method`.
#'   Otherwise, i.e., when strata variables are not provided, or when strata
#'   variables are provided but the Mantel-Fleiss criterion is not satisfied
#'   or cannot be evaluated, Fisher's exact test [tern::prop_fisher()] is used.
#'
#' @return
#'   * `s_test_proportion_diff_mf()` returns a list containing:
#'   \describe{
#'      \item{`pval` (`numeric(1)` or `numeric(0)`)}{P-value from the test, or
#'      `numeric(0)` when the function is evaluated for the reference column
#'      (`.in_ref_col` is NULL or `.in_ref_col` is `TRUE`).}
#'      \item{`executed_method` (`character(1)`)}{Name of the test actually
#'      used for the analysis.
#'      Takes the value `NA_character_` when the function is evaluated for the
#'      reference column (`.in_ref_col` is `NULL` or `.in_ref_col` is `TRUE`).
#'      Otherwise, identifies the method used: `"cmh"`, `"cmh_sato"`, `"cmh_wh"`,
#'      or `"fisher"`.
#'      Formatted analysis functions can use this value to determine whether an
#'      appropriate footnote should be added.}
#'   }
#'
#' @order 3
#' @export
#' @examples
#' test_prop_d <- s_test_proportion_diff_mf(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "Placebo"),
#'   .in_ref_col = FALSE,
#'   val = "Y",
#'   variables = list(strata = c("f1", "f2"))
#' )
#' test_prop_d
#'
s_test_proportion_diff_mf <- function(df,
                                      .var,
                                      .in_ref_col = NULL,
                                      .ref_group = NULL,
                                      val = TRUE,
                                      variables = list(strata = NULL),
                                      na.rm = FALSE,
                                      alternative = c("two.sided", "less", "greater"),
                                      mf_method = c("cmh", "cmh_sato", "cmh_wh"),
                                      mf_threshold = NULL) {
  assert_flag(.in_ref_col, null.ok = TRUE)
  assert_data_frame(.ref_group, null.ok = TRUE)
  assert_list(variables, null.ok = TRUE)
  assert_flag(na.rm)

  mf_method <- match.arg(mf_method)

  if (is.null(.in_ref_col) || .in_ref_col) {
    executed_method <- NA_character_
    pval <- numeric()
  } else {
    assert_false(is.null(.ref_group))

    rsp_data <- h_prepare_rsp_table(
      df = df,
      df_ref = .ref_group,
      var = .var,
      val = val,
      strata_vars = variables$strata,
      complete_cases = na.rm
    )
    tbl <- rsp_data$tbl

    # Check the Mantel-Fleiss criterion for stratified data.
    is_mf_satisfied <- if (is.null(variables$strata)) {
      warning(
        "No strata variables were supplied; the Mantel-Fleiss criterion ",
        "cannot be checked. Falling back to Fisher's exact test."
      )
      FALSE
    } else if (is.null(mf_threshold)) {
      # Note: mantel_fleiss_crit() can return NA.
      isTRUE(mantel_fleiss_crit(rsp_data$tbl))
    } else {
      isTRUE(mantel_fleiss_crit(rsp_data$tbl, threshold = mf_threshold))
    }

    pval <- if (is_mf_satisfied) {
      executed_method <- mf_method
      switch(mf_method,
        cmh = prop_cmh(tbl, alternative = alternative),
        cmh_sato = prop_cmh(tbl, alternative = alternative, diff_se = "sato"),
        cmh_wh = prop_cmh(tbl, alternative = alternative, transform = "wilson_hilferty")
      )
    } else {
      executed_method <- "fisher"
      tbl_unstrat <- margin.table(tbl, 1:2)
      prop_fisher(tbl_unstrat, alternative = alternative)
    }
  }

  # Set labels.
  method_label <- paste0(
    "(",
    d_test_proportion_diff("fisher", method_only = TRUE),
    " / ",
    d_test_proportion_diff(mf_method, alternative, method_only = TRUE),
    ")"
  )

  list(
    pval = formatters::with_label(pval, method_label),
    executed_method = executed_method
  )
}

#' @describeIn test_proportion_diff_mf Formatted analysis function used as `afun`
#'   to test the difference in response proportions, with method selection based
#'   on the Mantel-Fleiss criterion.
#'
#' @return
#' * `a_test_proportion_diff_mf()` returns the corresponding `RowsVerticalSection`
#' object with formatted results.
#'
#' @order 2
#' @export
#' @examples
#' lyt <- basic_table() |>
#'   split_cols_by(var = "grp", ref_group = "Placebo") |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_test_proportion_diff_mf,
#'     extra_args = list(
#'       val = "Y",
#'       variables = list(strata = c("f1", "f2"))
#'     )
#'   )
#'
#' build_table(lyt, df = dta)
#'
a_test_proportion_diff_mf <- function(df,
                                      .var,
                                      .in_ref_col = NULL,
                                      .ref_group = NULL,
                                      val = TRUE,
                                      variables = list(strata = NULL),
                                      na.rm = FALSE,
                                      alternative = c("two.sided", "less", "greater"),
                                      mf_method = c("cmh", "cmh_sato", "cmh_wh"),
                                      mf_threshold = NULL,
                                      ...,
                                      .stats = NULL,
                                      .formats = NULL,
                                      .labels = NULL,
                                      .indent_mods = NULL,
                                      exact_footnote = rtables::RefFootnote(
                                        note = tern::d_test_proportion_diff(
                                          method = "fisher", method_only = TRUE
                                        ),
                                        index = 1L,
                                        symbol = "+"
                                      )) {
  assert_scalar(.var)
  assert_scalar(.in_ref_col, null.ok = TRUE)
  assert_scalar(val)
  assert_scalar(na.rm)
  assert_true(
    identical(class(exact_footnote), structure("RefFootnote", package = "rtables")) ||
      test_string(exact_footnote)
  )

  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_test_proportion_diff_mf,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .in_ref_col = .in_ref_col,
      .ref_group = list(.ref_group),
      val = val,
      variables = list(variables),
      na.rm = na.rm,
      alternative = list(alternative),
      mf_method = list(mf_method),
      mf_threshold = mf_threshold,
      dots_extra_args
    )
  )

  method <- x_stats$executed_method
  x_stats$executed_method <- NULL

  cell_footnotes <- if (identical(method, "fisher")) { # method can be NA.
    fn <- list(list(exact_footnote))
    setNames(rep(fn, length(x_stats)), names(x_stats))
  } else {
    list(NULL)
  }

  format_stats(
    x_stats,
    method_groups = "test_proportion_diff",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods,
    .cell_footnotes = cell_footnotes
  )
}

#' Helpers for Processing Least Square Means
#'
#' @inheritParams fit_mmrm_j
#' @param fit result of model fitting function, e.g. [mmrm::mmrm()] or [stats::lm()].
#' @param averages (`list`)\cr optional named list of visit levels which should be averaged
#'   and reported along side the single visits.
#' @param weights (`string`)\cr argument from [emmeans::emmeans()], 'counterfactual' by default.
#' @param specs (`list`)\cr list of least square means specifications, with
#'   elements `coefs` (coefficient list) and `grid` (corresponding `data.frame`).
#' @param emmeans_res (`list`)\cr initial `emmeans` result from [h_get_emmeans_res()].
#'
#' @name lsmeans_helpers
#' @keywords internal
NULL

#' @describeIn lsmeans_helpers partial matching of a set of `options` to a
#' character vector `x`. Here partial matching means that for each element of `x` we look for the
#' (first) element of `options` which is contained in the element of `x`. Then we return
#' the matched `options` in the same order as `x`.
#' @param options (`character`)\cr vector of options to match against `x`.
#' @param x (`character`)\cr vector of strings to be partially matched with `options`
h_partial_match <- function(options, x) {
  checkmate::assert_character(options)
  checkmate::assert_character(x)

  result <- sapply(x, function(xi) {
    matches <- vapply(
      options,
      function(opt) grepl(opt, xi, fixed = TRUE),
      logical(1)
    )
    options[which(matches)[1L]]
  }, USE.NAMES = FALSE)
  if (anyNA(result)) {
    warning(
      "Some elements of 'x' did not match any of the 'options': ",
      paste(x[is.na(result)], collapse = ", ")
    )
  }
  result
}

#' @describeIn lsmeans_helpers returns a list with
#'   `object` (`emmGrid` object containing `emmeans` results) and `grid`
#'   (`data.frame` containing the (optional) subgroup, arm and the visit variables
#'   together with the sample size `n` for each combination).
h_get_emmeans_res <- function(fit, vars, weights) {
  data_complete <- stats::model.frame(fit)
  checkmate::assert_data_frame(data_complete)
  checkmate::assert_list(vars)

  if (!is.null(vars$subgroup)) {
    checkmate::assert_factor(data_complete[[vars$subgroup]])
  }
  emmeans_object <- emmeans::emmeans(
    fit,
    data = data_complete,
    specs = c(vars$subgroup, vars$visit, vars$arm),
    weights = weights
  )

  # Save grid with renamed number of subjects column.
  visit_arm_grid <- emmeans_object@grid
  wgt_index <- match(".wgt.", names(visit_arm_grid))
  names(visit_arm_grid)[wgt_index] <- "n"
  visit_arm_grid$n <- as.integer(visit_arm_grid$n)

  list(object = emmeans_object, grid = visit_arm_grid)
}

#' @describeIn lsmeans_helpers constructs average of visits specifications.
h_get_average_visit_specs <- function(emmeans_res, vars, averages, fit) {
  visit_grid <- emmeans_res$grid[[vars$visit]]
  model_frame <- stats::model.frame(fit)
  averages_list <- list()
  visit_vec <- n_vec <- c()
  if (!is.null(vars$subgroup)) {
    subgroup_grid <- emmeans_res$grid[[vars$subgroup]]
    subgroup_vec <- c()
  }
  if (!is.null(vars$arm)) {
    arm_grid <- emmeans_res$grid[[vars$arm]]
    arm_vec <- c()
  }
  for (i in seq_along(averages)) {
    average_label <- names(averages)[i]
    visits_average <- averages[[i]]
    checkmate::assert_subset(visits_average, choices = levels(visit_grid))
    which_visits_in_average <- visit_grid %in% visits_average
    average_coefs <- as.integer(which_visits_in_average) / length(visits_average)
    zero_coefs <- numeric(length = length(average_coefs))

    if (is.null(vars$arm) && is.null(vars$subgroup)) {
      averages_list[[average_label]] <- average_coefs
      visit_vec <- c(visit_vec, average_label)
      is_in_subset <- (model_frame[[vars$visit]] %in% visits_average)
      this_n <- length(unique(model_frame[is_in_subset, vars$id]))
      n_vec <- c(n_vec, this_n)
    } else if (is.null(vars$arm) && !is.null(vars$subgroup)) {
      for (this_subgroup in levels(subgroup_grid)) {
        this_coefs <- zero_coefs
        subgroup_average_label <- paste(this_subgroup, average_label, sep = ".")
        which_subgroup <- subgroup_grid == this_subgroup
        which_visits_and_subgroup <- which_visits_in_average & which_subgroup
        this_coefs[which_visits_and_subgroup] <- 1 / sum(which_visits_and_subgroup)
        averages_list[[subgroup_average_label]] <- this_coefs
        subgroup_vec <- c(subgroup_vec, this_subgroup)
        visit_vec <- c(visit_vec, average_label)
        is_in_subset <- (model_frame[[vars$subgroup]] == this_subgroup) &
          (model_frame[[vars$visit]] %in% visits_average)
        this_n <- length(unique(model_frame[is_in_subset, vars$id]))
        n_vec <- c(n_vec, this_n)
      }
    } else if (!is.null(vars$arm) && is.null(vars$subgroup)) {
      for (this_arm in levels(arm_grid)) {
        this_coefs <- zero_coefs
        arm_average_label <- paste(this_arm, average_label, sep = ".")
        which_arm <- arm_grid == this_arm
        this_coefs[which_arm] <- average_coefs[which_arm]
        averages_list[[arm_average_label]] <- this_coefs
        arm_vec <- c(arm_vec, this_arm)
        visit_vec <- c(visit_vec, average_label)
        is_in_subset <- (model_frame[[vars$arm]] == this_arm) & (model_frame[[vars$visit]] %in% visits_average)
        this_n <- length(unique(model_frame[is_in_subset, vars$id]))
        n_vec <- c(n_vec, this_n)
      }
    } else {
      for (this_arm in levels(arm_grid)) {
        for (this_subgroup in levels(subgroup_grid)) {
          this_coefs <- zero_coefs
          arm_subgroup_average_label <- paste(this_subgroup, this_arm, average_label, sep = ".")
          which_arm <- arm_grid == this_arm
          which_subgroup <- subgroup_grid == this_subgroup
          which_visits_and_arm_and_subgroup <- which_visits_in_average & which_arm & which_subgroup
          this_coefs[which_visits_and_arm_and_subgroup] <- 1 / sum(which_visits_and_arm_and_subgroup)
          averages_list[[arm_subgroup_average_label]] <- this_coefs
          arm_vec <- c(arm_vec, this_arm)
          subgroup_vec <- c(subgroup_vec, this_subgroup)
          visit_vec <- c(visit_vec, average_label)
          is_in_subset <- (model_frame[[vars$arm]] == this_arm) &
            (model_frame[[vars$subgroup]] == this_subgroup) &
            (model_frame[[vars$visit]] %in% visits_average)
          this_n <- length(unique(model_frame[is_in_subset, vars$id]))
          n_vec <- c(n_vec, this_n)
        }
      }
    }
  }
  if (is.null(vars$arm) && is.null(vars$subgroup)) {
    averages_grid <- data.frame(visit = visit_vec, n = n_vec)
    names(averages_grid) <- c(vars$visit, "n")
  } else if (!is.null(vars$arm) && is.null(vars$subgroup)) {
    averages_grid <- data.frame(arm = arm_vec, visit = visit_vec, n = n_vec)
    names(averages_grid) <- c(vars$arm, vars$visit, "n")
  } else if (is.null(vars$arm) && !is.null(vars$subgroup)) {
    averages_grid <- data.frame(subgroup = subgroup_vec, visit = visit_vec, n = n_vec)
    names(averages_grid) <- c(vars$subgroup, vars$visit, "n")
  } else {
    averages_grid <- data.frame(subgroup = subgroup_vec, arm = arm_vec, visit = visit_vec, n = n_vec)
    names(averages_grid) <- c(vars$subgroup, vars$arm, vars$visit, "n")
  }
  list(coefs = averages_list, grid = averages_grid)
}

#' @describeIn lsmeans_helpers estimates least square means as a `data.frame`
#'   given specifications.
#'
#' @note The difference here compared to the original tern.mmrm::h_get_spec_visit_estimates()
#'   function is that additional arguments for [emmeans::contrast()] can be passed via the
#'   dots (`...`) argument.
#'   Once this has been added to the `tern.mmrm` package then its functions can be used instead.
#'
#' @param tests (`flag`)\cr whether to add test results to the estimates.
#' @param ... additional arguments for [emmeans::contrast()].
h_get_spec_visit_estimates <- function(emmeans_res, specs, conf_level, tests = FALSE, ...) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_list(specs)
  checkmate::assert_number(conf_level)
  checkmate::assert_flag(tests)

  conts <- emmeans::contrast(emmeans_res$object, specs$coefs, ...)
  cis <- stats::confint(conts, level = conf_level)
  res <- cbind(
    specs$grid,
    data.frame(estimate = cis$estimate, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL)
  )
  if (tests) {
    conts_df <- as.data.frame(conts)
    res$t_stat <- conts_df$t.ratio
    res$p_value <- conts_df$p.value
    res$p_value_less <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = TRUE)
    res$p_value_greater <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = FALSE)
  }
  res
}

#' @describeIn lsmeans_helpers estimates least square means for single visits.
h_get_single_visit_estimates <- function(emmeans_res, conf_level) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_number(conf_level)

  cis <- stats::confint(emmeans_res$object, level = conf_level)
  cbind(
    emmeans_res$grid[, setdiff(names(emmeans_res$grid), "n"), drop = FALSE],
    data.frame(estimate = cis$emmean, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL),
    emmeans_res$grid[, "n", drop = FALSE]
  )
}

#' @describeIn lsmeans_helpers constructs `data.frame` with
#'   relative reduction vs. reference arm based on single visit estimates.
#' @param estimates (`data.frame`)\cr single visit least square mean estimates.
h_get_relative_reduc_df <- function(estimates, vars) {
  checkmate::assert_data_frame(estimates)
  checkmate::assert_list(vars)

  ref_arm_level <- estimates[[vars$arm]][1L]
  ref_estimates <- estimates[estimates[[vars$arm]] == ref_arm_level, c(vars$subgroup, vars$visit, "estimate")]
  names(ref_estimates)[names(ref_estimates) == "estimate"] <- "ref"
  result <- merge(
    estimates[estimates[[vars$arm]] != ref_arm_level, ],
    ref_estimates,
    by = c(vars$subgroup, vars$visit),
    sort = FALSE
  )
  result$relative_reduc <- (result$ref - result$estimate) / result$ref
  result[, c(vars$subgroup, vars$visit, vars$arm, "relative_reduc")]
}

#' @describeIn lsmeans_helpers constructs single visit contrast specifications.
h_single_visit_contrast_specs <- function(emmeans_res, vars) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_list(vars)

  emmeans_res$grid$index <- seq_len(nrow(emmeans_res$grid))

  grid_by_subgroup_visit <- split(emmeans_res$grid, emmeans_res$grid[c(vars$subgroup, vars$visit)])

  arm_levels <- emmeans_res$object@levels[[vars$arm]]
  visit_levels <- emmeans_res$object@levels[[vars$visit]]
  if (!is.null(vars$subgroup)) {
    subgroup_levels <- emmeans_res$object@levels[[vars$subgroup]]
  }
  ref_arm_level <- arm_levels[1L]
  zeros_coefs <- numeric(nrow(emmeans_res$grid))
  overall_list <- list()
  arm_vec <- visit_vec <- subgroup_vec <- c()
  for (j in seq_along(grid_by_subgroup_visit)) {
    this_grid <- grid_by_subgroup_visit[[j]]
    ref_index <- which(this_grid[[vars$arm]] == ref_arm_level)
    this_visit <- as.character(unique(this_grid[[vars$visit]]))
    checkmate::assert_true(length(this_visit) == 1L)
    if (!is.null(vars$subgroup)) {
      this_subgroup <- as.character(unique(this_grid[[vars$subgroup]]))
      checkmate::assert_true(length(this_subgroup) == 1L)
    }
    this_ref_coefs <- zeros_coefs
    this_ref_coefs[this_grid$index[ref_index]] <- -1
    this_list <- list()
    for (i in seq_len(nrow(this_grid))[-ref_index]) {
      this_coefs <- this_ref_coefs
      this_coefs[this_grid$index[i]] <- 1
      this_arm <- as.character(this_grid[[vars$arm]][i])
      arm_vec <- c(arm_vec, this_arm)
      visit_vec <- c(visit_vec, this_visit)
      if (!is.null(vars$subgroup)) {
        subgroup_vec <- c(subgroup_vec, this_subgroup)
      }
      this_label <- paste(this_arm, this_visit, sep = ".")
      if (!is.null(vars$subgroup)) {
        this_label <- paste(this_subgroup, this_label, sep = ".")
      }
      this_list[[this_label]] <- this_coefs
    }
    overall_list <- c(overall_list, this_list)
  }

  grid <- data.frame(arm = arm_vec, visit = visit_vec)
  if (!is.null(vars$subgroup)) {
    grid[[vars$subgroup]] <- subgroup_vec
  }
  names(grid) <- c(vars$arm, vars$visit, vars$subgroup)
  list(coefs = overall_list, grid = grid)
}

#' @describeIn lsmeans_helpers constructs average visits contrast specifications,
#'   given the `specs` for single visit contrasts and the averages required.
h_average_visit_contrast_specs <- function(specs, averages, vars) {
  subgroup_arm_visit_grid <- specs$grid
  arm_levels <- unique(subgroup_arm_visit_grid[[vars$arm]])
  if (!is.null(vars$subgroup)) {
    subgroup_levels <- unique(subgroup_arm_visit_grid[[vars$subgroup]])
  }
  subgroup_arm_visit_grid$index <- seq_len(nrow(subgroup_arm_visit_grid))
  grid_by_arm_subgroup <- split(subgroup_arm_visit_grid, subgroup_arm_visit_grid[c(vars$arm, vars$subgroup)])
  overall_list <- list()
  subgroup_vec <- arm_vec <- visit_vec <- c()
  for (j in seq_along(grid_by_arm_subgroup)) {
    this_grid <- grid_by_arm_subgroup[[j]]
    this_arm <- as.character(unique(this_grid[[vars$arm]]))
    checkmate::assert_true(length(this_arm) == 1L)
    if (!is.null(vars$subgroup)) {
      this_subgroup <- as.character(unique(this_grid[[vars$subgroup]]))
      checkmate::assert_true(length(this_subgroup) == 1L)
    }
    for (i in seq_along(averages)) {
      average_label <- names(averages)[i]
      visits_average <- averages[[i]]
      which_visits_in_average <- this_grid[, vars$visit] %in% visits_average
      averaged_indices <- this_grid$index[which_visits_in_average]
      this_comb <- paste(this_arm, average_label, sep = ".")
      if (!is.null(vars$subgroup)) {
        this_comb <- paste(this_subgroup, this_comb, sep = ".")
      }
      averaged_coefs <- colMeans(do.call(rbind, specs$coefs[averaged_indices]))
      overall_list[[this_comb]] <- averaged_coefs
      arm_vec <- c(arm_vec, this_arm)
      if (!is.null(vars$subgroup)) {
        subgroup_vec <- c(subgroup_vec, this_subgroup)
      }
      visit_vec <- c(visit_vec, average_label)
    }
  }

  grid <- data.frame(arm = arm_vec, visit = visit_vec)
  if (!is.null(vars$subgroup)) {
    grid[[vars$subgroup]] <- subgroup_vec
  }
  names(grid) <- c(vars$arm, vars$visit, vars$subgroup)

  list(coefs = overall_list, grid = grid)
}

#' @describeIn lsmeans_helpers Computes multiplicity-adjusted p-values and
#'   confidence intervals for treatment-vs-reference contrasts using `multcomp`.
#'   Returns a `data.frame` with the arm and visit grid columns plus
#'   `p_value`, `p_value_less`, `p_value_greater`, `lower_cl`, and `upper_cl`.
#'
#' @param contrast_df (`numeric`)
#'   Degrees of freedom from the unadjusted contrast estimates, used to derive
#'   a single df for [emmeans::as.glht()].
h_get_mult_adj_estimates <- function(emmeans_res, vars, mult_adj, conf_level, contrast_df) {
  checkmate::assert_list(emmeans_res)
  checkmate::assert_list(vars)
  checkmate::assert_string(mult_adj)
  checkmate::assert_number(conf_level)
  checkmate::assert_numeric(contrast_df)

  emmeans_conts <- emmeans::contrast(
    emmeans_res$object,
    method = "trt.vs.ctrl",
    by = c(vars$subgroup, vars$visit),
    adjust = "none" # To avoid a note below. Does not matter.
  )
  if (!requireNamespace("multcomp", quietly = TRUE)) {
    stop("please install multcomp for multiplicity adjustment")
  }
  glht_type <- switch(mult_adj,
    dunnett = "single-step",
    `step-down-dunnett` = "free"
  )
  glht_test <- multcomp::adjusted(type = glht_type)
  # We need a single df for the as.glht below. We give it explicitly to avoid a message.
  glht_df <- floor(mean(contrast_df, na.rm = TRUE))

  glht_conts_greater <- emmeans::as.glht(emmeans_conts, df = glht_df, alternative = "greater")
  glht_summary_greater <- summary(glht_conts_greater, test = glht_test)
  pvals_greater <- do.call(c, lapply(glht_summary_greater, function(x) x$test$pvalues))

  glht_conts_lower <- emmeans::as.glht(emmeans_conts, df = glht_df, alternative = "less")
  glht_summary_lower <- summary(glht_conts_lower, test = glht_test)
  pvals_lower <- do.call(c, lapply(glht_summary_lower, function(x) x$test$pvalues))

  glht_conts <- emmeans::as.glht(emmeans_conts, df = glht_df, alternative = "two.sided")
  glht_summary <- summary(glht_conts, test = glht_test)
  pvals <- do.call(c, lapply(glht_summary, function(x) x$test$pvalues))

  glht_ci <- stats::confint(glht_conts, level = conf_level)
  glht_ci_matrix <- do.call(rbind, lapply(glht_ci, function(x) x$confint[, c("lwr", "upr")]))

  arm_levels <- emmeans_res$object@levels[[vars$arm]]
  non_ref_arms <- arm_levels[-1L]

  grid <- emmeans_conts@grid
  arm_vec <- h_partial_match(options = non_ref_arms, x = as.character(grid$contrast))
  grid <- cbind(
    arm = arm_vec,
    grid[c(vars$subgroup, vars$visit)]
  )
  names(grid) <- c(vars$arm, vars$subgroup, vars$visit)

  data.frame(
    grid,
    p_value = pvals,
    p_value_less = pvals_lower,
    p_value_greater = pvals_greater,
    lower_cl = glht_ci_matrix[, "lwr"],
    upper_cl = glht_ci_matrix[, "upr"],
    row.names = NULL
  )
}

#' Odds ratio estimation
#'
#' @description `r lifecycle::badge('stable')`
#' A set of functions for Odds-Ratio (OR) calculation.
#'
#' @param method (`string`)\cr whether to use the correct (`'exact'`) calculation in the conditional likelihood or one
#'   of the approximations, or the CMH method. See [survival::clogit()] for details.
#'
#' @param df (`data.frame`)\cr input data frame.
#' @param .var (`string`)\cr name of the response variable.
#' @param .df_row (`data.frame`)\cr data frame containing all rows.
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#' @param .ref_group (`data.frame`)\cr reference group data frame.
#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
#' @param variables (`list`)\cr list with arm and strata variable names.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param groups_list (`list`)\cr list of groups for combination.
#'
#' @note
#' The `a_odds_ratio_j()` and `s_odds_ratio_j()` functions have the `_j` suffix to distinguish them
#' from [tern::a_odds_ratio()] and [tern::s_odds_ratio()], respectively.
#' These functions differ as follows:
#'
#' * Additional `method = 'cmh'` option is provided to calculate the Cochran-Mantel-Haenszel estimate.
#' * The p-value is returned as an additional statistic.
#'
#' Once these updates are contributed back to `tern`, they can later be replaced by the `tern` versions.
#'
#' @name odds_ratio
#' @order 1
NULL

#' @describeIn odds_ratio Statistics function which estimates the odds ratio
#'   between a treatment and a control. A `variables` list with `arm` and `strata`
#'   variable names must be passed if a stratified analysis is required.
#'
#' @param na_if_no_events (`flag`)\cr whether the point estimate should be `NA` if there
#'   are no events in one arm. The p-value and confidence interval will still be computed.
#'
#' @return
#' * `s_odds_ratio_j()` returns a named list with the statistics `or_ci`
#'   (containing `est`, `lcl`, and `ucl`), `pval` and `n_tot`.
#'
#' @examples
#' s_odds_ratio_j(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   .df_row = dta
#' )
#'
#' s_odds_ratio_j(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   .df_row = dta,
#'   variables = list(arm = "grp", strata = "strata")
#' )
#'
#' s_odds_ratio_j(
#'   df = subset(dta, grp == "A"),
#'   method = "cmh",
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   .df_row = dta,
#'   variables = list(arm = "grp", strata = c("strata"))
#' )
#' @export
s_odds_ratio_j <- function(
  df,
  .var,
  .ref_group,
  .in_ref_col,
  .df_row,
  variables = list(arm = NULL, strata = NULL),
  conf_level = 0.95,
  groups_list = NULL,
  na_if_no_events = TRUE,
  method = c("exact", "approximate", "efron", "breslow", "cmh")) {
  checkmate::assert_flag(na_if_no_events)
  # New: pval here
  y <- list(or_ci = list(), n_tot = list(), pval = list())
  method <- match.arg(method)
  one_group_empty <- nrow(df) == 0 || nrow(.ref_group) == 0

  if (!.in_ref_col) {
    (assert_proportion_value)(conf_level)
    assert_df_with_variables(df, list(rsp = .var))
    assert_df_with_variables(.ref_group, list(rsp = .var))

    if (one_group_empty) {
      y <- list(or_ci = c(est = NA_real_, lcl = 0, ucl = Inf), n_tot = c(n_tot = nrow(df) + nrow(.ref_group)), pval = 1)
    } else if (is.null(variables$strata)) {
      data <- data.frame(
        rsp = c(.ref_group[[.var]], df[[.var]]),
        grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))
      )
      y <- or_glm_j(data, conf_level = conf_level)
    } else {
      assert_df_with_variables(.df_row, c(list(rsp = .var), variables))
      checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow", "cmh"), empty.ok = FALSE)
      # The group variable prepared for stratified analysis must be synchronized with the combination groups
      # definition.
      if (is.null(groups_list)) {
        ref_grp <- as.character(unique(.ref_group[[variables$arm]]))
        trt_grp <- as.character(unique(df[[variables$arm]]))
        grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)
      } else {
        # If more than one level in reference col.
        reference <- as.character(unique(.ref_group[[variables$arm]]))
        grp_ref_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(reference %in% x))
        ref_grp <- names(groups_list)[grp_ref_flag]

        # If more than one level in treatment col.
        treatment <- as.character(unique(df[[variables$arm]]))
        grp_trt_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(treatment %in% x))
        trt_grp <- names(groups_list)[grp_trt_flag]

        grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)
        grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)
      }

      # New: CMH method
      if (method == "cmh") {
        data <- data.frame(
          rsp = c(.ref_group[[.var]], df[[.var]]),
          grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref")),
          strata = interaction(rbind(.ref_group[variables$strata], df[variables$strata]))
        )

        y <- or_cmh(data, conf_level = conf_level)
      } else {
        # The reference level in `grp` must be the same as in the `rtables` column split.
        data <- data.frame(rsp = .df_row[[.var]], grp = grp, strata = interaction(.df_row[variables$strata]))

        y_all <- or_clogit_j(data, conf_level = conf_level, method = method)
        checkmate::assert_string(trt_grp)
        # New: pval here
        checkmate::assert_subset(trt_grp, names(y_all$or_ci_pvals))
        y_or_ci_pval <- y_all$or_ci_pvals[[trt_grp]]
        y$or_ci <- y_or_ci_pval[c("est", "lcl", "ucl")]
        y$n_tot <- y_all$n_tot
        y$pval <- y_or_ci_pval["pval"]
      }
    }

    one_group_no_events <- (sum(.ref_group[[.var]]) == 0) || (sum(df[[.var]]) == 0)
    if (na_if_no_events && one_group_no_events) {
      y$or_ci[["est"]] <- NA_real_
    }

    na_because_sparse <- one_group_empty || (na_if_no_events && one_group_no_events)
    if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && !na_because_sparse && method != "approximate") {
      warning(
        "Unable to compute the odds ratio estimate. Please try re-running the function with ",
        "parameter `method` set to \"approximate\"."
      )
    }
  }

  y$or_ci <- with_label(x = y$or_ci, label = paste0("Odds Ratio (", 100 * conf_level, "% CI)"))

  # New: pval here
  y$pval <- unname(y$pval)

  y
}

#' @describeIn odds_ratio Formatted analysis function which is used as `afun`. Note that the
#'   junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
#'
#' @return
#' * `a_odds_ratio_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' set.seed(12)
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
#'   strata = factor(sample(c("C", "D"), 100, TRUE))
#' )
#'
#' a_odds_ratio_j(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   ref_path = c("grp", "B"),
#'   .spl_context = data.frame(
#'     cur_col_split = I(list("grp")),
#'     cur_col_split_val = I(list(c(grp = "A"))),
#'     full_parent_df = I(list(dta))
#'   ),
#'   .df_row = dta
#' )
#'
#'
#' l <- basic_table() |>
#'   split_cols_by(var = "grp") |>
#'   analyze(
#'     "rsp",
#'     afun = a_odds_ratio_j,
#'     show_labels = "hidden",
#'     extra_args = list(
#'       ref_path = c("grp", "B"),
#'       .stats = c("or_ci", "pval")
#'     )
#'   )
#'
#' build_table(l, df = dta)
#'
#' l2 <- basic_table() |>
#'   split_cols_by(var = "grp") |>
#'   analyze(
#'     "rsp",
#'     afun = a_odds_ratio_j,
#'     show_labels = "hidden",
#'     extra_args = list(
#'       variables = list(arm = "grp", strata = "strata"),
#'       method = "cmh",
#'       ref_path = c("grp", "A"),
#'       .stats = c("or_ci", "pval")
#'     )
#'   )
#'
#' build_table(l2, df = dta)
#' @export
#' @order 2
a_odds_ratio_j <- function(
  df,
  .var,
  .df_row,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_odds_ratio_j,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .df_row = list(.df_row),
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "odds_ratio",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Helper functions for odds ratio estimation
#'
#' @description `r lifecycle::badge('stable')`
#'
#' Functions to calculate odds ratios in [s_odds_ratio_j()].
#'
#' @inheritParams odds_ratio
#' @inheritParams proposal_argument_convention
#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally
#'   `strata` for [or_clogit_j()].
#' @return A named `list` of elements `or_ci`, `n_tot` and `pval`.
#'
#' @seealso [odds_ratio]
#'
#' @name h_odds_ratio
NULL

#' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be
#'   exactly 2 groups in `data` as specified by the `grp` variable.
#'
#' @examples
#' data <- data.frame(
#'   rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),
#'   grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],
#'   strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],
#'   stringsAsFactors = TRUE
#' )
#'
#' or_glm_j(data, conf_level = 0.95)
#'
#' @export
or_glm_j <- function(data, conf_level) {
  checkmate::assert_logical(data$rsp)
  (assert_proportion_value)(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))

  data$grp <- as_factor_keep_attributes(data$grp)
  assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
  formula <- stats::as.formula("rsp ~ grp")
  model_fit <- stats::glm(formula = formula, data = data, family = stats::binomial(link = "logit"))

  # Note that here we need to discard the intercept.
  or <- exp(stats::coef(model_fit)[-1])
  or_ci <- exp(stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE])

  values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
  n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")

  # New: pval here
  pval <- summary(model_fit)$coef[-1, "Pr(>|z|)"]

  list(or_ci = values, n_tot = n_tot, pval = pval)
}

#' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for
#'   the whole data set including all groups, since the results are not the same as when doing
#'   pairwise comparisons between the groups.
#'
#' @examples
#' data <- data.frame(
#'   rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),
#'   grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],
#'   strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],
#'   stringsAsFactors = TRUE
#' )
#'
#' or_clogit_j(data, conf_level = 0.95)
#'
#' @export
#' @importFrom survival Surv
or_clogit_j <- function(data, conf_level, method = "exact") {
  checkmate::assert_logical(data$rsp)
  (assert_proportion_value)(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
  checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
  checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)

  data$grp <- as_factor_keep_attributes(data$grp)
  data$strata <- as_factor_keep_attributes(data$strata)

  # Deviation from convention: `survival::strata` must be simply `strata`.
  strata <- survival::strata
  formula <- stats::as.formula("rsp ~ grp + strata(strata)")
  model_fit <- clogit_with_tryCatch(
    formula = formula,
    data = data,
    method = method
  )

  # New: pval here

  # Create a list with one set of OR estimates, CI and p-value per coefficient, i.e.  comparison of one group vs. the
  # reference group.
  coef_est <- stats::coef(model_fit)
  ci_est <- stats::confint(model_fit, level = conf_level)
  pvals <- summary(model_fit)$coef[, "Pr(>|z|)", drop = FALSE]
  or_ci_pvals <- list()
  for (coef_name in names(coef_est)) {
    grp_name <- gsub("^grp", "", x = coef_name)
    or_ci_pvals[[grp_name]] <- stats::setNames(
      object = c(exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), pvals[coef_name, 1]),
      nm = c("est", "lcl", "ucl", "pval")
    )
  }
  list(or_ci_pvals = or_ci_pvals, n_tot = c(n_tot = model_fit$n))
}

#' @describeIn h_odds_ratio Estimates the odds ratio based on CMH. Note that there must be
#'   exactly 2 groups in `data` as specified by the `grp` variable.
#'
#' @examples
#' set.seed(123)
#' data <- data.frame(
#'   rsp = as.logical(rbinom(n = 40, size = 1, prob = 0.5)),
#'   grp = letters[sample(1:2, size = 40, replace = TRUE)],
#'   strata = LETTERS[sample(1:2, size = 40, replace = TRUE)],
#'   stringsAsFactors = TRUE
#' )
#'
#' or_cmh(data, conf_level = 0.95)
#'
#' @export
or_cmh <- function(data, conf_level) {
  checkmate::assert_logical(data$rsp)
  assert_proportion_value(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))

  data$grp <- as_factor_keep_attributes(data$grp)
  assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)

  # first dimension: treatment, control - therefore we reverse the levels order 2nd dimension: TRUE, FALSE 3rd
  # dimension: levels of strata rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
  t_tbl <- table(
    factor(data$grp, levels = rev(levels(data$grp))),
    factor(data$rsp, levels = c("TRUE", "FALSE")),
    data$strata
  )

  trt_ind <- 1
  ctrl_ind <- 2

  resp_ind <- 1
  nonresp_ind <- 2

  n1resp <- t_tbl[trt_ind, resp_ind, ]
  n2resp <- t_tbl[ctrl_ind, resp_ind, ]
  n1non <- t_tbl[trt_ind, nonresp_ind, ]
  n2non <- t_tbl[ctrl_ind, nonresp_ind, ]
  # Example: n2non are the control patient non-responders per stratum.

  # CMH statistic for odds ratio, Treatment over Control
  use_stratum <- (n1resp + n2resp + n1non + n2non) > 0
  n1resp <- n1resp[use_stratum]
  n2resp <- n2resp[use_stratum]
  n1non <- n1non[use_stratum]
  n2non <- n2non[use_stratum]
  n <- n1resp + n2resp + n1non + n2non

  or_num <- sum(n1resp * n2non / n)
  or_denom <- sum(n1non * n2resp / n)
  log_or <- log(or_num) - log(or_denom)
  or <- exp(log_or)

  term1_num <- sum((n1resp + n2non) * n1resp * n2non / n^2)
  term1_denom <- 2 * (sum(n1resp * n2non / n))^2

  term2_num <- sum(((n1resp + n2non) * n1non * n2resp + (n1non + n2resp) * n1resp * n2non) / n^2)
  term2_denom <- 2 * (sum(n1resp * n2non / n)) * (sum(n1non * n2resp / n))

  term3_num <- sum((n1non + n2resp) * n1non * n2resp / n^2)
  term3_denom <- 2 * (sum(n1non * n2resp / n))^2

  var_log_or <- term1_num / term1_denom + term2_num / term2_denom + term3_num / term3_denom
  se_log_or <- sqrt(var_log_or)

  z <- stats::qnorm((1 + conf_level) / 2)
  log_rel_or <- log_or + c(-1, +1) * z * se_log_or
  ci <- exp(log_rel_or)
  or_ci <- stats::setNames(c(or, ci), c("est", "lcl", "ucl"))

  pval <- stats::mantelhaen.test(t_tbl, correct = FALSE)$p.value

  n_tot <- stats::setNames(sum(n), "n_tot")

  list(or_ci = or_ci, n_tot = n_tot, pval = pval)
}

#' @name a_freq_j
#'
#' @title Analysis/statistical function for count and percentage in core columns
#' and (optional) relative risk columns
#'
#' @inheritParams proposal_argument_convention
#' @param .var (`character(1)`)\cr Name of a categorical analysis variable in `df`.
#' The variable must be a `factor`.
#' @param val (`character` or NULL)\cr
#' When NULL, all levels of the incoming variable (variable used in the `analyze` call)
#' will be considered.\cr
#' When a single `string`, only that current level/value of the incoming variable
#' will be considered.\cr
#' When multiple levels, only those levels/values of the incoming variable
#' will be considered.\cr
#' When no values are observed (eg zero row input df),
#' a row with row-label `No data to report` will be included in the table.
#' @param drop_levels (`logical`)\cr If `TRUE` non-observed levels
#' (based upon .df_row) will not be included.\cr
#' Cannot be used together with `val`.
#' @param excl_levels (`character` or NULL)\cr
#' When NULL, no levels of the incoming variable (variable used in the `analyze` call)
#' will be excluded.\cr
#' When multiple levels, those levels/values of the incoming variable
#' will be excluded.\cr
#' Cannot be used together with `val`.
#' @param new_levels (list(2) or NULL)\cr List of length 2.\cr
#'     First element : names of the new levels\cr
#'     Second element: list with values of the new levels.\cr
#' @param new_levels_after (`logical`)\cr If `TRUE` new levels will be added after last level.
#' @param denom (`string`)\cr See Details.
#' @param alt_df (`dataframe`)\cr Will be derived based upon alt_df_full and denom_by within a_freq_j.
#' @param parent_df (`dataframe`)\cr Will be derived within a_freq_j based
#' upon the input dataframe that goes into build_table (df) and denom_by.\cr
#' It is a data frame in the higher row-space than the current input df
#' (which underwent row-splitting by the rtables splitting machinery).
#'
#' @param countsource Either `df`, `altdf`, or `altdf_subset`.\cr
#' When `altdf` the counts will be based upon the alternative dataframe `alt_df`.\cr
#' When `altdf_subset` the counts will be based upon `alt_df` but first restricted\cr
#' to the levels/values of the current row split for `.var` (or to `val` when provided).\cr
#' This is useful for subgroup processing,
#' to present counts of subjects in a subgroup from the alternative dataframe.
#'
#' @details
#'
#' `denom` controls the denominator used to calculate proportions/percents.
#' It must be one of \cr
#' \itemize{
#' \item \strong{N_col} Column count, \cr
#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
#' \item \strong{N_colgroup} Number of patients from the column group variable
#' (note that this is based upon the input .alt_df_full dataframe).\cr
#' Note that the argument `colgroup` (column variable) needs to be provided,
#' as it cannot be retrieved directly from the column layout definition.
#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
#' (`.row_df` from the rtables splitting machinery).\cr
#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
#' This higher row-level split is specified in the argument `denom_by`.\cr
#' }
#'
#' @return
#' * `s_freq_j`: returns a list of following statistics\cr
#' \itemize{
#' \item n_df
#' \item n_rowdf
#' \item n_parentdf
#' \item n_altdf
#' \item denom
#' \item count
#' \item count_unique
#' \item count_unique_fraction
#' \item count_unique_denom_fraction
#' \item unique_fraction
#' }
#'
#' @export
#' @importFrom stats setNames
s_freq_j <- function(
  df,
  .var,
  .df_row,
  val = NULL,
  drop_levels = FALSE,
  excl_levels = NULL,
  alt_df,
  parent_df,
  id = "USUBJID",
  denom = c("n_df", "n_altdf", "N_col", "n_rowdf", "n_parentdf"),
  .N_col,
  countsource = c("df", "altdf", "altdf_subset")
) {
  if (is.na(.var) || is.null(.var)) {
    stop("Argument .var cannot be NA or NULL.")
  }

  checkmate::assert_string(.var)
  checkmate::assert_string(id)
  checkmate::assert_subset(id, colnames(df), empty.ok = FALSE)

  countsource <- match.arg(countsource)

  if (countsource %in% c("altdf", "altdf_subset")) {
    df <- alt_df
  }

  checkmate::assert_names(names(df), must.include = .var)
  checkmate::assert_class(df[[.var]], classes = "factor")

  .alt_df <- alt_df

  n1 <- length(unique(.alt_df[[id]]))
  n2 <- length(unique(df[[id]]))

  n3 <- length(unique(.df_row[[id]]))

  if (is.null(parent_df)) {
    parent_df <- df
  }
  n4 <- length(unique(parent_df[[id]]))


  denom <- match.arg(denom) |> switch(
    "n_altdf" = n1,
    "n_df" = n2,
    "n_rowdf" = n3,
    "N_col" = .N_col,
    "n_parentdf" = n4
  )

  y <- list()

  y$n_altdf <- c("n_altdf" = n1)
  y$n_df <- c("n_df" = n2)
  y$n_rowdf <- c("n_rowdf" = n3)
  y$n_parentdf <- c("n_parentdf" = n4)
  y$denom <- c("denom" = denom)

  if (drop_levels) {
    obs_levs <- unique(.df_row[[.var]])
    obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)

    if (!is.null(excl_levels)) obs_levs <- setdiff(obs_levs, excl_levels)

    if (!is.null(val)) {
      stop("argument val cannot be used together with drop_levels = TRUE.")
    }
    val <- obs_levs
  }

  if (!is.null(val)) {
    df <- df[df[[.var]] %in% val, ]
    .df_row <- .df_row[.df_row[[.var]] %in% val, ]

    df <- h_update_factor(df, .var, val)
    .df_row <- h_update_factor(.df_row, .var, val)
  }

  if (!is.null(excl_levels) && drop_levels == FALSE) {
    # restrict the levels to the ones specified in val argument
    df <- df[!(df[[.var]] %in% excl_levels), ]
    .df_row <- .df_row[!(.df_row[[.var]] %in% excl_levels), ]

    df <- h_update_factor(df, .var, excl_levels = excl_levels)
    .df_row <- h_update_factor(.df_row, .var, excl_levels = excl_levels)
  }

  x <- df[[.var]]
  x_unique <- unique(df[, c(.var, id)])[[.var]]

  if (identical(levels(df[[.var]]), no_data_to_report_str)) {
    xy <- list()
    nms <- c(
      "count",
      "count_unique",
      "count_unique_fraction",
      "count_unique_denom_fraction",
      "unique_fraction"
    )
    xy <- replicate(length(nms), list(setNames(list(NULL), no_data_to_report_str)))
    names(xy) <- nms
    y <- append(y, xy)
  } else {
    y$count <- lapply(
      as.list(table(x, useNA = "ifany")),
      stats::setNames,
      nm = "count"
    )

    y$count_unique <- lapply(
      as.list(table(x_unique, useNA = "ifany")),
      stats::setNames,
      nm = "count_unique"
    )

    y$count_unique_fraction <- lapply(
      y$count_unique,
      function(x) {
        # Return NA when the denom = 0.
        # The formatting function converts NA values to "-" for display.
        c(x, "p" = ifelse(denom > 0, x / denom, NA))
      }
    )

    y$count_unique_denom_fraction <- lapply(
      y$count_unique,
      function(x) {
        # Return NA when the denom = 0.
        # The formatting function converts NA values to "-" for display.
        c(x, "d" = denom, "p" = ifelse(denom > 0, x / denom, NA))
      }
    )

    y$unique_fraction <- lapply(
      y$count_unique,
      function(x) {
        # Return NA when the denom = 0.
        # The formatting function converts NA values to "-" for display.
        c("p" = ifelse(denom > 0, x / denom, NA_real_))
      }
    )
  }

  return(y)
}

s_risk_diff_levii_j <- function(
  levii,
  df,
  .var,
  ref_df,
  ref_denom_df,
  .in_ref_col,
  curgrp_denom_df,
  id,
  variables,
  conf_level,
  method,
  weights_method
) {
  dfii <- df[df[[.var]] == levii & !is.na(df[[.var]]), ]
  ref_dfii <- ref_df[ref_df[[.var]] == levii & !is.na(ref_df[[.var]]), ]

  # construction of df_val, based upon curgrp_denom_df, dfii
  df_val <- curgrp_denom_df
  df_val$rsp <- FALSE
  # subjects with value levii observed in df TRUE
  df_val$rsp[df_val[[id]] %in% unique(dfii[[id]])] <- TRUE

  # repeat for ref group, based upon ref_denom_df, ref_dfii
  ref_df_val <- ref_denom_df
  ref_df_val$rsp <- FALSE
  # subjects with value levii observed in ref_df TRUE
  ref_df_val$rsp[ref_df_val[[id]] %in% unique(ref_dfii[[id]])] <- TRUE

  res_ci_3d <- tern::s_proportion_diff(
    df = df_val,
    .var = "rsp",
    .ref_group = ref_df_val,
    .in_ref_col = .in_ref_col,
    variables = variables,
    conf_level = conf_level,
    method = method,
    weights_method = weights_method
  )$diff_est_ci
}


s_risk_diff_val_j <- function(
  df,
  .var,
  .df_row,
  ctrl_grp,
  cur_trt_grp,
  trt_var,
  val = NULL,
  drop_levels = FALSE,
  excl_levels = NULL,
  denom_df,
  id = "USUBJID",
  riskdiff = TRUE,
  variables = list(strata = NULL),
  conf_level = 0.95,
  method = c(
    "waldcc",
    "wald",
    "cmh",
    "ha",
    "newcombe",
    "newcombecc",
    "strat_newcombe",
    "strat_newcombecc",
    "cmh_sato",
    "cmh_mn",
    "uncond_exact_diff"
  ),
  weights_method = "cmh"
) {
  if (drop_levels) {
    obs_levs <- unique(.df_row[[.var]])
    obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)

    if (!is.null(excl_levels)) obs_levs <- setdiff(obs_levs, excl_levels)

    if (!is.null(val)) {
      stop("argument val cannot be used together with drop_levels = TRUE, please specify one or the other.")
    }
    val <- obs_levs
  }

  if (!is.null(val)) {
    # restrict the levels to the ones specified in val argument
    df <- df[df[[.var]] %in% val, ]
    .df_row <- .df_row[.df_row[[.var]] %in% val, ]

    df <- h_update_factor(df, .var, val)
    .df_row <- h_update_factor(.df_row, .var, val)
  }

  if (!is.null(excl_levels) && drop_levels == FALSE) {
    # restrict the levels to the ones specified in val argument
    df <- df[!(df[[.var]] %in% excl_levels), ]
    .df_row <- .df_row[!(.df_row[[.var]] %in% excl_levels), ]

    df <- h_update_factor(df, .var, excl_levels = excl_levels)
    .df_row <- h_update_factor(.df_row, .var, excl_levels = excl_levels)
  }

  levs <- levels(df[[.var]])

  if (identical(levs, no_data_to_report_str)) {
    riskdiff <- FALSE
  }
  if (!riskdiff) {
    return(list(rr_ci_3d = setNames(replicate(length(levs), list(NULL)), levs)))
  }
  ### check on denom_df
  if (NROW(denom_df[[id]]) > length(unique(denom_df[[id]]))) {
    stop(
      "\nProblem: a_freq_j \n
           Denominator has multiple records per id. \n
           Please specify colgroup and/or denom_by to refine your denominator for proper risk difference derivation."
    )
  }

  ### are we in reference column?
  .in_ref_col <- (cur_trt_grp == ctrl_grp)

  ### data from reference group - df based
  ref_df <- get_ctrl_subset(.df_row, trt_var = trt_var, ctrl_grp = ctrl_grp)

  ### denominator data from reference group - denom_df based
  ref_denom_df <- get_ctrl_subset(
    denom_df,
    trt_var = trt_var,
    ctrl_grp = ctrl_grp
  )

  # ensure this is unique record per subject
  ref_denom_df <- unique(ref_denom_df[, c(id, variables$strata), drop = FALSE])

  ### denominator data from current group - denom_df based ---
  curgrp_denom_df <- get_ctrl_subset(
    denom_df,
    trt_var = trt_var,
    ctrl_grp = cur_trt_grp
  )

  # ensure this is unique record per subject
  curgrp_denom_df <- unique(curgrp_denom_df[, c(id, variables$strata), drop = FALSE])

  # calculate the stats for each of the levels in levs
  rr_ci_3d <- sapply(
    levs,
    s_risk_diff_levii_j,
    df = df,
    .var = .var,
    ref_df = ref_df,
    ref_denom_df = ref_denom_df,
    .in_ref_col = .in_ref_col,
    curgrp_denom_df = curgrp_denom_df,
    id = id,
    variables = variables,
    conf_level = conf_level,
    method = method,
    weights_method = weights_method,
    USE.NAMES = TRUE,
    simplify = FALSE
  )
  list(rr_ci_3d = rr_ci_3d)
}


#' @name a_freq_j
#'
#'
#' @inheritParams proposal_argument_convention
#' @param .stats (`character`)\cr Statistics to include in the table. May contain one or more of:
#' `"count"`, `"count_unique"`, `"count_unique_fraction"`,
#' `"count_unique_denom_fraction"`, `"unique_fraction"`,
#' `"n_df"`, `"n_altdf"`, `"n_rowdf"`, `"n_parentdf"`, `"denom"`.
#' See Value for the full list of available statistics.
#' @param riskdiff (`logical`)\cr
#' When `TRUE`, risk difference calculations will be performed and
#' presented (if required risk difference column splits are included).\cr
#' When `FALSE`, risk difference columns will remain blank
#' (if required risk difference column splits are included).
#' @param ref_path (`string`)\cr Column path specifications for
#' the control group for the relative risk derivation.
#' @param variables Will be passed onto the risk difference function
#' (internal function s_risk_diff_val_j), which is based upon [tern::s_proportion_diff()].\cr
#' See `?tern::s_proportion_diff` for details.
#' @param method Will be passed onto the risk difference function (internal function s_risk_diff_val_j).\cr
#' @param weights_method Will be passed onto the risk difference function (internal function s_risk_diff_val_j).\cr
#' @param label (`string`)\cr
#' When `val` has length 1,
#' the row label to be shown on the output can be specified using this argument.\cr
#' When `val` is a `character vector`, the `label_map` argument can be specified
#' to control the row-labels.
#' @param labelstr An argument to ensure this function can be used
#' as a `cfun` in a `summarize_row_groups` call.\cr
#' It is recommended not to utilize this argument for other purposes.\cr
#' The label argument could be used instead (if `val` is a single string)\cr
#' An another approach could be to utilize the `label_map` argument
#' to control the row labels of the incoming analysis variable.
#' @param label_fstr (`string`)\cr
#' a sprintf style format string.
#' It can contain up to one `"%s"`, which takes the current split value and
#' generates the row/column label.\cr
#' It will be combined with the `labelstr` argument,
#' when utilizing this function as
#' a `cfun` in a `summarize_row_groups` call.\cr
#' It is recommended not to utilize this argument for other purposes.
#' The label argument could be used instead (if `val` is a single string)\cr
#' @param label_map (`data.frame`)\cr
#' A mapping data frame used to translate levels of the analysis variable(s) into
#' the row labels displayed in the table, optionally conditioned on the nearest row-split.\cr
#'
#' Four types of mappings are supported:
#' \enumerate{
#'   \item Single-variable mapping. Column names: `level`, `label`.
#'   \item Multi-variable mapping. Column names: `var`, `level`, `label`.
#'   \item Conditional-on-row-split mapping. Column names: `<split_var>`, `level`, `label`.
#'   \item Conditional-on-row-split multi-variable mapping. Column names: `<split_var>`, `var`, `level`, `label`.
#' }
#' Here, `<split_var>` is a placeholder for the name of the variable used for the nearest row-split
#' (e.g. `SEX`, `PARAMCD`).\cr
#'
#' **Recommendation**: ensure input variable(s) are of type factor, to avoid the error
#' "got a label map that doesn't provide labels for all values".\cr
#'
#' See examples for more details.
#' @param .alt_df_full (`dataframe`)\cr Denominator dataset
#' for fraction and relative risk calculations.\cr
#' this argument gets populated by the rtables
#' split machinery (see [rtables::additional_fun_params]).
#' @param denom_by (`character`)\cr Variables from row-split
#' to be used in the denominator derivation.\cr
#' This controls both `denom = "n_parentdf"` and `denom = "n_altdf"`.\cr
#' When `denom = "n_altdf"`, the denominator is derived from `.alt_df_full`
#' in combination with `denom_by` argument
#' @param .labels_n (named `character`)\cr
#' String to control row labels for the 'n'-statistics.\cr
#' Only useful when more than one 'n'-statistic is requested (rare situations only).
#' @param .formats (named 'character' or 'list')\cr
#' formats for the statistics.
#' @param extrablankline (`logical`)\cr
#' When `TRUE`, an extra blank line will be added after the last value.\cr
#' Avoid using this in template scripts, use section_div = " " instead (once PR for rtables is available)\cr
#' @param extrablanklineafter (`string`)\cr
#' When the row-label matches the string, an extra blank line will be added after
#' that value.
#' @param restr_columns `character`\cr
#' If not NULL, columns not defined in `restr_columns` will be blanked out.
#' @param colgroup The name of the column group variable that is used as source
#' for denominator calculation.\cr
#' Required to be specified when `denom = "N_colgroup"`.
#' @param addstr2levs string, if not NULL will be appended to the rowlabel for that level,
#' eg to add ",n (percent)" at the end of the rowlabels
#'
#' @examples
#' library(dplyr)
#'
#' adsl <- ex_adsl |> select("USUBJID", "SEX", "ARM")
#' adae <- ex_adae |> select("USUBJID", "AEBODSYS", "AEDECOD")
#' adae[["TRTEMFL"]] <- "Y"
#'
#' trtvar <- "ARM"
#' ctrl_grp <- "B: Placebo"
#' adsl$colspan_trt <- factor(ifelse(adsl[[trtvar]] == ctrl_grp, " ", "Active Study Agent"),
#'   levels = c("Active Study Agent", " ")
#' )
#'
#' adsl$rrisk_header <- "Risk Difference (%) (95% CI)"
#' adsl$rrisk_label <- paste(adsl[[trtvar]], paste("vs", ctrl_grp))
#'
#' adae <- adae |> left_join(adsl)
#'
#' colspan_trt_map <- create_colspan_map(adsl,
#'   non_active_grp = "B: Placebo",
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = trtvar
#' )
#'
#' ref_path <- c("colspan_trt", " ", trtvar, ctrl_grp)
#'
#' lyt <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar, labels_var = "rrisk_label", split_fun = remove_split_levels(ctrl_grp))
#'
#' lyt1 <- lyt |>
#'   analyze("TRTEMFL",
#'     show_labels = "hidden",
#'     afun = a_freq_j,
#'     extra_args = list(
#'       method = "wald",
#'       .stats = c("count_unique_denom_fraction"),
#'       ref_path = ref_path
#'     )
#'   )
#'
#' result1 <- build_table(lyt1, adae, alt_counts_df = adsl)
#'
#' result1
#'
#' x_drug_x <- list(length(unique(subset(adae, adae[[trtvar]] == "A: Drug X")[["USUBJID"]])))
#' N_x_drug_x <- length(unique(subset(adsl, adsl[[trtvar]] == "A: Drug X")[["USUBJID"]]))
#' y_placebo <- list(length(unique(subset(adae, adae[[trtvar]] == ctrl_grp)[["USUBJID"]])))
#' N_y_placebo <- length(unique(subset(adsl, adsl[[trtvar]] == ctrl_grp)[["USUBJID"]]))
#'
#' tern::stat_propdiff_ci(
#'   x = x_drug_x,
#'   N_x = N_x_drug_x,
#'   y = y_placebo,
#'   N_y = N_y_placebo
#' )
#'
#' x_combo <- list(length(unique(subset(adae, adae[[trtvar]] == "C: Combination")[["USUBJID"]])))
#' N_x_combo <- length(unique(subset(adsl, adsl[[trtvar]] == "C: Combination")[["USUBJID"]]))
#'
#' tern::stat_propdiff_ci(
#'   x = x_combo,
#'   N_x = N_x_combo,
#'   y = y_placebo,
#'   N_y = N_y_placebo
#' )
#'
#'
#' extra_args_rr <- list(
#'   denom = "n_altdf",
#'   denom_by = "SEX",
#'   riskdiff = FALSE,
#'   .stats = c("count_unique")
#' )
#'
#' extra_args_rr2 <- list(
#'   denom = "n_altdf",
#'   denom_by = "SEX",
#'   riskdiff = TRUE,
#'   ref_path = ref_path,
#'   method = "wald",
#'   .stats = c("count_unique_denom_fraction"),
#'   na_str = rep("NA", 3)
#' )
#'
#' lyt2 <- basic_table(
#'   top_level_section_div = " ",
#'   colcount_format = "N=xx"
#' ) |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar, show_colcounts = TRUE) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar,
#'     labels_var = "rrisk_label", split_fun = remove_split_levels("B: Placebo"),
#'     show_colcounts = FALSE
#'   ) |>
#'   split_rows_by("SEX", split_fun = drop_split_levels) |>
#'   summarize_row_groups("SEX",
#'     cfun = a_freq_j,
#'     extra_args = append(extra_args_rr, list(label_fstr = "Gender: %s"))
#'   ) |>
#'   split_rows_by("TRTEMFL",
#'     split_fun = keep_split_levels("Y"),
#'     indent_mod = -1L,
#'     section_div = c(" ")
#'   ) |>
#'   summarize_row_groups("TRTEMFL",
#'     cfun = a_freq_j,
#'     extra_args = append(extra_args_rr2, list(
#'       label =
#'         "Subjects with >=1 AE"
#'     ))
#'   ) |>
#'   split_rows_by("AEBODSYS",
#'     split_label = "System Organ Class",
#'     split_fun = trim_levels_in_group("AEDECOD"),
#'     label_pos = "topleft",
#'     section_div = c(" "),
#'     nested = TRUE
#'   ) |>
#'   summarize_row_groups("AEBODSYS",
#'     cfun = a_freq_j,
#'     extra_args = extra_args_rr2
#'   ) |>
#'   analyze("AEDECOD",
#'     afun = a_freq_j,
#'     extra_args = extra_args_rr2
#'   )
#'
#' result2 <- build_table(lyt2, adae, alt_counts_df = adsl)
#'
#' # -------------------------------------------------------------------------
#' # Examples using the label_map argument
#' # -------------------------------------------------------------------------
#'
#' adsl <- ex_adsl |> select("USUBJID", "SEX", "ARM")
#' adae <- ex_adae |> select("USUBJID", "AEBODSYS", "AEDECOD")
#' adae[["TRTEMFL"]] <- "Y"
#'
#' trtvar <- "ARM"
#' adae <- adae |> left_join(adsl)
#'
#' # -------------------------------------------------------------------------
#' # 1. Simple mapping.
#' # Remaps factor levels (value) to custom new labels (label).
#' # -------------------------------------------------------------------------
#'
#' label_map_simple <- data.frame(
#'   value = c("M", "F", "UNDIFFERENTIATED", "U"),
#'   label = c("Male", "Female", "Undifferentiated", "Unknown")
#' )
#'
#' lyt_lmap1 <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by(trtvar) |>
#'   analyze("SEX",
#'     afun = a_freq_j,
#'     extra_args = list(
#'       .stats = "count_unique_fraction",
#'       label_map = label_map_simple
#'     )
#'   )
#'
#' result_lmap1 <- build_table(lyt_lmap1, adsl, alt_counts_df = adsl)
#' result_lmap1
#'
#' # -------------------------------------------------------------------------
#' # 2. Multi-variable mapping.
#' # Useful in situations where multiple Y/N variables can be analyzed in one
#' # [rtables::analyze()] call.
#' # -------------------------------------------------------------------------
#'
#' multi_vars <- c("DTH30FL", "DTHA30FL", "DTHB30FL")
#' adslx <- pharmaverseadamjnj::adsl
#' # ensure the variables are factor with levels Y/N - and variable label is kept
#' adslx <- adslx |>
#'   mutate(across(all_of(multi_vars), \(x) structure(
#'     factor(x, levels = c("Y", "N")),
#'     label = attr(x, "label")
#'   )))
#'
#' map_multi <- data.frame(
#'   var = multi_vars,
#'   value = "Y",
#'   label = c(
#'     "Death <=30D of Last Trt Flag",
#'     "Death >30D from Last Trt Flag",
#'     "Death <=30D of First Trt Flag"
#'   )
#' )
#'
#' lyt_lmap1 <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("ARM") |>
#'   analyze(multi_vars,
#'     afun = a_freq_j,
#'     extra_args = list(
#'       .stats = "count_unique_denom_fraction",
#'       label_map = map_multi,
#'       val = "Y"
#'     ),
#'     show_labels = "hidden"
#'   )
#'
#' result_lmap2 <- build_table(lyt_lmap1, adslx)
#' result_lmap2
#'
#' # -------------------------------------------------------------------------
#' # 3. Conditional-on-row-split mapping.
#' # -------------------------------------------------------------------------
#'
#' map_rowsplit <- data.frame(
#'   SEX = c("M", "F"),
#'   value = c("Y", "Y"),
#'   label = c("Male subjects with >=1 TE AE", "Female subjects with >=1 TE AE")
#' )
#'
#' adsl <- ex_adsl |> select("USUBJID", "ARM", "SEX")
#' adae <- ex_adae |> select("USUBJID", "AEBODSYS", "AEDECOD")
#' adae[["TRTEMFL"]] <- "Y"
#' adae <- adae |> left_join(adsl)
#'
#' lyt_lmap3 <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("ARM") |>
#'   split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M")), child_labels = "hidden") |>
#'   analyze("TRTEMFL",
#'     afun = a_freq_j,
#'     extra_args = list(
#'       .stats = "count_unique_denom_fraction",
#'       label_map = map_rowsplit,
#'       val = "Y"
#'     ),
#'     show_labels = "hidden"
#'   )
#'
#' result_lmap3 <- build_table(lyt_lmap3, adae, alt_counts_df = adsl)
#' result_lmap3
#'
#' # -----------------------------------------------------------------------------------
#' # 4. Conditional-on-row-split multi-variable mapping.
#' # -----------------------------------------------------------------------------------
#' adsl_jnj <- pharmaverseadamjnj::adsl
#' advs_jnj <- pharmaverseadamjnj::advs
#'
#' multi_vars <- c("CRIT1FL", "CRIT2FL", "CRIT3FL")
#'
#' map_multi_rowsplit <- data.frame(
#'   PARAMCD = c(rep("DIABP", 3), rep("SYSBP", 3)),
#'   var = rep(multi_vars, 2),
#'   value = rep("Y", 6),
#'   label = c(
#'     "<50 mmHg and with >20 mmHg decrease from baseline",
#'     ">105 mmHg and with >30 mmHg increase from baseline",
#'     "Diastolic blood pressure<60",
#'     "<90 mmHg and with >30 mmHg decrease from baseline",
#'     ">180 mmHg and with >40 mmHg increase from baseline",
#'     "Systolic blood pressure<90"
#'   )
#' )
#'
#' lyt_lmap4 <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("TRT01A") |>
#'   split_rows_by("PARAMCD", split_fun = keep_split_levels(c("DIABP", "SYSBP"))) |>
#'   analyze(multi_vars,
#'     afun = a_freq_j,
#'     extra_args = list(
#'       .stats = "count_unique_denom_fraction",
#'       label_map = map_multi_rowsplit,
#'       val = "Y"
#'     ),
#'     show_labels = "hidden"
#'   )
#'
#' result_lmap4 <- build_table(lyt_lmap4, advs_jnj, alt_counts_df = adsl_jnj)
#' result_lmap4
#'
#' @return
#' * `a_freq_j`: returns a list of requested statistics with formatted `rtables::CellValue()`.\cr
#' Within the relative risk difference columns, the following stats are blanked out:
#' \itemize{
#' \item any of the n-statistics (n_df, n_altdf, n_parentdf, n_rowdf, denom)
#' \item count
#' \item count_unique
#' }
#' For the others (count_unique_fraction, count_unique_denom_fraction, unique_fraction),
#' the statistic is replaced by the relative risk difference + confidence interval.
#' @export
a_freq_j <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  drop_levels = FALSE,
  excl_levels = NULL,
  new_levels = NULL,
  new_levels_after = FALSE,
  addstr2levs = NULL,
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "N_colgroup", "n_rowdf", "n_parentdf"),
  riskdiff = TRUE,
  ref_path = NULL,
  variables = list(strata = NULL),
  conf_level = 0.95,
  method = c(
    "wald",
    "waldcc",
    "cmh",
    "ha",
    "newcombe",
    "newcombecc",
    "strat_newcombe",
    "strat_newcombecc",
    "cmh_sato",
    "cmh_mn",
    "uncond_exact_diff"
  ),
  weights_method = "cmh",
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats = "count_unique_denom_fraction",
  .formats = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3),
  .labels_n = NULL,
  extrablankline = FALSE,
  extrablanklineafter = NULL,
  restr_columns = NULL,
  colgroup = NULL,
  countsource = c("df", "altdf", "altdf_subset")
) {
  checkmate::assert_string(id)
  checkmate::assert_subset(id, colnames(df), empty.ok = FALSE)
  checkmate::check_character(ref_path, min.len = 2L)
  checkmate::assert_true(length(ref_path) %% 2L == 0L)

  if (riskdiff && !is.null(ref_path) && is.null(.alt_df_full)) {
    stop("In order to get correct numbers in relative risk column, please specify alt_counts_df in build_table.")
  }

  denom <- match.arg(denom)
  method <- match.arg(method)

  if (!is.null(labelstr) && is.na(.var)) {
    stop(
      "Please specify var call to summarize_row_groups when using cfun = a_freq_j, i.e.,\n",
      "summarize_row_groups('varname', cfun = a_freq_j)"
    )
  }

  if (denom == "N_colgroup") {
    if (is.null(colgroup)) {
      stop("Colgroup must be specified when denom = N_colgroup.")
    }

    checkmate::assert_character(colgroup, null.ok = FALSE, max.len = 1)

    if (colgroup == tail(.spl_context$cur_col_split[[1]], 1)) {
      stop(
        "N_colgroup cannot be used when colgroup is lowest column split."
      )
    }
  }

  check_alt_df_full(denom, c("n_altdf", "N_colgroup"), .alt_df_full)

  res_dataprep <- h_a_freq_dataprep(
    df = df,
    labelstr = labelstr,
    .var = .var,
    val = val,
    drop_levels = drop_levels,
    excl_levels = excl_levels,
    new_levels = new_levels,
    new_levels_after = new_levels_after,
    addstr2levs = addstr2levs,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .N_col = .N_col,
    id = id,
    denom = denom,
    variables = variables,
    label = label,
    label_fstr = label_fstr,
    label_map = label_map,
    .alt_df_full = .alt_df_full,
    denom_by = denom_by,
    .stats = .stats,
    countsource = countsource
  )
  # res_dataprep is list with elements
  # df .df_row val
  # drop_levels excl_levels
  # alt_df parentdf new_denomdf
  # .stats
  # make these elements available in current environment
  df <- res_dataprep$df
  .df_row <- res_dataprep$.df_row
  val <- res_dataprep$val
  drop_levels <- res_dataprep$drop_levels
  excl_levels <- res_dataprep$excl_levels
  alt_df <- res_dataprep$alt_df
  parentdf <- res_dataprep$parentdf
  new_denomdf <- res_dataprep$new_denomdf
  .stats <- res_dataprep$.stats

  ## prepare for column based split
  col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (!is.null(colgroup)) {
    colexpr_substr <- h_colexpr_substr(colgroup, .spl_context$cur_col_expr[[1]])

    if (is.null(colexpr_substr)) {
      stop("\n Problem a_freq_j: incorrect colgroup specification.")
    }

    new_denomdf <- subset(.alt_df_full, eval(parse(text = colexpr_substr)))
    .df_row <- subset(.df_row, eval(parse(text = colexpr_substr)))
  }

  if (!inriskdiffcol) {
    if (denom != "N_colgroup" && !is.null(new_denomdf)) {
      ### for this part : perform column split on denominator dataset
      new_denomdf <- subset(new_denomdf, eval(col_expr))
    }
    if (denom == "N_colgroup") {
      denom <- "n_altdf"
    }

    x_stats <- s_freq_j(
      df,
      .var = .var,
      .df_row = .df_row,
      val = val,
      drop_levels = drop_levels,
      excl_levels = excl_levels,
      alt_df = new_denomdf,
      parent_df = new_denomdf,
      id = id,
      denom = denom,
      .N_col = .N_col,
      countsource = countsource
    )
    ## remove relrisk stat from .stats
    .stats_adj <- .stats[!(.stats %in% "rr_ci_3d")]
  } else {
    if (riskdiff && is.null(ref_path)) {
      stop("argument ref_path cannot be NULL.")
    }
    if (denom == "N_colgroup") {
      stop(
        "denom N_colgroup cannot be used in a layout with risk diff columns."
      )
    }
    if (!riskdiff) {
      trt_var <- NULL
      ctrl_grp <- NULL
      cur_trt_grp <- NULL
    } else {
      trt_var <- ref_path[length(ref_path) - 1L]
      ctrl_grp <- ref_path[length(ref_path)]
      stopifnot(ctrl_grp %in% levels(df[[trt_var]]))
      cur_trt_grp <- h_get_cur_trt_grp(trt_var, .spl_context)

      if (!is.null(colgroup) && trt_var == colgroup) {
        stop(
          "\n Problem: a_freq_j: colgroup and treatment variable from ref_path are the same.
             This is not intented for usage with relative risk columns.
             Either remove risk difference columns from layout, set riskdiff = FALSE, or update colgroup."
        )
      }

      new_denomdf <- upd_denom_df_combo(
        new_denomdf,
        trt_var,
        cur_trt_grp,
        .spl_context
      )
    }

    x_stats <- s_risk_diff_val_j(
      df,
      .var = .var,
      .df_row = .df_row,
      val = val,
      drop_levels = drop_levels,
      excl_levels = excl_levels,
      denom_df = new_denomdf,
      id = id,
      riskdiff = riskdiff,
      # treatment/ref group related arguments
      trt_var = trt_var,
      ctrl_grp = ctrl_grp,
      cur_trt_grp = cur_trt_grp,
      # relrisk specific arguments
      variables = variables,
      conf_level = conf_level,
      method = method,
      weights_method = weights_method
    )

    ## this will ensure the following stats will be shown as empty column in relative risk column
    xy <- sapply(
      c(
        "count",
        "count_unique",
        "n_df",
        "n_altdf",
        "n_rowdf",
        "n_parentdf",
        "denom"
      ),
      function(x) {
        stats::setNames(list(x = NULL), x)
      },
      USE.NAMES = TRUE,
      simplify = FALSE
    )
    x_stats <- append(x_stats, xy)

    ## restrict to relrisk stat from .stats
    # when both count_unique_fraction and count_unique_denom_fraction are requested, the rr_ci_3d stat is in here twice
    # this does not seem to introduce a problem, although might not be ideal
    # see further
    .stats_adj <- replace(
      .stats,
      .stats %in%
        c(
          "count_unique_fraction",
          "count_unique_denom_fraction",
          "fraction_count_unique_denom",
          "unique_fraction"
        ),
      "rr_ci_3d"
    )
  }

  res_prepinrows <- h_a_freq_prepinrows(
    x_stats,
    .stats_adj,
    .formats,
    labelstr,
    label_fstr,
    label,
    .indent_mods,
    .labels_n,
    na_str
  )
  # res_prepinrows is list with elements
  # x_stats .formats .labels .indent_mods .format_na_strs
  # make these elements available in current environment
  x_stats <- res_prepinrows$x_stats
  .formats <- res_prepinrows$.formats
  .labels <- res_prepinrows$.labels
  .indent_mods <- res_prepinrows$.indent_mods
  .format_na_strs <- res_prepinrows$.format_na_strs

  ### blank out columns not in restr_columns
  # get column label
  colid_lbl <- utils::tail(
    .spl_context$cur_col_split_val[[NROW(.spl_context)]],
    1
  )
  if (!is.null(restr_columns) && !(tolower(colid_lbl) %in% tolower(restr_columns))) {
    x_stats <- lapply(x_stats, FUN = function(x) {
      NULL
    })
  }

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )

  ### add extra blankline to the end of inrows --- as long as section_div is not working as expected
  # nolint start
  if (!is.null(inrows) && extrablankline ||
    (!is.null(extrablanklineafter) && length(.labels) == 1 && .labels == extrablanklineafter)) {
    inrows <- add_blank_line_rcells(inrows)
  } # nolint end

  return(inrows)
}

#' @describeIn a_freq_j Wrapper for the `afun` which can exclude
#'   row split levels from producing the analysis. These have to be specified in the
#'   `exclude_levels` argument, see `?do_exclude_split` for details.
#' @export
a_freq_j_with_exclude <- function(
  df,
  labelstr = NULL,
  exclude_levels,
  .var = NA,
  .spl_context,
  .df_row,
  .N_col,
  .alt_df_full = NULL,
  .stats = "count_unique_denom_fraction",
  .formats = NULL,
  .indent_mods = NULL,
  .labels_n = NULL,
  ...
) {
  if (do_exclude_split(exclude_levels, .spl_context)) {
    NULL
  } else {
    a_freq_j(
      df = df,
      labelstr = labelstr,
      .var = .var,
      .spl_context = .spl_context,
      .df_row = .df_row,
      .N_col = .N_col,
      .alt_df_full = .alt_df_full,
      .stats = .stats,
      .formats = .formats,
      .indent_mods = .indent_mods,
      .labels_n = .labels_n,
      ...
    )
  }
}

get_all_comp_lvls <- function(colspan_trt_map) {
  nonactlvl <- unique(as.character(colspan_trt_map[[1]]))[2]
  unique(as.character(colspan_trt_map[colspan_trt_map[[1]] == nonactlvl, 2]))
}

get_first_comp_lvl <- function(colspan_trt_map) {
  get_all_comp_lvls(colspan_trt_map)[1]
}

get_comp_path <- function(map, lvl) {
  rw <- map[map[[2]] == lvl, ]
  c(names(map)[1], rw[[1]], names(map)[2], rw[[2]])
}


## ugh. thisisfine.jpg XXX  :( :( :(
##
## this is where we munge treatment names/labels into comparison versions
do_sib_val_surgery <- function(splval, comp_lvl, newexargs, spl, comp_label) {
  expr <- make_subset_expr(spl, splval)
  splval@subset_expression <- expr
  splval@value <- make_comp_name(splval@value, comp_lvl)
  splval@label <- make_comp_name(splval@label, comp_label)
  args <- c(newexargs, splval@extra)
  splval@extra <- args
  splval
}


## do "surgery" on all of the original values to enforce uniqueness and
## correct comparison labels
surgical_suite <- function(orig_ret, comp_lvl, newexargs, spl, combo_map) {
  out <- orig_ret
  comp_label <- get_comp_label(comp_lvl, orig_ret, combo_map)
  out$values <- lapply(
    out$values,
    do_sib_val_surgery,
    comp_lvl = comp_lvl,
    newexargs = newexargs,
    spl = spl,
    comp_label = comp_label
  )
  out$labels <- vapply(out$values, obj_label, "")
  newnms <- vapply(out$values, value_names, "")
  out <- lapply(
    out,
    function(part) {
      names(part) <- newnms
      part
    }
  )
  names(out) <- names(orig_ret)
  out
}

get_comp_label <- function(comp_level, orig_ret, combo_map) {
  if (!is.null(combo_map) && comp_level %in% combo_map$valname) {
    ret <- unique(combo_map$label[combo_map$valname == comp_level])
  } else {
    ind <- which(comp_level == names(orig_ret$values))
    stopifnot(length(ind) == 1)
    ret <- obj_label(orig_ret$values[[ind]])
  }
  ret
}

add_sib_facets <- function(comp_level, colspan_trt_map, combo_map_all) {
  function(ret, spl, .spl_context, fulldf) {
    combo_map <- NULL
    if (!is.null(combo_map_all)) {
      combo_map <- combo_map_all[combo_map_all$comparator_level == comp_level, ]
    }
    comp_path <- get_comp_path(colspan_trt_map, comp_level)
    ret <- insert_subset_exprs(ret, spl, comp_path = comp_path)
    out <- ret
    exargs <- list(ref_path = get_comp_path(colspan_trt_map, comp_level))
    if (NROW(combo_map) > 0) {
      for (i in seq_len(NROW(combo_map))) {
        out <- add_combo_facet(
          combo_map$valname[i],
          combo_map$label[i],
          combo_map$levelcombo[[i]],
          combo_map$exargs[[i]]
        )(
          ret = out,
          spl = spl,
          .spl_context = .spl_context,
          fulldf = fulldf
        )
      } #     }
    }
    out <- surgical_suite(out, comp_level, exargs, spl = spl, combo_map = combo_map_all)
    names(out) <- names(ret)
    out
  }
}

#' Make Multi-comparator Split Function
#'
#' Create a custom splitting function suitable for creating risk
#' difference columns against one or more comparators. This is used
#' within `col_struct_w_risk_diffs`.
#'
#' @param colspan_trt_map (`data.frame`)\cr A data.frame defining the
#'     active and non-active groups of treatment arms, including
#'     combination arms defined in `combo_levels_map`, as returned by
#'     [create_colspan_map()].
#'
#' @param combo_levels_map (`data.frame` or `NULL`)\cr NULL (the
#'     default) or a data.frame indicating combination levels to added
#'     to some or all blocks of comparisons. See Details.
#'
#' @param comp_level_map (`data.frame` or `NULL`)\cr A data.frame with
#'     columns `active` and `comparator` indivating which risk
#'     difference comparisons to include in the column structure, or
#'     `NULL` (the default), indicating all active vs non-active
#'     pairwise comparisons as defined `colspan_trt_map` treatment
#'     groupings.
#'
#' @param .pre `(list)`\cr A list of additional preprocessing
#'     functions to be provided to `make_split_fun`. Defaults to
#'     `list()`.
#'
#' @param .post `(list)`\cr A list of additional post-processing
#'     functions to be provided to `make_split_fun` *after* those
#'     which provide this function's primary multi-comparator
#'     functionality. Defaults to `list()`
#'
#' @return A split function suitable for use in both `split_rows_by`
#'     and `split_cols_by`.
#'
#' @details
#' This split function is intended to create a set of risk difference
#' or similar columns. As such it will automatically exclude the facet
#' for each comparator level (e.g., Placebo vs Placebo) as determined
#' by the last element of each element of `comp_level_paths`.
#'
#' Further control of facets is provided by `comp_level_map`. If
#' `NULL` (the default), all non-control/reference groups will be
#' compared pairwise with all control/reference groups as defined by
#' the grouping in `colspan_trt_map`.
#'
#'  If specified, `comp_level_map` must be a `data.frame` (including
#'  `tbl_df`) with three columns:
#'
#' - `active` - (character) the value to be compared to a reference level,
#' - `comparator` - (character) the level that should be compared against, and
#' - `active_is_combo` - (logical) is the level specified in `active` a virtual combination level.
#' - `comparator_is_combo` - (logical) is the level specified in `comparator` a virtual combination level.
#'
#' If a `data.frame` with only the `active` and `comparator` columns
#' is given for `comp_level_map`, `active_is_combo` and
#' `comparator_is_combo` are inferred from `colspan_trt_map`.
#'
#' If any rows of `comp_level_map` have `active_is_combo == TRUE` or
#' `comparator_is_combo`, the relevant values in those rows *must*
#' also appear in `combo_levels_map` with the correct level for
#' comp_level (or the `select_all_levels` sentinel value which
#' indicates inclusion for all comparators).
#'
#' If specified, `combo_levels_map` must be a `data.frame` (including `tbl_df`)
#' with the following columns:
#'
#' - `valname` - (`character`) The name(s) for the combination level(s),
#' - `label` - (`character`) the label(s) for the combination level(s),
#' - `levelcombo` - (`list` of `character`) the levels of the split
#'   variable to be combined, or `select_all_levels` for all levels,
#' - `exargs` - (`list`) the extra_args values for each combo level. If not
#'   present this will be assumed to be `list()` for all combo levels.
#' - `compare_against` - (`list` of `character`) Optional. The reference level(s) the
#'   combo level should be compared against, or `select_all_levels` for
#'   inclusion against all comparators.
#' - `is_control` - (`logical`) Optional. Is this combination level going
#'   to be used as a reference level (must appear as the last element in
#'   one of `comp_level_paths` if so).
#'
#' When specifying `combo_levels_map` if the `compare_against` column
#' is omitted, comparison against all reference levels will be
#' performed for all combination levels. If `is_control` is omitted,
#' it will be assumed as `FALSE` for all combination levels.
#'
#' Order of combination levels when multiple are present for a single
#' comparator, as well as their position relative to non-combination
#' comparisons, is determined by row order in `combo_levels_map`.
#'
#' Labels and names of comparison columns involving combination levels
#' will be automatically computed in the form of
#' `"<combo level name/label> vs <ref group name>"`. Note currently
#' ref group *name* is always used as it needs to be inferable from
#' `colspan_trt_map`.
#'
#'
#' The comparator reference path is calculated based on
#' `colspan_trt_map` and then added as `ref_path` to the extra_args
#' associated with generated facet. As such, analysis (or content)
#' functions used underneath a split using the generated split
#' function must accept either `ref_path` or `...`.
#'
#' @note It is not currently possible to use a virtual combination
#'     level as a comparator/reference group. If you need this
#'     functionality please contact the maintainers by filing an issue
#'     at https://github.com/johnsonandjohnson/junco/issues
#'
#' @family std_col_struct
#'
#' @export
make_multicomp_splfun <- function(
  colspan_trt_map,
  combo_levels_map = NULL,
  comp_level_map = NULL,
  .pre = list(),
  .post = list()
) {
  colspan_trt_map <- enrich_colspan_map(colspan_trt_map, combo_levels_map)
  if (is.null(comp_level_map)) {
    comp_levels <- get_all_comp_lvls(colspan_trt_map)
  } else {
    comp_levels <- unique(as.character(comp_level_map$comparator))
  }
  if (!is.null(combo_levels_map)) {
    combo_levels_map <- expand_combo_map(combo_levels_map, ref_lvls = comp_levels)
  }

  funlst <- list(
    function(ret, spl, .spl_context, fulldf) {
      sib_sets <- lapply(
        comp_levels,
        function(lvl) {
          sib_fac_fun <- add_sib_facets(
            lvl,
            colspan_trt_map = colspan_trt_map,
            combo_map_all = combo_levels_map
          )
          sib_fac_fun(ret, spl, .spl_context, fulldf)
        }
      )
      out <- lapply(
        names(ret),
        function(nm) {
          unlist(lapply(seq_along(sib_sets), function(ii) sib_sets[[ii]][[nm]]), recursive = FALSE)
        }
      )
      names(out) <- names(ret)
      out
    }
  )

  make_split_fun(
    pre = .pre,
    post = c(
      funlst,
      apply_comp_map(
        splvar = names(colspan_trt_map)[2],
        comp_levels,
        comp_map = comp_level_map,
        combo_map = combo_levels_map
      ),
      .post
    )
  )
}

## add combo levels to colspan map IFF *none*
## are present
enrich_colspan_map <- function(colspan_map, combodf) {
  ## assume if any combo levels are present that the
  ## missing ones are intentional
  if (
    is.null(combodf) ||
      any(combodf$valname %in% colspan_map[[2]])
  ) {
    return(colspan_map)
  }
  combo_levs <- combodf$valname

  if (!("is_control" %in% names(combodf))) {
    combodf$is_control <- FALSE
  }

  ## second one is control spanner
  span_levs <- unique(colspan_map[[1]])

  in_ctrl <- function(spn) spn == span_levs[2]
  subset_combo_lvls <- function(spn) {
    combo_levs[combodf$is_control == in_ctrl(spn)]
  }

  mapspl <- split(colspan_map, colspan_map[[1]])
  rws <- lapply(
    span_levs,
    function(nm) {
      cur_levs <- subset_combo_lvls(nm)
      rbind(
        mapspl[[nm]],
        if (length(cur_levs) > 0) {
          setNames(
            data.frame(nm, subset_combo_lvls(nm)),
            names(colspan_map)
          )
        }
      )
    }
  )

  do.call(rbind, rws)
}


make_comp_name <- function(act_nm, comp_nm) paste0(act_nm, " vs ", comp_nm)

## conversion of names/labels to comparison versions is now
## handled (much) later, in surgical_suite and apply_comp_map
expand_combo_map <- function(combo_map, ref_lvls) {
  if (NROW(combo_map) == 0) {
    return(combo_map)
  }

  if (!("compare_against" %in% names(combo_map))) {
    combo_map$compare_against <- lapply(seq_len(NROW(combo_map)), function(i) select_all_levels)
  }

  rws <- lapply(
    seq_len(NROW(combo_map)),
    function(ii) {
      first_ref <- ref_lvls[1]
      remaining_refs <- ref_lvls[-1]
      mp_rw <- combo_map[ii, ]
      comp_against <- mp_rw$compare_against[[1]]
      if (is.null(comp_against) || is(comp_against, "AllLevelsSentinel")) {
        comp_against <- ref_lvls
      }

      if (mp_rw$valname %in% ref_lvls) {
        mp_rw$compare_against[[1]] <- character()
        mp_rw$comparator_level <- ""
        rws_out <- list(mp_rw)
      } else {
        ## TODO this seems overkill for what is left inside
        ## the lapply, refactor into saner form
        rws_out <- lapply(comp_against, function(cur_ref_lvl) {
          ref_lvl_ind <- match(cur_ref_lvl, ref_lvls)
          cur_rw <- combo_map[ii, ]
          cur_rw$comparator_level <- cur_ref_lvl
          cur_rw
        })
      }

      do.call(rbind.data.frame, rws_out)
    }
  )
  ret <- do.call(rbind.data.frame, rws)
  ## never compare level against itself
  ## needed to (easily) support combo control grps
  ret <- ret[ret$valname != ret$comparator_level, ]
  ret
}


apply_comp_map <- function(splvar, ref_lvls, comp_map, combo_map) {
  function(ret, spl, fulldf, ...) {
    all_lvls <- levels(fulldf[[splvar]])

    if (is.null(comp_map)) {
      comp_map <- make_dflt_comp_map(fulldf, splvar, ref_lvls, combo_map)
    }
    lvls_to_keep <- make_comp_name(comp_map$active, comp_map$comparator)
    restrict_facets(lvls_to_keep, op = "keep")(ret, spl, fulldf)
  }
}

#' @export
#' @rdname make_multicomp_splfun
#' @param df (`data.frame`)\cr Data used to derive the available levels for
#'   the splitting variable `spl_var` and to construct the default comparison
#'   map when `comp_level_map` is not provided.
#' @param spl_var (`character(1)`)\cr Name of the splitting variable (typically
#'   the treatment variable) whose levels define active and comparator groups.
#' @param ref_lvls (`character`)\cr The level names to be treated as reference
#'   (control) groups. Comparisons will be formed against these levels.
#' @param combo_map (`data.frame`)\cr A combination levels map (i.e., the value
#'   passed to `combo_levels_map`) used to include virtual combination levels in
#'   the default comparison map.
#' @return For `make_dflt_comp_map()`, a `data.frame` with columns
#'   `active`, `comparator`, `active_is_combo`, and `comparator_is_combo`,
#'   listing the comparisons to keep and whether either side is a virtual
#'   combination level.
make_dflt_comp_map <- function(df, spl_var, ref_lvls, combo_map) {
  all_lvls <- as.character(levels(df[[spl_var]]))

  non_ref <- setdiff(all_lvls, ref_lvls)
  base_rws <- lapply(
    ref_lvls,
    function(ref_lvl_i) {
      data.frame(active = non_ref, comparator = ref_lvl_i, active_is_combo = FALSE, comparator_is_combo = FALSE)
    }
  )

  if ("is_control" %in% names(combo_map)) {
    act_combo_map <- combo_map[!combo_map$is_control, ]
  } else {
    act_combo_map <- combo_map
  }
  combo_rws <- combodf_to_comp_map(combodf = act_combo_map, ref_lvls = ref_lvls, all_base_lvls = all_lvls)
  ret <- do.call(rbind.data.frame, c(base_rws, list(combo_rws)))

  ret$tmp_fact <- factor(ret$comparator, levels = ref_lvls)
  o <- order(ret$tmp_fact)
  ret <- ret[o, ]
  ret$tmp_fact <- NULL
  ret
}


combodf_to_comp_map <- function(combodf, ref_lvls, all_base_lvls) {
  nrcombo <- NROW(combodf)
  if (nrcombo == 0) {
    return(NULL)
  }

  if (!("is_control" %in% names(combodf))) {
    combodf$is_control <- combodf$valname %in% ref_lvls
  }

  non_ref_lvls <- c(
    setdiff(all_base_lvls, ref_lvls),
    combodf$valname[!combodf$is_control]
  )
  if (!("compare_against" %in% names(combodf))) {
    combodf$compare_against <- ifelse(
      combodf$is_control,
      replicate(nrcombo, list(non_ref_lvls)),
      replicate(nrcombo, list(ref_lvls))
    )
  }

  if (any(combodf$is_control) && !all(combodf$valname[combodf$is_control] %in% ref_lvls)) {
    stop(
      "Combination levels [",
      paste(combodf$valname[combodf$is_control], collapse = ", "),
      "] were listed as control groups in the combination df but are ",
      "missing from specified reference levels"
    )
  }

  rws <- lapply(
    seq_len(nrcombo),
    function(i) {
      cur_rw <- combodf[i, ]
      is_ctrl <- cur_rw$is_control
      comp_against <- cur_rw$compare_against[[1]]
      if (is(comp_against, "AllLevelsSentinel")) {
        if (is_ctrl) {
          comp_against <- non_ref_lvls
        } else {
          comp_against <- ref_lvls
        }
      }
      if (is_ctrl) {
        data.frame(
          active = comp_against,
          comparator = cur_rw$valname,
          active_is_combo = !(comp_against %in% all_base_lvls),
          comparator_is_combo = TRUE
        )
      } else {
        data.frame(
          active = cur_rw$valname,
          comparator = comp_against,
          active_is_combo = TRUE,
          comparator_is_combo = comp_against %in% combodf$valname
        )
      }
    }
  )

  ## if there are combinations acting as both active and reference
  ## levels the comparisons between them will be duplicated
  ret <- do.call(rbind.data.frame, rws)
  dups <- duplicated(ret[, c("active", "comparator")])
  ret[!dups, ]
}


#' Standard Column Structure With Grouped Treatments and Difference Columns
#'
#' @param lyt (`PreDataTableLayouts`). The layout to modify. This
#'     should virtually always be the object returned by
#'     `basic_table`.
#' @param colspan_trt_map (`data.frame`). The spanning label map for
#'     the main columns, as given by `create_colspan_map`.
#' @param combo_map_df (`data.frame` or `NULL`). A combination data
#'     frame as defined by [add_combo_levels()] with an additional
#'     `is_control` column indicating whether the virtual level will
#'     act as a reference (`TRUE`) or active (`FALSE`) group.
#' @param comp_map (`data.frame` or `NULL`). A data.frame with columns
#'     `"active"`, `"comparator"`, `"active_is_combo"` and
#'     `"comparator_is_combo"`, or `NULL` indicating the default
#'     comparison behavior (See Details).
#' @param diff_cols (`logical(1)`). Whether the risk difference
#'     column structure should be included (`TRUE`, the default) or
#'     not (`FALSE`).
#' @param diffs_label (`character(1)`). The spanning label for the
#'     risk difference section of columns
#'
#' @param .main_pre (`list` of `function`s). Passed to
#'     [rtables::make_split_fun()] as `pre` for treatment split in main
#'     structure.
#' @param .main_post (`list` of `function`s). Passed to
#'     [rtables::make_split_fun()] as `post` for treatment split in
#'     main structure.
#' @param .rr_pre (`list` of `function`s). Passed to
#'     [make_multicomp_splfun()] as `.pre` for risk difference
#'     faceting.
#' @param .rr_post (`list` of `function`s). Passed to
#'     [make_multicomp_splfun()] as `.post` for risk difference
#'     faceting.
#'
#' @details
#'
#' This function combines multiple `rtables` column splitting
#' instructions with customized split functions to create a column
#' structure with treatment columns for each treatment arm (optionally
#' including combination arms), grouped by active and non-active, with
#' risk difference columns comparing active arm(s) against one or more
#' non-active controls. It is intended for use in layouts that will
#' use [a_freq_j()] or similar `junco`-style analysis functions which
#' support risk difference columns and accept a `ref_path` argument.
#'
#' It is equivalent to the following sequence of layout instructions:
#'
#'  1. splitting on a colspan labeling variable with
#'  [rtables::trim_levels_to_map()] as the split function;
#'  2. splitting on treatment;
#'  3. adding a (non-nested) overall column acting as the risk difference spanning label; and finally
#'  4. splitting on treatment using [make_multicomp_splfun()] as the
#'  split function
#'
#' In addition, it supports:
#'
#'  - comparison against multiple control groups (as specified by `colspan_trt_map` and/or `comp_map`),
#'  - virtual combination-levels as active an/or control "treatments" (via `combo_map_df`),
#'  - full control of which comparisons are performed, and their order (via `comp_map`).
#'
#' If combination levels are declared via `combo_map_df` but none
#' appear in `colspan_trt_map`, all combinations will be added to the
#' appropriate group within the map based on `combo_map_df$is_control`
#' (assumed to be `FALSE` if the column is missing), with a warning.
#'
#' If some combination levels *do* appear in `combo_map_df` but
#' others do not, a warning will be thrown but the missing combination
#' levels will *not* be added to the treatment map.
#'
#' By default (when `comp_map` is `NULL`), all active treatments,
#' including active combinations, will be compared against all control
#' groups.
#'
#' The risk difference section of the structure is declared using
#' [make_multicomp_splfun()]. Reference paths are inferred
#' automatically from `colspan_trt_map` (after combination levels have
#' been added if necessary).
#'
#' For the purposes of pathin in the resulting structure,
#' `diffs_label` will be both the split name and split value of the
#' parent containing the individual risk difference columns.
#'
#' @returns `lyt` updated with the specified main and risk difference
#'     column structures added
#'
#'
#' @family std_col_struct
#' @export
#' @examples
#' colspan_var <- create_colspan_var(
#'   data.frame(TRT01A = factor(c("Placebo", "Active 1", "Active 2"))),
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = "Control",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#' colspan_trt_map <- create_colspan_map(
#'   colspan_var,
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = "Control",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#'
#' lyt <- basic_table() |>
#'   grouped_cols_w_diffs(colspan_trt_map) |>
#'   analyze("TRT01A", afun = function(x, ...) length(x))
#'
#' build_table(lyt, colspan_var)

grouped_cols_w_diffs <- function(
  lyt,
  colspan_trt_map,
  combo_map_df = NULL,
  ## default behavior for comp_map is taken care of in make_multicomp_splfun
  comp_map = NULL,
  diff_cols = TRUE,
  diffs_label = "Risk Differences",
  .main_pre = list(),
  .main_post = list(),
  .rr_pre = list(),
  .rr_post = list()
) {
  trtvar <- names(colspan_trt_map)[2]
  spanvar <- names(colspan_trt_map)[1]

  if (!is.null(combo_map_df)) {
    if (!("is_control" %in% names(combo_map_df))) {
      combo_map_df$is_control <- FALSE
    }
    main_post <- lapply(
      seq_len(NROW(combo_map_df)),
      function(i) {
        force(i)
        add_combo_facet(
          name = combo_map_df$valname[i],
          label = combo_map_df$label[i],
          levels = combo_map_df$levelcombo[[i]],
          extra = combo_map_df$exargs[[i]]
        )
      }
    )

    combo_nms <- combo_map_df$valname

    ## we're guaranteed to have some combo levels at this point
    combo_found <- combo_nms %in% colspan_trt_map[[trtvar]]
    if (!any(combo_found)) {
      message(
        "none of the combination levels appeared in the colspan treatment map;",
        " adding them automatically."
      )
      colspan_trt_map <- add_combo_levs_to_trtmap(colspan_trt_map, combo_map_df)
    } else if (any(!combo_found)) {
      warning("some combination levels defined in combo_map_df do not appear in colspan_trt_map")
    }
  } else {
    main_post <- list()
  }

  main_post <- c(main_post, .trtmap_to_post_funs(colspan_trt_map), .main_post)

  main_splfun <- make_split_fun(pre = .main_pre, post = main_post)

  lyt <- lyt |>
    split_cols_by(names(colspan_trt_map)[1]) |>
    split_cols_by(trtvar, split_fun = main_splfun)
  if (diff_cols) {
    rr_splfun <- make_multicomp_splfun(
      colspan_trt_map,
      comp_level_map = comp_map,
      combo_levels_map = combo_map_df,
      .pre = .rr_pre,
      .post = .rr_post
    )

    lyt <- lyt |>
      ## this is inherently non-nested
      add_overall_col(label = diffs_label) |>
      split_cols_by(trtvar, split_fun = rr_splfun)
  }
  lyt
}


combos_to_trtmap_rows <- function(combo_map, trtmap_sect) {
  ret <- data.frame(
    trtmap_sect[[1]][1],
    combo_map$valname
  )
  names(ret) <- names(trtmap_sect)
  ret
}


add_combo_levs_to_trtmap <- function(trtmap, combo_map) {
  span_vec <- trtmap[[1]]
  spltrtmap <- split(trtmap, span_vec)
  spanorder <- unique(span_vec) ## need this because split sorts things... like a clown.
  activedf <- spltrtmap[[spanorder[1]]]
  ctrldf <- spltrtmap[[spanorder[2]]]

  if (any(combo_map$is_control)) {
    ctrldf <- rbind(
      ctrldf,
      combos_to_trtmap_rows(combo_map[combo_map$is_control, ], ctrldf)
    )
  }

  if (any(!combo_map$is_control)) {
    activedf <- rbind(
      activedf,
      combos_to_trtmap_rows(combo_map[!combo_map$is_control, ], activedf)
    )
  }
  rbind(activedf, ctrldf)
}


.trtmap_to_post_funs <- function(trtmap) {
  splmap <- split(trtmap, trtmap[[1]])
  lapply(
    splmap,
    .map_sect_to_post_fun
  )
}

.map_sect_to_post_fun <- function(map) {
  cond_rm_facets(map[[2]], value = unique(map[[1]]), keep_matches = TRUE)
}


spans_trtvar_no_diffs <- function(
  lyt,
  colspan_trt_map,
  combo_map_df = NULL,
  trtvar = names(colspan_trt_map)[2],
  .pre = list(),
  .post = list()
) {

  spanvar <- names(colspan_trt_map)[1]

  if (!is.null(combo_map_df)) {
    if (!("is_control" %in% names(combo_map_df))) {
      combo_map_df$is_control <- FALSE
    }
    main_post <- lapply(
      seq_len(NROW(combo_map_df)),
      function(i) {
        force(i)
        add_combo_facet(
          name = combo_map_df$valname[i],
          label = combo_map_df$label[i],
          levels = combo_map_df$levelcombo[[i]],
          extra = combo_map_df$exargs[[i]]
        )
      }
    )

    combo_nms <- combo_map_df$valname

    ## we're guaranteed to have some combo levels at this point
    combo_found <- combo_nms %in% colspan_trt_map[[trtvar]]
    if (!any(combo_found)) {
      message(
        "none of the combination levels appeared in the colspan treatment map;",
        " adding them automatically."
      )
      colspan_trt_map <- add_combo_levs_to_trtmap(colspan_trt_map, combo_map_df)
    } else if (any(!combo_found)) {
      warning("some combination levels defined in combo_map_df do not appear in colspan_trt_map")
    }
  } else {
    main_post <- list()
  }

  main_post <- c(
    main_post,
    if (!is.null(colspan_trt_map)) .trtmap_to_post_funs(colspan_trt_map),
    .post
  )

  main_splfun <- make_split_fun(pre = .pre, post = main_post)

  if (!is.null(spanvar)) {
    lyt <- lyt |>
      split_cols_by(
        spanvar,
        split_fun = keep_split_levels(
          only = unique(colspan_trt_map[[spanvar]]),
          reorder = TRUE
        )
      )
  }
  lyt <- split_cols_by(lyt, trtvar, split_fun = main_splfun, show_colcounts = TRUE)
  lyt
}

#' @rdname grouped_cols_w_diffs
#' @param trtvar (`character(1)` or `NULL`)\cr the treatment variable
#'     to split by. Defaults to the treatment variable in
#'     `colspan_trt_map`.
#' @param subgrp_var (`character(1)` or `NULL`)\cr the name of the
#'     subgroup variable to split by within the `trtvar` split
#' @param subgrp_lbl (`character(1)` or `NULL`)\cr the spanning label
#'     to place over the subgroups, if different than `subgrp_var`
#' @param total_facet (`logical(1)`)\cr should an overall facet be
#'     prepended to the partition defined by `subgrp_var`? Defaults to
#'     `TRUE`.
#' @param total_lbl (`character(1)`)\cr Label to be used for the
#'     overall facet, if applicable. Defaults to `"Total"`; ignored if
#'     `total_facet` is `FALSE`.
#' @param .pre (`list` of `function`s)\cr Passed to
#'     [rtables::make_split_fun()] as `pre` for treatment splitting.
#' @param .post (`list` of `function`s)\cr Passed to
#'     [rtables::make_split_fun()] as `post` for treatment splitting
#'     after the standard column-structure processing.
#' @details `grouped_cols_w_subgrps` creates a hierarchical column
#'     structure that splits by `trtvar`, underneath which is a
#'     spanning label over a split with a Total column along with
#'     columns for each level of `subgrp_var`.
#' @export
#' @examples
#' dat <- create_colspan_var(
#'   data.frame(
#'     TRT01A = factor(rep(c("Placebo", "Active 1"), each = 2)),
#'     SEX = factor(rep(c("Female", "Male"), 2))
#'   ),
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = "Control",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#' colspan_trt_map <- create_colspan_map(
#'   dat,
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = "Control",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#'
#' lyt <- basic_table() |>
#'   grouped_cols_w_subgrps(
#'     colspan_trt_map,
#'     subgrp_var = "SEX",
#'     subgrp_lbl = "SUB_*"
#'   ) |>
#'   analyze("TRT01A", afun = function(x, ...) length(x))
#'
#' build_table(lyt, dat)
grouped_cols_w_subgrps <- function(
  lyt,
  colspan_trt_map = NULL,
  combo_map_df = NULL,
  trtvar = names(colspan_trt_map)[2],
  subgrp_var = NULL,
  subgrp_lbl = subgrp_var,
  total_facet = TRUE,
  total_lbl = "Total",
  .pre = list(),
  .post = list()
) {
  if (is.null(trtvar)) {
    stop("trtvar must be specified if no colspan map is provided.")
  }

  if (is.null(subgrp_var)) {
    stop(
      "no subgroup variable specified, use grouped_cols_w_diffs with diff_cols=FALSE ",
      "to create a grouped column structure with no subgrouping."
    )
  }

  ## handles spanning variable if necessary and the treatment var split
  lyt <- spans_trtvar_no_diffs(
    lyt,
    colspan_trt_map = colspan_trt_map,
    combo_map_df = combo_map_df,
    trtvar = trtvar,
    .pre = .pre,
    .post = .post
  )

  lyt <- lyt |>
    split_cols_by(
      trtvar,
      split_fun = make_split_fun(
        post = list(
          add_overall_facet(subgrp_lbl, subgrp_lbl),
          restrict_facets(subgrp_lbl, op = "keep")
        )
      )
    ) |>
    split_cols_by(
      subgrp_var,
      ## NULL is default behavior so this is ok
      split_fun = if (total_facet) add_overall_level(total_lbl, first = TRUE)
    )
  lyt
}

#' Create Column Structure for a J&J-Style Shift Table
#'
#' @param lyt (`PreDataTableLayouts`)\cr The layout, typically as
#'     returned directly from `basic_table`.
#' @param var (`character(1)`)\cr The variable defining the partition
#'     to create a shift table for.
#' @param span_lbl (`character(1)`)\cr The spanning label for the
#'     shift portion of the column structure. Defaults to
#'     `"Baseline"`.
#' @param .outer_spl_var (`character(1)`)\cr The variable to
#'     "split on" when creating the spanning labels. Must exist in the
#'     dataset(s) used in `build_table` but its values are irrelevant.
#'
#' @details This function creates a column structure akin to the following
#' (with Grade 1 through Grade 5 representing the levels of `var`):
#'
#' ```
#'                               Baseline
#'   N   Grade 1   Grade 2   Grade 3   Grade 4   Grade 5   Total
#' ——————————————————————————————————————————————————————————————
#' ```
#'
#' @examples
#' shift_data <- data.frame(
#'   BASE = factor(c("Grade 1", "Grade 2", "Grade 3")),
#'   CHG = c("Improved", "Stable", "Worsened")
#' )
#'
#' lyt <- basic_table() |>
#'   shift_tbl_col_struct("BASE") |>
#'   analyze("CHG", afun = function(x, ...) length(x))
#'
#' build_table(lyt, shift_data)
#' @return `lyt` updated with the specified shift table column structure.
#' @family std_col_struct
#' @export
shift_tbl_col_struct <- function(lyt, var, span_lbl = "Baseline", .outer_spl_var = var) {
  outer_splfun <- make_split_fun(
    post = list(
      add_overall_facet("N", label = " "),
      add_overall_facet("shift_table", label = span_lbl),
      restrict_facets(c("N", "shift_table"), op = "keep")
    )
  )

  inner_splfun <- make_split_fun(
    post = list(
      add_overall_facet("Total", label = "Total"),
      function(ret, spl, fulldf, .spl_context) {
        if (.spl_context$value[[1]] == "N") {
          make_split_result("N", labels = c(N = "N"), list(N = fulldf), subset_exprs = list(N = quote(TRUE)))
        } else {
          ret
        }
      }
    )
  )

  lyt <- lyt |>
    split_cols_by(.outer_spl_var, split_fun = outer_splfun) |>
    split_cols_by(var, split_fun = inner_splfun)
  lyt
}

#' Standard All vs Some (e.g. Related AEs) column structure
#'
#' @inheritParams grouped_cols_w_subgrps
#' @param subgrp_lbl (`character(1)`)\cr The label to put above the combination level representing `subgrp_lvls`
#' @param all_lbl (`character(1)`)\cr The label to put above the "All" column
#' @param subgrp_lvls (`characgter`)\cr All level(s) to be included in the `subgrp_lbl` column.
#'
#' @details
#' This column structure generating function is for comparing a single portion of the data (as represented by
#' level(s) of `subgrp_var`) against the full data, comparison of AE counts to treatment-related AE counts
#' being a motivating example.
#'
#'
#' @examples
#'
#'  library(junco)
#' dat <- create_colspan_var(
#'   data.frame(
#'     TRT01A = factor(rep(c("Placebo", "Active 1", "Active 2"), each = 5)),
#'     GRADE = factor(rep(paste("Grade ", 1:5), 3))
#'   ),
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = "Control",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#' colspan_trt_map <- create_colspan_map(
#'   dat,
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = "Control",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#'
#' lyt <- basic_table() |>
#'     some_v_all_col_struct(
#'     colspan_trt_map,
#'     subgrp_var = "GRADE",
#'     subgrp_lvls = c("Grade 4", "Grade 5"),
#'     subgrp_lbl = "High Grade",
#'     all_lbl = "All Grades")
#'
#' build_table(lyt, dat)
#'
#' @export
some_v_all_col_struct <- function(
  lyt,
  colspan_trt_map = NULL,
  combo_map_df = NULL,
  trtvar = names(colspan_trt_map)[2],
  subgrp_var = NULL,
  subgrp_lbl = subgrp_var,
  all_lbl,
  subgrp_lvls,
  .pre = list(),
  .post = list()
) {
  if (is.null(trtvar)) {
    stop("trtvar must be specified if no colspan map is provided.")
  }

  if (is.null(subgrp_var)) {
    stop(
      "no subgroup variable specified, use grouped_cols_w_diffs with diff_cols=FALSE ",
      "to create a grouped column structure with no subgrouping."
    )
  }

  lyt <- spans_trtvar_no_diffs(
    lyt,
    colspan_trt_map = colspan_trt_map,
    combo_map_df = combo_map_df,
    trtvar = trtvar,
    .pre = .pre,
    .post = .post
  )

  lyt <- lyt |>
    split_cols_by(
      subgrp_var,
      split_fun = make_split_fun(
        post = list(
          add_overall_facet(all_lbl, label = all_lbl),
          add_combo_facet(
            name = paste0(subgrp_var, "_subset"),
            label = subgrp_lbl,
            levels = subgrp_lvls
          ),
          restrict_facets(
            c(all_lbl, paste0(subgrp_var, "_subset")),
            op = "keep"
          )
        )
      )
    )

  lyt
}

#' Patient years exposure
#' @description Statistical/Analysis Function for presenting Patient years exposure summary data
#'
#' @name a_patyrs_j
#' @order 1
NULL

#' @describeIn a_patyrs_j Statistical Function for Patient years exposure summary data
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .var (`string`)\cr variable name containing the patient years data.
#' @param id (`string`)\cr subject variable name.
#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
#' @param source (`string`)\cr source of data, either "alt_df" or "df".
#' @param inriskdiffcol (`logical`)\cr flag indicating if the function is called within a risk difference column.
#'
#' @return
#' * `s_patyrs_j()` returns a list containing the patient years statistics.
#' The list of available statistics for can be viewed by running `junco_get_stats("a_patyrs_j")`.
#' Currently, this is just a single statistic `patyrs`, patient years of exposure.
#'
#' @keywords internal
s_patyrs_j <- function(
  df,
  .var,
  id = "USUBJID",
  .alt_df_full,
  source = c("alt_df", "df"),
  inriskdiffcol = FALSE
) {
  source <- match.arg(source)

  if (source == "alt_df") {
    if (is.null(.alt_df_full)) {
      stop(paste(
        "s_patyrs_j with source = alt_df requires a non-null .alt_df_full"
      ))
    }
    df <- .alt_df_full
  }
  df <- unique(df[, c(id, .var)])

  x <- list()

  if (!inriskdiffcol) {
    patyrs <- sum(df[[.var]])
  } else {
    patyrs <- list(x = NULL)
  }
  x[["patyrs"]] <- stats::setNames(patyrs, nm = "patyrs")

  return(x)
}

#' @describeIn a_patyrs_j Formatted analysis function for patient years summary which is used
#' as `afun` in `analyze` or `cfun` in `summarize_row_groups`.
#'
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .var (`string`)\cr variable name containing the patient years data.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param id (`string`)\cr subject variable name.
#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
#' @param .formats (named 'character' or 'list')\cr formats for the statistics.
#' @param .labels (named 'character')\cr labels for the statistics.
#' @param source (`string`)\cr source of data, either "alt_df" or "df".
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param .stats (`character`)\cr statistics to select for the table.
#'
#' @return
#' * `a_patyrs_j` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @export
#'
#' @examples
#' library(tern)
#' library(dplyr)
#' trtvar <- "ARM"
#' ctrl_grp <- "B: Placebo"
#' cutoffd <- as.Date("2023-09-24")
#'
#'
#' adexsum <- ex_adsl |>
#'   create_colspan_var(
#'     non_active_grp          = ctrl_grp,
#'     non_active_grp_span_lbl = " ",
#'     active_grp_span_lbl     = "Active Study Agent",
#'     colspan_var             = "colspan_trt",
#'     trt_var                 = trtvar
#'   ) |>
#'   mutate(
#'     rrisk_header = "Risk Difference (95% CI)",
#'     rrisk_label = paste(!!rlang::sym(trtvar), "vs", ctrl_grp),
#'     TRTDURY = case_when(
#'       !is.na(EOSDY) ~ EOSDY,
#'       TRUE ~ as.integer(cutoffd - as.Date(TRTSDTM) + 1)
#'     )
#'   ) |>
#'   select(USUBJID, !!rlang::sym(trtvar), colspan_trt, rrisk_header, rrisk_label, TRTDURY)
#'
#' adae <- ex_adae |>
#'   group_by(USUBJID, AEDECOD) |>
#'   select(USUBJID, AEDECOD, ASTDY) |>
#'   mutate(rwnum = row_number()) |>
#'   mutate(AOCCPFL = case_when(
#'     rwnum == 1 ~ "Y",
#'     TRUE ~ NA
#'   )) |>
#'   filter(AOCCPFL == "Y")
#'
#' aefup <- left_join(adae, adexsum, by = "USUBJID")
#'
#' colspan_trt_map <- create_colspan_map(adexsum,
#'   non_active_grp = ctrl_grp,
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = trtvar
#' )
#'
#' ref_path <- c("colspan_trt", " ", trtvar, ctrl_grp)
#'
#' ################################################################################
#' # Define layout and build table:
#' ################################################################################
#'
#' lyt <- basic_table(show_colcounts = TRUE, colcount_format = "N=xx", top_level_section_div = " ") |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar, labels_var = "rrisk_label", split_fun = remove_split_levels(ctrl_grp)) |>
#'   analyze("TRTDURY",
#'     nested = FALSE,
#'     show_labels = "hidden",
#'     afun = a_patyrs_j
#'   )
#' result <- build_table(lyt, aefup, alt_counts_df = adexsum)
#' result
#'
a_patyrs_j <- function(
  df,
  .var,
  .df_row,
  id = "USUBJID",
  .alt_df_full = NULL,
  .formats = NULL,
  .labels = NULL,
  source = c("alt_df", "df"),
  .spl_context,
  .stats = "patyrs"
) {
  source <- match.arg(source)

  if (length(.stats) > 1 || (length(.stats) == 1 && .stats != "patyrs")) {
    stop("a_patyrs_j: .stats must be 'patyrs'.")
  }

  check_alt_df_full(source, "alt_df", .alt_df_full)

  cur_col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (source == "alt_df") {
    ### derive appropriate alt_df based upon .spl_context and .alt_df_full
    ### note that this is not yet within the current column

    alt_df <- h_create_altdf(
      .spl_context,
      .df_row,
      .alt_df_full,
      denom_by = NULL,
      id = id,
      variables = NULL,
      denom = "n_altdf"
    )
    ## restrict to current column
    new_denomdf <- subset(alt_df, eval(cur_col_expr))
  } else {
    new_denomdf <- df
  }

  x_stats <- s_patyrs_j(
    df,
    .alt_df_full = new_denomdf,
    .var = .var,
    id = id,
    source = source,
    inriskdiffcol = inriskdiffcol
  )

  x_stats <- x_stats[.stats]

  levels_per_stats <- lapply(x_stats, names)

  .formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
  .labels <- junco_get_labels_from_stats(.stats, .labels, levels_per_stats)
  .labels <- .unlist_keep_nulls(.labels)

  x_stats <- x_stats[.stats]

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels
  )

  return(inrows)
}

#' Exposure-Adjusted Incidence Rate
#' @description
#' Statistical/Analysis Function for presenting Exposure-Adjusted Incidence Rate summary data
#'
#'
#' @name a_eair100_j
NULL

#' @describeIn a_eair100_j
#' calculates exposure-adjusted incidence rates (EAIR) per `num_p_year` person-years for a
#' specific level of a variable.
#'
#'
#' @param levii (`string`)\cr the specific level of the variable to calculate EAIR for.
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param .var (`string`)\cr variable name that is passed by `rtables`.
#' @param .alt_df_full (`dataframe`)\cr alternative dataset for calculations.
#' @param id (`string`)\cr subject variable name.
#' @param fup_var (`string`)\cr name of the variable containing the total follow-up duration
#'   for each subject, expressed in **years**.
#'   Used as the at-risk exposure time for subjects who did **not** experience the event.
#' @param occ_var (`string` or `NULL`)\cr name of the flag variable identifying the
#'   **first** occurrence of the event within each subject and level, encoded as `"Y"`.
#'   Only records where `occ_var == "Y"` contribute to the event count (`n_event`),
#'  and only one event record per subject is allowed.
#'   \cr If `NULL`, event occurrence filtering is skipped and time at risk is taken
#'   from `fup_var` in `alt_counts_df` for all subjects.
#' @param occ_dy (`string` or `NULL`)\cr When `occ_var` not `NULL`: name of the variable
#'  containing the relative day of the
#'   first event occurrence, expressed in **days** (e.g., `ASTDY`).
#'   For subjects with an event (`occ_var == "Y"`), this value is converted to years
#'   as `occ_dy / 365.25` and used as the at-risk exposure time instead of `fup_var`.
#'   Must be on the same time origin as `fup_var` (i.e., relative to start of exposure).
#' @param num_p_year (`numeric`)\cr scaling factor for the incidence rate, representing
#'   the number of person-years used as the denominator base.
#'   The EAIR is calculated as `num_p_year * n_event / total_person_years`.
#'   Defaults to `100`, yielding a rate per 100 person-years.
#'   For example, use `1` for a rate per person-year or `1000` for a rate per
#'   1000 person-years.
#' @param count_multiple_events (`logical`)\cr if `TRUE`, counts the total number of events
#'   per subject rather than treating each subject as contributing 1 to `n_event`.
#'   Only considered when `occ_var = NULL`.
#'   Defaults to `FALSE`.
#'
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param conf_type_diff (`string`)\cr method used to compute the confidence interval for the EAIR difference.
#'   One of `"wald"` (Wald without continuity correction), `"waldcc"` (Wald with continuity correction),
#'   `"mn"` (Miettinen-Nurminen score), or `"scas"` (skewness-corrected asymptotic score).
#'   Defaults to `"wald"`.
#' @param conf_type_eair (`string`)\cr method used to compute the confidence interval for the EAIR rate.
#'   One of `"exact"`, `"normal"`, `"normal_log"`, `"byar"`
#'   \cr See `?tern:::h_incidence_rate` and `?tern::incidence_rate`, argument `control` for more information.
#'   Defaults to `"exact"`.
#' @param vs_ref_group (`logical`)\cr if TRUE, risk difference (against reference group) calculations will be performed.
#' @param cur_col_expr (`expression`)\cr current column expression taken from `rtables` `.spl_context`
#' splitting machinery (`cur_col_expr`).
#' @param ref_col_expr (`expression` or `NULL`)\cr column expression for the reference group.
#' Required to be an expression if `vs_ref_group` is `TRUE`
#' @param inriskdiffcol (`logical`)\cr flag indicating if the function is called within a risk difference column.
#'
#' @return
#'  * `s_eair100_levii_j()` returns a list containing the following statistics:
#' \itemize{
#'   \item n_event: Number of subjects with the event, or total event count if `count_multiple_events = TRUE`
#'   \item person_years: Total person-years of follow-up
#'   \item eair: Exposure-adjusted incidence rate per `num_p_year` person-years
#'   \item n_eair: Combination of `n_event` and `eair` statistics.
#'   \item eair_n: Combination of `eair` and `n_event` statistics.
#'   \item eair_n_py: Combination of `eair`, `n_event` and `person_years` statistics.
#'   \item eair_ci: Confidence interval for `eair`, method specified in `conf_type_eair`.
#'   \item eair_est_ci: Combination of `eair` and `eair_ci`.
#'   \item eair_diff_est: Difference in EAIR between current group and reference group
#'    (if `diff`=TRUE and `inriskdiffcol`=TRUE)
#'   \item eair_diff_ci: Confidence interval for difference in EAIR between current group and reference group
#'    (if `diff`=TRUE and `inriskdiffcol`=TRUE)
#'   \item eair_diff_est_ci: Combination of `eair_diff_est` and `eair_diff_ci`.
#' }
#' The list of available statistics (core columns) can also be viewed by
#' running `junco_get_stats("a_eair100_j")`.
#' @details
#' The exposure-adjusted incidence rate (EAIR) is defined as:
#' - When (`occ_var` not `NULL`) or `count_multiple_events = FALSE`:
#' \cr the **number of subjects**
#' with at least one occurrence of a specified adverse event divided by the total
#' at-risk exposure time across all subjects.
#'
#' - When `occ_var = NULL` and `count_multiple_events = TRUE`:
#' \cr the total **number of events** across of a specified adverse event divided by the total
#' at-risk exposure time across all subjects.
#'
#' Total at-risk exposure time is calculated for each subject
#' as:
#' - When `occ_var` not `NULL`
#' \itemize{
#' \item for subjects with the event: relative day (from the start of exposure) of
#' the onset date of the **first** occurrence of the specified event (`occ_var` and `occ_dy`),
#' transformed from days into years as `occ_dy/365.25`, or
#' \item for subjects without the event: total duration of follow-up (expressed in years)
#' (e.g., treatment discontinuation, completion, or censoring) (`fup_var`).
#' }
#' - When `occ_var = NULL`\cr
#' for all subjects: total duration of follow-up (expressed in years)
#' (e.g., treatment discontinuation, completion, or censoring) (`fup_var`).
#'
#' The EAIR is expressed as:
#'
#' \deqn{
#'   \mathrm{EAIR} = \hat r = \frac{n}{T}
#' }
#'
#' where:
#' \itemize{
#'   \item \eqn{n} is the number of subjects with at least one occurrence of the event
#'   \item T = \eqn{ \sum_{i=1}^{N} t_i}, with
#'   \item \eqn{t_i} is the at-risk exposure time for subject \eqn{i},
#'   expressed in subject-years
#' }
#'
#' The difference between two EAIRs is
#' \eqn{\hat \theta = (\hat r_1 - \hat r_2)}.
#'
#' Wald's method for the confidence interval approximation is used (Liu et al., 2006), which uses the standard error
#' \deqn{
#' \mathrm{se}(\hat r_1 - \hat r_2) =
#' \sqrt{\frac{n_1}{T_1^2} + \frac{n_2}{T_2^2}}
#' }{
#' se = sqrt(n1/T1^2 + n2/T2^2)
#' }
#' and the \eqn{100(1-\alpha)\%} confidence interval is
#' \deqn{
#' (\hat r_1 - \hat r_2) \pm z_{1-\alpha/2}\,\mathrm{se}(\hat r_1 - \hat r_2)
#' }{
#' (r1 - r2) +/- z_(1-a/2) * SE
#' }
#' where \eqn{z_{1-\alpha/2}} is the standard normal quantile. [1](https://metricgate.com/docs/poisson-rate-comparison/)
#' \cr
#' \cr Other methods for confidence interval for difference can be specified in `conf_type_diff` argument.
#'
#' EAIR is commonly reported per 100 subject-years:
#'
#' \deqn{
#'   \mathrm{EAIR}_{100} = 100 \times \hat r
#' }
#' @references
#' Liu, G. F., Wang, J., Liu, K., and Snavely, D. B. (2006).
#' Confidence intervals for an exposure adjusted incidence rate difference
#' with applications to clinical trials.
#' \emph{Statistics in Medicine}, \strong{25}(8), 1275--1286.
#' \doi{10.1002/sim.2335}
#' @keywords internal
s_eair100_levii_j <- function(
  levii,
  df,
  .df_row,
  .var,
  .alt_df_full = NULL,
  id = "USUBJID",
  fup_var,
  occ_var,
  occ_dy,
  num_p_year = 100,
  count_multiple_events = FALSE,
  conf_level = 0.95,
  conf_type_diff = c("wald", "waldcc", "mn", "scas"),
  conf_type_eair = c("exact", "normal", "normal_log", "byar"),
  vs_ref_group = FALSE,
  .in_ref_col,
  cur_col_expr,
  ref_col_expr,
  inriskdiffcol = FALSE
) {
  conf_type_diff <- match.arg(conf_type_diff)
  method_part <- switch(conf_type_diff,
    "wald" = "Wald, without correction",
    "waldcc" = "Wald, with correction",
    "mn" = "Miettinen and Nurminen",
    "scas" = "skewness-corrected asymptotic score",
    stop(paste(conf_type_diff, "does not have a description"))
  )
  method_part <- paste0("(", method_part, ")")
  conf_type_eair <- match.arg(conf_type_eair)
  method_eair_part <- switch(conf_type_eair,
    "exact" = "Exact",
    "byar" = "byar",
    "normal" = "normal",
    "normal_log" = "log-normal",
    stop(paste(conf_type_eair, "does not have a description"))
  )
  method_eair_part <- paste0(" (", method_eair_part, ")")

  if (vs_ref_group && (!is.expression(cur_col_expr))) {
    stop("cur_col_expr must be an expression when vs_ref_group = TRUE")
  }
  # subset .alt_df_full to current column
  .alt_df_full_cur_group <- subset(.alt_df_full, eval(cur_col_expr))
  cur_dfs <- h_get_eair_df(
    levii,
    df,
    denom_df = .alt_df_full_cur_group,
    .var = .var,
    id = id,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy,
    count_multiple_events = count_multiple_events
  )
  cur_df_num <- cur_dfs$df_num
  cur_df_denom <- cur_dfs$df_denom
  ### statistics derivation
  # note: variables n_events and mod_fup_var are derived by h_get_eair_df
  # when count_multiple_events == TRUE, n_events: number of events per subject
  # when count_multiple_events == FALSE, n_events: 1 for subjects with event
  x1 <- sum(cur_df_num[["n_events"]])
  n1 <- sum(cur_df_denom[["mod_fup_var"]])
  cur_eair <- num_p_year * x1 / n1
  cur_n_eair <- c(x1, cur_eair)

  x <- list()
  eair_lbl <- paste0("eair (per ", num_p_year, " person years)")
  n_event_lbl <-
    if (is.null(occ_var) && count_multiple_events) {
      "Number of events"
    } else {
      "Number of subjects with event"
    }

  x$n_event <- c("n_event" = x1)
  x$person_years <- c("person_years" = n1)
  x$eair <- stats::setNames(c("eair" = cur_eair), "eair")
  x$n_eair <- stats::setNames(c("n_eair" = cur_n_eair), c("n_event", "eair"))
  x$eair_n <- stats::setNames(c("eair_n" = x$n_eair[c(2, 1)]), c("eair", "n_event"))
  x$eair_n_py <- stats::setNames(c("eair_n_py" = c(x$eair_n, n1)), c("eair", "n_event", "py"))

  attr(x$n_event, "label") <- n_event_lbl
  attr(x$eair, "label") <- eair_lbl
  attr(x$n_eair, "label") <- paste0(n_event_lbl, " (", eair_lbl, ")")
  attr(x$eair_n, "label") <- paste0(eair_lbl, " (", n_event_lbl, ")")
  attr(x$eair_n_py, "label") <- paste0(eair_lbl, " (", n_event_lbl, "/", "person-years", ")")

  # ci for rates - utilize tern function to derive rate_ci
  tern_incid_rate <- h_incidence_rate(
    person_years = n1,
    n_events = x1,
    control = list(
      num_pt_year = num_p_year,
      input_time_unit = "year",
      conf_level = conf_level,
      conf_type = conf_type_eair
    )
  )

  x$eair_ci <- stats::setNames(c("eair_ci" = tern_incid_rate$rate_ci), "eair_ci")
  attr(x$eair_ci, "label") <- paste0(f_conf_level(conf_level), method_eair_part)

  x$eair_est_ci <- stats::setNames(c("eair_est_ci" = c(x$eair, tern_incid_rate$rate_ci)), "eair_est_ci")
  attr(x$eair_est_ci, "label") <- paste0(eair_lbl, " with (", f_conf_level(conf_level), method_eair_part, ")")


  if (vs_ref_group) {
    # perform vs ref group derivations
    if (inriskdiffcol) {
      # stats that will be blanked out in risk diff columns (only applicable to horizontal layout)
      x$n_event <- c("n_event" = NULL)
      x$person_years <- c("person_years" = NULL)
      x$eair_ci <- c("eair_ci" = NULL)
    }

    # retrieve ref_group info from ref_col_expr for both .alt_df_full and .df_row
    alt_df_full_ref_group <- subset(.alt_df_full, eval(ref_col_expr))
    ref_group <- subset(.df_row, eval(ref_col_expr))

    ref_dfs <- h_get_eair_df(
      levii,
      df = ref_group,
      denom_df = alt_df_full_ref_group,
      .var = .var,
      id = id,
      fup_var = fup_var,
      occ_var = occ_var,
      occ_dy = occ_dy,
      count_multiple_events = count_multiple_events
    )

    ref_df_num <- ref_dfs$df_num
    ref_df_denom <- ref_dfs$df_denom

    ### statistics derivation
    x2 <- sum(ref_df_num[["n_events"]])
    n2 <- sum(ref_df_denom[["mod_fup_var"]])

    ref_eair <- num_p_year * x2 / n2
    ref_n_eair <- c(x2, ref_eair)

    rdiff <- cur_eair - ref_eair
    eair_diff_est_stats <- h_s_eair_diff(x1, n1,
      x2, n2,
      conf_type = conf_type_diff,
      conf_level = conf_level
    )
    # combine est of difference with its ci
    eair_diff_est_ci <- num_p_year *
      c(eair_diff_est_stats$diff_est, eair_diff_est_stats$diff_lcl, eair_diff_est_stats$diff_ucl)

    x$eair_diff_est_ci <- stats::setNames(
      c("eair_diff_est_ci" = eair_diff_est_ci),
      nm = c("estimate", "lcl", "ucl")
    )
    attr(x$eair_diff_est_ci, "label") <-
      paste0("Difference in eair with (", f_conf_level(conf_level), ") ", method_part)

    x$eair_diff_ci <- x$eair_diff_est_ci[2:3]
    attr(x$eair_diff_ci, "label") <-
      paste0(f_conf_level(conf_level), " for difference in eair ", method_part)

    x$eair_diff_est <- x$eair_diff_est_ci[1]
    attr(x$eair_diff_est, "label") <- "Difference in eair"
  } else {
    # no risk diff calculations - set stats to NULL, ie blank
    x$eair_diff_est_ci <- c("eair_diff_est_ci" = NULL)
    x$eair_diff_est <- c("eair_diff_est" = NULL)
    x$eair_diff_ci <- c("eair_diff_ci" = NULL)
  }

  return(x)
}

#' @describeIn a_eair100_j
#' Formatted analysis function for exposure adjusted incidence rate summary which is
#' used as `afun` in `analyze` or `cfun` in `summarize_row_groups`.\cr
#'
#' @param labelstr (`string`)\cr Not intended to be set by user, only present to be able to use function as a `cfun`.
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param drop_levels (`logical`)\cr if TRUE, non-observed levels will not be included.
#' @param riskdiff (`logical`)\cr if TRUE, risk difference calculations will be performed.
#' @param ref_path (`string`)\cr column path specifications for the control group.
#' @param .stats (`character`)\cr statistics to select for the table.\cr
#' @param .formats (named 'character' or 'list')\cr formats for the statistics.
#' @param .labels (named 'character')\cr labels for the statistics.
#' @param .indent_mods (named `integer`)\cr indent modifiers for the labels.
#' @param na_str (`string`)\cr string used to replace all NA or empty values in the output.
#' @param row_labels_adj (`logical`)\cr If `TRUE` and number of requested statistics = 1,
#' the row label on the table will reflect the level of the incoming variable rather than
#' the label for the statistic.
#' \cr Set to default `TRUE` for backward-compatibility reasons.
#' @param riskdiff_setup (`string`)\cr Are risk differences presented in horizontal way, or vertical way.
#' \cr When horizontal, the statistics for `eair`, `n_eair`, `eair_n` will be replaced by
#' `ear_diff_est_ci` in the risk difference columns.
#' If `.stats` include any of difference in eair rates statistics,
#' these will be removed as `ear_diff_est_ci` will be displayed in the risk difference columns
#'
#' @return
#'  * `a_eair100_j` returns the corresponding list with formatted [rtables::CellValue()].\cr
#' Within a risk difference column, the statistics `eair` and `n_eair` are replaced by `eair_diff_est_ci`
#' (difference in EAIR between current group and reference group, together with it's confidence interval).

#' @export
#'
#' @examples
#' library(tern)
#' library(dplyr)
#' trtvar <- "ARM"
#' ctrl_grp <- "B: Placebo"
#' cutoffd <- as.Date("2023-09-24")
#'
#'
#' adexsum <- ex_adsl |>
#'   create_colspan_var(
#'     non_active_grp          = ctrl_grp,
#'     non_active_grp_span_lbl = " ",
#'     active_grp_span_lbl     = "Active Study Agent",
#'     colspan_var             = "colspan_trt",
#'     trt_var                 = trtvar
#'   ) |>
#'   mutate(
#'     rrisk_header = "Risk Difference (95% CI)",
#'     rrisk_label = paste(!!rlang::sym(trtvar), "vs", ctrl_grp),
#'     TRTDURY = case_when(
#'       !is.na(EOSDY) ~ EOSDY,
#'       TRUE ~ as.integer(cutoffd - as.Date(TRTSDTM) + 1)
#'     )
#'   ) |>
#'   select(USUBJID, !!rlang::sym(trtvar), colspan_trt, rrisk_header, rrisk_label, TRTDURY)
#'
#' adexsum$TRTDURY <- as.numeric(adexsum$TRTDURY)
#'
#' adae <- ex_adae |>
#'   group_by(USUBJID, AEDECOD) |>
#'   select(USUBJID, AEDECOD, ASTDY) |>
#'   mutate(rwnum = row_number()) |>
#'   mutate(AOCCPFL = case_when(
#'     rwnum == 1 ~ "Y",
#'     TRUE ~ NA
#'   )) |>
#'   filter(AOCCPFL == "Y")
#'
#' aefup <- left_join(adae, adexsum, by = "USUBJID")
#'
#' colspan_trt_map <- create_colspan_map(adexsum,
#'   non_active_grp = ctrl_grp,
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = trtvar
#' )
#'
#' ref_path <- c("colspan_trt", " ", trtvar, ctrl_grp)
#'
#' ################################################################################
#' # Define layout and build table:
#' ################################################################################
#'
#' lyt <- basic_table(show_colcounts = TRUE, colcount_format = "N=xx", top_level_section_div = " ") |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar, labels_var = "rrisk_label", split_fun = remove_split_levels(ctrl_grp)) |>
#'   analyze("TRTDURY",
#'     show_labels = "hidden",
#'     afun = a_patyrs_j
#'   ) |>
#'   analyze(
#'     vars = "AEDECOD",
#'     afun = a_eair100_j,
#'     extra_args = list(
#'       fup_var = "TRTDURY",
#'       occ_var = "AOCCPFL",
#'       occ_dy = "ASTDY",
#'       ref_path = ref_path,
#'       drop_levels = TRUE
#'     )
#'   )
#'
#' result <- build_table(lyt, aefup, alt_counts_df = adexsum)
#' head(result, 5)
#'
a_eair100_j <- function(
  df,
  labelstr = NULL,
  .var,
  .df_row,
  .spl_context,
  .alt_df_full = NULL,
  id = "USUBJID",
  fup_var,
  occ_var,
  occ_dy = NULL,
  num_p_year = 100,
  count_multiple_events = FALSE,
  drop_levels = FALSE,
  riskdiff = TRUE,
  ref_path = NULL,
  .stats = c("eair"),
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3),
  # treatment/ref group related arguments
  conf_level = 0.95,
  conf_type_diff = c("wald", "waldcc", "mn", "scas"),
  conf_type_eair = c("normal", "normal_log", "exact", "byar"),
  row_labels_adj = FALSE,
  riskdiff_setup = c("horizontal", "vertical")
) {
  conf_type_diff <- match.arg(conf_type_diff)
  conf_type_eair <- match.arg(conf_type_eair)
  riskdiff_setup <- match.arg(riskdiff_setup)

  if (riskdiff && is.null(ref_path)) {
    stop("ref_path cannot be NULL when riskdiff = TRUE, please specify it. See ?get_ref_info for details.")
  }

  ref_info <- get_ref_info_expanded(
    df,
    .var,
    .df_row,
    .spl_context,
    ref_path,
    riskdiff,
    riskdiff_setup
  )

  perform_vs_ref_stats <- ref_info$perform_vs_ref_stats
  ref_col_expr <- ref_info$ref_col_expr
  .in_ref_col <- ref_info$.in_ref_col

  ## prepare for column based split
  cur_col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  # if no stats requested, get all stats
  .stats <- junco_get_stats(
    "a_eair100_j",
    stats_in = .stats,
    custom_stats_in = NULL
  )
  if (any(.stats %in% c("eair_diff_est_ci", "eair_diff_est", "eair_diff_ci")) && riskdiff_setup == "horizontal") {
    .stats <- .stats[!(.stats %in% c("eair_diff_est_ci", "eair_diff_est", "eair_diff_ci"))]
  }

  checkmate::assert_string(fup_var, null.ok = FALSE)
  checkmate::assert_string(occ_var, null.ok = TRUE)
  if (!is.null(occ_var)) {
    checkmate::assert_string(occ_dy, null.ok = FALSE)
  }

  checkmate::assert_names(colnames(df), must.include = c(occ_var, occ_dy))

  if (is.null(.alt_df_full)) {
    stop(paste("a_eair100_j: .alt_df_full cannot be NULL. Specify `alt_counts_df` to `build_table`"))
  }
  checkmate::assert_names(colnames(.alt_df_full), must.include = c(fup_var))

  inrowsplit <- FALSE
  if (.var == tail(.spl_context$split, 1L)) {
    # note: this will catch the rowsplit only if parent_name in split_rows_by call is .var (default)
    drop_levels <- TRUE
    inrowsplit <- TRUE
  }

  ### combine all preprocessing of incoming df/.df_row in one function
  ### do this outside stats derivation functions (s_freq_j/)
  ### use all of val/excl_levels/drop_levels//new_levels/label/label_map/labelstr/label_fstr
  upd_dfrow <- h_upd_dfrow(
    .df_row,
    .var,
    val = NULL,
    excl_levels = NULL,
    drop_levels = drop_levels,
    new_levels = NULL,
    new_levels_after = FALSE,
    label = NULL,
    label_map = NULL,
    labelstr = labelstr,
    label_fstr = NULL,
    .spl_context = .spl_context
  )

  .df_row <- upd_dfrow$df_row
  df <- upd_dfrow$df

  ### derive appropriate alt_df based upon .spl_context and .alt_df_full
  ### note that only row-based splits are done
  ### for now only for variables from the first split_rows_by
  alt_df <- h_create_altdf(
    .spl_context,
    .df_row,
    .alt_df_full,
    denom_by = NULL,
    id = id,
    variables = NULL,
    denom = "n_altdf"
  )
  new_denomdf <- alt_df

  # gather arguments to pass onto s_function
  fn_Args <- list(
    df = df,
    .df_row = .df_row,
    .var = .var,
    id = id,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy,
    num_p_year = num_p_year,
    count_multiple_events = count_multiple_events,
    cur_col_expr = cur_col_expr,
    ref_col_expr = ref_col_expr,
    vs_ref_group = perform_vs_ref_stats,
    .in_ref_col = !perform_vs_ref_stats,
    inriskdiffcol = riskdiff_setup == "horizontal" && inriskdiffcol,
    conf_level = conf_level,
    conf_type_eair = conf_type_eair,
    .alt_df_full = .alt_df_full,
    conf_type_diff = conf_type_diff
  )

  levs <- levels(.df_row[[.var]])
  y <- mapply(
    s_eair100_levii_j,
    levii = levs,
    MoreArgs = fn_Args,
    SIMPLIFY = FALSE
  )

  ### rearrange list y to  list to x_stats
  # y is a nested list with
  # outer elements levels of incoming variable
  # inner elements stat elements statistics from

  #### this is to ensure the remainder of the code can stay the same as in a_freq_j
  stnms <- junco_get_stats("a_eair100_j")
  x_stats <- extract_x_stats(y, stnms)

  # x_stats is a nested list with
  # outer elements stat elements statistics (all 5 from stnms)
  # inner elements levels of incoming variable
  # this will ensure we can perform subsetting on .stats
  # like x_stats[.stats]

  # transpose_named_list cannot be used as this will not ensure all 5 poss stats are in
  if (inriskdiffcol && riskdiff_setup == "horizontal") {
    .stats_adj <- replace(.stats, .stats %in% c("eair", "n_eair", "eair_n", "eair_n_py"), "eair_diff_est_ci")
  } else {
    .stats_adj <- .stats
  }

  .stats <- .stats_adj

  # Fill in formatting defaults


  x_stats <- x_stats[.stats]
  x_stats_orig <- x_stats
  # from now onwards, retransform x_stats back into structure
  # list with outer elements stats levels from incoming variable
  # inner elements statistics
  x_stats <- transpose_named_list(x_stats)

  levels_per_stats <- lapply(x_stats, names)
  # in case no default label get the label from the x_stats directly
  # this is to cover statistics with dynamic label, such as
  # n_event Either Number of events or Number of subjects with events
  .labels_pre <- junco_get_labels_from_attrib(.stats, .labels, x_stats)

  .formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
  .labels <- junco_get_labels_from_stats(.stats, .labels_pre, levels_per_stats)
  .labels <- .unlist_keep_nulls(.labels)

  # make adjustments to rowlabels  when not inrowsplit
  if (!inrowsplit && length(.stats) > 1) {
    # if more than one stat requested and variable is not in a prior splitrowscall
    # prepend the level of the incoming variable (which is now in names of x_stats) to the label
    .labels <- paste(rep(names(x_stats), each = length(.stats)), .labels)
  } else if (!inrowsplit && length(.stats) == 1 && row_labels_adj) {
    # if one stat requested and variable is not in a prior splitrowscall
    # show the levels of the incoming variable, rather than the statistic
    .labels <- names(x_stats)
  }
  .labels <- gsub("^\\s+", "", .labels)

  .indent_mods <- junco_get_indents_from_stats(
    .stats,
    .indent_mods,
    levels_per_stats
  )
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  # .format_na_strs processing
  # if na_str = c(NA, NA, NA)
  # this will ensure the ci (NA, NA, NA) will be represented as NE (NE, NE)
  # the value NE is defined as the default to replace NA in our jjcs format

  if (!is.null(na_str)) {
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
  } else {
    .format_na_strs <- NULL
  }

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )

  return(inrows)
}

#' @name jj_complex_scorefun
#' @title Complex Scoring Function
#' @description
#' A function used for sorting AE tables (and others) as required.
#' @details
#' This sort function sorts as follows:
#' * Takes all the columns from a specified spanning column header (default= colspan_trt)
#' and sorts by the last treatment
#' column within this.
#' * If no spanning column header variable exists (e.g you have only one active treatment arm and have decided to
#' remove the spanning header from your layout), it will sort by the first treatment column in your table.
#'
#' This function is not really designed for tables that have sub-columns. However, if users wish to override any
#' default sorting behavior, they can simply specify their own colpath to use for sorting on (default = NULL)
#'
#' @param spanningheadercolvar (`character`)\cr
#' Name of spanning header variable that defines the active treatment columns.
#' If you do not have an active treatment spanning header column then user can define this as NA.
#' @param usefirstcol (`logical`)\cr
#' This allows you to just use the first column of the table to sort on.
#' @param colpath (`character`)\cr
#' Name of column path that is needed to sort by (default=NULL).
#' This overrides other arguments if specified
#' (except firstcat and lastcat which will be applied if requested on this colpath).
#' @param firstcat (`logical`)\cr
#' If you wish to put any category at the top of the list despite any n's, user can specify it here.
#' @param lastcat (`logical`)\cr
#' If you wish to put any category at the bottom of the list despite any n's, user can specify it here.
#' @param cellvalue_index (`integer`)\cr
#' Index of the cell value to perform the scoring on.
#' @export
#' @returns A function which can be used as a score function (scorefun in `sort_at_path`).
# @examples #result <- sort_at_path(result, c('root', 'AEBODSYS'), scorefun = jj_complex_scorefun())
#' @examples
#' library(dplyr)
#' ADAE <- data.frame(
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   AEBODSYS = c(
#'     "SOC 1", "SOC 2", "SOC 1", "SOC 2", "SOC 2",
#'     "SOC 2", "SOC 2", "SOC 1", "SOC 2", "SOC 1"
#'   ),
#'   AEDECOD = c(
#'     "Coded Term 2", "Coded Term 1", "Coded Term 3", "Coded Term 4",
#'     "Coded Term 4", "Coded Term 4", "Coded Term 5", "Coded Term 3",
#'     "Coded Term 1", "Coded Term 2"
#'   ),
#'   TRT01A = c(
#'     "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
#'     "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
#'   ),
#'   TRTEMFL = c("Y", "Y", "N", "Y", "Y", "Y", "Y", "N", "Y", "Y")
#' )
#'
#' ADAE <- ADAE |>
#'   dplyr::mutate(TRT01A = as.factor(TRT01A))
#'
#' ADAE$colspan_trt <- factor(ifelse(ADAE$TRT01A == "Placebo", " ", "Active Study Agent"),
#'   levels = c("Active Study Agent", " ")
#' )
#'
#' ADAE$rrisk_header <- "Risk Difference (%) (95% CI)"
#' ADAE$rrisk_label <- paste(ADAE$TRT01A, paste("vs", "Placebo"))
#'
#' colspan_trt_map <- create_colspan_map(ADAE,
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#'
#' ref_path <- c("colspan_trt", " ", "TRT01A", "Placebo")
#'
#' ADSL <- unique(ADAE |> select(USUBJID, "colspan_trt", "rrisk_header", "rrisk_label", "TRT01A"))
#'
#' lyt <- basic_table() |>
#'   split_cols_by(
#'     "colspan_trt",
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by("TRT01A") |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(
#'     "TRT01A",
#'     labels_var = "rrisk_label",
#'     split_fun = remove_split_levels("Placebo")
#'   ) |>
#'   analyze(
#'     "TRTEMFL",
#'     a_freq_j,
#'     show_labels = "hidden",
#'     extra_args = list(
#'       method = "wald",
#'       label = "Subjects with >=1 AE",
#'       ref_path = ref_path,
#'       .stats = "count_unique_fraction"
#'     )
#'   ) |>
#'   split_rows_by("AEBODSYS",
#'     split_label = "System Organ Class",
#'     split_fun = trim_levels_in_group("AEDECOD"),
#'     label_pos = "topleft",
#'     section_div = c(" "),
#'     nested = FALSE
#'   ) |>
#'   summarize_row_groups(
#'     "AEBODSYS",
#'     cfun = a_freq_j,
#'     extra_args = list(
#'       method = "wald",
#'       ref_path = ref_path,
#'       .stats = "count_unique_fraction"
#'     )
#'   ) |>
#'   analyze(
#'     "AEDECOD",
#'     afun = a_freq_j,
#'     extra_args = list(
#'       method = "wald",
#'       ref_path = ref_path,
#'       .stats = "count_unique_fraction"
#'     )
#'   )
#'
#' result <- build_table(lyt, ADAE, alt_counts_df = ADSL)
#'
#' result
#'
#' result <- sort_at_path(
#'   result,
#'   c("root", "AEBODSYS"),
#'   scorefun = jj_complex_scorefun()
#' )
#'
#' result <- sort_at_path(
#'   result,
#'   c("root", "AEBODSYS", "*", "AEDECOD"),
#'   scorefun = jj_complex_scorefun()
#' )
#'
#' result
#' @rdname complex_scoring_function
#' @aliases jj_complex_scorefun
jj_complex_scorefun <- function(
  spanningheadercolvar = "colspan_trt",
  usefirstcol = FALSE,
  colpath = NULL,
  firstcat = NULL,
  lastcat = NULL,
  cellvalue_index = 1
) {
  paths <- NULL

  function(tt) {
    if (is.null(paths)) {
      paths <<- col_paths(tt)
      if (is.null(colpath)) {
        if (is.na(spanningheadercolvar)) {
          atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
          use_paths <- atrt_paths
          act_trt_lst <- paths[use_paths]
          first_list <- sapply(act_trt_lst, utils::head, 1)
          first_at_value <- utils::head(first_list, n = 1)
          colpath <<- first_at_value
        } else {
          atrt_paths <- vapply(paths, function(pth) pth[[1]] == spanningheadercolvar && pth[[2]] != " ", TRUE)
          use_paths <- atrt_paths
          act_trt_lst <- paths[use_paths]
          last_list <- sapply(act_trt_lst, utils::tail, 1)
          last_at_value <- utils::tail(last_list, n = 1)
          colpath <<- last_at_value
        }

        if (usefirstcol) {
          atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
          use_paths <- atrt_paths
          act_trt_lst <- paths[use_paths]
          first_list <- sapply(act_trt_lst, utils::head, 1)
          first_at_value <- utils::head(first_list, n = 1)
          colpath <<- first_at_value
        }
      }
    }
    unl_cv <- unlist(cell_values(tt, colpath = colpath), use.names = FALSE)
    if (length(unl_cv) < cellvalue_index) {
      score <- NULL
    } else {
      score <- unl_cv[cellvalue_index]
    }

    if (length(score) == 0) {
      score <- 1
    }

    if (!is.null(firstcat)) {
      if (obj_name(tt) == firstcat) {
        score <- Inf
      }
    }
    if (!is.null(lastcat)) {
      if (obj_name(tt) == lastcat) {
        score <- -99999
      }
    }
    if (obj_name(tt) == " ") {
      score <- -Inf
    }

    return(score)
  }
}

#' @name safe_prune_table
#'
#' @title Safely Prune Table With Empty Table Message If Needed
#'
#' @inheritParams rtables::prune_table
#'
#' @param empty_msg (`character(1)`)\cr The message to place in the table
#' if no rows were left after pruning
#'
#' @param spancols (`logical(1)`)\cr Should `empty_msg` be spanned
#' across the table's columns (`TRUE`) or placed in the
#' rows row label (`FALSE`). Defaults to `FALSE` currently.
#'
#' @rdname safe_prune_table
#' @return `tt` pruned based on the arguments, or, if
#' pruning would remove all rows, a TableTree with the
#' same column structure, and one row containing the
#' empty message spanning all columns.
#'
#' @export
#' @examples
#' prfun <- function(tt) TRUE
#'
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_cols_by("STRATA1") |>
#'   split_rows_by("SEX") |>
#'   analyze("AGE")
#' tbl <- build_table(lyt, ex_adsl)
#'
#' safe_prune_table(tbl, prfun)
safe_prune_table <- function(
  tt,
  prune_func = prune_empty_level,
  stop_depth = NA,
  empty_msg = " - No Data To Display - ",
  spancols = FALSE) {
  ret <- prune_table(tt = tt, prune_func = prune_func, stop_depth = stop_depth, depth = 0)
  if (is.null(ret)) {
    ret <- tt[integer(), , keep_titles = TRUE, keep_topleft = TRUE, keep_footers = TRUE]

    if (spancols) {
      ## this will eventually be the only option...
      ret <- sanitize_table_struct(ret, empty_msg = empty_msg)
    } else {
      tree_children(ret) <- list(rrowl(empty_msg, rep(" ", ncol(tt))))
    }
  }
  ret
}

#' @name count_pruner
#'
#' @title Count Pruner
#'
#' @description
#' This is a pruning constructor function which identifies records to be pruned
#' based on the count (assumed to be the first statistic displayed when a compound
#' statistic (e.g., ## / ## (XX.X percent) is presented).
#'
#' @param  count   (`numeric`)\cr count threshold. Function will keep all records strictly greater
#'                 than this threshold.
#' @param  cols    (`character`)\cr column path (character or integer (column indices))
#' @param  cat_include     (`character`)\cr Category to be considered for pruning
#' @param  cat_exclude (`character`)\cr Category to be excluded from pruning
#' @export
#'
#' @examples
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   TRT01P = factor(
#'     c(
#'       "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
#'       "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
#'     )
#'   ),
#'   FASFL = c("Y", "Y", "Y", "Y", "N", "Y", "Y", "Y", "Y", "Y"),
#'   SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
#'   PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
#' )
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT01P") |>
#'   add_overall_col("Total") |>
#'   analyze("FASFL",
#'     var_labels = "Analysis set:",
#'     afun = a_freq_j,
#'     extra_args = list(label = "Full", val = "Y"),
#'     show_labels = "visible"
#'   ) |>
#'   analyze("SAFFL",
#'     var_labels = "Analysis set:",
#'     afun = a_freq_j,
#'     extra_args = list(label = "Safety", val = "Y"),
#'     show_labels = "visible"
#'   ) |>
#'   analyze("PKFL",
#'     var_labels = "Analysis set:",
#'     afun = a_freq_j,
#'     extra_args = list(label = "PK", val = "Y"),
#'     show_labels = "visible"
#'   )
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#'
#' result <- prune_table(
#'   result,
#'   prune_func = count_pruner(cat_exclude = c("Safety"), cols = "Total")
#' )
#'
#' result
#' @rdname count_pruner
#' @returns  Function that can be utilized as pruning function in prune_table.
#'
count_pruner <- function(count = 0, cat_include = NULL, cat_exclude = NULL, cols = c("TRT01A")) {
  colpaths <- NULL

  function(tt) {
    # Do not ever prune the following rows.  a row that should be kept in the table will get the value of FALSE

    if ( # nolint start
      !methods::is(tt, "TableRow") ||
        methods::is(tt, "LabelRow") ||
        obj_label(tt) == " " ||
        (!is.null(cat_include) &&
          !obj_label(tt) %in% cat_include) ||
        (!is.null(cat_exclude) && obj_label(tt) %in% cat_exclude)
    ) { # nolint end
      return(FALSE)
    }

    # Check the remaining rows to see if any meet the specified threshold.

    if (!is.null(cols)) {
      tt <- subset_cols(tt, cols)
    }

    # init return value to FALSE (not remove row)
    remove <- FALSE

    if (is.null(colpaths)) {
      colpaths <<- col_paths(tt)
    }

    # identify non relative risk columns as in rrisk columns first element is not a count, but diff percentage with
    # small total columns and count > 0 (eg count = 1, n per group = 10), you can run into count1 = 1, countpbo =
    # 0, diffpct = 10, this row should not be considered though
    cp_nonrelrisk <- vapply(
      colpaths,
      function(pth) {
        !any(grepl("rrisk", tolower(pth)))
      },
      FUN.VALUE = TRUE
    )

    ## only continue if at least one non relative risk column selected
    if (any(cp_nonrelrisk)) {
      # get cell_values of non rel risk columns
      cell_vals <- cell_values(tt)[cp_nonrelrisk]

      len_cell_vals <- lapply(cell_vals, function(x) {
        length(x)
      })

      if (any(len_cell_vals == 0)) {
        stop("column cell values has not appropriate structure (a column with NULL value).")
      }

      # get count (first element)
      counts <- unlist(
        lapply(cell_vals, function(x) {
          x[[1]]
        }),
        use.names = FALSE
      )

      # check that we do have counts only
      checkmate::assert_integerish(counts)

      keep <- counts > count
      # the row should be kept if at least one column has count above threshold
      keep <- any(keep)

      # pruning function should return TRUE if row has to be removed, ie opposite of keep
      remove <- !keep
    }

    return(remove)
  }
}


#' @name bspt_pruner
#'
#' @title Pruning Function for pruning based on a fraction and/or a difference from the control arm
#'
#' @description
#' This is a pruning constructor function which identifies records to be pruned
#' based on the the fraction from the percentages. In addition to just looking at a
#' fraction within an arm,
#' this function also allows further flexibility to also prune based on a comparison versus the control arm.
#' @param  fraction   (`proportion`)\cr Fraction threshold.
#' Function will keep all records strictly greater
#'                 than this threshold.
#' @param  cols    (`character`)\cr Column path.
#' @param  keeprowtext     (`character`)\cr Row to be excluded from pruning.
#' @param reg_expr (`logical`)\cr Apply keeprowtext as a regular expression (grepl with fixed = TRUE)
#' @param  control        (`character`)\cr Control Group
#' @param  diff_from_control  (`numeric`)\cr Difference from control threshold.
#' @param  only_more_often    (`logical`)\cr TRUE: Only consider when column pct is more often
#' than control. FALSE: Also select a row where column pct is less often than
#' control and abs(diff) above threshold
#'
#' @export
#'
#'
#' @examples
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   TRT01P = c(
#'     "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
#'     "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
#'   ),
#'   FASFL = c("Y", "Y", "Y", "Y", "N", "Y", "Y", "Y", "Y", "Y"),
#'   SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
#'   PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
#' )
#'
#' ADSL <- ADSL |>
#'   dplyr::mutate(TRT01P = as.factor(TRT01P)) |>
#'   dplyr::mutate(SAFFL = factor(SAFFL, c("Y", "N"))) |>
#'   dplyr::mutate(PKFL = factor(PKFL, c("Y", "N")))
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT01P") |>
#'   add_overall_col("Total") |>
#'   split_rows_by(
#'     "FASFL",
#'     split_fun = drop_and_remove_levels("N"),
#'     child_labels = "hidden"
#'   ) |>
#'   analyze("FASFL",
#'     var_labels = "Analysis set:",
#'     afun = a_freq_j,
#'     show_labels = "visible",
#'     extra_args = list(label = "Full", .stats = "count_unique_fraction")
#'   ) |>
#'   split_rows_by(
#'     "SAFFL",
#'     split_fun = remove_split_levels("N"),
#'     child_labels = "hidden"
#'   ) |>
#'   analyze("SAFFL",
#'     var_labels = "Analysis set:",
#'     afun = a_freq_j,
#'     show_labels = "visible",
#'     extra_args = list(label = "Safety", .stats = "count_unique_fraction")
#'   ) |>
#'   split_rows_by(
#'     "PKFL",
#'     split_fun = remove_split_levels("N"),
#'     child_labels = "hidden"
#'   ) |>
#'   analyze("PKFL",
#'     var_labels = "Analysis set:",
#'     afun = a_freq_j,
#'     show_labels = "visible",
#'     extra_args = list(label = "PK", .stats = "count_unique_fraction")
#'   )
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#'
#' result <- prune_table(
#'   result,
#'   prune_func = bspt_pruner(
#'     fraction = 0.05,
#'     keeprowtext = "Safety",
#'     cols = c("Total")
#'   )
#' )
#'
#' result
#' @rdname bspt_pruner
#' @returns  Function that can be utilized as pruning function in prune_table.
#'
bspt_pruner <- function(
  fraction = 0.05,
  keeprowtext = "Analysis set: Safety",
  reg_expr = FALSE,
  control = NULL,
  diff_from_control = NULL,
  only_more_often = TRUE,
  cols = c("TRT01A")) {
  if (is.null(fraction) && is.null(diff_from_control)) {
    stop("At least one of fraction or diff_from_control must be non-NULL.")
  }
  if (!is.null(diff_from_control) && is.null(control)) {
    stop("control must be specified when diff_from_control is not NULL.")
  }

  function(tt) {
    # Do not ever prune the following rows.
    if (!methods::is(tt, "TableRow") || methods::is(tt, "LabelRow")) {
      return(FALSE)
    }

    if (
      reg_expr &&
        any(sapply(keeprowtext, function(x) {
          grepl(x, obj_label(tt), fixed = TRUE)
        }))
    ) {
      return(FALSE)
    }
    if (!reg_expr && obj_label(tt) %in% keeprowtext) {
      return(FALSE)
    }

    # init return value to FALSE (not remove row)
    remove <- FALSE

    # needed later for control column
    tt_all_cols <- tt

    if (!is.null(cols)) {
      tt <- subset_cols(tt, cols)
    }

    colpaths <- col_paths(tt)
    # identify non relative risk columns
    cp_nonrelrisk <- vapply(
      colpaths,
      function(pth) {
        !any(grepl("rrisk", tolower(pth)))
      },
      FUN.VALUE = TRUE
    )

    ## only continue if at least one non relative risk column selected
    if (any(cp_nonrelrisk)) {
      # get rid of rel risk columns (if present)
      cell_vals <- cell_values(tt)[cp_nonrelrisk]

      len_cell_vals <- lapply(cell_vals, function(x) {
        length(x)
      })

      if (any(len_cell_vals < 2)) {
        stop("column cell values has not appropriate structure (less than 2 values in cell).")
      }

      # get count and percentage columns counts in first col pcts in second col
      counts <- unname(lst_slicer(cell_vals, 1, numeric(1)))
      pcts <- unname(lst_slicer(cell_vals, 2, numeric(1)))

      checkmate::check_integerish(counts)
      # similarly check that pcts is indeed a percentage
      if (!all(pcts >= 0 & pcts <= 1)) {
        stop("second value column cell is not a percentage.")
      }

      if (!is.null(fraction)) {
        # avoid problems with FALSE for 0.05 >= 0.05
        check_pcts <- pcts >= fraction |
          vapply(
            pcts,
            function(x) {
              isTRUE(all.equal(x, fraction))
            },
            TRUE
          )
      }

      if (!is.null(diff_from_control)) {
        # get control group from all columns tt (in case the columns selected would not include the control
        # group)
        colpaths0 <- col_paths(subset_cols(tt_all_cols, c(control)))
        cp0_nonrelrisk <- vapply(
          colpaths0,
          function(pth) {
            !any(grepl("rrisk", tolower(pth)))
          },
          FUN.VALUE = TRUE
        )
        colpaths0 <- colpaths0[cp0_nonrelrisk]

        if (length(colpaths0) != 1) {
          stop("control group spec does not result in single column.")
        } else {
          colpaths0 <- colpaths0[[1]]
          # get percent from control group
          pct0 <- cell_values(tt_all_cols, colpath = c(control))[[1]][2]

          if (!(pct0 >= 0 && pct0 <= 1)) {
            stop("second value of control column cell is not a percentage.")
          }
        }

        # check if control group column was also present in main column selector
        colid0 <- which(sapply(colpaths, function(x) {
          all(x == colpaths0)
        }))

        pctdiffs <- pcts - pct0

        # exclude control column from this (would only be relevant if we want to check criteria on all columns
        # rather than any column)
        if (!identical(colid0, integer(0))) pctdiffs <- pctdiffs[-colid0]

        # if not only_more_often be equally strict on worse from control, better as control ie also select rows
        # where column is less often than control pct = 0.07 pct0 = 0.10 (diff = -0.03 )
        if (!only_more_often) pctdiffs <- abs(pctdiffs)

        # avoid problems with FALSE for 0.02 >= 0.02
        check_diffpcts <- pctdiffs >= diff_from_control |
          vapply(
            pctdiffs,
            function(x) {
              isTRUE(all.equal(x, diff_from_control))
            },
            TRUE
          )
      }

      # final step to check if row should be kept in table
      if (!is.null(fraction) && is.null(diff_from_control)) {
        # keep row in table if any column pct above threshold
        keep <- any(check_pcts)
      } else if ((!is.null(fraction) && !is.null(diff_from_control))) {
        # if any column pct above threshold AND any diff pct above threshold note any is used in both
        # expressions separately situation pct = 0.04 pct0 = 0.06 should be kept (fraction = 0.05, abs(diff
        # control) = 0.02) this problem only arises in the non-default situation when only_more_often is FALSE
        # (ie when column pct is less often than control) this would not be the case if we would any(check_pcts
        # & check_diffpcts) as 0.04 is below fraction
        keep <- any(check_pcts) && any(check_diffpcts)
      } else if ((is.null(fraction) && !is.null(diff_from_control))) {
        keep <- any(check_diffpcts)
      }

      # pruning function should return TRUE if row has to be removed, ie opposite of keep
      remove <- !keep
    }

    return(remove)
  }
}

lst_slicer <- function(lst, ind, type) {
  vapply(lst, `[[`, i = ind, type)
}

#' @name remove_rows
#'
#' @title
#' Pruning function to remove specific rows of a table regardless of counts
#' @description
#' This function will remove all rows of a table based on the row text
#' provided by the user.
#' @param  removerowtext  (`character`)\cr Define a text string for which any row with row text will be removed.
#' @param reg_expr (`logical`)\cr Apply removerowtext as a regular expression
#' (grepl with fixed = TRUE)
#' @export
#' @rdname remove_rows
#'
#' @examples
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   TRT01P = c(
#'     "ARMA", "ARMB", "ARMA", "ARMB", "ARMB", "Placebo",
#'     "Placebo", "Placebo", "ARMA", "ARMB"
#'   ),
#'   Category = c(
#'     "Cat 1", "Cat 2", "Cat 1", "Unknown", "Cat 2",
#'     "Cat 1", "Unknown", "Cat 1", "Cat 2", "Cat 1"
#'   ),
#'   SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
#'   PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
#' )
#'
#' ADSL <- ADSL |>
#'   dplyr::mutate(TRT01P = as.factor(TRT01P))
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT01P") |>
#'   analyze(
#'     "Category",
#'     afun = a_freq_j,
#'     extra_args = list(.stats = "count_unique_fraction")
#'   )
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#'
#' result <- prune_table(result, prune_func = remove_rows(removerowtext = "Unknown"))
#'
#' result
#' @aliases remove_rows
#' @returns Function that can be utilized as pruning function in prune_table.
#'
remove_rows <- function(removerowtext = NULL, reg_expr = FALSE) {
  function(tt) {
    if (!methods::is(tt, "TableRow") || methods::is(tt, "LabelRow")) {
      return(FALSE)
    }

    ret <- FALSE
    if (!is.null(removerowtext)) {
      if (!reg_expr) {
        ret <- obj_label(tt) %in% removerowtext
      } else {
        ret <- any(sapply(removerowtext, function(x) {
          grepl(x, obj_label(tt), fixed = TRUE)
        }))
      }
    }

    ret
  }
}

#' @name keep_non_null_rows
#'
#' @title Pruning Function to accommodate removal of completely NULL rows within a table
#'
#' @description
#' Condition function on individual analysis rows. Flag as FALSE when all
#' columns are NULL, as then the row should not be kept. To be utilized as a
#' row_condition in function tern::keep_rows
#'
#' @param  tr      (`TableTree`)\cr The TableTree object to prune.
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' ADSL <- data.frame(
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   TRT01P = c(
#'     "ARMA", "ARMB", "ARMA", "ARMB", "ARMB", "Placebo",
#'     "Placebo", "Placebo", "ARMA", "ARMB"
#'   ),
#'   AGE = c(34, 56, 75, 81, 45, 75, 48, 19, 32, 31),
#'   SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
#'   PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
#' )
#'
#' ADSL <- ADSL |>
#'   mutate(TRT01P = as.factor(TRT01P))
#'
#' create_blank_line <- function(x) {
#'   list(
#'     "Mean" = rcell(mean(x), format = "xx.x"),
#'     " " = rcell(NULL),
#'     "Max" = rcell(max(x))
#'   )
#' }
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT01P") |>
#'   analyze("AGE", afun = create_blank_line)
#'
#' result <- build_table(lyt, ADSL)
#'
#' result
#' result <- prune_table(result, prune_func = tern::keep_rows(keep_non_null_rows))
#'
#' result
#' @rdname keep_non_null_rows
#' @returns A function that can be utilized as a row_condition in the tern::keep_rows function.
#'
keep_non_null_rows <- function(tr) {
  if (methods::is(tr, "DataRow")) {
    r_cellvalue_null <- unlist(lapply(cell_values(tr), is.null))
    check <- all(r_cellvalue_null)

    ### if check TRUE (all cell values NULL -- need to return FALSE as need to remove)
    ret <- !check
  } else {
    ret <- TRUE
  }
  ret
}

#' Conditional proportion with adaptive CI (exact vs. Wald)
#'
#' The analysis function [a_cond_proportion_j()] is used to create a layout
#' element that estimates a response proportion with confidence interval,
#' automatically selecting between exact and Wald methods based on observed
#' counts and user-defined limits.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @details
#' The statistics function mirrors [tern::s_proportion()] usage and output but
#' removes the `method` argument and decides internally between
#' "clopper-pearson" and "wald".
#'
#' The exact method is used when any of these are true:
#' (a) the number of responders is `num_limit` (or less),
#' (b) all subjects except `num_limit` (or less) have observed response,
#' or (c) the observed group size is less than `denom_limit`.
#'
#' Depending on the `method_scope` choice, this decision is either taken
#' based on the response data for an individual cell (`method_scope = "cell"`),
#' or based on the response data for the entire row (`method_scope = "row"`):
#'
#' - With `method_scope = "cell"`, the counts used for the decision are:
#'   - numerator: the number of responders in the current cell;
#'   - denominator: the total number of observations in the cell (using `df`)
#'     if `denom = "n"`, or across the row (using `.df_row`) if `denom = "N_row"`.
#' - With `method_scope = "row"`, the counts used for the decision are:
#'   - numerator: the total number of responders across the row (using `.df_row`);
#'   - denominator: the total number of observations across the row (from `.df_row`).
#'
#' CI computation follows [tern::s_proportion()] conventions: helper functions
#' are called with `n = denom`, so when `denom = "N_row"`, this row-level
#' denominator is used for the interval.
#'
#' @inheritParams proposal_argument_convention
#' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,
#'   it indicates whether each subject is a responder or not. `TRUE` represents
#'   a successful outcome. If a `data.frame` is provided, the logical vector of
#'   responses must be indicated as a variable name in `.var`.
#' @param .var (`string`)
#' @param conf_level (`numeric`)
#' @param denom (`character`)\cr denominator to use for percentage and CI computation:
#'   "n" (default, number of observed records), or "N_row" (number of observations in the row).
#' @param long (`flag`)\cr whether a long description is required.
#' @param na.rm (`flag`)\cr whether `NA` responses should be removed before analysis.
#'   If `FALSE` and `NA` values are present, an error is raised.
#'   Note that missing values are also removed from the row-wise counts
#'   which is relevant when `method_scope = "row"` or `denom = "N_row"`.
#' @param num_limit (`int`)\cr numerator limit to trigger the exact method.
#' @param denom_limit (`int`)\cr denominator limit to trigger the exact method.
#' @param method_scope (`string`)\cr select the CI method using counts from the
#'   current cell (`"cell"`) or all columns in the current row (`"row"`). See details.
#' @param .df_row (`data.frame`)\cr data for the current row across all columns,
#'   automatically supplied by `rtables`.
#' @param method (`string` or `NULL`)\cr selected CI method to show in the
#'   label. `NULL` retains the combined method description.
#' @param method_denom (`int`)\cr denominator used for the selected CI method.
#' @param method_rsp (`int`)\cr numerator used for the selected CI method.
#'
#' @name cond_proportion_j
NULL

#' Helper Function to Extract Count Responders
#'
#' Converts a response vector, or a response column from a data frame, to logical
#' values and returns its responder and observation counts.
#'
#' @param x (`vector` or `data.frame`)\cr Response data.
#' @param .var (`string`)\cr Response column in `x` when `x` is a data frame.
#' @param na.rm (`flag`)\cr Whether to remove missing responses before counting.
#'
#' @return A named list with `rsp` (logical response vector), `n_rsp` (responders) and `len_rsp`
#'   (non-missing observations, when `na.rm = TRUE`).
#'
#' @keywords internal
h_get_rsp_counts <- function(x, .var, na.rm = FALSE) {
  rsp <- if (checkmate::test_atomic_vector(x)) {
    x
  } else {
    tern::assert_df_with_variables(x, list(rsp = .var))
    x[[.var]]
  }
  rsp <- safe_as_logical(rsp, na.rm = na.rm)
  list(rsp = rsp, n_rsp = sum(rsp), len_rsp = length(rsp))
}

#' @describeIn cond_proportion_j Statistics function estimating a proportion
#'   along with its confidence interval, with adaptive method selection.
#'
#' @return
#' * `s_cond_proportion_j()` returns statistics `n_prop` (`n` responders and proportion)
#'   and `prop_ci` (proportion CI), formatted consistently with [tern::s_proportion()].
#'
#' @examples
#' # Logical vector input
#' rsp_v <- c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)
#' s_cond_proportion_j(rsp_v)
#'
#' # Data frame input
#' dta <- data.frame(rsp = c(TRUE, TRUE, FALSE, TRUE, FALSE, NA))
#' s_cond_proportion_j(dta, .var = "rsp", na.rm = TRUE)
#'
#' # Using method_scope = "row" (requires .df_row in ...)
#' df_row <- data.frame(rsp = rep(rsp_v, 2))
#' s_cond_proportion_j(
#'   dta, .var = "rsp", method_scope = "row",
#'   .df_row = df_row, na.rm = TRUE
#' )
#'
#' @export
s_cond_proportion_j <- function(
  df,
  .var,
  conf_level = 0.95,
  long = FALSE,
  na.rm = FALSE,
  num_limit = 0,
  denom_limit = 10,
  denom = c("n", "N_row"),
  method_scope = c("cell", "row"),
  .df_row = NULL
) {
  checkmate::assert_flag(long)
  checkmate::assert_flag(na.rm)
  assert_proportion_value(conf_level)
  checkmate::assert_int(num_limit, lower = 0)
  checkmate::assert_int(denom_limit, lower = 0)
  denom <- match.arg(denom)
  method_scope <- match.arg(method_scope)

  rsp_counts <- h_get_rsp_counts(df, .var, na.rm = na.rm)
  rsp <- rsp_counts[["rsp"]]
  n_obs <- rsp_counts[["len_rsp"]]
  n_rsp <- rsp_counts[["n_rsp"]]

  if (method_scope == "row" || denom == "N_row") {
    row_rsp_counts <- h_get_rsp_counts(.df_row, .var, na.rm = na.rm)
  }
  denom_val <- switch(
    denom,
    n = n_obs,
    N_row = row_rsp_counts[["len_rsp"]]
  )
  assert_int(denom_val, lower = n_obs)
  p_hat <- ifelse(denom_val > 0, n_rsp / denom_val, 0)

  # Define the numerator and denominator used for the CI method selection.
  if (method_scope == "row") {
    method_denom <- row_rsp_counts[["len_rsp"]]
    method_rsp <- row_rsp_counts[["n_rsp"]]
  } else {
    method_denom <- denom_val
    method_rsp <- n_rsp
  }

  use_exact <- (method_denom < denom_limit) ||
    (method_rsp <= num_limit) ||
    (method_rsp >= (method_denom - num_limit))
  method <- if (use_exact) "clopper-pearson" else "wald"

  prop_ci <- switch(
    method,
    "clopper-pearson" = prop_clopper_pearson(rsp, n = denom_val, conf_level),
    "wald" = prop_wald(rsp, n = denom_val, conf_level)
  )

  label <- d_cond_proportion_j(
    conf_level,
    long = long,
    num_limit = num_limit,
    denom_limit = denom_limit,
    method = if (method_scope == "row") method else NULL,
    method_denom = if (method_scope == "row") method_denom else NULL,
    method_rsp = if (method_scope == "row") method_rsp else NULL
  )

  list(
    "n_prop" = formatters::with_label(c(n_rsp, p_hat), "Responders"),
    "prop_ci" = formatters::with_label(
      x = 100 * prop_ci,
      label = label
    )
  )
}

#' @describeIn cond_proportion_j Description helper function for the conditional
#'   proportion summary label.
#'
#' @return
#' * `d_cond_proportion_j()` returns a string describing the analysis label.
#'
#' @examples
#' d_cond_proportion_j(conf_level = 0.90, long = FALSE, num_limit = 0, denom_limit = 10)
#'
#' # With dedicated row-wise method:
#' d_cond_proportion_j(
#'   conf_level = 0.90, long = TRUE, num_limit = 0, denom_limit = 10,
#'   method = "wald", method_denom = 10, method_rsp = 8)
#'
#' @export
d_cond_proportion_j <- function(
  conf_level,
  long = FALSE,
  num_limit = NULL,
  denom_limit = NULL,
  method = NULL,
  method_denom = NULL,
  method_rsp = NULL
) {
  assert_proportion_value(conf_level)
  assert_flag(long)
  assert_string(method, null.ok = TRUE)

  label <- paste0(conf_level * 100, "% CI")

  if (long) {
    label <- paste(label, "for Response Rates")
  }

  method_part <- if (!is.null(method)) {
    assert_choice(method, choices = c("wald", "clopper-pearson"))
    assert_count(num_limit)
    assert_count(denom_limit)
    assert_count(method_denom)
    assert_count(method_rsp)
    reason <- if (method == "wald") {
      paste0("n >= ", denom_limit, ", x = ", method_rsp)
    } else if (method_denom < denom_limit) {
      paste0("n < ", denom_limit)
    } else if (method_rsp <= num_limit) {
      if (num_limit == 0) "x = 0" else paste0("x <= ", num_limit)
    } else if (method_rsp >= (method_denom - num_limit)) {
      if (num_limit == 0) "x = n" else paste0("x >= n - ", num_limit)
    } else {
      stop("Selected Clopper-Pearson method has no matching selection criterion.")
    }
    if (long) {
      switch(
        method,
        "wald" = paste0(
          "Wald because ",
          reason
        ),
        "clopper-pearson" = paste0(
          "Clopper-Pearson because ",
          reason
        )
      )
    } else {
      switch(
        method,
        "wald" = "Wald",
        "clopper-pearson" = "Clopper-Pearson"
      )
    }
  } else if (long) {
    assert_count(num_limit)
    assert_count(denom_limit, positive = TRUE)
    paste0(
      "Wald if n >= ",
      denom_limit,
      ", x > ",
      num_limit,
      ", x < n - ",
      num_limit,
      "; else Clopper-Pearson"
    )
  } else {
    "Wald / Clopper-Pearson"
  }

  paste0(label, " (", method_part, ")")
}

#' @describeIn cond_proportion_j Formatted analysis function which is used as
#'   `afun` for conditional proportion with adaptive CI selection (exact vs. Wald).
#'
#' @return
#' * `a_cond_proportion_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' nex <- 100
#' dta <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
#'   "grp" = sample(c("A", "B"), nex, TRUE),
#'   "f1"  = sample(c("a1", "a2"), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' l <- basic_table() |>
#'   split_cols_by(var = "grp") |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_cond_proportion_j,
#'     extra_args = list(
#'       conf_level = 0.90,
#'       num_limit = 0,
#'       denom_limit = 10
#'     )
#'   )
#'
#' build_table(l, df = dta)
#'
#' @export
#' @order 2
a_cond_proportion_j <- function(
  df,
  .var,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL,
  .df_row = NULL
) {
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_cond_proportion_j,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .df_row = list(.df_row),
      dots_extra_args
    )
  )

  format_stats(
    x_stats,
    method_groups = "estimate_proportion",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

## contribute to formatters
#' @name inches_to_spaces
#' @title Conversion of inches to spaces.
#' @param ins (`numeric`)\cr Vector of widths in inches.
#' @param fontspec (`font_spec`)\cr The font specification to use.
#' @param raw (`logical(1)`)\cr Should the answer be returned unrounded
#'  (`TRUE`), or rounded to the nearest reasonable value (`FALSE`,
#'  the default).
#' @param tol (`numeric(1)`)\cr The numeric tolerance. Values
#'  between an integer `n`, and `n+tol` will be returned
#'  as `n`, rather than `n+1`, if `raw == FALSE`. Ignored
#'  when `raw` is `TRUE`.
#' @return The number of either fractional (`raw = TRUE`) or whole (`raw = FALSE`)
#'   spaces that will fit within `ins` inches in the specified font.
#' @export
inches_to_spaces <- function(ins, fontspec, raw = FALSE, tol = sqrt(.Machine$double.eps)) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  spcw <- grid::convertWidth(grid::unit(1, "strwidth", " "), "inches", valueOnly = TRUE)
  ans <- ins / spcw
  if (!raw) {
    win_tol <- ans - floor(ans) < tol
    ans[win_tol] <- floor(ans)
    ans[!win_tol] <- ceiling(ans)
  }
  ans
}

#' @importFrom formatters wrap_string_ttype
ttype_wrap_vec <- function(vec, fontspec, width, wordbreak_ok = TRUE, ...) {
  lapply(
    vec,
    wrap_string_ttype,
    width = width,
    fontspec = fontspec,
    wordbreak_ok = wordbreak_ok,
    ...
  )
}

#' @name check_wrap_nobreak
#' @title Check Word Wrapping
#' @description Check a set of column widths for word-breaking wrap behavior.
#' @param tt (`TableTree`)\cr TableTree object
#' @param colwidths (`numeric`)\cr Column widths (in numbers of spaces under `fontspec`)
#' @param fontspec (`font_spec`)\cr Font specification object
#'
#' @return `TRUE` if the wrap is able to be done without breaking words,
#' `FALSE` if wordbreaking is required to apply `colwidths`.
#' @rdname check_wrap_nobreak
#' @export
check_wrap_nobreak <- function(tt, colwidths, fontspec) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  mpf <- matrix_form(tt, fontspec = fontspec)
  strs <- mf_strings(mpf)
  colok <- vapply(
    seq_len(ncol(strs)),
    function(i) {
      res <- tryCatch(
        ttype_wrap_vec(strs[, i, drop = TRUE], colwidths[i], fontspec = fontspec, wordbreak_ok = FALSE),
        error = function(e) e
      )
      !methods::is(res, "error")
    },
    TRUE
  )
  all(colok)
}

#' Colwidths for all columns to be forced on one page.
#'
#' @param tt (`TableTree`)\cr TableTree object to calculate column widths for
#' @param fontspec (`font_spec`)\cr Font specification object
#' @param col_gap (`numeric`)\cr Column gap in spaces
#' @param rowlabel_width (`numeric`)\cr Width of row labels in spaces
#' @param print_width_ins (`numeric`)\cr Print width in inches
#' @param landscape (`logical`)\cr Whether the output is in landscape orientation
#' @param lastcol_gap (`logical`)\cr Whether to include a gap after the last column
#' @keywords internal
smart_colwidths_1page <- function(
  tt,
  fontspec,
  col_gap = 6L,
  rowlabel_width = inches_to_spaces(2, fontspec),
  print_width_ins = ifelse(landscape, 11, 8.5) - 2.12,
  landscape = FALSE,
  lastcol_gap = TRUE) {
  total_cpp <- floor(inches_to_spaces(print_width_ins, fontspec = fontspec, raw = TRUE))

  nc <- ncol(tt)
  remain <- total_cpp - rowlabel_width - col_gap * (nc - !lastcol_gap)

  c(rowlabel_width - col_gap, spread_integer(remain, nc))
}

spaces_to_inches <- function(spcs, fontspec) {
  nchar_ttype(" ", fontspec, raw = TRUE) * spcs
}

no_cellwrap_colwidths <- function(tt, fontspec, col_gap = 4L, label_width_ins = 2) {
  if (is.null(col_gap)) {
    col_gap <- 4L
  }
  mpf <- matrix_form(tt, TRUE, FALSE, fontspec = fontspec, col_gap = col_gap)
  strmat <- mf_strings(mpf)
  label_width_max <- inches_to_spaces(label_width_ins, fontspec)

  nchar_mat <- nchar_ttype(strmat[-seq_len(mf_nlheader(mpf)), , drop = FALSE],
    fontspec = fontspec
  )

  label_width <- min(
    label_width_max,
    max(nchar_mat[, 1, drop = TRUE])
  )
  col_maxes <- apply(nchar_mat[, -1, drop = FALSE], 2, max)
  c(label_width, col_maxes + col_gap)
}

pack_into_lines2 <- function(strs, wrdwidths = nchar_ttype(strs), colwidth, fontspec) {
  if (length(wrdwidths) == 0 || (length(wrdwidths) == 1 && wrdwidths <= colwidth)) {
    return(1)
  }
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }

  csums <- cumsum(wrdwidths + c(0, rep(1, length(wrdwidths) - 1)))
  oneline_wdth <- sum(wrdwidths) + length(wrdwidths) - 1
  if (colwidth >= ceiling(oneline_wdth)) {
    return(1)
  }
  lines <- 0
  wrdsused <- 0
  widthused <- 0
  index_seq <- seq_along(wrdwidths)
  totwrds <- length(wrdwidths)
  adj <- 0
  ## finite precision arithmetic is a dreamscape of infinite wonder
  tol <- sqrt(.Machine$double.eps)
  while (wrdsused < length(wrdwidths)) {
    csums_i <- csums - widthused

    fit <- which(index_seq > wrdsused & csums_i <= colwidth + tol)
    widthused <- sum(widthused, wrdwidths[fit], length(fit))
    wrdsused <- wrdsused + length(fit)
    lines <- lines + 1
  }
  lines
}

recursive_add_poss <- function(
  wlst,
  cur_lst,
  ubnd_width,
  lbnd_width,
  ubnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = ubnd_width)$lines,
  lbnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = lbnd_width)$lines,
  fontspec) {
  if (ubnd_width <= lbnd_width + 1 + sqrt(.Machine$double.eps)) {
    return(cur_lst)
  }
  curw <- floor((ubnd_width + lbnd_width) / 2)
  curlnsdf <- calc_total_lns(wlst, fontspec = fontspec, colwidth = curw)
  to_add <- list(curlnsdf)

  if (curlnsdf$lines != lbnd_lines) {
    to_add <- c(
      to_add,
      recursive_add_poss(
        wlst = wlst,
        fontspec = fontspec,
        ubnd_width = curw,
        ubnd_lines = curlnsdf$lines,
        lbnd_width = lbnd_width,
        lbnd_lines = lbnd_lines,
        cur_lst = list()
      )
    )
  }
  if (curlnsdf$lines != ubnd_lines) {
    to_add <- c(
      to_add,
      recursive_add_poss(
        wlst = wlst,
        fontspec = fontspec,
        ubnd_width = ubnd_width,
        ubnd_lines = ubnd_lines,
        lbnd_width = curw,
        lbnd_lines = curlnsdf$lines,
        cur_lst = list()
      )
    )
  }

  c(cur_lst, to_add)
}

calc_total_lns <- function(wlst, colwidth, fontspec, lns_per_pg = 50) {
  lns <- vapply(
    seq_along(wlst),
    function(i) {
      pack_into_lines2(wrdwidths = wlst[[i]], colwidth = colwidth, fontspec = fontspec)
    },
    1
  )
  nonblnks <- !vapply(wlst, function(x) length(x) == 0, TRUE)
  celllns <- lns[-1]
  cllsum <- sum(celllns)
  hdr <- lns[1]
  data.frame(
    colwidth = colwidth,
    lines = cllsum + ceiling(cllsum / lns_per_pg) * hdr,
    cell_lines = cllsum,
    lbl_lines = hdr,
    min_cell_lines = min(1, celllns[nonblnks], na.rm = TRUE),
    max_cell_lines = max(celllns)
  )
}


calc_poss_lines <- function(wlst, lbound, avail_spc, fontspec) {
  minposs <- calc_total_lns(wlst, lbound + avail_spc, fontspec)
  maxposs <- calc_total_lns(wlst, lbound, fontspec)

  retlst <- list(minposs, maxposs)

  retlst <- recursive_add_poss(
    wlst = wlst,
    ubnd_width = lbound + avail_spc,
    lbnd_width = lbound,
    cur_lst = retlst,
    fontspec = fontspec
  )
  do.call(rbind, retlst)
}


make_poss_wdf <- function(
  mpf,
  incl_header = FALSE,
  col_gap = 3,
  pg_width_ins = 8.88,
  fontspec = font_spec("Times", 9, 1.2)) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  if (!methods::is(mpf, "MatrixPrintForm")) {
    mpf <- matrix_form(mpf, fontspec = fontspec, col_gap = col_gap)
  }
  strs <- mf_strings(mpf)
  if (!incl_header) {
    strs <- strs[-seq_len(mf_nlheader(mpf)), ]
  }
  nc <- ncol(strs)
  nr <- nrow(strs)
  ## strip out markup so we are not over countin (by as much)
  strs <- matrix(gsub("~[{[][[:alpha:]]+ ([^]}]+)[]}]", "\\1", strs), ncol = nc, nrow = nr)

  possrows <- lapply(seq_len(ncol(strs)), function(ii) {
    res <- one_col_strs(strs[, ii, drop = TRUE], fontspec = fontspec, col_gap = col_gap)
    res$col_num <- ii
    res
  })

  possdf <- do.call(rbind, possrows)
  o <- order(possdf$col_num, possdf$colwidth)
  possdf <- possdf[o, ]
  possdf
}

#'
#' @param mpf (`listing_df` or `MatrixPrintForm` derived thereof)\cr The listing
#' calculate column widths for.
#' @param incl_header (`logical(1)`)\cr Should the constraint to not break up
#' individual words be extended to words in the column labels? Defaults to `TRUE`
#' @param col_gap (`numeric(1)`)\cr Amount of extra space (in spaces) to
#' assume between columns. Defaults to `0.5`
#' @param pg_width_ins (`numeric(1)`)\cr Number of inches in width for
#'  *the portion of the page the listing will be printed to*. Defaults to `8.88`
#'  which corresponds to landscape orientation on a standard page after margins.
#' @param fontspec (`font_spec`)\cr Defaults to Times New Roman 8pt font with 1.2 line
#' height.
#' @param verbose (`logical(1)`)\cr Should additional information messages be
#' displayed during the calculation of the column widths? Defaults to `FALSE`.
#' @return
#' * `listing_column_widths`: a vector of column widths suitable to use in `tt_to_tlgrtf` and
#' other exporters.
#' @rdname def_colwidths
#' @export
listing_column_widths <- function(
  mpf,
  incl_header = TRUE,
  col_gap = 0.5,
  pg_width_ins = 8.88,
  fontspec = font_spec("Times", 8, 1.2),
  verbose = FALSE) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  possdf <- make_poss_wdf(
    mpf = mpf,
    incl_header = incl_header,
    col_gap = col_gap,
    fontspec = fontspec,
    pg_width_ins = pg_width_ins
  )
  optimal <- optimal_widths(
    possdf = possdf,
    tot_spaces = inches_to_spaces(pg_width_ins, fontspec = fontspec),
    verbose = verbose
  )
  optimal$colwidth
}

find_free_colspc <- function(curposs, fullposs, thresh = 0.99, skip = integer(), verbose = FALSE) {
  orig_curposs <- curposs
  maxlns_ind <- which.max(curposs$cell_lines)
  longestcol <- curposs$col_num[maxlns_ind]
  maxlns <- curposs$cell_lines[maxlns_ind]
  adjrow_inds <- setdiff(which(curposs$cell_lines < thresh * maxlns), skip)
  for (arowi in adjrow_inds) {
    col <- curposs$col_num[arowi]
    colwidthii <- curposs$colwidth[arowi]
    fp_ind <- with(fullposs, min(which(col_num == col & cell_lines <= maxlns & colwidth < colwidthii)))
    if (is.finite(fp_ind)) {
      if (verbose) {
        oldwdth <- curposs$colwidth[arowi]
        newwdth <- fullposs$colwidth[fp_ind]
        msg <- sprintf("adjusting column %d width from %d to %d", col, oldwdth, newwdth)
        message(msg)
      }
      curposs[arowi, ] <- fullposs[fp_ind, ]
    }
  }
  curposs
}

constrict_lbl_lns <- function(curdf, possdf, avail_spc = 0, verbose = TRUE) {
  old_lbl_lns <- max(curdf$lbl_lines)
  cols_to_pack <- which(curdf$lbl_lines == old_lbl_lns)
  olddf <- curdf
  success <- TRUE
  for (ii in cols_to_pack) {
    colii <- curdf$col_num[ii]
    cwidthii <- curdf$colwidth[ii]
    possdfii <- possdf[possdf$col_num == colii & possdf$lbl_lines < old_lbl_lns, ]
    if (nrow(possdfii) == 0) {
      success <- FALSE
      break
    }
    newrow <- possdfii[ii, ]
    if (ii > nrow(possdfii)) {
      success <- FALSE
      break
    }
    if (newrow$colwidth - cwidthii > avail_spc) {
      success <- FALSE
      break
    }
    ## assuming sorted
    curdf[ii, ] <- newrow
    avail_spc <- avail_spc + cwidthii - newrow$colwidth
  }

  if (verbose) {
    if (success) {
      msg <- paste(
        "overall number of label rows successfully reduced. Cols affected: ",
        paste(curdf$col_num[cols_to_pack], collapse = ", ")
      )
    } else {
      msg <- paste("Unable to reduce label rows required.")
    }
  }

  if (!success) {
    curdf <- olddf
  }
  curdf
}

optimal_widths <- function(possdf, tot_spaces = 320, max_lbl_lines = 3, verbose = FALSE) {
  odf <- order(possdf$col_num, possdf$colwidth)
  possdf <- possdf[odf, ]
  badlbl <- which(possdf$lbl_lines > max_lbl_lines)
  if (length(badlbl > 0)) {
    if (verbose) {
      message("Excluding ", length(badlbl), " column widths for labels taking over ", max_lbl_lines, " lines.")
    }
    possdf <- possdf[-badlbl, ]
    possdf <- possdf[possdf$lbl_lines <= max_lbl_lines, , drop = FALSE]
  }
  full_possdf <- possdf
  ## already ordered by colnum then width so this the first of each colwidth is the min width for that col
  dups <- duplicated(possdf$col_num)
  curdf <- possdf[!dups, ]
  possdf <- possdf[dups, ] ## without rows for ones in curdf
  spcleft <- tot_spaces - sum(curdf$colwidth)
  if (verbose) {
    message(
      "Optimizng Column Widths\n",
      "Initial lines required: ",
      max(curdf$lines),
      "\n",
      "Available adjustment: ",
      spcleft,
      " spaces\n"
    )
  }
  done <- FALSE
  while (!done) {
    oldwdths <- curdf$colwidth
    curdf <- constrict_lbl_lns(curdf, possdf, verbose = verbose)
    if (all.equal(curdf$colwidth, oldwdths)) {
      done <- TRUE
    }
  }
  change <- TRUE
  while (spcleft > 0 && change && nrow(possdf) > 0) {
    change <- FALSE
    ii <- which.max(curdf$cell_lines)
    spcleft <- tot_spaces - sum(curdf$colwidth)
    colii <- curdf$col_num[ii]
    bef_lns <- curdf$cell_lines[ii]
    bef_width <- curdf$colwidth[ii]
    nextlns <- max(curdf$cell_lines[-ii])
    cand_row_cond <- possdf$col_num == colii & possdf$cell_lines < bef_lns & possdf$colwidth - bef_width <= spcleft
    canddf <- possdf[cand_row_cond, , drop = FALSE]
    if (nrow(canddf) > 0) {
      more_than_next <- canddf$cell_lines >= nextlns
      if (any(more_than_next)) {
        candrow <- canddf[max(which(more_than_next)), ]
      } else {
        candrow <- canddf[nrow(canddf), ]
      }

      if (verbose) {
        message(
          "COL ",
          colii,
          " width: ",
          bef_width,
          "->",
          candrow$colwidth,
          " lines req: ",
          bef_lns,
          "->",
          candrow$cell_lines
        )
      }
      change <- TRUE
      curdf[ii, ] <- candrow
    }
  }
  curdf
}


one_col_strs <- function(strcol, col_gap = 2, fontspec) {
  strspls <- strsplit(strcol, split = "(-| (?=[^/]))", perl = TRUE)
  strspl_widths <- lapply(strspls, nchar_ttype, fontspec = fontspec, raw = TRUE)
  lbound_raw <- max(unlist(strspl_widths))
  lbound <- ceiling(lbound_raw + 2 * col_gap)
  ret <- calc_poss_lines(strspl_widths, lbound, 50, fontspec = fontspec)
  ret
}



#' @name def_colwidths
#'
#' @title Define Column Widths
#'
#' @description
#' `def_colwidths` uses heuristics to determine suitable column widths given a
#' table or listing, and a font.
#'
#' @param tt input TableTree
#' @param fontspec Font specification
#' @param label_width_ins Label Width in Inches.
#' @param col_gap Column gap in spaces. Defaults to `.5` for listings and `3`
#'   for tables.
#' @param type Type of the TableTree, used to determine column width calculation method.
#'
#' @details Listings are assumed to be rendered landscape on standard A1 paper,
#'   such that all columns are rendered on one page. Tables are allowed to
#'   be horizontally paginated, and column widths are determined based only on
#'   required word wrapping. See the `Automatic Column Widths` vignette for
#'   a detailed discussion of the algorithms used.
#' @return
#' * `def_colwidths`: a vector of column widths (including the label row pseudo-column in the table
#'   case) suitable for use rendering `tt` in the specified font.
#' @export
def_colwidths <- function(tt,
                          fontspec,
                          label_width_ins = 2,
                          col_gap = ifelse(type == "Listing", .5, 3),
                          type = tlg_type(tt)) {
  if (type == "Figure") {
    ret <- NULL
  } else if (type == "Table") {
    if (
      is.list(tt) &&
        !methods::is(tt, "MatrixPrintForm") &&
        !is.null(formatters::mf_col_widths(tt[[1]]))
    ) {
      ret <- formatters::mf_col_widths(tt[[1]])
    } else {
      ret <- no_cellwrap_colwidths(tt, fontspec, col_gap = col_gap, label_width_ins = label_width_ins)
    }
  } else {
    ret <- listing_column_widths(tt, fontspec = fontspec, col_gap = col_gap)
  }
  ret
}

.h_s_eair_diff_scalar <- function(x1,
                                  n1,
                                  x2,
                                  n2,
                                  conf_type = c("wald", "waldcc", "mn", "scas"),
                                  conf_level = 0.95) {
  conf_type <- match.arg(conf_type)
  diff_est <- switch(conf_type,
    waldcc = h_s_eair_diff_wald(x1, n1, x2, n2, conf_level, cc = TRUE),
    wald   = h_s_eair_diff_wald(x1, n1, x2, n2, conf_level, cc = FALSE),
    mn     = h_s_eair_diff_mn(x1, n1, x2, n2, conf_level, skew = FALSE),
    scas   = h_s_eair_diff_mn(x1, n1, x2, n2, conf_level, skew = TRUE)
  )
  list(diff_est = diff_est$est, diff_lcl = diff_est$ci[1], diff_ucl = diff_est$ci[2])
}

h_s_eair_diff <- function(x1,
                          n1,
                          x2,
                          n2,
                          conf_type,
                          conf_level = 0.95) {
  results <- mapply(
    .h_s_eair_diff_scalar,
    x1, n1, x2, n2,
    MoreArgs = list(conf_type = conf_type, conf_level = conf_level),
    SIMPLIFY = FALSE
  )
  data.frame(
    diff_est = sapply(results, `[[`, "diff_est"),
    diff_lcl = sapply(results, `[[`, "diff_lcl"),
    diff_ucl = sapply(results, `[[`, "diff_ucl")
  )
}

h_s_eair_diff_wald <- function(x1, n1, x2, n2, conf_level, cc = TRUE) {
  alpha <- 1 - conf_level
  est <- x1 / n1 - x2 / n2
  se <- sqrt(x1 / n1^2 + x2 / n2^2)

  coeff <- stats::qnorm(1 - alpha / 2)
  term2 <- coeff * se
  if (cc) {
    term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)
  }
  lcl <- est - term2
  ucl <- est + term2

  eair_diff <- list()
  eair_diff$est <- est
  eair_diff$ci <- c(lcl, ucl)
  eair_diff
}

h_s_eair_diff_mn <- function(x1, n1, x2, n2, conf_level, skew = FALSE) {
  alpha <- 1 - conf_level
  z <- stats::qnorm(1 - alpha / 2)

  est <- x1 / n1 - x2 / n2

  lcl <- .conf_poi_rd(x1, n1, x2, n2, z, lower = TRUE, skew = skew, level = conf_level)
  ucl <- .conf_poi_rd(x1, n1, x2, n2, z, lower = FALSE, skew = skew, level = conf_level)

  eair_diff <- list()
  eair_diff$est <- est
  eair_diff$ci <- c(lcl, ucl)
  eair_diff
}

.score_poi_rd <- function(x1, n1, x2, n2, theta, skew = FALSE, level = 0.95) {
  alpha <- 1 - level
  p1hat <- x1 / n1
  p2hat <- x2 / n2
  Stheta <- (p1hat - p2hat) - theta
  if (isTRUE(abs(Stheta) == 0)) {
    return(0)
  }
  x <- x1 + x2
  N <- n1 + n2
  A <- N
  B <- N * theta - x
  C_ <- -x2 * theta
  num <- (-B + sqrt(B^2 - 4 * A * C_))
  p2d <- ifelse(isTRUE(num == 0), 0, num / (2 * A))
  p1d <- p2d + theta
  V <- p1d / n1 + p2d / n2
  score1 <- Stheta / sqrt(V)

  if (!skew) {
    return(score1)
  }

  # Skewness correction (SCAS)
  mu3 <- p1d / (n1^2) - p2d / (n2^2)
  scterm <- mu3 / (6 * V^(3 / 2))
  if (isTRUE(scterm == 0)) {
    return(score1)
  }

  A_q <- scterm
  B_q <- 1
  C_q <- -(score1 + scterm)
  dsct <- B_q^2 - 4 * A_q * C_q
  if (dsct < 0) {
    # Fallback to simplified skewness correction
    qtnorm <- stats::qnorm(1 - alpha / 2)
    score1 <- score1 - (qtnorm^2 - 1) * scterm
  } else {
    score1 <- (-B_q + sqrt(dsct)) / (2 * A_q)
  }

  return(score1)
}

.conf_poi_rd <- function(x1, n1, x2, n2, z, lower = FALSE,
                         skew = FALSE, level = 0.95) {
  p1 <- x1 / n1
  p2 <- x2 / n2
  p_hat <- p1 - p2
  dp <- 1 + ifelse(lower, 1, -1) * p_hat
  i <- 1
  while (i <= 50) {
    dp <- 0.5 * dp
    y <- p_hat + ifelse(lower, -1, 1) * dp
    score <- .score_poi_rd(x1, n1, x2, n2, y, skew = skew, level = level)
    # For lower bound: score decreases as y moves left, find where score = +z
    #   -> move y further left if score > z (still too close to estimate)
    # For upper bound: score decreases as y moves right, find where score = -z
    #   -> move y further right if score > -z (still too close to estimate)
    if (lower) {
      if (score < z) p_hat <- y
    } else {
      if (score > -z) p_hat <- y
    }
    if ((dp < 1e-07) || (abs(score - ifelse(lower, z, -z)) < 1e-06)) {
      break
    } else {
      i <- i + 1
    }
  }
  return(y)
}

#' Get Control Subset
#'
#' Retrieves a subset of the DataFrame based on treatment variable and control group.
#'
#' @param df (`data.frame`)\cr Data frame to subset.
#' @param trt_var (`character`)\cr Treatment variable name.
#' @param ctrl_grp (`character`)\cr Control group value.
#' @return Subset of the data frame.
#' @keywords internal
get_ctrl_subset <- function(df, trt_var, ctrl_grp) {
  df[df[[trt_var]] == ctrl_grp, ]
}


#' Create Alternative Data Frame
#'
#' Creates an alternative data frame based on the current split context.
#'
#' @param .spl_context Current split context.
#' @param .df_row Current data frame row.
#' @param denomdf Denominator data frame.
#' @param denom_by Denominator grouping variable.
#' @param id Identifier variable.
#' @param variables Variables to include in the analysis.
#' @param denom Denominator type.
#' @return Grand parent dataset.
#' @noRd
#' @keywords Internal
h_create_altdf <- function(.spl_context, .df_row, denomdf, denom_by = NULL, id, variables, denom) {
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)
  if (is.null(denomdf) && denom %in% c("N_col") && length(.spl_context$split) > 1 && inriskdiffcol) {
    stop("In order to get correct numbers in relative risk column,
         the alt_counts_df dataset should be passed to build_table")
  }

  ### parent df in the current row-split (all col splits are still in)
  pardf <- .spl_context$full_parent_df[[NROW(.spl_context)]]

  ## if no denomdf defined, use input if you want to use alt_source df, you better pass on the same dataframe as
  ## denomdf in the function call

  colsplit <- .spl_context$cur_col_split[[1]]
  if (length(colsplit) == 1 && tolower(colsplit) == "total") {
    colsplit <- NULL
  }

  if (is.null(denomdf) || denom %in% c("n_df", "n_rowdf")) {
    #### once we have the rtables version >= 0.6.12 -- is.null(denomdf) only will happen when build_table has been
    #### used without alt_counts_df argument denom options c('N_col', 'n_df', 'n_altdf', 'N_colgroup', 'n_rowdf',
    #### 'n_parentdf') note that n_altdf always has a non-null denomdf N_colgroup and n_parentdf will be handled
    #### separately n_parentdf in h_denom_parentdf N_colgroup with h_colexpr_substr

    denomdf <- unique(.df_row[, c(id, variables$strata, colsplit, denom_by), drop = FALSE])
  }

  # grand parent dataset starts of from denomdf -- not yet rowsplits this is for the risk diff columns to include all
  # subjects to start from
  gpardf <- denomdf

  nm_gpardf <- names(gpardf)

  sbgrpvar <- intersect(.spl_context$split, nm_gpardf)

  cursbgrp_value <- NULL

  if (!is.null(denom_by) && length(sbgrpvar) > 0) {
    ### assumption: the subgroup is the first variable in the row-split if this assumption is not valid ---
    ### re-design and let user pass in the subgroup variable
    sbgrpvar <- denom_by[1]
    cur_index <- which(.spl_context$split == sbgrpvar)
    if (length(cur_index) > 0) {
      cursbgrp_value <- .spl_context$value[[cur_index]]

      gpardf <- subset(denomdf, eval(denomdf[[sbgrpvar]] == cursbgrp_value))
    }
    if (length(cur_index) == 0) {
      # cat(paste('sbgrpvar', sbgrpvar)) cat(paste( unique(.spl_context$value), sep = ', '))
    }
  }

  ## note this is a rowsplit only, not yet column split
  return(gpardf)
}

#' No Data to Report String
#'
#' A constant string used when there is no data to display in a table.
#' This is used as a placeholder in tables when no data is available for a particular category.
#'
#' @return A character string with the value "No data to report".
#'
#' @export
#' @keywords internal
no_data_to_report_str <- "No data to report"


#' Update Factor
#'
#' Updates a factor variable in a data frame based on specified values.
#'
#' @param df Data frame containing the variable to update.
#' @param .var Variable name to update.
#' @param val Values to keep.
#' @param excl_levels Levels to exclude from the factor.
#' @return Updated data frame.
#' @noRd
h_update_factor <- function(df, .var, val = NULL, excl_levels = NULL) {
  if (!is.factor(df[[.var]]) || (is.null(val) && is.null(excl_levels))) {
    return(df)
  }

  if ((!is.null(val) && !is.null(excl_levels))) {
    stop("update_factor cannot be used with both val and excl_levels specified.")
  }

  all_levels <- levels(df[[.var]])

  if (!is.null(val)) {
    exclude_levels <- all_levels[!(all_levels %in% val)]
    remaining_levels <- setdiff(all_levels, exclude_levels)
  }
  if (!is.null(excl_levels)) {
    exclude_levels <- all_levels[all_levels %in% excl_levels]
    remaining_levels <- setdiff(all_levels, exclude_levels)
  }

  ## introduce level No data to report
  if (length(remaining_levels) == 0) {
    remaining_levels <- no_data_to_report_str
  }
  df[[.var]] <- factor(as.character(df[[.var]]), levels = remaining_levels)

  return(df)
}


#' Extract Substring from Column Expression
#'
#' Retrieves the substring from a column expression related to a variable component.
#'
#' get substring from col_expr related to var component
#' intended usage is on strings coming from .spl_context$cur_col_expr
#' these strings are of type '!(is.na(var) & var %in% 'xxx') & !(is.na(var2) & var2 %in% 'xxx')'
#'
#' @param var Variable to extract from the expression.
#' @param col_expr Column expression string.
#' @return Substring corresponding to the variable.
#' @noRd
#' @keywords internal
h_colexpr_substr <- function(var, col_expr) {
  # reconstructing the strings is not an option as doesn't work for combined columns facets
  cur_col_expr <- as.character(col_expr)

  if (!grepl(var, cur_col_expr, fixed = TRUE)) {
    return(NULL)
  }

  z2 <- paste0("(!is.na(", var, ") & ", var, " %in%")
  start <- regexpr(z2, cur_col_expr, fixed = TRUE)
  end <- start + attr(start, "match.length") - 1
  z1 <- cbind(start, end)

  ### start of the string
  z1_start <- z1[1, 1]

  ### figure out what is the appropriate end expression has several & in string

  positions <- gregexpr("&", cur_col_expr, fixed = TRUE)
  start <- unlist(positions)
  end <- start + attr(positions[[1]], "match.length") - 1
  z3 <- cbind(start, end)[, 1]

  ### get the first & after the end of z3 ((!is.na(TRT01A) & TRT01A %in%)
  h <- z3 > z1[, 2]
  if (any(h)) {
    z4 <- which.max(h)
    z1_end <- z3[z4] - 3
  } else {
    z1_end <- nchar(cur_col_expr)
  }

  col_expr_substr <- substr(cur_col_expr, z1_start, z1_end)

  return(col_expr_substr)
}

#' Get Denominator Parent Data Frame
#'
#' Retrieves the parent data frame based on denominator.
#'
#' @param .spl_context Current split context.
#' @param denom Denominator type.
#' @param denom_by Denominator grouping variable.
#' @return Parent data frame.
#' @noRd
#' @keywords internal
h_denom_parentdf <- function(.spl_context, denom, denom_by) {
  if (denom != "n_parentdf") {
    return(NULL)
  }
  if (is.null(denom_by)) {
    stop("denom_by must be specified when using denom = 'n_parentdf'.")
  }
  split <- .spl_context$split
  if (split[1] == "root" && !is.null(denom_by)) {
    denom_by <- c("root", denom_by)
  }
  split <- intersect(denom_by, split)
  parentdf <- .spl_context$full_parent_df[[length(split)]]
  return(parentdf)
}

#' Add New Levels to Data Frame
#'
#' Adds new factor levels to a specified variable in the data frame.
#'
#' @param df Data frame to update.
#' @param .var Variable to which new levels will be added.
#' @param new_levels List of new levels to add.
#' @param addstr2levs String to add to new levels.
#' @param new_levels_after Boolean, indicating if new levels should be added after existing levels.
#' @return Updated data frame.
#' @noRd
#' @keywords internal
h_df_add_newlevels <- function(df, .var, new_levels, addstr2levs = NULL, new_levels_after) {
  varvec <- df[[.var]]

  levs <- if (is.factor(varvec)) levels(varvec) else sort(unique(varvec))

  if (!is.null(new_levels)) {
    ## assumption: new_levels[[1]] : names of the new levels new_levels[[2]] : values of the new levels
    if (length(new_levels[[1]]) != length(new_levels[[2]])) {
      stop(
        "new_levels must be a list of length 2, second element must be a ",
        "list of same length as first element."
      )
    }
    if (any(duplicated(unlist(new_levels[[2]])))) {
      stop(
        "unlist(new_levels[[2]]) contains duplicates: duplicate assignment ",
        "of a level to a new level is not allowed."
      )
    }

    sortnewlevs <- unlist(lapply(X = new_levels[[2]], FUN = function(x) {
      min(which(levs %in% x)) - 0.1
    }))

    if (new_levels_after) {
      sortnewlevs <- unlist(lapply(X = new_levels[[2]], FUN = function(x) {
        max(which(levs %in% x)) + 0.1
      }))
    }

    newlevs <- c(levs, new_levels[[1]])
    sortx <- c(seq_along(levs), sortnewlevs)

    newlevsx <- newlevs[order(sortx)]

    levs <- newlevsx

    ### add newlevels to df
    for (i in seq_along(new_levels[[1]])) {
      levii <- unlist(new_levels[[2]][i])

      addi <- df[df[[.var]] %in% levii, ]
      addi[[.var]] <- new_levels[[1]][i]

      df <- rbind(df, addi)
    }
  }

  levlabels <- levs
  if (!is.null(addstr2levs)) {
    levlabels <- paste0(levs, addstr2levs)
  }

  df[[.var]] <- factor(as.character(df[[.var]]), levels = levs, labels = levlabels)

  return(df)
}

#' @title Get Current Treatment Group
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Retrieves the current treatment group from the current column split-path,
#' given the treatment variable name.
#'
#' @param trt_var (`character(1)`)\cr The treatment variable name.
#' @param .spl_context (`data.frame`)\cr The current split context.
#' @return A character string containing the treatment group name.
#'
#' @keywords internal
#' @author WW
#' @seealso [cur_col_split_path()]
#' @examples
#' \dontrun{
#' .spl_context <- data.frame(
#'   cur_col_split = I(list(c("ARM"))),
#'   cur_col_split_val = I(list(c("Placebo")))
#' )
#'
#' h_get_cur_trt_grp("ARM", .spl_context)
#' h_get_cur_trt_grp("TRT", .spl_context) # errors: TRT not found
#' }
#'
h_get_cur_trt_grp <- function(trt_var, .spl_context) {
  checkmate::assert_string(trt_var)
  checkmate::assert_data_frame(.spl_context)

  cur_col_path <- cur_col_split_path(.spl_context)
  checkmate::assert_true(length(cur_col_path) %% 2L == 0L)

  trt_var_pos <- strict_match(trt_var, cur_col_path, odd = TRUE)
  cur_col_path[trt_var_pos + 1L]
}

# helper function to define expression for retrieving ref_group type of datasets
h_get_ref_col_expr <- function(ref_path = NULL) {
  if (is.null(ref_path)) {
    stop("h_get_ref_col_expr: ref_path cannot be NULL")
  }
  checkmate::assert_character(ref_path, min.len = 2L, names = "unnamed")
  checkmate::assert_true(length(ref_path) %% 2 == 0)

  vars <- ref_path[seq(from = 1L, to = length(ref_path) - 1L, by = 2L)]
  levels <- ref_path[seq(from = 2L, to = length(ref_path), by = 2L)]

  parts <- paste0(
    "!is.na(", vars, ") & (", vars, " %in% c(\"", levels, "\"))"
  )

  res <- paste(parts, collapse = " & ")
  call_expr <- parse(text = res)[[1]]

  as.expression(call_expr)
}

get_ref_info_expanded <- function(df,
                                  .var,
                                  .df_row,
                                  .spl_context,
                                  ref_path,
                                  riskdiff = TRUE,
                                  riskdiff_setup = c("horizontal", "vertical")) {
  riskdiff_setup <- match.arg(riskdiff_setup)

  if (riskdiff && is.null(ref_path)) {
    stop("ref_path cannot be NULL when riskdiff = TRUE, please specify it. See ?get_ref_info for details.")
  }

  ## prepare for column based split
  cur_col_expr <- .spl_context$cur_col_expr[[1]]
  ## colid can be used to figure out if we're in the relative risk columns or not
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (!is.null(ref_path)) {
    ref <- get_ref_info(ref_path, .spl_context)
    .in_ref_col <- ref$in_ref_col
    .ref_group <- ref$ref_group
    ref_col_expr <- h_get_ref_col_expr(ref_path)
  } else {
    ref_col_expr <- NULL
    .in_ref_col <- NULL
    .ref_group <- NULL
  }

  # !perform_vs_ref_stats will be passed as .in_ref_col in the s_function s_eair100_levii_j
  # while it does not entirely reflect
  # whether in ref column or not
  # it is the behaviour of performing vs ref group calculations what is important
  if (riskdiff && riskdiff_setup == "vertical" && is.null(.in_ref_col)) {
    perform_vs_ref_stats <- FALSE
  } else if (riskdiff && riskdiff_setup == "vertical" && is.logical(.in_ref_col)) {
    perform_vs_ref_stats <- !.in_ref_col
  } else if (
    riskdiff &&
      riskdiff_setup == "horizontal" &&
      inriskdiffcol &&
      !identical(df, subset(.df_row, eval(ref_col_expr)))
  ) {
    perform_vs_ref_stats <- TRUE
  } else {
    perform_vs_ref_stats <- FALSE
  }
  return(list(
    .in_ref_col = .in_ref_col,
    .ref_group = .ref_group,
    perform_vs_ref_stats = perform_vs_ref_stats,
    ref_col_expr = ref_col_expr
  ))
}

#' Update Data Frame Row
#'
#' Updates a row in the data frame based on various parameters.
#'
#' @param df_row Data frame row to update.
#' @param .var Variable name to update.
#' @param val Values to keep.
#' @param excl_levels Levels to exclude from the factor.
#' @param drop_levels Boolean, indicating if levels should be dropped.
#' @param new_levels New levels to add.
#' @param new_levels_after Boolean, indicating if new levels should be added after existing levels.
#' @param addstr2levs String to add to new levels.
#' @param label Label string.
#' @param label_map Mapping for labels.
#' @param labelstr Label string to replace.
#' @param label_fstr Format string for labels.
#' @param .spl_context Current split context.
#' @return List containing updated data frames and values.
#' @noRd
#' @keywords internal
h_upd_dfrow <- function(
  df_row,
  .var,
  val,
  excl_levels,
  drop_levels,
  new_levels,
  new_levels_after,
  addstr2levs,
  label,
  label_map,
  labelstr,
  label_fstr,
  .spl_context
) {
  if (!is.null(label) && !is.null(label_map)) {
    stop("a_freq_j: label and label_map cannot be used together.")
  }

  if (!is.null(labelstr) && (!is.null(val) || !is.null(new_levels) || !is.null(excl_levels))) {
    stop("a_freq_j: val/excl_levels/new_levels cannot be used in a summarize_row_group call.")
  }

  if (!is.null(new_levels) && (is.null(.var) || is.na(.var))) {
    stop("When using new_levels, var must be provided in analyze call with a_freq_j.")
  }

  if (!is.null(val) && drop_levels == TRUE) {
    stop("argument val cannot be used together with drop_levels = TRUE.")
  }

  if (!is.null(val) && !is.null(excl_levels)) {
    stop("argument val and excl_levels cannot be used together.")
  }

  ## start making updates to factor information on incoming data

  if (!is.null(new_levels)) {
    df_row <- h_df_add_newlevels(
      df = df_row,
      .var = .var,
      new_levels = new_levels,
      new_levels_after = new_levels_after,
      addstr2levs = addstr2levs
    )
  }

  # if character var turn incoming data into factor, with levels from row-based df
  if (!is.na(.var) && is.character(df_row[[.var]]) && is.null(labelstr)) {
    levels <- sort(unique(df_row[[.var]]))
    df_row[[.var]] <- factor(df_row[[.var]], levels = levels)
    drop_levels <- FALSE
  }

  if (!is.null(labelstr)) {
    single_level <- labelstr

    if (!is.null(label_fstr) && grepl("%s", label_fstr, fixed = TRUE)) {
      single_level <- sprintf(label_fstr, single_level)
    }

    df_row[[.var]] <- as.character(df_row[[.var]])
    df_row[[.var]][!is.na(df_row[[.var]])] <- single_level

    df_row[[.var]] <- factor(as.character(df_row[[.var]]), levels = single_level)
    drop_levels <- FALSE
  }

  if (drop_levels) {
    obs_levs <- unique(df_row[[.var]])
    obs_levs <- intersect(levels(df_row[[.var]]), obs_levs)

    if (!is.null(excl_levels)) obs_levs <- setdiff(obs_levs, excl_levels)

    val <- obs_levs
    excl_levels <- NULL
  }

  if (is.null(val) && !is.null(label_map)) {
    split_info <- .spl_context[c("split", "value")]
    val <- h_restrict_val(df_row, .var, label_map, split_info)
  }

  if (!is.null(val)) {
    # do not yet restrict to val levels, only update factors to the requested levels df_row <-
    df_row <- h_update_factor(df_row, .var, val)
  }
  if (!is.null(excl_levels)) {
    # do not yet exclude the level specified in excl_levels, only update factors to remove requested levels df_row

    df_row <- h_update_factor(df_row, .var, excl_levels = excl_levels)
    val <- levels(df_row[[.var]])
  }

  ## update data with level coming from label -- important that this is done after restriction to val levels!!!
  if (!is.null(label)) {
    # similar to processing when labelstr
    single_level <- label
    df_row[[.var]] <- as.character(df_row[[.var]])
    df_row[[.var]][!is.na(df_row[[.var]])] <- single_level
    val <- label
    df_row[[.var]] <- factor(df_row[[.var]], levels = single_level)
  }

  # now update labels coming from label_map
  if (!is.null(label_map)) {
    split_info <- .spl_context[c("split", "value")]
    new_labels <- h_get_label_map(levels(df_row[[.var]]), label_map, .var, split_info)

    df_row[[.var]] <- factor(as.character(df_row[[.var]]), levels = levels(df_row[[.var]]), labels = new_labels)

    val <- new_labels
  }

  # now apply the updated factors from df_row to df as well due to drop_levels = TRUE can have different results when
  # applying all of the above to df
  col_expr <- .spl_context$cur_col_expr[[1]]
  df <- subset(df_row, eval(col_expr))

  return(list(df_row = df_row, df = df, val = val))
}


#' Get Label Map
#'
#' Maps labels based on the provided label map and split context.
#'
#' @param .labels Current labels.
#' @param label_map Mapping for labels.
#' @param .var Variable name.
#' @param split_info Current split information.
#' @return Mapped labels.
#' @noRd
#' @keywords internal
h_get_label_map <- function(.labels, label_map, .var, split_info) {
  if (!is.null(label_map)) {
    if (!all(c("split", "value") %in% names(split_info))) {
      stop("split_info does not contain required elements.")
    }

    nodata <- FALSE
    if (length(.labels) == 1 && .labels == no_data_to_report_str) {
      nodata <- TRUE
    }

    ### if label_map has a variable from row split, apply current splits on label_map tibble as well
    rowsplits <- split_info$split

    label_map_split <- intersect(names(label_map), rowsplits)

    if (!(length(label_map_split) == 0)) {
      for (i in seq_along(label_map_split)) {
        cursplvar <- label_map_split[i]
        cid <- match(cursplvar, rowsplits)
        cursplval <- split_info$value[cid]

        label_map <- label_map[label_map[[cursplvar]] == cursplval, ]
      }
    }

    if ("var" %in% names(label_map)) {
      label_map <- label_map[label_map[["var"]] == .var, ]
    }

    .labels <- label_map$label[match(.labels, label_map$value)]

    if (nodata && anyNA(.labels)) {
      stop(paste0(
        "got a label map that doesn't provide labels for all values.\n",
        "Perhaps convert analysis variable ", .var, " to a factor?"
      ))
    }
    if (anyNA(.labels)) {
      stop("got a label map that doesn't provide labels for all values.")
    }
  }

  return(.labels)
}


#' A Frequency Data Preparation Function
#'
#' Prepares frequency data for analysis.
#' @noRd
#' @param df Data frame to prepare.
#' @param labelstr Label string.
#' @param .var Variable name.
#' @param val Values for analysis.
#' @param drop_levels Boolean, indicating if levels should be dropped.
#' @param excl_levels Levels to exclude.
#' @param new_levels New levels to add.
#' @param new_levels_after Boolean for adding new levels after existing ones.
#' @param addstr2levs String to add to new levels.
#' @param .df_row Current data frame row.
#' @param .spl_context Current split context.
#' @param .N_col Number of columns.
#' @param id Identifier variable.
#' @param denom Denominator types.
#' @param variables Variables to include in the analysis.
#' @param label Label string.
#' @param label_fstr Formatted label string.
#' @param label_map Mapping for labels.
#' @param .alt_df_full Alternative full data frame.
#' @param denom_by Denominator grouping variable.
#' @param .stats Statistics to compute.
#' @return List containing prepared data frames and values.
h_a_freq_dataprep <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  drop_levels = FALSE,
  excl_levels = NULL,
  new_levels = NULL,
  new_levels_after = FALSE,
  addstr2levs = NULL,
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "N_colgroup", "n_rowdf", "n_parentdf"),
  variables,
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats,
  countsource = c("df", "altdf", "altdf_subset")
) {
  denom <- match.arg(denom)

  df <- df[!is.na(df[[.var]]), ]
  .df_row <- .df_row[!is.na(.df_row[[.var]]), ]

  # if no stats requested, get all stats
  .stats <- junco_get_stats("a_freq_j", stats_in = .stats, custom_stats_in = NULL)

  ### combine all preprocessing of incoming df/.df_row in one function do this outside stats derivation functions
  ### (s_freq_j/) use all of val/excl_levels/drop_levels//new_levels/ label/label_map/labelstr/label_fstr
  upd_dfrow <- h_upd_dfrow(
    df_row = .df_row,
    .var = .var,
    val = val,
    excl_levels = excl_levels,
    drop_levels = drop_levels,
    new_levels = new_levels,
    new_levels_after = new_levels_after,
    addstr2levs = addstr2levs,
    label = label,
    label_map = label_map,
    labelstr = labelstr,
    label_fstr = label_fstr,
    .spl_context = .spl_context
  )

  .df_row <- upd_dfrow$df_row
  df <- upd_dfrow$df

  val <- upd_dfrow$val

  # from here onwards proceed with drop_levels = FALSE action has already been done in h_upd_dfrow, and proper
  # observed values will be passed to val for s_freq_j
  drop_levels <- FALSE
  excl_levels <- NULL

  ### derive appropriate alt_df based upon .spl_context and .alt_df_full note that only row-based splits are done for
  ### now only for variables from the first split_rows_by
  alt_df <- h_create_altdf(
    .spl_context,
    .df_row,
    .alt_df_full,
    denom_by = denom_by,
    id = id,
    variables = variables,
    denom = denom
  )

  if (identical(countsource, "altdf_subset")) {
    # prefer explicit val, otherwise use the levels present in .df_row.
    if (!is.null(alt_df) && !is.na(.var) && (.var %in% names(alt_df))) {
      keep_vals <- NULL
      if (!is.null(val)) {
        keep_vals <- val
      } else if (!is.null(.df_row) && !is.null(.df_row[[.var]])) {
        keep_vals <- if (is.factor(.df_row[[.var]])) levels(.df_row[[.var]]) else unique(.df_row[[.var]])
      }

      if (!is.null(keep_vals)) {
        keep_vals <- intersect(keep_vals, unique(alt_df[[.var]]))
        if (length(keep_vals) > 0) {
          alt_df <- alt_df[alt_df[[.var]] %in% keep_vals, , drop = FALSE]
          alt_df <- h_update_factor(alt_df, .var, keep_vals)
        }
      }
    }
  }
  new_denomdf <- alt_df

  parentdf <- h_denom_parentdf(.spl_context, denom, denom_by)
  if (denom == "n_parentdf") {
    new_denomdf <- parentdf
  }

  return(list(
    df = df,
    .df_row = .df_row,
    val = val,
    drop_levels = drop_levels,
    excl_levels = excl_levels,
    alt_df = alt_df,
    parentdf = parentdf,
    new_denomdf = new_denomdf,
    .stats = .stats
  ))
}


#' Frequency Preparation in Rows
#'
#' Prepares frequency data in rows based on provided parameters.
#' @noRd
#' @param x_stats Statistics data.
#' @param .stats_adj Adjusted statistics.
#' @param .formats Format settings.
#' @param labelstr Label string.
#' @param label_fstr Formatted label string.
#' @param label Label string.
#' @param .indent_mods Indentation settings.
#' @param .labels_n Labels for statistics.
#' @param na_str String for NA values.
#' @return List containing prepared statistics, formats, labels, and indentation.
#' @noRd
#' @keywords internal
h_a_freq_prepinrows <- function(
  x_stats,
  .stats_adj,
  .formats,
  labelstr,
  label_fstr,
  label,
  .indent_mods,
  .labels_n,
  na_str
) {
  # Fill in formatting defaults

  x_stats <- x_stats[.stats_adj]

  levels_per_stats <- lapply(x_stats, names)

  # Fill in formats/indents/labels with custom input and defaults
  .formats <- junco_get_formats_from_stats(.stats_adj, .formats, levels_per_stats)

  # lbls
  all_stats <- junco_get_stats("a_freq_j", stats_in = NULL, custom_stats_in = NULL)
  count_rr_stats <- grep("(count|rr_ci)", all_stats, value = TRUE)
  n_stats <- setdiff(all_stats, count_rr_stats)
  n_stats <- .stats_adj[.stats_adj %in% n_stats]

  if (length(.stats_adj) == 1 && length(n_stats) == 1) {
    if (!is.null(labelstr) && (!is.null(label))) {
      lbls <- label
    } else if (!is.null(labelstr) && !is.null(.labels_n)) {
      lbls <- .labels_n
    } else if (!is.null(labelstr) && is.null(label_fstr)) {
      lbls <- labelstr
    } else if (!is.null(labelstr) && !is.null(label_fstr) && grepl("%s", label_fstr, fixed = TRUE)) {
      lbls <- sprintf(label_fstr, labelstr)
    } else if (!is.null(label)) {
      lbls <- label
    } else {
      .labels <- .labels_n
      lbls <- junco_get_labels_from_stats(.stats_adj, .labels, levels_per_stats)
    }
  } else {
    if (length(n_stats) > 1 && is.null(.labels_n)) {
      msg <- paste0(
        "recommend to specify non-null .labels_n argument when multiple n_stats selected (",
        paste0(n_stats, collapse = ", "),
        ")"
      )
      message(msg)
    }
    ### labels from the non n-stat statistics are present on levels_per_stats labels for the n-stat statistics come
    ### from .labels_n (user) or from defaults
    .labels <- .labels_n
    lbls <- junco_get_labels_from_stats(.stats_adj, .labels, levels_per_stats)
  }
  .labels <- lbls
  .labels <- .unlist_keep_nulls(.labels)

  # indents
  .indent_mods_orig <- .indent_mods
  .indent_mods <- junco_get_indents_from_stats(.stats_adj, .indent_mods, levels_per_stats)

  # adjust indents when n_stat is included and no indents where passed by user
  if (length(n_stats) >= 1 && is.null(.indent_mods_orig)) {
    .indent_mods_new <- sapply(
      names(.indent_mods),
      FUN = function(x) {
        ret <- 0
        if (!(x %in% n_stats)) ret <- 1
        return(ret)
      },
      simplify = FALSE,
      USE.NAMES = TRUE
    )
    .indent_mods <- .indent_mods_new
  }

  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  # .format_na_strs processing if na_str = c(NA, NA, NA) this will ensure the ci (NA, NA, NA) will be represented as
  # NE (NE, NE) the value NE is defined as the default to replace NA in our jjcs format

  if (!is.null(na_str)) {
    # Create a list of na_str values for each format in .formats
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
    names(.format_na_strs) <- names(.formats)
  } else {
    .format_na_strs <- NULL
  }

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  return(list(
    x_stats = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  ))
}

#' Subset Combination
#'
#' Subsets a data frame based on specified combination criteria.
#' @noRd
#' @param df Data frame to subset.
#' @param combosdf Data frame containing combinations.
#' @param do_not_filter Variables to not filter.
#' @param filter_var Variable used for filtering.
#' @param flag_var Flag variable for filtering.
#' @param colid Column ID for identification.
#' @return Subsetted data frame.
h_subset_combo <- function(df, combosdf, do_not_filter, filter_var, flag_var, colid) {
  ### this is the core code for subsetting to appropriate combo level
  if (!is.null(flag_var)) {
    df <- df[df[[flag_var]] %in% "Y", ]
  }

  # get the string related to combosdf text from colid it is the last part of the column id after the .  eg 'Active
  # Study Agent.Xanomeline High Dose.Thru 3 months' colid_str is 'Thru 3 months'
  # colid_str <- stringr::str_split_i(colid,
  # '\\.', i = -1)
  colid_str <- tail(unlist(strsplit(colid, "\\.")), 1)

  filter_val <- combosdf[combosdf$valname == colid_str, ]$label

  if (!(colid_str %in% do_not_filter)) {
    df <- df[df[[filter_var]] %in% filter_val, ]
  }

  return(df)
}

#' @noRd
#' @param df_row Data frame row to update.
#' @param .var Variable name.
#' @param label_map Mapping for labels.
#' @param split_info Current split information.
#'
#' @return Restriction of val to appropriate levels from `label_map`.
h_restrict_val <- function(df_row, .var, label_map, split_info) {
  val <- NULL
  xval_row <- unique(df_row[[.var]])
  xval_map <- label_map$value

  diff <- setdiff(xval_row, xval_map)

  if (length(diff) == 0) {
    # If label_map has a variable from row split, apply
    # current splits on label_map tibble as well.
    rowsplits <- split_info$split

    label_map_split <- intersect(names(label_map), rowsplits)

    if (length(label_map_split) != 0) {
      for (i in seq_along(label_map_split)) {
        cursplvar <- label_map_split[i]
        cid <- match(cursplvar, rowsplits)
        cursplval <- split_info$value[cid]

        label_map <- label_map[label_map[[cursplvar]] == cursplval, ]
      }
    }

    if ("var" %in% names(label_map)) {
      label_map <- label_map[label_map[["var"]] == .var, ]
    }

    val <- label_map$value
  }
  val
}

#' @noRd
#' @param denom_df denominator dataframe for relative risk calculation
#' @param trt_var variable used as treatment variable
#' @param cur_trt_grp current treatment group level
#' @param .spl_context Current split context.
#'
#' @return Denominator dataframe with updated treatment variable to current treatment group level if this was
#' coming from a combined facet
#'
upd_denom_df_combo <- function(
  denom_df,
  trt_var,
  cur_trt_grp,
  .spl_context
) {
  # check if we are in a combo facet, trt_var in that facet is not the same as in denom_df
  in_combo <- !(cur_trt_grp %in% unique(denom_df[[trt_var]]))
  if (in_combo) {
    colexpr_substr_combo <- h_colexpr_substr(trt_var, .spl_context$cur_col_expr[[1]])
    # adjust denom_df to update values of trt_var to reflect the combo value as in df
    y1 <- subset(denom_df, eval(parse(text = colexpr_substr_combo)))
    y1[[trt_var]] <- cur_trt_grp
    y2 <- subset(denom_df, eval(parse(text = paste0("!", colexpr_substr_combo))))
    denom_df <- rbind(y1, y2)
  }
  denom_df
}

#' @title Analysis Function: Sum and Ratio of Sums
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Computes one or more of the following statistics for use with
#' [rtables::analyze()]:
#' - `"sum"`: `sum(.var)`
#' - `"sum_unique"`: `sum(.var)` after keeping unique rows by `id_var`
#' - `"ratio"`: `sum(.var) / sum(denom_by)`
#' - `"ratio_unique"`: same ratio after keeping unique rows by `id_var`
#'
#' Both `.var` and `denom_by` columns must be numeric (integer, double, or
#' logical coerced to numeric).
#'
#' @inheritParams proposal_argument_convention
#' @param .stats (`character`)\cr one or more of `"sum"`, `"sum_unique"`,
#'   `"ratio"`, `"ratio_unique"`. Default: `"sum"`.
#' @param denom_by (`string` or `NULL`)\cr denominator column; required for
#'   `"ratio"` and `"ratio_unique"`.
#' @param id_var (`string` or `NULL`)\cr subject-id column for unique row selection;
#'   required for `"sum_unique"` and `"ratio_unique"`.
#' @param .indent_mods (named `integer` or `NULL`)\cr indent modifiers for the
#'   row labels. Defaults to `NULL` (no modification).
#' @param na_str (`character` or `NULL`)\cr string(s) used to replace `NA`
#'   values in the formatted output. Defaults to `NULL` (no replacement).
#'
#' @return A `RowsVerticalSection` for use by rtables.
#'
#' @author VR
#'
#' @importFrom rtables in_rows
#' @export
#'
#' @examples
#' df <- data.frame(
#'   USUBJID = c("S01", "S01", "S02", "S03"),
#'   ARM     = factor(c("A", "A", "A", "B")),
#'   EVENTS  = c(1, 1, 0, 1),
#'   DAYS    = c(10, 10, 20, 15)
#' )
#'
#' # All 4 stats in a layout (S01 duplicate tests unique logic)
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   analyze(
#'     "EVENTS",
#'     afun = a_sum_ratio_j,
#'     extra_args = list(
#'       .stats   = c("sum", "sum_unique", "ratio", "ratio_unique"),
#'       denom_by = "DAYS",
#'       id_var   = "USUBJID"
#'     )
#'   )
#'
#' build_table(lyt, df)
a_sum_ratio_j <- function(
  df,
  .var,
  .stats = "sum",
  denom_by = NULL,
  id_var = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL,
  na_str = NULL,
  ...
) {
  # Data Validation ------------------------------------------------------------
  valid_stats <- c("sum", "sum_unique", "ratio", "ratio_unique")

  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df), must.include = .var)
  checkmate::assert_numeric(df[[.var]], .var.name = .var)
  checkmate::assert_subset(.stats, choices = valid_stats)

  needs_ratio <- any(.stats %in% c("ratio", "ratio_unique"))
  needs_unique <- any(.stats %in% c("sum_unique", "ratio_unique"))

  if (needs_ratio) {
    checkmate::assert_string(denom_by)
    checkmate::assert_names(colnames(df), must.include = denom_by)
    checkmate::assert_numeric(df[[denom_by]], .var.name = denom_by)
  }
  if (needs_unique) {
    checkmate::assert_string(id_var)
    checkmate::assert_names(colnames(df), must.include = id_var)
  }

  # Helper funcs -----------------------------------------------
  sum_plain <- function(v) {
    sum(df[[v]], na.rm = TRUE)
  }

  sum_unique <- function(v) {
    d <- unique(df[!is.na(df[[v]]), c(id_var, v), drop = FALSE])
    sum(d[[v]], na.rm = TRUE)
  }

  safe_ratio <- function(n, d) {
    if (is.na(d) || d == 0) {
      c(n, NA_real_)
    } else {
      c(n, n / d)
    }
  }

  # Default formats and labels -------------------------------------------------
  default_fmt <- c(
    sum = "xx",
    sum_unique = "xx",
    ratio = "xx (xx.x%)",
    ratio_unique = "xx (xx.x%)"
  )
  default_lbl <- c(
    sum = "Sum",
    sum_unique = "Sum (unique)",
    ratio = "Ratio",
    ratio_unique = "Ratio (unique)"
  )

  # Compute stats ---------------------------------------------------------------
  n_plain <- if (any(.stats %in% c("sum", "ratio"))) {
    sum_plain(.var)
  } else {
    NULL
  }
  n_unique <- if (any(.stats %in% c("sum_unique", "ratio_unique"))) {
    sum_unique(.var)
  } else {
    NULL
  }
  d_plain <- if (any(.stats %in% c("ratio")) && !is.null(denom_by)) {
    sum_plain(denom_by)
  } else {
    NULL
  }
  d_unique <- if (any(.stats %in% c("ratio_unique")) && !is.null(denom_by)) {
    sum_unique(denom_by)
  } else {
    NULL
  }

  # Build result list ---------------------------------------------------------------
  x_stats <- list()
  if ("sum" %in% .stats) {
    x_stats[["sum"]] <- n_plain
  }
  if ("sum_unique" %in% .stats) {
    x_stats[["sum_unique"]] <- n_unique
  }
  if ("ratio" %in% .stats) {
    x_stats[["ratio"]] <- safe_ratio(n_plain, d_plain)
  }
  if ("ratio_unique" %in% .stats) {
    x_stats[["ratio_unique"]] <- safe_ratio(n_unique, d_unique)
  }

  # Resolve formats and labels ------------------------------------------
  fmts <- default_fmt[names(x_stats)]
  labels <- default_lbl[names(x_stats)]
  if (!is.null(.formats)) {
    fmts[names(.formats)] <- .formats
  }
  if (!is.null(.labels)) {
    labels[names(.labels)] <- .labels
  }

  .format_na_strs <- if (!is.null(na_str)) {
    lapply(names(fmts), function(x) na_str)
  } else {
    NULL
  }

  in_rows(
    .list = x_stats,
    .formats = as.list(fmts),
    .names = labels,
    .labels = labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )
}

#' Split Function Factory for the Response Tables (RESP01)
#'
#' The main purpose here is to have a column dependent split into either comparative
#' statistic (relative risk or odds ratio with p-value) in the 'Overall' column,
#' and count proportions and corresponding confidence intervals in the other treatment
#' arm columns.
#'
#' @inheritParams proposal_argument_convention
#' @param method (`string`)\cr which method to use for the comparative statistics.
#'
#' @return A split function for use in the response table RESP01 and similar ones.
#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
#'   post-processing function.
#' @export
#'
#' @examples
#' split_fun <- resp01_split_fun_fct(
#'   method = "or_cmh",
#'   conf_level = 0.95
#' )
resp01_split_fun_fct <- function(method = c("rr", "or_logistic", "or_cmh"), conf_level) {
  method <- match.arg(method)
  (assert_proportion_value)(conf_level)

  post_fun <- function(ret, spl, fulldf, .spl_context) {
    all_expr <- expression(TRUE)
    # Here check if we are in 'Overall' column or not.
    this_col <- .spl_context[nrow(.spl_context), "value"][[1]]
    in_overall <- this_col == "Overall"
    # Accordingly, return left and right column labels and value identifiers.
    if (in_overall) {
      # In the Overall column, we want the comparison statistic and corresponding p-value.
      comp_stat_name <- if (method == "rr") "Relative Risk" else "Odds Ratio"
      short_split_result(
        comp_stat_ci = paste0(comp_stat_name, " (", f_conf_level(conf_level), ")~[super a]"),
        pval = "p-value~[super b]",
        fulldf = fulldf
      )
    } else {
      # In the treatment arm columns, we want counts and CI for proportions.
      short_split_result(
        count_prop = "n (%)",
        prop_ci = paste0(f_conf_level(conf_level), " for %"),
        fulldf = fulldf
      )
    }
  }
  make_split_fun(post = list(post_fun))
}

#' Content Row Function for Counts of Subgroups in Response Tables (RESP01)
#'
#' @inheritParams proposal_argument_convention
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param label_fstr (`string`)\cr format string for the label.
#'
#' @return The correct [rtables::in_rows()] result.
#' @export
#'
#' @examples
#' fake_spl_context <- data.frame(
#'   cur_col_split_val = I(list(c(ARM = "A: Drug X", count_prop = "count_prop")))
#' )
#' resp01_counts_cfun(
#'   df = DM,
#'   labelstr = "Blue",
#'   .spl_context = fake_spl_context,
#'   .alt_df = DM,
#'   label_fstr = "Color: %s"
#' )
resp01_counts_cfun <- function(df, labelstr, .spl_context, .alt_df, label_fstr) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  if (this_col_split[1] != "Overall" && this_col_split[2] == "count_prop") {
    in_rows(nrow(.alt_df), .formats = "xx", .labels = sprintf(label_fstr, labelstr))
  } else {
    NULL
  }
}

#' Formatted Analysis Function for Comparative Statistic in Response Tables (RESP01)
#'
#' This function applies to a `logical` column called `.var` from `df`.
#' The response proportion is compared between the treatment arms identified
#' by column `arm`.
#'
#' @inheritParams proposal_argument_convention
#' @param include (`flag`)\cr whether to include the results for this variable.
#' @param arm (`string`)\cr column name in the data frame that identifies the treatment arms.
#' @param formats (`list`)\cr containing formats for `comp_stat_ci` and `pval`.
#' @param methods (`list`)\cr containing methods for comparative statistics. The element `comp_stat_ci` can be
#'   'rr' (relative risk), 'or_cmh' (odds ratio with CMH estimation and p-value) or 'or_logistic' (odds ratio
#'   estimated by conditional or standard logistic regression). The element `pval` can be 'fisher' (Fisher's
#'   exact test) or 'chisq' (chi-square test), only used when using unstratified analyses with 'or_logistic'.
#' @param stat (`string`)\cr the statistic to return, either `comp_stat_ci`
#'   or `pval`.
#'
#' @return The formatted result as [rtables::rcell()].
#' @seealso [resp01_a_comp_stat_factor()] for the `factor` equivalent.
#' @export
#'
#' @examples
#' dm <- droplevels(subset(formatters::DM, SEX %in% c("F", "M")))
#' dm$RESP <- as.logical(sample(c(TRUE, FALSE), size = nrow(DM), replace = TRUE))
#'
#' resp01_a_comp_stat_logical(
#'   dm,
#'   .var = "RESP",
#'   conf_level = 0.9,
#'   include = TRUE,
#'   arm = "SEX",
#'   strata = "RACE",
#'   stat = "comp_stat_ci",
#'   methods = list(comp_stat_ci = "or_cmh"),
#'   formats = list(
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
resp01_a_comp_stat_logical <- function(df,
                                       .var,
                                       conf_level,
                                       include,
                                       arm,
                                       strata,
                                       formats,
                                       methods,
                                       stat = c("comp_stat_ci", "pval")) {
  checkmate::assert_logical(df[[.var]])
  checkmate::assert_factor(df[[arm]], n.levels = 2L)
  checkmate::assert_flag(include)
  stat <- match.arg(stat)

  if (include) {
    checkmate::assert_list(methods)
    checkmate::assert_subset(methods$comp_stat_ci, c("rr", "or_cmh", "or_logistic"))

    df_by <- split(df, f = df[[arm]])
    this_df <- df_by[[1]]
    this_ref_group <- df_by[[2]]

    this_res <- if (methods$comp_stat_ci == "rr") {
      # Stratified CMH test for point estimate and p-value, and Wald statistic for the confidence interval
      s_res <- s_relative_risk(
        this_df,
        .var = .var,
        .ref_group = this_ref_group,
        .in_ref_col = FALSE,
        variables = list(strata = strata),
        conf_level = conf_level
      )
      list(comp_stat_ci = s_res$rel_risk_ci, pval = s_res$pval)
    } else if (methods$comp_stat_ci == "or_logistic") {
      # Odds Ratio Variant 1: (Conditional/Standard) Logistic regression for odds ratio point estimate and
      # confidence interval.
      s_res <- s_odds_ratio_j(
        this_df,
        .var = .var,
        .ref_group = this_ref_group,
        .in_ref_col = FALSE,
        .df_row = rbind(this_df, this_ref_group),
        variables = list(arm = arm, strata = strata),
        conf_level = conf_level,
        method = "exact" # Only used if strata are present.
      )
      pval <- if (is.null(strata)) {
        checkmate::assert_subset(methods$pval, c("fisher", "chisq"))

        # If not stratified, then the p-value can come either from Fisher's exact or chi-square test.
        p_res <- s_test_proportion_diff(
          this_df,
          .var = .var,
          .ref_group = this_ref_group,
          .in_ref_col = FALSE,
          method = methods$pval
        )
        p_res$pval
      } else {
        s_res$pval
      }
      list(comp_stat_ci = s_res$or_ci, pval = pval)
    } else if (methods$comp_stat_ci == "or_cmh") {
      # Odds Ratio Variant 2: Stratified CMH test for odds ratio point estimate and confidence interval and
      # corresponding CMH test p-value.
      s_res <- s_odds_ratio_j(
        this_df,
        .var = .var,
        .ref_group = this_ref_group,
        .in_ref_col = FALSE,
        .df_row = rbind(this_df, this_ref_group),
        variables = list(arm = arm, strata = strata),
        conf_level = conf_level,
        method = "cmh"
      )
      list(comp_stat_ci = s_res$or_ci, pval = s_res$pval)
    }
    rcell(this_res[[stat]], format = formats[[stat]])
  } else {
    NULL
  }
}

#' Formatted Analysis Function for Comparative Statistic in Response Tables (RESP01)
#'
#' This function applies to a `factor` column called `.var` from `df`.
#'
#' @inheritParams proposal_argument_convention
#' @param include (`character`)\cr for which factor levels to include the comparison
#'   statistic results.
#' @param \dots see [resp01_a_comp_stat_logical()] for additional required arguments.
#'
#' @return The formatted result as [rtables::rcell()].
#' @export
#'
#' @examples
#' dm <- droplevels(subset(formatters::DM, SEX %in% c("F", "M")))
#'
#' resp01_a_comp_stat_factor(
#'   dm,
#'   .var = "COUNTRY",
#'   conf_level = 0.9,
#'   include = c("USA", "CHN"),
#'   arm = "SEX",
#'   strata = "RACE",
#'   stat = "comp_stat_ci",
#'   methods = list(comp_stat_ci = "or_cmh"),
#'   formats = list(
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
resp01_a_comp_stat_factor <- function(df,
                                      .var,
                                      include,
                                      ...) {
  checkmate::assert_factor(df[[.var]])
  checkmate::assert_character(include, null.ok = TRUE)
  checkmate::assert_subset(x = include, choices = levels(df[[.var]]))

  design_df <- as.data.frame(h_get_design_mat(df, .var))

  res <- sapply(X = levels(df[[.var]]), simplify = FALSE, FUN = function(lvl) {
    df[[.var]] <- design_df[[lvl]]
    resp01_a_comp_stat_logical(df = df, .var = .var, include = lvl %in% include, ...)
  })
  in_rows(.list = res, .labels = levels(df[[.var]]))
}

#' Formatted Analysis and Content Summary Function for Response Tables (RESP01)
#'
#' This function applies to both `factor` and `logical` columns called
#' `.var` from `df`. Depending on the position in the split, it returns the
#' right formatted results for the RESP01 and related layouts.
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams resp01_a_comp_stat_logical
#' @param include_comp (`character` or `flag`)\cr whether to include comparative
#'   statistic results, either `character` for factors or `flag` for logicals.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param arm (`string`)\cr column name in the data frame that identifies the treatment arms.
#' @param label (`string`)\cr only for logicals, which label to use. (For factors, the
#'   labels are the factor levels.)
#' @param formats (`list`)\cr containing formats for `prop_ci`, `comp_stat_ci`
#'   and `pval`.
#' @param methods (`list`)\cr containing methods for comparative statistics. The element `comp_stat_ci` can be
#'   'rr' (relative risk), 'or_cmh' (odds ratio with CMH estimation and p-value) or 'or_logistic' (odds ratio
#'   estimated by conditional or standard logistic regression). The element `pval` can be 'fisher' (Fisher's
#'   exact test) or 'chisq' (chi-square test), only used when using unstratified analyses with 'or_logistic'.
#'   The element `prop_ci` specifies the method for proportion confidence interval calculation.
#'
#' @return The formatted result as [rtables::in_rows()] result.
#' @export
#'
#' @examples
#' fake_spl_context <- data.frame(
#'   cur_col_split_val = I(list(c(ARM = "A: Drug X", count_prop = "count_prop")))
#' )
#' dm <- droplevels(subset(DM, SEX %in% c("F", "M")))
#' resp01_acfun(
#'   dm,
#'   .alt_df = dm,
#'   .var = "COUNTRY",
#'   .spl_context = fake_spl_context,
#'   conf_level = 0.9,
#'   include_comp = c("USA", "CHN"),
#'   arm = "SEX",
#'   strata = "RACE",
#'   methods = list(
#'     comp_stat_ci = "or_cmh",
#'     pval = "",
#'     prop_ci = "wald"
#'   ),
#'   formats = list(
#'     prop_ci = jjcsformat_xx("xx.% - xx.%"),
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
#' fake_spl_context2 <- data.frame(
#'   cur_col_split_val = I(list(c(ARM = "Overall", comp_stat_ci = "comp_stat_ci")))
#' )
#' resp01_acfun(
#'   dm,
#'   .alt_df = dm,
#'   .var = "COUNTRY",
#'   .spl_context = fake_spl_context2,
#'   conf_level = 0.9,
#'   include_comp = c("USA", "CHN"),
#'   arm = "SEX",
#'   strata = "RACE",
#'   methods = list(
#'     comp_stat_ci = "or_cmh",
#'     pval = "",
#'     prop_ci = "wald"
#'   ),
#'   formats = list(
#'     prop_ci = jjcsformat_xx("xx.% - xx.%"),
#'     comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
#'     pval = jjcsformat_pval_fct(0.05)
#'   )
#' )
resp01_acfun <- function(df,
                         labelstr = NULL,
                         label = NULL,
                         .var,
                         .spl_context,
                         include_comp,
                         .alt_df,
                         conf_level,
                         arm,
                         strata,
                         formats,
                         methods) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  x <- df[[.var]]
  is_factor <- is.factor(x)
  res <- if (this_col_split[1] != "Overall") {
    if (this_col_split[2] == "count_prop") {
      if (is_factor) {
        s_proportion_factor(x, .alt_df = .alt_df)
      } else {
        s_proportion_logical(x, .alt_df = .alt_df)$n_prop
      }
    } else {
      checkmate::assert_true(this_col_split[2] == "prop_ci")
      if (is_factor) {
        a_proportion_ci_factor(
          df,
          .var = .var,
          .alt_df = .alt_df,
          conf_level = conf_level,
          formats = formats,
          method = methods$prop_ci
        )
      } else {
        a_proportion_ci_logical(
          x,
          .alt_df = .alt_df,
          conf_level = conf_level,
          formats = formats,
          method = methods$prop_ci
        )
      }
    }
  } else {
    checkmate::assert_true(this_col_split[1] == "Overall")
    if (is_factor) {
      resp01_a_comp_stat_factor(
        df,
        .var = .var,
        conf_level = conf_level,
        include = include_comp,
        arm = arm,
        strata = strata,
        stat = this_col_split[2],
        formats = formats,
        methods = methods
      )
    } else {
      resp01_a_comp_stat_logical(
        df,
        .var = .var,
        conf_level = conf_level,
        include = include_comp,
        arm = arm,
        strata = strata,
        stat = this_col_split[2],
        formats = formats,
        methods = methods
      )
    }
  }
  if (is_factor) {
    res
  } else {
    if (!is.null(labelstr)) {
      label <- labelstr
    }
    in_rows(res, .labels = label)
  }
}

#' @name a_two_tier
#'
#' @title Two Tier Analysis Function
#'
#' @author GB, WW.
#'
#' @description `a_two_tier()`: The analysis function used as an `afun` in \link[rtables]{analyze}.
#'   This function simulates a final additional level of nesting with a
#'   traditional analyze call inside it.
#'
#'   This makes it possible to create what *appear to be* group summary or
#'   content rows and to *optionally or conditionally* generate one or more
#'   "detail" rows underneath it.
#'
#'   For example, in a disposition table, one might want counts for completed
#'   and ongoing patients with no further detail underneath, but a breakdown of
#'   specific reasons beneath the count of patients who discontinued treatment.
#'
#' @details `a_two_tier()`: Both the analysis variable and `inner_var` must be factors.
#'   Detail rows are differentiated by having an indent mod of one, causing them
#'   to hang indented under their corresponding group row.
#'
#' @note In its current form, this function may not retain any formatting or
#'   labeling instructions added by `grp_fun` or `detail_fun`, and it will
#'   override any `.indent_mods` values specified by them. This behavior may
#'   change in future versions.
#'
#' @inheritParams proposal_argument_convention
#' @param inner_var (`string`)\cr single variable name to use when generating
#'   the detail rows.
#' @param drill_down_levs (`character`)\cr the level(s) of `.var` under which
#'   detail rows should be generated.
#' @param use_all_levels (`flag`)\cr controls which factor levels will be
#'   present for `inner_var` (both in `df`/`x` and in `.df_row`) when calling
#'   `detail_fun`.
#'   If `TRUE`, all levels (those present on the factor `.df_row[[inner_var]]`,
#'   *regardless if the level is observed in the row group or not) will be
#'   present when creating detail rows.
#'   Otherwise (the default), only the levels observed
#'   *anywhere in the row group, i.e., within `.df_row`* will be present.
#' @param grp_fun (`function`)\cr analysis function to be used when generating
#'   the "group summary" outer rows.
#' @param detail_fun (`function`)\cr analysis function to be used when generating
#'   "detail" inner rows.
#' @param .alt_df_full (`dataframe`)\cr denominator dataset for fraction and
#'   relative risk calculations.\cr
#'   this argument gets populated by the rtables split machinery
#'   (see [rtables::additional_fun_params]).
#' @param ... additional arguments passed directly to `grp_fun` and `detail_fun`.
#'
#' @return `a_two_tier()`: A `RowsVerticalSection` object including both the group row and all
#'   detail rows, if applicable, for the facet.
#'
#' @import checkmate
#' @export
#'
#' @examples
#'
#' # Example 1
#'
#' lyt_obs_levels <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_rows_by("EOSSTT", child_labels = "hidden") |>
#'   analyze("EOSSTT",
#'     afun = a_two_tier,
#'     extra_args = list(
#'       grp_fun = simple_analysis,
#'       detail_fun = simple_analysis,
#'       inner_var = "DCSREAS",
#'       drill_down_levs = "DISCONTINUED"
#'     )
#'   )
#'
#' tbl <- build_table(lyt_obs_levels, ex_adsl)
#' tbl
#'
#' lyt_all_levels <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_rows_by("EOSSTT", child_labels = "hidden") |>
#'   analyze("EOSSTT",
#'     afun = a_two_tier,
#'     extra_args = list(
#'       grp_fun = simple_analysis,
#'       detail_fun = simple_analysis,
#'       inner_var = "DCSREAS",
#'       drill_down_levs = "DISCONTINUED",
#'       use_all_levels = TRUE
#'     )
#'   )
#'
#' adsl_subset <- subset(ex_adsl, DCSREAS != "ADVERSE EVENT")
#' levels(adsl_subset$DCSREAS)
#'
#' tbl_all_levels <- build_table(lyt_all_levels, adsl_subset)
#' tbl_all_levels
#'
#' tbl_obs_levels <- build_table(lyt_obs_levels, adsl_subset)
#' tbl_obs_levels
#'
#' # Example 2
#'
#' library(dplyr)
#'
#' trtvar <- "ARM"
#' ctrl_grp <- "B: Placebo"
#'
#' adsl <- ex_adsl |> select(c("USUBJID", "STRATA1", "EOSSTT", "DCSREAS", all_of(trtvar)))
#' adsl$colspan_trt <- factor(
#'   ifelse(adsl[[trtvar]] == ctrl_grp, " ", "Active Study Agent"),
#'   levels = c("Active Study Agent", " ")
#' )
#' adsl$rrisk_header <- "Risk Difference (%) (95% CI)"
#' adsl$rrisk_label <- paste(adsl[[trtvar]], paste("vs", ctrl_grp))
#'
#' colspan_trt_map <- create_colspan_map(
#'   df = adsl,
#'   non_active_grp = ctrl_grp,
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = trtvar
#' )
#'
#' a_freq_j_args <- list(
#'   .stats = "count_unique_fraction",
#'   denom = "n_altdf",
#'   ref_path = c("colspan_trt", " ", trtvar, ctrl_grp)
#' )
#'
#' two_tier_args <- list(
#'   grp_fun = a_freq_j,
#'   detail_fun = a_freq_j,
#'   inner_var = "DCSREAS",
#'   drill_down_levs = "DISCONTINUED"
#' )
#'
#' lyt_rrisk <- basic_table() |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) |>
#'   split_cols_by(trtvar) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(trtvar, labels_var = "rrisk_label", split_fun = remove_split_levels(ctrl_grp)) |>
#'   split_rows_by("STRATA1") |>
#'   split_rows_by("EOSSTT", child_labels = "hidden") |>
#'   analyze("EOSSTT", afun = a_two_tier, extra_args = c(two_tier_args, a_freq_j_args))
#'
#' adsl_subset <- subset(
#'   adsl,
#'   EOSSTT != "COMPLETED" & (is.na(DCSREAS) | DCSREAS != "PROTOCOL VIOLATION")
#' )
#'
#' tbl_rrisk <- build_table(lyt_rrisk, adsl_subset, alt_counts_df = adsl_subset)
#' tbl_rrisk
#'
a_two_tier <- function(df,
                       labelstr = NULL,
                       .var,
                       .N_col,
                       .df_row,
                       inner_var,
                       drill_down_levs,
                       .spl_context,
                       use_all_levels = FALSE,
                       grp_fun,
                       detail_fun,
                       .alt_df_full = NULL,
                       ...) {
  assert_string(inner_var)
  assert_character(drill_down_levs)
  assert_flag(use_all_levels)
  assert_function(grp_fun)
  assert_function(detail_fun)

  if (!all(sapply(c(.var, inner_var), \(x) is.factor(df[[x]])))) {
    stop("a_two_tier requires both input variables .var and inner_var as factor")
  }

  cur_grp <- tail(.spl_context$value, 1)
  df[[.var]] <- factor(df[[.var]], levels = cur_grp)
  .df_row[[.var]] <- factor(.df_row[[.var]], levels = cur_grp)
  args <- list(
    labelstr = labelstr,
    .var = .var,
    .N_col = .N_col,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .alt_df_full = .alt_df_full,
    ...
  )
  if (names(formals(grp_fun))[1] == "df") {
    args <- c(list(df = df), args)
  } else {
    args <- c(list(x = df[[.var]]), args)
  }
  if (identical(grp_fun, a_freq_j)) {
    # this will ensure row with cur_grp will be presented
    # even if 0 observed in current row
    args[["drop_levels"]] <- FALSE
    args <- c(list(val = cur_grp), args)
  }
  cell_vals <- unclass(
    do.call(grp_fun, args)
  )
  names(cell_vals) <- attr(cell_vals, "row_label")

  ## calculate the drill-down values if necessary
  if (cur_grp %in% drill_down_levs && any(!is.na(.df_row[[inner_var]]))) {
    ## have to make sure we use all levels for the whole row group
    ## so that each column gets the same number of values in the same order
    all_inner_levs <- levels(df[[inner_var]])
    if (use_all_levels) {
      detail_levs <- all_inner_levs
    } else {
      detail_levs <- all_inner_levs[all_inner_levs %in% all_inner_levs[.df_row[[inner_var]]]]
    }

    inner_vec <- factor(df[[inner_var]], levels = detail_levs)
    df[[inner_var]] <- factor(df[[inner_var]], levels = detail_levs)
    .df_row[[inner_var]] <- factor(.df_row[[inner_var]], levels = detail_levs)
    det_args <- list(
      .var = inner_var,
      .N_col = .N_col,
      .df_row = .df_row,
      .spl_context = .spl_context,
      .alt_df_full = .alt_df_full,
      ...
    )
    if (names(formals(detail_fun))[1] == "df") {
      det_args <- c(list(df = df), det_args)
    } else {
      det_args <- c(list(x = df[[inner_var]]), det_args)
    }

    detail_vals <- unclass(
      do.call(detail_fun, det_args)
    )

    names(detail_vals) <- attr(detail_vals, "row_label")
  } else {
    detail_vals <- list()
  }
  in_rows(
    .list = c(cell_vals, detail_vals),
    .indent_mods = c(0, rep(1, length.out = length(detail_vals)))
  )
}


#' @rdname a_two_tier
#'
#' @description `a_three_tier()`: Extends `a_two_tier()` by adding a third level
#'   of nesting: a group summary outer row, mid-level detail rows (one per level
#'   of `inner_var1`), and innermost detail rows (one per level of `inner_var2`)
#'   nested beneath each mid-level row.
#'
#' @details `a_three_tier()`: The analysis variable, `inner_var1`, and `inner_var2` must all be
#'   factors. Mid-level rows are indented by one and innermost rows by two,
#'   relative to the group summary row.
#'
#' @inheritParams a_two_tier
#' @param inner_var1 (`string`)\cr single variable name to use when generating
#'   the mid-level (second tier) detail rows.
#' @param inner_var2 (`string`)\cr single variable name to use when generating
#'   the innermost (third tier) detail rows, nested under each level of `inner_var1`.
#'
#' @return `a_three_tier()`: A `RowsVerticalSection` object including the group row, mid-level
#'   detail rows, and innermost detail rows, if applicable, for the facet.
#'
#' @import checkmate
#' @export
#'
a_three_tier <- function(df,
                         labelstr = NULL,
                         .var,
                         .N_col,
                         .df_row,
                         inner_var1,
                         inner_var2,
                         drill_down_levs,
                         .spl_context,
                         use_all_levels = FALSE,
                         grp_fun,
                         detail_fun,
                         .alt_df_full = NULL,
                         ...) {
  assert_string(inner_var1)
  assert_string(inner_var2)
  assert_character(drill_down_levs)
  assert_flag(use_all_levels)
  assert_function(grp_fun)
  assert_function(detail_fun)

  if (!all(sapply(c(.var, inner_var1, inner_var2), \(x) is.factor(df[[x]])))) {
    stop("a_three_tier requires all input variables .var, inner_var1 and inner_var2 as factor")
  }

  cur_grp <- tail(.spl_context$value, 1)
  df[[.var]] <- factor(df[[.var]], levels = cur_grp)
  .df_row[[.var]] <- factor(.df_row[[.var]], levels = cur_grp)
  args <- list(
    labelstr = labelstr,
    .var = .var,
    .N_col = .N_col,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .alt_df_full = .alt_df_full,
    ...
  )
  if (names(formals(grp_fun))[1] == "df") {
    args <- c(list(df = df), args)
  } else {
    args <- c(list(x = df[[.var]]), args)
  }

  if (identical(grp_fun, a_freq_j)) {
    # this will ensure row with cur_grp will be presented
    # even if 0 observed in current row
    args[["drop_levels"]] <- FALSE
    args <- c(list(val = cur_grp), args)
  }
  # perform calculation for outer level values
  cell_vals <- unclass(
    do.call(grp_fun, args)
  )
  names(cell_vals) <- attr(cell_vals, "row_label")

  ## calculate the drill-down values if necessary
  if (cur_grp %in% drill_down_levs && any(!is.na(.df_row[[inner_var1]]))) {
    ## have to make sure we use all levels for the whole row group
    ## so that each column gets the same number of values in the same order
    all_inner_levs <- levels(df[[inner_var1]])

    if (use_all_levels) {
      detail_levs <- all_inner_levs
    } else {
      detail_levs <- all_inner_levs[all_inner_levs %in% all_inner_levs[.df_row[[inner_var1]]]]
    }

    inner_vec <- factor(df[[inner_var1]], levels = detail_levs)
    df[[inner_var1]] <- factor(df[[inner_var1]], levels = detail_levs)
    .df_row[[inner_var1]] <- factor(.df_row[[inner_var1]], levels = detail_levs)

    # inner_vec will be looped over each level separately to act as a row_group
    # .df_row_inner will reflect .df_row + filter to level of inner_var
    # inner_vec2 can be done at once
    # .df_row_inner
    df_orig <- df
    df_row_orig <- .df_row
    detail_vals <- c()
    indentmods <- c()
    detail_vals_lbl <- c()
    for (i in seq_along(detail_levs)) {
      inner_lev_i <- detail_levs[i]
      # restrict to current row & i-th level of inner_va1
      .df_row <- df_row_orig[df_row_orig[[inner_var1]] == inner_lev_i, ]
      .df_row[[inner_var1]] <- factor(.df_row[[inner_var1]], levels = inner_lev_i)
      df <- df_orig[df_orig[[inner_var1]] == inner_lev_i, ]
      df[[inner_var1]] <- factor(df[[inner_var1]], levels = inner_lev_i)

      # get levels of inner_var2
      all_inner_levs2 <- levels(df[[inner_var2]])
      if (use_all_levels) {
        detail_levs2 <- all_inner_levs2
      } else {
        # restrict to observed levels of inner_var2 in this updated df_row
        # cur_grp (level of outer var (.var)) and inner_lev_i (level of mid level var (inner_var1))
        detail_levs2 <- all_inner_levs2[all_inner_levs2 %in% all_inner_levs2[.df_row[[inner_var2]]]]
      }
      inner_vec2 <- factor(df[[inner_var2]], levels = detail_levs2)
      df[[inner_var2]] <- factor(df[[inner_var2]], levels = detail_levs2)
      .df_row[[inner_var2]] <- factor(.df_row[[inner_var2]], levels = detail_levs2)

      det_args <- list(
        .var = inner_var1,
        .N_col = .N_col,
        .df_row = .df_row,
        .spl_context = .spl_context,
        .alt_df_full = .alt_df_full,
        ...
      )
      if (names(formals(detail_fun))[1] == "df") {
        det_args <- c(list(df = df), det_args)
      } else {
        det_args <- c(list(x = df[[inner_var1]]), det_args)
      }

      # mid level values at level inner_lev_i
      detail_vals_i <- unclass(
        do.call(detail_fun, det_args)
      )

      names(detail_vals_i) <- attr(detail_vals_i, "row_label")

      # now get the inner level ones
      if (any(!is.na(.df_row[[inner_var2]]))) {
        det_args2 <- list(
          .var = inner_var2,
          .N_col = .N_col,
          .df_row = .df_row,
          .spl_context = .spl_context,
          .alt_df_full = .alt_df_full,
          ...
        )
        if (names(formals(detail_fun))[1] == "df") {
          det_args2 <- c(list(df = df), det_args2)
        } else {
          det_args2 <- c(list(x = df[[inner_var2]]), det_args2)
        }
        detail_vals2 <- unclass(
          do.call(detail_fun, det_args2)
        )
        detail_vals2_lbl <- attr(detail_vals2, "row_label")
        if (i > 1) {
          names(detail_vals2) <- paste0(attr(detail_vals2, "row_label"), "[[", i, "]]")
        } else {
          names(detail_vals2) <- attr(detail_vals2, "row_label")
        }
        detail_vals <- c(detail_vals, detail_vals_i, detail_vals2)
        indentmods <- c(indentmods, c(1, rep(2, length.out = length(detail_vals2))))
        detail_vals_lbl <- c(detail_vals_lbl, names(detail_vals_i), detail_vals2_lbl)
      }
    }
  } else {
    detail_vals <- list()
    indentmods <- NULL
    detail_vals_lbl <- c()
  }

  in_rows(
    .list = c(cell_vals, detail_vals),
    .indent_mods = c(0, indentmods),
    .labels = c(names(cell_vals), detail_vals_lbl)
  )
}

#' @name a_freq_subcol_j
#'
#' @title Analysis function count and percentage with extra column-subsetting in
#' selected columns (controlled by subcol_* arguments)
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams a_freq_j
#' @param subcol_split (`string`)\cr text to search colid to determine whether further subsetting
#'                     should be performed.
#' @param subcol_var (`string`)\cr name of variable containing to be searched for the text
#'                     identified in subcol_val argument.
#' @param subcol_val (`string`)\cr value to use to perform further data sub-setting.
#' @param denom (`string`)\cr
#' One of \cr
#' \itemize{
#' \item \strong{N_col} Column count, \cr
#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
#' (`.row_df` from the rtables splitting machinery).\cr
#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
#' This higher row-level split is specified in the argument `denom_by`.\cr
#' }
#' @param .formats (named 'character' or 'list')\cr
#' formats for the statistics.
#' @seealso [a_freq_j()] for extensive `label_map` usage examples.
#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' ADSL <- ex_adsl |>
#'   select(USUBJID, ARM)
#'
#' ADSL$COLSPAN_REL <- "AEs"
#'
#' ADAE <- ex_adae |>
#'   select(USUBJID, ARM, AEDECOD, AREL)
#'
#' ADAE <- ADAE |>
#'   mutate(
#'     AEREL = case_when(
#'       AREL == "Y" ~ "RELATED",
#'       AREL == "N" ~ "NOT RELATED"
#'     ),
#'     AEREL = factor(AEREL),
#'     COLSPAN_REL = "AEs"
#'   )
#'
#' combodf <- tribble(
#'   ~valname,  ~label,        ~levelcombo, ~exargs,
#'   "RELATED", "Related AEs", c("AEs"),    list()
#' )
#'
#' lyt <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("COLSPAN_REL", split_fun = rtables::add_combo_levels(combodf, trim = TRUE)) |>
#'   split_cols_by("ARM") |>
#'   analyze("AEDECOD",
#'     afun = a_freq_subcol_j,
#'     extra_args = list(
#'       subcol_split = "RELATED",
#'       subcol_var = "AEREL",
#'       subcol_val = "RELATED"
#'     )
#'   )
#'
#' result <- build_table(lyt, ADAE, alt_counts_df = ADSL)
#'
#' result
a_freq_subcol_j <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  # arguments specific to a_freq_subcol_j
  subcol_split = NULL,
  subcol_var = NULL,
  subcol_val = NULL,
  # arguments specific to a_freq_subcol_j till here
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats = c("count_unique_denom_fraction"),
  .formats = NULL,
  .labels_n = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3)
) {
  denom <- match.arg(denom)

  if (!is.null(labelstr) && is.na(.var)) {
    stop(
      "Argument var must be specified in call to summarize_row_groups when using cfun = a_freq_subcol_j."
    )
  }

  check_alt_df_full(denom, "n_altdf", .alt_df_full)

  res_dataprep <- h_a_freq_dataprep(
    df = df,
    labelstr = labelstr,
    .var = .var,
    val = val,
    drop_levels = FALSE,
    excl_levels = NULL,
    new_levels = NULL,
    new_levels_after = FALSE,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .N_col = .N_col,
    id = id,
    denom = denom,
    variables = NULL,
    label = label,
    label_fstr = label_fstr,
    label_map = label_map,
    .alt_df_full = .alt_df_full,
    denom_by = denom_by,
    .stats = .stats
  )
  # res_dataprep is list with elements
  # df .df_row val
  # drop_levels excl_levels
  # alt_df parentdf new_denomdf
  # .stats
  # make these elements available in current environment
  df <- res_dataprep$df
  .df_row <- res_dataprep$.df_row
  val <- res_dataprep$val
  alt_df <- res_dataprep$alt_df
  parentdf <- res_dataprep$parentdf
  new_denomdf <- res_dataprep$new_denomdf
  .stats <- res_dataprep$.stats

  ## colid can be used to figure out if we're in subcolum
  colid <- .spl_context$cur_col_id[[1]]

  ### this is the core code for subsetting to appropriate subcol_val
  insubcol <- grepl(subcol_split, colid, fixed = TRUE)
  if (insubcol) {
    df <- subset(df, df[[subcol_var]] == subcol_val)
  }

  ## the same s-function can be used as in a_freq_j
  x_stats <- s_freq_j(
    df,
    .var = .var,
    .df_row = .df_row,
    val = val,
    alt_df = new_denomdf,
    parent_df = new_denomdf,
    id = id,
    denom = denom,
    .N_col = .N_col,
    countsource = "df"
  )

  .stats_adj <- .stats

  res_prepinrows <- h_a_freq_prepinrows(
    x_stats,
    .stats_adj,
    .formats,
    labelstr,
    label_fstr,
    label,
    .indent_mods,
    .labels_n,
    na_str
  )
  # res_prepinrows is list with elements
  # x_stats .formats .labels .indent_mods .format_na_strs
  # make these elements available in current environment
  x_stats <- res_prepinrows$x_stats
  .formats <- res_prepinrows$.formats
  .labels <- res_prepinrows$.labels
  .indent_mods <- res_prepinrows$.indent_mods
  .format_na_strs <- res_prepinrows$.format_na_strs

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )

  return(inrows)
}

#' @keywords internal
formatter_references <- list(
  "jjcsformat_xx" =
    jjcsformat_xx("xx.xxxxxxxxx"),
  "jjcsformat_fraction" =
    jjcsformat_cnt_den_fract_fct(type = "count_fraction"),
  "jjcsformat_pval" =
    jjcsformat_pval_fct(alpha = 0),
  "jjcsformat_range" =
    jjcsformat_range_fct("xx.xx"),
  "format_xx" =
    format_xx("xx"),
  "format_extreme_values" =
    format_extreme_values(2L),
  "format_extreme_values_ci" =
    format_extreme_values_ci(2L),
  "format_count_fraction_fixed_dp" =
    format_count_fraction_fixed_dp,
  "format_count_fraction" =
    format_count_fraction,
  "format_fraction_fixed_dp" =
    format_fraction_fixed_dp,
  "format_sigfig_j" = format_sigfig_j(sigfig = 3, "xx")
)

#' @keywords internal
body_matches <- function(fmtfun, reference_fun) {
  identical(deparse(body(fmtfun)), deparse(body(reference_fun)))
}

#' @keywords internal
get_input_jjcs_fmtfun <- function(fmtfun) {
  if (length(fmtfun) != 1) {
    stop("fmtfun should be of length 1")
  }

  if (is.list(fmtfun)) {
    fmtfun <- fmtfun[[1]]
  }

  result <- list(
    fun_fact = "",
    str = "",
    d = NA_integer_,
    str_formatters = NA,
    type = "",
    alpha = "",
    message = "",
    fmt_package = "",
    is_fun = FALSE,
    fun = fmtfun,
    round_type = FALSE,
    whole_integer = NA,
    drop0trailing = NA,
    zero_threshold = 0
  )

  valid_fmt_str <- unlist(list_valid_format_labels(), use.names = FALSE)

  # Handle character inputs separately.
  if (is.character(fmtfun)) {
    if (fmtfun %in% valid_fmt_str) {
      result$fun_fact <- ""
      result$str <- fmtfun
      result$str_formatters <- TRUE
      result$fmt_package <- "formatters"
      result$round_type <- TRUE
    } else {
      result$fun_fact <- "string"
      result$str <- fmtfun
      result$str_formatters <- FALSE
      result$message <- paste(
        "fmtfun is a string but not a supported formatting value"
      )
    }

    return(result)
  }

  if (!is.function(fmtfun)) {
    result$message <- paste(
      "fmtfun is not a function/character"
    )

    message(result$message)

    return(result)
  }

  # from here on fmtfun is a function
  x_body_matches <- sapply(formatter_references, body_matches, fmtfun = fmtfun)
  formatter_key <- if (any(x_body_matches)) {
    names(formatter_references)[which(x_body_matches)[1L]]
  } else {
    "unknown"
  }

  result$is_fun <- TRUE
  if (formatter_key != "unknown") {
    result$round_type <- "round_type" %in% names(formals(fmtfun))
  }
  switch(formatter_key,
    "jjcsformat_xx" = {
      result$fun_fact <- "jjcsformat_xx"
      result$str <- get0(
        "str",
        envir = environment(fmtfun),
        ifnotfound = ""
      )
      result$str_formatters <- FALSE
      result$fmt_package <- "junco"
    },
    "jjcsformat_fraction" = {
      result$fun_fact <- "jjcsformat_fraction"
      result$type <- get0(
        "type",
        envir = environment(fmtfun),
        ifnotfound = ""
      )
      result$fmt_package <- "junco"
    },
    "jjcsformat_pval" = {
      result$fun_fact <- "jjcsformat_pval"
      result$alpha <- as.character(
        get0(
          "alpha",
          envir = environment(fmtfun),
          ifnotfound = ""
        )
      )
      result$fmt_package <- "junco"
    },
    "jjcsformat_range" = {
      result$fun_fact <- "jjcsformat_range"
      result$str <- as.character(
        get0(
          "str",
          envir = environment(fmtfun),
          ifnotfound = ""
        )
      )
      result$fmt_package <- "junco"
    },
    "format_xx" = {
      result$fun_fact <- "format_xx"
      result$str <- as.character(
        get0(
          "str",
          envir = environment(fmtfun),
          ifnotfound = ""
        )
      )
      result$fmt_package <- "tern"
    },
    "format_extreme_values" = {
      result$fun_fact <- "format_extreme_values"
      result$str <- "???"
      result$fmt_package <- "tern"
    },
    "format_extreme_values_ci" = {
      result$fun_fact <- "format_extreme_values_ci"
      result$str <- "???"
      result$fmt_package <- "tern"
    },
    "format_count_fraction_fixed_dp" = {
      result$fun_fact <- "format_count_fraction_fixed_dp"
      result$fmt_package <- "tern"
    },
    "format_count_fraction" = {
      result$fun_fact <- "format_count_fraction"
      result$fmt_package <- "tern"
    },
    "format_fraction_fixed_dp" = {
      result$fun_fact <- "format_fraction_fixed_dp"
      result$fmt_package <- "tern"
    },
    "format_sigfig_j" = {
      result$fun_fact <- "format_sigfig_j"
      result$str <- as.character(
        get0(
          "format",
          envir = environment(fmtfun),
          ifnotfound = ""
        )
      )
      result$d <- as.numeric(
        get0(
          "sigfig",
          envir = environment(fmtfun),
          ifnotfound = ""
        )
      )
      result$whole_integer <-
        get0(
          "whole_integer",
          envir = environment(fmtfun),
          ifnotfound = FALSE
        )
      result$drop0trailing <-
        get0(
          "drop0trailing",
          envir = environment(fmtfun),
          ifnotfound = FALSE
        )
      result$zero_threshold <-
        get0(
          "zero_threshold",
          envir = environment(fmtfun),
          ifnotfound = 0L
        )
      result$fmt_package <- "junco"
    },
    "unknown" = {
      result$fun_fact <- "???"
      result$fmt_package <- "???"
      result$message <- paste(
        "fmtfun is an unknown formatting function not defined",
        "in formatters/tern/junco"
      )
    }
  )

  result
}


#' @name fmt_utils
#'
#' @title Utilities for reviewing format specification objects
#'
#' @details fmt_utils general details
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param myfmts A named list of either formatting specifications (ie stats with its associated formats)
#'  or a list of variables with formatting specifications.
#'
#' @param recursive `logical(1)`
#' Set to `TRUE` when requesting details from named list of variables with specifications.
#' Set to `FALSE` when requesting details from named list of statistics with format specifications.
#'
#' @param as_tibble `logical(1)` When  `TRUE`, convert the information into a tibble for ease of reviewing.
#'
#'
#' @param fmt1 A named list of formatting specifications (ie stats with its associated format)
#' @param fmt2 Another named list of formatting specifications (ie stats with its associated format),
#'  to compare against `fmt1`
NULL

#' @describeIn fmt_utils A utility function to collect information on formatting specification in list or tibble format.
#'
#' The following information is collected:
#' - var (variable name): Only applicable if the format specification is a named list with formattings specs
#' (eg list("AGE" = c("mean" = "xx", "se" = "xx.x"), "BMI" = c("mean" = "xx.x", "se" = "xx.xx"))), eg processed via
#' `fmt_spec_var_d` function.
#' - stat (name of statistic)
#' - fun_fact : name of function factory that has produced the format specification
#'  (if spec is from formatting function, blank if spec is string).\cr
#'  Only the following known formatting functions are supported:
#'
#'    - jjcsformat_xx
#'    - jjcsformat_cnt_den_fract_fct,
#'    - jjcsformat_pval_fct,
#'    - jjcsformat_range_fct,
#'    - tern::format_xx,
#'    - tern::format_extreme_values,
#'    - tern::format_extreme_values_ci,
#'    - tern::format_count_fraction_fixed_dp,
#'    - tern::format_count_fraction,
#'    - tern::format_fraction_fixed_dp,
#'    - format_sigfig_j
#'
#'  - str: string from specification, or str from formatting function factory (`jjcsformat_xx`, ....)
#'  - str_formatters: (`logical`) Is the str value a valid format string as in ([list_valid_format_labels()])?
#'  - type: when formatting function factory `jjcsformat_cnt_den_fract_fct` is used
#'  - alpha: when formatting function factory `jjcsformat_pval_fct` is used
#'  - message: Message when formatting function is unknown, or input string was
#'    not valid format string as in ([list_valid_format_labels()])
#'  - fmt_package: In which package was the formatting specification defined.
#'  - is_fun: (`logical`) Is the formatting specification a function?
#'  - round_type: (`logical`) Does the formatting support `round_type` argument/behavior?
#'  - fun: Formatting string or body of the formatting function.
#'
#'  Only when one of the formats provided is based upon formatting function factory `format_sigfig_j` setup:
#'  - d: value used for `sigfig`
#'  - whole_integer: value used for `whole_integer`
#'  - drop0trailing: value used for `drop0trailing`
#'  - zero_threshold: value used for `zero_threshold`
#' @examples
#' # Example for get_fmt_details --
#' junco_def_d <- c(
#'   "mean" = "xx.dx",
#'   "mean_sd" = "xx.dx (xx.dxx)",
#'   "range" = "(xx.d, xx.d)"
#' )
#'
#' myfmts <- fmt_spec_single_d(
#'   d = 1,
#'   stats_in = c("mean", "mean_sd"),
#'   fmt_d_def = junco_def_d,
#'   fmt_d_in = NULL
#' )
#'
#' fmt_details <- get_fmt_details(myfmts, as_tibble = TRUE)
#'
#' myfmts2 <- fmt_spec_single_d(
#'   d = 3,
#'   stats_in = c("mean", "mean_sd"),
#'   fmt_d_def = junco_def_d,
#'   fmt_d_in = NULL
#' )
#' fmt_details2 <- get_fmt_details(myfmts2, as_tibble = TRUE)
#' fmt_details2
#'
#' # Example for get_fmt_details using format specs for variables --
#' # processed with fmt_spec_var_d
#' var <- c("AGE" = 0, "BMI" = 1, "BMRKR1" = 2)
#' vars_fmt <- fmt_spec_var_d(var,
#'   stats_in = NULL,
#'   fmt_d_def = junco_def_d,
#'   fmt_d_in = NULL
#' )
#' fmt_details2 <- get_fmt_details(vars_fmt, as_tibble = TRUE, recursive = TRUE)
#'
#' @export
get_fmt_details <- function(myfmts, recursive = FALSE, as_tibble = TRUE) {
  lst <- if (recursive) {
    lapply(myfmts, get_fmt_details, as_tibble = as_tibble)
  } else {
    lapply(myfmts, get_input_jjcs_fmtfun)
  }

  names(lst) <- names(myfmts)

  if (!recursive && as_tibble) {
    df <- do.call(
      rbind,
      lapply(names(lst), function(nm) {
        xx <- lst[[nm]]
        xx$fun <- NULL
        data.frame(
          stat = nm,
          as.data.frame(xx, stringsAsFactors = FALSE)
        )
      })
    )
    df <- dplyr::as_tibble(df)

    df$fun <- lapply(lst, `[[`, "fun")
    lst <- df
  }

  if (recursive && as_tibble) {
    lst <- dplyr::bind_rows(lst, .id = "var")
  }

  if (as_tibble && !any(lst[["fun_fact"]] == "format_sigfig_j")) {
    # drop format_sigfig_j specific columns
    dropcols <- c("d", "whole_integer", "drop0trailing", "zero_threshold")
    lst <- lst[, setdiff(names(lst), dropcols), drop = FALSE]
  }
  lst
}


#' @noRd
#' @param fmt_t1 Tibble information from specification 1
#' @param fmt_t2 Tibble information from specification 2
#' @keywords internal
compare_fmt_tibble <- function(fmt_t1, fmt_t2) {
  nms <- names(fmt_t1)
  nms <- nms[nms != "fun"]
  fmt_t1_x <- fmt_t1[, nms]
  fmt_t2_x <- fmt_t2[, nms]
  c1 <- identical(fmt_t1_x, fmt_t2_x)

  fmt_t1_y <- fmt_t1[["fun"]][[1]]
  fmt_t2_y <- fmt_t2[["fun"]][[1]]
  if (is.function(fmt_t1_y) && is.function(fmt_t2_y)) {
    c2 <- body_matches(fmt_t1_y, fmt_t2_y)
  } else if (is.character(fmt_t1_y) && is.character(fmt_t2_y)) {
    c2 <- identical(fmt_t1_y, fmt_t2_y)
  } else {
    c2 <- FALSE
  }

  rslt <- c1 & c2
}

#' @describeIn fmt_utils A utility to report findings in differences between 2 formatting specification vectors.
#' It returns a list object with the following information:
#' - spec1 : For statistics with a different specification, tibble with specification details from `fmt1`.
#' - spec2 : For statistics with a different specification, tibble with specification details from `fmt2`.
#' The tibbles in `spec1` and `spec2` contain information as described in `get_fmt_details()`.
#' - msg: Message on how many stats have a difference in specification.
#' - comm_stats: Vector of stats in common between `fmt1` and `fmt2`.
#' - diff_stats: Vector of stats with any difference identified.
#' @examples
#'
#' # Example for compare_fmt_specs --
#' test1_target <- junco_default_formats
#' # junco_def_d_all has been constructed with d = 1 as reference
#' # compare against junco_default_formats
#' test1_d <- fmt_spec_single_d(
#'   d = 1,
#'   stats_in = NULL,
#'   fmt_d_def = junco_def_d_all,
#'   fmt_d_in = NULL
#' )
#'
#' check1 <- compare_fmt_specs(test1_d, test1_target)
#' check1
#'
#' # more differences when using other d
#' test2_d <- fmt_spec_single_d(
#'   d = 2,
#'   stats_in = NULL,
#'   fmt_d_def = junco_def_d_all,
#'   fmt_d_in = NULL
#' )
#'
#' check2 <- compare_fmt_specs(test2_d, test1_target)
#'
#' @export
#'
compare_fmt_specs <- function(fmt1, fmt2) {
  result <- list(
    spec1 = NULL,
    spec2 = NULL,
    msg = NULL,
    comm_stats = NULL,
    diff_stats = NULL
  )
  stats_diff <- NULL

  stats1 <- names(fmt1)
  stats2 <- names(fmt2)
  stats <- intersect(stats1, stats2)
  if (length(stats) == 0) {
    result$msg <- "No stats in common"
    result$comm_stats <- NULL
  } else {
    result$comm_stats <- stats
    fmt1 <- fmt1[stats]
    fmt2 <- fmt2[stats]

    check <- sapply(names(fmt1), \(stat) {
      fmt_t1 <- get_fmt_details(list(stat = fmt1[[stat]]))
      fmt_t2 <- get_fmt_details(list(stat = fmt2[[stat]]))
      fmt_t1[["stat"]] <- stat
      fmt_t2[["stat"]] <- stat

      compare_fmt_tibble(fmt_t1, fmt_t2)
    })

    if (sum(!check) == 0) {
      result$msg <- "All common stats specs identical"
    } else {
      stats_diff <- check[!check]
      stats_diff <- names(stats_diff)
      result$spec1 <- get_fmt_details(fmt1[stats_diff])
      result$spec2 <- get_fmt_details(fmt2[stats_diff])
      result$msg <- paste0(length(stats_diff), " common stats with differences in specs")
      result$diff_stats <- stats_diff
    }
  }

  if (!is.null(result$msg)) {
    message(result$msg)
    message("More details are available in created object.")
  }
  return(result)
}

#' Relative risk estimation
#'
#' The analysis function [a_relative_risk()] is used to create a layout element
#' to estimate the relative risk for response within a studied population using
#' stratified CMH or unstratified Wald methods.
#' The primary analysis variable, `vars`, is a logical variable indicating
#' whether a response has occurred for each record.
#' For CMH, a stratification variable must be supplied via the
#' `strata` element of the `variables` argument.
#'
#' @details The variance of the CMH relative risk estimate is calculated using
#'   the Greenland and Robins (1985) variance estimation.
#'   The unstratified `wald` and `waldcc` methods use a normal approximation
#'   for the log relative risk.
#'   `waldcc` adds 0.5 to
#'   each response count and each group total in both the estimate and variance.
#'   With `wald`, a zero response count gives undefined confidence limits and
#'   p-value (`NA`).
#'
#' @param df (`data.frame`)\cr input data frame.
#' @param .var (`string`)\cr name of the response variable.
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#' @param .ref_group (`data.frame`)\cr reference group data frame.
#' @param .in_ref_col (`logical(1)`)\cr whether the current column is the reference column.
#' @param variables (`list`)\cr list with strata variable names.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param complete_cases (`logical(1)`) \cr whether to remove incomplete rows from `df`
#'   before constructing the response, group, strata, and contingency table.
#' @param method (`string`)\cr relative risk method: `cmh`, `wald`, or `waldcc`.
#' @param weights_method (`string`)\cr method to use for weights calculation in stratified analysis.
#'
#' @name relative_risk
NULL

#' @describeIn relative_risk Statistics function estimating the relative risk for response.
#'
#' @return
#' * `s_relative_risk()` returns a named list of elements `rel_risk_ci` and `pval`.
#'
#' @examples
#' nex <- 100
#' dta <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
#'   "grp" = sample(c("A", "B"), nex, TRUE),
#'   "f1" = sample(c("a1", "a2"), nex, TRUE),
#'   "f2" = sample(c("x", "y", "z"), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' s_relative_risk(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   variables = list(strata = c("f1", "f2")),
#'   conf_level = 0.90
#' )
#' @export
s_relative_risk <- function(
  df,
  .var,
  .ref_group = NULL,
  .in_ref_col = NULL,
  variables = list(strata = NULL),
  conf_level = 0.95,
  complete_cases = FALSE,
  method = c("cmh", "wald", "waldcc"),
  weights_method = "cmh"
) {
  checkmate::assert_flag(.in_ref_col, null.ok = TRUE)
  method <- match.arg(method)
  weights_method <- match.arg(weights_method)

  y <- if (is.null(.in_ref_col) || .in_ref_col) {
    list(
      rel_risk_ci = c(est = NA_real_, lcl = NA_real_, ucl = NA_real_),
      pval = NA_real_
    )
  } else {
    prepared <- tern::h_prepare_rsp_table(
      df = df,
      df_ref = .ref_group,
      var = .var,
      strata_vars = if (method == "cmh") variables$strata else NULL,
      complete_cases = complete_cases
    )

    if (method == "cmh") {
      prop_ratio_cmh(tbl = prepared$tbl, conf_level = conf_level)
    } else {
      prop_ratio_wald(tbl = prepared$tbl, conf_level = conf_level, correction = (method == "waldcc"))
    }
  }

  y$rel_risk_ci <- with_label(
    x = y$rel_risk_ci,
    label = paste0("Relative risk (", f_conf_level(conf_level), ")")
  )
  y$pval <- unname(y$pval)

  y
}

#' @describeIn relative_risk Formatted analysis function which is used as `afun`. Note that the
#'   junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
#'
#' @return
#' * `a_relative_risk()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' nex <- 100
#' dta <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
#'   "grp" = sample(c("A", "B"), nex, TRUE),
#'   "f1" = sample(c("a1", "a2"), nex, TRUE),
#'   "f2" = sample(c("x", "y", "z"), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' l <- basic_table() |>
#'   split_cols_by(var = "grp") |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_relative_risk,
#'     extra_args = list(
#'       conf_level = 0.90,
#'       variables = list(strata = "f1"),
#'       ref_path = c("grp", "B")
#'     )
#'   )
#'
#' build_table(l, df = dta)
#' @export
#' @order 2
a_relative_risk <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_relative_risk,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "relative_risk",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}


#' @keywords internal
safe_mh_test <- function(...) {
  tryCatch(
    stats::mantelhaen.test(...),
    error = function(e) list(p.value = NA_real_)
  )
}

#' Relative Risk CMH Statistic
#'
#' Calculates the relative risk which is defined as the ratio between the
#' response rates between the experimental treatment group and the control treatment group, adjusted
#' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights.
#'
#' @inheritParams proposal_argument_convention
#' @param tbl (`array`)\cr a 2 by 2 by number of strata contingency table, as returned
#'   in the `tbl` element of [tern::h_prepare_rsp_table()]. Rows (first dimension) are reference
#'   then treatment; columns (second dimension) are responders then nonresponders;
#'   the third dimension represents the strata.
#'
#' @return A list with elements `rel_risk_ci` and `pval`.
#' @examples
#'
#' set.seed(2)
#' rsp <- factor(
#'   sample(c(TRUE, FALSE), 100, TRUE),
#'   levels = c(TRUE, FALSE)
#' )
#' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
#' grp <- factor(grp, levels = c("Placebo", "Treatment"))
#' strata_data <- data.frame(
#'   "f1" = sample(c("a", "b"), 100, TRUE),
#'   "f2" = sample(c("x", "y", "z"), 100, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' tbl <- table(grp, rsp, interaction(strata_data))
#' prop_ratio_cmh(
#'   tbl = tbl,
#'   conf_level = 0.90
#' )
#'
#' @export
prop_ratio_cmh <- function(tbl, conf_level = 0.95) {
  assert_response_table(tbl, stratified = TRUE)
  checkmate::assert_number(conf_level, lower = 0, upper = 1)
  if (any(apply(tbl, 3L, sum) < 5)) {
    warning("Less than 5 observations in some strata.")
  }
  # Rows are reference then treatment; columns are strata, including a single stratum.
  n_resp <- matrix(tbl[, 1L, ], nrow = 2)
  n <- margin.table(tbl, margin = c(1L, 3L))
  checkmate::assert_integerish(as.vector(n), lower = 0)

  # CMH statistic for relative risk, Treatment over Control
  use_stratum <- colSums(n > 0) == 2L
  n <- n[, use_stratum, drop = FALSE]
  n_resp <- n_resp[, use_stratum, drop = FALSE]
  n_total <- colSums(n)

  rel_risk_num <- sum(n_resp[2L, ] * n[1L, ] / n_total)
  rel_risk_denom <- sum(n_resp[1L, ] * n[2L, ] / n_total)
  log_rel_risk <- log(rel_risk_num) - log(rel_risk_denom)
  rel_risk <- exp(log_rel_risk)

  var_num <- sum((n[1L, ] * n[2L, ] * colSums(n_resp) - n_resp[1L, ] * n_resp[2L, ] * n_total) / n_total^2)
  var_denom <- rel_risk_num * rel_risk_denom
  var_log_rel_risk <- var_num / var_denom
  se_log_rel_risk <- sqrt(var_log_rel_risk)

  z <- stats::qnorm((1 + conf_level) / 2)
  log_rel_risk_ci <- log_rel_risk + c(-1, +1) * z * se_log_rel_risk
  ci <- exp(log_rel_risk_ci)
  rel_risk_ci <- stats::setNames(c(rel_risk, ci), c("est", "lcl", "ucl"))

  if (any(rowSums(tbl[, 1L, , drop = FALSE]) == 0)) {
    rel_risk_ci <- c(est = NA_real_, lcl = 0, ucl = Inf)
  }

  pval <- safe_mh_test(tbl, correct = FALSE)$p.value

  list(
    rel_risk_ci = rel_risk_ci,
    pval = pval
  )
}


#' Relative Risk Wald Statistic
#'
#' Estimates the relative response risk in the second group divided by that in the first
#' group, with log-scale Wald confidence limits and a two-sided Wald p-value.
#'
#' @inheritParams proposal_argument_convention
#' @param tbl (`matrix`)\cr a 2 by 2 contingency table, as returned in the
#'   `tbl` element of [tern::h_prepare_rsp_table()]. Rows are reference then
#'   treatment; columns are responders then nonresponders.
#' @param correction (`flag`)\cr whether to add 0.5 to the response counts and
#'   group totals, in order to support the case where there are zero responses in either group
#'   (Haldane-Anscombe correction).
#' @return A `list` containing two elements:
#'   * `rel_risk_ci`: A named numeric vector (`est`, `lcl`, `ucl`) specifying the point estimate,
#'      lower confidence limit, and upper confidence limit of the relative risk.
#'   * `pval`: A numeric scalar representing the two-sided Wald p-value.
#'
#' @examples
#' prop_ratio_wald(
#'   tbl = rbind(ref = c(1, 1), trt = c(2, 1)),
#'   correction = TRUE
#' )
#' @export
prop_ratio_wald <- function(tbl, conf_level = 0.95, correction = FALSE) {
  assert_response_table(tbl)
  checkmate::assert_number(conf_level, lower = 0, upper = 1)
  checkmate::assert_flag(correction)

  n_resp <- tbl[, 1L]
  n <- rowSums(tbl)
  checkmate::assert_true(all(n > 0))

  if (correction) {
    add_on <- 0.5
    n_resp <- n_resp + add_on
    n <- n + add_on
  }
  estimate <- (n_resp[2L] / n[2L]) / (n_resp[1L] / n[1L])

  if (any(n_resp == 0)) {
    if (is.nan(estimate)) {
      estimate <- NA_real_
    }
    ci <- c(NA_real_, NA_real_)
    pval <- NA_real_
  } else {
    se <- sqrt(sum(1 / n_resp - 1 / n))
    log_rr <- log(estimate)
    z <- stats::qnorm((1 + conf_level) / 2)
    ci <- exp(log_rr + c(-1, 1) * z * se)
    pval <- if (se == 0) 1 else 2 * stats::pnorm(-abs(log_rr / se))
  }

  list(
    rel_risk_ci = stats::setNames(
      c(estimate, ci),
      c("est", "lcl", "ucl")
    ),
    pval = unname(pval)
  )
}

#' Stratified Exposure-Adjusted Incidence Rate (EAIR)
#' @name a_eair_strat_j
#' @description
#' Statistical/Analysis function for presenting a stratified exposure-adjusted
#' incidence rate (EAIR) and its Wald confidence interval across strata
#' (e.g., study size weighted exposure).
#'
#' This function is an extension to the unstratified function `a_eair100_j()`.
#'
#' @details
#' The weighting method uses raw event counts `n_ti` in both the rate and variance.
#'   \deqn{\hat r_{ti} = \texttt{num\_p\_year} \times \frac{n_{ti}}{T_{ti}}}
#'
#'
#' The strata weight is `w_i = T_0i + T_1i` (total person-years across
#' **all** groups in strata `i`), and the pooled weighted rate is:
#' \deqn{\hat r_t = \sum_i \frac{w_i}{W} \hat r_{ti}, \quad W = \sum_i w_i}
#'
#' The Wald 95% CI for the pooled rate is:
#' \deqn{\hat r_t \pm z_{1-\alpha/2} \times \frac{\texttt{num\_p\_year}}{W}
#'   \sqrt{\sum_i w_i^2 \frac{n_{ti}}{T_{ti}^2}}}.
#'
#' The weighted rate difference and its Wald CI are:
#' \deqn{\hat\delta = \sum_i \frac{w_i}{W}(\hat r_{1i} - \hat r_{0i})}
#' \deqn{\hat\delta \pm z_{1-\alpha/2} \times \frac{\texttt{num\_p\_year}}{W}
#'   \sqrt{\sum_i w_i^2 \left(\frac{n_{1i}+c}{T_{1i}^2} + \frac{n_{0i}}{T_{0i}^2}\right)}}
#'
#' @inherit a_eair100_j params
#' @inherit s_eair100_levii_j params
#'
#' @param strata (`string`)\cr variable identifying strata (e.g., study identifier).
#'
#' @return
#' * `s_eair_strat_levii_j()` returns a list containing the following statistics:
#'
#' \itemize{
#'   \item `n_event_total`: total event count across strata (current arm)
#'   \item `person_years_total`: total person-years across strata (current arm)
#'   \item `eair_strat`: stratified pooled EAIR per `num_p_year` person-years
#'   \item `n_eair_strat`: composite of `n_event_total` and `eair_strat`
#'   \item `eair_strat_ci`: Wald CI for `eair_strat`
#'   \item `eair_strat_est_ci`: composite of `eair_strat` and `eair_strat_ci`
#'   \item `eair_strat_n`: composite of `eair_strat` and `n_event_total`
#'   \item `eair_strat_n_py`: composite of `eair_strat`, `n_event_total` and `person_years_total`
#'   \item `eair_strat_diff_est_ci`: stratified rate difference with Wald CI
#'     (only when `vs_ref_group = TRUE`, otherwise `NULL`)
#'   \item `eair_strat_diff_est`: estimate for the difference in stratified rate
#'   \item `eair_strat_diff_ci`: CI (Wald type) for the difference in stratified rate
#' }
#'
#'
#' The list of available statistics (core columns) can also be viewed by
#' running `junco_get_stats("a_eair_strat_j")`.
#' @seealso [a_eair100_j()]
#' @references
#' Scosyrev, E & Pethe, A (2022). Confidence intervals for exposure-adjusted rate
#' differences in randomized trials.
#' Pharmaceutical Statistics, 2022;21:103–121.
#' doi: 10.1002/pst.2155
#'
#' Crowe, B., Chuang-Stein, C., Lettis, S., & Brueckner, A. (2016).
#' Reporting adverse drug reactions in product labels.
#' Therapeutic Innovation & Regulatory Science, 50(4), 455-463.
#' doi: 10.1177/2168479016628574


#'
#'
#' @keywords internal
s_eair_strat_levii_j <- function(
  levii,
  df,
  .df_row,
  .alt_df_full,
  .var,
  strata,
  id = "USUBJID",
  fup_var,
  occ_var = NULL,
  occ_dy = NULL,
  num_p_year = 100,
  count_multiple_events = FALSE,
  conf_level = 0.95,
  vs_ref_group = FALSE,
  .in_ref_col,
  cur_col_expr,
  ref_col_expr,
  inriskdiffcol = FALSE
) {
  checkmate::assert_string(strata)
  checkmate::assert_string(fup_var)
  checkmate::assert_string(occ_var, null.ok = TRUE)
  checkmate::assert_flag(vs_ref_group)
  if (!is.null(occ_var)) {
    checkmate::assert_string(occ_dy, null.ok = FALSE)
  }
  checkmate::assert_names(colnames(.alt_df_full), must.include = c(id, fup_var, strata))

  denom_df_full_mod <- h_get_eair_df(
    levii = levii,
    df = .df_row,
    denom_df = .alt_df_full,
    .var = .var,
    id = id,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy,
    count_multiple_events = count_multiple_events,
    strata = strata
  )
  denom_df_full_mod <- denom_df_full_mod$df_denom

  # study weights from FULL denominator (all arms combined per study)
  w_by_strata <- tapply(
    denom_df_full_mod[["mod_fup_var"]],
    denom_df_full_mod[[strata]],
    sum,
    na.rm = TRUE
  )
  strata_levels <- names(w_by_strata)

  # gather common arguments for .get_stratum
  .alt_df_full_cur_group <- subset(.alt_df_full, eval(cur_col_expr))
  args_get_stratum <- list(
    strata = strata,
    strata_levels = strata_levels,
    levii = levii,
    .var = .var,
    id = id,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy,
    count_multiple_events = count_multiple_events
  )
  stratum_stats <- do.call(
    .get_stratum_stats,
    args = append(
      list(
        df_arm = df,
        denom_arm = .alt_df_full_cur_group
      ),
      args_get_stratum
    )
  )

  # gather common arguments for h_s_eair_strat_numbers
  args_get_numbers <- list(
    strata = strata,
    w_by_strata = w_by_strata,
    num_p_year = num_p_year
  )

  curcore <- do.call(
    h_s_eair_strat_numbers,
    args = append(
      list(stratum_stats = stratum_stats),
      args_get_numbers
    )
  )

  n_vec <- curcore$n_vec
  py_vec <- curcore$py_vec
  r_vec <- curcore$r_vec
  w_vec <- curcore$w_vec

  .stats <- h_s_eair_strat_estimates(
    n_vec = n_vec,
    py_vec = py_vec,
    r_vec = r_vec,
    w_vec = w_vec,
    conf_level = conf_level,
    num_p_year = num_p_year
  )

  # rate difference vs reference arm
  diff_stats <- list()
  if (vs_ref_group) {
    ref_denom_df <- subset(.alt_df_full, eval(ref_col_expr))
    ref_df <- subset(.df_row, eval(ref_col_expr))

    ref_stratum_stats <- do.call(
      .get_stratum_stats,
      args = append(
        list(
          df_arm = ref_df,
          denom_arm = ref_denom_df
        ),
        args_get_stratum
      )
    )

    refcore <- do.call(
      h_s_eair_strat_numbers,
      args = append(
        list(stratum_stats = ref_stratum_stats),
        args_get_numbers
      )
    )

    ref_n_vec <- refcore$n_vec
    ref_py_vec <- refcore$py_vec
    ref_r_vec <- refcore$r_vec

    diff_stats <- h_s_eair_strat_diff_estimates(
      n_vec = n_vec,
      py_vec = py_vec,
      r_vec = r_vec,
      w_vec = w_vec,
      ref_n_vec = ref_n_vec,
      ref_py_vec = ref_py_vec,
      ref_r_vec = ref_r_vec,
      num_p_year = num_p_year,
      conf_level = conf_level
    )
  } else {
    diff_stats$eair_strat_diff_est_ci <- numeric(0)
  }

  attr(diff_stats$eair_strat_diff_est_ci, "label") <- paste0(
    "Difference in stratified EAIR (",
    formatC(conf_level * 100, format = "f", digits = 0), "% CI, Wald)"
  )

  .stats <- append(.stats, diff_stats)
  .stats
}

#' @describeIn a_eair_strat_j
#' Formatted analysis function for stratified (eg study size-weighted) EAIR, used as `afun`
#' in [rtables::analyze()].
#'
#'
#' @return
#' * `a_eair_strat_j()` returns a list of formatted [rtables::CellValue()] rows.
#' Within a risk difference column,
#' the statistics `eair_strat` and `n_eair_strat` are replaced by `eair_strat_diff_est_ci`
#' (difference in EAIR between current group and reference group,
#' together with it's confidence interval).
#' @export
#'
#' @examples
#' library(tern)
#' library(dplyr)
#'
#' set.seed(42)
#' n <- 120
#' adsl <- data.frame(
#'   USUBJID = paste0("S", seq_len(n)),
#'   ARM = rep(c("Treatment", "Placebo"), each = n / 2),
#'   STUDY = rep(c("Study1", "Study2", "Study3"), times = n / 3),
#'   TRTDURY = runif(n, 0.5, 3),
#'   stringsAsFactors = FALSE
#' )
#' adae <- data.frame(
#'   USUBJID = sample(adsl$USUBJID, 40),
#'   AEDECOD = "Headache",
#'   ASTDY = sample(30:500, 40, replace = TRUE),
#'   AOCCPFL = "Y",
#'   stringsAsFactors = FALSE
#' )
#' aefup <- merge(adae, adsl, by = "USUBJID")
#'
#' # Standard method (matches rdcomaeinci SAS macro)
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   analyze(
#'     "AEDECOD",
#'     afun = a_eair_strat_j,
#'     extra_args = list(
#'       strata = "STUDY",
#'       fup_var = "TRTDURY",
#'       occ_var = "AOCCPFL",
#'       occ_dy = "ASTDY",
#'       .stats = c("eair_strat", "eair_strat_ci")
#'     )
#'   )
#' result <- build_table(lyt, aefup, alt_counts_df = adsl)
#' result
a_eair_strat_j <- function(
  df,
  labelstr = NULL,
  .var,
  .df_row,
  .spl_context,
  .alt_df_full = NULL,
  id = "USUBJID",
  strata,
  fup_var,
  occ_var = NULL,
  occ_dy = NULL,
  num_p_year = 100,
  count_multiple_events = FALSE,
  drop_levels = FALSE,
  riskdiff = FALSE,
  ref_path = NULL,
  conf_level = 0.95,
  .stats = "eair_strat",
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3),
  row_labels_adj = FALSE,
  riskdiff_setup = c("horizontal", "vertical")
) {
  riskdiff_setup <- match.arg(riskdiff_setup)

  if (is.null(.alt_df_full)) {
    stop("a_eair_strat_j: .alt_df_full cannot be NULL. Specify `alt_counts_df` in `build_table`.")
  }
  if (riskdiff && is.null(ref_path)) {
    stop("a_eair_strat_j: ref_path cannot be NULL when riskdiff = TRUE.")
  }
  checkmate::assert_string(strata)
  checkmate::assert_names(colnames(.alt_df_full), must.include = c(id, fup_var, strata))

  # if no stats requested, get all stats
  .stats <- junco_get_stats(
    "a_eair_strat_j",
    stats_in = .stats,
    custom_stats_in = NULL
  )
  if (
    any(
      .stats %in% c("eair_strat_diff_est_ci", "eair_strat_diff_est", "eair_strat_diff_ci")
    ) &&
      riskdiff_setup == "horizontal"
  ) {
    .stats <-
      .stats[!(.stats %in% c("eair_strat_diff_est_ci", "eair_strat_diff_est", "eair_strat_diff_ci"))]
  }

  cur_col_expr <- .spl_context$cur_col_expr[[1]]
  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  # reference group expressions and data (for rate difference)
  ref_col_expr <- NULL
  ref_df <- NULL
  ref_denom_df <- NULL
  .in_ref_col <- NULL

  ref_info <- get_ref_info_expanded(
    df,
    .var,
    .df_row,
    .spl_context,
    ref_path,
    riskdiff,
    riskdiff_setup
  )

  perform_vs_ref_stats <- ref_info$perform_vs_ref_stats
  ref_col_expr <- ref_info$ref_col_expr
  .in_ref_col <- ref_info$.in_ref_col

  if (riskdiff) {
    ref_denom_df <- subset(.alt_df_full, eval(ref_col_expr))
    ref_df <- subset(.df_row, eval(ref_col_expr))
  }

  inrowsplit <- FALSE
  if (.var == tail(.spl_context$split, 1L)) {
    # note: this will catch the rowsplit only if parent_name in split_rows_by call is .var (default)
    drop_levels <- TRUE
    inrowsplit <- TRUE
  }

  ### combine all preprocessing of incoming df/.df_row in one function
  ### do this outside stats derivation functions (s_freq_j/)
  ### use all of val/excl_levels/drop_levels//new_levels/label/label_map/labelstr/label_fstr
  upd_dfrow <- h_upd_dfrow(
    .df_row,
    .var,
    val = NULL,
    excl_levels = NULL,
    drop_levels = drop_levels,
    new_levels = NULL,
    new_levels_after = FALSE,
    label = NULL,
    label_map = NULL,
    labelstr = labelstr,
    label_fstr = NULL,
    .spl_context = .spl_context
  )

  .df_row <- upd_dfrow$df_row
  df <- upd_dfrow$df

  levs <- levels(.df_row[[.var]])
  if (is.null(levs)) levs <- unique(.df_row[[.var]])

  fn_Args <- list(
    strata = strata,
    df = df,
    .df_row = .df_row,
    .var = .var,
    id = id,
    fup_var = fup_var,
    occ_var = occ_var,
    occ_dy = occ_dy,
    num_p_year = num_p_year,
    count_multiple_events = count_multiple_events,
    cur_col_expr = cur_col_expr,
    ref_col_expr = ref_col_expr,
    vs_ref_group = perform_vs_ref_stats,
    .in_ref_col = !perform_vs_ref_stats,
    inriskdiffcol = riskdiff_setup == "horizontal" && inriskdiffcol,
    conf_level = conf_level,
    .alt_df_full = .alt_df_full
  )

  y <- mapply(
    s_eair_strat_levii_j,
    levii = levs,
    MoreArgs = fn_Args,
    SIMPLIFY = FALSE
  )

  ### rearrange list y to  list to x_stats
  # y is a nested list with
  # outer elements levels of incoming variable
  # inner elements stat elements statistics from

  #### this is to ensure the remainder of the code can stay the same as in a_freq_j
  stnms <- junco_get_stats("a_eair_strat_j")
  x_stats <- extract_x_stats(y, stnms)

  # x_stats is a nested list with
  # outer elements stat elements statistics (all 5 from stnms)
  # inner elements levels of incoming variable
  # this will ensure we can perform subsetting on .stats
  # like x_stats[.stats]

  # transpose_named_list cannot be used as this will not ensure all 5 poss stats are in
  if (inriskdiffcol && riskdiff_setup == "horizontal") {
    .stats_adj <-
      replace(
        .stats,
        .stats %in%
          c("eair_strat", "n_eair_strat", "eair_strat_n", "eair_strat_n_py"),
        "eair_strat_diff_est_ci"
      )
  } else {
    .stats_adj <- .stats
  }

  .stats <- .stats_adj

  # Fill in formatting defaults


  x_stats <- x_stats[.stats]
  x_stats_orig <- x_stats
  # from now onwards, retransform x_stats back into structure
  # list with outer elements stats levels from incoming variable
  # inner elements statistics
  x_stats <- transpose_named_list(x_stats)

  levels_per_stats <- lapply(x_stats, names)
  # in case no default label get the label from the x_stats directly
  # this is to cover statistics with dynamic label, such as
  # n_event Either Number of events or Number of subjects with events
  .labels_pre <- junco_get_labels_from_attrib(.stats, .labels, x_stats)

  .formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
  .labels <- junco_get_labels_from_stats(.stats, .labels_pre, levels_per_stats)
  .labels <- .unlist_keep_nulls(.labels)

  # make adjustments to rowlabels  when not inrowsplit
  if (!inrowsplit && length(.stats) > 1) {
    # if more than one stat requested and variable is not in a prior splitrowscall
    # prepend the level of the incoming variable (which is now in names of x_stats) to the label
    .labels <- paste(rep(names(x_stats), each = length(.stats)), .labels)
  } else if (!inrowsplit && length(.stats) == 1 && row_labels_adj) {
    # if one stat requested and variable is not in a prior splitrowscall
    # show the levels of the incoming variable, rather than the statistic
    .labels <- names(x_stats)
  }
  .labels <- gsub("^\\s+", "", .labels)

  .indent_mods <- junco_get_indents_from_stats(
    .stats,
    .indent_mods,
    levels_per_stats
  )
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  # .format_na_strs processing
  # if na_str = c(NA, NA, NA)
  # this will ensure the ci (NA, NA, NA) will be represented as NE (NE, NE)
  # the value NE is defined as the default to replace NA in our jjcs format

  if (!is.null(na_str)) {
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
  } else {
    .format_na_strs <- NULL
  }

  # Unlist stats + names
  x_stats <- .unlist_keep_nulls(x_stats)
  names(x_stats) <- names(.formats)

  ### final step: turn requested stats into rtables rows
  inrows <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )
}


h_s_eair_strat_numbers <- function(strata,
                                   w_by_strata,
                                   stratum_stats,
                                   num_p_year) {
  w_vec <- as.numeric(w_by_strata)
  W <- sum(w_vec)
  cur_stats <- stratum_stats
  n_vec <- sapply(cur_stats, `[[`, "n")
  py_vec <- sapply(cur_stats, `[[`, "py")

  # per-study rates
  r_vec <- num_p_year * (n_vec) / py_vec

  return(list(
    n_vec = n_vec,
    py_vec = py_vec,
    r_vec = r_vec,
    w_vec = w_vec
  ))
}

h_s_eair_strat_estimates <- function(n_vec,
                                     py_vec,
                                     r_vec,
                                     w_vec,
                                     conf_level,
                                     num_p_year) {
  W <- sum(w_vec)

  # weighted pooled rate
  eair_strat <- if (W > 0) sum(w_vec * r_vec) / W else NA_real_

  # Wald variance for pooled rate: (num_p_year/W)^2 * sum(w_i^2 * (n_i) / T_i^2)
  root_sum <- sum(w_vec^2 * (n_vec) / py_vec^2)
  z <- stats::qnorm(1 - (1 - conf_level) / 2)
  se_rate <- (num_p_year / W) * sqrt(root_sum)
  eair_ci <- c(max(0, eair_strat - z * se_rate), eair_strat + z * se_rate)
  n_total <- sum(n_vec)
  py_total <- sum(py_vec)

  # assemble return list
  x <- list()

  x$n_event_total <- stats::setNames(n_total, "n_event_total")
  attr(x$n_event_total, "label") <- "n (events)"

  x$person_years_total <- stats::setNames(py_total, "person_years_total")
  attr(x$person_years_total, "label") <- "Total person-years"

  x$eair_strat <- stats::setNames(eair_strat, "eair_strat")
  attr(x$eair_strat, "label") <- paste0(
    "Stratified EAIR per ", num_p_year, " PY"
  )

  x$n_eair_strat <- stats::setNames(
    c(n_total, eair_strat),
    c("n_event_total", "eair_strat")
  )
  attr(x$n_eair_strat, "label") <- paste0("n (stratified EAIR per ", num_p_year, " PY)")

  x$eair_strat_ci <- stats::setNames(eair_ci, c("lcl", "ucl"))
  attr(x$eair_strat_ci, "label") <- paste0(
    formatC(conf_level * 100, format = "f", digits = 0), "% CI (Wald)"
  )

  x$eair_strat_est_ci <- stats::setNames(
    c(eair_strat, eair_ci),
    c("eair_strat", "lcl", "ucl")
  )
  attr(x$eair_strat_est_ci, "label") <- paste0(
    "Stratified EAIR (", formatC(conf_level * 100, format = "f", digits = 0), "% CI)"
  )

  x$eair_strat_n <- stats::setNames(
    c(eair_strat, n_total),
    c("eair_strat", "n_event_total")
  )
  attr(x$eair_strat_n, "label") <- paste0("stratified EAIR per ", num_p_year, " PY (n)")

  x$eair_strat_n_py <- stats::setNames(
    c(eair_strat, n_total),
    c("eair_strat", "n_event_total")
  )
  attr(x$eair_strat_n_py, "label") <- paste0("stratified EAIR per ", num_p_year, " PY (n/person-years)")

  x
}

h_s_eair_strat_diff_estimates <- function(n_vec,
                                          py_vec,
                                          r_vec,
                                          w_vec,
                                          ref_n_vec,
                                          ref_py_vec,
                                          ref_r_vec,
                                          num_p_year,
                                          conf_level) {
  W <- sum(w_vec)
  z <- stats::qnorm(1 - (1 - conf_level) / 2)

  d_vec <- r_vec - ref_r_vec
  d_adj <- if (W > 0) sum(w_vec * d_vec) / W else NA_real_

  root_diff <- sum(w_vec^2 * ((n_vec) / py_vec^2 + (ref_n_vec) / ref_py_vec^2))
  se_diff <- (num_p_year / W) * sqrt(root_diff)

  diff_ci <- c(d_adj - z * se_diff, d_adj + z * se_diff)

  x <- list()
  x$eair_strat_diff_est_ci <- stats::setNames(
    c(d_adj, diff_ci),
    c("estimate", "lcl", "ucl")
  )
  attr(x$eair_strat_diff_est_ci, "label") <- paste0(
    "Difference in stratified EAIR (",
    formatC(conf_level * 100, format = "f", digits = 0), "% CI, Wald)"
  )

  x$eair_strat_diff_est <- stats::setNames(
    c(d_adj),
    c("estimate")
  )
  attr(x$eair_strat_diff_est, "label") <- "Difference in stratified EAIR"

  x$eair_strat_diff_ci <- stats::setNames(
    c(diff_ci),
    c("lcl", "ucl")
  )
  attr(x$eair_strat_diff_ci, "label") <- paste0(
    formatC(conf_level * 100, format = "f", digits = 0), "% CI (Wald)"
  )

  x
}

#' Impute missing binary responses and analyze each imputed data set
#'
#' Performs independent Bernoulli imputations for missing binary responses in
#' the control and treatment groups, then calculates a CMH risk difference and
#' p-value for each imputed data set. Only observations in `ctrlab` and
#' `trtlab` are included in the analysis.
#'
#' @param dat (`data.frame`)
#'   Analysis data containing treatment, response, and stratification variables.
#' @param p_ctrl (`numeric(1)`)
#'   Probability of response used to impute missing control-group responses.
#' @param p_trt (`numeric(1)`)
#'   Probability of response used to impute missing treatment-group responses.
#' @param trtvar (`string`)
#'   Name of the treatment variable in `dat`.
#' @param ctrlab (`string`)
#'   Value of `trtvar` identifying the control group.
#' @param trtlab (`string`)
#'   Value of `trtvar` identifying the treatment group.
#' @param respvar (`string`)
#'   Name of a logical binary response variable in `dat`. Missing values are
#'   imputed; observed values are retained.
#' @param stratvar (`character`)
#'   Names of one or more stratification variables in `dat`. Stratification
#'   variables must not be missing in the analysis groups.
#' @param n_imputations (`count`)
#'   Number of independently imputed data sets to analyze.
#'
#' @return A tibble with one row per imputation and the following columns:
#'
#' * `rd_est`: CMH risk-difference estimate.
#' * `rd_se`: standard error of the risk-difference estimate.
#' * `rd_var`: variance of the risk-difference estimate.
#' * `p_cmh`: CMH p-value using the Wilson-Hilferty transformation.
#' * `z_stat`: Wilson-Hilferty z statistic used to calculate `p_cmh`.
#'
#' @keywords internal
h_impute_analyze_resp <- function(
  dat,
  p_ctrl,
  p_trt,
  trtvar,
  ctrlab,
  trtlab,
  respvar,
  stratvar,
  n_imputations
) {
  checkmate::assert_data_frame(dat)
  checkmate::assert_number(p_ctrl, lower = 0, upper = 1, finite = TRUE)
  checkmate::assert_number(p_trt, lower = 0, upper = 1, finite = TRUE)
  checkmate::assert_string(trtvar)
  checkmate::assert_string(ctrlab)
  checkmate::assert_string(trtlab)
  checkmate::assert_string(respvar)
  checkmate::assert_character(stratvar, min.len = 1, any.missing = FALSE, unique = TRUE)
  checkmate::assert_count(n_imputations, positive = TRUE)
  checkmate::assert_subset(c(trtvar, respvar, stratvar), choices = names(dat))
  checkmate::assert_logical(dat[[respvar]], any.missing = TRUE)
  checkmate::assert_true(ctrlab != trtlab)

  treatment <- as.character(dat[[trtvar]])
  ctrl_data <- dat[which(treatment == ctrlab), , drop = FALSE]
  trt_data <- dat[which(treatment == trtlab), , drop = FALSE]

  checkmate::assert_true(nrow(ctrl_data) > 0)
  checkmate::assert_true(nrow(trt_data) > 0)

  analysis_data <- rbind(ctrl_data, trt_data)
  strata <- interaction(analysis_data[stratvar], drop = TRUE)
  response <- c(ctrl_data[[respvar]], trt_data[[respvar]])
  group <- factor(
    rep(c("ref", "Not-ref"), c(nrow(ctrl_data), nrow(trt_data))),
    levels = c("ref", "Not-ref")
  )
  missing_response <- is.na(response)
  missing_ctrl_response <- group == "ref" & missing_response
  missing_trt_response <- group == "Not-ref" & missing_response
  n_missing_ctrl <- sum(missing_ctrl_response)
  n_missing_trt <- sum(missing_trt_response)

  results <- vector("list", n_imputations)
  for (i in seq_len(n_imputations)) {
    imputed_response <- response
    if (n_missing_ctrl > 0) {
      imputed_response[missing_ctrl_response] <- as.logical(stats::rbinom(
        n = n_missing_ctrl,
        size = 1,
        prob = p_ctrl
      ))
    }
    if (n_missing_trt > 0) {
      imputed_response[missing_trt_response] <- as.logical(stats::rbinom(
        n = n_missing_trt,
        size = 1,
        prob = p_trt
      ))
    }
    rd_result <- tern::prop_diff_cmh(imputed_response, group, strata, diff_se = "standard")
    cmh_result <- tern::prop_cmh(
      table(group, imputed_response, strata),
      transform = "wilson_hilferty"
    )
    results[[i]] <- c(
      rd_est = rd_result$diff,
      rd_se = rd_result$se_diff,
      p_cmh = as.numeric(cmh_result),
      z_stat = attr(cmh_result, "z_stat")
    )
  }

  results <- as.data.frame(do.call(rbind, results))
  tibble::tibble(
    rd_est = results$rd_est,
    rd_se = results$rd_se,
    rd_var = results$rd_se^2,
    p_cmh = results$p_cmh,
    z_stat = results$z_stat
  )
}

#' Calculate results across binary-imputation scenarios
#'
#' Runs `h_impute_analyze_resp()` for each paired control and treatment response
#' probability, pools estimates across imputations using Rubin's rules, and
#' pools Wilson-Hilferty z statistics to obtain a p-value. A scenario where both
#' probabilities are zero or one is deterministic and is therefore analyzed
#' once rather than repeatedly imputed.
#'
#' @param dat (`data.frame`)
#'   Analysis data containing treatment, response, and stratification variables.
#' @param p_ctrl (`numeric`)
#'   Control-group response probabilities, one for each scenario.
#' @param p_trt (`numeric`)
#'   Treatment-group response probabilities, paired with `p_ctrl` by position.
#' @param trtvar (`string`)
#'   Name of the treatment variable in `dat`.
#' @param ctrlab (`string`)
#'   Value of `trtvar` identifying the control group.
#' @param trtlab (`string`)
#'   Value of `trtvar` identifying the treatment group.
#' @param respvar (`string`)
#'   Name of a logical binary response variable in `dat`.
#' @param stratvar (`character`)
#'   Names of one or more stratification variables in `dat`.
#' @param n_imputations (`count`)
#'   Number of imputations for non-deterministic scenarios.
#' @param pvalcat (named `list`)
#'   P-value categories passed to [categorize_pval()].
#'
#' @return A tibble with one row per scenario. `rd` and `rd_se` are the pooled
#' risk-difference estimate and standard error; `p_value` and `p_cat` are the
#' pooled p-value and its category. `marker_flag` and `effect_label` contain
#' `"*"` when a deterministic scenario or a single-imputation p-value fallback
#' was used.
#'
#' @examples
#' dat <- data.frame(
#'   arm = rep(c("Control", "Treatment"), each = 4),
#'   response = c(TRUE, FALSE, NA, TRUE, TRUE, FALSE, NA, FALSE),
#'   strata = rep(c("A", "B"), 4)
#' )
#' pvalcat <- list("<0.05" = c(0, 0.05), ">=0.05" = c(0.05, 1))
#'
#' set.seed(123)
#' resp_multiple_imputation(
#'   dat,
#'   p_ctrl = c(0, 0.25),
#'   p_trt = c(1, 0.75),
#'   trtvar = "arm",
#'   ctrlab = "Control",
#'   trtlab = "Treatment",
#'   respvar = "response",
#'   stratvar = "strata",
#'   n_imputations = 5,
#'   pvalcat = pvalcat
#' )
#' @export
resp_multiple_imputation <- function(
  dat,
  p_ctrl,
  p_trt,
  trtvar,
  ctrlab,
  trtlab,
  respvar,
  stratvar,
  n_imputations,
  pvalcat
) {
  checkmate::assert_numeric(p_ctrl, min.len = 1, lower = 0, upper = 1, finite = TRUE)
  checkmate::assert_numeric(p_trt, min.len = 1, lower = 0, upper = 1, finite = TRUE)
  checkmate::assert_true(length(p_ctrl) == length(p_trt))
  checkmate::assert_count(n_imputations, positive = TRUE)
  checkmate::assert_list(h_normalize_pvalcat(pvalcat)) # Just to check that it works.

  results <- lapply(seq_along(p_ctrl), function(i) {
    control_probability <- p_ctrl[[i]]
    treatment_probability <- p_trt[[i]]
    m <- if (all(c(control_probability, treatment_probability) %in% c(0, 1))) 1L else n_imputations

    per_imputation <- h_impute_analyze_resp(
      dat = dat,
      p_ctrl = control_probability,
      p_trt = treatment_probability,
      trtvar = trtvar,
      ctrlab = ctrlab,
      trtlab = trtlab,
      respvar = respvar,
      stratvar = stratvar,
      n_imputations = m
    )

    if (m == 1) {
      estimate <- per_imputation$rd_est[[1]]
      standard_error <- per_imputation$rd_se[[1]]
      p_value <- per_imputation$p_cmh[[1]]
      used_fallback <- TRUE
    } else {
      pooled_rd <- pool_rubin_scalar(per_imputation$rd_est, per_imputation$rd_var)
      estimate <- pooled_rd$est
      standard_error <- pooled_rd$se
      pooled_p_value <- pool_z_stat(per_imputation$z_stat)$p
      used_fallback <- is.na(pooled_p_value) || !is.finite(pooled_p_value)
      p_value <- if (used_fallback) per_imputation$p_cmh[[1]] else pooled_p_value
    }

    marker_flag <- if (m == 1 || used_fallback) "*" else ""
    tibble::tibble(
      p_ctrl = control_probability,
      p_trt = treatment_probability,
      m = m,
      rd = estimate,
      rd_se = standard_error,
      p_value = p_value,
      p_cat = categorize_pval(p_value, pvalcat),
      marker_flag = marker_flag,
      effect_label = paste0(
        formatC(100 * estimate, format = "f", digits = 1),
        "%",
        marker_flag
      )
    )
  })

  tibble::as_tibble(do.call(rbind, results))
}

#' @noRd
#' @title internal helpers for ancova
#' @description Internal helper that derives adjusted means and contrasts for a single
#' treatment level from an `emmeans` ANCOVA fit, optionally handling interaction
#' terms and reference group contrasts.
#'
#' @param emmeans_fit (`emmGrid`)\cr
#'   Object returned by [emmeans::emmeans()].
#' @param sum_level (`character`)\cr
#'   Single treatment level for which estimates are requested.
#' @inheritParams tern::s_ancova
#'
#' @return A list with components:
#' * `sum_fit_level`: summary statistics for the adjusted mean.
#' * `sum_contrasts_level`: contrast estimates versus reference (if applicable).
#' * `y`: observed response values used for `n`.
#'
#' @keywords internal

h_ancova_est_single <- function(emmeans_fit,
                                sum_level,
                                interaction_y,
                                interaction_item,
                                df,
                                .var,
                                .df_row,
                                .ref_group,
                                arm,
                                conf_level,
                                .in_ref_col) {
  # Ensure that there is only one element in sum_level.
  checkmate::assert_scalar(sum_level)

  sum_fit <- summary(
    emmeans_fit,
    level = conf_level
  )

  sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, , drop = FALSE]

  # Get the index of the ref arm
  if (interaction_y != FALSE) {
    y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])
    # convert characters selected in interaction_y into the numeric order
    interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)
    sum_fit_level <- sum_fit_level[interaction_y, ]
    # if interaction is called, reset the index
    ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
    ref_key <- utils::tail(ref_key, n = 1)
    ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key
  } else {
    y <- df[[.var]]
    # Get the index of the ref arm when interaction is not called
    ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
    ref_key <- utils::tail(ref_key, n = 1)
  }

  if (.in_ref_col) {
    sum_contrasts_level <- list()
    sum_contrasts_level[["estimate"]] <- numeric()
    sum_contrasts_level[["lower.CL"]] <- numeric()
    sum_contrasts_level[["upper.CL"]] <- numeric()
    sum_contrasts_level[["p.value"]] <- numeric()
  } else {
    if (!is.null(.ref_group)) {
      # Estimate the differences between the marginal means.
      emmeans_contrasts <- emmeans::contrast(
        emmeans_fit,
        # Compare all arms versus the control arm.
        method = "trt.vs.ctrl",
        # Take the arm factor from .ref_group as the control arm.
        ref = ref_key,
        level = conf_level
      )
      sum_contrasts <- summary(
        emmeans_contrasts,
        # Derive confidence intervals, t-tests and p-values.
        infer = TRUE,
        # Do not adjust the p-values for multiplicity.
        adjust = "none"
      )

      contrast_lvls <- gsub(
        "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
      )
      if (!is.null(interaction_item)) {
        sum_contrasts_level <- sum_contrasts[
          grepl(sum_level, contrast_lvls, fixed = TRUE), ,
          drop = FALSE
        ]
      } else {
        sum_contrasts_level <- sum_contrasts[
          (sum_level == contrast_lvls | paste0("(", sum_level, ")") == contrast_lvls), ,
          drop = FALSE
        ]
      }
      if (interaction_y != FALSE) {
        sum_contrasts_level <- sum_contrasts_level[interaction_y, , drop = FALSE]
      }
    } else {
      sum_contrasts_level <- list()
      sum_contrasts_level[["estimate"]] <- NA
      sum_contrasts_level[["lower.CL"]] <- NA
      sum_contrasts_level[["upper.CL"]] <- NA
      sum_contrasts_level[["p.value"]] <- NA
    }
  }
  ret <- list(
    sum_fit_level = sum_fit_level,
    sum_contrasts_level = sum_contrasts_level,
    y = y
  )
  ret
}



#' Internal utility to construct contrast weights across treatment levels,
#' supporting equal or proportional weighting schemes.
#' @noRd
#' @param weight_mode (`character`)\cr
#'   Weighting strategy: `"equal"` or `"proportional"`.
#' @param normalize (`logical`)\cr
#'   Whether to normalize weights to sum to 1.
#' @param sum_fit (`data.frame`)\cr
#'   Summary output from [emmeans::summary.emmGrid()].
#' @param sum_levels (`character`)\cr
#'   Treatment levels included in the combination.
#' @param arm (`character`)\cr
#'   Treatment arm variable name.
#' @param data (`data.frame` | `NULL`)\cr
#'   Dataset used to derive proportional weights.
#'
#' @return A named numeric vector of weights for all treatment levels.
#'
#' @keywords internal

make_contrast_weights <- function(
  sum_fit,
  sum_levels,
  arm,
  data,
  weight_mode = c("equal", "proportional"),
  normalize = TRUE) {
  weight_mode <- match.arg(weight_mode)
  trt_levels <- levels(sum_fit[[arm]])
  # weights for contrast contains all trt_levels from sum_fit, not just the sum_levels
  # zero for all levels
  w_all <- setNames(numeric(length(trt_levels)), trt_levels)

  if (weight_mode == "equal") {
    w <- rep(1, length(sum_levels))
    names(w) <- sum_levels
  } else if (weight_mode == "proportional") {
    w <- table(data[[arm]])[sum_levels]
  }

  if (normalize) {
    w <- w / sum(w)
  }

  # update the weights for sum_levels with the above values
  w_all[names(w)] <- w[names(w)]
  w_all
}



#' Internal helper that derives adjusted means and contrasts for combined
#' treatment levels using contrast-based weighting from an `emmeans` ANCOVA fit.
#' @noRd
#' @inheritParams tern::s_ancova
#' @param weights_combo (`character`)\cr
#'   Weighting method for combined contrasts.
#'
#' @return A list with components:
#' * `sum_fit_level`: adjusted mean estimates for the combination.
#' * `sum_contrasts_level`: contrast estimates versus reference.
#' * `y`: observed response values used for `n`.
#'
#' @keywords internal

h_ancova_est_combined <- function(
  emmeans_fit,
  sum_level,
  interaction_y,
  interaction_item,
  df,
  .var,
  .df_row,
  .ref_group,
  arm,
  conf_level,
  .in_ref_col,
  weights_combo) {
  if (.in_ref_col) {
    stop("not intended for usage in reference column")
  }
  if (is.null(weights_combo)) {
    stop("In a combined column specifications for weights_combo must be non-NULL.")
  } else {
    weights_combo <- match.arg(weights_combo,
      choices = c("equal", "proportional", "proportional_marginal"),
      several.ok = FALSE
    )
  }
  sum_fit <- summary(
    emmeans_fit,
    level = conf_level
  )
  ref_name <- unique(.ref_group[[arm]])

  # weights for contrasts, proportional/proportianal_marginal or equal
  # proportional_marginal is only relevant for an interaction term between arm and interaction_item
  # when no interaction proportional_marginal and proportional yield the same weights
  # when interaction :
  # weights with proportional will be within the given level of the interaction_item (ie interaction_y)
  # weights with proportional_marginal will across all levels of the interaction_item
  if (weights_combo == "proportional" && (interaction_y != FALSE)) {
    data_weights <- df[!is.na(.var), ]
    data_weights <- data_weights[(data_weights[[interaction_item]] == interaction_y), ]
  } else if (weights_combo %in% c("proportional", "proportional_marginal")) {
    data_weights <- df[!is.na(.var), ]
    weights_combo <- "proportional"
  } else {
    data_weights <- NULL
  }

  w <- make_contrast_weights(
    weight_mode = weights_combo,
    normalize = TRUE,
    sum_fit = sum_fit,
    sum_levels = sum_level,
    arm = arm,
    data = data_weights
  )
  w2 <- w
  w2[ref_name] <- -1

  if (interaction_y == FALSE) {
    y <- df[[.var]]
    w_start <- as.data.frame(emmeans_fit)
    w_start[["weights1"]] <- w
    w_start[["weights2"]] <- w2
  } else {
    y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])

    w_start <- as.data.frame(emmeans_fit)
    w_start[["weights1"]] <- 0
    w_start[["weights2"]] <- 0
    w_start[["weights1"]][w_start[[interaction_item]] == interaction_y] <- w
    w_start[["weights2"]][w_start[[interaction_item]] == interaction_y] <- w2
  }

  contr <- emmeans::contrast(emmeans_fit,
                             list(setNames(list(w_start[["weights1"]]), "Estimate contrast"),
                                  setNames(list(w_start[["weights2"]]), "Estimate contrast vs ref")),
                             # Derive confidence intervals, t-tests and p-values.
                             infer = TRUE,
                             # Do not adjust the p-values for multiplicity.
                             adjust = "none")

  contr_df <- as.data.frame(contr)

  contr_df[["emmeans"]] <- contr_df[["estimate"]]
  sum_fit_level <- contr_df[contr_df$contrast == "Estimate contrast", , drop = FALSE]
  sum_contrasts_level <- contr_df[contr_df$contrast == "Estimate contrast vs ref", , drop = FALSE]

  if (length(ref_name) == 0) {
    sum_contrasts_level <- list()
    sum_contrasts_level[["estimate"]] <- numeric()
    sum_contrasts_level[["lower.CL"]] <- numeric()
    sum_contrasts_level[["upper.CL"]] <- numeric()
    sum_contrasts_level[["p.value"]] <- numeric()
  }

  ret <- list(
    sum_fit_level = sum_fit_level,
    sum_contrasts_level = sum_contrasts_level,
    y = y
  )
  ret
}

#' @title Junco Extended ANCOVA Function
#' @name s_ancova_j
#' @inheritParams tern::s_ancova
#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `"counterfactual"` by default.
#' @param method_combo (`string`)\cr Method for derivations in combined column.
#'   * `contrast` Derivations for the combined level are done through contrasts from the original model
#' (using weights per `weights_combo` specifications).
#'   * `collapse` The ancova model for the combined group will be performed with group levels that contribute
#' to the combination collapsed into a single combined level.
#'
#' For more information see the vignette `ANCOVA with Combined Treatment Groups`.
#' @param weights_combo (`string`)\cr Weights for the contrasts of the combined levels.
#'   * `equal` 1/(number of levels from arm variable included in the combination)
#'   * `proportional`, `proportional_marginal` weight for each level included in
#'    the combination is proportional to number of observations in that level
#'\cr The difference between `proportional` and `proportional_marginal` is only
#'relevant when the model includes an interaction between arm and other factor variable (`interaction_item`).
#'\cr `proportional_marginal` interprets proportional over all levels of
#' `interaction_item`, ie, the same weights will be used for all levels of `interaction_item`.
#'\cr For `proportional` the weights will be derived within
#'the requested level (`interaction_y`) for `interaction_item`.
#' @description Extension to tern:::s_ancova, 3 extra statistics are returned:
#'   * `lsmean_se`: Marginal mean and estimated SE in the group.
#'   * `lsmean_ci`: Marginal mean and associated confidence interval in the group.
#'   * `lsmean_diff_with_ci`: Difference in mean and associated confidence level in one combined statistic.
#'   In addition, the LS mean weights can be specified.
#'   In addition, also a NULL .ref_group can be specified, the lsmean_diff related estimates will be returned as NA.
#' @export
#' @return Returns a named list of 8 statistics (3 extra compared to `tern:::s_ancova()`).
#' @family Inclusion of ANCOVA Functions
#' @examples
#' library(dplyr)
#' library(tern)
#'
#' df <- iris |> filter(Species == "virginica")
#' .df_row <- iris
#' .var <- "Petal.Length"
#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
#' .ref_group <- iris |> filter(Species == "setosa")
#' conf_level <- 0.95
#' s_ancova_j(df, .var, .df_row, variables, .ref_group, .in_ref_col = FALSE, conf_level)
s_ancova_j <- function(
  df,
  .var,
  .df_row,
  variables,
  .ref_group,
  .in_ref_col,
  conf_level,
  interaction_y = FALSE,
  interaction_item = NULL,
  weights_emmeans = "counterfactual",
  method_combo = c("contrasts", "collapse"),
  weights_combo = NULL) {
  if ((!is.null(interaction_item) && interaction_y == FALSE) ||
        (is.null(interaction_item) && interaction_y != FALSE)) {
    stop(
      "If interaction is needed it is required to set interaction_item to variable for interaction",
      "\n and interaction_y to a level of the interaction variable.",
      "\n If interaction is not needed, set interaction_y to FALSE and interaction_item to NULL."
    )
  }
  arm <- variables$arm
  method_combo <- match.arg(method_combo)

  .df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
  df <- subset(df, !is.na(df[[.var]]))
  .ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))

  n_obs_trt_lvls <- length(unique(.df_row[[arm]]))

  arm <- variables$arm
  sum_level_start <- as.character(unique(df[[arm]]))

  incombo <- length(sum_level_start) > 1
  if (incombo && method_combo == "collapse") {
    # proceed with model on updated levels for treatment group
    orig_levels <- levels(.df_row[[arm]])
    new_levels <- orig_levels
    new_levels[orig_levels %in% sum_level_start] <- "Combined"

    df[[arm]] <- factor(as.character(df[[arm]]),
                        levels = orig_levels,
                        labels = new_levels)
    .df_row[[arm]] <- factor(as.character(.df_row[[arm]]),
                             levels = orig_levels,
                             labels = new_levels)
    .ref_group[[arm]] <- factor(as.character(.ref_group[[arm]]),
                                levels = orig_levels,
                                labels = new_levels)
  }

  ### sparse data problems with underlying ancova function
  if (NROW(.df_row) == 0) {
    ret <- NULL
  } else if (NROW(df) == 0 || n_obs_trt_lvls < 2) {
    ## all stats are NA
    ret <- list(
      n_fit = with_label(0, "n"),
      lsmean = with_label(NA, "Adjusted Mean"),
      lsmean_se = with_label(rep(NA, 2), "Adjusted Mean (SE)"),
      lsmean_ci = with_label(
        rep(NA, 3),
        paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
      ),
      lsmean_diff = with_label(NA, "Difference in Adjusted Means"),
      lsmean_diff_ci = with_label(
        rep(NA, 2),
        paste("Difference in Adjusted Means", f_conf_level(conf_level))
      ),
      lsmean_diff_with_ci = with_label(
        rep(NA, 3),
        paste0(
          "Difference in Adjusted Means",
          " (",
          f_conf_level(conf_level),
          ")"
        )
      ),
      pval = with_label(NA, "p-value")
    )
  } else {
    if (NROW(.ref_group) == 0) {
      .ref_group <- NULL
    } else if (length(levels(.df_row[[arm]])) > n_obs_trt_lvls) {
      # missing arm levels need to be removed from the factor, in order to have the correct estimates,
      # and avoid errors with further code
      .df_row[[arm]] <- droplevels(.df_row[[arm]])
      df[[arm]] <- factor(
        as.character(df[[arm]]),
        levels = levels(.df_row[[arm]])
      )
      .ref_group[[arm]] <- factor(
        as.character(.ref_group[[arm]]),
        levels = levels(.df_row[[arm]])
      )
    }

    emmeans_fit <- tern::h_ancova(
      .var = .var,
      variables = variables,
      .df_row = .df_row,
      weights_emmeans = weights_emmeans,
      interaction_item = interaction_item
    )
    sum_fit <- summary(
      emmeans_fit,
      level = conf_level
    )
    sum_level <- as.character(unique(df[[arm]]))

    if (length(sum_level) == 1) {
      est_single_fit <- h_ancova_est_single(
        emmeans_fit,
        sum_level,
        interaction_y,
        interaction_item,
        df,
        .var,
        .df_row,
        .ref_group,
        arm,
        conf_level,
        .in_ref_col
      )

      sum_fit_level <- est_single_fit[["sum_fit_level"]]
      sum_contrasts_level <- est_single_fit[["sum_contrasts_level"]]
      y <- est_single_fit[["y"]]
    } else {
      est_combined_fit <- h_ancova_est_combined(
        emmeans_fit,
        sum_level,
        interaction_y,
        interaction_item,
        df,
        .var,
        .df_row,
        .ref_group,
        arm,
        conf_level,
        .in_ref_col,
        weights_combo
      )

      sum_fit_level <- est_combined_fit[["sum_fit_level"]]
      sum_contrasts_level <- est_combined_fit[["sum_contrasts_level"]]
      y <- est_combined_fit[["y"]]
    }

    ret <- list(
      n_fit = with_label(length(y[!is.na(y)]), "n"),
      lsmean = with_label(sum_fit_level$emmean, "Adjusted Mean"),
      lsmean_se = with_label(
        c(sum_fit_level$emmean, sum_fit_level$SE),
        "Adjusted Mean (SE)"
      ),
      lsmean_ci = with_label(
        c(
          sum_fit_level$emmean,
          sum_fit_level$lower.CL,
          sum_fit_level$upper.CL
        ),
        paste0("Adjusted Mean", " (", f_conf_level(conf_level), ")")
      ),
      lsmean_diff = with_label(
        sum_contrasts_level$estimate,
        "Difference in Adjusted Means"
      ),
      lsmean_diff_ci = with_label(
        c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),
        paste("Difference in Adjusted Means", f_conf_level(conf_level))
      ),
      lsmean_diff_with_ci = with_label(
        c(
          sum_contrasts_level$estimate,
          sum_contrasts_level$lower.CL,
          sum_contrasts_level$upper.CL
        ),
        paste0(
          "Difference in Adjusted Means",
          " (",
          f_conf_level(conf_level),
          ")"
        )
      ),
      pval = with_label(sum_contrasts_level$p.value, "p-value")
    )
  }
  return(ret)
}

#' @name s_summarize_ancova_j
#' @title ANCOVA Summary Function
#' @description Combination of [tern::s_summary], and ANCOVA based estimates for mean and diff between columns,
#' based on ANCOVA function `s_ancova_j`.
#' @inherit s_ancova_j
#' @param ... Additional arguments passed to `s_ancova_j`.
#' @details Combination of [tern::s_summary], and ANCOVA based estimates for mean and diff between columns,
#' based on ANCOVA function `s_ancova_j`
#' @return returns the statistics from `tern::s_summary(x)`, appended with a new statistics based upon ANCOVA
#' @export
#' @family Inclusion of ANCOVA Functions
# @seealso s_ancova_j
#' @examples
#' library(dplyr)
#' library(tern)
#'
#' df <- iris |> filter(Species == "virginica")
#' .df_row <- iris
#' .var <- "Petal.Length"
#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
#' .ref_group <- iris |> filter(Species == "setosa")
#' conf_level <- 0.95
#' s_summarize_ancova_j(
#'   df,
#'   .var = .var,
#'   .df_row = .df_row,
#'   variables = variables,
#'   .ref_group = .ref_group,
#'   .in_ref_col = FALSE,
#'   conf_level = conf_level
#' )
s_summarize_ancova_j <- function(
  df,
  .var,
  .df_row,
  .ref_group,
  .in_ref_col,
  ...) {
  x <- df[[.var]]
  y1 <- s_summary(x)
  y2 <- s_ancova_j(
    df = df,
    .var = .var,
    .ref_group = .ref_group,
    .in_ref_col = .in_ref_col,
    .df_row = .df_row,
    ...
  )
  c(y1, y2)
}

#' @describeIn s_summarize_ancova_j Formatted analysis function which is used as `afun`. Note that the
#'   junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
#'
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#'
#' @return
#' * `a_summarize_ancova_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#'
#' basic_table() |>
#'   split_cols_by("Species") |>
#'   add_colcounts() |>
#'   analyze(
#'     vars = "Petal.Length",
#'     afun = a_summarize_ancova_j,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     table_names = "unadj",
#'     var_labels = "Unadjusted comparison",
#'     extra_args = list(
#'       variables = list(arm = "Species", covariates = NULL),
#'       conf_level = 0.95,
#'       .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means"),
#'       ref_path = c("Species", "setosa")
#'     )
#'   ) |>
#'   analyze(
#'     vars = "Petal.Length",
#'     afun = a_summarize_ancova_j,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     table_names = "adj",
#'     var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)",
#'     extra_args = list(
#'       variables = list(
#'         arm = "Species",
#'         covariates = c("Sepal.Length", "Sepal.Width")
#'       ),
#'       conf_level = 0.95,
#'       ref_path = c("Species", "setosa")
#'     )
#'   ) |>
#'   build_table(iris)
#'
#' @export
#' @order 2
a_summarize_ancova_j <- function(
  df,
  .var,
  .df_row,
  ref_path,
  .spl_context,
  ...,
  .stats = c(
    "n",
    "mean_sd",
    "median",
    "range",
    "quantiles",
    "lsmean_se",
    "lsmean_ci",
    "lsmean_diff_with_ci",
    "pval"
  ),
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_summarize_ancova_j,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .df_row = list(.df_row),
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "summarize_ancova_j",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Tabulation of RBMI Results
#'
#' @description `r lifecycle::badge('stable')`
#'
#' These functions can be used to produce tables from RBMI.
#'
#' @name tabulate_rbmi
#'
#' @note These functions have been forked from `tern.rbmi`. Additional features are:
#'
#' * Additional `ref_path` argument.
#' * Extraction of variance statistics in the `tidy()` method.
#' * Adapted to `rbmi` forked functions update with more than two treatment groups.
NULL

#' @describeIn tabulate_rbmi Helper function to produce data frame with results
#'   of pool for a single visit.
#'
#' @param x (`list`)\cr is a list of pooled object from `rbmi` analysis results.
#'   This list includes analysis results, confidence level, hypothesis testing type.
#' @param visit_name (`string`)\cr single visit level.
#' @param group_names (`character`)\cr group levels.
#' @return
#' * `h_tidy_pool()` returns a `data.frame` with results of pooled analysis for a single visit.
#'
#' @export
h_tidy_pool <- function(x, visit_name, group_names) {
  checkmate::assert_list(x)
  checkmate::assert_string(visit_name)
  checkmate::assert_character(group_names)

  ref_name <- paste0("lsm_", group_names[1], "_", visit_name)
  ref <- x[[ref_name]]

  list2df <- \(l) with(l, data.frame(est, ci_l = ci[1], ci_u = ci[2], se, pvalue, df))

  var_name <- paste0("var_", visit_name)
  var <- if (var_name %in% names(x)) {
    # This is the case for ANCOVA.
    list2df(x[[var_name]])
  } else {
    # This is the case for MMRM.
    var_names <- paste0("var_", group_names[-1], "_", visit_name)
    checkmate::assert_subset(var_names, names(x))
    var_dfs <- lapply(x[var_names], list2df)
    var <- do.call(rbind, var_dfs)
  }

  contr_names <- paste0("trt_", group_names[-1], "_", visit_name)
  contr_dfs <- lapply(x[contr_names], list2df)
  contr <- do.call(rbind, contr_dfs)

  alt_names <- paste0("lsm_", group_names[-1], "_", visit_name)
  alt_dfs <- lapply(x[alt_names], list2df)
  alt <- do.call(rbind, alt_dfs)

  df_ref <- data.frame(
    visit = visit_name,
    group = group_names[1],
    est = ref$est,
    se_est = ref$se,
    lower_cl_est = ref$ci[1],
    upper_cl_est = ref$ci[2],
    est_contr = NA_real_,
    se_contr = NA_real_,
    lower_cl_contr = NA_real_,
    upper_cl_contr = NA_real_,
    p_value = NA_real_,
    relative_reduc = NA_real_,
    mse = NA_real_,
    df = NA_real_,
    stringsAsFactors = FALSE
  )
  df_alt <- data.frame(
    visit = visit_name,
    group = group_names[-1],
    est = alt$est,
    se_est = alt$se,
    lower_cl_est = alt$ci_l,
    upper_cl_est = alt$ci_u,
    est_contr = contr$est,
    se_contr = contr$se,
    lower_cl_contr = contr$ci_l,
    upper_cl_contr = contr$ci_u,
    p_value = contr$pvalue,
    relative_reduc = contr$est / df_ref$est,
    mse = var$est,
    df = var$df,
    stringsAsFactors = FALSE
  )
  rbind(df_ref, df_alt)
}

#' Helper method (for [`broom::tidy()`]) to prepare a data frame from an
#'   `pool` `rbmi` object containing the LS means and contrasts and multiple visits
#'
#' @method tidy pool
#' @param x (`pool`) is a list of pooled object from `rbmi` analysis results. This list includes
#' analysis results, confidence level, hypothesis testing type.
#' @param visits (`character`)\cr all visit levels. Otherwise too hard to guess this.
#' @param ... Additional arguments. Not used. Needed to match generic signature only.
#' @importFrom generics tidy
#' @export
#' @keywords internal
#' @return A `data.frame`.
tidy.pool <- function(x, visits, ...) {
  ls_raw <- x$pars

  has_lsm <- grepl("^lsm_", names(ls_raw))
  has_first_visit <- grepl(paste0("_", visits[1]), names(ls_raw), fixed = TRUE)
  is_lsm_first_visit <- has_lsm & has_first_visit

  group_names <- names(ls_raw)[is_lsm_first_visit]
  group_names <- gsub(pattern = "^lsm_", replacement = "", x = group_names)
  group_names <- gsub(pattern = paste0("_", visits[1]), replacement = "", x = group_names, fixed = TRUE)

  spl <- rep(visits, each = length(ls_raw) / length(visits))

  ls_split <- split(ls_raw, spl)

  ls_df <- mapply(
    FUN = h_tidy_pool,
    x = ls_split,
    visit_name = visits,
    MoreArgs = list(group_names = group_names),
    SIMPLIFY = FALSE
  )

  result <- do.call(rbind, unname(ls_df))

  result$visit <- factor(result$visit, levels = visits)
  result$group <- factor(result$group, levels = group_names)
  result$conf_level <- x$conf.level

  result
}

#' @describeIn tabulate_rbmi Statistics function which is extracting estimates
#'   from a tidied RBMI results data frame.
#'
#' @param df (`data.frame`)\cr input with LS means results.
#' @param .in_ref_col (`flag`)\cr whether reference column is specified.
#' @param show_relative (`string`)\cr 'reduction' if (`control - treatment`, default)
#'   or 'increase' (`treatment - control`) of relative change from baseline?
#' @return
#' * `s_rbmi_lsmeans()` returns a list of statistics extracted from a tidied LS means data frame.
#' @export
s_rbmi_lsmeans <- function(df, .in_ref_col, show_relative = c("reduction", "increase")) {
  checkmate::assert_flag(.in_ref_col)

  show_relative <- match.arg(show_relative)
  if_not_ref <- function(x) if (.in_ref_col) character() else x
  list(
    adj_mean_se = c(df$est, df$se_est),
    adj_mean_ci = with_label(c(df$lower_cl_est, df$upper_cl_est), f_conf_level(df$conf_level)),
    diff_mean_se = if_not_ref(c(df$est_contr, df$se_contr)),
    diff_mean_ci = with_label(
      if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
      f_conf_level(df$conf_level)
    ),
    change = switch(show_relative,
      reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
      increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
    ),
    p_value = if_not_ref(df$p_value),
    additional_title_row = NULL
  )
}

#' @describeIn tabulate_rbmi Formatted Analysis function which is used as `afun`.
#'
#' @inheritParams proposal_argument_convention
#' @export
a_rbmi_lsmeans <- function(
  df,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_rbmi_lsmeans,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "tabulate_rbmi",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Extract Estimates from Multivariate Cox Regression Model Fit Object
#'
#' @param x (`coxreg.multivar`)\cr from [tern::fit_coxreg_multivar()].
#' @export
#' @return A data frame containing Cox regression results with columns for term,
#'   coef_se (coefficient and standard error), p.value, hr (hazard ratio),
#'   hr_ci (confidence interval for hazard ratio), and labels (formatted term labels).
#' @keywords internal
#'
#' @examples
#' anl <- tern::tern_ex_adtte |>
#'   dplyr::mutate(EVENT = 1 - CNSR)
#'
#' variables <- list(
#'   time = "AVAL",
#'   event = "EVENT",
#'   arm = "ARM",
#'   covariates = c("SEX", "AGE")
#' )
#'
#' control <- tern::control_coxreg(
#'   conf_level = 0.9,
#'   ties = "efron"
#' )
#'
#' fit <- tern::fit_coxreg_multivar(
#'   data = anl,
#'   variables = variables,
#'   control = control
#' )
#'
#' h_extract_coxreg_multivar(fit)
h_extract_coxreg_multivar <- function(x) {
  checkmate::assert_class(x, "coxreg.multivar")
  vars <- c(x$vars$arm, x$vars$covariates)

  # Extract the table.
  tab <- broom::tidy(x$mod, exponentiate = FALSE, conf.int = TRUE, conf.level = x$control$conf_level)
  tab$hr <- exp(tab$estimate)
  tab$hr_ci <- Map(lcl = exp(tab$conf.low), ucl = exp(tab$conf.high), f = function(lcl, ucl) c(lcl, ucl))
  tab$coef_se <- Map(coef = tab$estimate, se = tab$std.error, f = function(coef, se) c(coef, se))
  colnms <- c("term", "coef_se", "p.value", "hr", "hr_ci")
  tab <- tab[, colnms, drop = FALSE]

  # Format nicely the term labels.
  var_to_term <- sapply(vars, function(v) which(startsWith(tab$term, v)), USE.NAMES = TRUE, simplify = FALSE)
  tab$labels <- unlist(lapply(vars, function(v) {
    inds <- var_to_term[[v]]
    strip_term <- gsub(paste0("^", v), "", tab$term[inds])
    this_df <- x$dat[v]
    if (is.character(this_df[[1]])) {
      this_df[[1]] <- as.factor(this_df[[1]])
    }
    if (is.factor(this_df[[1]])) {
      ref_level <- levels(this_df[[1]])[1]
      var_name <- if (v == x$vars$arm) "Treatment" else labels_or_names(this_df)
      paste0(var_name, " (", strip_term, " vs. ", ref_level, ")")
    } else {
      labels_or_names(this_df)
    }
  }))
  tab
}

#' First Level Column Split Function for TEFOS03 (mmy) Table Layout
#' @seealso [rtables::make_split_fun()] for details.
#' @keywords internal
tefos03_first_post_fun <- function(ret, spl, fulldf, .spl_context) {
  all_expr <- expression(TRUE)
  short_split_result(model_fit = "Model Fit", hazard_ratio = "Hazard Ratio", fulldf = fulldf)
}
tefos03_first_split_fun <- make_split_fun(post = list(tefos03_first_post_fun))

#' Second Level Column Split Function Factory for TEFOS03 (mmy) Table Layout
#'
#' @inheritParams proposal_argument_convention
#'
#' @return Split function to use in the TEFOS03 (mmy) and related table layouts.
#'
#' @seealso [tefos03_first_post_fun()] for the first level split.
#' @keywords internal
tefos03_second_split_fun_fct <- function(conf_level) {
  post_fun <- function(ret, spl, fulldf, .spl_context) {
    all_expr <- expression(TRUE)
    colset <- .spl_context[nrow(.spl_context), "value"][[1]]
    if (colset == "model_fit") {
      short_split_result(coef_se = "Coeff. (SE)", pval = "p-value", fulldf = fulldf)
    } else {
      short_split_result(hr_est = "Estimate", hr_ci = f_conf_level(conf_level), fulldf = fulldf)
    }
  }
  make_split_fun(post = list(post_fun))
}

#' @importFrom tern fit_coxreg_multivar
#' @keywords internal
memoised_fit_coxreg_multivar <- memoise::memoise(fit_coxreg_multivar)

#' Analysis Function for TEFOS03 and Related Table Layouts
#'
#' @inheritParams proposal_argument_convention
#' @param control (`list`)\cr from [tern::control_coxreg()].
#' @param formats (`list`)\cr including `coef_se`, `hr_est`, `hr_ci` and `pval` formats.
#' @param variables (`list`)\cr see [tern::fit_coxreg_multivar()] for required variable
#'   specifications.
#'
#' @keywords internal
tefos03_afun <- function(df, .var, .spl_context, variables, control, formats) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  model_fit <- memoised_fit_coxreg_multivar(data = df, variables = variables, control = control)
  tab <- h_extract_coxreg_multivar(model_fit)
  if (this_col_split[1] == "model_fit") {
    if (this_col_split[2] == "coef_se") {
      in_rows(.list = tab$coef_se, .formats = formats$coef_se, .labels = tab$labels)
    } else {
      in_rows(.list = tab$p.value, .formats = formats$pval, .labels = tab$labels)
    }
  } else {
    if (this_col_split[2] == "hr_est") {
      in_rows(.list = tab$hr, .formats = formats$hr_est, .labels = tab$labels)
    } else {
      in_rows(.list = tab$hr_ci, .formats = formats$hr_ci, .labels = tab$labels)
    }
  }
}

#' Layout Generating Function for TEFOS03 and Related Cox Regression Layouts
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams tefos03_afun
#' @param var (`string`)\cr any variable from the data, because this is not used.
#'
#' @return `lyt` modified to add the desired cox regression table section.
#' @export
#' @examples
#' anl <- tern::tern_ex_adtte |>
#'   dplyr::mutate(EVENT = 1 - CNSR)
#'
#' variables <- list(
#'   time = "AVAL",
#'   event = "EVENT",
#'   arm = "ARM",
#'   covariates = c("SEX", "AGE")
#' )
#'
#' basic_table() |>
#'   summarize_coxreg_multivar(
#'     var = "STUDYID",
#'     variables = variables
#'   ) |>
#'   build_table(df = anl)
summarize_coxreg_multivar <- function(
  lyt,
  var,
  variables,
  control = control_coxreg(),
  formats = list(
    coef_se = jjcsformat_xx("xx.xx (xx.xx)"),
    hr_est = jjcsformat_xx("xx.xx"),
    hr_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
    pval = jjcsformat_pval_fct(0)
  )
) {
  second_split_fun <- tefos03_second_split_fun_fct(conf_level = control$conf_level)
  lyt |>
    split_cols_by(var = var, split_fun = tefos03_first_split_fun) |>
    split_cols_by(var = var, split_fun = second_split_fun) |>
    analyze(
      vars = var,
      var_labels = "Model Parameter",
      show_labels = "visible",
      afun = tefos03_afun,
      extra_args = list(variables = variables, control = control, formats = formats)
    )
}

#' Split Function for Compliance Columns
#'
#' Here we just split into 3 columns for expected, received and missing visits.
#'
#' @inheritParams proposal_argument_convention
#' @param ret (`list`)\cr result from previous split function steps.
#' @param spl (`split`)\cr split object.
#' @param fulldf (`data.frame`)\cr full data frame.
#' @param vals (`character`)\cr values to use for the split.
#' @param trim (`logical`)\cr whether to trim the values.
#'
#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
#'   post-processing function.
cmp_post_fun <- function(ret, spl, fulldf, .spl_context) {
  short_split_result(
    expected = "Expected, N",
    received = "Received, n (%)",
    missing = "Missing, n (%)",
    fulldf = fulldf
  )
}
#' @rdname cmp_post_fun
#' @return a split function for use with [rtables::split_rows_by]
#' when creating proportion-based tables with compliance columns.
#' @export
cmp_split_fun <- make_split_fun(post = list(cmp_post_fun))

#' @title Summary Analysis Function for Compliance Columns
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format, for use in a split content row. The denominator here is
#'   from the expected visits column.
#' @inheritParams proposal_argument_convention
#' @param variables (`list`)\cr with variable names of logical columns for
#'   `expected`, `received` and `missing` visits.
#' @param formats (`list`)\cr with the `count_percent` format to use for the received
#'   and missing visits columns.
#' @return The [rtables::in_rows()] result with the counts and proportion statistics.
#' @seealso [cmp_post_fun()] for the corresponding split function.
#' @export
cmp_cfun <- function(df, labelstr, .spl_context, variables, formats) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  this_afun_col <- this_col_split[2]

  exp <- df[[variables$expected]]
  checkmate::assert_logical(exp)
  n_exp <- sum(exp)
  rec <- df[[variables$received]]
  mis <- df[[variables$missing]]

  if (this_afun_col == "expected") {
    in_rows(n_exp, .labels = labelstr, .formats = "xx.")
  } else if (this_afun_col == "received") {
    checkmate::assert_logical(rec)
    checkmate::assert_true(all(exp[rec]))

    # Check if count_percent format is available
    if (!is.null(formats) && !("count_percent" %in% names(formats))) {
      stop("'count_percent' format must be provided in the formats argument")
    }

    in_rows(sum(rec) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
  } else if (this_afun_col == "missing") {
    checkmate::assert_logical(mis)
    checkmate::assert_true(all(exp[mis]))
    checkmate::assert_true(!any(rec[mis]))

    # Check if count_percent format is available
    if (!is.null(formats) && !("count_percent" %in% names(formats))) {
      stop("'count_percent' format must be provided in the formats argument")
    }

    in_rows(sum(mis) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
  }
}

make_dps_regex <- function(keyword, type = c("[", "{")) {
  mustart <- match.arg(type)
  muend <- ifelse(mustart == "[", "]", "}")

  paste0("[~][", mustart, "]", keyword, " ([^", muend, "]+)[", muend, "]")
}

handle_one_markup <- function(strs, keyword, rtfstart, rtfend) {
  start <- ifelse(nzchar(rtfstart), paste0("\\", rtfstart, " "), "")
  end <- ifelse(nzchar(rtfstart), paste0("\\", rtfend, " "), "")
  out <- gsub(make_dps_regex(keyword), paste0(start, "\\1", end), strs)
  out <- gsub(make_dps_regex(keyword, "{"), paste0(start, "\\1", end), out)
  out
}


dps_markup_df <- tibble::tribble(
  ~keyword,
  ~rtfstart,
  ~rtfend,
  "super",
  "\\super",
  "\\nosupersub",
  "sub",
  "\\sub",
  "\\nosupersub",
  "optional",
  "",
  ""
)


#' Default String Mapping for Special Characters
#'
#' A tibble that maps special characters to their UTF-8 equivalents for use in RTF output.
#' Currently it maps ">=" and "<=" to the Unicode characters.
#'
#' @return A tibble with columns 'pattern' and 'value', where 'pattern' contains
#'   the string to be replaced and 'value' contains the replacement.
#'
#' @export
#' @keywords internal
default_str_map <- tibble::tribble(
  ~pattern,
  ~value,
  ">=",
  intToUtf8(strtoi(2265, base = 16)),
  "<=",
  intToUtf8(strtoi(2264, base = 16))
)

convert_dps_markup <- function(strs, markup_df = dps_markup_df) {
  for (i in seq_len(nrow(markup_df))) {
    strs <- handle_one_markup(strs, markup_df$keyword[i], markup_df$rtfstart[i], markup_df$rtfend[i])
  }
  strs
}

strmodify <- function(strs, replacement_str = default_str_map) {
  map_tbl <- replacement_str
  if (!is.null(map_tbl) && nrow(map_tbl) > 0) {
    for (i in seq_len(nrow(map_tbl))) {
      pattern <- map_tbl$pattern[[i]]
      value <- map_tbl$value[i]
      strs <- gsub(pattern, value, strs, fixed = TRUE)
    }
  }
  return(strs)
}

prep_strs_for_rtf <- function(strs, string_map = default_str_map, markup_df = dps_markup_df) {
  strs <- convert_dps_markup(strs, markup_df)
  strs <- strmodify(strs, string_map)
  return(strs)
}


#' Relabel Variables in a Dataset
#'
#' This function relabels variables in a dataset based on a provided list of labels.
#' It can either replace existing labels or only add labels to variables without them.
#'
#' @param x (`data.frame`)\cr dataset containing variables to be relabeled.
#' @param lbl_list (`list`)\cr named list of labels to apply to variables.
#' @param replace_existing (`logical`)\cr if TRUE, existing labels will be replaced;
#'   if FALSE, only variables without labels will be updated.
#'
#' @return The dataset with updated variable labels.
#'
#' @export
#' @keywords internal
var_relabel_list <- function(x, lbl_list, replace_existing = TRUE) {
  if (replace_existing) {
    vars_to_relabel <- intersect(names(x), names(lbl_list))
  } else {
    get_variables_with_empty_labels <- function(x) {
      labels <- var_labels(x)
      mask <- lapply(labels, is.na) |> unlist()
      return(names(labels[mask]))
    }

    vars_without_labels <- get_variables_with_empty_labels(x)
    vars_to_relabel <- intersect(vars_without_labels, names(lbl_list))
  }
  do.call(var_relabel, c(list(x = x), lbl_list[vars_to_relabel]))
}

#' Adding Labels To Variables For Model
#'
#' @param vars (`list`)\cr variables to use.
#' @param data (`data.frame`)\cr data to use.
#' @param x (`character`)\cr an element in vars.
#'
#' @name labels
#' @keywords internal
NULL

#' @describeIn labels checks if element in `vars` is not `NULL` and not empty.
h_is_specified <- function(x, vars) {
  !is.null(vars[[x]]) && (length(vars[[x]]) > 0)
}

#' @describeIn labels checks if element in vars is not NULL and exists in dataset.
h_is_specified_and_in_data <- function(x, vars, data) {
  h_is_specified(x, vars) && all(vars[[x]] %in% names(data))
}

#' @describeIn labels gets label for each element in vars.
h_check_and_get_label <- function(x, vars, data) {
  checkmate::assert_true(h_is_specified_and_in_data(x, vars, data))
  res <- NULL
  for (v in vars[[x]]) {
    label <- attr(data[[v]], "label")
    string <- ifelse(!is.null(label), label, v)
    res <- c(res, stats::setNames(string, v))
  }
  res
}

#' Extraction of Covariate Parts from Character Vector
#'
#' @description
#' Extraction of Covariate Parts from Character Vector.
#'
#' @param covariates (`character`)\cr specification in the usual way, see examples.
#'
#' @return Character vector of the covariates involved in `covariates` specification.
#' @keywords internal
h_get_covariate_parts <- function(covariates) {
  checkmate::assert_character(covariates, null.ok = TRUE)
  if (is.null(covariates)) {
    NULL
  } else {
    unique(unlist(strsplit(covariates, split = "\\*|:")))
  }
}

#' @describeIn labels returns the list of variables with labels.
h_labels <- function(vars, data) {
  checkmate::assert_list(vars)
  checkmate::assert_data_frame(data)
  labels <- list()
  labels$response <- h_check_and_get_label("response", vars, data)
  labels$id <- h_check_and_get_label("id", vars, data)
  labels$visit <- h_check_and_get_label("visit", vars, data)
  if (h_is_specified("arm", vars)) {
    labels$arm <- h_check_and_get_label("arm", vars, data)
  }
  if (h_is_specified("covariates", vars)) {
    vars$parts <- h_get_covariate_parts(vars$covariates)
    labels$parts <- h_check_and_get_label("parts", vars, data)
  }
  if (h_is_specified("weights", vars)) {
    labels$weights <- h_check_and_get_label("weights", vars, data)
  }
  if (h_is_specified("subgroup", vars)) {
    labels$subgroup <- h_check_and_get_label("subgroup", vars, data)
  }
  return(labels)
}

#' Building Model Formula
#'
#' This builds the model formula which is used inside [fit_mmrm_j()] and provided
#' to [mmrm::mmrm()] internally. It can be instructive to look at the resulting
#' formula directly sometimes. In particular, if a `subgroup` variable is included
#' in `vars`, then the formula will include the interaction of `subgroup` with
#' `arm` and `visit`.
#'
#' @param vars (`list`)\cr variables to use in the model.
#' @param cor_struct (`string`)\cr specify the covariance structure to use.
#' @return Formula to use in [mmrm::mmrm()].
#' @export
#'
#' @examples
#' vars <- list(
#'   response = "AVAL",
#'   covariates = c("RACE", "SEX"),
#'   id = "USUBJID",
#'   arm = "ARMCD",
#'   visit = "AVISIT",
#'   subgroup = "REGION"
#' )
#' build_formula(vars, "auto-regressive")
#' build_formula(vars)
build_formula <- function(
  vars,
  cor_struct = c(
    "unstructured",
    "toeplitz",
    "heterogeneous toeplitz",
    "ante-dependence",
    "heterogeneous ante-dependence",
    "auto-regressive",
    "heterogeneous auto-regressive",
    "compound symmetry",
    "heterogeneous compound symmetry"
  )
) {
  checkmate::assert_list(vars)
  cor_struct <- match.arg(cor_struct)
  covariates_part <- paste(vars$covariates, collapse = " + ")
  arm_visit_part <- if (is.null(vars$arm)) {
    vars$visit
  } else {
    paste0(vars$arm, "*", vars$visit)
  }
  if (!is.null(vars$subgroup)) {
    arm_visit_part <- paste0(arm_visit_part, "*", vars$subgroup)
  }
  random_effects_fun <- switch(cor_struct,
    unstructured = "us",
    toeplitz = "toep",
    `heterogeneous toeplitz` = "toeph",
    `ante-dependence` = "ad",
    `heterogeneous ante-dependence` = "adh",
    `auto-regressive` = "ar1",
    `heterogeneous auto-regressive` = "ar1h",
    `compound symmetry` = "cs",
    `heterogeneous compound symmetry` = "csh"
  )
  random_effects_part <- paste0(random_effects_fun, "(", vars$visit, " | ", vars$id, ")")
  rhs_formula <- paste(arm_visit_part, "+", random_effects_part)
  if (covariates_part != "") {
    rhs_formula <- paste(covariates_part, "+", rhs_formula)
  }
  stats::as.formula(paste(vars$response, "~", rhs_formula))
}

#' Extract Least Square Means from `MMRM`
#'
#' Extracts the least square means from an `MMRM` fit.
#'
#' @inheritParams fit_mmrm_j
#' @param fit (`mmrm`)\cr result of [mmrm::mmrm()].
#' @param averages (`list`)\cr named list of visit levels which should be averaged
#'   and reported along side the single visits.
#' @param weights (`string`)\cr type of weights to be used for the least square means,
#'   see [emmeans::emmeans()] for details.
#' @param mult_adj (`string`)\cr multiplicity adjustment within visits for the contrasts.
#' @return A list with data frames `estimates` and `contrasts`.
#'   The attributes `averages`, `weights` and `mult_adj` save the settings used.
#'
#' @note This is modified from `tern.mmrm` and has the additional `mult_adj` argument.
#' @export
get_mmrm_lsmeans <- function(
  fit, vars, conf_level, weights, averages = list(),
  mult_adj = c("none", "dunnett", "step-down-dunnett")
) {
  checkmate::assert_class(fit, "mmrm")
  checkmate::assert_list(averages, types = "character")
  mult_adj <- match.arg(mult_adj)
  emmeans_res <- h_get_emmeans_res(fit, vars, weights)

  # Get least square means estimates for single visits, and possibly averaged visits.
  estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
  if (length(averages)) {
    average_specs <- h_get_average_visit_specs(emmeans_res, vars, averages, fit)
    average_estimates <- h_get_spec_visit_estimates(emmeans_res, average_specs, conf_level)
    estimates <- rbind(estimates, average_estimates)
  }
  has_arm_var <- !is.null(vars$arm)
  if (!has_arm_var) {
    return(list(estimates = estimates))
  }
  # Continue with contrasts when we have an arm variable.
  if (mult_adj != "none" && !identical(averages, list())) {
    stop("Multiplicity adjustment within visits cannot be combined with averages across visits")
  }

  contrast_specs <- h_single_visit_contrast_specs(emmeans_res, vars)
  contrast_estimates <- h_get_spec_visit_estimates(emmeans_res, contrast_specs, conf_level, tests = TRUE)

  if (length(averages)) {
    average_contrast_specs <- h_average_visit_contrast_specs(contrast_specs, averages, vars)
    average_contrasts <- h_get_spec_visit_estimates(emmeans_res, average_contrast_specs, conf_level, tests = TRUE)
    contrast_estimates <- rbind(contrast_estimates, average_contrasts)
  }

  if (mult_adj != "none") {
    # We just calculate the adjusted p-values and confidence intervals here and replace them
    # in the contrast_estimates data frame. The estimates and t-stats remain unchanged.
    mult_adj_df <- h_get_mult_adj_estimates(
      emmeans_res = emmeans_res,
      vars = vars,
      mult_adj = mult_adj,
      conf_level = conf_level,
      contrast_df = contrast_estimates$df
    )
    contrast_estimates$p_value <- mult_adj_df$p_value
    contrast_estimates$p_value_less <- mult_adj_df$p_value_less
    contrast_estimates$p_value_greater <- mult_adj_df$p_value_greater
    contrast_estimates$lower_cl <- mult_adj_df$lower_cl
    contrast_estimates$upper_cl <- mult_adj_df$upper_cl
  }

  relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
  contrast_estimates <- merge(
    contrast_estimates,
    relative_reduc_df,
    by = c(vars$subgroup, vars$arm, vars$visit),
    sort = FALSE
  )
  if (!is.null(vars$subgroup)) {
    contrast_estimates[[vars$subgroup]] <- factor(
      contrast_estimates[[vars$subgroup]],
      levels = intersect(levels(estimates[[vars$subgroup]]), contrast_estimates[[vars$subgroup]])
    )
  }
  contrast_estimates[[vars$arm]] <- factor(
    contrast_estimates[[vars$arm]],
    levels = intersect(levels(estimates[[vars$arm]]), contrast_estimates[[vars$arm]])
  )
  contrast_estimates[[vars$visit]] <- factor(
    contrast_estimates[[vars$visit]],
    levels = intersect(levels(estimates[[vars$visit]]), contrast_estimates[[vars$visit]])
  )
  structure(
    list(estimates = estimates, contrasts = contrast_estimates),
    averages = averages,
    weights = weights,
    mult_adj = mult_adj
  )
}

#' `MMRM` Analysis
#'
#' Does the `MMRM` analysis. Multiple other functions can be called on the result to produce
#' tables and graphs.
#'
#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `MMRM`.
#'   The following elements need to be included as character vectors and match corresponding columns
#'   in `data`:
#'
#'   - `response`: the response variable.
#'   - `covariates`: the additional covariate terms (might also include interactions).
#'   - `id`: the subject ID variable.
#'   - `arm`: the treatment group variable (factor).
#'   - `visit`: the visit variable (factor).
#'   - `weights`: optional weights variable (if `NULL` or omitted then no weights will be used).
#'
#'   Note that the main effects and interaction of `arm` and `visit` are by default
#'   included in the model.
#' @param data (`data.frame`)\cr with all the variables specified in
#'   `vars`. Records with missing values in any independent variables
#'   will be excluded.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param cor_struct (`string`)\cr specifying the covariance structure, defaults to
#'   `'unstructured'`. See the details.
#' @param averages_emmeans (`list`)\cr optional named list of visit levels which should be averaged
#'   and reported along side the single visits.
#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
#' @param mult_adj_emmeans (`string`)\cr whether to multiplicity adjust LS means contrast p-values and
#'   confidence intervals within visits when there are more than 2 treatment arms. Note that this cannot
#'   be combined with `averages_emmeans`. Either "none", "dunnett" or "step-down-dunnett".
#' @param ... additional arguments for [mmrm::mmrm()], in particular `reml` and options listed in
#'   [mmrm::mmrm_control()].
#'
#' @details Multiple different degree of freedom adjustments are available via the `method` argument
#'   for [mmrm::mmrm()]. In addition, covariance matrix adjustments are available via `vcov`.
#'   Please see [mmrm::mmrm_control()] for details and additional useful options.
#'
#'   For the covariance structure (`cor_struct`), the user can choose among the following options.
#'
#'   - `unstructured`: Unstructured covariance matrix. This is the most flexible choice and default.
#'        If there are `T` visits, then `T * (T+1) / 2` variance parameters are used.
#'   - `toeplitz`: Homogeneous Toeplitz covariance matrix, which uses `T` variance parameters.
#'   - `heterogeneous toeplitz`: Heterogeneous Toeplitz covariance matrix,
#'        which uses `2 * T - 1` variance parameters.
#'   - `ante-dependence`: Homogeneous Ante-Dependence covariance matrix, which uses `T` variance parameters.
#'   - `heterogeneous ante-dependence`: Heterogeneous Ante-Dependence covariance matrix,
#'        which uses `2 * T - 1` variance parameters.
#'   - `auto-regressive`: Homogeneous Auto-Regressive (order 1) covariance matrix,
#'        which uses 2 variance parameters.
#'   - `heterogeneous auto-regressive`: Heterogeneous Auto-Regressive (order 1) covariance matrix,
#'        which uses `T + 1` variance parameters.
#'   - `compound symmetry`: Homogeneous Compound Symmetry covariance matrix, which uses 2
#'        variance parameters.
#'   - `heterogeneous compound symmetry`: Heterogeneous Compound Symmetry covariance matrix, which uses
#'        `T + 1` variance parameters.
#'
#' @return A `tern_model` object which is a list with model results:
#'
#'   - `fit`: The `mmrm` object which was fitted to the data. Note that via `mmrm::component(fit, 'optimizer')`
#'       the finally used optimization algorithm can be obtained, which can be useful for refitting the model
#'       later on.
#'   - `cov_estimate`: The matrix with the covariance matrix estimate.
#'   - `diagnostics`: A list with model diagnostic statistics (REML criterion, AIC, corrected AIC, BIC).
#'   - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
#'        The attributes `averages`, `weights` and `mult_adj` save the settings used
#'        (`averages_emmeans`, `weights_emmeans` and `mult_adj_emmeans`).
#'   - `vars`: The variable list.
#'   - `labels`: Corresponding list with variable labels extracted from `data`.
#'   - `cor_struct`: input.
#'   - `ref_level`: The reference level for the arm variable, which is always the first level.
#'   - `treatment_levels`: The treatment levels for the arm variable.
#'   - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
#'   - `additional`: List with any additional inputs passed via `...`
#'
#' @export
#'
#' @note This function has the `_j` suffix to distinguish it from [mmrm::fit_mmrm()].
#'   It is modified from the `tern.mmrm` package.
#'   The new features are:
#'
#'   - the `mult_adj_emmeans` argument and its functionality
#'   - the `subgroup` variable in `vars` and its functionality
#'
#'   These could later be contributed upstream in `tern.mmrm`.
#'
#' @examples
#' mmrm_results <- fit_mmrm_j(
#'   vars = list(
#'     response = "FEV1",
#'     covariates = c("RACE", "SEX"),
#'     id = "USUBJID",
#'     arm = "ARMCD",
#'     visit = "AVISIT"
#'   ),
#'   data = mmrm::fev_data,
#'   cor_struct = "unstructured",
#'   weights_emmeans = "equal",
#'   averages_emmeans = list(
#'     "VIS1+2" = c("VIS1", "VIS2")
#'   )
#' )
fit_mmrm_j <- function(
  vars = list(
    response = "AVAL",
    covariates = c(),
    id = "USUBJID",
    arm = "ARM",
    visit = "AVISIT",
    subgroup = NULL
  ),
  data,
  conf_level = 0.95,
  cor_struct = "unstructured",
  weights_emmeans = "counterfactual",
  averages_emmeans = list(),
  mult_adj_emmeans = c("none", "dunnett", "step-down-dunnett"),
  ...
) {
  labels <- h_labels(vars, data)
  formula <- build_formula(vars, cor_struct)
  weights <- if (!is.null(vars$weights)) data[[vars$weights]] else NULL

  fit <- mmrm::mmrm(formula = formula, data = data, weights = weights, reml = TRUE, ...)
  lsmeans <- get_mmrm_lsmeans(
    fit = fit,
    vars = vars,
    conf_level = conf_level,
    averages = averages_emmeans,
    weights = weights_emmeans,
    mult_adj = mult_adj_emmeans
  )
  cov_estimate <- mmrm::VarCorr(fit)
  visit_levels <- rownames(cov_estimate)
  contrasts_from_visits <- match(visit_levels, lsmeans$contrasts[[vars$visit]])
  df <- stats::setNames(lsmeans$contrasts$df[contrasts_from_visits], visit_levels)
  results <- list(
    fit = fit,
    cov_estimate = cov_estimate,
    lsmeans = lsmeans,
    vars = vars,
    labels = labels,
    mse = diag(cov_estimate),
    df = df,
    cor_struct = cor_struct,
    ref_level = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[1],
    treatment_levels = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[-1],
    conf_level = conf_level,
    additional = list(...)
  )
  class(results) <- "tern_model"
  return(results)
}

#' Pool analysis results obtained from the imputed datasets
#'
#' @details This has been forked from the `rbmi` package, mainly to support in
#' addition the pooling of variance estimates. See pool() for more details.
#'
#' @param results an analysis object created by analyse().
#'
#' @param conf.level confidence level of the returned confidence interval.
#' Must be a single number between 0 and 1. Default is 0.95.
#'
#' @param alternative a character string specifying the alternative hypothesis,
#' must be one of `"two.sided"` (default), `"greater"` or `"less"`.
#'
#' @param type a character string of either `"percentile"` (default) or
#' `"normal"`. Determines what method should be used to calculate the bootstrap
#' confidence intervals. See details.
#' Only used if `method_condmean(type = "bootstrap")` was specified
#' in the original call to draws().
#'
#' @returns A list of class `pool`.
#'
#' @export
rbmi_pool <- function(
  results,
  conf.level = 0.95,
  alternative = c("two.sided", "less", "greater"),
  type = c("percentile", "normal")
) {
  rbmi::validate(results)

  alternative <- match.arg(alternative)
  type <- match.arg(type)

  pool_type <- class(results$results)[[1]]
  checkmate::assert_true(identical(pool_type, "rubin"))

  results_transpose <- (utils::getFromNamespace("transpose_results", "rbmi"))(
    results$results,
    (utils::getFromNamespace("get_pool_components", "rbmi"))(pool_type)
  )

  pars <- lapply(
    results_transpose,
    function(x, ...) mod_pool_internal_rubin(x, ...),
    conf.level = conf.level,
    alternative = alternative,
    type = type,
    D = results$method$D
  )

  method <- pool_type

  ret <- list(
    pars = pars,
    conf.level = conf.level,
    alternative = alternative,
    N = length(results$results),
    method = method
  )
  class(ret) <- "pool"
  return(ret)
}

mod_pool_internal_rubin <- function(results, conf.level, alternative, type, D) {
  ests <- results$est
  ses <- results$se
  dfs <- results$df
  alpha <- 1 - conf.level

  # Note: Need to take median here, because in the MMRM case the d.f. will be slightly different for each imputed
  # data set analysis.
  v_com <- stats::median(dfs)

  res_rubin <- if (utils::packageVersion("rbmi") > "1.6.1") {
    (utils::getFromNamespace("rubin_rules", "rbmi"))(
      ests = ests,
      ses = ses,
      v_com = v_com,
      method = "barnard-rubin"
    )
  } else {
    (utils::getFromNamespace("rubin_rules", "rbmi"))(
      ests = ests,
      ses = ses,
      v_com = v_com
    )
  }

  ret <- (utils::getFromNamespace("parametric_ci", "rbmi"))(
    point = res_rubin$est_point,
    se = sqrt(res_rubin$var_t),
    alpha = alpha,
    alternative = alternative,
    qfun = stats::qt,
    pfun = stats::pt,
    df = res_rubin$df
  )
  # Here also return the pooled d.f.:
  ret$df <- res_rubin$df

  return(ret)
}

#' Tabulation for Exposure Tables
#'
#'
#' @details
#' Creates statistics needed for standard exposure table.
#' This includes differences and 95% CI and total treatment years.
#' This is designed to be used as an analysis (afun in `analyze`) function.
#'
#' @name a_summarize_ex_j
NULL

#' @inheritParams proposal_argument_convention
#' @describeIn a_summarize_ex_j Statistics function needed for the exposure tables.
#'
#' @param daysconv (`numeric`)\cr conversion required to get the values into days
#' (i.e 1 if original PARAMCD unit is days, 30.4375 if original PARAMCD unit is in months)
#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
#' If TRUE, ANCOVA methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
#' @param comp_btw_group (`logical`)\cr If TRUE, comparison between groups will be performed.
#' \cr When ancova = FALSE, the estimate of between group difference (on CHG) will be based upon two-sample t-test.
#' \cr When ancova = TRUE, the same ANCOVA model will be used for the estimate of between group difference (on CHG).
#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param conf_level (`proportion`)\cr Confidence level of the interval
#' @param variables (named list of strings)\cr
#' list of additional analysis variables, with expected elements:
#'    * arm (string)\cr
#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
#' Specifically, the first level of arm variable is taken as the reference group.
#'    * covariates (character)\cr
#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
s_summarize_ex_j <- function(
  df,
  .var,
  .df_row,
  .spl_context,
  comp_btw_group = TRUE,
  ref_path = NULL,
  ancova = FALSE,
  interaction_y,
  interaction_item,
  conf_level,
  daysconv,
  variables
) {
  control <- control_analyze_vars()
  control$conf_level <- conf_level
  x_stats <- s_summary(df[[.var]], na.rm = TRUE, .var, control = control)
  ## add extra for subject years
  subj_years <- x_stats[["sum"]] * daysconv / 365.25
  x_stats[["total_subject_years"]] <- c(x_stats[["sum"]], subj_years)
  names(x_stats[["total_subject_years"]]) <- c("total", "subject_years")

  cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
  indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)

  if (indiffcol) {
    # blank out all stats
    x_stats <- sapply(
      names(x_stats),
      FUN = function(x) {
        x_stats[[x]] <- NULL
      },
      simplify = FALSE,
      USE.NAMES = TRUE
    )
    # diff between group will be updated in mean_sd stat
    if (comp_btw_group) {
      trt_var <- ref_path[length(ref_path) - 1L]
      ctrl_grp <- ref_path[length(ref_path)]
      cur_trt_grp <- h_get_cur_trt_grp(trt_var, .spl_context)

      .in_ref_col <- FALSE
      if (cur_trt_grp == ctrl_grp) .in_ref_col <- TRUE

      .ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]

      if (ancova) {
        # ancova method for diff between group
        x_stats2 <- s_summarize_ancova_j(
          df = df,
          .var = .var,
          .ref_group = .ref_group,
          .in_ref_col = .in_ref_col,
          .df_row = .df_row,
          conf_level = conf_level,
          interaction_y = interaction_y,
          interaction_item = interaction_item,
          variables = variables
        )
        diffstat <- x_stats2[["lsmean_diff_with_ci"]]
      } else {
        # descriptive method for diff between group
        x_stats2 <- s_summarize_desc_j(
          df = df,
          .var = .var,
          .ref_group = .ref_group,
          .in_ref_col = .in_ref_col,
          control = control
        )
        diffstat <- x_stats2[["mean_diff_with_ci"]]
      }
      # actual update with the diffstat
      x_stats[["mean_sd"]] <- diffstat
    }
  }

  return(x_stats)
}

#' @title Analysis Function For Exposure Tables
#' @description
#' A function to create the appropriate statistics needed for exposure table
#' @inheritParams proposal_argument_convention
#'
#' @describeIn a_summarize_ex_j Formatted analysis function which is used as `afun`.
#'
#' @return
#' * `a_summarize_ex_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @aliases a_summarize_ex_j
#' @examples
#' library(dplyr)
#' ADEX <- ex_adsl |> select(USUBJID, ARM, TRTSDTM, EOSSTT, EOSDY)
#'
#' trtvar <- "ARM"
#' ctrl_grp <- "B: Placebo"
#' cutoffd <- as.Date("2023-09-24")
#'
#' ADEX <- ADEX |>
#'   create_colspan_var(
#'     non_active_grp          = ctrl_grp,
#'     non_active_grp_span_lbl = " ",
#'     active_grp_span_lbl     = "Active Study Agent",
#'     colspan_var             = "colspan_trt",
#'     trt_var                 = trtvar
#'   ) |>
#'   mutate(
#'     diff_header = "Difference in Means (95% CI)",
#'     diff_label = paste(!!rlang::sym(trtvar), "vs", ctrl_grp),
#'     TRTDURY = case_when(
#'       !is.na(EOSDY) ~ EOSDY,
#'       TRUE ~ as.integer(cutoffd - as.Date(TRTSDTM) + 1)
#'     )
#'   )
#'
#' colspan_trt_map <- create_colspan_map(ADEX,
#'   non_active_grp = ctrl_grp,
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = trtvar
#' )
#'
#' ref_path <- c("colspan_trt", "", trtvar, ctrl_grp)
#'
#' lyt <- basic_table() |>
#'   split_cols_by(
#'     "colspan_trt",
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by(trtvar) |>
#'   split_cols_by("diff_header", nested = FALSE) |>
#'   split_cols_by(
#'     trtvar,
#'     split_fun = remove_split_levels(ctrl_grp),
#'     labels_var = "diff_label"
#'   ) |>
#'   analyze("EOSDY",
#'     afun = a_summarize_ex_j, var_labels = "Duration of treatment (Days)",
#'     show_labels = "visible",
#'     indent_mod = 0L,
#'     extra_args = list(
#'       daysconv = 1,
#'       ref_path = ref_path,
#'       variables = list(arm = trtvar, covariates = NULL),
#'       ancova = TRUE,
#'       comp_btw_group = TRUE
#'     )
#'   )
#'
#' result <- build_table(lyt, ADEX, alt_counts_df = ADEX)
#' result
#' @export
a_summarize_ex_j <- function(
  df,
  .var,
  .df_row,
  .spl_context,
  comp_btw_group = TRUE,
  ref_path = NULL,
  ancova = FALSE,
  interaction_y = FALSE,
  interaction_item = NULL,
  conf_level = 0.95,
  variables,
  .stats = c("mean_sd", "median", "range", "quantiles", "total_subject_years"),
  .formats = c(diff_mean_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)")),
  .labels = c(quantiles = "Interquartile range"),
  .indent_mods = NULL,
  na_str = rep("NA", 3),
  daysconv = 1
) {
  checkmate::check_character(ref_path, min.len = 2L)
  checkmate::assert_true(length(ref_path) %% 2L == 0L)

  if (!is.numeric(df[[.var]])) {
    stop("a_summarize_ex_j issue: input variable must be numeric.")
  }

  if (comp_btw_group && is.null(ref_path)) {
    stop("a_summarize_ex_j issue: argument ref_path cannot be NULL.")
  }

  if (comp_btw_group && ancova && is.null(variables)) {
    stop("a_summarize_ex_j issue: argument variables must be defined when ancova is requested.")
  }

  x_stats <- s_summarize_ex_j(
    df = df,
    .var = .var,
    .df_row = .df_row,
    .spl_context = .spl_context,
    comp_btw_group = comp_btw_group,
    ref_path = ref_path,
    ancova = ancova,
    interaction_y = interaction_y,
    interaction_item = interaction_item,
    conf_level = conf_level,
    daysconv = daysconv,
    variables = variables
  )

  # Fill in formatting defaults
  .stats_in <- .stats
  .stats <- tern_get_stats("analyze_vars_numeric", stats_in = .stats, custom_stats_in = NULL)
  if ("total_subject_years" %in% .stats_in) {
    # place the extra statistic at the appropriate place within .stats vector
    i <- match("total_subject_years", .stats_in)
    x <- .stats_in[i:length(.stats_in)]
    if (length(x) == 1) {
      .stats <- c(.stats, "total_subject_years")
    } else {
      i2 <- min(match(x, .stats), na.rm = TRUE)
      if (i2 == 1) {
        .stats <- c("total_subject_years", .stats)
      } else {
        .stats <- c(.stats[1:(i2 - 1)], "total_subject_years", .stats[i2:length(.stats)])
      }
    }
  }

  .stats_ext <- c(.stats, "diff_mean_est_ci")

  .formats <- junco_get_formats_from_stats(.stats_ext, .formats)
  .labels <- junco_get_labels_from_stats(.stats, .labels, label_attr_from_stats = get_label_attr_from_stats(x_stats))
  .indent_mods <- junco_get_indents_from_stats(.stats, .indent_mods)

  .names <- names(.labels)
  .labels <- .unlist_keep_nulls(.labels)
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
  indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)

  if (indiffcol && comp_btw_group) {
    .formats[["mean_sd"]] <- .formats[["diff_mean_est_ci"]]
  }
  .formats[["diff_mean_est_ci"]] <- NULL

  if (!is.null(na_str)) {
    .format_na_strs <- lapply(names(.formats), FUN = function(x) {
      na_str
    })
  } else {
    .format_na_strs <- NULL
  }

  x_stats <- x_stats[.stats]
  ret <- in_rows(
    .list = x_stats,
    .formats = .formats,
    .names = .names,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )
  return(ret)
}

s_summarize_desc_j <- function(df, .var, .ref_group, .in_ref_col, control = control_analyze_vars()) {
  x <- df[[.var]]
  y1 <- s_summary(x)
  y2 <- NULL

  # diff in means versus control group, based upon 2 sample t.test
  y2$mean_diff_with_ci <- numeric()
  if (!is.null(.ref_group) && !.in_ref_col) {
    x1 <- df[[.var]]
    x2 <- .ref_group[[.var]]

    x1 <- x1[!is.na(x1)]
    x2 <- x2[!is.na(x2)]

    ttest_stat <- safe_t_test(x1, x2, conf.level = control$conf_level)

    stat <- ttest_stat[c("estimate", "conf.int")]
    stat$diff <- stat$estimate[1] - stat$estimate[2]
    stat <- c(stat$diff, stat$conf.int)

    y2$mean_diff_with_ci <- with_label(
      c(mean_diff_with_ci = stat),
      paste("Difference in Mean + ", f_conf_level(control$conf_level))
    )
  }
  y <- c(y1, y2)

  return(y)
}

s_aval_chg_col1 <- function(df, .var, denom, .N_col, id, indatavar) {
  ## First column AVAL - show n/N (%)
  mystat <- "n"

  if (!is.null(indatavar)) {
    df <- subset(df, !is.na(df[[indatavar]]))
  }

  x <- df[[.var]]

  x_stats <- s_summary(x)
  x_stats <- x_stats[mystat]

  ### Ndenom derivation in case denom = N
  Ndenom <- .N_col
  if (denom == "N") {
    ### as our input dataset has ensured we have unique subjects we can just use the length of x here still safer
    ### to use id variable
    nsub <- length(unique(df[[id]]))
    Ndenom <- nsub
  }

  count_denom_frac <- c(x_stats$n, Ndenom, x_stats$n / Ndenom)
  names(count_denom_frac) <- c("n", "N", "fraction")

  count_frac <- count_denom_frac[c("n", "fraction")]
  count <- count_denom_frac[c("n")]

  y <- list()
  y$count_denom_frac <- count_denom_frac
  y$count_frac <- count_frac
  y$count <- count

  return(y)
}

s_aval_chg_col23_diff <- function(
  df,
  .var,
  .df_row,
  .ref_group,
  .in_ref_col,
  ancova,
  interaction_y,
  interaction_item,
  conf_level,
  variables,
  trt_var,
  ctrl_grp,
  cur_param,
  cur_lvl,
  weights_emmeans,
  method_combo,
  weights_combo
) {
  .df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
  df <- subset(df, !is.na(df[[.var]]))
  .ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))

  if (nrow(.df_row) == 0) {
    #### this is only when input row no non-missing records in any of the columns expected to occur for baseline
    #### timepoint for analysis variable change only here we want a blank cell, not a cell with all NA's NULL is
    #### generating a blank cell
    x_stats <- NULL
    mystat1 <- c("mean_ci_3d", "mean_diff_with_ci")
  } else if (!ancova) {
    mystat1 <- c("mean_ci_3d", "mean_diff_with_ci")

    control <- control_analyze_vars()
    control$conf_level <- conf_level
    x_stats <- s_summarize_desc_j(
      df = df,
      .var = .var,
      .ref_group = .ref_group,
      .in_ref_col = .in_ref_col,
      control = control
    )
  } else {
    mystat1 <- c("lsmean_ci", "lsmean_diff_with_ci")

    ### sparse data problems with underlying ancova function 1/ if nrow(.df_row) = 0 NULL (blank columns)

    ### 2/ if nrow(df) = 0 no ancova - lsmean and lsmean diff should be na

    ### 3/ if nrow(df) > 0, & nrow(.ref_group) = 0 ancova for ls mean only, NULL .ref_group -- lsmean diff should
    ### be na

    ### 4/ if nrow(df) > 0, & nrow(.ref_group) > 0 and at least one group with 0 data update levels in
    ### .df_row/df/.ref_group to avoid problems for contrast

    #### by making updates to .df_row/df/.ref_group, situation 3 and 4 could be used together with general case

    .df_row_trtlevels <- unique(.df_row[[trt_var]])

    if (NROW(.df_row_trtlevels) == 0) {
      ### No data at all
      x_stats <- NULL
    } else if (NROW(df) == 0 || NROW(.df_row_trtlevels) == 1) {
      ### current column no data/less than 2 treatment levels

      x_stats <- list()
      x_stats[[mystat1[1]]] <- rep(NA, 3)
      x_stats[[mystat1[2]]] <- rep(NA, 3)
    } else {
      ### ancova situation, and some updates to prevent problems with sparse data
      if ((!ctrl_grp %in% .df_row_trtlevels)) {
        # LS means for current group can be estimated from model, but not difference in LS means set .ref_group
        # to NULL to proceed with s_summarize_ancova_j function update to underlying s_ancova_j to cover NULL
        # ref_group in call
        .ref_group <- NULL
      }
      if (NROW(.df_row_trtlevels) < length(levels(.df_row[[trt_var]]))) {
        # missing levels need to be removed from the factor, in order to have the correct estimates, and avoid
        # errors with underlying tern:::s_ancova function
        .df_row[[trt_var]] <- droplevels(.df_row[[trt_var]])
        df[[trt_var]] <- factor(as.character(df[[trt_var]]), levels = levels(.df_row[[trt_var]]))
        .ref_group[[trt_var]] <- factor(as.character(.ref_group[[trt_var]]), levels = levels(.df_row[[trt_var]]))
      }

      x_stats <- s_summarize_ancova_j(
        df = df,
        .var = .var,
        .ref_group = .ref_group,
        .in_ref_col = .in_ref_col,
        .df_row = .df_row,
        conf_level = conf_level,
        interaction_y = interaction_y,
        interaction_item = interaction_item,
        variables = variables,
        weights_emmeans = weights_emmeans,
        method_combo = method_combo,
        weights_combo = weights_combo
      )
    }
  }

  y <- list(mean_ci_3d = x_stats[[mystat1[1]]], mean_diff_with_ci = x_stats[[mystat1[2]]])
  return(y)
}


#' @name a_summarize_aval_chg_diff_j
#'
#' @title Analysis function 3-column presentation
#'
#' @description Analysis functions to produce a 1-row summary presented in
#' a 3-column layout in the columns (column 1 = N, column 2 = Value, column 3 = Change).\cr
#' In the difference columns, only 1 column will be presented : difference + CI\cr
#' When ancova = `TRUE`, the presented statistics will be based on ANCOVA method (`s_summarize_ancova_j`).\cr
#' mean and ci (both for Value (column 2) and CHG (column 3)) using statistic `lsmean_ci`\cr
#' mean and ci for the difference column are based on same ANCOVA model using statistic `lsmean_diff_with_ci`\cr
#' When ancova = `FALSE`, descriptive statistics will be used instead.\cr
#' In the difference column, the 2-sample t-test will be used.
#'
#' @details See Description
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams s_ancova_j
#' @param denom (`string`)\cr choice of denominator for proportions. Options are:
#'   * `N`: number of records in this column/row split.
#' \cr There is no check in place that the current split only has one record per subject.
#' Users should be careful with this.
#'   * `.N_col`: number of records in this column intersection (based on alt_counts_df dataset)
#'   \cr (when alt_counts_df is a single record per subjects, this will match number of subjects)
#'
#' @param d (default = 1) \cr choice of Decimal precision.
#' Note that one extra precision will be added, as means are presented.
#'  \cr Options are:
#'   * numerical(1)
#'   * variable name containing information on the precision, this variable
#'   should be available on input dataset. The content of this variable should
#'   then be an integer.
#'
#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
#' If TRUE, ANCOVA methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
#' @param comp_btw_group (`logical`)\cr If TRUE, comparison between groups will be performed.
#' \cr When ancova = FALSE, the estimate of between group difference (on CHG)
#' will be based upon a two-sample t-test.
#' \cr When ancova = TRUE, the same ANCOVA model will be used for the estimate of between group difference (on CHG).
#'
#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
#' @param conf_level (`proportion`)\cr Confidence level of the interval
#' @param variables (named list of strings)\cr
#' list of additional analysis variables, with expected elements:
#'    * arm (string)\cr
#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
#' Specifically, the first level of arm variable is taken as the reference group.
#'    * covariates (character)\cr
#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
#'
#'
#' @param format_na_str (`string`)\cr
#'
#' @param indatavar (`string`)\cr If not null, variable name to extra subset
#' incoming df to non-missing values of this variable.
#' @param multivars (`string(3)`)\cr Variables names to use in 3-col layout.
#'
#' @param .stats  (named `list`)\cr column statistics to select for the table.
#' The following column names are to be used: `col1`, `col23`, `coldiff`.\cr
#' For `col1`, the following stats can be specified.\cr
#' For `col23`, only `mean_ci_3d` is available. When ancova = `TRUE` these are LS Means, otherwise, arithmetic means.\cr
#' For `coldiff`, only `mean_diff_with_ci` is available. When ancova = `TRUE` these
#' are LS difference in means, otherwise, difference in means based upon 2-sample t-test.\cr
#' @param .formats (named `list`)\cr formats for the column statistics. `xx.d` style formats can be used.
#' @param .formats_fun (named `list`)\cr formatting functions for the column
#' statistics, to be applied after the conversion of `xx.d` style to the
#' appropriate precision.
#'
#' @rdname a_summarize_aval_chg_diff_j
#' @return A function that can be used in an analyze function call
#' @export
#'
#'
#' @examples
#' library(dplyr)
#'
#' ADEG <- data.frame(
#'   STUDYID = c(
#'     "DUMMY", "DUMMY", "DUMMY", "DUMMY", "DUMMY",
#'     "DUMMY", "DUMMY", "DUMMY", "DUMMY", "DUMMY"
#'   ),
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   TRT01A = c(
#'     "ARMA", "ARMA", "ARMA", "ARMA", "ARMA", "Placebo",
#'     "Placebo", "Placebo", "ARMA", "ARMA"
#'   ),
#'   PARAM = c("BP", "BP", "BP", "BP", "BP", "BP", "BP", "BP", "BP", "BP"),
#'   AVISIT = c(
#'     "Visit 1", "Visit 1", "Visit 1", "Visit 1", "Visit 1",
#'     "Visit 1", "Visit 1", "Visit 1", "Visit 1", "Visit 1"
#'   ),
#'   AVAL = c(56, 78, 67, 87, 88, 93, 39, 87, 65, 55),
#'   CHG = c(2, 3, -1, 9, -2, 0, 6, -2, 5, 2)
#' )
#'
#' ADEG <- ADEG |>
#'   mutate(
#'     TRT01A = as.factor(TRT01A),
#'     STUDYID = as.factor(STUDYID)
#'   )
#'
#' ADEG$colspan_trt <- factor(ifelse(ADEG$TRT01A == "Placebo", " ", "Active Study Agent"),
#'   levels = c("Active Study Agent", " ")
#' )
#' ADEG$rrisk_header <- "Risk Difference (%) (95% CI)"
#' ADEG$rrisk_label <- paste(ADEG$TRT01A, paste("vs", "Placebo"))
#'
#' colspan_trt_map <- create_colspan_map(ADEG,
#'   non_active_grp = "Placebo",
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#' ref_path <- c("colspan_trt", " ", "TRT01A", "Placebo")
#'
#' lyt <- basic_table() |>
#'   split_cols_by(
#'     "colspan_trt",
#'     split_fun = trim_levels_to_map(map = colspan_trt_map)
#'   ) |>
#'   split_cols_by("TRT01A") |>
#'   split_rows_by(
#'     "PARAM",
#'     label_pos = "topleft",
#'     split_label = "Blood Pressure",
#'     section_div = " ",
#'     split_fun = drop_split_levels
#'   ) |>
#'   split_rows_by(
#'     "AVISIT",
#'     label_pos = "topleft",
#'     split_label = "Study Visit",
#'     split_fun = drop_split_levels,
#'     child_labels = "hidden"
#'   ) |>
#'   split_cols_by_multivar(
#'     c("AVAL", "AVAL", "CHG"),
#'     varlabels = c("n/N (%)", "Mean (CI)", "CFB (CI)")
#'   ) |>
#'   split_cols_by("rrisk_header", nested = FALSE) |>
#'   split_cols_by(
#'     "TRT01A",
#'     split_fun = remove_split_levels("Placebo"),
#'     labels_var = "rrisk_label"
#'   ) |>
#'   split_cols_by_multivar(c("CHG"), varlabels = c(" ")) |>
#'   analyze("STUDYID",
#'     afun = a_summarize_aval_chg_diff_j,
#'     extra_args = list(
#'       format_na_str = "-", d = 0,
#'       ref_path = ref_path, variables = list(arm = "TRT01A", covariates = NULL)
#'     )
#'   )
#'
#' result <- build_table(lyt, ADEG)
#'
#' result
#' @family Inclusion of ANCOVA Functions
a_summarize_aval_chg_diff_j <- function(
  df,
  .df_row,
  .spl_context,
  ancova = FALSE,
  comp_btw_group = TRUE,
  ref_path = NULL,
  .N_col,
  denom = c("N", ".N_col"),
  indatavar = NULL,
  d = 0,
  id = "USUBJID",
  interaction_y = FALSE,
  interaction_item = NULL,
  conf_level = 0.95,
  variables = list(arm = "TRT01A", covariates = NULL),
  format_na_str = "",
  .stats = list(col1 = "count_denom_frac", col23 = "mean_ci_3d", coldiff = "mean_diff_with_ci"),
  .formats = list(col1 = NULL, col23 = "xx.dx (xx.dx, xx.dx)", coldiff = "xx.dx (xx.dx, xx.dx)"),
  .formats_fun = list(col1 = jjcsformat_count_denom_fraction, col23 = jjcsformat_xx, coldiff = jjcsformat_xx),
  multivars = c("AVAL", "AVAL", "CHG"),
  weights_emmeans = NULL,
  method_combo = c("contrasts", "collapse"),
  weights_combo = NULL
) {
  checkmate::check_character(ref_path, min.len = 2L)
  checkmate::assert_true(length(ref_path) %% 2L == 0L)

  denom <- match.arg(denom)
  method_combo <- match.arg(method_combo)

  if (comp_btw_group && is.null(ref_path)) {
    stop("ref_path cannot be NULL, please specify it. See ?get_ref_info for details.")
  }

  if (!(length(multivars) == 3)) {
    stop("argument multivars must be of length 3.")
  }

  if (!(all(multivars %in% names(df)))) {
    stop("all variables specified in multivars must be available on input dataset df.")
  }

  if (multivars[1] == multivars[2]) {
    multivars[2] <- paste0(multivars[2], "._[[2]]_.")
  }

  if (
    !is.list(.stats) ||
      !all(c("col1", "col23", "coldiff") %in% names(.stats)) ||
      !is.list(.formats) ||
      !all(c("col1", "col23", "coldiff") %in% names(.formats)) ||
      !is.list(.formats_fun) ||
      !all(c("col1", "col23", "coldiff") %in% names(.formats_fun))
  ) {
    stop(paste(
      "Issue a_summarize_aval_chg_diff_j \n.stats/.formats/.formats_fun must",
      "be a list with names c(\"col1\", \"col23\", \"coldiff\")."
    ))
  }

  row_vars <- .spl_context$split
  row_val <- .spl_context$cur_col_split_val

  col_split <- .spl_context$cur_col_split

  ## treatment group value/variable KEY assumption : treatment variable is the last split_col prior to
  ## split_cols_by_multivar
  colvars <- col_split[[NROW(.spl_context)]]
  colvars_multivars <- which(colvars == "multivars")
  if (identical(colvars_multivars, integer(0))) {
    stop("Layout must at least contain a split_cols_by_multivar call.")
  }
  if (colvars_multivars == 1) {
    stop("Layout must at least contain a split_cols_by prior to split_cols_by_multivar call.")
  }
  ## KEY assumption : treatment variable is the last split_col prior to split_cols_by_multivar
  trt_var <- .spl_context$cur_col_split[[NROW(.spl_context)]][colvars_multivars - 1]
  trt_val <- .spl_context$cur_col_split_val[[NROW(.spl_context)]][colvars_multivars - 1]

  mysplitlevel <- length(.spl_context$split)
  cur_lvl <- .spl_context$value[[mysplitlevel]]
  cur_col_id <- .spl_context$cur_col_id[[mysplitlevel]]

  cur_param <- .spl_context$value[[mysplitlevel - 1]]

  indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)

  # Early return if we're not comparing between groups but we're in a difference column
  if (!comp_btw_group && indiffcol) {
    return(rcell(NULL, format = NULL, label = cur_lvl, format_na_str = format_na_str))
  }

  ## variable that is analyzed
  last_val <- utils::tail(.spl_context$cur_col_split_val[[NROW(.spl_context)]], 1)

  # as AVAL will be utilized twice, the second call results in last_val == 'AVAL._[[2]]_.'  take the first part of it
  # in flast_val (will become AVAL) flast_val <- stringr::str_split_1(last_val, pattern = '._')[1]
  flast_val <- unlist(strsplit(last_val, "._"))[1]

  x_stats <- NULL
  fmt_d <- NULL

  .in_ref_col <- FALSE
  .ref_group <- NULL
  ctrl_grp <- NULL
  if (comp_btw_group) {
    checkmate::assert_true(identical(trt_var, ref_path[length(ref_path) - 1L]))
    ctrl_grp <- ref_path[length(ref_path)]
    stopifnot(ctrl_grp %in% levels(df[[trt_var]]))

    if (trt_val == ctrl_grp) .in_ref_col <- TRUE

    .ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]
  }

  if (last_val == multivars[1] && !indiffcol) {
    mystat <- .stats[["col1"]]
    if (is.null(.formats[["col1"]])) {
      fmt <- .formats_fun[["col1"]]
    } else {
      fmt <- .formats[["col1"]]
    }

    x_stats <- s_aval_chg_col1(
      df = df,
      .var = flast_val,
      denom = denom,
      .N_col = .N_col,
      id = id,
      indatavar = indatavar
    )
  } else if (last_val %in% multivars[2:3]) {
    x_stats <- s_aval_chg_col23_diff(
      df = df,
      .var = flast_val,
      .df_row = .df_row,
      .ref_group = .ref_group,
      .in_ref_col = .in_ref_col,
      ancova = ancova,
      interaction_y = interaction_y,
      interaction_item = interaction_item,
      conf_level = conf_level,
      variables = variables,
      trt_var = trt_var,
      ctrl_grp = ctrl_grp,
      cur_param = cur_param,
      cur_lvl = cur_lvl,
      weights_emmeans = weights_emmeans,
      method_combo = method_combo,
      weights_combo = weights_combo
    )

    if (comp_btw_group && indiffcol) {
      mystat1 <- "coldiff"
    } else {
      mystat1 <- "col23"
    }
    mystat <- .stats[[mystat1]]

    fmt_d <- .formats[[mystat1]]
    formatting_fun <- .formats_fun[[mystat1]]

    fmt <- format_xxd(fmt_d, d = d, .df_row = .df_row, formatting_fun = formatting_fun)
  }
  x_stats <- x_stats[[mystat]]

  ret <- rcell(x_stats, format = fmt, label = cur_lvl, format_na_str = format_na_str)
  return(ret)
}

#' Calculate Count and Percentage of the Maximum Level of an Ordered Factor per
#' Subject.
#'
#' @description A formatted analysis function used as an `afun` in
#'  \link[rtables]{analyze} and as a `cfun` in \link[rtables]{summarize_row_groups}.
#'
#'  It computes count and proportion statistics for the maximum level of an
#'  ordered factor, `df[[.var]]`, for each unique subject in `df[[id]]`.
#'  Specifically, for each subject, the function identifies the highest level
#'  of `df[[.var]]`, producing one value per subject.
#'  Then, if `any_level = TRUE`, the function reports the total number of
#'  maximum values, excluding those specified in `any_level_exclude`.
#'  Otherwise, it tabulates the frequency of each maximum level across all
#'  subjects.
#'
#'  This function is particularly useful for identifying the maximum severity of
#'  adverse events in a treatment sequence, where the most severe event
#'  experienced by a subject is used for reporting.
#'
#' @note The denominator for proportions is computed using the `denom_df`
#'  argument. This serves as a temporary workaround until the next version of
#'  `rtables` is released, which will support `.alt_count_df` for use in
#'  `afun`/`cfun`.
#'
#' @details For each unique subject, only the maximum level of the ordered factor
#'  `df[[.var]]` is included in the final count and percentage statistics.
#'
#' @inheritParams proposal_argument_convention
#' @param .alt_df_full (`dataframe`)\cr A dataset used to compute the
#'  denominator for proportions. This is required when the same subject appears
#'  multiple times in the dataset due to treatment sequences.
#'  `colnames(.alt_df_full)` must be a superset of `id`.
#'  This argument gets populated by the rtables split machinery
#'  (see [rtables::additional_fun_params]).
#' @param any_level (`flag`)\cr
#'  Should be set to `TRUE` when the function is used as a `cfun`.
#' @param any_level_exclude (`character`)\cr
#'  Applicable only when `any_level = TRUE`. Specifies levels of `df[[.var]]`
#'  to exclude from the statistic (default = "Missing").
#'
#' @returns A `RowsVerticalSection` object.
#'
#' @author WW
#'
#' @export
#'
#' @examples
#' treatments <- factor(c("a", "b", "c"))
#' ae_severities <- c("Missing", "Mild", "Moderate", "Severe")
#' ae_severities <- ordered(ae_severities, levels = ae_severities)
#' my_adae <- data.frame(
#'   ID = c(1, 1, 1, 2, 2, 3, 3, 3, 3, 4),
#'   TRT = factor(c("a", "b", "b", "b", "c", "c", "a", "c", "b", "b")),
#'   AESEV = ae_severities[c(4L, 1L, 2L, 1L, 2L, 1L, 2L, 3L, 1L, 2L)]
#' )
#' my_adsl <- data.frame(
#'   ID = rep(1:5, each = 3),
#'   TRT = factor(rep(c("a", "b", "c"), times = 5))
#' )
#'
#' aesevall_spf <- make_combo_splitfun(
#'   nm = "AESEV_ALL",
#'   label = "Any AE",
#'   levels = NULL,
#' )
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT") |>
#'   add_overall_col("Total") |>
#'   split_rows_by("AESEV", split_fun = aesevall_spf) |>
#'   summarize_row_groups(
#'     "AESEV",
#'     cfun = a_maxlev,
#'     extra_args = list(id = "ID", any_level = TRUE)
#'   ) |>
#'   analyze(
#'     "AESEV",
#'     afun = a_maxlev,
#'     extra_args = list(id = "ID")
#'   )
#' build_table(lyt, my_adae, alt_counts_df = my_adsl)
a_maxlev <- function(df,
                     labelstr = NULL,
                     .var,
                     .spl_context,
                     id = "USUBJID",
                     .alt_df_full = NULL,
                     any_level = FALSE,
                     any_level_exclude = "Missing",
                     ...) {
  checkmate::assert_factor(df[[.var]], ordered = TRUE, any.missing = FALSE)
  checkmate::assert_string(id)
  checkmate::assert_subset(id, choices = colnames(df))
  checkmate::assert_subset(id, choices = colnames(.alt_df_full))
  checkmate::assert_flag(any_level)
  checkmate::assert_character(any_level_exclude, any.missing = FALSE, unique = TRUE)

  varvec <- df[[.var]]
  levs <- levels(varvec)
  levs_lab <- if (any_level) {
    labelstr
  } else {
    levs
  }

  N_row <- nrow(df)
  count_pct <- if (N_row != 0) {
    max_per_id <- tapply(varvec, df[[id]], max)
    max_per_id <- ordered(levs[max_per_id], levels = levs) # tapply loses levels of varvec.

    count_max <- if (any_level) {
      sum(max_per_id != any_level_exclude)
    } else {
      table(max_per_id)
    }

    cur_col <- subset(.alt_df_full, eval(.spl_context$cur_col_expr[[1]]))
    N <- length(unique(cur_col[[id]]))
    as.list(data.frame(rbind(count_max, count_max / N)))
  } else {
    rep(list(NA), length(levs_lab))
  }

  count_pct <- setNames(count_pct, levs_lab)

  in_rows(
    .list = count_pct,
    .formats = jjcsformat_count_fraction,
    .format_na_strs = "-"
  )
}

#' @title Descriptive Statistics for Univariate Data with Optional Reference
#' Comparison
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Computes descriptive statistics for a single variable `df[[.var]]` using
#' [tern::s_summary()], which dispatches type-specific methods depending on the
#' S3 class of the input (e.g., character, factor, logical, numeric).
#'
#' Optionally, it computes estimates and associated inferential statistics for
#' the difference in population means between two underlying distributions,
#' based on observed samples `df[[.var]]` and `.ref_group[[.var]]` using
#' [s_diff_means()].
#' These statistics are applicable only to numeric data.
#'
#' @inheritParams proposal_argument_convention
#' @param .var (`character(1)`)\cr Name of the column in `df` containing the
#'   values for which statistics are computed. The variable type is handled by
#'   the corresponding methods of [tern::s_summary()].
#'   If difference-in-means statistics are requested, `df[[.var]]` must be
#'   numeric.
#' @param .stats (`character` or `NULL`)\cr Names of statistics to be computed.
#'   For numerical data, the names of supported statistics are listed via
#'   [tern::get_stats()] for statistics for a single variable and
#'   `junco_get_stats("diff_means")` for difference-in-means statistics.
#'   If `NULL`, all available statistics for numerical data are computed.
#' @param control (`list`)\cr List of control options passed to
#'   [tern::s_summary()].
#'   If difference-in-means statistics are requested, `control$conf_level`
#'   specifies the confidence level of the interval.
#' @param ... Additional named arguments passed to [s_diff_means()], except
#'   `df1`, `df2`, `.var`, and `conf.level`, which are already passed.
#'
#' @importFrom tern control_analyze_vars s_summary get_stats
#'
#' @returns A named `list` with the requested statistics.
#'
#' @author WW
#'
#' @export
#'
#' @examples
#' df <- data.frame(
#'   USUBJID = c("X01", "X02", "X03", "X04", "X05"),
#'   TRT01A = rep("ARM_A", 5),
#'   PARAMCD = rep("SYSBP", 5),
#'   AVISIT = rep("Visit 1", 5),
#'   CHG = c(4, 1, -1, 9, -2)
#' )
#' df
#'
#' rg <- data.frame(
#'   USUBJID = c("X06", "X07", "X08", "X09", "X10"),
#'   TRT01A = rep("Placebo", 5),
#'   PARAMCD = rep("SYSBP", 5),
#'   AVISIT = rep("Visit 1", 5),
#'   CHG = c(-2, 6, -2, 5, 2)
#' )
#' rg
#'
#' .stats <- c("n", "mean_sd", "diff_means_n1", "diff_means_n2", "diff_means_est_ci")
#'
#' # With reference group.
#' s_summary_diff(df, "CHG", .stats, rg)
#'
#' # Using df as reference.
#' s_summary_diff(df, "CHG", .stats, df, .in_ref_col = TRUE)
#'
s_summary_diff <- function(df,
                           .var,
                           .stats = NULL,
                           .ref_group = NULL,
                           .in_ref_col = FALSE,
                           control = tern::control_analyze_vars(),
                           ...) {
  checkmate::assert_data_frame(df, null.ok = FALSE)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df), must.include = .var)
  checkmate::assert_character(
    x = .stats, any.missing = FALSE, min.len = 1, unique = TRUE, null.ok = TRUE
  )
  checkmate::assert_flag(.in_ref_col, null.ok = FALSE)
  checkmate::assert_list(control, null.ok = FALSE)

  if (is.null(.stats)) {
    .stats <- unique(c(tern::get_stats(), junco_get_stats("diff_means")))
  }

  y <- tern::s_summary(df[[.var]], control = control)

  .stats_diff <- .stats[startsWith(.stats, "diff_means_")]
  if (length(.stats_diff) >= 1) {
    dm <- if (.in_ref_col) {
      setNames(vector(mode = "list", length = length(.stats_diff)), .stats_diff)
    } else {
      if (!checkmate::test_data_frame(.ref_group, null.ok = FALSE)) {
        stop(".ref_group must be a data.frame for diff_means_* stats when .in_ref_col = FALSE")
      }
      checkmate::assert_names(names(control), must.include = "conf_level")
      s_diff_means(df, .ref_group, .var, conf.level = control$conf_level, ...)
    }
    y <- c(y, dm)
  }

  y[.stats]
}

#' Analysis of Covariance
#'
#' Performs an analysis of covariance between two groups returning the estimated
#' "treatment effect" (i.e. the contrast between the two treatment groups) and
#' the least square means estimates in each group.
#'
#' @param data A `data.frame` containing the data to be used in the model.
#' @param vars A `vars` object as generated by the set_vars() function from the rbmi package. Only the `group`,
#' `visit`, `outcome` and `covariates` elements are required. See details.
#' @param visits An optional character vector specifying which visits to
#' fit the ancova model at. If `NULL`, a separate ancova model will be fit to the
#' outcomes for each visit (as determined by `unique(data[[vars$visit]])`).
#' See details.
#' @param weights Character, either `"counterfactual"` (default), `"equal"`,
#' `"proportional_em"` or `"proportional"`.
#' Specifies the weighting strategy to be used when calculating the lsmeans.
#' See the weighting section for more details.
#'
#' @details
#' The function works as follows:
#'
#' 1. Select the first value from `visits`.
#' 2. Subset the data to only the observations that occurred on this visit.
#' 3. Fit a linear model as  `vars$outcome ~ vars$group + vars$covariates`.
#' 4. Extract the "treatment effect" & least square means for each treatment group.
#' 5. Repeat points 2-3 for all other values in `visits`.
#'
#' If no value for `visits` is provided then it will be set to
#' `unique(data[[vars$visit]])`.
#'
#' In order to meet the formatting standards set by [rbmi_analyse()] the results will be collapsed
#' into a single list suffixed by the visit name, e.g.:
#' ```
#' list(
#'    var_visit_1 = list(est = ...),
#'    trt_B_visit_1 = list(est = ...),
#'    lsm_A_visit_1 = list(est = ...),
#'    lsm_B_visit_1 = list(est = ...),
#'    var_visit_2 = list(est = ...),
#'    trt_B_visit_2 = list(est = ...),
#'    lsm_A_visit_2 = list(est = ...),
#'    lsm_B_visit_2 = list(est = ...),
#'    ...
#' )
#' ```
#' Please note that "trt" refers to the treatment effects, and "lsm" refers to the least
#' square mean results. In the above example `vars$group` has two factor levels A and B.
#' The new "var" refers to the model estimated variance of the residuals.
#'
#' If you want to include interaction terms in your model this can be done
#' by providing them to the `covariates` argument of the set_vars() function from the rbmi package
#' e.g. `set_vars(covariates = c("sex*age"))`.
#'
#' @return a list of variance (`var_*`), treatment effect (`trt_*`), and
#'   least square mean (`lsm_*`) estimates for each visit, organized as
#'   described in Details above.
#'
#' @note These functions have the `rbmi_` prefix to distinguish them from the corresponding
#'   `rbmi` package functions, from which they were copied from. Additional features here
#'   include:
#'
#'   * Support for more than two treatment groups.
#'   * Variance estimates are returned.
#'
#' @seealso [rbmi_analyse()]
#' @seealso [stats::lm()]
#' @seealso The set_vars() function from the rbmi package
#' @export
rbmi_ancova <- function(
  data,
  vars,
  visits = NULL,
  weights = c("counterfactual", "equal", "proportional_em", "proportional")
) {
  outcome <- vars[["outcome"]]
  group <- vars[["group"]]
  covariates <- vars[["covariates"]]
  visit <- vars[["visit"]]
  weights <- match.arg(weights)

  expected_vars <- c(
    utils::getFromNamespace("extract_covariates", "rbmi")(covariates),
    outcome,
    group
  )

  if (is.null(visits)) {
    visits <- unique(data[[visit]])
  }

  res <- lapply(
    visits,
    function(x) {
      data2 <- data[data[[visit]] == x, ]
      res <- rbmi_ancova_single(data2, outcome, group, covariates, weights)
      names(res) <- paste0(names(res), "_", x)
      return(res)
    }
  )
  return(unlist(res, recursive = FALSE))
}


#' Implements an Analysis of Covariance (ANCOVA)
#'
#' @description
#' Performance analysis of covariance. See [rbmi_ancova()] for full details.
#'
#' @param outcome string, the name of the outcome variable in `data`.
#' @param group string, the name of the group variable in `data`.
#' @param covariates character vector containing the name of any additional covariates
#' to be included in the model as well as any interaction terms.
#'
#' @inheritParams rbmi_ancova
#'
#' @details
#' - `group` must be a factor variable with only 2 levels.
#' - `outcome` must be a continuous numeric variable.
#' @export
#' @return a list containing `var` with variance estimates as well as
#' `trt_*` and `lsm_*` entries. See [rbmi_ancova()] for full details.
#' @examples
#'
#'  iris2 <- iris[iris$Species %in% c("versicolor", "virginica"), ]
#'  iris2$Species <- factor(iris2$Species)
#'  rbmi_ancova_single(iris2, "Sepal.Length", "Species", c("Petal.Length * Petal.Width"))
#'
#'
#' @seealso [rbmi_ancova()]
rbmi_ancova_single <- function(
  data,
  outcome,
  group,
  covariates,
  weights = c("counterfactual", "equal", "proportional_em", "proportional")
) {
  checkmate::assert_string(outcome)
  checkmate::assert_string(group)
  weights <- match.arg(weights)

  checkmate::assert_factor(data[[group]], n.levels = 2L)
  checkmate::assert_numeric(data[[outcome]])
  data2 <- data[, c(
    utils::getFromNamespace("extract_covariates", "rbmi")(covariates),
    outcome,
    group
  )]

  frm <- utils::getFromNamespace("as_simple_formula", "rbmi")(
    outcome,
    c(group, covariates)
  )

  mod <- stats::lm(formula = frm, data = data2)

  args <- list(model = mod, .weights = weights)

  grp_levels <- levels(data2[[group]])

  all_lsm <- lapply(
    grp_levels,
    \(x) {
      do.call(
        utils::getFromNamespace("lsmeans", "rbmi"),
        c(args, stats::setNames(x, group))
      )
    }
  )
  names(all_lsm) <- paste0("lsm_", grp_levels)

  var_est <- summary(mod)$sigma^2
  var_df <- stats::df.residual(mod)

  all_trt <- lapply(
    paste0(group, grp_levels[-1]),
    \(x) {
      list(
        est = stats::coef(mod)[x],
        se = sqrt(stats::vcov(mod)[x, x]),
        df = var_df
      )
    }
  )
  names(all_trt) <- paste0("trt_", grp_levels[-1])

  var_res <- list(
    var = list(
      est = var_est,
      # Reference: Davison, Statistical Methods, p. 371 (just above 8.3.2)
      se = var_est / sqrt(var_df / 2),
      df = var_df
    )
  )

  c(var_res, all_trt, all_lsm)
}

#' Get default statistical methods and their associated formats, labels, and indent modifiers
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @note These functions have been copied from the `tern` package file
#'   `utils_default_stats_formats_labels.R` from GitHub development version 0.9.7.9017.
#'   Slight modifications have been applied to enhance functionality:
#'
#'   * `tern_get_stats` added the `tern_stats` argument to avoid hardcoding within the function's body.
#'   * `tern_get_labels_from_stats` is more careful when receiving partial `labels_in`
#'      and partial `label_attr_from_stats`.
#'
#'   Once these features are included in the `tern` package, this file could be removed from
#'   the `junco` package, and the functions could be used from the `tern` namespace directly.
#'
#' @name tern_default_stats_formats_labels
NULL


#' @keywords internal
.split_std_from_custom_stats <- function(stats_in) {
  out <- list(default_stats = NULL, custom_stats = NULL, all_stats = NULL)
  if (is.list(stats_in)) {
    is_custom_fnc <- sapply(stats_in, is.function)
    checkmate::assert_list(
      stats_in[is_custom_fnc],
      types = "function",
      names = "named"
    )
    out[["custom_stats"]] <- stats_in[is_custom_fnc]
    out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc])
    all_stats <- names(stats_in) # to keep the order
    all_stats[!is_custom_fnc] <- out[["default_stats"]]
    out[["all_stats"]] <- all_stats
  } else {
    out[["default_stats"]] <- out[["all_stats"]] <- stats_in
  }
  out
}

#' @keywords internal
.apply_stat_functions <- function(
  default_stat_fnc,
  custom_stat_fnc_list,
  args_list) {
  # Default checks
  checkmate::assert_function(default_stat_fnc)
  checkmate::assert_list(
    custom_stat_fnc_list,
    types = "function",
    null.ok = TRUE,
    names = "named"
  )
  checkmate::assert_list(args_list)

  # Checking custom stats have same formals
  if (!is.null(custom_stat_fnc_list)) {
    fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]]
    for (fnc in custom_stat_fnc_list) {
      if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) {
        stop(
          "The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ",
          "as the default statistical function. In this case your custom function has ",
          names(formals(fnc))[[1]],
          " as first parameter, while the default function has ",
          fundamental_call_to_data,
          "."
        )
      }
      if (!any(names(formals(fnc)) == "...")) {
        stop(
          "The custom statistical function needs to have `...` as a parameter to accept additional arguments. ",
          "In this case your custom function does not have `...`."
        )
      }
    }
  }

  # Applying
  out_default <- do.call(default_stat_fnc, args = args_list)
  out_custom <- lapply(
    custom_stat_fnc_list,
    function(fnc) do.call(fnc, args = args_list)
  )

  # Merging
  c(out_default, out_custom)
}

#' @describeIn tern_default_stats_formats_labels Get statistics available for a given method
#'   group (analyze function).
#' @keywords internal
tern_get_stats <- function(
  method_groups = "analyze_vars_numeric",
  stats_in = NULL,
  custom_stats_in = NULL,
  add_pval = FALSE,
  tern_defaults = tern_default_stats) {
  checkmate::assert_character(method_groups)
  checkmate::assert_character(stats_in, null.ok = TRUE)
  checkmate::assert_character(custom_stats_in, null.ok = TRUE)
  checkmate::assert_flag(add_pval)

  # Default is still numeric
  if (any(method_groups == "analyze_vars")) {
    method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"
  }

  type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks

  # Defaults for loop
  out <- NULL

  # Loop for multiple method groups
  for (mgi in method_groups) {
    if (mgi %in% names(tern_defaults)) {
      out_tmp <- tern_defaults[[mgi]]
    } else {
      stop(
        "The selected method group (",
        mgi,
        ") has no default statistical method."
      )
    }
    out <- unique(c(out, out_tmp))
  }

  # Add custom stats
  out <- c(out, custom_stats_in)

  # If you added pval to the stats_in you certainly want it
  if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
    stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]

    # Must be only one value between choices
    checkmate::assert_choice(
      stats_in_pval_value,
      c("pval", "pval_counts", "pvalue")
    )

    # Mismatch with counts and numeric
    if (
      any(grepl("counts", method_groups)) &&
        stats_in_pval_value != "pval_counts" ||
        any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval"
    ) {
      # nolint
      stop(
        "Inserted p-value (",
        stats_in_pval_value,
        ") is not valid for type ",
        type_tmp,
        ". Use ",
        paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),
        " instead."
      )
    }

    # Lets add it even if present (thanks to unique)
    add_pval <- TRUE
  }

  # Mainly used in "analyze_vars" but it could be necessary elsewhere
  if (isTRUE(add_pval)) {
    if (any(grepl("counts", method_groups))) {
      out <- unique(c(out, "pval_counts"))
    } else {
      out <- unique(c(out, "pval"))
    }
  }

  # Filtering for stats_in (character vector)
  if (!is.null(stats_in)) {
    out <- intersect(stats_in, out) # It orders them too
  }

  # If intersect did not find matches (and no pval?) -> error
  if (length(out) == 0) {
    stop(
      "The selected method group(s) (",
      paste0(method_groups, collapse = ", "),
      ")",
      " do not have the required default statistical methods:\n",
      paste0(stats_in, collapse = " ")
    )
  }

  out
}

#' @describeIn tern_default_stats_formats_labels Get formats corresponding to a list of statistics.
#' @keywords internal
tern_get_formats_from_stats <- function(
  stats,
  formats_in = NULL,
  levels_per_stats = NULL,
  tern_defaults = tern_default_formats) {
  checkmate::assert_character(stats, min.len = 1)
  # It may be a list if there is a function in the formats
  if (checkmate::test_list(formats_in, null.ok = TRUE)) {
    checkmate::assert_list(formats_in, null.ok = TRUE)
    # Or it may be a vector of characters
  } else {
    checkmate::assert_character(formats_in, null.ok = TRUE)
  }
  checkmate::assert_list(levels_per_stats, null.ok = TRUE)

  # If unnamed formats given as formats_in and same number of stats, use one format per stat
  if (
    !is.null(formats_in) &&
      length(formats_in) == length(stats) &&
      is.null(names(formats_in)) &&
      is.null(levels_per_stats)
  ) {
    out <- as.list(formats_in) |> stats::setNames(stats)
    return(out)
  }

  # If levels_per_stats not given, assume one row per statistic
  if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) |> stats::setNames(stats)

  # Apply custom formats
  out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults)

  # Default to NULL if no format
  case_input_is_not_stat <- unlist(out, use.names = FALSE) == unlist(levels_per_stats, use.names = FALSE)
  out[names(out) == out | case_input_is_not_stat] <- list(NULL)

  out
}

#' @describeIn tern_default_stats_formats_labels Get labels corresponding to a list of statistics.
#' @keywords internal
tern_get_labels_from_stats <- function(
  stats,
  labels_in = NULL,
  levels_per_stats = NULL,
  label_attr_from_stats = NULL,
  tern_defaults = tern_default_labels) {
  checkmate::assert_character(stats, min.len = 1)

  # Modification:
  # If any label_attr_from_stats is available and valid, save in labels_in
  # if not specified there already (so don't overwrite labels_in).
  if (!is.null(label_attr_from_stats)) {
    valid_label_attr_from_stats <- label_attr_from_stats[
      nzchar(label_attr_from_stats) &
        !sapply(label_attr_from_stats, is.null) &
        !is.na(label_attr_from_stats)
    ]
    if (length(valid_label_attr_from_stats)) {
      do_save <- setdiff(
        names(valid_label_attr_from_stats),
        names(labels_in)
      )
      labels_in <- c(labels_in, valid_label_attr_from_stats[do_save])
    }
  }

  # It may be a list
  if (checkmate::test_list(labels_in, null.ok = TRUE)) {
    checkmate::assert_list(labels_in, null.ok = TRUE)
    # Or it may be a vector of characters
  } else {
    checkmate::assert_character(labels_in, null.ok = TRUE)
  }
  checkmate::assert_list(levels_per_stats, null.ok = TRUE)

  # If unnamed labels given as labels_in and same number of stats, use one label per stat
  if (
    !is.null(labels_in) &&
      length(labels_in) == length(stats) &&
      is.null(names(labels_in)) &&
      is.null(levels_per_stats)
  ) {
    out <- as.list(labels_in) |> stats::setNames(stats)
    return(out)
  }

  # If levels_per_stats not given, assume one row per statistic
  if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) |> stats::setNames(stats)

  # Apply custom labels
  out <- .fill_in_vals_by_stats(levels_per_stats, labels_in, tern_defaults)
  out
}

# Function to loop over each stat and levels to set correct values
.fill_in_vals_by_stats <- function(levels_per_stats, user_in, tern_defaults) {
  out <- list()

  levels_per_stats_list <- NULL
  for (stat_i in names(levels_per_stats)) {
    # Get all levels of the statistic
    all_lvls <- levels_per_stats[[stat_i]]

    if ((length(all_lvls) == 1 && all_lvls == stat_i) || is.null(all_lvls)) {
      # One row per statistic
      out[[stat_i]] <- if (stat_i %in% names(user_in)) {
        # 1. Check for stat_i in user input
        user_in[[stat_i]]
      } else if (stat_i %in% names(tern_defaults)) {
        # 2. Check for stat_i in tern defaults
        tern_defaults[[stat_i]]
      } else {
        # 3. Otherwise stat_i
        stat_i
      }
      levels_per_stats_list <- c(levels_per_stats_list, stat_i)
    } else {
      # One row per combination of variable level and statistic
      # Loop over levels for each statistic
      for (lev_i in all_lvls) {
        # Construct row name (stat_i.lev_i)
        row_nm <- paste(stat_i, lev_i, sep = ".")

        out[[row_nm]] <- if (row_nm %in% names(user_in)) {
          # 1. Check for stat_i.lev_i in user input
          user_in[[row_nm]]
        } else if (lev_i %in% names(user_in)) {
          # 2. Check for lev_i in user input
          user_in[[lev_i]]
        } else if (stat_i %in% names(user_in)) {
          # 3. Check for stat_i in user input
          user_in[[stat_i]]
        } else if (lev_i %in% names(tern_defaults)) {
          # 4. Check for lev_i in tern defaults (only used for labels)
          tern_defaults[[lev_i]]
        } else if (stat_i %in% names(tern_defaults)) {
          # 5. Check for stat_i in tern defaults
          tern_defaults[[stat_i]]
        } else {
          # 6. Otherwise lev_i
          lev_i
        }
        levels_per_stats_list <- c(levels_per_stats_list, row_nm)
      }
    }
  }

  if (any(duplicated(levels_per_stats_list))) {
    # this is to cover the same stat more than once
    # in risk diff column more than one stat transformed into same riskdiff stat
    out <- out[levels_per_stats_list]
  }

  out
}

#' @describeIn tern_default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.
#' @keywords internal
tern_get_indents_from_stats <- function(stats,
                                        indents_in = NULL,
                                        levels_per_stats = NULL,
                                        tern_defaults = as.list(rep(0L, length(stats))) |> stats::setNames(stats)) {
  checkmate::assert_character(stats, min.len = 1)
  # It may be a list
  if (checkmate::test_list(indents_in, null.ok = TRUE)) {
    checkmate::assert_list(indents_in, null.ok = TRUE)
    # Or it may be a vector of integers
  } else {
    checkmate::assert_integerish(indents_in, null.ok = TRUE)
  }
  checkmate::assert_list(levels_per_stats, null.ok = TRUE)

  # If levels_per_stats not given, assume one row per statistic
  if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) |> stats::setNames(stats)

  # Single indentation level for all rows
  if (is.null(names(indents_in)) && length(indents_in) == 1) {
    out <- rep(indents_in, length(levels_per_stats |> unlist()))
    return(out)
  }

  # Apply custom indentation
  out <- .fill_in_vals_by_stats(levels_per_stats, indents_in, tern_defaults)
  out
}

# tern_default_labels ----

#' @describeIn tern_default_stats_formats_labels Named `character` vector of default labels for `tern`.
#'   This is only copied here from the latest GitHub version, because otherwise a tern test fails.
#'
#' @keywords internal
tern_default_labels <- c(
  cv = "CV (%)",
  iqr = "IQR",
  geom_cv = "CV % Geometric Mean",
  geom_mean = "Geometric Mean",
  geom_mean_sd = "Geometric Mean (SD)",
  geom_mean_ci = "Geometric Mean 95% CI",
  geom_mean_ci_3d = "Geometric Mean (95% CI)",
  geom_sd = "Geometric SD",
  mad = "Median Absolute Deviation",
  max = "Maximum",
  mean = "Mean",
  mean_ci = "Mean 95% CI",
  mean_ci_3d = "Mean (95% CI)",
  mean_pval = "Mean p-value (H0: mean = 0)",
  mean_sd = "Mean (SD)",
  mean_sdi = "Mean -/+ 1xSD",
  mean_se = "Mean (SE)",
  mean_sei = "Mean -/+ 1xSE",
  median = "Median",
  median_ci = "Median 95% CI",
  median_ci_3d = "Median (95% CI)",
  median_range = "Median (Min - Max)",
  min = "Minimum",
  n = "n",
  n_blq = "n_blq",
  nonunique = "Number of events",
  pval = "p-value (t-test)", # Default for numeric
  pval_counts = "p-value (chi-squared test)", # Default for counts
  quantiles = "25% and 75%-ile",
  quantiles_lower = "25%-ile (95% CI)",
  quantiles_upper = "75%-ile (95% CI)",
  range = "Min - Max",
  range_censor = "Range (censored)",
  range_event = "Range (event)",
  rate = "Adjusted Rate",
  rate_ratio = "Adjusted Rate Ratio",
  sd = "SD",
  se = "SE",
  sum = "Sum",
  unique = "Number of patients with at least one event"
)


# utility function to get labels from x_stats label attribute (or name if no label present)
#' @keywords internal
junco_get_labels_from_attrib <- function(.stats, .labels, x_stats) {
  .labels_out <- unlist(junco_get_labels_from_stats(.stats, .labels, setNames(as.list(.stats), .stats)))
  .labels_out <- .labels_out[.stats]

  if (!all(names(x_stats) %in% .stats)) {
    # assumption: incoming x_stats has .stats in inner list
    # key assumption, all inner lists have same structure
    inner_names <- unique(lapply(x_stats, names))
    if (length(inner_names) > 1 || !(all(inner_names[[1]] %in% .stats))) {
      stop("incorrect .stats/x_stats structure assumption")
    }
    # now we can more safely take the first element to retrieve labels
    nms_stats_pre <- x_stats[[1]]
  } else {
    nms_stats_pre <- x_stats
  }

  nms_stats <- vapply(seq_along(nms_stats_pre), function(i) {
    el <- nms_stats_pre[[i]]
    attr(el, "label") %||% names(nms_stats_pre)[i]
  }, character(1))

  names(nms_stats) <- .stats

  .labels_out[.labels_out == .stats] <- nms_stats[.labels_out == .stats]

  .labels_out
}

#' @title Safe Wrapper for `stats::t.test()`
#'
#' @noRd
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A robust wrapper around [stats::t.test()] that prevents errors from
#' interrupting execution.
#'
#' Instead of failing, the function returns an object of class `"htest"`
#' containing `NA` values for inferential statistics together with the computed
#' sample mean(s) and an informative error message embedded in the `method`
#' field.
#'
#' This is particularly useful in pipelines, simulations, or batch analyses
#' where occasional invalid inputs (e.g., constant vectors or insufficient
#' observations) would otherwise stop execution.
#'
#' @details
#' Inputs `x` and `y` must be numeric vectors containing only finite,
#' non-missing values. In particular, `NA`, `NaN`, `Inf`, and `-Inf` values are
#' not allowed and will trigger an error before [stats::t.test()] is evaluated.
#'
#' When [stats::t.test()] succeeds, the resulting `"htest"` object is returned
#' unchanged except that `data.name` is reconstructed from the original
#' expressions supplied to `x` and `y`.
#'
#' When an error occurs, the function returns an object of class `"htest"` with:
#'
#' \itemize{
#'   \item `NA_real` values for `statistic`, `parameter`, `p.value`, `stderr`,
#'   and `conf.int`
#'   \item computed sample mean(s) stored in `estimate`
#'   \item the original null hypothesis value stored in `null.value`
#'   \item the original test type and error message appended to `method`.
#' }
#'
#' @inheritParams stats::t.test
#' @param x (`numeric`)\cr A numeric vector containing only finite, non-missing
#'   values.
#' @param y (`numeric`)\cr  An optional numeric vector containing only finite,
#'   non-missing values.
#'
#' @return
#' An object of class `"htest"`.
#'
#' If [stats::t.test()] succeeds, the standard `"htest"` object is returned.
#' If an error occurs, an `"htest"` object with `NA` inferential statistics and
#' computed sample mean(s) in `estimate` is returned instead.
#'
#' @author WW
#'
#' @importFrom stats t.test
#'
#' @examples
#' # Standard usage
#' x <- 1:10
#' y <- 11:20
#'
#' t.test(x, y)
#' safe_t_test(x, y)
#'
#' # Paired test with constant differences
#' x <- rep(10, 5)
#'
#' t.test(x, x, paired = TRUE)
#' safe_t_test(x, x, paired = TRUE)
#'
#' # Example triggering an error (constant data)
#' t.test(x, x)
#' safe_t_test(x, x)
safe_t_test <- function(
  x,
  y = NULL,
  alternative = c("two.sided", "less", "greater"),
  mu = 0,
  paired = FALSE,
  var.equal = FALSE,
  conf.level = 0.95,
  ...
) {
  x_expr <- substitute(x)
  y_expr <- substitute(y)
  alternative <- match.arg(alternative)

  checkmate::assert_numeric(x, any.missing = FALSE, finite = TRUE)
  if (paired) {
    checkmate::assert_numeric(y, finite = TRUE, any.missing = FALSE, len = length(x))
  } else {
    checkmate::assert_numeric(y, finite = TRUE, any.missing = FALSE, null.ok = TRUE)
  }
  checkmate::assert_choice(alternative, choices = c("two.sided", "less", "greater"))
  checkmate::assert_number(mu, finite = TRUE)
  checkmate::assert_flag(paired)
  checkmate::assert_flag(var.equal)
  checkmate::assert_number(conf.level, lower = 0, upper = 1, finite = TRUE)

  tryCatch(
    {
      res <- stats::t.test(
        x = x,
        y = y,
        alternative = alternative,
        mu = mu,
        paired = paired,
        var.equal = var.equal,
        conf.level = conf.level,
        ...
      )

      res$data.name <- if (is.null(y)) {
        deparse1(x_expr)
      } else {
        paste(deparse1(x_expr), "and", deparse1(y_expr))
      }

      res
    },
    error = function(e) {
      if (paired) {
        x <- x - y
        y <- NULL
      }

      if (is.null(y)) {
        estimate <- mean(x)
        dname <- deparse1(x_expr)
        method <- ifelse(paired, "Paired t-test", "One Sample t-test")
        names(estimate) <- ifelse(paired, "mean difference", "mean of x")
      } else {
        estimate <- c(mean(x), mean(y))
        dname <- paste(deparse1(x_expr), "and", deparse1(y_expr))
        method <- paste(if (!var.equal) "Welch", "Two Sample t-test")
        names(estimate) <- c("mean of x", "mean of y")
      }
      estimate[is.nan(estimate)] <- NA_real_

      names(mu) <- if (paired) {
        "mean difference"
      } else if (!is.null(y)) {
        "difference in means"
      } else {
        "mean"
      }

      out <- list(
        statistic = setNames(NA_real_, "t"),
        parameter = setNames(NA_real_, "df"),
        p.value = NA_real_,
        conf.int = c(NA_real_, NA_real_),
        estimate = estimate,
        null.value = mu,
        stderr = NA_real_,
        alternative = alternative,
        method = paste0(method, " (failed: ", e$message, ")"),
        data.name = dname
      )
      attr(out$conf.int, "conf.level") <- conf.level

      class(out) <- "htest"
      out
    }
  )
}

#' @name a_freq_combos_j
#'
#' @title Analysis function count and percentage in column design controlled by combosdf
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams a_freq_j
#'
#' @param combosdf The df which provides the mapping of column facets to produce cumulative counts for .N_col.\cr
#' In the cell facet, these cumulative records must then be removed from the numerator,
#' which can be done via the filter_var parameter
#' to avoid unwanted counting of events.
#' @param do_not_filter A vector of facets (i.e., column headers), identifying headers for which
#' no filtering of records should occur.
#' That is, the numerator should contain cumulative counts.  Generally, this will be used for a
#' "Total" column, or something similar.
#' @param filter_var The variable which identifies the records to count in the numerator for any given column.
#' Generally, this will contain text matching the column header for the column associated with a given record.
#' @param flag_var Variable which identifies the occurrence (or first occurrence) of an event.
#' The flag variable is expected to have a value of "Y" identifying that the event should be counted, or NA otherwise.
#' @param denom (`string`)\cr
#' One of \cr
#' \itemize{
#' \item \strong{N_col} Column count, \cr
#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
#' (`.row_df` from the rtables splitting machinery).\cr
#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
#' This higher row-level split is specified in the argument `denom_by`.\cr
#' }
#' @param .formats (named 'character' or 'list')\cr
#' formats for the statistics.
#' @seealso [a_freq_j()] for extensive `label_map` usage examples.
#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
#'
#' @examples
#' library(dplyr)
#' ADSL <- ex_adsl |> select(USUBJID, ARM, EOSSTT, EOSDT, EOSDY, TRTSDTM)
#'
#' cutoffd <- as.Date("2023-09-24")
#'
#' ADSL <- ADSL |>
#'   mutate(
#'     TRTDURY = case_when(
#'       !is.na(EOSDY) ~ EOSDY,
#'       TRUE ~ as.integer(cutoffd - as.Date(TRTSDTM) + 1)
#'     )
#'   ) |>
#'   mutate(ACAT1 = case_when(
#'     TRTDURY < 183 ~ "0-6 Months",
#'     TRTDURY < 366 ~ "6-12 Months",
#'     TRUE ~ "+12 Months"
#'   )) |>
#'   mutate(ACAT1 = factor(ACAT1, levels = c("0-6 Months", "6-12 Months", "+12 Months")))
#'
#'
#' ADAE <- ex_adae |> select(USUBJID, ARM, AEBODSYS, AEDECOD, ASTDY)
#'
#' ADAE <- ADAE |>
#'   mutate(TRTEMFL = "Y") |>
#'   mutate(ACAT1 = case_when(
#'     ASTDY < 183 ~ "0-6 Months",
#'     ASTDY < 366 ~ "6-12 Months",
#'     TRUE ~ "+12 Months"
#'   )) |>
#'   mutate(ACAT1 = factor(ACAT1, levels = c("0-6 Months", "6-12 Months", "+12 Months")))
#'
#' combodf <- tribble(
#'   ~valname, ~label, ~levelcombo, ~exargs,
#'   "Tot", "Total", c("0-6 Months", "6-12 Months", "+12 Months"), list(),
#'   "A_0-6 Months", "0-6 Months", c("0-6 Months", "6-12 Months", "+12 Months"), list(),
#'   "B_6-12 Months", "6-12 Months", c("6-12 Months", "+12 Months"), list(),
#'   "C_+12 Months", "+12 Months", c("+12 Months"), list()
#' )
#'
#'
#' lyt <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("ARM") |>
#'   split_cols_by("ACAT1",
#'     split_fun = rtables::add_combo_levels(
#'       combosdf = combodf,
#'       trim = FALSE, keep_levels = combodf$valname
#'     )
#'   ) |>
#'   analyze("TRTEMFL",
#'     show_labels = "hidden",
#'     afun = a_freq_combos_j,
#'     extra_args = list(
#'       val = "Y",
#'       label = "Subjects with >= 1 AE",
#'       combosdf = combodf,
#'       filter_var = "ACAT1",
#'       do_not_filter = "Tot"
#'     )
#'   )
#'
#'
#' result <- build_table(lyt, df = ADAE, alt_counts_df = ADSL)
#'
#' result
#' @export
a_freq_combos_j <- function(
  df,
  labelstr = NULL,
  .var = NA,
  val = NULL,
  # arguments specific to a_freq_combos_j
  combosdf = NULL,
  do_not_filter = NULL,
  filter_var = NULL,
  flag_var = NULL,
  # arguments specific to a_freq_combos_j till here
  .df_row,
  .spl_context,
  .N_col,
  id = "USUBJID",
  denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
  label = NULL,
  label_fstr = NULL,
  label_map = NULL,
  .alt_df_full = NULL,
  denom_by = NULL,
  .stats = "count_unique_denom_fraction",
  .formats = NULL,
  .labels_n = NULL,
  .indent_mods = NULL,
  na_str = rep("NA", 3)
) {
  denom <- match.arg(denom)

  check_alt_df_full(denom, "n_altdf", .alt_df_full)

  if (!is.null(combosdf) && !all(c("valname", "label") %in% names(combosdf))) {
    stop("a_freq_combos_j: combosdf must have variables valname and label.")
  }

  res_dataprep <- h_a_freq_dataprep(
    df = df,
    labelstr = labelstr,
    .var = .var,
    val = val,
    drop_levels = FALSE,
    excl_levels = NULL,
    new_levels = NULL,
    new_levels_after = FALSE,
    .df_row = .df_row,
    .spl_context = .spl_context,
    .N_col = .N_col,
    id = id,
    denom = denom,
    variables = NULL,
    label = label,
    label_fstr = label_fstr,
    label_map = label_map,
    .alt_df_full = .alt_df_full,
    denom_by = denom_by,
    .stats = .stats
  )
  # res_dataprep is list with elements
  # df .df_row val
  # drop_levels excl_levels
  # alt_df parentdf new_denomdf
  # .stats
  # make these elements available in current environment
  df <- res_dataprep$df
  .df_row <- res_dataprep$.df_row
  val <- res_dataprep$val
  drop_levels <- res_dataprep$drop_levels
  excl_levels <- res_dataprep$excl_levels
  alt_df <- res_dataprep$alt_df
  parentdf <- res_dataprep$parentdf
  new_denomdf <- res_dataprep$new_denomdf
  .stats <- res_dataprep$.stats

  ## colid can be used to figure out if we're in the combo column or not
  colid <- .spl_context$cur_col_id[[1]]

  ### this is the core code for subsetting to appropriate combo level
  df <- h_subset_combo(
    df = df,
    combosdf = combosdf,
    do_not_filter = do_not_filter,
    filter_var = filter_var,
    flag_var = flag_var,
    colid = colid
  )

  ## the same s-function can be used as in a_freq_j
  x_stats <- s_freq_j(
    df,
    .var = .var,
    .df_row = .df_row,
    val = val,
    alt_df = new_denomdf,
    parent_df = new_denomdf,
    id = id,
    denom = denom,
    .N_col = .N_col,
    countsource = "df"
  )

  .stats_adj <- .stats

  res_prepinrows <- h_a_freq_prepinrows(
    x_stats,
    .stats_adj,
    .formats,
    labelstr,
    label_fstr,
    label,
    .indent_mods,
    .labels_n,
    na_str
  )
  # res_prepinrows is list with elements
  # x_stats .formats .labels .indent_mods .format_na_strs
  # make these elements available in current environment
  x_stats <- res_prepinrows$x_stats
  .formats <- res_prepinrows$.formats
  .labels <- res_prepinrows$.labels
  .indent_mods <- res_prepinrows$.indent_mods
  .format_na_strs <- res_prepinrows$.format_na_strs

  ### final step: turn requested stats into rtables rows
  in_rows(
    .list = x_stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .format_na_strs = .format_na_strs
  )
}

#' Assert a Response Contingency Table
#'
#' Checks that a response table contains finite, non-negative integer-like counts
#' in a 2 by 2 table, optionally with a third dimension for strata.
#'
#' @param tbl (`array`)\cr A 2 by 2 response table, or a 2 by 2 by strata array,
#'   containing finite, non-negative integer-like counts without missing values.
#' @param stratified (`flag`)\cr Whether `tbl` must have a third dimension for strata.
#'
#' @return Invisibly returns `NULL`.
#' @keywords internal
#' @noRd
assert_response_table <- function(tbl, stratified = FALSE) {
  checkmate::assert_flag(stratified)
  d <- if (stratified) 3L else 2L
  checkmate::assert_array(tbl, mode = "integerish", d = d)
  checkmate::assert_true(identical(dim(tbl)[1:2], c(2L, 2L)))
  checkmate::assert_numeric(tbl, lower = 0, finite = TRUE, any.missing = FALSE)
  invisible(NULL)
}

#' Extract the left-hand side of a formula
#'
#' @param x (`formula`)\cr A two-sided formula, e.g., `y ~ x1 + x2`.
#'
#' @return (`character(1)`) The name of the left-hand side of the formula.
#'
#' @examples
#' leftside(y ~ x)
#'
#' @export
leftside <- function(x) {
  checkmate::assert_formula(x)
  res <- x[[2L]]
  res <- as.character(res)
  checkmate::assert_string(res)
  res
}

#' Extract the right-hand side of a formula
#'
#' @param x (`formula`)\cr A two-sided formula, e.g., `y ~ x1 + x2`.
#'
#' @return (`character(1)`) The right-hand side of the formula.
#'
#' @examples
#' rightside(y ~ x1 + x2)
#'
#' @export
rightside <- function(x) {
  checkmate::assert_formula(x)
  res <- x[[3L]]
  if (is.character(res) && length(res) == 1L) {
    res <- as.character(res)
  } else {
    res <- paste(deparse(res), collapse = "")
  }
  checkmate::assert_string(res)
  res
}

#' Custom unlist function
#'
#' Unlist a list, but retain `NULL` as `'NULL'` or `NA`.
#'
#' @keywords internal
.unlist_keep_nulls <- function(lst, null_placeholder = "NULL", recursive = FALSE) {
  lapply(lst, function(x) if (is.null(x)) null_placeholder else x) |>
    unlist(recursive = recursive)
}

#' @title Title Case Conversion
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Convert strings to title case (first letter of each word capitalized),
#' with the option to keep specified words, such as conjunctions, lowercase.
#'
#' @param x (`character` or `factor`)\cr
#'   Input string.
#' @param lowercase_words (`character` or `NULL`)\cr
#'   Words that should remain lowercase when converting to title case.
#'   Matching is case-insensitive. Specified words are only converted to
#'   lowercase when they are not the first word in the string. The first word is
#'   always capitalized, even if it is included in `lowercase_words`.
#' @return `x` converted to title case, with words specified in
#'   `lowercase_words` kept lowercase.
#'
#' @export
#'
#' @examples
#' x <- c("THIS IS an eXaMple", "statement TO CAPItaliZe")
#' string_to_title(x)
#' string_to_title(x, c("is", "an", "to"))
#'
#' x <- factor(
#'   c("OPTIMAL DOSE", "UNDERDOSE"),
#'   levels = c("OPTIMAL DOSE", "UNDERDOSE", "OVERDOSE")
#' )
#' string_to_title(x)
#'
string_to_title <- function(x, lowercase_words = NULL) {
  checkmate::assert(
    checkmate::check_character(x, null.ok = TRUE),
    checkmate::check_factor(x, null.ok = TRUE)
  )
  checkmate::assert_character(lowercase_words, min.chars = 1L, any.missing = FALSE, null.ok = TRUE)

  if (is.null(x)) {
    return(character())
  }

  # Step 1. Apply initial title case (capitalize the first letter of every word).
  y <- if (is.factor(x)) {
    levels(x)
  } else {
    x
  }

  pattern <- "(^|\\s)(\\w)"
  replacement <- "\\1\\U\\2"
  y <- gsub(pattern, replacement, tolower(y), perl = TRUE)

  # Step 2. Apply lowercase exceptions for specified words.
  if (!is.null(lowercase_words)) {
    # Match specified words only when preceded by whitespace that follows
    # a non-whitespace character, ensuring the first word is excluded.
    pattern_lw <- paste0(
      "(?<=\\S)(\\s+)(",
      paste(lowercase_words, collapse = "|"),
      ")(?=\\s|$)"
    )

    # Preserve the preceding whitespace and convert the word to lowercase.
    replacement_lw <- "\\1\\L\\2"

    y <- gsub(pattern_lw, replacement_lw, y, ignore.case = TRUE, perl = TRUE)
  }

  ret <- if (is.factor(x)) {
    levels(x) <- y
    x
  } else {
    y
  }

  ret
}

#' Check If `.alt_df_full` Is `NULL`
#'
#' For example, in `a_patyrs_j()`, if `source` is `"alt_df"`, we need to
#' check if `.alt_df_full` is `NULL`.
#'
#' @noRd
check_alt_df_full <- function(argument, values, .alt_df_full) {
  if (!argument %in% values || !is.null(.alt_df_full)) {
    return(invisible())
  }

  name <- deparse(substitute(argument))

  stop(sprintf(
    '`.alt_df_full` cannot be `NULL` when `%s` is `"%s"`',
    name,
    argument
  ))
}

#' @title Extract Vectors for Two-Sample Analysis
#'
#' @noRd
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Extract (aligned) vectors from two data frames for two-sample statistical
#' analysis using complete-case (non-missing) observations.
#'
#' For unpaired data, values are extracted directly from each dataset with
#' missing values (`NA`) removed independently.
#'
#' For paired data, observations are first matched using the key variable(s)
#' specified in `paired_by`, and only complete pairs are retained.
#'
#' The function validates that `paired_by` uniquely identifies rows in each
#' dataset (after removing rows with incomplete values in `paired_by` columns)
#' and raises an error if duplicates are detected.
#'
#' @details
#' The function performs the following steps depending on the `paired` flag:
#'
#' \strong{Unpaired case (`paired = FALSE`):}
#' \enumerate{
#'   \item Extract `.var` from each dataset.
#'   \item Remove `NA` values independently from each vector.
#' }
#'
#' \strong{Paired case (`paired = TRUE`):}
#' \enumerate{
#'   \item Check that `paired_by` uniquely identifies rows in each dataset,
#'     considering only rows that are complete cases for the `paired_by` columns.
#'
#'   \item Merge `df1` and `df2` by the columns specified in `paired_by`.
#'   The merged data contains only the `paired_by` columns and the `.var` column
#'   from each dataset.
#'
#'   \item Remove rows containing any missing values (`NA`) in the merged data.
#'
#'   \item Extract aligned vectors corresponding to `.var`.
#' }
#'
#' This function is intended for internal use in two-sample statistical
#' procedures such as paired and unpaired t-tests.
#'
#' @param df1 (`data.frame`)\cr First dataset.
#' @param df2 (`data.frame`)\cr Second dataset.
#' @param .var (`character(1)`)\cr Name of the variable to extract from both
#'   datasets.
#' @param paired (`logical(1)`)\cr Whether the values in `df1[[.var]]` and
#'   `df2[[.var]]` should be treated as paired (matched) samples.
#' @param paired_by (`character`)\cr Column name(s) used to match observations
#'   between `df1` and `df2`. Required only if `paired = TRUE`.
#'
#' @return
#' A named `list` with:
#' \describe{
#'   \item{x1}{Non-missing values from `df1[[.var]]` after optional pairing.}
#'   \item{x2}{Non-missing values from `df2[[.var]]` after optional pairing.}
#' }
#'
#' Returned vectors may be shorter than the original inputs due to removal of
#' unmatched observations, missing values (`NA`).
#'
#' @author WW
#'
#' @keywords internal
#'
#' @importFrom stats complete.cases
#'
#' @examples
#' df1 <- data.frame(id = c("A", "B", "C", "D"), value = 1:4)
#' df2 <- data.frame(id = c("A", "C", "D", "E", "F"), value = c(11, 13:14, NA, 16))
#' df1
#' df2
#'
#' # Unpaired
#' extract_vectors(df1, df2, "value")
#'
#' # Paired
#' extract_vectors(df1, df2, "value", paired = TRUE, paired_by = "id")
#'
extract_vectors <- function(df1, df2, .var, paired = FALSE, paired_by) {
  checkmate::assert_data_frame(df1)
  checkmate::assert_data_frame(df2)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df1), must.include = .var)
  checkmate::assert_names(colnames(df2), must.include = .var)
  checkmate::assert_flag(paired)

  if (paired) {
    checkmate::assert_character(paired_by)
    checkmate::assert_names(colnames(df1), must.include = paired_by)
    checkmate::assert_names(colnames(df2), must.include = paired_by)

    df1_keys <- df1[complete.cases(df1[, paired_by]), paired_by]
    df2_keys <- df2[complete.cases(df2[, paired_by]), paired_by]

    if (any(duplicated(df1_keys))) {
      stop("Duplicate values in 'paired_by' columns in df1 (complete cases only).")
    }

    if (any(duplicated(df2_keys))) {
      stop("Duplicate values in 'paired_by' columns in df2 (complete cases only).")
    }

    suffixes <- c("_df1", "_df2")

    df <- merge(
      df1[, c(paired_by, .var), drop = FALSE],
      df2[, c(paired_by, .var), drop = FALSE],
      by = paired_by,
      suffixes = suffixes
    )
    df <- df[complete.cases(df), , drop = FALSE]

    varsfx <- paste0(.var, suffixes)
    x1 <- df[[varsfx[1]]]
    x2 <- df[[varsfx[2]]]
  } else {
    x1 <- df1[[.var]]
    x2 <- df2[[.var]]

    x1 <- x1[!is.na(x1)]
    x2 <- x2[!is.na(x2)]
  }

  list(x1 = x1, x2 = x2)
}


#' Helper for Finding AVISIT after which CHG are all Missing
#'
#' @description
#' Helper for Finding AVISIT after which CHG are all Missing.
#'
#' @param df (`data.frame`)\cr with `CHG` and `AVISIT` variables.
#'
#' @return A string with either the factor level after which `AVISIT` is all missing,
#'   or `NA`.
#' @export
#'
#' @examples
#' df <- data.frame(
#'   AVISIT = factor(c(1, 2, 3, 4, 5)),
#'   CHG = c(5, NA, NA, NA, 3)
#' )
#' find_missing_chg_after_avisit(df)
#'
#' df2 <- data.frame(
#'   AVISIT = factor(c(1, 2, 3, 4, 5)),
#'   CHG = c(5, NA, 3, NA, NA)
#' )
#' find_missing_chg_after_avisit(df2)
#'
#' df3 <- data.frame(
#'   AVISIT = factor(c(1, 2, 3, 4, 5)),
#'   CHG = c(NA, NA, NA, NA, NA)
#' )
#' find_missing_chg_after_avisit(df3)
find_missing_chg_after_avisit <- function(df) {
  checkmate::assert_data_frame(df)
  checkmate::assert_factor(df$AVISIT, unique = TRUE, any.missing = FALSE)
  checkmate::assert_numeric(df$CHG)

  # Ensure the dataframe is sorted by AVISIT
  df <- df[order(df$AVISIT), ]

  # Last visit with available data.
  visit_levels_available <- as.integer(df[!is.na(df$CHG), ]$AVISIT)

  if (!length(visit_levels_available)) {
    return(levels(df$AVISIT)[1])
  }
  visit_levels_max_available <- max(visit_levels_available)

  # Visits with missing data.
  visit_levels_missing <- as.integer(df[is.na(df$CHG), ]$AVISIT)

  # Missing visits at the end.
  visit_levels_missing_end <- visit_levels_missing[
    visit_levels_missing > visit_levels_max_available
  ]

  # Return first one if there is any.
  if (length(visit_levels_missing_end)) {
    levels(df$AVISIT)[min(visit_levels_missing_end)]
  } else {
    NA_character_
  }
}


#'
#' @description
#' Helper for transposing a named list of named lists, where inner lists have same names
#'
#' @param x (`list`)\cr with depth of 2.
#'
#' @return Transposed version of list where inner elements now are outer elements.
#' @noRd
#' @keywords internal
transpose_named_list <- function(x) {
  # x: named list of named lists
  keys <- unique(lapply(x, names))
  if (length(keys) != 1) {
    stop("Input list must have same names on all sublists")
  } else {
    keys <- keys[[1]]
  }
  # rebuild structure
  setNames(
    lapply(keys, function(k) {
      setNames(
        lapply(x, function(inner_list) {
          inner_list[[k]]
        }),
        names(x)
      )
    }),
    keys
  )
}

#' @title Copy missing attributes to an object
#'
#' @noRd
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Copies attributes from `source` to `target` that are not already present
#' on `target`. Existing attributes of `target` are preserved.
#'
#' @param source An object providing the attributes to copy.
#' @param target An object to which missing attributes are copied.
#'
#' @return The `target` object with any missing attributes copied from `source`.
#'
#' @author WW
#' @keywords internal
#' @seealso [factor_by_order()]
#'
#' @examples
#'
#' x <- factor(c("Placebo", "Placebo", "Drug X"))
#'
#' x_labeled <- formatters::with_label(x, label = "Treatment Group")
#' attributes(x_labeled)
#'
#' # Copy the `label` attribute from `x_labeled` to `x`.
#' x_copy <- copy_attributes(x_labeled, x)
#' attributes(x_copy)
#'
copy_attributes <- function(source, target) {
  source_attr <- attributes(source)
  if (is.null(source_attr)) {
    return(target)
  }

  target_attr <- attributes(target)

  to_copy <- setdiff(names(source_attr), names(target_attr))
  attributes(target) <- c(target_attr, source_attr[to_copy])
  target
}

#' @title Check whether two vectors define a one-to-one correspondence
#'
#' @noRd
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tests whether `x` and `y` define a bijection between their unique non-missing
#' values.
#'
#' Missing values are treated specially: if `match_na = FALSE`, any missing
#' values will trigger an error. If `match_na = TRUE`, an `NA` in `x`
#' must correspond to an `NA` in `y` at the same position; otherwise, an error
#' is thrown.
#'
#' @note Factors are not supported because they may contain unused levels that
#'   do not appear in the observed data. For such levels, the corresponding
#'   values in the other vector are not available, and therefore a bijection
#'   cannot be determined.
#'
#' @param x (`character` or `numeric`)\cr A vector defining one side of the
#'   mapping.
#' @param y (`character` or `numeric`)\cr A vector defining the other side of
#'   the mapping. Must have the same length as `x`.
#' @param match_na (`logical(1)`)\cr Whether to permit missing values (`NA`)
#'   if they appear at identical positions in both vectors.
#'   If `FALSE` (the default), any presence of missing values triggers an error.
#'
#' @return A single logical value indicating whether `x` and `y` define a
#'   bijection.
#'
#' @seealso [factor_by_order()]
#' @keywords internal
#' @author WW
#'
#' @examples
#' is_bijection(c("A", "A", "B"), c(1, 1, 2))
#'
#' is_bijection(c("A", "B"), c(1, 1))
#'
#' is_bijection(c("A", NA), c(1, NA))
#'
#' is_bijection(c("A", NA), c(1, 2))
is_bijection <- function(x, y, match_na = FALSE) {
  checkmate::assert(
    checkmate::test_character(x) || checkmate::test_numeric(x)
  )
  checkmate::assert(
    checkmate::test_character(y, len = length(x)) ||
      checkmate::test_numeric(y, len = length(x))
  )
  checkmate::assert_flag(match_na)

  # NA validation.
  na_x <- is.na(x)
  na_y <- is.na(y)
  if (any(na_x != na_y)) {
    stop("NAs are present in 'x' and 'y', but not at identical positions.")
  }
  # At this point, na_x and na_y are component-wise equal;
  # therefore, any(na_x | na_y) is equivalent to any(na_x).
  if (!match_na && any(na_x)) {
    stop("NAs are present in 'x' and 'y', but 'match_na' is set to FALSE.")
  }

  # Check bijection.
  n_unique_x <- length(unique(x))
  n_unique_y <- length(unique(y))

  bijection <- if (n_unique_x != n_unique_y) {
    FALSE
  } else {
    x_first_positions <- match(x, x)
    all(y == y[x_first_positions], na.rm = TRUE)
  }

  bijection
}

#' @title Create a factor with levels ordered by a separate ordering vector
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Converts a character vector or factor into a factor where the level order is
#' determined by a second integer-like vector containing the corresponding order
#' values.
#'
#' @details The values in `x` and `y` must define a bijection between the unique
#'   non-missing values: each unique value in `x` must correspond to exactly one
#'   unique value in `y`, and vice versa.
#'   Missing values are handled separately: `NA` values in `x` and `y` must
#'   occur at the same positions. Missing values are not included as factor
#'   levels.
#'
#'   If `x` is already a factor containing unobserved (unused) levels, these
#'   unobserved levels will be dropped in the resulting factor.
#'
#' @param x (`character` or `factor`)\cr A vector to be converted to a factor.
#' @param y (`integerish`)\cr A vector defining the order of levels in `x`.
#'   Must have the same length as `x`.
#' @param ordered (`logical(1)`)\cr Indicates whether the result should be
#'   an ordered factor. Defaults to `FALSE`.
#'
#' @return A factor created from `x`, with levels ordered according to `y`.
#'   Attributes of `x` other than `class` and `levels` are preserved.
#'   If `ordered = TRUE`, an ordered factor is returned.
#'   If `x` is empty or consists entirely of missing values, a factor with
#'   no levels is returned.
#'
#' @author WW
#'
#' @export
#' @examples
#' factor_by_order(c("A", "A", "B"), c(1, 1, 2))
#'
#' factor_by_order(c("A", "A", "B"), c(1, 1, 2), ordered = TRUE)
#'
#' factor_by_order(c("A", "A", "B"), c(2, 2, 1))
#'
#' factor_by_order(c("A", "A", "B", NA), c(1, 1, 2, NA))
#'
#' \dontrun{
#' factor_by_order(c("A", "A", "B", NA), c(1, 2, 2, 4))
#' }
#'
factor_by_order <- function(x, y, ordered = FALSE) {
  checkmate::assert_multi_class(x, classes = c("character", "factor"))
  checkmate::assert_integerish(y, len = length(x))
  checkmate::assert_flag(ordered)

  x_char <- as.character(x)

  if (!is_bijection(x_char, y, match_na = TRUE)) {
    stop("`x` and `y` must define a bijection between their unique non-NA values; NA values must correspond.")
  }

  factor_levels <- unique(x_char[order(y)])
  factor_levels <- factor_levels[!is.na(factor_levels)]
  f <- factor(x_char, levels = factor_levels, ordered = ordered)

  # Preserve non-factor attributes of `x`.
  copy_attributes(source = x, target = f)
}

#' @title Strictly Match a Value in a Character Vector
#'
#' @description
#' Finds a unique match of a value in either the odd or even positions of a
#' character vector. An error is raised if no match or more than one match is
#' found in the selected positions.
#'
#' @param x (`character(1)`)\cr
#'   The value to match.
#' @param y (`character`)\cr
#'   The character vector in which to search for `x`.
#' @param odd (`flag`)\cr
#'   Whether to restrict the match to odd positions. Defaults to `TRUE`.
#'   If `FALSE`, only even positions are considered.
#'
#' @return An integer containing the unique position of `x` in `y`.
#'
#' @keywords internal
#' @author WW
#'
#' @examples
#' \dontrun{
#' strict_match("A", c("A", "Placebo"))
#'
#' strict_match("SEX", c("SomeVar", "SomeVal", "SEX", "Male"))
#'
#' strict_match("ARM", c("SEX", "Male"))
#' strict_match("Male", c("SEX", "Male"))
#' strict_match("ARM", c("ARM", "Placebo", "ARM", "Active"))
#' }
#'
strict_match <- function(x, y, odd = TRUE) {
  checkmate::assert_string(x)
  checkmate::assert_character(y, any.missing = FALSE)
  checkmate::assert_flag(odd)

  pos <- which(x == y)

  # odd = TRUE -> use 1L -> keep odd positions
  # odd = FALSE -> use 0L -> keep even positions
  pos <- if (odd) {
    pos[pos %% 2L != 0L]
  } else {
    pos[pos %% 2L == 0L]
  }

  if (length(pos) == 0L) {
    stop(paste0(
      "Value ('",
      x,
      "') not found in the ",
      ifelse(odd, "odd", "even"),
      " positions of ('",
      paste(y, collapse = "."),
      "')."
    ))
  }

  if (length(pos) > 1L) {
    stop(paste0(
      "Value ('",
      x,
      "') must be unique in the ",
      ifelse(odd, "odd", "even"),
      " positions of ('",
      paste(y, collapse = "."),
      "')."
    ))
  }

  pos
}

#' Safe Conversion to Logical Vector
#'
#' @param x (`vector`)\cr The input vector to be safely converted to a logical vector.
#' @param na.rm (`flag`)\cr Whether to remove missing values after conversion.
#'
#' @return
#' A logical vector corresponding to the input `x`. If the conversion introduces
#' unexpected `NA` values, an error is raised.
#'
#' @keywords internal
safe_as_logical <- function(x, na.rm = FALSE) {
  checkmate::assert_vector(x, strict = TRUE)
  checkmate::assert_flag(na.rm)
  result <- as.logical(x)
  if (anyNA(result) && !identical(is.na(x), is.na(result))) {
    stop("Conversion to logical introduced unexpected NAs.")
  }
  if (anyNA(result)) {
    if (na.rm) {
      result <- result[!is.na(result)]
    } else {
      stop("Missing values detected in response and `na.rm = FALSE`.", call. = FALSE)
    }
  }
  result
}

#' Analysis Function for Response Variables
#'
#' This function calculates counts and percentages for response variables (Y/N values),
#' with optional risk difference calculations.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param .var (`string`)\cr variable name that is passed by `rtables`.
#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
#' @param .N_col (`integer`)\cr column-wise N (column count) for the full column being analyzed.
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param resp_var (`string`)\cr response variable name containing Y/N values.
#' @param id (`string`)\cr subject variable name.
#' @param drop_levels (`logical`)\cr if TRUE, non-observed levels will not be included.
#' @param riskdiff (`logical`)\cr if TRUE, risk difference calculations will be performed.
#' @param ref_path (`string`)\cr column path specifications for the control group.
#' @param variables (`list`)\cr variables to include in the analysis.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param method (`character`)\cr method for calculating confidence intervals.
#' @param weights_method (`character`)\cr method for calculating weights.
#' @param .formats (`character` or NULL)\cr formats to apply to the statistics. If NULL, default formats will be used.
#' @param na_str (`character`)\cr string to use for NA values. Defaults to `rep("NA", 3)`.
#' @param legacy (`logical(1)`)\cr To allow for backward compatibility default of used format.
#' @return Formatted analysis function which is used as `afun` in `analyze_vars()`
#' and as `cfun` in `summarize_row_groups()`.
#'
#' @export
#'
#' @examples
#' library(dplyr)
#' ADSL <- ex_adsl |> select(USUBJID, ARM, SEX)
#'
#' ADAE <- ex_adae |> select(USUBJID, ARM, SEX, AEBODSYS, AEDECOD)
#'
#' ADAE <- ADAE |>
#'   mutate(TRTEMFL = "Y")
#'
#' lyt <- basic_table(show_colcounts = TRUE) |>
#'   split_cols_by("ARM") |>
#'   analyze("SEX",
#'     show_labels = "visible",
#'     afun = a_freq_resp_var_j,
#'     extra_args = list(resp_var = "TRTEMFL", riskdiff = FALSE)
#'   )
#'
#' result <- build_table(lyt, df = ADAE, alt_counts_df = ADSL)
#'
#' result
a_freq_resp_var_j <- function(
  df,
  .var,
  .df_row,
  .N_col,
  .spl_context,
  resp_var = NULL,
  id = "USUBJID",
  drop_levels = FALSE,
  riskdiff = TRUE,
  ref_path = NULL,
  variables = list(strata = NULL),
  conf_level = formals(s_proportion_diff)$conf_level,
  method = c(
    "wald",
    "waldcc",
    "cmh",
    "ha",
    "newcombe",
    "newcombecc",
    "strat_newcombe",
    "strat_newcombecc",
    "cmh_sato",
    "cmh_mn",
    "uncond_exact_diff"
  ),
  weights_method = formals(s_proportion_diff)$weights_method,
  .formats = NULL,
  na_str = rep("NA", 3),
  legacy = FALSE
) {
  # ---- Derive statistics: xx / xx (xx.x%)

  if (is.null(resp_var)) {
    stop(
      "afun a_freq_resp_var_j: resp_var cannot be NULL."
    )
  }

  resp_var_values <- unique(df[[resp_var]][!is.na(df[[resp_var]])])
  if (
    is.character(df[[resp_var]]) &&
      any(is.na(df[[resp_var]])) &&
      all(resp_var_values == "Y")
  ) {
    stop(
      paste0(
        "afun a_freq_resp_var_j: it is not clear if missing resp_var should be considered non-response. ",
        "Please make it a factor with appropriate Y(/N) levels."
      )
    )
  }

  if (length(setdiff(resp_var_values, c("Y", "N"))) > 0) {
    stop("afun a_freq_resp_var_j: resp_var must contain only Y/N values.")
  }

  if (is.character(df[[resp_var]])) {
    df[[resp_var]] <- factor(df[[resp_var]], levels = c("Y", "N"))
  }

  df <- df[!is.na(df[[.var]]), ]

  # nolint start
  if ((is.factor(df[[resp_var]]) &&
    (identical(levels(df[[resp_var]]), c("Y", "N")) || identical(levels(df[[resp_var]]), c("N", "Y")))) ||
    is.character(df[[resp_var]])
  ) { # nolint end
    # missing values in resp_var should be excluded, not considered as not met response
    # subject will then not contribute to denominator
    df <- df[!is.na(df[[resp_var]]), ]
    .df_row <- .df_row[!is.na(.df_row[[resp_var]]), ]
  }

  if (drop_levels) {
    obs_levs <- unique(.df_row[[.var]])
    obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)

    val_var <- obs_levs
    # restrict the levels to the ones specified in val_var
    df <- df[df[[.var]] %in% val_var, ]
    .df_row <- .df_row[.df_row[[.var]] %in% val_var, ]

    df <- h_update_factor(df, .var, val_var)
  }

  varvec <- df[[.var]]

  levs <- if (is.factor(varvec)) levels(varvec) else sort(unique(varvec))

  colid <- .spl_context$cur_col_id[[1]]
  inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)

  if (riskdiff) {
    trt_var <- ref_path[length(ref_path) - 1L]
    ctrl_grp <- ref_path[length(ref_path)]
    cur_trt_grp <- h_get_cur_trt_grp(trt_var, .spl_context)
  }

  fn <- function(levii) {
    dfii <- df[df[[.var]] == levii, ]
    dfrowii <- .df_row[.df_row[[.var]] == levii, ]

    if (!inriskdiffcol) {
      # use the core s_freq_j function on the current level of the incoming variable (.var)
      # note that the response variable will become .var in the below call
      # val is restricted to Y to show number of response on the current level of .var
      rslt <- s_freq_j(
        dfii,
        .df_row = dfrowii,
        .var = resp_var,
        alt_df = NULL,
        parent_df = NULL,
        val = "Y",
        denom = "n_df"
      )

      .stat <- "count_unique_denom_fraction"
      x_stat <- rslt[[.stat]]$Y
      # use .formats if provided, otherwise default to jjcsformat_count_denom_fraction
      if (!legacy) {
        fmt <- if (is.null(.formats)) jjcsformat_count_denom_fraction else .formats
      } else {
        fmt <- if (is.null(.formats)) jjcsformat_count_denom_fraction_legacy else .formats
      }

      rslt <- rcell(x_stat, format = fmt)
    } else {
      # use the risk difference function s_risk_diff_val_j on the current level of the incoming variable (.var)
      # note that the response variable will become .var in the below call
      # val is restricted to Y to show number of response on the current level of .var
      denom_df <- dfrowii
      # for combined facet, denom_df value for the treatment group needs update
      denom_df <- upd_denom_df_combo(
        denom_df,
        trt_var,
        cur_trt_grp,
        .spl_context
      )

      rslt <- s_risk_diff_val_j(
        df = dfii,
        .var = resp_var,
        .df_row = dfrowii,
        val = "Y",
        denom_df = denom_df,
        id = id,
        riskdiff = riskdiff,
        # treatment/ref group related arguments
        trt_var = trt_var,
        ctrl_grp = ctrl_grp,
        cur_trt_grp = cur_trt_grp,
        # relrisk specific arguments
        variables = variables,
        conf_level = conf_level,
        method = method,
        weights_method = weights_method
      )
      x_stat <- rslt[["rr_ci_3d"]]$Y
      # use .formats if provided, otherwise default to rr format
      fmt <- if (is.null(.formats)) jjcsformat_xx("xx.x (xx.x, xx.x)") else .formats
      rslt <- rcell(
        x_stat,
        format = fmt,
        format_na_str = na_str
      )
    }

    # rslt is a single rcell row
    return(rslt)
  }

  ### apply function fn to all levels of incoming .var
  ### cls is a list of single rcell rows - ie one line per level is presented
  cls <- lapply(levs, fn)

  names(cls) <- levs
  return(cls)
}

.find_titles_file <- function(path = ".") {
  if (file.exists(file.path(path, "titles.csv"))) {
    file.path(path, "titles.csv")
  } else if (file.exists(file.path(path, "titles.xlsx"))) {
    file.path(path, "titles.xlsx")
  } else {
    stop(
      "No titles.csv/xlsx file detected at path ", path,
      "please specify parent directory, full file path, or ",
      "pass the full titles data.frame directly."
    )
  }
}

#' @importFrom utils read.csv
.read_titles_file <- function(file) {
  if (grepl("csv$", file, ignore.case = TRUE)) {
    df <- read.csv(file, check.names = FALSE)
  } else if (grepl("xlsx$", file, ignore.case = TRUE)) {
    if (!requireNamespace("readxl")) {
      stop("readxl package is required for xslx file support, please install it.")
    }
    df <- readxl::read_excel(path = file, sheet = 1, range = readxl::cell_cols("A:C"))
  } else {
    stop("Unrecognized titles file type. file: ", file)
  }
  df
}

# ----
#' @name  get_titles_from_file
#' @title Get Titles/Footers For Table From Sources
#'
#' @description Retrieves the titles and footnotes for a given table from a CSV/XLSX file or a data.frame.
#'
#' @details Retrieves the titles for a given output id (see below) and outputs
#'          a list containing the title and footnote objects supported by
#'          rtables. Both titles.csv and titles.xlsx (*if `readxl` is
#'          installed*) files are supported, with titles.csv being checked
#'          first.
#'
#'          Data is expected to have `TABLE ID`, `IDENTIFIER`, and `TEXT` columns,
#'          where `IDENTIFIER` has the value `TITLE` for a title and `FOOT*` for
#'          footer materials where `*` is a positive integer. `TEXT` contains
#'          the value of the title/footer to be applied.
#'
#' @param file (`character(1)`)\cr A path to CSV or xlsx file containing title
#'   and footer information for one or more outputs. See Details. Ignored if
#'   `title_df` is specified.
#' @param input_path (`character(1)`)\cr A path to look for
#'   titles.csv/titles.xlsx. Ignored if `file` or `title_df` is specified.
#' @param title_df (`data.frame`)\cr A data.frame containing titles and footers for
#'   one or more  outputs. See Details.
#' @param id (`character(1)`)\cr The identifier for the table of interest.
#'
#' @export
#' @returns  List object containing: title, subtitles, main_footer, prov_footer
#'           for the table of interest.  Note: the subtitles and prov_footer are
#'           currently set to NULL. Suitable for use with [`set_titles()`].
# ----
get_titles_from_file <- function(id,
                                 file = .find_titles_file(input_path),
                                 input_path = ".",
                                 title_df = .read_titles_file(file)) {
  ## "TABLE ID" gets munged to "TABLE.ID"
  title_df <- title_df[title_df[["TABLE ID"]] == id, , drop = FALSE]

  message(paste0("Static titles file/data.frame used: "))

  msg <- NULL

  if (nrow(title_df) == 0) {
    msg <- paste0(
      paste("Warning: Table ID", id, "not found in Title file."),
      "\n",
      "A dummy title will be generated to be able to get rtf file produced.",
      "\n",
      "Ensure the titles file gets updated to include the table identifier"
    )

    title <- "Table ID not found in titles file, dummy title for rtf generation purpose"
    main_footer <- "Ensure the titles file gets updated to include the table identifier"
  } else {
    title <- title_df[title_df$IDENTIFIER == "TITLE", ]$TEXT

    if (length(title) != 1) {
      msg <- "Warning: Title file should contain exactly one title record per Table ID"
    } else {
      message(file)
    }

    main_footer <- title_df[grep("^FOOT", title_df$IDENTIFIER), ]$TEXT

    if (length(main_footer) == 0) {
      main_footer <- character()
    }
  }

  if (!is.null(msg)) {
    warning(msg)
  }

  # ---- Return titles and footnotes.

  title_foot <- list(
    title = title,
    subtitles = NULL,
    main_footer = main_footer,
    prov_footer = NULL
  )

  return(title_foot)
}

# ----
#' @name  set_titles
#' @title Set Output Titles
#'
#' @description Retrieves titles and footnotes from the list specified in the titles
#'              argument and appends them to the TableTree specified in the obj argument.
#'
#'
#' @param obj (`TableTree`)\cr The TableTree to which the titles and footnotes will be appended.
#' @param titles (`list`)\cr The list object containing the titles and footnotes to be appended.
#' @export
#'
#' @returns  The TableTree object specified in the obj argument, with titles
#'           and footnotes appended.
# ----
set_titles <- function(obj, titles) {
  ## add title and footers
  main_title(obj) <- titles$title
  if (!is.null(titles$subtitles)) {
    subtitles(obj) <- titles$subtitles
  }
  main_footer(obj) <- titles$main_footer
  if (!is.null(titles$prov_footer)) {
    prov_footer(obj) <- titles$prov_footer
  }

  return(obj)
}

#' rm_other_facets_fact
#' @param nm character. names of facets to keep. all other facets will be
#' removed
#' @returns a function suitable for use within the `post` portion make_split_fun
rm_other_facets_fact <- function(nm) {
  function(ret, spl, .spl_context, fulldf) {
    keep <- which(names(ret$values) %in% nm)
    stopifnot(length(keep) > 0)
    # values already have subsetting expressions on them
    make_split_result(ret$values[keep], ret$datasplit[keep], ret$labels[keep])
  }
}

#' @name real_add_overall_facet
#'
#' @title Add Overall Facet
#'
#' @description
#' A function to help add an overall facet to your tables.
#'
#' @param name (`character`)\cr Name/virtual 'value' for the new facet.
#' @param label (`character`)\cr Label for the new facet.
#'
#' @note Current add_overall_facet is bugged. Can be used directly after it's fixed
#' https://github.com/pharmaverse/rtables/issues/768
#' @examples
#' splfun <- make_split_fun(post = list(real_add_overall_facet("Total", "Total")))
#'
#' @export
#' @returns Function usable directly as a split function.
real_add_overall_facet <- function(name, label) {
  function(ret, spl, .spl_context, fulldf) {
    add_to_split_result(
      ret,
      values = name,
      datasplit = stats::setNames(list(fulldf), name),
      labels = stats::setNames(label, name),
      subset_exprs = quote(TRUE)
    )
  }
}

#' @name make_combo_splitfun
#'
#' @title Split Function Helper
#'
#' @description
#' A function which aids the construction for users to create their own split function for combined columns.
#' @param nm (`character`)\cr Name/virtual 'value' for the new facet.
#' @param label (`character`)\cr Label for the new facet.
#' @param levels (`character` or NULL)\cr The levels to combine into the new facet,
#' or NULL, indicating the facet should include all incoming data.
#' @param rm_other_facets (`logical`)\cr Should facets other than the newly
#' created one be removed. Defaults to `TRUE`.
#' @export
#' @returns Function usable directly as a split function.
#' @examples
#' aesevall_spf <- make_combo_splitfun(nm = "AESEV_ALL", label = "Any AE", levels = NULL)
make_combo_splitfun <- function(nm, label = nm, levels = NULL, rm_other_facets = TRUE) {
  if (is.null(levels)) {
    fn <- real_add_overall_facet(name = nm, label = label)
  } else {
    fn <- add_combo_facet(name = nm, label = label, levels = levels)
  }
  if (rm_other_facets) {
    rmfun <- rm_other_facets_fact(nm)
  } else {
    rmfun <- NULL
  }
  make_split_fun(post = c(list(fn), if (rm_other_facets) list(rmfun)))
}

blank_regex <- "^[[:space:]]*$"

combine_nonblank <- function(name, label) {
  function(ret, spl, .spl_context, fulldf) {
    df <- fulldf[!grepl(blank_regex, fulldf[[spl_variable(spl)]]), ]
    add_to_split_result(
      ret,
      values = name,
      datasplit = stats::setNames(list(df), name),
      labels = stats::setNames(label, name)
    )
  }
}

rm_blank_levels <- function(df, spl, ...) {
  var <- spl_variable(spl)
  varvec <- df[[var]]
  oldlevs <- levels(varvec)
  newlevs <- oldlevs[!grepl(blank_regex, oldlevs)]
  df <- df[!grepl(blank_regex, varvec), ]
  df[[var]] <- factor(df[[var]], levels = newlevs)
  df
}

find_torm <- function(spl_ret, torm, torm_regex, keep_matches) {
  if (!is.null(torm)) {
    ans_lgl <- names(spl_ret$datasplit) %in% torm
  } else {
    ans_lgl <- grepl(torm_regex, names(spl_ret$datasplit))
  }
  if (keep_matches) {
    ans_lgl <- !ans_lgl
  }
  which(ans_lgl)
}

.check_rem_cond <- function(cond_str, cond_regex, spl_ctx, pos, type) {
  if (is.null(cond_str) && is.null(cond_regex)) {
    return(TRUE)
  }
  if (!is.null(cond_str) && !is.null(cond_regex)) {
    stop(
      "Got both ",
      paste(paste0(type, c("", "_regex")), collapse = " and "),
      ". Please specify at most one of these."
    )
  }
  ctx_data <- spl_ctx[[type]][pos]
  if (!is.null(cond_str)) {
    any(cond_str %in% ctx_data)
  } else {
    any(grepl(cond_regex, ctx_data))
  }
}

## handle support for NA and negative positions only called once but code is nicer with it factored out here
resolve_ancestor_pos <- function(anc_pos, numrows) {
  if (is.na(anc_pos)) {
    anc_pos <- seq_len(numrows)
  } else if (any(anc_pos < 0)) {
    if (!all(anc_pos < 0)) {
      stop("Got mix of negative and non-negative values for ancestor_pos; ", "this is not supported.")
    }
    ## direct parent is actually NROW(.spl_context) so avoid off-by-1 error with the + 1 here
    anc_pos <- numrows - (anc_pos + 1)
  }
  anc_pos
}

#' @name cond_rm_facets
#' @title Conditional Removal of Facets
#'
#' @param facets (`character` or NULL)\cr Vector of facet names to be removed
#' if condition(s) are met
#' @param facets_regex (`character`)\cr Regular expression to identify facet
#' names to be removed if condition(s) are met.
#' @param ancestor_pos (`numeric`)\cr Row in spl_context to check the condition
#' within. E.g., 1 represents the first split, 2 represents the second split
#' nested within the first, etc. NA specifies that the conditions
#' should be checked at all split levels. Negative integers indicate position
#' counting back from the current one, e.g., -1 indicates the direct parent
#' (most recent split before this one). Negative and positive/NA positions
#' cannot be mixed.
#' @param split (`character` or NULL)\cr If specified, name of the split
#' at position `ancestor_pos` must be identical to this value for
#' the removal condition to be met.
#' @param split_regex (`character` or NULL)\cr If specified, a regular expression
#' the name of the split at position `ancestor_pos` must match for
#' the removal condition to be met. Cannot be specified at the same time
#' as `split`.
#' @param value (`character` or NULL)\cr If specified, split (facet) value
#' at position `ancestor_pos` must be identical to this value for
#' removal condition to be met.
#' @param value_regex (`character` or NULL)\cr If specified, a regular expression
#' the value of the split at position `ancestor_pos` must match for
#' the removal condition to be met. Cannot be specified at the same time
#' as `value`.
#' @param keep_matches (`logical`)\cr Given the specified condition is met,
#' should the facets removed be those matching `facets`/`facets_regex`
#' (`FALSE`, the default), or those *not* matching (`TRUE`).
#'
#' @details Facet removal occurs when the specified condition(s)
#' on the split(s) and or value(s) are met within at least one
#' of the split_context rows indicated by `ancestor_pos`; otherwise
#' the set of facets is returned unchanged.
#'
#' If facet removal is performed, either *all* facets which match `facets` (or
#' `facets_regex` will be removed ( the default `keep_matches == FALSE`
#'  case), or all *non-matching* facets will be removed (when
#'   `keep_matches_only == TRUE`).
#'
#' @note A degenerate table is likely to be returned if all facets
#' are removed.
#'
#' @returns A function suitable for use in `make_split_fun`'s
#' `post` argument which encodes the specified condition.
#' @export
#' @examples
#'
#' rm_a_from_placebo <- cond_rm_facets(
#'   facets = "A",
#'   ancestor_pos = NA,
#'   value_regex = "Placeb",
#'   split = "ARM"
#' )
#' mysplit <- make_split_fun(post = list(rm_a_from_placebo))
#'
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_cols_by("STRATA1", split_fun = mysplit) |>
#'   analyze("AGE", mean, format = "xx.x")
#' build_table(lyt, ex_adsl)
#'
#' rm_bc_from_combo <- cond_rm_facets(
#'   facets = c("B", "C"),
#'   ancestor_pos = -1,
#'   value_regex = "Combi"
#' )
#' mysplit2 <- make_split_fun(post = list(rm_bc_from_combo))
#'
#' lyt2 <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_cols_by("STRATA1", split_fun = mysplit2) |>
#'   analyze("AGE", mean, format = "xx.x")
#' tbl2 <- build_table(lyt2, ex_adsl)
#' tbl2
#'
#' rm_bc_from_combo2 <- cond_rm_facets(
#'   facets_regex = "^A$",
#'   ancestor_pos = -1,
#'   value_regex = "Combi",
#'   keep_matches = TRUE
#' )
#' mysplit3 <- make_split_fun(post = list(rm_bc_from_combo2))
#'
#' lyt3 <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_cols_by("STRATA1", split_fun = mysplit3) |>
#'   analyze("AGE", mean, format = "xx.x")
#' tbl3 <- build_table(lyt3, ex_adsl)
#'
#' stopifnot(identical(cell_values(tbl2), cell_values(tbl3)))
cond_rm_facets <- function(
  facets = NULL,
  facets_regex = NULL,
  ancestor_pos = 1,
  split = NULL,
  split_regex = NULL,
  value = NULL,
  value_regex = NULL,
  keep_matches = FALSE
) {
  ## detect errors/miscalling which don't even require us to have the facets
  if (is.null(split) && is.null(split_regex) && is.null(value) && is.null(value_regex)) {
    stop(
      "Must specify condition in terms of at least one of ",
      "split name (split or split_regex) or ",
      "facet value (value or value_regex)."
    )
  }
  if (is.null(facets) && is.null(facets_regex)) {
    stop("Must specify facets either facets or facets_regex, got neither.")
  } else if (!is.null(facets) && !is.null(facets_regex)) {
    stop("Got both facets and facets_regex, this is not supported, please specify only one.")
  }
  function(ret, spl, .spl_context, fulldf) {
    torm_ind <- c()
    ancestor_pos <- resolve_ancestor_pos(ancestor_pos, NROW(.spl_context))
    torm_ind <- find_torm(ret, facets, facets_regex, keep_matches = keep_matches)
    fct_abbrev <- ifelse(is.null(facets_regex), paste(facets, collapse = ", "), facets_regex)
    split_match <- .check_rem_cond(
      split, split_regex, .spl_context, ancestor_pos, type = "split"
    )
    value_match <- .check_rem_cond(
      value, value_regex, .spl_context, ancestor_pos, type = "value"
    )
    if (split_match && value_match) {
      no_rm_msg <- paste0(
        "No facets matched removal criteria [", fct_abbrev, "] ",
        "in function created with cond_rm_facets.\n",
        "Occured at path: ",
        rtables::spl_context_to_disp_path(.spl_context)
      )

      all_rm_msg <- paste0(
        "All facets matched removal criteria [",
        fct_abbrev, "] in function created with cond_rm_facets. ",
        "This will result in a degenerate table (if the condition ",
        "is met) within row splitting and in table-creation failing ",
        "entirely in column splitting.\n",
        "Occured at path: ",
        rtables::spl_context_to_disp_path(.spl_context)
      )
      no_rm_case <- (length(torm_ind) == 0 && !keep_matches) ||
        (length(torm_ind) == length(ret$datasplit) && keep_matches)
      all_rm_case <- (length(torm_ind) == 0 && keep_matches) ||
        (length(torm_ind) == length(ret$datasplit) && !keep_matches)

      if (no_rm_case) {
        warning(no_rm_msg, call. = FALSE)
      } else if (all_rm_case) {
        warning(all_rm_msg, call. = FALSE)
      }
      ## find_torm handles the keep matching case, so
      ## by this point torm_ind is always the ones to remove
      ret <- lapply(ret, function(part) part[-torm_ind])
    }

    ret
  }
}


#' @name rm_levels
#'
#' @title Removal of Levels
#'
#' @description
#' Custom function for removing level inside pre step in make_split_fun.
#'
#' @param excl (`character`)\cr Choose which level(s) to remove
#' @return A function implementing pre-processing split behavior (for use in
#'   `make_split_fun(pre = )` which removes the levels in `excl` from the data
#'   before facets are generated.
#' @export
rm_levels <- function(excl) {
  function(df, spl, ...) {
    var <- spl_variable(spl)
    varvec <- df[[var]]
    oldlevs <- levels(varvec)

    exclevs <- oldlevs %in% excl
    newlevs <- oldlevs[!exclevs]
    df[[var]] <- factor(df[[var]], levels = newlevs)
    df
  }
}

#' Shortcut for Creating Custom Column Splits
#'
#' This is a shortcut for a common use of [rtables::make_split_result()] where you need to create
#' custom column splits with different labels but using the same full dataset for each column.
#' It automatically sets up the values, datasplit (using the same full dataset for each column),
#' and subset_exprs (using TRUE for all subsets) parameters for make_split_result().
#'
#' @param ... sequence of named labels for the columns.
#' @param fulldf (`data.frame`)\cr The `fulldf` which will be used for each column.
#' @return The result from [rtables::make_split_result()].
#'
#' @keywords internal
short_split_result <- function(..., fulldf) {
  labels <- c(...)
  values <- stats::setNames(names(labels), names(labels))
  datasplit <- stats::setNames(replicate(n = length(labels), list(fulldf)), names(labels))
  subset_exprs <- replicate(n = length(labels), list(expression(TRUE)))
  make_split_result(values = values, labels = labels, datasplit = datasplit, subset_exprs = subset_exprs)
}

#' Predicate to Check if Split Should be Excluded
#'
#' @inheritParams proposal_argument_convention
#' @returns `TRUE` if the current split context matches any of the exclude levels,
#'   `FALSE` otherwise.
#'
#' @export
#' @examples
#'
#' do_exclude_split(
#'   exclude_levels = list(AVISIT = "Baseline"),
#'   .spl_context = data.frame(
#'     split = c("AVISIT", "ARM"),
#'     value = c("Week 4", "Placebo")
#'   )
#' )
#' do_exclude_split(
#'   exclude_levels = list(AVISIT = "Baseline"),
#'   .spl_context = data.frame(
#'     split = c("AVISIT", "ARM"),
#'     value = c("Baseline", "Placebo")
#'   )
#' )
do_exclude_split <- function(exclude_levels, .spl_context) {
  checkmate::assert_list(exclude_levels, names = "unique")
  checkmate::assert_data_frame(.spl_context)

  split_vals <- .spl_context[, c("split", "value")]
  split_vals_list <- as.list(split_vals$value) |>
    stats::setNames(split_vals$split)
  found_splits <- intersect(names(split_vals_list), names(exclude_levels))
  for (split_var in found_splits) {
    if (any(split_vals_list[[split_var]] %in% exclude_levels[[split_var]])) {
      return(TRUE)
    }
  }
  FALSE
}




insert_subset_exprs <- function(partinfo, spl, comp_path = NULL) {
  rvs <- rawvalues(partinfo$values)
  names(rvs) <- names(partinfo$values)
  exprs <- lapply(rvs, function(rvi) make_subset_expr(spl, rvi))
  newvals <- mapply(function(val, expr) {
    exvals <- rtables::splv_extra(val)
    if (!is.null(rtables::value_expr(val))) {
      return(val)
    }
    val@subset_expression <- expr
    val
  },
  val = partinfo$values,
  expr = exprs,
  SIMPLIFY = FALSE)
  names(newvals) <- names(partinfo$values)

  names(exprs) <- names(rvs)
  make_split_result(
    ## names(partinfo$values), ## AllLevelsSentinel is not playing nice here but should be handled by expr
    newvals,
    partinfo$datasplit,
    partinfo$labels
  )
}

#' @name summary_subset
#'
#' @title Wrappers Around `tern::a_summary()` with Optional Subsetting and Labels
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These wrappers around [tern::a_summary()] allow optional row subsetting
#' using a logical expression evaluated in the context of the input data frame.
#'
#' `a_summary_subset()` is an [rtables] analysis function (see
#' [rtables::analyze()]), while `c_summary_subset_label()` is a content row
#' function (see [rtables::summarize_row_groups()]) that may optionally
#' append a label to the resulting content row.
#'
#' @details
#' [tern::a_summary()] is a formatted analysis function that computes summary
#' statistics for a single variable. In typical use within the [rtables]
#' framework, the analysis variable is first extracted from a data frame and
#' then passed to [tern::a_summary()] as a standalone vector.
#'
#' The `a_summary_subset()` and `c_summary_subset_label()` wrappers extend
#' this behavior by:
#' - accepting a data frame (`df`) as input,
#' - optionally subsetting rows using a logical expression,
#' - extracting the analysis variable `.var` after subsetting,
#' - and passing the resulting vector to [tern::a_summary()].
#'
#' @inheritParams proposal_argument_convention
#' @param filter_expr (`expression`)
#'   A single logical expression wrapped in `expression(...)` used to subset
#'   rows of `df` before summarization. Exactly one expression is allowed.
#'   The expression is evaluated using [eval()] in an environment containing
#'   the columns of `df`, meaning that all column names are available as
#'   variables.
#'
#'   In the current implementation, variables used in the expression can only
#'   be column names of `df`. That is, the following is not supported:
#'   `min_age <- 45;`
#'   `a_summary_subset(df, "AVAL", expression(AGE > min_age))`,
#'   given that `AVAL` is a column in `df` and `min_age` is not a column in `df`.
#'
#'   The expression must evaluate to a logical vector whose length is exactly
#'   equal to `nrow(df)`. No recycling is performed.
#'   In particular, scalar logical values such as `expression(TRUE)` or
#'   `expression(FALSE)` are not allowed when `nrow(df) > 1`.
#' @param ... Additional arguments passed to [tern::a_summary()], excluding
#'   the `x` argument, which is constructed internally from `df[[.var]]`
#'   after applying the filter.
#'
#' @return
#' Returns the same type of object as [tern::a_summary()].
#'
#' @author WW
#'
#' @seealso
#' [tern::a_summary()]
#'
NULL

#' @describeIn summary_subset Analysis function with optional subsetting.
#' @importFrom tern a_summary
#' @importFrom assertthat is.string
#' @export
#' @examples
#'
#' ## Analysis function:
#'
#' df <- data.frame(
#'   ID = 1:8,
#'   AGE = c(34, NA, 52, 45, 50, NA, 41, 29),
#'   AVAL = c(1.2, 3, -1.5, 0.8, 3.5, 2, -1.1, 0.3)
#' )
#' df
#'
#' stats <- c("n", "sum")
#'
#' tern::a_summary(df$AVAL, .stats = stats)
#'
#' a_summary_subset(df, "AVAL", expression(!is.na(AGE)), .stats = stats)
#' a_summary_subset(df, "AVAL", expression(AGE > 30 & AVAL > 0), .stats = stats)
#'
a_summary_subset <- function(df, .var, filter_expr, ...) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df), must.include = .var)
  checkmate::assert_class(filter_expr, "expression")
  checkmate::assert_true(length(filter_expr) == 1)

  row_mask <- eval(filter_expr[[1]], envir = df)
  checkmate::assert_logical(row_mask, len = nrow(df))
  x <- df[row_mask, .var, drop = TRUE]

  dots <- list(...)
  dots$x <- x
  if (".formats" %in% names(dots) && identical(dots[[".formats"]], "default")) {
    if ("formats_var" %in% names(dots) && assertthat::is.string(dots[["formats_var"]])) {
      xfmt <- dots[["formats_var"]]
      checkmate::assert_names(colnames(df), must.include = xfmt)
      .formats <- unique(df[[xfmt]])[[1]]
      dots$.formats <- .formats
      dots$formats_var <- NULL
    }
  }

  do.call(tern::a_summary, dots)
}

#' @describeIn summary_subset Content row function with optional subsetting
#' and an optional label prepended to the resulting content row using
#' [prepend_label_cell()].
#'
#' @inheritParams prepend_label_cell
#'
#' @export
#' @examples
#'
#' ## Content row function:
#'
#' df <- data.frame(
#'   USUBJID = rep(1:6, each = 2),
#'   AVISIT = rep(c("Baseline", "Day 1"), 6),
#'   AVAL = c(1, 3, 2, 9, 13, 19, 15, 23, 43, 56, 24, 32),
#'   ABLFL = rep(c(TRUE, FALSE), 6),
#'   BASE = rep(c(1, 2, 13, 15, 43, 24), each = 2),
#'   CHG = c(0, 2, 0, 7, 0, 6, 0, 8, 0, 13, 0, 8)
#' )
#' df
#'
#' c_summary_subset_label(
#'   df = df,
#'   .var = "BASE",
#'   filter_expr = expression(ABLFL),
#'   label = "Baseline",
#'   .stats = c("n", "mean_sd")
#' )
c_summary_subset_label <- function(df,
                                   labelstr,
                                   .var,
                                   filter_expr,
                                   label = "",
                                   label_indent_mod = 0L,
                                   ...) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df), must.include = .var)
  checkmate::assert_class(filter_expr, "expression")
  checkmate::assert_true(length(filter_expr) == 1)
  checkmate::assert_string(label, na.ok = TRUE)
  checkmate::assert_int(label_indent_mod)

  y <- a_summary_subset(df = df, .var = .var, filter_expr = filter_expr, ...)
  prepend_label_cell(y, label = label, label_indent_mod = label_indent_mod)
}

#' Analysis and Content Summary Function Producing Blank Line
#'
#' @inheritParams proposal_argument_convention
#'
#' @export
ac_blank_line <- function(df, labelstr = "") {
  in_rows(.list = NA_real_, .labels = labelstr, .formats = "xx", .format_na_strs = "")
}

#' Insertion of Blank Lines in a Layout
#'
#' @inheritParams proposal_argument_convention
#'
#' @description This is a hack for `rtables` in order to be able to add row gaps,
#' i.e. blank lines.
#' In particular, by default this function needs to maintain a global state for avoiding
#' duplicate table names. The global state variable is hidden by using
#' a dot in front of its name. However, this likely won't work with parallelisation across
#' multiple threads and also causes non-reproducibility of the resulting `rtables`
#' object. Therefore also a custom table name can be used.
#'
#' @return The modified layout now including a blank line after the current
#'   row content.
#' @export
#'
#' @examples
#' ADSL <- ex_adsl
#'
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_rows_by("STRATA1") |>
#'   analyze(vars = "AGE", afun = function(x) {
#'     in_rows(
#'       "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)")
#'     )
#'   }) |>
#'   insert_blank_line() |>
#'   analyze(vars = "AGE", table_names = "AGE_Range", afun = function(x) {
#'     in_rows(
#'       "Range" = rcell(range(x), format = "xx.xx - xx.xx")
#'     )
#'   })
#' build_table(lyt, ADSL)
insert_blank_line <- function(lyt, table_names = NULL) {
  varnames_rows <- vars_in_layout(lyt@row_layout)
  checkmate::assert_character(varnames_rows, min.len = 1L)
  last_varname_rows <- utils::tail(varnames_rows, 1L)

  this_table_name <- if (is.null(table_names)) {
    default_table_name <- paste0(".post_", last_varname_rows, "_blank")

    # A named list for tracking table names and counts
    table_count <- getOption("junco.insert_blank_line")

    new_count <- if (default_table_name %in% names(table_count)) {
      table_count[[default_table_name]] + 1
    } else {
      1
    }

    table_count[[default_table_name]] <- new_count
    options(junco.insert_blank_line = table_count)

    paste(default_table_name, new_count, sep = "_")
  } else {
    checkmate::assert_string(table_names, min.chars = 1L)
    table_names
  }

  analyze(
    lyt,
    vars = last_varname_rows,
    afun = ac_blank_line,
    show_labels = "hidden",
    table_names = this_table_name
  )
}

add_blank_line_rcells <- function(ret) {
  # check that ret is expected structure and not NULL
  if (is.null(ret)) {
    stop("add_blank_line_rcells: ret cannot be NULL.")
  }
  if (!(inherits(ret, "RowsVerticalSection") || inherits(ret, "CellValue"))) {
    stop("add_blank_line_rcells:  ret must be of class RowsVerticalSection or CellValue.")
  }

  if (inherits(ret, "RowsVerticalSection")) {
    xlabel <- attr(ret, "row_labels")
    indent_mods <- lapply(ret, function(obj) {
      attr(obj, "indent_mod")
    })
    ret <- unclass(ret) # avoid error from new c.RowsVerticalSection
  } else {
    xlabel <- attr(ret, "label")
    indent_mods <- attr(ret, "indent_mod")
  }

  fmts <- lapply(ret, obj_format)
  na_strs <- lapply(ret, obj_na_str)
  # ret <- append(ret,rcell(NA_real_,format = 'xx')) use a character version for the new line, rather than NA - to
  # allow NA processing for other stuff
  ret <- c(ret, in_rows(rcell(NA, format = "xx"), .labels = " ", .formats = "xx", .format_na_strs = " "))
  fmts <- append(fmts, "xx")
  na_strs <- append(na_strs, " ")
  indent_mods <- append(indent_mods, 0L)
  xlabel <- append(xlabel, " ")
  ret <- stats::setNames(ret, xlabel)

  # perform the update to add the extra line
  fret <- in_rows(
    .list = ret,
    .labels = xlabel,
    .formats = fmts,
    .format_na_strs = na_strs,
    .indent_mods = indent_mods
  )

  fret
}

#' @title Prepend a Label Row to a RowsVerticalSection Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Prepends a label row to a `RowsVerticalSection` object.
#'
#' `RowsVerticalSection` objects are returned by analysis functions used within
#' the **rtables** framework and are typically created with
#' [rtables::in_rows()].
#'
#' This function is typically used to introduce section headers
#' (e.g., "Descriptive Statistics") in tabular reports and other reporting
#' outputs.
#'
#' @note The `row_na_strs` and `row_footnotes` attributes of the
#'   `RowsVerticalSection` object are not preserved.
#'   Since an additional row is added, be aware of recycling rules; that is,
#'   the length of all attributes of `x` should be equal to `length(x)`.
#'
#' @param x (`RowsVerticalSection`)\cr Analysis result object.
#' @param label (`character(1)`)\cr Label to insert as the first row.
#' @param label_indent_mod (`integer(1)`)\cr Indentation modifier applied to
#'   the label row.
#'
#' @returns A `RowsVerticalSection` object with a label row prepended.
#'
#' @importFrom rtables rcell in_rows
#'
#' @export
#'
#' @examples
#' rvs <- rtables::in_rows(
#'   Mean = rtables::rcell(5),
#'   Range = rtables::rcell(c(1, 8))
#' )
#'
#' prepend_label_cell(
#'   rvs,
#'   "Descriptive Statistics",
#'   label_indent_mod = 1L
#' )
#'
prepend_label_cell <- function(x, label = "", label_indent_mod = 0L) {
  checkmate::assert_class(x, "RowsVerticalSection")
  checkmate::assert_string(label, na.ok = TRUE)
  checkmate::assert_int(label_indent_mod)
  checkmate::assert_true(
    !("__label" %in% c(names(x), attr(x, "row_names")))
  )

  label_rcell <- rcell(NULL, label = label, indent_mod = label_indent_mod)
  ret <- rtables::in_rows(
    .list = c(list("__label" = label_rcell), x)
  )

  # row_names
  x_rn <- attr(x, "row_names")
  if (!is.null(x_rn)) {
    label_rn <- if (!is.null(names(x_rn))) {
      c("__label" = "__label")
    } else {
      "__label"
    }
    attr(ret, "row_names") <- c(label_rn, x_rn)
  }

  # row_labels
  x_rl <- attr(x, "row_labels")
  if (!is.null(x_rl)) {
    label_rl <- if (!is.null(names(x_rl))) {
      c("__label" = label)
    } else {
      label
    }
    attr(ret, "row_labels") <- c(label_rl, x_rl)
  }

  # row_formats
  x_rf <- attr(x, "row_formats")
  if (length(x_rf) >= 2 || !is.null(x_rf[[1]])) {
    attr(ret, "row_formats") <- c("__label" = list(NULL), x_rf)
  }

  # indent_mods
  x_im <- attr(x, "indent_mods")
  if (!is.null(x_im)) {
    label_im <- if (!is.null(names(x_im))) {
      c("__label" = label_indent_mod)
    } else {
      label_indent_mod
    }
    attr(ret, "indent_mods") <- c(label_im, x_im)
  }

  ret
}

#' @keywords internal
memoised_fit_mmrm <- memoise::memoise(fit_mmrm_j)

#' Helper Function to Fit the MMRM and Return LS Mean Estimates and Contrasts
#'
#' @inheritParams proposal_argument_convention
#' @param df_parent (`data.frame`)\cr data set containing all analysis variables
#'   from all visits and arms.
#' @param ref_arm_level (`string`)\cr the reference arm which should be compared
#'   against.
#' @param ref_visit_levels (`character`)\cr the reference visits which should not
#'   be included in the model fit.
#' @param ... additional options passed to [fit_mmrm_j()].
#'
#' @return The resulting estimates and contrasts LS means as returned by
#'   [tidy.tern_model()].
#' @keywords internal
h_summarize_mmrm <- function(.var, df_parent, variables, ref_arm_level, ref_visit_levels, ...) {
  checkmate::assert_string(.var)
  variables$response <- .var

  checkmate::assert_string(ref_arm_level)
  arm_levels <- levels(df_parent[[variables$arm]])
  if (arm_levels[1L] != ref_arm_level) {
    checkmate::assert_subset(ref_arm_level, arm_levels[-1L])
    df_parent[[variables$arm]] <- stats::relevel(df_parent[[variables$arm]], ref = ref_arm_level)
  }
  checkmate::assert_character(ref_visit_levels)
  in_ref_visits <- df_parent[[variables$visit]] %in% ref_visit_levels
  df_parent <- df_parent[!in_ref_visits, , drop = FALSE]
  checkmate::assert_true(nrow(df_parent) > 1)
  new_levels <- setdiff(levels(df_parent[[variables$visit]]), ref_visit_levels)
  df_parent[[variables$visit]] <- factor(df_parent[[variables$visit]], levels = new_levels)
  mod_fit <- memoised_fit_mmrm(vars = variables, data = df_parent, ...)
  tidy(mod_fit)
}

#' Dynamic tabulation of MMRM results with tables
#'
#' @description `r lifecycle::badge('stable')`
#'
#' These functions can be used to produce tables for MMRM results, within
#' tables which are split by arms and visits. This is helpful when higher-level
#' row splits are needed (e.g. splits by parameter or subgroup).
#'
#' @name summarize_mmrm
#' @examples
#' set.seed(123)
#' longdat <- data.frame(
#'   ID = rep(DM$ID, 5),
#'   AVAL = c(
#'     rep(0, nrow(DM)),
#'     rnorm(n = nrow(DM) * 4)
#'   ),
#'   VISIT = factor(rep(paste0("V", 0:4), each = nrow(DM)))
#' ) |>
#'   dplyr::inner_join(DM, by = "ID")
#'
NULL

#' @describeIn summarize_mmrm Statistics function which is extracting estimates,
#'   not including any results when in the reference visit, and only showing LS mean
#'   estimates when in the reference arm and not in reference visit. It uses
#'   [s_lsmeans()] for the final processing.
#'
#' @inheritParams proposal_argument_convention
#' @param ref_levels (`list`)\cr with `visit` and `arm` reference levels.
#' @param ... eventually passed to [fit_mmrm_j()] via [h_summarize_mmrm()].
#' @export
s_summarize_mmrm <- function(
  df,
  .var,
  variables,
  ref_levels,
  .spl_context,
  alternative = c("two.sided", "less", "greater"),
  show_relative = c("reduction", "increase"),
  ...) {
  alternative <- match.arg(alternative)

  checkmate::assert_list(variables, names = "unique")
  visit_var <- variables$visit
  arm_var <- variables$arm

  checkmate::assert_list(ref_levels, names = "unique")
  checkmate::assert_subset(c(visit_var, arm_var), names(ref_levels))
  ref_visits <- ref_levels[[visit_var]]
  ref_arm <- ref_levels[[arm_var]]
  checkmate::assert_string(ref_arm)

  current_visit <- as.character(unique(df[[visit_var]]))
  current_arm <- as.character(unique(df[[arm_var]]))
  checkmate::assert_string(current_visit)
  checkmate::assert_string(current_arm)

  in_ref_visits <- current_visit %in% ref_visits
  in_ref_arm <- current_arm == ref_arm

  if (in_ref_visits) {
    ## this is returned
    list(
      n = NULL,
      adj_mean_se = NULL,
      adj_mean_ci = NULL,
      adj_mean_est_ci = NULL,
      diff_mean_se = NULL,
      diff_mean_ci = NULL,
      diff_mean_est_ci = NULL,
      change = NULL,
      p_value = NULL
    )
  } else { # non ref visit
    n_splits <- nrow(.spl_context)

    # Check that the current row split is by the visit variable.
    current_split_var <- .spl_context[n_splits, "split"]
    checkmate::assert_true(identical(current_split_var, visit_var))

    # Then take the data frame with all visits and fit the MMRM on it.
    df_parent <- .spl_context[n_splits - 1, "full_parent_df"][[1]]
    lsm_df <- h_summarize_mmrm(
      .var = .var,
      df_parent = df_parent,
      variables = variables,
      ref_arm_level = ref_arm,
      ref_visit_levels = ref_visits,
      ...
    )

    # Subset to the current table cell we are looking at.
    matches_visit <- lsm_df[[visit_var]] == current_visit
    matches_arm <- lsm_df[[arm_var]] == current_arm
    matches_both <- which(matches_visit & matches_arm)
    checkmate::assert_int(matches_both)

    s_lsmeans(
      lsm_df[matches_both, ],
      .in_ref_col = in_ref_arm,
      alternative = alternative,
      show_relative = show_relative
    )
  } # end ref visits if/else
}

#' @describeIn summarize_mmrm Formatted analysis function which is used as `afun`.
#'
#' @return
#' * `a_summarize_mmrm()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' basic_table() |>
#'   split_rows_by("VISIT") |>
#'   split_cols_by("ARM") |>
#'   analyze(
#'     vars = "AVAL",
#'     afun = a_summarize_mmrm,
#'     na_str = tern::default_na_str(),
#'     show_labels = "hidden",
#'     extra_args = list(
#'       variables = list(
#'         covariates = c("AGE"),
#'         id = "ID",
#'         arm = "ARM",
#'         visit = "VISIT"
#'       ),
#'       conf_level = 0.9,
#'       cor_struct = "toeplitz",
#'       ref_levels = list(VISIT = "V0", ARM = "B: Placebo")
#'     )
#'   ) |>
#'   build_table(longdat) |>
#'   prune_table(all_zero)
#' @export
a_summarize_mmrm <- function(
  df,
  .var,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_summarize_mmrm,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .var = .var, .spl_context = list(.spl_context), dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "summarize_mmrm",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' @describeIn summarize_mmrm Wrapper for the `afun` which can exclude
#'   row split levels from producing the analysis. These have to be specified in the
#'   `exclude_levels` argument, see `?do_exclude_split` for details.
#' @export
a_summarize_mmrm_with_exclude <- function(
  df,
  .var,
  exclude_levels,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  if (do_exclude_split(exclude_levels, .spl_context)) {
    NULL
  } else {
    a_summarize_mmrm(
      df = df,
      .var = .var,
      .spl_context = .spl_context,
      ...,
      .stats = .stats,
      .formats = .formats,
      .labels = .labels,
      .indent_mods = .indent_mods
    )
  }
}

#' @title s_function for proportion of factor levels
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format. The denominator here is from the alternative counts data set
#'   in the given row and column split.
#'
#'   If a total row is shown, then here just the total number is shown (without 100%).
#' @param x (`factor`)\cr categorical variable we want to analyze.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param use_alt_counts (`flag`)\cr whether the `.alt_df` should be used for the total, i.e. the denominator.
#'   If not, then the number of non-missing values in `x` is used.
#' @param show_total (`string`)\cr show the total level optionally on the top or in the bottom
#'   of the factor levels.
#' @param total_label (`string`)\cr which label to use for the optional total level.
#' @return The [rtables::in_rows()] result with the proportion statistics.
#' @seealso [s_proportion_logical()] for tabulating logical `x`.
#' @export
s_proportion_factor <- function(
  x,
  .alt_df,
  use_alt_counts = TRUE,
  show_total = c("none", "top", "bottom"),
  total_label = "Total"
) {
  checkmate::assert_factor(x)
  checkmate::assert_flag(use_alt_counts)
  show_total <- match.arg(show_total)

  N <- if (use_alt_counts) nrow(.alt_df) else sum(!is.na(x))
  tab <- lapply(as.list(table(x)), function(xi) rcell(xi * c(1, 1 / N), format = jjcsformat_count_fraction))
  if (show_total != "none") {
    checkmate::assert_string(total_label)
    tab_total <- stats::setNames(list(rcell(N, format = "xx")), total_label)

    tab <- if (show_total == "top") {
      c(tab_total, tab)
    } else {
      c(tab, tab_total)
    }
  }
  in_rows(.list = tab)
}

#' @title s_function for proportion of `TRUE` in logical vector
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format. The denominator here is from the alternative counts data set
#'   in the given row and column split.
#' @param x (`logical`)\cr binary variable we want to analyze.
#' @param label (`string`)\cr label to use.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @return The [rtables::in_rows()] result with the proportion statistics.
#' @seealso [s_proportion_factor()] for tabulating factor `x`.
#' @export
s_proportion_logical <- function(x, label = "Responders", .alt_df) {
  n <- sum(x)
  N <- nrow(.alt_df)
  p_hat <- n / N
  list(n_prop = with_label(rcell(c(n, p_hat), format = jjcsformat_count_fraction), label))
}

#' @title c_function for proportion of `TRUE` in logical vector
#' @description A simple statistics function which prepares the numbers with percentages
#'   in the required format, for use in a split content row. The denominator here is
#'   from the column N. Note that we don't use here .alt_df because that might not
#'   have required row split variables available.
#' @param x (`logical`)\cr binary variable we want to analyze.
#' @param labelstr (`string`)\cr label string.
#' @param labelstr (`string`)\cr label string.
#' @param label_fstr (`string`)\cr format string for the label.
#' @param format (`character` or `list`)\cr format for the statistics.
#' @param .N_col (`numeric`)\cr number of columns.
#' @param .N_col (`numeric`)\cr number of columns.
#' @return The [rtables::in_rows()] result with the proportion statistics.
#' @seealso [s_proportion_logical()] for the related statistics function.
#' @export
c_proportion_logical <- function(x, labelstr, label_fstr, format, .N_col) {
  checkmate::assert_logical(x)
  num <- sum(x)
  denom <- .N_col
  in_rows(est_prop = c(num, num / denom), .formats = format, .labels = sprintf(label_fstr, labelstr))
}

#' Helper Function to Create Logical Design Matrix from Factor Variable
#'
#' @description
#' Helper Function to Create Logical Design Matrix from Factor Variable.
#'
#' @param df (`data.frame`)\cr including a factor variable with name in `.var`.
#' @param .var (`string`)\cr name of the factor variable.
#'
#' @return The logical matrix with dummy encoding of all factor levels.
#' @keywords internal
#' @export
#' @examples
#' h_get_design_mat(df = data.frame(a = factor(c("a", "b", "a"))), .var = "a")
h_get_design_mat <- function(df, .var) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_factor(df[[.var]])

  model_formula <- stats::as.formula(paste("~ -1 +", .var))
  design_mat <- stats::model.matrix(model_formula, df)
  mode(design_mat) <- "logical"
  colnames(design_mat) <- levels(df[[.var]])
  design_mat
}

#' Formatted Analysis Function For Proportion Confidence Interval for Logical
#'
#' @description
#' Formatted Analysis Function For Proportion Confidence Interval for Logical.
#'
#' @param x (`logical`)\cr including binary response values.
#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
#' @param formats (`list`)\cr including element `prop_ci` with the
#'   required format. Note that the value is in percent already.
#' @param method (`string`)\cr please see [tern::s_proportion()] for possible
#'   methods.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#'
#' @return The [rtables::rcell()] result.
#' @export
#'
#' @examples
#' a_proportion_ci_logical(
#'   x = DM$SEX == "F",
#'   .alt_df = DM,
#'   conf_level = 0.95,
#'   formats = list(prop_ci = jjcsformat_xx("xx.xx% - xx.xx%")),
#'   method = "wald"
#' )
a_proportion_ci_logical <- function(x, .alt_df, conf_level, method, formats) {
  checkmate::assert_logical(x)
  checkmate::assert_data_frame(.alt_df)
  checkmate::assert_list(formats)

  diff_n <- nrow(.alt_df) - length(x)
  if (diff_n > 0) {
    x <- c(x, rep(FALSE, length = diff_n))
  }
  est <- s_proportion(x, conf_level = conf_level, method = method)
  rcell(est$prop_ci, format = formats$prop_ci)
}

#' Formatted Analysis Function For Proportion Confidence Interval for Factor
#'
#' @description
#' Formatted Analysis Function For Proportion Confidence Interval for Factor.
#'
#' @param df (`data.frame`)\cr including factor `.var`.
#' @param .var (`string`)\cr name of the factor variable.
#' @param .var (`string`)\cr name of the factor variable.
#' @param \dots see [a_proportion_ci_logical()] for additionally required
#'   arguments.
#'
#' @return The [rtables::rcell()] result.
#' @export
#'
#' @examples
#' a_proportion_ci_factor(
#'   df = DM,
#'   .var = "SEX",
#'   .alt_df = DM,
#'   conf_level = 0.95,
#'   formats = list(prop_ci = jjcsformat_xx("xx.x%, xx.x%")),
#'   method = "clopper-pearson"
#' )
a_proportion_ci_factor <- function(df, .var, ...) {
  checkmate::assert_factor(df[[.var]])

  design_mat <- h_get_design_mat(df, .var)
  design_df <- as.data.frame(design_mat)
  res <- lapply(design_df, a_proportion_ci_logical, ...)
  in_rows(.list = res, .labels = colnames(design_mat))
}

#' Split Function for Proportion Analysis Columns
#'
#' Here we just split into 3 columns `n`, `%` and `Cum %`.
#'
#' @param ret (`list`)\cr return value from the previous split function.
#' @param spl (`list`)\cr split information.
#' @param fulldf (`data.frame`)\cr full data frame.
#' @param .spl_context (`environment`)\cr split context environment.
#'
#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
#'   post-processing function.
prop_post_fun <- function(ret, spl, fulldf, .spl_context) {
  short_split_result(n = "n", percent = "%", cum_percent = "Cum %", fulldf = fulldf)
}

#' @rdname prop_post_fun
#'
#' @param df A data frame that contains all analysis variables.
#' @param vals A character vector that contains values to use for the split.
#' @param labels A character vector that contains labels for the statistics (without indent).
#' @param trim A single logical that indicates whether to trim the values.
#' @return a split function for use in [rtables::split_rows_by].
#' @export
prop_split_fun <- make_split_fun(post = list(prop_post_fun))

#' Formatted Analysis Function for Proportion Analysis
#'
#' This function applies to a factor `x` when a column split was prepared with
#' [prop_split_fun()] before.
#'
#' @details In the column named `n`, the counts of the categories as well as an
#' optional `Total` count will be shown. In the column named `percent`, the
#' percentages of the categories will be shown, with an optional blank entry for
#' `Total`. In the column named `cum_percent`, the cumulative percentages will
#' be shown instead.
#'
#' @param x (`factor`)\cr factor variable to analyze.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param formats (`list`)\cr formats for the statistics.
#' @param add_total_level (`flag`)\cr whether to add a total level.
#' @param x (`factor`)\cr factor variable to analyze.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param formats (`list`)\cr formats for the statistics.
#' @param add_total_level (`flag`)\cr whether to add a total level.
#'
#' @return A `VerticalRowsSection` as returned by [rtables::in_rows].
#' @export
prop_table_afun <- function(x, .spl_context, formats, add_total_level = FALSE) {
  checkmate::assert_list(formats, len = 3, names = "unique")
  checkmate::assert_names(names(formats), permutation.of = c("n", "percent", "cum_percent"))
  checkmate::assert_flag(add_total_level)

  stat <- utils::tail(.spl_context[nrow(.spl_context), "cur_col_split_val"][[1]], 1)
  optional_total <- function(x) if (add_total_level) x else NULL
  ns <- table(x)
  res <- if (stat == "n") {
    c(as.list(ns), optional_total(length(x)))
  } else if (stat == "percent") {
    c(as.list(ns / length(x) * 100), optional_total(list(NULL)))
  } else if (stat == "cum_percent") {
    c(as.list(cumsum(ns / length(x) * 100)), optional_total(list(NULL)))
  } else {
    stop("unexpected proportion statistic in split")
  }
  in_rows(.list = res, .labels = c(levels(x), optional_total("Total")), .formats = formats[[stat]])
}

#' @name diff_means
#'
#' @title Difference in Means
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Computes estimates and associated inferential statistics for the estimand
#' defined as the difference in population means between two distributions.
#'
#' The following quantities are available:
#' \describe{
#'   \item{diff_means_n1}{Sample size of Group 1.}
#'   \item{diff_means_n2}{Sample size of Group 2.}
#'   \item{diff_means_est}{Point estimate of the difference in population means.}
#'   \item{diff_means_se}{Standard error of the estimator of the difference in population means.}
#'   \item{diff_means_est_se}{The point estimate and the standard error.}
#'   \item{diff_means_ci}{Confidence interval for the difference in population means.}
#'   \item{diff_means_est_ci}{The point estimate and the confidence interval.}
#' }
#'
#' @details
#' Supports both non-paired and paired samples. For non-paired samples, the
#' estimator is defined as the difference between sample means. For paired
#' samples, the estimator is defined as the mean of within-pair differences.
#'
#' Inferential statistics, including standard errors and confidence intervals,
#' are obtained using a t-distribution framework via the internal
#' `safe_t_test()` function.
#'
#' It supports only numeric variables.
#' Only complete (non-missing) observations are used in statistical computations.
#' Non-finite values (i.e., `Inf`, `-Inf`) are not allowed.
#'
#' @inheritParams proposal_argument_convention
#' @param .var (`character(1)`)\cr Name of the column in the dataset(s)
#'   containing observed sample values.
#' @param ... Additional named arguments passed to `s_diff_means()` and
#'   `safe_t_test()`.
#'
#' @author WW
NULL

#' @describeIn diff_means Statistical function that computes estimates of the
#' difference in means.
#' The first sample is taken from `df1[[.var]]` and the second from
#' `df2[[.var]]`.
#'
#' If `paired = FALSE`, missing values are removed separately from each sample
#' prior to statistical computations.
#' If `paired = TRUE`, observations are matched using `paired_by` prior to
#' statistical analysis, and only complete pairs are used.
#'
#' Data extraction, alignment, and missing-value handling are delegated to the
#' internal `extract_vectors()` function, which prepares cleaned numeric
#' vectors for both paired and unpaired settings.
#'
#' Inferential statistics are then computed using `safe_t_test()` applied to
#' the processed vectors.
#'
#' @param df1 (`data.frame`)\cr Dataset for the first sample.
#' @param df2 (`data.frame`)\cr Dataset for the second sample.
#' @param paired (`logical(1)`)\cr Whether the samples are paired.
#' @param paired_by (`character` or `NULL`)\cr Column name(s) in `df1` and `df2`
#'   used to match observations between datasets.
#'   Required when `paired = TRUE` and must uniquely identify each pair in both
#'   datasets.
#'
#' @return
#' * `s_diff_means()` returns a named `list` containing the quantities described
#' in the Description section.
#'
#' @seealso `safe_t_test()`, `extract_vectors()`
#'
#' @importFrom tern f_conf_level
#' @importFrom formatters with_label
#'
#' @export
#'
#' @examples
#'
#' ## Statistics function:
#'
#' df1 <- data.frame(id = c("A", "B", "C", "D"), value = 1:4)
#' df2 <- data.frame(id = c("A", "C", "D", "E", "F"), value = c(3:1, NA, 16))
#'
#' # Unpaired samples.
#' s_diff_means(df1, df2, "value", conf.level = .8)
#'
#' # Paired samples.
#' s_diff_means(df1, df2, "value", paired = TRUE, paired_by = "id")
#'
s_diff_means <- function(df1,
                         df2,
                         .var,
                         paired = FALSE,
                         paired_by = NULL,
                         ...) {
  checkmate::assert_data_frame(df1)
  checkmate::assert_data_frame(df2)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df1), must.include = .var)
  checkmate::assert_names(colnames(df2), must.include = .var)
  checkmate::assert_numeric(df1[[.var]], finite = TRUE)
  checkmate::assert_numeric(df2[[.var]], finite = TRUE)
  checkmate::assert_flag(paired, null.ok = FALSE)
  if (paired) {
    checkmate::assert_character(paired_by)
    checkmate::assert_names(colnames(df1), must.include = paired_by)
    checkmate::assert_names(colnames(df2), must.include = paired_by)
  }

  vecs <- extract_vectors(df1, df2, .var, paired = paired, paired_by = paired_by)
  n1 <- length(vecs$x1)
  n2 <- length(vecs$x2)

  # Get estimates.
  ttest_res <- safe_t_test(vecs$x1, vecs$x2, paired = paired, ...)
  est <- if (paired) {
    ttest_res$estimate
  } else {
    ttest_res$estimate[1] - ttest_res$estimate[2]
  }
  ci <- ttest_res$conf.int
  se <- ttest_res$stderr
  conf.level <- attr(ci, "conf.level")

  names(n1) <- "diff_means_n1"
  names(n2) <- "diff_means_n2"
  names(est) <- "diff_means_est"
  names(ci) <- c("diff_means_ci_lwr", "diff_means_ci_upr")
  names(se) <- "diff_means_se"
  est_ci <- c(est, ci)
  attr(est_ci, "conf.level") <- conf.level

  label <- "Difference in Means"
  cl <- tern::f_conf_level(conf.level)

  y <- list()
  y$diff_means_n1 <- formatters::with_label(n1, paste(label, "Sample Size (Group 1)"))
  y$diff_means_n2 <- formatters::with_label(n2, paste(label, "Sample Size (Group 2)"))
  y$diff_means_est <- formatters::with_label(est, label)
  y$diff_means_se <- formatters::with_label(se, paste(label, "SE"))
  y$diff_means_est_se <- formatters::with_label(c(est, se), paste(label, "(SE)"))
  y$diff_means_ci <- formatters::with_label(ci, paste(label, cl))
  y$diff_means_est_ci <- formatters::with_label(est_ci, paste0(label, " (", cl, ")"))

  y
}

#' @describeIn diff_means Formatted analysis function which is used as `afun` in
#' [rtables::analyze()].
#'
#' The sample from the first distribution is `df[[.var]]`, and the sample from
#' the second distribution is `.ref_group[[.var]]`, where `.ref_group` is
#' computed by [get_ref_info()] using `.spl_context` and `ref_path`.
#'
#' If `ref_path = NULL`, then `a_diff_means()` returns an [rtables::in_rows()]
#' result with an empty `formatted_cell` for every statistic specified in
#' `.stats`.
#'
#' @param df (`data.frame`)\cr Dataset for the first sample.
#' @param ref_path (`character`)\cr Global reference group specification; see
#'   [get_ref_info()]. This specifies the column path for the second sample.
#'   Specifically, the second sample is `.ref_group[[.var]]`, where
#'   `.ref_group` is computed by [get_ref_info()] using `.spl_context` and
#'   `ref_path`.
#'
#'   This is a workaround for an [rtables] limitation in supporting
#'   `.ref_group` / `.in_ref_col` in the presence of stacked headers.
#'   Normally, `.ref_group` and `.in_ref_col` are provided by the [rtables]
#'   tabulation framework when the current column split is within the reference
#'   variable.
#' @param .stats (`character`)\cr Statistics to include in the table.
#'
#'   Available options are:
#'   ``r shQuote(junco_get_stats("diff_means"), type = "sh")``
#'
#'   If `NULL`, all statistics are included.
#'
#' @return
#' * `a_diff_means()` returns formatted [rtables::in_rows()] result with the
#' quantities requested in `.stats`.
#'
#' @importFrom stats setNames
#'
#' @export
#'
#' @examples
#'
#' ## Analysis  function:
#'
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_rows_by(
#'     "PARAMCD",
#'     labels_var = "PARAM",
#'     split_fun = keep_split_levels(c("SYSBP", "DIABP"))
#'   ) |>
#'   split_rows_by(
#'     "AVISIT",
#'     split_fun = keep_split_levels(c("BASELINE", "WEEK 1 DAY 8"))
#'   ) |>
#'   analyze(
#'     "AVAL",
#'     afun = tern::a_summary,
#'     extra_args = list(.stats = c("n", "mean")),
#'     show_labels = "hidden"
#'   ) |>
#'   analyze(
#'     "AVAL",
#'     afun = a_diff_means,
#'     table_names = "aval_diff",
#'     extra_args = list(
#'       .stats = "diff_means_est_ci",
#'       ref_path = c("ARM", "B: Placebo")
#'     ),
#'     show_labels = "hidden"
#'   )
#'
#' tbl <- build_table(lyt, formatters::ex_advs)
#' tbl
#'
a_diff_means <- function(
  df,
  .var,
  .spl_context,
  ref_path = NULL,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_data_frame(.spl_context)
  checkmate::assert_character(ref_path, min.len = 1L, null.ok = TRUE)
  checkmate::assert_character(.stats, null.ok = TRUE)
  if (!is.null(.stats)) {
    checkmate::assert_names(.stats, subset.of = junco_get_stats("diff_means"))
  }

  ref <- get_ref_info(ref_path, .spl_context)
  .ref_group <- ref$ref_group
  .in_ref_col <- ref$in_ref_col

  y <- if (is.null(.in_ref_col) || .in_ref_col) {
    .stats <- junco_get_stats("diff_means", stats_in = .stats)
    setNames(vector(mode = "list", length = length(.stats)), .stats)
  } else {
    s_diff_means(df1 = df, df2 = .ref_group, .var = .var, ...)
  }

  format_stats(
    y,
    method_groups = "diff_means",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' MMRM Analysis for Imputed Datasets
#'
#' Performs an MMRM for two or more groups returning the estimated
#' 'treatment effect' (i.e. the contrast between treatment groups and the control
#' group) and the least square means estimates in each group.
#'
#' @param data (`data.frame`)\cr containing the data to be used in the model.
#' @param vars (`vars`)\cr list as generated by the set_vars() function from the rbmi package.
#' Only the `subjid`, `group`,
#' `visit`, `outcome` and `covariates` elements are required. See details.
#' @param cov_struct (`string`)\cr the covariance structure to use. Note that the same
#'   covariance structure is assumed for all treatment groups.
#' @param visits (`NULL` or `character`)\cr An optional character vector specifying
#'   which visits to fit the MMRM at. If `NULL`, the MMRM model will be fit to
#'   the whole dataset.
#' @param weights (`string`)\cr the weighting strategy to be used when calculating the
#'   least square means, either `'counterfactual'` or `'equal'`.
#' @param ... additional arguments passed to [mmrm::mmrm()], in particular
#'   `method` and `vcov` to control the degrees of freedom and variance-covariance
#'   adjustment methods as well as `reml` decide between REML and ML estimation.
#'
#' @details
#' The function works as follows:
#'
#' 1. Optionally select the subset of the `data` corresponding to `visits.
#' 2. Fit an MMRM as `vars$outcome ~ vars$group + vars$visit + vars$covariates`
#'    with the specified covariance structure for visits within subjects.
#' 3. Extract the 'treatment effect' & least square means for each treatment group
#'    vs the control group.
#'
#' In order to meet the formatting standards set by the analyse() function from the rbmi package,
#' the results will be collapsed
#' into a single list suffixed by the visit name, e.g.:
#' ```
#' list(
#'    var_B_visit_1 = list(est = ...),
#'    trt_B_visit_1 = list(est = ...),
#'    lsm_A_visit_1 = list(est = ...),
#'    lsm_B_visit_1 = list(est = ...),
#'    var_B_visit_2 = list(est = ...),
#'    trt_B_visit_2 = list(est = ...),
#'    lsm_A_visit_2 = list(est = ...),
#'    lsm_B_visit_2 = list(est = ...),
#'    ...
#' )
#' ```
#' Please note that 'trt' refers to the treatment effects, and 'lsm' refers to the least
#' square mean results. In the above example `vars$group` has two factor levels A and B.
#' The new 'var' refers to the model estimated variance of the residuals at the given
#' visit, together with the degrees of freedom (which is treatment group specific).
#'
#' If you want to include additional interaction terms in your model this can be done
#' by providing them to the `covariates` argument of the set_vars() function from the rbmi package
#' e.g. `set_vars(covariates = c('sex*age'))`.
#'
#' @note The `group` and `visit` interaction `group:visit` is not included by
#' default in the model, therefore please add that to `covariates` manually if
#' you want to include it. This will make sense in most cases.
#' @inherit rbmi_ancova return
#'
#' @seealso [rbmi_analyse()]
#' @seealso [mmrm::mmrm()]
#' @seealso The set_vars() function from the rbmi package
#' @export
rbmi_mmrm <- function(
  data,
  vars,
  cov_struct = c("us", "toep", "cs", "ar1"),
  visits = NULL,
  weights = c("counterfactual", "equal"),
  ...
) {
  subjid <- vars[["subjid"]]
  outcome <- vars[["outcome"]]
  group <- vars[["group"]]
  visit <- vars[["visit"]]
  covariates <- vars[["covariates"]]

  checkmate::assert_string(subjid)
  checkmate::assert_string(outcome)
  checkmate::assert_string(group)
  checkmate::assert_string(visit)
  checkmate::assert_character(covariates, null.ok = TRUE)

  cov_struct <- match.arg(cov_struct)
  weights <- match.arg(weights)

  expected_vars <- c((utils::getFromNamespace("extract_covariates", "rbmi"))(covariates), outcome, group, subjid, visit)
  checkmate::assert_subset(expected_vars, names(data))

  checkmate::assert_factor(data[[visit]])
  if (is.null(visits)) {
    visits <- as.character(unique(data[[visit]]))
  }
  checkmate::assert_subset(visits, as.character(data[[visit]]))
  data <- data[data[[visit]] %in% visits, , drop = FALSE]

  covariates_part <- paste(covariates, collapse = " + ")
  grp_visit_part <- paste(group, "+", visit)
  random_effects_part <- paste0(cov_struct, "(", visit, " | ", subjid, ")")
  rhs_formula <- paste(grp_visit_part, "+", random_effects_part)
  if (covariates_part != "") rhs_formula <- paste(covariates_part, "+", rhs_formula)
  formula <- stats::as.formula(paste(outcome, "~", rhs_formula))

  fit <- mmrm::mmrm(formula, data = data, ...)
  res <- lapply(visits, function(x) {
    res <- rbmi_mmrm_single_info(fit, visit_level = x, visit = visit, group = group, weights = weights)
    names(res) <- paste0(names(res), "_", x)
    return(res)
  })
  unlist(res, recursive = FALSE)
}

#' Extract Single Visit Information from a Fitted MMRM for Multiple Imputation Analysis
#'
#' @description
#' Extracts relevant estimates from a given fitted MMRM. See [rbmi_mmrm()] for full details.
#'
#' @param fit (`mmrm`)\cr the fitted MMRM.
#' @param visit_level (`string`)\cr the visit level to extract information for.
#' @param visit (`string`)\cr the name of the visit variable.
#' @param group (`string`)\cr the name of the group variable.
#'
#' @return a list with `trt_*`, `var_*` and `lsm_*` elements. See [rbmi_mmrm] for
#' full details.
#' @inheritParams rbmi_mmrm
#' @seealso [rbmi_mmrm()]
rbmi_mmrm_single_info <- function(fit, visit_level, visit, group, weights) {
  checkmate::assert_class(fit, "mmrm")
  checkmate::assert_string(visit_level)
  checkmate::assert_string(visit)
  checkmate::assert_string(group)

  data <- mmrm::component(fit, "full_frame")
  checkmate::assert_factor(data[[group]])
  grp_levels <- levels(data[[group]])

  visit_at_level <- stats::setNames(list(visit_level), visit)
  em_res <- emmeans::emmeans(fit, group, by = visit, at = visit_at_level, weights = weights)
  em_df <- as.data.frame(em_res)

  all_lsm <- lapply(grp_levels, function(x) {
    this_df <- em_df[em_df[[group]] == x, ]
    with(this_df, list(est = emmean, se = SE, df = df))
  })
  names(all_lsm) <- paste0("lsm_", grp_levels)

  var_est <- mmrm::VarCorr(fit)[visit_level, visit_level]

  cont_res <- emmeans::contrast(em_res, "trt.vs.ctrl", ref = grp_levels[1])
  cont_df <- as.data.frame(cont_res)

  all_var <- lapply(grp_levels[-1], function(x) {
    this_df <- cont_df[cont_df[["contrast"]] == paste(x, "-", grp_levels[1]), ]
    # Note: This should be revisited here for the `se` - currently we take the SE from the LS means contrast, not
    # from the variance estimate!
    with(this_df, list(est = var_est, se = SE, df = df))
  })
  names(all_var) <- paste0("var_", grp_levels[-1])

  all_trt <- lapply(grp_levels[-1], function(x) {
    this_df <- cont_df[cont_df[["contrast"]] == paste(x, "-", grp_levels[1]), ]
    with(this_df, list(est = estimate, se = SE, df = df))
  })
  names(all_trt) <- paste0("trt_", grp_levels[-1])

  c(all_var, all_trt, all_lsm)
}

#' @title Combined Proportion, Risk Difference, and Risk Difference Test
#'   Analysis Function with Method Selection Based on the Mantel-Fleiss
#'   Criterion
#'
#' @description
#'   Performs a combined analysis of proportions, treatment-vs-control risk
#'   differences, and tests of risk differences.
#'
#'   The method used for the risk difference and risk difference test is
#'   selected based on the Mantel-Fleiss criterion. If the Mantel-Fleiss (MF)
#'   criterion is satisfied, the Cochran-Mantel-Haenszel (CMH) method with Sato
#'   variance is used for both the risk difference and the corresponding
#'   statistical test.
#'
#'   If the Mantel-Fleiss criterion is not satisfied, an exact method is used.
#'   Specifically, the exact unconditional method is used for estimation of the
#'   risk difference, and Fisher's exact test is used for the hypothesis test.
#'
#' @inheritParams proposal_argument_convention
#' @inheritParams a_proportion_diff_mf mf_threshold exact_footnote
#'
#' @param .df_row (`data.frame`) \cr
#'   Data set containing all analysis variables across all columns for the given
#'   row split.
#'   It is required for risk difference and risk difference test calculations
#'   to obtain the reference data.
#' @param .var (`character(1)`)\cr
#'   Name of a response variable in `df` and `.df_row`.
#'   The variable must be a factor.
#' @param val (`character(1)`)\cr
#'   The value used to identify the response of interest. An observation is
#'   considered a response of interest when `df[[.var]] == val` (and
#'   `.df_row[[.var]] == val` for the reference group).
#'   Since `df[[.var]]` and `.df_row[[.var]]` must be factors, `val` must be
#'   a `character` value matching one of their levels.
#' @param colpaths (`list(3)`)\cr
#'   A named list containing elements defining the column paths corresponding
#'   to the three types of analysis. Supported names are `"prop"`, `"diff"`, and
#'   `"pval"`. Each element must contain the column path used to identify the
#'   corresponding column(s).
#'   Each column path must contain at least two elements and have an even length.
#'   For example, valid column paths include `c("ARM", "Placebo")` or
#'   `c("ARM", "*")`.
#'   See [rtables::col_paths()] for details on column path specification.
#' @param trt_var (`character(1)`)\cr
#'   The name of the treatment variable. This variable is used to identify
#'   the control group in `.df_row`.
#'   It is used only for risk difference and risk difference test calculations.
#' @param ctrl_group (`character(1)`)\cr
#'   The value of `trt_var` identifying the control treatment group.
#'   It is used only for risk difference and risk difference test calculations.
#' @param variables (`list` or `NULL`)\cr
#'   Optional stratification variables used by the Cochran-Mantel-Haenszel
#'   analysis. These are specified as `list(strata = <strata_vars>)`, where
#'   `<strata_vars>` is a character vector containing column names in `df`.
#'   All specified strata variables must be factors.
#'   Strata variables are used only for risk difference and risk difference
#'   test calculations.
#' @param .stats (`list`)\cr
#'   A named list of at most three elements specifying the statistic(s) to
#'   calculate for each type of analysis. Supported names are `"prop"`, `"diff"`,
#'   and `"pval"`.
#'   The supported values for each analysis type are determined by the `.stats`
#'   argument of [a_freq_j()], [a_proportion_diff_mf()], and
#'   [a_test_proportion_diff_mf()], respectively.
#'
#'    If a statistic is not supplied for any of the three analysis types, the
#'    following defaults are used:
#'    \itemize{
#'      \item `prop = "count_unique_denom_fraction"`
#'      \item `diff = "diff_est_ci"`
#'      \item `pval = "pval"`
#'    }
#'
#' @param .formats (`list`)\cr
#'   A named list of at most three elements specifying the formats for the
#'   statistics specified in `.stats`. Supported names are `"prop"`, `"diff"`,
#'   and `"pval"`. The format specified for each analysis type is passed to
#'   the corresponding analysis function.
#'
#' @param ... Additional arguments reserved for compatibility with the
#'   rtables analysis function interface.
#'
#' @details
#'   The analysis function determines which type of result to calculate based
#'   on the current column path specified by `colpaths`.
#'   \itemize{
#'    \item `"prop"`: calculates and displays the proportion for the current
#'    analysis facet.
#'    \item `"diff"`: calculates the treatment-vs-control proportion difference.
#'    \item `"pval"`: calculates the treatment-vs-control p-value.
#'   }
#'
#'   For proportion columns, [a_freq_j()] is used. For risk difference and
#'   p-value columns, the control group is identified from `.df_row` using
#'   `trt_var` and `ctrl_group`, and the corresponding [a_proportion_diff_mf()]
#'   or [a_test_proportion_diff_mf()] function is called.
#'
#'   The current column is identified using [in_column()] against each element
#'   of `colpaths` list.
#'   If the current column does not correspond to any of the configured `prop`,
#'   `diff`, or `pval` paths, an empty [rtables::rcell()].
#'
#'   The function first determines the current row label from `.spl_context`.
#'   If the current split represents the root of the analysis, the label
#'   `"Full analysis set"` is used; otherwise, the value of the leaf split is
#'   used.
#'
#' @return
#'   Returns the corresponding `CellValue` or `RowsVerticalSection` object with
#'   formatted results.
#'
#' @seealso [a_freq_j()], [a_proportion_diff_mf()], [a_test_proportion_diff_mf()],
#'
#' @author WW
#' @export
#' @examples
#' library(dplyr)
#'
#' adrs_f <- formatters::ex_adrs |>
#'   filter(
#'     ARM %in% c("A: Drug X", "B: Placebo"),
#'     PARAMCD == "BESRSPI"
#'   ) |>
#'   droplevels() |>
#'   mutate(
#'     rsp = factor(ifelse(AVALC == "CR", "Y", "N")),
#'     ARM_FOR_RISKCOLS = ARM # Required for Risk Difference and p-value columns
#'   )
#'
#' riskcols_combodf <- tribble(
#'   ~valname, ~label, ~levelcombo, ~exargs,
#'   "diff", "Risk Difference", "A: Drug X", list(),
#'   "pval", "p-value", "B: Placebo", list()
#' )
#'
#' col_split_fun <- add_combo_levels(
#'   riskcols_combodf,
#'   keep_levels = riskcols_combodf$valname
#' )
#'
#' # Additional arguments for a_combo_prop_diff_pval_mf().
#' extra_args <- list(
#'   colpaths = list(
#'     prop = c("ARM", "*"),
#'     diff = c("ARM_FOR_RISKCOLS", "diff"),
#'     pval = c("ARM_FOR_RISKCOLS", "pval")
#'   ),
#'   id = "SUBJID",
#'   trt_var = "ARM",
#'   ctrl_group = "B: Placebo",
#'   val = "Y",
#'   variables = list(strata = "BMRKR2"),
#'   .stats = list(diff = "diff")
#' )
#'
#' lyt <- basic_table(top_level_section_div = " ") |>
#'   split_cols_by("ARM") |>
#'   split_cols_by(
#'     "ARM_FOR_RISKCOLS",
#'     split_fun = col_split_fun,
#'     nested = FALSE
#'   ) |>
#'   analyze(
#'     "rsp",
#'     afun = a_combo_prop_diff_pval_mf,
#'     extra_args = extra_args
#'   ) |>
#'   split_rows_by(
#'     var = "SEX",
#'     split_label = "Gender",
#'     child_labels = "hidden",
#'     label_pos = "visible"
#'   ) |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_combo_prop_diff_pval_mf,
#'     extra_args = extra_args,
#'     show_labels = "hidden"
#'   )
#'
#' tbl <- build_table(lyt, adrs_f)
#' tbl
#'
a_combo_prop_diff_pval_mf <- function(df,
                                      .var,
                                      .df_row,
                                      .spl_context,
                                      val,
                                      colpaths,
                                      id = "USUBJID",
                                      trt_var,
                                      ctrl_group,
                                      variables = list(strata = NULL),
                                      mf_threshold = NULL,
                                      conf_level = 0.95,
                                      alternative = c("two.sided", "less", "greater"),
                                      exact_footnote = rtables::RefFootnote("Exact Inference", 1L, "+"),
                                      .stats = NULL,
                                      .formats = NULL,
                                      ...) {
  checkmate::assert_list(colpaths, names = "named")
  checkmate::assert_subset(names(colpaths), c("prop", "diff", "pval"))
  checkmate::assert_character(colpaths$prop, any.missing = FALSE, min.len = 2, null.ok = TRUE)
  checkmate::assert_character(colpaths$diff, any.missing = FALSE, min.len = 2, null.ok = TRUE)
  checkmate::assert_character(colpaths$pval, any.missing = FALSE, min.len = 2, null.ok = TRUE)
  checkmate::assert_data_frame(df)
  checkmate::assert_data_frame(.df_row)
  # .var
  checkmate::assert_string(.var)
  checkmate::assert_subset(.var, colnames(df))
  checkmate::assert_subset(.var, colnames(.df_row))
  checkmate::assert_factor(df[[.var]])
  checkmate::assert_factor(.df_row[[.var]])
  # id
  checkmate::assert_string(id)
  checkmate::assert_subset(id, colnames(df))
  checkmate::assert_subset(id, colnames(.df_row))
  # trt_var
  checkmate::assert_string(trt_var)
  checkmate::assert_subset(trt_var, colnames(df))
  checkmate::assert_subset(trt_var, colnames(.df_row))

  checkmate::assert_list(.stats, names = "named", null.ok = TRUE)
  checkmate::assert_subset(names(.stats), c("prop", "diff", "pval"))
  checkmate::assert_list(.formats, names = "named", null.ok = TRUE)
  checkmate::assert_subset(names(.formats), c("prop", "diff", "pval"))

  leaf_splc <- .spl_context[nrow(.spl_context), ]
  row_label <- if (leaf_splc$split == "root" && leaf_splc$value == "root") {
    "Full analysis set"
  } else {
    leaf_splc$value
  }

  in_prop <- in_column(colpaths$prop, .spl_context)
  in_diff <- in_column(colpaths$diff, .spl_context)
  in_pval <- in_column(colpaths$pval, .spl_context)
  # Assert that we are in at most one column at a time.
  checkmate::assert_true(sum(in_prop, in_diff, in_pval) <= 1L)

  if (in_prop) {
    # NA values of df[[.var]] as dropped silently!
    # https://github.com/johnsonandjohnson/junco/issues/461
    if (is.null(.stats$prop)) {
      .stats$prop <- "count_unique_denom_fraction"
    }
    a_freq_j(
      df = df,
      .var = .var,
      val = val,
      .df_row = .df_row,
      .spl_context = .spl_context,
      id = id,
      denom = "n_df",
      riskdiff = FALSE,
      variables = NULL,
      label = row_label,
      .stats = .stats$prop,
      .formats = .formats$prop
    )
  } else if (in_diff || in_pval) {
    ref_indices <- .df_row[[trt_var]] == ctrl_group
    .ref_group <- .df_row[ref_indices, , drop = FALSE]
    if (in_diff) {
      if (is.null(.stats$diff)) {
        .stats$diff <- "diff_est_ci"
      }
      a_proportion_diff_mf(
        df,
        .var = .var,
        .in_ref_col = FALSE,
        .ref_group = .ref_group,
        val = val,
        variables = variables,
        conf_level = conf_level,
        mf_method = "cmh_sato",
        mf_threshold = mf_threshold,
        .stats = .stats$diff,
        .formats = .formats$diff,
        .labels = setNames(list(row_label), .stats$diff),
        exact_footnote = exact_footnote
      )
    } else { # In p-value column.
      if (is.null(.stats$pval)) {
        .stats$pval <- "pval"
      }
      a_test_proportion_diff_mf(
        df,
        .var = .var,
        .in_ref_col = FALSE,
        .ref_group = .ref_group,
        val = val,
        variables = variables,
        alternative = alternative,
        mf_method = "cmh_sato",
        mf_threshold = mf_threshold,
        .stats = .stats$pval,
        .formats = .formats$pval,
        .labels = setNames(list(row_label), .stats$pval),
        exact_footnote = exact_footnote
      )
    }
  } else {
    rcell(NULL, format = NULL, label = row_label)
  }
}

#' Function Factory to Create Padded In Rows Content
#'
#' @param length_out (`numeric` or `NULL`)\cr full length which should be padded
#'   by `NA` which will be printed as empty strings.
#' @param label (`string`)\cr row label to be used for the first row only.
#'
#' @return The function of `content` and `.formats`.
#' @keywords internal
pad_in_rows_fct <- function(length_out = NULL, label = "") {
  checkmate::assert_count(length_out, null.ok = TRUE)
  checkmate::assert_string(label)

  function(content, .formats) {
    content_list <- as.list(content)
    if (!is.null(length_out)) {
      missing_length <- length_out - length(content_list)
      if (missing_length > 0) {
        content_list <- c(content_list, rep(NA, missing_length))
      }
    }
    in_rows(
      .list = content_list,
      .names = as.character(seq_along(content_list)),
      .labels = c(
        label,
        rep(
          "",
          length(content_list) -
            1L
        )
      ),
      .formats = .formats,
      .format_na_strs = ""
    )
  }
}

#' @rdname summarize_lsmeans_wide
#' @export
lsmeans_wide_first_split_fun_fct <- function(include_variance) {
  checkmate::assert_flag(include_variance)

  post_fun <- function(ret, spl, fulldf, .spl_context) {
    if (include_variance) {
      short_split_result(
        reference_group = "Reference Group",
        testing_group = "Testing Group",
        variance = "",
        comparison = "Testing-Reference",
        fulldf = fulldf
      )
    } else {
      short_split_result(
        reference_group = "Reference Group",
        testing_group = "Testing Group",
        comparison = "Testing-Reference",
        fulldf = fulldf
      )
    }
  }
  make_split_fun(post = list(post_fun))
}

#' @rdname summarize_lsmeans_wide
#' @export
lsmeans_wide_second_split_fun_fct <- function(pval_sided, conf_level, include_pval) {
  checkmate::assert_flag(include_pval)

  post_fun <- function(ret, spl, fulldf, .spl_context) {
    colset <- .spl_context[nrow(.spl_context), "value"][[1]]
    if (colset %in% c("reference_group", "testing_group")) {
      short_split_result(
        treatment = "Treatment",
        n = "N",
        lsmean = "LS Mean",
        se = "SE",
        fulldf = fulldf
      )
    } else if (colset == "variance") {
      short_split_result(mse = "M. S. Error", df = "Error DF", fulldf = fulldf)
    } else {
      if (include_pval) {
        short_split_result(
          lsmean = "LS Mean",
          se = "SE",
          ci = f_conf_level(conf_level),
          pval = paste0(abs(as.numeric(pval_sided)), "-sided p-value~[super a]"),
          fulldf = fulldf
        )
      } else {
        short_split_result(
          lsmean = "LS Mean",
          se = "SE",
          ci = f_conf_level(conf_level),
          fulldf = fulldf
        )
      }
    }
  }
  make_split_fun(post = list(post_fun))
}

#' @rdname summarize_lsmeans_wide
#' @export
lsmeans_wide_cfun <- function(
  df,
  labelstr,
  .spl_context,
  variables,
  ref_level,
  treatment_levels,
  pval_sided = c("2", "1", "-1"),
  conf_level,
  formats
) {
  this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  pad_in_rows <- pad_in_rows_fct(length_out = length(treatment_levels), label = labelstr)
  if (this_col_split[1] %in% c("reference_group", "testing_group")) {
    this_level <- if (this_col_split[1] == "reference_group") {
      ref_level
    } else {
      treatment_levels
    }
    has_this_level <- df[[variables$arm]] %in% this_level
    if (this_col_split[2] == "treatment") {
      pad_in_rows(this_level, .formats = "xx")
    } else if (this_col_split[2] == "n") {
      pad_in_rows(df$n[has_this_level], .formats = "xx")
    } else if (this_col_split[2] == "lsmean") {
      pad_in_rows(df$estimate_est[has_this_level], .formats = formats$lsmean)
    } else {
      pad_in_rows(df$se_est[has_this_level], .formats = formats$se)
    }
  } else if (this_col_split[1] == "variance") {
    has_trt <- df[[variables$arm]] %in% treatment_levels
    all_the_same <- (length(unique(df$mse[has_trt])) == 1) && (length(unique(df$df[has_trt])) == 1)
    # Note: We only take the first value, because in this ANCOVA case they are identical and we don't want to
    # repeat it in the table.
    inds <- if (all_the_same) 1 else seq_len(sum(has_trt))
    if (this_col_split[2] == "mse") {
      pad_in_rows(df$mse[has_trt][inds], .formats = formats$mse)
    } else {
      pad_in_rows(df$df[has_trt][inds], .formats = formats$df)
    }
  } else {
    has_trt <- df[[variables$arm]] %in% treatment_levels
    switch(this_col_split[2],
      "lsmean" = pad_in_rows(df$estimate_contr[has_trt], .formats = formats$lsmean_diff),
      "se" = pad_in_rows(df$se_contr[has_trt], .formats = formats$se),
      "ci" = pad_in_rows(
        tern::combine_vectors(df$lower_cl_contr[has_trt], df$upper_cl_contr[has_trt]),
        .formats = formats$ci
      ),
      "pval" = {
        pval_sided <- match.arg(pval_sided)
        pval_col <- switch(pval_sided,
          `2` = "p_value",
          `1` = "p_value_greater",
          `-1` = "p_value_less"
        )
        pad_in_rows(df[[pval_col]][has_trt], .formats = formats$pval)
      }
    )
  }
}

#' Layout Generating Function for LS Means Wide Table Layouts
#'
#' @inheritParams proposal_argument_convention
#' @param variables (`list`)\cr see [fit_ancova()] for required variable
#'   specifications.
#' @param ref_level (`string`)\cr the reference level of the treatment arm variable.
#' @param treatment_levels (`character`)\cr the non-reference levels of the treatment arm
#'   variable.
#' @param pval_sided (`string`)\cr either '2' for two-sided or '1' for 1-sided with greater than
#'   control or '-1' for 1-sided with smaller than control alternative hypothesis.
#' @param formats (`list`)\cr including `lsmean`, `mse`, `df`, `lsmean_diff`, `se`,
#'   `ci`, `pval` formats.
#' @param lyt (`layout`)\cr empty layout, i.e. result of [rtables::basic_table()]
#' @param include_variance (`flag`)\cr whether to include the variance statistics
#'   (M.S. error and d.f.).
#' @param include_pval (`flag`)\cr whether to include the p-value column.
#'
#' @return Modified layout.
#' @details The functions [lsmeans_wide_first_split_fun_fct()], [lsmeans_wide_second_split_fun_fct()] and
#'   [lsmeans_wide_cfun()] are also exported and can be used directly when the layout is slightly different (e.g.
#'   contains additional subgroup row split).
#'
#' @export
#' @examples
#' variables <- list(
#'   response = "FEV1",
#'   covariates = c("RACE", "SEX"),
#'   arm = "ARMCD",
#'   id = "USUBJID",
#'   visit = "AVISIT"
#' )
#' fit <- fit_ancova(
#'   vars = variables,
#'   data = mmrm::fev_data,
#'   conf_level = 0.9,
#'   weights_emmeans = "equal"
#' )
#' anl <- broom::tidy(fit)
#' basic_table() |>
#'   summarize_lsmeans_wide(
#'     variables = variables,
#'     ref_level = fit$ref_level,
#'     treatment_levels = fit$treatment_levels,
#'     pval_sided = "2",
#'     conf_level = 0.8
#'   ) |>
#'   build_table(df = anl)
summarize_lsmeans_wide <- function(
  lyt,
  variables,
  ref_level,
  treatment_levels,
  conf_level,
  pval_sided = "2",
  include_variance = TRUE,
  include_pval = TRUE,
  formats = list(
    lsmean = jjcsformat_xx("xx.x"),
    mse = jjcsformat_xx("xx.x"),
    df = jjcsformat_xx("xx."),
    lsmean_diff = jjcsformat_xx("xx.x"),
    se = jjcsformat_xx("xx.xx"),
    ci = jjcsformat_xx("(xx.xx, xx.xx)"),
    pval = jjcsformat_pval_fct(0)
  )
) {
  # Check that all required format elements are present in the formats parameter
  checkmate::assert_names(
    names(formats),
    must.include = c("lsmean", "mse", "df", "lsmean_diff", "se", "ci", "pval"),
    .var.name = "formats"
  )
  lyt |>
    split_cols_by(
      variables$arm,
      split_fun = lsmeans_wide_first_split_fun_fct(include_variance = include_variance)
    ) |>
    split_cols_by(
      variables$arm,
      split_fun = lsmeans_wide_second_split_fun_fct(
        include_pval = include_pval,
        pval_sided = pval_sided,
        conf_level = conf_level
      )
    ) |>
    split_rows_by(variables$visit, section_div = "") |>
    summarize_row_groups(
      var = variables$arm,
      cfun = lsmeans_wide_cfun,
      extra_args = list(
        variables = variables,
        ref_level = ref_level,
        treatment_levels = treatment_levels,
        pval_sided = pval_sided,
        conf_level = conf_level,
        formats = formats
      )
    )
}

#' @name remove_col_count
#'
#' @title Removal of Unwanted Column Counts
#'
#' @description
#' Remove the N=xx column headers for specified span_label_var columns - default is 'rrisk_header'.
#'
#' @details This works for only the lowest level of column splitting (since colcounts is used).
#'
#' @param obj (`TableTree`)\cr TableTree object.
#' @param span_label_var (`character`)\cr
#' The spanning header text variable value for which column headers will be removed from.
#'
#' @return TableTree object with column counts in specified columns removed.
#' @export
remove_col_count <- function(obj, span_label_var = "rrisk_header") {
  ## programatically figure out which ones we want
  unwanted_count <- function(pth) pth[1] == span_label_var
  to_blank <- sapply(col_paths(obj), unwanted_count)
  col_counts(obj)[to_blank] <- NA_integer_
  return(obj)
}

#' Pool a scalar estimate across imputations
#'
#' Applies Rubin's rules to combine scalar estimates and their
#' within-imputation variance estimates.
#'
#' @details For `m` imputations, the pooled estimate is the mean of `q`. The
#'   pooled variance combines the mean within-imputation variance with the
#'   between-imputation variance, using the usual `(1 + 1 / m)` multiplier.
#'   The returned standard error is the square root of the pooled variance.
#'
#' @param q (`numeric`)
#'   Vector of scalar estimates, with one value for each imputed dataset.
#' @param u (`numeric`)
#'   Vector of within-imputation variance estimates corresponding to `q`.
#'
#' @return A named `list` with the pooled estimate (`est`), standard error
#'   (`se`), variance (`var`), and number of imputations (`m`).
#'
#' @seealso [pool_z_stat()]
#' @export
#'
#' @examples
#' pool_rubin_scalar(
#'   q = c(0.20, 0.25, 0.15),
#'   u = c(0.01, 0.016, 0.012)
#' )
pool_rubin_scalar <- function(q, u) {
  # q: vector of estimates
  # u: vector of within-imputation variances
  m <- length(q)
  qbar <- mean(q, na.rm = TRUE)
  ubar <- mean(u, na.rm = TRUE)
  b <- stats::var(q, na.rm = TRUE)
  tvar <- ubar + (1 + 1 / m) * b
  se <- sqrt(tvar)
  list(est = qbar, se = se, var = tvar, m = m)
}

#' Pool z statistics across imputations
#'
#' Combines z statistics from multiple imputed datasets and calculates a
#' two-sided p-value for the pooled statistic.
#'
#' @details The within-imputation variance of a z statistic is approximately 1.
#'   The between-imputation variance is pooled using the same
#'   `(1 + 1 / m)` multiplier as [pool_rubin_scalar()]. The returned p-value is
#'   calculated from the standard normal distribution.
#'
#' @param z_stat_vals (`numeric`)
#'   Vector of z statistics, with one value for each imputed dataset.
#'
#' @return A named `list` with the pooled z statistic (`z`) and its two-sided
#'   p-value (`p`).
#'
#' @seealso [pool_rubin_scalar()]
#' @export
#'
#' @examples
#' pool_z_stat(c(1.1, 1.3, 1.2))
pool_z_stat <- function(z_stat_vals) {
  m <- length(z_stat_vals)
  qbar <- mean(z_stat_vals, na.rm = TRUE)
  b <- stats::var(z_stat_vals, na.rm = TRUE)
  ubar <- 1 # approx var(z) ~ 1 because it is a z statistic
  tvar <- ubar + (1 + 1 / m) * b
  z_pool <- qbar / sqrt(tvar)
  p_pool <- 2 * stats::pnorm(abs(z_pool), lower.tail = FALSE)
  list(z = z_pool, p = p_pool)
}

#' Shortcut Layout Function for Standard Continuous Variable Analysis
#'
#' @inheritParams proposal_argument_convention
#' @param formats (`list`)\cr formats including `mean_sd`, `median` and `range`
#'   specifications.
#'
#' @return Modified layout.
#' @export
analyze_values <- function(lyt, vars, ..., formats) {
  checkmate::assert_list(formats)
  checkmate::assert_names(names(formats), must.include = c("mean_sd", "median", "range"))

  analyze_vars(
    lyt,
    vars = vars,
    ...,
    .stats = c("n", "mean_sd", "median", "range"),
    .formats = c(n = "xx", mean_sd = formats$mean_sd, median = formats$median, range = formats$range),
    .labels = c(n = "N", mean_sd = "Mean (SD)", median = "Median", range = "Min, Max"),
    .indent_mods = c(n = 0, mean_sd = 1, median = 1, range = 1)
  )
}

#' @name cur_col_split_path_utils
#'
#' @title Utilities for the Current Column Split Path
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These helper functions are intended for use in [rtables] custom analysis
#' functions that depend on the current column split context.
#'
#' @inheritParams proposal_argument_convention
#'
#' @author WW
#'
#' @seealso
#' - [rtables::col_paths()] for obtaining column paths from a built table.
#'
#' @examples
#' .spl_context_1 <- data.frame(
#'   cur_col_split = I(list(c("ARM"))),
#'   cur_col_split_val = I(list(c("Placebo")))
#' )
#'
#' .spl_context_2 <- data.frame(
#'   cur_col_split = I(list(c("ARM", "desc_stat"))),
#'   cur_col_split_val = I(list(c("Placebo", "N")))
#' )
#'
NULL

#' @describeIn cur_col_split_path_utils
#' Get the current column split path.
#'
#' @return
#' * `cur_col_split_path()` returns a character vector containing the current
#'   column split path extracted from `.spl_context`, interleaved as
#'   `c(var1, val1, var2, val2, ...)`.
#'
#' @export
#'
#' @examples
#' cur_col_split_path(.spl_context_1)
#' cur_col_split_path(.spl_context_2)
#'
cur_col_split_path <- function(.spl_context) {
  checkmate::assert_data_frame(.spl_context, min.rows = 1L)
  checkmate::assert_subset(c("cur_col_split", "cur_col_split_val"), choices = colnames(.spl_context))
  checkmate::assert_list(.spl_context[nrow(.spl_context), "cur_col_split"], min.len = 1L)
  checkmate::assert_list(.spl_context[nrow(.spl_context), "cur_col_split_val"], min.len = 1L)
  checkmate::assert_character(.spl_context[nrow(.spl_context), "cur_col_split"][[1]], names = "unnamed")
  checkmate::assert_character(.spl_context[nrow(.spl_context), "cur_col_split_val"][[1]])
  checkmate::assert_true(
    length(.spl_context[nrow(.spl_context), "cur_col_split"][[1]]) ==
      length(.spl_context[nrow(.spl_context), "cur_col_split_val"][[1]])
  )

  leaf_splc <- .spl_context[nrow(.spl_context), ]
  c(rbind(leaf_splc$cur_col_split[[1]], leaf_splc$cur_col_split_val[[1]]))
}

#' @describeIn cur_col_split_path_utils
#' Determine whether a given column path matches the current column split path.
#'
#' @param col_path (`character` or `NULL`)\cr
#'   Column path specified as alternating split variable names and split values.
#'   Must have at least two elements and an even length, e.g.
#'   `c("ARM", "Placebo")` or `c("ARM", "*", "desc_stat", "N")`;
#'   see [rtables::col_paths()].
#'
#'   The special value `"*"` can be used as a wildcard to match any split
#'   variable name or value.
#'
#'   `NULL` can be used to indicate that no path is specified, in which case
#'   the function returns `FALSE`, regardless of `.spl_context`.
#'
#' @return
#' * `in_column()` returns a single logical value indicating whether the
#' current column split matches the specified `col_path`.
#'
#' @export
#'
#' @examples
#' in_column(c("ARM", "Placebo"), .spl_context_1)
#' in_column(c("ARM", "*"), .spl_context_1)
#' in_column(c("ARM", "X"), .spl_context_1)
#'
#' in_column(c("ARM", "*", "desc_stat", "N"), .spl_context_2)
#' in_column(c("ARM", "*", "desc_stat", "Mean"), .spl_context_2)
#'
#' # Use in an rtables custom analysis function.
#'
#' data <- formatters::ex_adsl
#' data$desc_stat <- "phantom"
#'
#' # analysis function
#' a_N_mean <- function(x, .spl_context) {
#'   if (in_column(c("ARM", "*", "desc_stat", "N"), .spl_context)) {
#'     rcell(length(x))
#'   } else if (in_column(c("ARM", "*", "desc_stat", "Mean"), .spl_context)) {
#'     rcell(mean(x), format = "xx.x")
#'   } else {
#'     rcell(NULL)
#'   }
#' }
#'
#' combodf <- data.frame(
#'   valname = c("N", "Mean"),
#'   label = c("N", "Mean"),
#'   levelcombo = I(list(select_all_levels, select_all_levels)),
#'   exargs = I(list(list(), list()))
#' )
#'
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_cols_by(
#'     "desc_stat",
#'     split_fun = add_combo_levels(combodf, keep_levels = c("N", "Mean"))
#'   ) |>
#'   analyze("AGE", afun = a_N_mean)
#'
#' tbl <- build_table(lyt, data)
#' tbl
#'
in_column <- function(col_path, .spl_context) {
  if (is.null(col_path)) {
    return(FALSE)
  }

  checkmate::assert_character(col_path, min.len = 2L, names = "unnamed")
  checkmate::assert_true(length(col_path) %% 2 == 0)
  checkmate::assert_data_frame(.spl_context, min.rows = 1L)

  cur_colpath <- cur_col_split_path(.spl_context)

  if (length(col_path) == length(cur_colpath)) {
    fixed <- which(col_path != "*")
    identical(col_path[fixed], cur_colpath[fixed])
  } else {
    FALSE
  }
}

#' Tabulation of Least Square Means Results
#'
#' @description `r lifecycle::badge('stable')`
#'
#' These functions can be used to produce tables from LS means, e.g. from [fit_mmrm_j()]
#' or [fit_ancova()].
#'
#' @note These functions have been forked from the `tern.mmrm` package. Additional features
#'   are:
#'
#'   * Additional `ref_path` argument for tern.mmrm::summarize_lsmeans().
#'   * The function is more general in that it also works for LS means results from ANCOVA
#'   * Additional statistic `diff_mean_est_ci` is returned
#'   * P-value sidedness can be chosen
#'
#' @name tabulate_lsmeans
#' @return
#' * For `s_lsmeans`, a list containing the same statistics returned by tern.mmrm::s_mmrm_lsmeans,
#' with the additional `diff_mean_est_ci` three-dimensional statistic.
#' * For `a_lsmeans`, a `VertalRowsSection` as returned by [rtables::in_rows].
#'
#' @examples
#' result <- fit_mmrm_j(
#'   vars = list(
#'     response = "FEV1",
#'     covariates = c("RACE", "SEX"),
#'     id = "USUBJID",
#'     arm = "ARMCD",
#'     visit = "AVISIT"
#'   ),
#'   data = mmrm::fev_data,
#'   cor_struct = "unstructured",
#'   weights_emmeans = "equal"
#' )
#'
#' df <- broom::tidy(result)
#'
#' s_lsmeans(df[8, ], .in_ref_col = FALSE)
#' s_lsmeans(df[8, ], .in_ref_col = FALSE, alternative = "greater", show_relative = "increase")
#'
#' dat_adsl <- mmrm::fev_data |>
#'   dplyr::select(USUBJID, ARMCD) |>
#'   unique()
#'
#' basic_table() |>
#'   split_cols_by("ARMCD") |>
#'   add_colcounts() |>
#'   split_rows_by("AVISIT") |>
#'   analyze(
#'     "AVISIT",
#'     afun = a_lsmeans,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     extra_args = list(
#'       .stats = c(
#'         "n",
#'         "adj_mean_se",
#'         "adj_mean_ci",
#'         "diff_mean_se",
#'         "diff_mean_ci"
#'       ),
#'       .labels = c(
#'         adj_mean_se = "Adj. LS Mean (Std. Error)",
#'         adj_mean_ci = "95% CI",
#'         diff_mean_ci = "95% CI"
#'       ),
#'       .formats = c(adj_mean_se = jjcsformat_xx("xx.x (xx.xx)")),
#'       alternative = "greater",
#'       ref_path = c("ARMCD", result$ref_level)
#'     )
#'   ) |>
#'   build_table(
#'     df = broom::tidy(result),
#'     alt_counts_df = dat_adsl
#'   )
NULL

#' @describeIn tabulate_lsmeans Helper method (for [broom::tidy()]) to prepare a `data.frame` from an
#'   `tern_model` object containing the least-squares means and contrasts.
#' @method tidy tern_model
#' @importFrom generics tidy
#' @export
tidy.tern_model <- function(x, ...) {
  # nolint
  vars <- x$vars
  estimates <- x$lsmeans$estimates
  df <- if (is.null(vars$arm)) {
    nams <- names(estimates)
    to_rename <- match(c("estimate", "se", "df", "lower_cl", "upper_cl"), nams)
    names(estimates)[to_rename] <- paste0(names(estimates)[to_rename], "_est")
    estimates
  } else {
    contrasts <- x$lsmeans$contrasts
    merge(
      x = estimates,
      y = contrasts,
      by = c(vars$subgroup, vars$visit, vars$arm),
      suffixes = c("_est", "_contr"),
      all = TRUE
    )
  }
  if (!is.null(vars$arm)) {
    df[[vars$arm]] <- factor(df[[vars$arm]], levels = levels(estimates[[vars$arm]]))
  }
  df[[vars$visit]] <- factor(df[[vars$visit]], levels = levels(estimates[[vars$visit]]))
  if (!is.null(vars$subgroup)) {
    df[[vars$subgroup]] <- factor(df[[vars$subgroup]], levels = levels(estimates[[vars$subgroup]]))
  }
  df$conf_level <- x$conf_level
  if (!is.null(x$mse)) {
    df$mse <- x$mse[df[[vars$visit]]]
  }
  if (!is.null(x$df)) {
    df$df <- x$df[df[[vars$visit]]]
  }
  df
}

#' @describeIn tabulate_lsmeans Statistics function which is extracting estimates from a tidied least-squares means
#'   data frame.
#' @inheritParams proposal_argument_convention
#' @export
s_lsmeans <- function(df,
                      .in_ref_col,
                      alternative = c("two.sided", "less", "greater"),
                      show_relative = c("reduction", "increase")) {
  alternative <- match.arg(alternative)
  show_relative <- match.arg(show_relative)
  if_not_ref <- function(x) if (.in_ref_col) character() else x
  list(
    n = df$n,
    adj_mean_se = c(df$estimate_est, df$se_est),
    adj_mean_ci = with_label(
      c(df$lower_cl_est, df$upper_cl_est),
      paste0("Adjusted Mean ", f_conf_level(df$conf_level))
    ),
    adj_mean_est_ci = with_label(
      c(df$estimate_est, df$lower_cl_est, df$upper_cl_est),
      paste0("Adjusted Mean (", f_conf_level(df$conf_level), ")")
    ),
    diff_mean_se = if_not_ref(c(df$estimate_contr, df$se_contr)),
    diff_mean_ci = with_label(
      if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
      paste0("Difference in Adjusted Means ", f_conf_level(df$conf_level))
    ),
    diff_mean_est_ci = with_label(
      if_not_ref(c(df$estimate_contr, df$lower_cl_contr, df$upper_cl_contr)),
      paste0("Difference in Adjusted Means (", f_conf_level(df$conf_level), ")")
    ),
    change = switch(show_relative,
      reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
      increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
    ),
    p_value = if_not_ref(switch(alternative,
      two.sided = with_label(df$p_value, "2-sided p-value"),
      less = with_label(df$p_value_less, "1-sided p-value (less)"),
      greater = with_label(df$p_value_greater, "1-sided p-value (greater)")
    ))
  )
}

#' @describeIn tabulate_lsmeans Formatted Analysis function to be used as `afun`
#' @export
a_lsmeans <- function(df,
                      ref_path,
                      .spl_context,
                      ...,
                      .stats = NULL,
                      .formats = NULL,
                      .labels = NULL,
                      .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_lsmeans,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "tabulate_lsmeans",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' @importFrom stats ave
h_get_eair_df <- function(
  levii,
  df,
  denom_df,
  .var,
  id,
  occ_var,
  occ_dy,
  fup_var,
  count_multiple_events = FALSE,
  strata = NULL
) {
  dfii <- df[df[[.var]] == levii & !is.na(df[[.var]]), ]

  df_denom <- unique(denom_df[, c(id, fup_var, strata), drop = FALSE])
  if (!is.null(occ_var)) {
    df_num <- unique(subset(dfii, dfii[[occ_var]] == "Y")[, c(id, .var, occ_var, occ_dy, strata), drop = FALSE])
    df_num[["n_events"]] <- 1L
    if (any(duplicated(df_num[[id]]))) {
      stop("Input dataset must uniquely identify one record per subject/.var/occ_var.")
    }
  } else {
    if (count_multiple_events) {
      df_num <- dfii[, c(id, .var, strata), drop = FALSE]
      df_num[["n_events"]] <- ave(as.character(df_num[[id]]), as.character(df_num[[id]]), FUN = length)
      df_num <- unique(df_num)
    } else {
      df_num <- unique(dfii[, c(id, .var, strata), drop = FALSE])
      df_num[["n_events"]] <- 1L
    }
  }
  df_num[["n_events"]] <- as.numeric(df_num[["n_events"]])
  ### construct modified fup var subjects not in numerator - use fup_var from df_denom
  df_denom[["mod_fup_var"]] <- df_denom[[fup_var]]

  if (!is.null(occ_var)) {
    ### add vars from df_num onto df_denom
    df_denom <- merge(df_denom, df_num, by = c(id, strata), all.x = TRUE)

    # subjects in numerator dataset, use occ_dy variable/365.25
    id_to_update <- df_denom[[id]] %in% df_num[[id]]
    df_denom[id_to_update, "mod_fup_var"] <- df_denom[id_to_update, occ_dy] / 365.25
  }

  return(list(df_denom = df_denom, df_num = df_num))
}

# helper: get n and T per stratum for one arm's df/denom
.get_stratum_stats <- function(strata, strata_levels, df_arm, denom_arm,
                               levii, .var, id, fup_var, occ_var, occ_dy, count_multiple_events) {
  lapply(strata_levels, function(stratum) {
    df_s <- df_arm[df_arm[[strata]] == stratum, , drop = FALSE]
    denom_s <- denom_arm[denom_arm[[strata]] == stratum, , drop = FALSE]
    eair_dfs <- h_get_eair_df(
      levii = levii,
      df = df_s,
      denom_df = denom_s,
      .var = .var,
      id = id,
      fup_var = fup_var,
      occ_var = occ_var,
      occ_dy = occ_dy,
      count_multiple_events = count_multiple_events,
      strata = strata
    )
    list(
      n  = sum(eair_dfs$df_num[["n_events"]]),
      py = sum(eair_dfs$df_denom[["mod_fup_var"]])
    )
  })
}

extract_x_stats <- function(list_with_stats, stat_nms) {
  sapply(
    stat_nms,
    function(stat) {
      sapply(
        names(list_with_stats),
        function(x) {
          list_with_stats[[x]][[stat]]
        },
        simplify = FALSE
      )
    },
    simplify = FALSE
  )
}

#' Get default statistical methods and their associated formats, labels, and indent modifiers
#'
#' @description `r lifecycle::badge('stable')`
#'
#' Utility functions to get valid statistic methods for different method groups
#' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers
#' (`.indent_mods`). This utility is used across `junco`, but some of its working principles can be
#' seen in [tern::analyze_vars()].
#'
#' @param stats (`character`)\cr statistical methods to return defaults for.
#' @param levels_per_stats (named `list` of `character` or `NULL`)\cr named list where the name of each element is a
#'   statistic from `stats` and each element is the levels of a `factor` or `character` variable (or variable name),
#'   each corresponding to a single row, for which the named statistic should be calculated for. If a statistic is only
#'   calculated once (one row), the element can be either `NULL` or the name of the statistic. Each list element will be
#'   flattened such that the names of the list elements returned by the function have the format `statistic.level` (or
#'   just `statistic` for statistics calculated for a single row). Defaults to `NULL`.
#'
#' @details
#' Current choices for `type` are `counts` and `numeric` for [tern::analyze_vars()] and affect `junco_get_stats()`.
#'
#' @note
#' These defaults are experimental because we use the names of functions to retrieve the default
#' statistics. This should be generalized in groups of methods according to more reasonable groupings.
#'
#' These functions have been modified from the `tern` file `utils_default_stats_formats_labels.R`.
#' This file contains `junco` specific wrappers of functions called within the `afun` functions,
#' in order to point to `junco` specific default statistics, formats and labels.
#'
#' @name default_stats_formats_labels
NULL

#' @describeIn default_stats_formats_labels Get statistics available for a given method
#'   group (analyze function). To check available defaults see `junco_default_stats` list.
#'
#' @param method_groups (`character`)\cr indicates the statistical method group (`junco` analyze function)
#'   to retrieve default statistics for. A character vector can be used to specify more than one statistical
#'   method group.
#' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. If custom statistical
#'   functions are used, `stats_in` needs to have them in too.
#' @param custom_stats_in (`character`)\cr custom statistics to add to the default statistics.
#' @param add_pval (`flag`)\cr should `'pval'` (or `'pval_counts'` if `method_groups` contains
#'   `'analyze_vars_counts'`) be added to the statistical methods?
#'
#' @return
#' * `junco_get_stats()` returns a `character` vector of statistical methods.
#'
#' @export
junco_get_stats <- function(
  method_groups = "analyze_vars_numeric",
  stats_in = NULL,
  custom_stats_in = NULL,
  add_pval = FALSE
) {
  tern_get_stats(
    method_groups = method_groups,
    stats_in = stats_in,
    custom_stats_in = custom_stats_in,
    add_pval = add_pval,
    tern_defaults = junco_default_stats
  )
}

#' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics.
#'   To check available defaults see list `junco_default_formats`.
#'
#' @param formats_in (named `vector`)\cr custom formats to use instead of defaults. Can be a character vector with
#'   values from [formatters::list_valid_format_labels()] or custom format functions. Defaults to `NULL` for any rows
#'   with no value is provided.
#'
#' @return
#' * `junco_get_formats_from_stats()` returns a named list of formats as strings or functions.
#'
#' @note Formats in `tern` or `junco` and `rtables` can be functions that take in the table cell value and
#'   return a string. This is well documented in `vignette('custom_appearance', package = 'rtables')`.
#'
#' @export
junco_get_formats_from_stats <- function(stats, formats_in = NULL, levels_per_stats = NULL) {
  tern_get_formats_from_stats(
    stats = stats,
    formats_in = formats_in,
    levels_per_stats = levels_per_stats,
    tern_defaults = junco_default_formats
  )
}

#' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics.
#'   To check for available defaults see list `junco_default_labels`.
#'
#' @param labels_in (named `character`)\cr custom labels to use instead of defaults. If no value is provided, the
#'   variable level (if rows correspond to levels of a variable) or statistic name will be used as label.
#' @param label_attr_from_stats (named `list`)\cr if `labels_in = NULL`, then this will be used instead. It is a list
#'   of values defined in statistical functions as default labels. Values are ignored if `labels_in` is provided or `''`
#'   values are provided.
#'
#' @return
#' * `junco_get_labels_from_stats()` returns a named list of labels as strings.
#'
#' @export
junco_get_labels_from_stats <- function(
  stats,
  labels_in = NULL,
  levels_per_stats = NULL,
  label_attr_from_stats = NULL
) {
  tern_get_labels_from_stats(
    stats = stats,
    labels_in = labels_in,
    levels_per_stats = levels_per_stats,
    label_attr_from_stats = label_attr_from_stats,
    tern_defaults = junco_default_labels
  )
}

#' @describeIn default_stats_formats_labels Get label attributes from statistics list.
#' @param x_stats (`list`)\cr with the statistics results.
#' @keywords internal
get_label_attr_from_stats <- function(x_stats) {
  sapply(x_stats, obj_label)
}

#' @describeIn default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.
#'
#' @param indents_in (named `integer`)\cr custom row indent modifiers to use instead of defaults. Defaults to `0L` for
#'   all values.
#'
#' @return
#' * `junco_get_indents_from_stats()` returns a named list of indentation modifiers as integers. By default all of the
#'   indentations will be zero.
#'
#' @export
junco_get_indents_from_stats <- function(stats, indents_in = NULL, levels_per_stats = NULL) {
  # For statistics still remaining without default indentation after looking in junco_default_indents, use
  # indentation 0 as default.
  remaining_stats <- setdiff(stats, names(junco_default_indents))
  default_indents <- c(
    junco_default_indents,
    as.list(rep(0L, length(remaining_stats))) |>
      stats::setNames(remaining_stats)
  )

  tern_get_indents_from_stats(
    stats = stats,
    indents_in = indents_in,
    levels_per_stats = levels_per_stats,
    tern_defaults = default_indents
  )
}

#' @describeIn default_stats_formats_labels
#' Format statistics results according to format specifications.
#'
#' @inheritParams rtables::in_rows .cell_footnotes .row_footnotes
#' @return
#' * `format_stats()` returns the correspondingly formatted [rtables::in_rows()] result.
#'
#' @export
format_stats <- function(x_stats,
                         method_groups,
                         stats_in,
                         formats_in,
                         labels_in,
                         indents_in,
                         .cell_footnotes = list(NULL),
                         .row_footnotes = list(NULL)) {
  .stats <- junco_get_stats(method_groups, stats_in = stats_in)

  .formats <- junco_get_formats_from_stats(stats = .stats, formats_in = formats_in)

  label_attr <- get_label_attr_from_stats(x_stats)
  .labels <- junco_get_labels_from_stats(stats = .stats, labels_in = labels_in, label_attr_from_stats = label_attr)
  .labels <- .unlist_keep_nulls(.labels)

  .indent_mods <- junco_get_indents_from_stats(stats = .stats, indents_in = indents_in)
  .indent_mods <- .unlist_keep_nulls(.indent_mods)

  x_stats <- x_stats[.stats]

  in_rows(
    .list = x_stats,
    .formats = .formats,
    .names = names(.labels),
    .labels = .labels,
    .indent_mods = .indent_mods,
    .cell_footnotes = .cell_footnotes,
    .row_footnotes = .row_footnotes
  )
}


# junco_default_stats -----------------------------------------------------------

#' @describeIn default_stats_formats_labels Named list of available statistics by method group for `junco`.
#'
#' @format
#' * `junco_default_stats` is a named list of available statistics, with each element
#'   named for their corresponding statistical method group.
#'
#' @export
junco_default_stats <- list(
  cmhrms = c("pval"),
  event_free = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "event_free_ci"),
  kaplan_meier = c("quantiles_lower", "median_ci_3d", "quantiles_upper", "range_with_cens_info"),
  odds_ratio = c("n_tot", "or_ci", "pval"),
  proportion_diff = c("diff", "diff_ci", "diff_est_ci"),
  relative_risk = c("rel_risk_ci", "pval"),
  diff_means = c(
    "diff_means_n1",
    "diff_means_n2",
    "diff_means_est",
    "diff_means_se",
    "diff_means_est_se",
    "diff_means_ci",
    "diff_means_est_ci"
  ),
  estimate_proportion = c("n_prop", "prop_ci"),
  summarize_ancova_j = c(
    "n",
    "sum",
    "mean",
    "sd",
    "se",
    "mean_sd",
    "mean_se",
    "mean_ci",
    "mean_sei",
    "mean_sdi",
    "mean_ci_3d",
    "mean_pval",
    "median",
    "mad",
    "median_ci",
    "median_ci_3d",
    "quantiles",
    "iqr",
    "range",
    "min",
    "max",
    "median_range",
    "cv",
    "geom_mean",
    "geom_sd",
    "geom_mean_sd",
    "geom_mean_ci",
    "geom_cv",
    "geom_mean_ci_3d",
    "n_fit",
    "lsmean",
    "lsmean_se",
    "lsmean_ci",
    "lsmean_diff",
    "lsmean_diff_ci",
    "lsmean_diff_with_ci",
    "pval"
  ),
  summarize_mmrm = c(
    "n",
    "adj_mean_se",
    "adj_mean_ci",
    "adj_mean_est_ci",
    "diff_mean_se",
    "diff_mean_ci",
    "diff_mean_est_ci",
    "change",
    "p_value"
  ),
  tabulate_lsmeans = c(
    "n",
    "adj_mean_se",
    "adj_mean_ci",
    "adj_mean_est_ci",
    "diff_mean_se",
    "diff_mean_ci",
    "diff_mean_est_ci",
    "change",
    "p_value"
  ),
  tabulate_rbmi = c(
    "adj_mean_se",
    "adj_mean_ci",
    "diff_mean_se",
    "diff_mean_ci",
    "change",
    "p_value",
    "additional_title_row"
  ),
  test_proportion_diff = c("pval"),
  a_freq_j = c(
    "n_altdf",
    "n_df",
    "n_rowdf",
    "n_parentdf",
    "denom",
    "count",
    "count_unique",
    "count_unique_fraction",
    "count_unique_denom_fraction",
    "unique_fraction"
  ),
  a_patyrs_j = c("patyrs"),
  a_eair100_j = c(
    "n_event", "person_years",
    "eair", "n_eair", "eair_ci", "eair_est_ci", "eair_n", "eair_n_py",
    "eair_diff_est_ci", "eair_diff_est", "eair_diff_ci"
  ),
  a_eair_strat_j = c(
    "n_event_total", "person_years_total",
    "eair_strat", "n_eair_strat", "eair_strat_ci", "eair_strat_est_ci",
    "eair_strat_n", "eair_strat_n_py",
    "eair_strat_diff_est_ci", "eair_strat_diff_est", "eair_strat_diff_ci"
  ),
  analyze_vars_numeric_j = c(
    tern_default_stats["analyze_vars_numeric"][[1]],
    "mean_diff_with_ci"
  ),
  aval_chg_col1 = c("count_denom_frac", "count_frac", "count"),
  aval_chg_col23 = c("mean_ci_3d", "mean_diff_with_ci"),
  a_sum_ratio_j = c(
    "sum", "sum_unique", "ratio", "ratio_unique"
  )
)

not_in_junco <- setdiff(names(tern_default_stats), names(junco_default_stats))
junco_default_stats <- c(junco_default_stats, tern_default_stats[not_in_junco])


# junco_default_formats ---------------------------------------------------------
junco_default_formats_start <- c(
  adj_mean_se = jjcsformat_xx("xx.xx (xx.xxx)"),
  adj_mean_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  adj_mean_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  change = "xx.x%",
  cv = jjcsformat_xx("xx.xx"),
  diff = jjcsformat_xx("xx.x"),
  diff_ci = jjcsformat_xx("(xx.x, xx.x)"),
  diff_est_ci = jjcsformat_xx("xx.x (xx.x, xx.x)"),
  diff_mean_se = jjcsformat_xx("xx.xx (xx.xxx)"),
  diff_mean_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  diff_mean_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  #
  # s_diff_means stats:
  diff_means_n1 = jjcsformat_xx("xx."),
  diff_means_n2 = jjcsformat_xx("xx."),
  diff_means_est = jjcsformat_xx("xx.xx"),
  diff_means_se = jjcsformat_xx("xx.xxx"),
  diff_means_est_se = jjcsformat_xx("xx.xx (xx.xxx)"),
  diff_means_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  diff_means_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  # end s_diff_means stats.
  #
  event_free_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  event_free_rate = jjcsformat_xx("xx.xx"),
  geom_sd = jjcsformat_xx("xx.xxx"),
  geom_se = jjcsformat_xx("xx.xxx"),
  geom_mean_sd = jjcsformat_xx("xx.xx (xx.xxx)"),
  geom_mean_se = jjcsformat_xx("xx.xx (xx.xxx)"),
  geom_cv = jjcsformat_xx("xx.xx"),
  geom_mean = jjcsformat_xx("xx.xx"),
  geom_mean_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  hr = jjcsformat_xx("xx.xx"),
  hr_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  hr_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  iqr = jjcsformat_xx("xx.xx"),
  quantiles_upper = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  quantiles_lower = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  lsmean = jjcsformat_xx("xx.xx"),
  lsmean_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  lsmean_diff = jjcsformat_xx("xx.xx"),
  lsmean_diff_with_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  lsmean_diff_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  lsmean_se = jjcsformat_xx("xx.xx (xx.xxx)"),
  mad = jjcsformat_xx("xx.xx"),
  mean = jjcsformat_xx("xx.xx"),
  mean_sd = jjcsformat_xx("xx.xx (xx.xxx)"),
  mean_se = jjcsformat_xx("xx.xx (xx.xxx)"),
  mean_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  mean_diff_with_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  mean_pval = jjcsformat_pval_fct(0),
  median = jjcsformat_xx("xx.xx"),
  median_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  median_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  median_range = jjcsformat_xx("xx.xx (xx.x, xx.x)"),
  n = jjcsformat_xx("xx."),
  n_tot = jjcsformat_xx("xx."),
  n_tot_events = jjcsformat_xx("xx."),
  or_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
  pt_at_risk = "xx",
  pval = jjcsformat_pval_fct(0),
  pvalue = jjcsformat_pval_fct(0),
  p_value = jjcsformat_pval_fct(0),
  quantiles = jjcsformat_xx("xx.xx, xx.xx"),
  range = jjcsformat_xx("xx.x, xx.x"),
  range_with_cens_info = jjcsformat_range_fct("xx.xx"),
  rate_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  rate_se = jjcsformat_xx("xx.xx"),
  rate_diff_ci_3d = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  rel_risk_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
  sd = jjcsformat_xx("xx.xxx"),
  se = jjcsformat_xx("xx.xxx"),
  n_altdf = "xx",
  n_df = "xx",
  n_rowdf = "xx",
  n_parentdf = "xx",
  denom = "xx",
  count = "xx",
  count_unique = "xx",
  count_fraction = jjcsformat_count_fraction,
  count_fraction_fixed_dp = jjcsformat_count_fraction,
  count_unique_fraction = jjcsformat_count_fraction,
  count_unique_denom_fraction = jjcsformat_count_denom_fraction,
  count_denom_frac = jjcsformat_count_denom_fraction,
  count_frac = jjcsformat_count_fraction,
  unique_fraction = jjcsformat_fraction,
  rr_ci_3d = jjcsformat_xx("xx.x (xx.x, xx.x)"),
  patyrs = jjcsformat_xx("xx.x"),
  eair = jjcsformat_xx("xx.x"),
  eair_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  eair_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  eair_diff_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  eair_diff_est = jjcsformat_xx("xx.xx"),
  eair_diff_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  n_eair = jjcsformat_xx("xx (xx.x)"),
  eair_n = jjcsformat_xx("xx.x (xx)"),
  eair_n_py = jjcsformat_xx("xx.x (xx/xx.x)"),
  n_event = "xx",
  person_years = jjcsformat_xx("xx.xx"),
  eair_strat = jjcsformat_xx("xx.x"),
  n_event_total = "xx",
  person_years_total = jjcsformat_xx("xx.xx"),
  n_eair_strat = jjcsformat_xx("xx (xx.x)"),
  eair_strat_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
  eair_strat_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  eair_strat_diff_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)"),
  total_subject_years = jjcsformat_xx("xx.x (xx.x)"),
  n_fit = "xx",
  unique = jjcsformat_count_fraction,
  sum = "xx",
  sum_unique = "xx",
  ratio = jjcsformat_xx("xx (xx.x%)"),
  ratio_unique = jjcsformat_xx("xx (xx.x%)")
)

tern_formats_only <- setdiff(names(tern_default_formats), names(junco_default_formats_start))
#' @describeIn default_stats_formats_labels Named vector of default formats for `junco`.
#'
#' @format
#' * `junco_default_formats` is a named vector of available default formats, with each element
#'   named for their corresponding statistic.
#'
#' @export
junco_default_formats <- c(junco_default_formats_start, tern_default_formats[tern_formats_only])

# junco_default_labels ----------------------------------------------------------
junco_default_labels_start <- c(
  additional_title_row = "Additional Title",
  adj_mean_se = "Adjusted Mean (SE)",
  adj_mean_est_ci = "Adjusted Mean (CI)",
  diff = "Difference in Response rate (%)",
  diff_mean_se = "Difference in Adjusted Means (SE)",
  diff_mean_est_ci = "Difference in Adjusted Means (CI)",
  #
  # s_diff_means stats:
  diff_means_n1 = "Difference in Means Sample Size (Group 1)",
  diff_means_n2 = "Difference in Means Sample Size (Group 2)",
  diff_means_est = "Difference in Means",
  diff_means_se = "Difference in Means SE",
  diff_means_est_se = "Difference in Means (SE)",
  diff_means_ci = "Difference in Means CI",
  diff_means_est_ci = "Difference in Means (CI)",
  # end s_diff_means stats.
  #
  hr = "Hazard Ratio",
  mean_sd = "Mean (SD)",
  median = "Median",
  median_range = "Median (min, max)",
  n_tot = "Total n",
  n_tot_events = "Total events",
  pval = "p-value",
  pvalue = "p-value",
  p_value = "p-value",
  range = "Min, max",
  range_with_cens_info = "Min, max",
  n_altdf = "N",
  n_df = "N",
  n_rowdf = "N",
  n_parentdf = "N",
  denom = "N",
  patyrs = "Patient years",
  person_years = "Person years",
  eair_strat = "Stratified EAIR",
  n_event_total = "n (events)",
  person_years_total = "Total person-years",
  n_eair_strat = "n (Stratified EAIR)",
  total_subject_years = "Total treatment (subject years)",
  sum = "Sum",
  sum_unique = "Sum (unique)",
  ratio = "Ratio",
  ratio_unique = "Ratio (unique)"
)
tern_labels_only <- setdiff(names(tern_default_labels), names(junco_default_labels_start))

#' @describeIn default_stats_formats_labels Named `character` vector of default labels for `junco`.
#'
#' @format
#' * `junco_default_labels` is a named `character` vector of available default labels, with each element
#'   named for their corresponding statistic.
#'
#' @export
junco_default_labels <- c(junco_default_labels_start, tern_default_labels[tern_labels_only])

#' @describeIn default_stats_formats_labels Named `integer` vector of default indents for `junco`.
#'
#' @format
#' * `junco_default_indents` is a named `integer` vector of available default indents, with each element
#'   named for their corresponding statistic. Only indentations different from zero need to be
#'   recorded here.
#'
#' @export
junco_default_indents <- c(
  additional_title_row = 1L,
  adj_mean_ci = 1L,
  adj_mean_est_ci = 1L,
  change = 1L,
  diff_ci = 1L,
  diff_mean_ci = 1L,
  diff_mean_est_ci = 1L,
  #
  # s_diff_means stats:
  diff_means_n1 = 0L,
  diff_means_n2 = 0L,
  diff_means_est = 0L,
  diff_means_se = 0L,
  diff_means_est_se = 0L,
  diff_means_ci = 0L,
  diff_means_est_ci = 0L,
  # end s_diff_means stats.
  #
  hr_ci = 1L,
  or_ci = 1L,
  pval = 1L,
  p_value = 1L,
  rate_se = 1L,
  rate_ci = 1L,
  rel_risk_ci = 1L
)

#' @name jjcs_num_formats
#'
#' @title Numeric Formatting Function
#'
#' @description
#' Formatting setter for selected numerical statistics.
#'
#' @param d (`numeric`)\cr precision of individual values
#' @param cap (`numeric`)\cr cap to numerical precision (d > cap --
#' will use precision as if cap was specified as precision)
#'
#' @return list:
#'  - fmt : named vector with formatting function (jjcsformat_xx) for numerical stats: range, median, mean_sd, sd
#'  - spec : named vector with formatting specifications for numerical stats: range, median, mean_sd, sd
#' @export
#' @examples
#' P1_precision <- jjcs_num_formats(d = 0)$fmt
#' jjcs_num_formats(2)$fmt
#' jjcs_num_formats(2)$spec
jjcs_num_formats <- function(d, cap = 4) {
  fmt_xx <- function(d, cap) {
    prec <- NULL
    ### report as is
    if (is.na(d)) {
      return("xx")
    }
    checkmate::assertCount(d)

    ### set a cap to number of decimal precision
    d <- min(d, cap)
    if (d > 0) prec <- paste0(prec, paste0(rep("x", d), collapse = ""))
    if (d >= 0) prec <- paste0("xx.", prec)

    return(prec)
  }

  fmt_rng <- function(d, cap) {
    prec <- fmt_xx(d, cap = cap)
    fmt <- list()
    fmt$spec <- paste0(prec, ", ", prec)
    fmt$fmt <- jjcsformat_xx(fmt$spec)

    return(fmt)
  }

  fmt_median <- function(d, cap) {
    prec <- fmt_xx(d, cap = cap)
    fmt <- list()
    fmt$spec <- prec
    fmt$fmt <- jjcsformat_xx(fmt$spec)
    return(fmt)
  }

  fmt_meansd <- function(d, cap) {
    prec1 <- fmt_xx(d, cap = cap)
    prec2 <- fmt_xx(d + 1, cap = cap + 1)
    fmt <- list()
    fmt$spec <- paste0(prec1, " (", prec2, ")")
    fmt$fmt <- jjcsformat_xx(fmt$spec)
    return(fmt)
  }
  fmt_sd <- function(d, cap) {
    prec <- fmt_xx(d, cap)
    fmt <- list()
    fmt$spec <- prec
    fmt$fmt <- jjcsformat_xx(fmt$spec)
    return(fmt)
  }

  ## apply formats for each of the stats with appropriate d and cap
  xfmt_rng <- fmt_rng(d, cap = cap)
  xfmt_meansd <- fmt_meansd(d + 1, cap = cap + 1)
  xfmt_sd <- fmt_sd(d + 2, cap = cap + 2)
  xfmt_median <- fmt_median(d + 1, cap = cap + 1)

  fmts <- list()

  fmts$fmt <- c(range = xfmt_rng$fmt, mean_sd = xfmt_meansd$fmt, sd = xfmt_sd$fmt, median = xfmt_median$fmt)

  fmts$spec <- c(range = xfmt_rng$spec, mean_sd = xfmt_meansd$spec, sd = xfmt_sd$spec, median = xfmt_median$spec)

  return(fmts)
}

#' @keywords internal
invert_list <- function(x, simplify = FALSE) {
  stopifnot(is.list(x), !is.null(names(x)))
  vals <- unlist(x, use.names = FALSE)
  parents <- rep(names(x), lengths(x))
  out <- split(parents, vals)
  if (simplify && all(lengths(out) == 1L)) {
    out <- unlist(out, use.names = TRUE)
  }
  out
}

#' @keywords internal
all_stats_junco_method <- junco_default_stats

#' @keywords internal
all_stats_junco_stat <- invert_list(all_stats_junco_method)

#' @keywords internal
junco_def_d_all_start <- get_fmt_details(junco_default_formats)

# add method_group information
#' @keywords internal
junco_def_d_all_start$method_group <- all_stats_junco_stat[junco_def_d_all_start$stat]

#' @keywords internal
str_not_d_style <- c(
  "xx%", "xx.x%", "xx.xx%", "xx.xxx%", "(N=xx)", ">999.9", ">999.99", "x.xxxx | (<0.0001)",
  "N=xx (xx%)", "xx (xx%)", "xx (xx.%)", "xx (xx.x%)", "xx (xx.xx%)", "xx. (xx.%)", "xx.x (xx.x%)", "xx.xx (xx.xx%)",
  "xx / xx (xx.%)", "xx / xx (xx.x%)", "xx / xx (xx.xx%)",
  "xx.", "xx"
)

#' @keywords internal
stat_not_d_style <- c(
  "additional_title_row",
  "all",
  "count",
  "count_fraction",
  "count_fraction_fixed_dp",
  "count_unique",
  "count_unique_denom_fraction",
  "count_unique_fraction",
  "denom",
  "diff_means_n1",
  "diff_means_n2",
  "eair",
  "eair_ci",
  "eair_diff_ci",
  "eair_diff_est",
  "eair_diff_est_ci",
  "eair_n",
  "eair_strat_diff_est_ci",
  "eair_strat_est_ci",
  "eair_strat_n",
  "eair_strat_n_py",
  "eair_est_ci",
  "eair_n_py",
  "eair_strat",
  "eair_strat_ci",
  "event_free_ci",
  "event_free_rate",
  "event_free_rate_3d",
  "fraction",
  "hr",
  "hr_ci",
  "hr_ci_3d",
  "lr_stat_df",
  "mean_pval",
  "n",
  "n_altdf",
  "n_blq",
  "n_df",
  "n_eair",
  "n_eair_strat",
  "n_event",
  "n_event_total",
  "n_events",
  "n_fit",
  "n_parentdf",
  "n_patients",
  "n_prop",
  "n_rate",
  "n_rowdf",
  "n_rsp",
  "n_tot",
  "n_tot_events",
  "n_unique",
  "nonunique",
  "or",
  "or_ci",
  "p_value",
  "patyrs",
  "person_years",
  "person_years_total",
  "prop",
  "prop_ci",
  "pt_at_risk",
  "pval",
  "pval_inter",
  "pvalue",
  "rate",
  "rate_ci",
  "rate_diff",
  "rate_diff_ci",
  "rate_diff_ci_3d",
  "rate_ratio",
  "rate_ratio_ci",
  "rate_se",
  "rel_risk_ci",
  "riskdiff",
  "rr_ci_3d",
  "total_subject_years",
  "unique",
  "unique_count",
  "ztest_pval"
)


#' @keywords internal
target_d_style <- within(junco_def_d_all_start, {
  target_d <- fun_fact == "jjcsformat_xx" |
    (fmt_package == "formatters" & !(str %in% str_not_d_style))

  target_d[stat %in% stat_not_d_style] <- FALSE

  # d = 1 corresponds to default
  str_d <- ifelse(
    target_d,
    gsub("xx.x", "xx.d", str, fixed = TRUE),
    ifelse(!is_fun, str, NA)
  )
})

# proposed default formats for d-style processing ----------------
junco_def_d_all1 <- target_d_style[["fun"]]
junco_def_d_all1[!is.na(target_d_style[["str_d"]])] <-
  target_d_style[["str_d"]][!is.na(target_d_style[["str_d"]])]
names(junco_def_d_all1) <- target_d_style[["stat"]]

#' @describeIn fmt_spec_d Named vector of default format specification using d-style notation.
#'
#' @format  * `junco_def_d_all` Used as default input vector for argument `fmt_d_def`
#' in functions `fmt_spec_single_d()`, `fmt_spec_df_d()` and `fmt_spec_var_d()`
#' (corresponds to the named vector of with default available formats [junco_default_formats]
#'  with d = 1)
#' @export
junco_def_d_all <- junco_def_d_all1

# proposed alternative 1 ----------------
junco_def_d_alt1 <- junco_def_d_all
junco_def_d_alt1[!is.na(target_d_style[["str_d"]])] <-
  gsub("xx.dxx", "xx.dx", junco_def_d_alt1[!is.na(target_d_style[["str_d"]])], fixed = TRUE)


#' @describeIn fmt_spec_d Alternative vector of d-style specification defaults.
#' @format * `junco_def_d_alt1` Alternative vector of d-style specification defaults.
#' @export
junco_def_d_alt1 <- junco_def_d_alt1

# proposed alternative 2 ----------------
junco_def_d_alt2 <- junco_def_d_alt1
junco_def_d_alt2[!is.na(target_d_style[["str_d"]])] <-
  gsub("xx.dx", "xx.d", junco_def_d_alt2[!is.na(target_d_style[["str_d"]])], fixed = TRUE)


#' @describeIn fmt_spec_d Another alternative vector of d-style specification defaults.
#' @format * `junco_def_d_alt2` Another alternative vector of d-style specification defaults.
#' @export
junco_def_d_alt2 <- junco_def_d_alt2

#' Helper function to normalize p-value categories
#'
#' @description Converts a named list of p-value category bounds into a matrix
#'   and retains the category labels in their supplied order.
#'
#' @param pvalcat (`named list`)\cr A non-empty named list. Each element must be
#'   a numeric vector of length two specifying the lower and upper bounds of a
#'   p-value category.
#'
#' @return A named `list` with the following elements:
#'
#' * `bounds`: a two-column numeric matrix of lower and upper category bounds.
#' * `cats`: a character vector of category labels.
#'
#' @keywords internal
h_normalize_pvalcat <- function(pvalcat) {
  checkmate::assert_list(pvalcat, min.len = 1, names = "unique")
  checkmate::assert_character(names(pvalcat), any.missing = FALSE, unique = TRUE)
  checkmate::assert_true(all(nzchar(names(pvalcat))))

  bounds <- lapply(pvalcat, function(x) {
    checkmate::assert_numeric(x, len = 2, any.missing = FALSE, finite = TRUE)
    checkmate::assert_true(x[1] <= x[2])
    x
  })

  list(
    bounds = matrix(unlist(bounds, use.names = FALSE), ncol = 2, byrow = TRUE),
    cats = names(pvalcat)
  )
}

#' Categorize p-values
#'
#' @description Assigns each p-value to a category defined by a named list of
#'   lower and upper bounds.
#'
#' @details Categories are evaluated in the order supplied by `pvalcat`. Bounds
#'   are lower-inclusive and upper-exclusive, except that the upper bound of
#'   the final category is inclusive. P-values that do not fall in a category,
#'   including missing values, are returned as `NA_character_`.
#'
#' @param p (`numeric`)\cr A vector of p-values to categorize. Missing values are
#'   permitted.
#' @param pvalcat (`named list`)\cr A non-empty named list of p-value category
#'   bounds. See [h_normalize_pvalcat()] for the required structure.
#'
#' @return A character vector of category labels, with one element per value in
#'   `p`.
#'
#' @examples
#' pvalcat <- list(
#'   "<0.001" = c(0, 0.001),
#'   "0.001 to <0.05" = c(0.001, 0.05),
#'   ">=0.05" = c(0.05, 1)
#' )
#'
#' categorize_pval(c(0, 0.001, 0.049, 0.05, 1, NA), pvalcat)
#' @export
categorize_pval <- function(p, pvalcat) {
  checkmate::assert_numeric(p, any.missing = TRUE)
  checkmate::assert_list(pvalcat, min.len = 1, names = "unique")

  info <- h_normalize_pvalcat(pvalcat)
  bounds <- info$bounds
  cats <- info$cats
  last_row <- nrow(bounds)

  vapply(
    p,
    function(x) {
      if (is.na(x)) {
        return(NA_character_)
      }

      idx <- which(
        bounds[, 1] <= x &
          (x < bounds[, 2] | (seq_len(last_row) == last_row & x <= bounds[, 2]))
      )
      if (length(idx) == 0) {
        return(NA_character_)
      }
      cats[idx[1]]
    },
    FUN.VALUE = character(1)
  )
}

#' `ANCOVA` Analysis
#'
#' Performs the `ANCOVA` analysis, separately for each visit.
#'
#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `ANCOVA` analysis.
#'   The following elements need to be included as character vectors and match corresponding columns
#'   in `data`:
#'
#'   - `response`: the response variable.
#'   - `covariates`: the additional covariate terms (might also include interactions).
#'   - `id`: the subject ID variable (not really needed for the computations but for internal logistics).
#'   - `arm`: the treatment group variable (factor).
#'   - `visit`: the visit variable (factor).
#'
#'   Note that the `arm` variable is by default included in the model, thus should not be part of `covariates`.
#' @param data (`data.frame`)\cr with all the variables specified in
#'   `vars`. Records with missing values in any independent variables
#'   will be excluded.
#' @param conf_level (`proportion`)\cr confidence level of the interval.
#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
#'
#' @return A `tern_model` object which is a list with model results:
#'
#'   - `fit`: A list with a fitted [stats::lm()] result for each visit.
#'   - `mse`: Mean squared error, i.e. variance estimate, for each visit.
#'   - `df`: Degrees of freedom for the variance estimate for each visit.
#'   - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
#'        The attribute `weights` savse the settings used (`weights_emmeans`).
#'   - `vars`: The variable list.
#'   - `labels`: Corresponding list with variable labels extracted from `data`.
#'   - `ref_level`: The reference level for the arm variable, which is always the first level.
#'   - `treatment_levels`: The treatment levels for the arm variable.
#'   - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
#'
#' @export
#' @examples
#' library(mmrm)
#'
#' fit <- fit_ancova(
#'   vars = list(
#'     response = "FEV1",
#'     covariates = c("RACE", "SEX"),
#'     arm = "ARMCD",
#'     id = "USUBJID",
#'     visit = "AVISIT"
#'   ),
#'   data = fev_data,
#'   conf_level = 0.9,
#'   weights_emmeans = "equal"
#' )
#'
fit_ancova <- function(
  vars = list(response = "AVAL", covariates = c(), arm = "ARM", visit = "AVISIT", id = "USUBJID"),
  data,
  conf_level = 0.95,
  weights_emmeans = "proportional") {
  labels <- h_labels(vars, data)

  arm_levels <- levels(data[[vars$arm]])
  ref_level <- arm_levels[1]
  trt_levels <- arm_levels[-1]
  visit_levels <- levels(data[[vars$visit]])
  grid <- list(
    factor(arm_levels, levels = arm_levels),
    factor(rep(visit_levels, each = length(arm_levels)), levels = visit_levels)
  ) |>
    stats::setNames(c(vars$arm, vars$visit)) |>
    as.data.frame()
  checkmate::assert_disjunct(vars$arm, vars$covariates)
  covariates_part <- paste(vars$covariates, collapse = " + ")
  formula <- if (covariates_part != "") {
    stats::as.formula(paste0(vars$response, " ~ ", covariates_part, " + ", vars$arm))
  } else {
    stats::as.formula(paste0(vars$response, " ~ ", vars$arm))
  }
  results_by_visit <- Map(
    data = split(data, data[[vars$visit]]),
    grid = split(grid, grid[[vars$visit]]),
    f = function(data, grid) {
      fit <- stats::lm(formula = formula, data = data)
      summary_fit <- summary(fit)
      emmeans_res <- h_get_emmeans_res(fit, vars = vars["arm"], weights = weights_emmeans)
      estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
      estimates[[vars$visit]] <- grid[[vars$visit]]
      estimates <- estimates[, c(vars$arm, vars$visit,
                                 setdiff(names(estimates), c(vars$arm, vars$visit))), drop = FALSE]
      contrasts <- h_get_spec_visit_estimates(
        emmeans_res,
        specs = list(
          coefs = "trt.vs.ctrl",
          grid = grid[-1, ] # Without the reference level row.
        ),
        conf_level = conf_level,
        tests = TRUE,
        ref = ref_level
      )
      relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
      contrasts <- merge(contrasts, relative_reduc_df, by = c(vars$arm, vars$visit), sort = FALSE)
      list(fit = fit, estimates = estimates, contrasts = contrasts, mse = summary_fit$sigma^2, df = summary_fit$df[2])
    }
  )
  lsmeans <- structure(
    list(
      estimates = do.call(rbind, c(lapply(results_by_visit, "[[", "estimates"), make.row.names = FALSE)),
      contrasts = do.call(rbind, c(lapply(results_by_visit, "[[", "contrasts"), make.row.names = FALSE))
    ),
    weights = weights_emmeans
  )
  results <- list(
    fit = lapply(results_by_visit, "[[", "fit"),
    mse = do.call(c, lapply(results_by_visit, "[[", "mse")),
    df = do.call(c, lapply(results_by_visit, "[[", "df")),
    lsmeans = lsmeans,
    vars = vars,
    labels = labels,
    ref_level = ref_level,
    treatment_levels = trt_levels,
    conf_level = conf_level
  )
  class(results) <- "tern_model"
  results
}

#' Cochran-Mantel-Haenszel Row Mean Scores test
#'
#' See <https://psiaims.github.io/CAMIS/Comp/r-sas_cmh.html> for a general comparison
#' overview between R and SAS.
#'
#' @inheritParams proposal_argument_convention
#'
#' @name cmhrms
#' @return
#' * `s_cmhrms_j` a single element list containing the p-value from row mean score test.
#' * `a_cmhrms_j` a `VerticalRowsSection` object (single row).
#' @order 1
NULL


#' @describeIn cmhrms Statistics function for the calculation of the p-value
#' based upon the row mean scores test.
#'
#' @export
#' @importFrom tern get_covariates
#' @order 3
#' @inheritParams proposal_argument_convention
#' @param variables (`list`)\cr list with arm and strata variable names.
#' @param collapse_combo (`logical`)\cr If TRUE, multiple arm levels from df
#'   will be combined into 1 level.
#'
s_cmhrms_j <- function(df, .var, .ref_group, .in_ref_col, ..., .df_row, variables, collapse_combo = FALSE) {
  checkmate::assert_list(variables)
  checkmate::assert_names(names(variables), must.include = "arm")

  colvar <- variables$arm
  if (collapse_combo && length(unique(df[[colvar]])) >= 2) {
    df[[colvar]] <- "Combined"
  }
  pwdf <- rbind(df, .ref_group)
  inputdf <- if (.in_ref_col) {
    # overall p-value -- however not needed on output?
    .df_row
  } else {
    # pairwise p-value
    pwdf
  }

  inputdf[[colvar]] <- as.character(inputdf[[colvar]])
  inputdf[[.var]] <- droplevels(factor(inputdf[[.var]]))

  strata <- variables$strata

  if (!is.null(strata) && length(strata) > 0) {
    var_list <- get_covariates(strata)
    assert_df_with_variables(.df_row, var_list)
  }
  strata_part <- paste(strata, collapse = " + ")
  formula <- if (strata_part != "") {
    stats::as.formula(paste0("Freq ~ ", colvar, " + ", .var, " | ", strata_part))
  } else {
    stats::as.formula(paste0("Freq ~ ", colvar, " + ", .var))
  }

  pval <- if (length(stats::na.omit(df[[.var]])) == 0 || length(unique(inputdf[[colvar]])) < 2) {
    numeric(0)
  } else {
    x_stats_cmh <-
      tryCatch(
        vcdExtra::CMHtest(
          formula,
          data = inputdf,
          overall = TRUE, details = TRUE
        ),
        error = function(cond) {
          message(conditionMessage(cond))
          # Choose a return value in case of error
          NULL
        }
      )

    x_stats_cmh <- if ((strata_part != "")) {
      x_stats_cmh$ALL$table
    } else {
      x_stats_cmh$table
    }

    rmeans <- x_stats_cmh["rmeans", , drop = TRUE]
    rmeans_pval <- rmeans[["Prob"]]

    if (is.null(x_stats_cmh)) {
      rmeans_pval <- NA
    }
    if (.in_ref_col) {
      numeric(0)
    } else {
      rmeans_pval
    }
  }
  list(pval = with_label(pval, "p-value"))
}

#' @describeIn cmhrms Formatted analysis function which is used as `afun`.
#' @export
#' @order 2
a_cmhrms_j <- function(df, .var,
                       ref_path,
                       .spl_context,
                       .ref_group,
                       .in_ref_col,
                       .df_row,
                       ...,
                       variables,
                       collapse_combo = TRUE,
                       .stats = NULL,
                       .formats = NULL,
                       .indent_mods = NULL,
                       .labels = NULL) {
  dots_extra_args <- list(...)
  ref <- get_ref_info(ref_path, .spl_context)
  .in_ref_col <- ref$in_ref_col

  x_stats <-
    .apply_stat_functions(
      default_stat_fnc = s_cmhrms_j,
      custom_stat_fnc_list = NULL,
      args_list = c(
        df = list(df),
        .var = .var,
        .ref_group = list(ref$ref_group),
        .in_ref_col = .in_ref_col,
        .df_row = list(.df_row),
        variables = list(variables),
        collapse_combo = collapse_combo,
        dots_extra_args
      )
    )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "cmhrms",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' @describeIn cmhrms Wrapper for the `afun` which can exclude
#'   row split levels from producing the analysis. These have to be specified in the
#'   `exclude_levels` argument, see `?do_exclude_split` for details.
#' @export
#' @order 3
a_cmhrms_j_with_exclude <- function(
  df,
  exclude_levels,
  .var,
  .spl_context,
  .ref_group,
  .in_ref_col,
  .df_row,
  ...,
  .stats = NULL,
  .formats = NULL,
  .indent_mods = NULL,
  .labels = NULL
) {
  if (do_exclude_split(exclude_levels, .spl_context)) {
    NULL
  } else {
    a_cmhrms_j(
      df = df,
      .var = .var,
      .spl_context = .spl_context,
      .ref_group = .ref_group,
      .in_ref_col = .in_ref_col,
      .df_row = .df_row,
      ...,
      .stats = .stats,
      .formats = .formats,
      .indent_mods = .indent_mods,
      .labels = .labels
    )
  }
}

#' @title Obtain reference group information from split context.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' `get_ref_info()` identifies a reference group defined by a column-split
#' path and returns both the reference-group data and an indicator of whether
#' the current column is the reference column. It is intended for use inside
#' custom `rtables` analysis functions.
#'
#' The reference group is specified using `ref_path`, which consists of
#' alternating column-split variable names and its corresponding levels.
#' For example, `c("SEX", "F", "ARM", "Placebo")` specifies the column-split
#' path where `SEX` is `"F"` and `ARM` is `"Placebo"`.
#'
#' @param ref_path (`character`) \cr
#'   Reference group specification as an `rtables` `colpath`; see Details.
#' @param .spl_context (`data.frame`) \cr
#'   Ancestor split-state information passed by `rtables`.
#' @param .var (`character(1)`) \cr
#'   The variable being analyzed; see [rtables::additional_fun_params].
#'   If supplied, the corresponding column is extracted from the reference-group
#'   data. If `NULL`, the complete reference-group data frame is returned.
#'
#' @return
#'   A list with the following elements:
#'   \itemize{
#'     \item `in_ref_col` (`logical(1)` or `NULL`) indicates whether the
#'       current column matches the reference path.
#'       This corresponds to `.in_ref_col` in [rtables::additional_fun_params].
#'     \item `ref_group` (`data.frame`, vector, or `NULL`) contains the
#'       observations belonging to the reference group. If `.var` is `NULL`,
#'       the complete data frame is returned; otherwise, the column specified
#'       by `.var` is returned.
#'       This corresponds to `.ref_group` in [rtables::additional_fun_params].
#'   }
#'
#'   If the reference path is not present in the current column-split
#'   hierarchy, both elements are `NULL`.
#'
#' @export
#'
#' @examples
#' dm <- DM
#' dm$colspan_trt <- factor(
#'   ifelse(dm$ARM == "B: Placebo", " ", "Active Study Agent"),
#'   levels = c("Active Study Agent", " ")
#' )
#' colspan_trt_map <- create_colspan_map(
#'   dm,
#'   non_active_grp = "B: Placebo",
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = "ARM"
#' )
#'
#' # A standard analysis function which uses a reference group.
#' standard_afun <- function(x, .ref_group, .in_ref_col) {
#'   diff_means <- if (isFALSE(.in_ref_col)) {
#'     mean(x) - mean(.ref_group)
#'   } else {
#'     NULL
#'   }
#'   in_rows(
#'     m = rcell(mean(x), label = "Mean"),
#'     dm = rcell(diff_means, label = "Difference in Means vs Placebo"),
#'     .formats = "xx.xx"
#'   )
#' }
#'
#' # The custom analysis function which can work with a global reference group.
#' result_afun <- function(x, ref_path, .spl_context, .var) {
#'   ref <- get_ref_info(ref_path, .spl_context, .var)
#'   standard_afun(x, .ref_group = ref$ref_group, .in_ref_col = ref$in_ref_col)
#' }
#'
#' ref_path <- c("colspan_trt", " ", "ARM", "B: Placebo")
#'
#' lyt <- basic_table() |>
#'   split_cols_by("colspan_trt", split_fun = trim_levels_to_map(colspan_trt_map)) |>
#'   split_cols_by("ARM") |>
#'   add_overall_col("Total") |>
#'   analyze("AGE", afun = result_afun, extra_args = list(ref_path = ref_path))
#'
#' build_table(lyt, dm)
get_ref_info <- function(ref_path, .spl_context, .var = NULL) {
  if (is.null(ref_path)) {
    return(NULL)
  }

  checkmate::assert_character(ref_path, min.len = 2L, names = "unnamed")
  checkmate::assert_true(length(ref_path) %% 2L == 0L)
  checkmate::assert_data_frame(.spl_context)
  checkmate::assert_subset("full_parent_df", colnames(.spl_context))
  checkmate::assert_string(.var, min.chars = 1L, null.ok = TRUE)

  # Compare column split names while ignoring split values.
  ref_path_val_pos <- seq(2L, length(ref_path), by = 2L)
  ref_path_any_val <- replace(ref_path, ref_path_val_pos, "*")
  if (!in_column(ref_path_any_val, .spl_context)) {
    return(list(in_ref_col = NULL, ref_group = NULL))
  }

  leaf_sc <- .spl_context[nrow(.spl_context), ]
  full_df <- leaf_sc$full_parent_df[[1L]]
  ref_path_vals <- paste(ref_path[ref_path_val_pos], collapse = ".")
  ref_group_rows <- leaf_sc[[ref_path_vals]][[1L]]
  ref_group <- full_df[ref_group_rows, ]
  if (!is.null(.var)) {
    ref_group <- ref_group[[.var]]
  }

  list(
    in_ref_col = in_column(ref_path, .spl_context),
    ref_group = ref_group
  )
}

#' @name  response_by_var
#' @title Count denom fraction statistic
#'
#' @description Derives the count_denom_fraction statistic (i.e., 'xx /xx (xx.x percent)' )\cr
#'              Summarizes the number of unique subjects with a response = 'Y' for a given variable
#'              (e.g. TRTEMFL) within each category of another variable (e.g., SEX).
#'              Note that the denominator is derived using input df,
#'              in order to have these aligned with alt_source_df, it is expected that df includes all subjects.
#'
#' @details This is an analysis function for use within `analyze`. Arguments
#'          `df`, `.var` will be populated automatically by rtables during
#'          the tabulation process.
#'
#' @param df           (`data.frame`)\cr Name of dataframe being analyzed.
#' @param labelstr     (`character vector`)\cr Custom label for the variable being analyzed.
#' @param .var         (`character`)\cr Name of the variable being analyzed. Records with non-missing
#'                     values will be counted in the denominator.
#' @param .N_col       (`numeric`)\cr The total for the current column.
#' @param resp_var     (`character`)\cr Name of variable, for which, records with a value of 'Y'
#'                     will be counted in the numerator.
#' @param id           (`character`)\cr Name of column in df which will have patient identifiers
#' @param .format      (`character`)\cr Format for the count/denominator/fraction output.
#' @param ...          Additional arguments passed to the function.
#' @examples
#' library(dplyr)
#'
#' ADAE <- data.frame(
#'   USUBJID = c(
#'     "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
#'     "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
#'   ),
#'   SEX_DECODE = c(
#'     "Female", "Female", "Male", "Female", "Male",
#'     "Female", "Male", "Female", "Male", "Female"
#'   ),
#'   TRT01A = c(
#'     "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
#'     "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
#'   ),
#'   TRTEMFL = c("Y", "Y", "N", "Y", "Y", "Y", "Y", "N", "Y", "Y")
#' )
#'
#' ADAE <- ADAE |>
#'   mutate(
#'     TRT01A = as.factor(TRT01A),
#'     SEX_DECODE = as.factor(SEX_DECODE)
#'   )
#'
#' lyt <- basic_table() |>
#'   split_cols_by("TRT01A") |>
#'   analyze(
#'     vars = "SEX_DECODE",
#'     var_labels = "Sex, n/Ns (%)",
#'     show_labels = "visible",
#'     afun = response_by_var,
#'     extra_args = list(resp_var = "TRTEMFL"),
#'     nested = FALSE
#'   )
#'
#' result <- build_table(lyt, ADAE)
#'
#' result
#' @return a `RowsVerticalSection` for use by the internal tabulation machinery of `rtables`
#' @export
response_by_var <- function(
  df,
  labelstr = NULL,
  .var,
  .N_col,
  resp_var = NULL,
  id = "USUBJID",
  .format = jjcsformat_count_denom_fraction,
  ...
) {
  # Derive statistics: xx / xx (xx.x%)

  if (is.null(resp_var)) {
    stop("afun response_by_var: resp_var cannot be NULL.")
  }

  resp_var_values <- unique(df[[resp_var]][!is.na(df[[resp_var]])])
  if (is.character(df[[resp_var]]) && any(is.na(df[[resp_var]])) && all(resp_var_values == "Y")) {
    stop(paste(
      "afun response_by_var: not clear if missing resp_var should be considered",
      "non-response. Please make it a factor with appropriate Y(/N) levels."
    ))
  }

  if (length(setdiff(resp_var_values, c("Y", "N"))) > 0) {
    stop("afun response_by_var: resp_var must contain only Y/N values.")
  }

  df <- df[!is.na(df[[.var]]), ]

  if ( # nolint start
    (is.factor(df[[resp_var]]) &&
      (identical(levels(df[[resp_var]]), c("Y", "N")) || identical(levels(df[[resp_var]]), c("N", "Y")))) ||
      is.character(df[[resp_var]])
  ) { # nolint end
    # missing values in resp_var should be excluded, not considered as not met response subject will then not
    # contribute to denominator
    df <- df[!is.na(df[[resp_var]]), ]
  }

  ## in other cases, missing values in resp_var will be considered not met response and subject will contribute to
  ## denominator
  varvec <- df[[.var]]

  # For group summaries, varvec will be a singular value, equal to the current split, whereas for afun summaries,
  # varvec will consist of all possible values of var.
  if (!is.null(labelstr)) {
    levs <- labelstr
  } else {
    levs <- if (is.factor(varvec)) levels(varvec) else unique(varvec)
  }

  fn <- function(levii) {
    dfii <- df[df[[.var]] == levii, ]

    den <- NROW(unique(dfii[, id]))
    num <- NROW(unique(dfii[dfii[[resp_var]] == "Y" & !is.na(dfii[[resp_var]]), id]))

    rcell(c(num * 1, den * 1, num * 1 / den), format = .format)
  }

  cls <- lapply(levs, fn)
  names(cls) <- levs

  # Hand off results to analyze

  in_rows(.list = cls)
}

#' @name a_summary_j
#'
#' @title Wrappers Around `tern::a_summary()` with Row Split Exclusion
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These wrappers around [tern::a_summary()] allow selected row split levels to
#' be excluded from producing the analysis.
#'
#' @details
#' [tern::a_summary()] is a formatted analysis function that computes summary
#' statistics for a single variable. In typical use within the [rtables]
#' framework, the analysis variable is first extracted from a data frame and
#' then passed to [tern::a_summary()] as a standalone vector.
#'
#' `a_summary_j_with_exclude()` extends this behavior by:
#' - accepting a data frame (`df`) as input,
#' - checking whether the current row split path should be excluded,
#' - returning `NULL` for excluded row split levels,
#' - extracting the analysis variable `.var` for all other row split levels,
#' - and passing the resulting vector to [tern::a_summary()].
#'
#' @inheritParams proposal_argument_convention
#' @param ... Additional arguments passed to [tern::a_summary()], excluding
#'   the `x` argument, which is constructed internally from `df[[.var]]`.
#'
#' @return
#' Returns the same type of object as [tern::a_summary()], or `NULL` when the
#' current row split path is excluded by `exclude_levels`.
#'
#' @seealso
#' [tern::a_summary()], [do_exclude_split()]
#'
NULL

#' @describeIn a_summary_j Analysis function which can exclude row split levels
#'   from producing the analysis. These have to be specified in the
#'   `exclude_levels` argument, see `?do_exclude_split` for details.
#'
#' @importFrom tern a_summary
#' @export
#'
#' @examples
#' df <- data.frame(
#'   USUBJID = 1:8,
#'   AVISIT = factor(rep(c("Baseline", "Week 1"), 4)),
#'   ARM = factor(rep(c("A", "B"), each = 4)),
#'   AVAL = c(1.2, 3, -1.5, 0.8, 3.5, 2, -1.1, 0.3)
#' )
#'
#' lyt <- basic_table() |>
#'   split_cols_by("ARM") |>
#'   split_rows_by("AVISIT") |>
#'   analyze(
#'     "AVAL",
#'     afun = a_summary_j_with_exclude,
#'     extra_args = list(exclude_levels = list(AVISIT = "Baseline"))
#'   )
#'
#' build_table(lyt, df)
a_summary_j_with_exclude <- function(
  df,
  .var,
  exclude_levels,
  .spl_context,
  ...
) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(.var)
  checkmate::assert_names(colnames(df), must.include = .var)

  if (do_exclude_split(exclude_levels, .spl_context)) {
    NULL
  } else {
    tern::a_summary(df[[.var]], ...)
  }
}

calc_one_visit_j <- function(datvec, statnm, visit, varnm, exclude_visits,
                             var_names = c("AVAL", "CHG", "BASE")) {
  checkmate::assert_string(statnm)
  checkmate::assert_choice(statnm, tern::get_stats(method_groups = "analyze_vars_numeric"))
  if ((varnm == var_names[2] || varnm == var_names[3]) && (visit %in% exclude_visits)) {
    stat <- list(NULL)
    names(stat) <- statnm
  } else {
    stats <- tern::s_summary(datvec)
    stat <- stats[statnm]
  }
  stat
}

#' @name column_stats
#' @title Statistics within the column space
#' @description
#' A function used for obtaining statistics within the columns of your table.
#' Used in change from baseline tables. This takes the visit names as its row labels.
#' @importFrom assertthat is.string
#' @param exclude_visits (`character vector`)\cr Vector of visit(s) for which you do not want the statistics displayed
#' in the baseline mean or change from baseline sections of the table.
#' @param var_names (`character vector`)\cr Vector of variable names to use instead of the default AVAL, CHG, BASE.
#' By default, the function expects these specific variable names in your data,
#' but you can customize them to match your dataset's column names.
#' @param .formats (named `character` or `list`)\cr formats for the statistics.
#' When set to `"default"` `formats_var` argument will be used for format setup.
#' @param formats_var (`string` or `NULL`)\cr `NULL` (the default) or the name of the list column containing named
#' lists of default formats to use. These will not override .formats (other than `"default"`).
#' @param exclude_visits Visits to exclude for the second/third part of the columns ("BASE", "CHG").
#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
#' @param df (`data.frame` or `tibble`)\cr dataset.
#' @param .var (`string`)\cr single variable name that is passed by `rtables`
#' @return An analysis function (for use with [rtables::analyze]) implementing
#'   the specified statistics.\cr
#'   Typically used in a layout that has been setup by [stats_in_cols_setup()]
#' @examples
#' # example code
#' library(dplyr)
#' advs <- ex_advs |>
#'   filter(AVISIT %in% toupper(c("Screening", "Baseline", "Week 1 Day 8", "Week 2 Day 15"))) |>
#'   mutate(AVISIT = droplevels(AVISIT)) |>
#'   filter(PARAMCD %in% c("DIABP", "SYSBP"))
#' advs_fmt <- tribble(
#'   ~PARAMCD, ~fmt_d,
#'   "DIABP", list(
#'     mean = "xx.xx", sd = "xx.xxx", se = "xx.xxx", median = "xx.xx",
#'     min = "xx.x", max = "xx.x", mean_sd = "xx.xx (xx.xxx)"
#'   ),
#'   "SYSBP", list(
#'     mean = "xx.x", sd = "xx.xx", se = "xx.xx", median = "xx.x",
#'     min = "xx.", max = "xx.", mean_sd = "xx.x (xx.xx)"
#'   )
#' )
#'
#' advs <- left_join(advs, advs_fmt)
#'
#' mysplitfun <- make_split_fun(
#'   post = list(stats_in_cols_setup())
#' )
#'
#' lyt <- basic_table() |>
#'   split_cols_by_multivar(
#'     c("AVAL", "BASE", "CHG"),
#'     varlabels = c("Visit Values", " ", "Change from Baseline")
#'   ) |>
#'   split_cols_by("STUDYID", split_fun = mysplitfun) |>
#'   split_rows_by("PARAM", split_fun = drop_split_levels) |>
#'   split_rows_by("ARMCD", labels_var = "ARM") |>
#'   analyze("AVISIT", afun = column_stats, extra_args = list(
#'     exclude_visits = toupper(c("Baseline", "Screening")),
#'     .formats = "default",
#'     formats_var = "fmt_d"
#'   ))
#' result <- build_table(lyt, advs, round_type = "sas")
#' head(result, 20)
#' @export
column_stats <- function(df, .var, .spl_context,
                         .formats = NULL,
                         formats_var = NULL,
                         exclude_visits = c("Baseline (DB)"),
                         var_names = c("AVAL", "CHG", "BASE")) {
  allcolsplvals <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
  statnm <- utils::tail(allcolsplvals, 1)
  varnm <- allcolsplvals[length(allcolsplvals) - 1]
  datvec <- df[[varnm]]
  datpervis <- split(datvec, df[[.var]]) ## ,var is AVISIT
  # derivation of statistics - current column - different rows for avisit
  stats_rows <- mapply(
    calc_one_visit_j,
    datvec = datpervis,
    visit = names(datpervis),
    MoreArgs = list(
      statnm = statnm,
      varnm = varnm,
      exclude_visits = exclude_visits,
      var_names = var_names
    )
  )
  # get appropriate format for statistic -
  if (identical(.formats, "default") && assertthat::is.string(formats_var)) {
    checkmate::assert_names(colnames(df), must.include = formats_var)
    myfmt <- df[[formats_var]][[1]][[statnm]]
  } else {
    .formats <- junco_get_formats_from_stats(
      stats = statnm,
      formats_in = .formats
    )
    myfmt <- .formats[[statnm]]
  }
  # inrows with appropriate formatting
  in_rows(
    .list = stats_rows,
    .names = names(datpervis),
    .formats = myfmt,
    .labels = names(datpervis)
  )
}

calc_N <- function(datvec, statnm, trt, varnm) {
  if (varnm != "AVAL") {
    return(NULL)
  }
  length(stats::na.omit(datvec))
}

#' Function factory to be used as Post-processing split function for setup of stats in column structure
#'
#' @description
#' This helper is designed to be used in the `post` argument of
#' [rtables::make_split_fun()] to expand a column facet (e.g. AVAL/BASE/CHG)
#' into the specific statistics to be analyzed for each subfacet. It returns a
#' split result instructing rtables which values/labels/subsets to create.
#'
#' Typical usage:
#'
#' -  construct a split function like `mysplitfun <- rtables::make_split_fun(post = list(stats_in_cols_setup()))`\cr
#' Then use `mysplitfun` in your table layout where you split columns by a
#' variable whose levels are one of "AVAL", "BASE", or "CHG" and want to
#' analyze different statistics for each.
#'
#' - column layout setup from
#' [rtables::split_cols_by_multivar()], followed by split_cols_by using `stats_in_cols_setup` in
#' conjunction with an analyze call with `afun` = [column_stats()]
#'
#' See examples for typical usage.
#'
#' @param stats_list `(list)` Named list with statistics to present for each variable.
#' Any statistic from tern::s_summary can be selected.
#' @param statlbls_list `` Named vector with labels to use for the statistic in column header.
#' If NULL, or a statistic name is not included, the default label for the statistic will be used.
#' @return A function that can be used inside [rtables::make_split_result()]
#'   statistics for the current column level.
#' @seealso [rtables::make_split_fun()], [rtables::make_split_result()].
#' @examples
#' # example code
#' library(dplyr)
#' advs <- ex_advs |>
#'   filter(AVISIT %in% toupper(c("Screening", "Baseline", "Week 1 Day 8", "Week 2 Day 15"))) |>
#'   mutate(AVISIT = droplevels(AVISIT))
#'
#' mysplitfun <- make_split_fun(
#'   post = list(stats_in_cols_setup())
#' )

#' lyt <- basic_table() |>
#'   split_cols_by_multivar(
#'     c("AVAL", "BASE", "CHG"),
#'     varlabels = c("Visit Values", " ", "Change from Baseline")
#'   ) |>
#'   split_cols_by("STUDYID", split_fun = mysplitfun) |>
#'   split_rows_by("PARAM") |>
#'   split_rows_by("ARMCD", labels_var = "ARM") |>
#'   analyze("AVISIT",
#'    afun = column_stats,
#'    extra_args = list(exclude_visits = toupper(c("Baseline", "Screening")))
#'   )
#' result <- build_table(lyt, advs, round_type = "sas")
#' head(result, 20)
#'
#' @export
stats_in_cols_setup <- function(
  stats_list = list(
    "AVAL" = c("n", "mean", "sd", "se", "median", "min", "max"),
    "BASE" = c("mean_sd"),
    "CHG" = c("n", "mean", "sd", "se", "median", "min", "max")
  ),
  statlbls_list = c(median = "Med", min = "Min", max = "Max", mean_sd = "Base Mean (SD)", n = "N")
) {
  function(ret, spl, fulldf, .spl_context) {
    all_expr <- expression(TRUE)
    colset <- .spl_context[nrow(.spl_context), "value"][[1]]

    if (!(colset %in% names(stats_list))) {
      stop(paste("something bad happened :(",
        paste0("incoming Variable to analyze (", colset, ")"),
        paste0("is not named in stats_list - names: ", paste0(names(stats_list), collapse = ", ")),
        sep = "\n"
      ))
    }

    stats <- stats_list[[colset]]
    statlbl <- junco_get_labels_from_stats(
      stats = stats,
      labels_in = statlbls_list,
      levels_per_stats = NULL,
      label_attr_from_stats = NULL
    )

    vals <- stats
    lbls <- statlbl[stats]
    datasplit <- rep(list(fulldf), length(stats))
    names(datasplit) <- stats
    subset_exprs <- rep(list(all_expr), length(stats))

    ret <- make_split_result(
      values = vals,
      labels = lbls,
      datasplit = datasplit,
      subset_exprs = subset_exprs
    )

    ret
  }
}

#' @name  a_coxph_hr
#' @title a_coxph_hr
#' @description a_coxph_hr `r lifecycle::badge("deprecated")` Use
#'   tern:::a_coxph_pairwise()` instead, and use `tern::coxph_pairwise()` as
#'   the layout-level wrapper.
#' @inheritParams odds_ratio
#' @export
a_coxph_hr <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  lifecycle::deprecate_stop(
    when = "0.1.7",
    what = "a_coxph_hr()",
    with = "tern:::a_coxph_pairwise()",
    details = "Use `tern:::coxph_pairwise()` as the layout-level wrapper."
  )
}

#' @name  s_coxph_hr
#' @title s_coxph_hr
#' @description s_coxph_hr `r lifecycle::badge("deprecated")` Use
#'  `tern::s_coxph_pairwise`  instead, and use `tern::coxph_pairwise()` as
#'   the layout-level wrapper.
#' @inheritParams odds_ratio
#' @keywords internal
s_coxph_hr <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  lifecycle::deprecate_stop(
    when = "0.1.7",
    what = "s_coxph_hr()",
    with = "tern:::s_coxph_pairwise()",
    details = "Use `tern:::coxph_pairwise()` as the layout-level wrapper."
  )
}

#' @title s_kaplan_meier
#' @description `r lifecycle::badge("deprecated")` Use [tern::s_surv_time()] instead.
#' @keywords internal
s_kaplan_meier <- function(df, .var, is_event, control = control_surv_time()) {
  lifecycle::deprecate_stop(
    when = "0.1.7",
    what = "s_kaplan_meier()",
    with = "tern::s_surv_time()",
    details = paste0(
      "Note: the label for `range_with_cens_info` has changed from ",
      "'Min, max' (junco) to 'Min - Max (with censoring)' (tern)."
    )
  )
}

#' @title a_kaplan_meier
#' @description `r lifecycle::badge("deprecated")` Use [tern::a_surv_time()] instead.
#' @param df (`data.frame`) input data.
#' @param .var (`string`) variable name.
#' @param ... additional arguments (ignored).
#' @param .stats (`character`) statistics to compute (ignored).
#' @param .formats (`list`) formats for statistics (ignored).
#' @param .labels (`list`) labels for statistics (ignored).
#' @param .indent_mods (`list`) indentation modifications (ignored).
#' @export
a_kaplan_meier <- function(df, .var, ..., .stats = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) {
  lifecycle::deprecate_stop(
    when = "0.1.7",
    what = "a_kaplan_meier()",
    with = "tern::a_surv_time()",
    details = paste0(
      "Note: the label for `range_with_cens_info` has changed from ",
      "'Min, max' (junco) to 'Min - Max (with censoring)' (tern)."
    )
  )
}


#' Create a `rbmi` ready cluster
#'
#' @description
#' `r lifecycle::badge("deprecated")` Use `rbmi::make_rbmi_cluster()` instead.
#'
#' @param cluster_or_cores (`integer` or `cluster object`)\cr
#' Number of parallel processes to use or an existing cluster to make use of
#' @param objects (`list`)\cr A named list of objects to export into the sub-processes
#' @param packages (`character vector`)\cr
#' A character vector of libraries to load in the sub-processes
#'
#' @return See `rbmi::make_rbmi_cluster()`.
#' @export
make_rbmi_cluster <- function(
  cluster_or_cores = 1,
  objects = NULL,
  packages = NULL
) {
  lifecycle::deprecate_stop(
    when = "0.1.7",
    what = "make_rbmi_cluster()",
    with = "rbmi::make_rbmi_cluster()"
  )
}

#' Parallelise Lapply
#'
#' @description
#' `r lifecycle::badge("deprecated")` This internal helper is no longer exported.
#' Use `rbmi::analyse()` directly.
#'
#' @param cl (`cluster object`)\cr Cluster created by [`parallel::makeCluster()`] or `NULL`
#' @param fun (`functions`)\cr Function to be run
#' @param x (`object`)\cr Object to be looped over
#' @param ... Extra arguments passed to `fun`
#' @return `list` of results of calling `fun` on elements of `x`.
par_lapply <- function(cl, fun, x, ...) {
  lifecycle::deprecate_stop(
    when = "0.1.6",
    what = "par_lapply()",
    details = "Use `rbmi::analyse()` directly."
  )
}

#' Analyse Multiple Imputed Datasets
#'
#' @description
#' This function takes multiple imputed datasets (as generated by
#' the impute() function from the rbmi package) and runs an analysis function on
#' each of them.
#'
#'
#' @details
#' This function works by performing the following steps:
#'
#' 1. Extract a dataset from the `imputations` object.
#' 2. Apply any delta adjustments as specified by the `delta` argument.
#' 3. Run the analysis function `fun` on the dataset.
#' 4. Repeat steps 1-3 across all of the datasets inside the `imputations`
#' object.
#' 5. Collect and return all of the analysis results.
#'
#' The analysis function `fun` must take a `data.frame` as its first
#' argument. All other options to [rbmi_analyse()] are passed onto `fun`
#'
#' @param imputations An `imputations` object as created by the impute() function from the rbmi package.
#' @param fun An analysis function to be applied to each imputed dataset. See details.
#' @param delta A `data.frame` containing the delta transformation to be applied to the imputed
#' datasets prior to running `fun`. See details.
#' @param ... Additional arguments passed onto `fun`.
#' @param cluster_or_cores (`numeric` or `cluster object`)\cr
#' The number of parallel processes to use when running this function. Can also be a
#' cluster object created by [`make_rbmi_cluster()`]. See the parallelisation section below.
#' @param .validate (`logical`)\cr
#' Should `imputations` be checked to ensure it conforms to the required format
#' (default = `TRUE`) ? Can gain a small performance increase if this is set to `FALSE` when
#' analysing a large number of samples.
#' @return An `analysis` object, as defined by `rbmi`, representing the desired
#' analysis applied to each of the imputed datasets in `imputations`.
#' @description
#' `r lifecycle::badge("deprecated")` Use `rbmi::analyse()` instead.
#'
#' @export
rbmi_analyse <- function(
  imputations,
  fun = rbmi_ancova,
  delta = NULL,
  ...,
  cluster_or_cores = 1,
  .validate = TRUE
) {
  lifecycle::deprecate_stop(
    when = "0.1.6",
    what = "rbmi_analyse()",
    with = "rbmi::analyse()"
  )
}

#' Proportion difference estimation
#'
#' The analysis function [a_proportion_diff_j()] can be used to create a layout element to estimate
#' the difference in proportion of responders within a studied population. The primary analysis variable,
#' `vars`, is a logical variable indicating whether a response has occurred for each record. See the `method`
#' parameter for options of methods to use when constructing the confidence interval of the proportion difference.
#' A stratification variable can be supplied via the `strata` element of the `variables` argument.
#'
#' @param df (`data.frame`)\cr input data frame.
#' @param .var (`string`)\cr name of the response variable.
#' @param ref_path (`character`)\cr path to the reference group.
#' @param .spl_context (`environment`)\cr split context environment.
#' @param ... Additional arguments passed to the statistics function.
#' @param .stats (`character`)\cr statistics to calculate.
#' @param .formats (`list`)\cr formats for the statistics.
#' @param .labels (`list`)\cr labels for the statistics.
#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
#' @param label (`string`)\cr label for the `diff_est_ci` statistic in [a_proportion_diff_j()]. Defaults to
#'   `"% Difference (conf_level CI)"`. Can be overridden by the caller.
#'
#' @name prop_diff
#' @order 1
#'
#' @note The [a_proportion_diff_j()] function has the `_j` suffix to distinguish it
#'   from [tern::a_proportion_diff()]. It is a thin wrapper around
#'   `tern::s_proportion_diff()` with the following additions:
#'
#'   * The `diff_est_ci` statistic (returned natively by tern since tern#1523) is
#'     relabelled with a shorter junco-style label (`"% Difference (conf_level CI)"`).
#'   * `ref_path` needs to be provided as extra argument to specify the control group column.
#'
NULL

#' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.
#'
#' @return
#' * `a_proportion_diff_j()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' nex <- 100
#' dta <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
#'   "grp" = sample(c("A", "B"), nex, TRUE),
#'   "f1" = sample(c("a1", "a2"), nex, TRUE),
#'   "f2" = sample(c("x", "y", "z"), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' l <- basic_table() |>
#'   split_cols_by(var = "grp") |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_proportion_diff_j,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     extra_args = list(
#'       conf_level = 0.9,
#'       method = "ha",
#'       ref_path = c("grp", "B")
#'     )
#'   )
#'
#' build_table(l, df = dta)
#' @export
#' @order 2
a_proportion_diff_j <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  conf_level = 0.95,
  label = paste0("% Difference (", f_conf_level(conf_level), ")"),
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = tern::s_proportion_diff,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      conf_level = conf_level,
      dots_extra_args
    )
  )

  # Relabel diff_est_ci with junco-style shorter label
  x_stats$diff_est_ci <- with_label(x_stats$diff_est_ci, label)

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "proportion_diff",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Difference test for two proportions
#'
#' @description `r lifecycle::badge('stable')`
#'
#' The analysis function [a_test_proportion_diff()] can be used to create a layout element to test
#' the difference between two proportions. The primary analysis variable, `vars`, indicates whether a
#' response has occurred for each record. See the `method` parameter for options of methods to use
#' to calculate the p-value. Additionally, a stratification variable can be supplied via the `strata`
#' element of the `variables` argument. The argument `alternative` specifies the direction of the
#' alternative hypothesis.
#'
#' @inheritParams proposal_argument_convention
#' @param ... Additional arguments passed to [tern::s_test_proportion_diff()], including:
#'   * `method` (`string`)\cr one of `chisq`, `cmh`, `cmh_wh`, `fisher` or `schouten`;
#'     specifies the test used to calculate the p-value.
#' @param .stats (`character`)\cr statistics to select for the table.
#'
#' @note This function has been forked from the `tern` package. Additional features are:
#'
#'   * Additional `ref_path` argument for flexible reference column path specification.
#'
#' @name prop_diff_test
#' @order 1
NULL

#' @describeIn prop_diff_test Formatted analysis function which is used as `afun`
#'
#' @return
#' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c("A", "B"), each = 50)),
#'   strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
#' )
#'
#' l <- basic_table() |>
#'   split_cols_by(var = "grp") |>
#'   analyze(
#'     vars = "rsp",
#'     afun = a_test_proportion_diff,
#'     show_labels = "hidden",
#'     extra_args = list(
#'       method = "cmh",
#'       variables = list(strata = "strata"),
#'       ref_path = c("grp", "B")
#'     )
#'   )
#'
#' build_table(l, df = dta)
#'
#' @export
#' @order 1
a_test_proportion_diff <- function(
  df,
  .var,
  ref_path,
  .spl_context,
  ...,
  .stats = NULL,
  .formats = NULL,
  .labels = NULL,
  .indent_mods = NULL
) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Obtain reference column information
  ref <- get_ref_info(ref_path, .spl_context)

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_test_proportion_diff,
    custom_stat_fnc_list = NULL,
    args_list = c(
      df = list(df),
      .var = .var,
      .ref_group = list(ref$ref_group),
      .in_ref_col = ref$in_ref_col,
      dots_extra_args
    )
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "test_proportion_diff",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Workaround statistics function to time point survival estimate with CI
#'
#' This is a workaround for [tern::s_surv_timepoint()], which adds a statistic
#' containing the time point specific survival estimate together with the
#' confidence interval.
#'
#' @inheritParams proposal_argument_convention
#'
#' @return
#' * `s_event_free` returns a list as returned by the [tern::s_surv_timepoint()]
#' with an additional three-dimensional statistic `event_free_ci` which
#' combines the `event_free_rate` and `rate_ci` statistics.
#' * `a_event_free` is analogous to [tern::a_surv_timepoint] but with the additional
#' three-dimensional statistic described above  available via `.stats`.
#'
#' @name event_free
#' @order 1
NULL

#' @describeIn event_free Statistics function which works like [tern::s_surv_timepoint()],
#'   the difference is that it returns the additional statistic `event_free_ci`.
#' @param time_point (`numeric`)\cr time point at which to estimate survival.
#' @param time_unit (`string`)\cr unit of time for the time point.
#' @param percent (`flag`)\cr whether to return in percent or not.
#' @export
#'
#' @examples
#' adtte_f <- tern::tern_ex_adtte |>
#'   dplyr::filter(PARAMCD == "OS") |>
#'   dplyr::mutate(
#'     AVAL = tern::day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#'
#' s_event_free(
#'   df = adtte_f,
#'   .var = "AVAL",
#'   time_point = 6,
#'   is_event = "is_event",
#'   time_unit = "month"
#' )
#' @order 3
s_event_free <- function(
  df,
  .var,
  time_point,
  time_unit,
  is_event,
  percent = FALSE,
  control = control_surv_timepoint()
) {
  checkmate::assert_string(time_unit, min.chars = 1L)
  start <- s_surv_timepoint(
    df = df,
    .var = .var,
    time_point = time_point,
    is_event = is_event,
    control = control
  )
  rates <- c(start$event_free_rate, start$rate_ci)
  if (!percent) rates <- rates / 100
  unit_label <- if (percent) "(%) " else ""
  c(
    start,
    list(
      event_free_ci = with_label(
        rates,
        paste0(
          time_point,
          "-",
          time_unit,
          " event-free rate ",
          unit_label,
          "(",
          obj_label(start$rate_ci),
          ")"
        )
      )
    )
  )
}

#' @describeIn event_free Formatted analysis function which is used as `afun`.
#'
#' @export
#' @order 2
#'
#' @examples
#' adtte_f <- tern::tern_ex_adtte |>
#'   dplyr::filter(PARAMCD == "OS") |>
#'   dplyr::mutate(
#'     AVAL = tern::day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#'
#' basic_table() |>
#'   split_cols_by(var = "ARMCD") |>
#'   analyze(
#'     vars = "AVAL",
#'     afun = a_event_free,
#'     show_labels = "hidden",
#'     na_str = tern::default_na_str(),
#'     extra_args = list(
#'       time_unit = "week",
#'       time_point = 3,
#'       is_event = "is_event"
#'     )
#'   ) |>
#'   build_table(df = adtte_f)
a_event_free <- function(df, .var, ..., .stats = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) {
  # Check for additional parameters to the statistics function
  dots_extra_args <- list(...)

  # Only support default stats, not custom stats
  .stats <- .split_std_from_custom_stats(.stats)$default_stats

  # Apply statistics function
  x_stats <- .apply_stat_functions(
    default_stat_fnc = s_event_free,
    custom_stat_fnc_list = NULL,
    args_list = c(df = list(df), .var = .var, dots_extra_args)
  )

  # Format according to specifications
  format_stats(
    x_stats,
    method_groups = "event_free",
    stats_in = .stats,
    formats_in = .formats,
    labels_in = .labels,
    indents_in = .indent_mods
  )
}

#' Get Visit Levels in Order Defined by Numeric Version
#'
#' @param visit_cat (`character`)\cr the categorical version.
#' @param visit_n (`numeric`)\cr the numeric version.
#'
#' @return The unique visit levels in the order defined by the numeric version.
#' @export
#'
#' @examples
#' get_visit_levels(
#'   visit_cat = c("Week 1", "Week 11", "Week 2"),
#'   visit_n = c(1, 5, 2)
#' )
get_visit_levels <- function(visit_cat, visit_n) {
  checkmate::assert_character(visit_cat)
  checkmate::assert_numeric(visit_n)

  nvar <- "n"
  visit_levels_df <- unique(data.frame(cat = visit_cat, n = visit_n))
  visit_levels_df <- visit_levels_df[order(visit_levels_df$n), ]
  visit_levels <- visit_levels_df$cat

  checkmate::assert_character(visit_levels, unique = TRUE)

  visit_levels
}

#' @name create_colspan_var
#' @title Creation of Column Spanning Variables
#' @description
#' A function used for creating a spanning variable for treatment groups.
#' @details
#' This function creates a spanning variable for treatment groups that is intended to
#' be used within the column space.
#' @param df (`data.frame`)\cr The name of the data frame in which the spanning variable is to be appended to
#' @param non_active_grp (`character`)\cr The value(s) of the treatments that represent the non-active or comparator
#' treatment groups
#' default value = c('Placebo')
#' @param non_active_grp_span_lbl (`character`)\cr The assigned value of the spanning
#' variable for the non-active or comparator
#' treatment groups
#' default value = ''
#' @param active_grp_span_lbl (`character`)\cr The assigned value of the spanning
#' variable for the active treatment group(s)
#' default value = 'Active Study Agent'
#' @param colspan_var (`character`)\cr The desired name of the newly created spanning variable
#' default value = 'colspan_trt'
#' @param trt_var (`character`)\cr The name of the treatment variable that is used to determine which
#' spanning treatment group value to apply.
#' default value = 'TRT01A'
#' @returns A data frame that contains the new variable as specified in colspan_var.
#' @rdname colspan_var
#' @export
#' @aliases create_colspan_var
#' @examples
#'
#' library(tibble)
#'
#' df <- tribble(
#'   ~TRT01A,
#'   "Placebo",
#'   "Active 1",
#'   "Active 2"
#' )
#'
#' df$TRT01A <- factor(df$TRT01A, levels = c("Placebo", "Active 1", "Active 2"))
#'
#' colspan_var <- create_colspan_var(
#'   df = df,
#'   non_active_grp = c("Placebo"),
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Treatment",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#'
#' colspan_var
create_colspan_var <- function(
  df,
  non_active_grp = c("Placebo"),
  non_active_grp_span_lbl = " ",
  active_grp_span_lbl = "Active Study Agent",
  colspan_var = "colspan_trt",
  trt_var = "TRT01A"
) {
  # Create a new column with the specified name using base R
  df[[colspan_var]] <- factor(
    ifelse(df[[trt_var]] %in% non_active_grp, non_active_grp_span_lbl, active_grp_span_lbl),
    levels = c(active_grp_span_lbl, non_active_grp_span_lbl)
  )

  return(df)
}

#' @name create_colspan_map
#' @title Creation of Column Spanning Mapping Dataframe
#' @description
#' A function used for creating a data frame containing the map that is compatible with
#' the rtables split function [rtables::trim_levels_to_map()].
#' @details
#' This function creates a data frame containing the map that is compatible with the rtables split function
#' [rtables::trim_levels_to_map()].
#' The levels of the specified trt_var variable will be stored within the trt_var variable
#' and the colspan_var variable will contain the corresponding spanning header value for each treatment group.
#' @inheritParams create_colspan_var
#' @param active_first (`logical`)\cr whether the active columns come first.
#' @returns A data frame that contains the map to be used with the rtables split function
#' [rtables::trim_levels_to_map()].
#' @seealso [rtables::add_combo_levels()] for creating split functions that utilize combination levels.
#' @rdname colspan_map
#' @export
#' @examples
#' library(tibble)
#'
#' df <- tribble(
#'   ~TRT01A,
#'   "Placebo",
#'   "Active 1",
#'   "Active 2"
#' )
#'
#' df$TRT01A <- factor(df$TRT01A, levels = c("Placebo", "Active 1", "Active 2"))
#'
#' colspan_map <- create_colspan_map(
#'   df = df,
#'   non_active_grp = c("Placebo"),
#'   non_active_grp_span_lbl = " ",
#'   active_grp_span_lbl = "Active Study Agent",
#'   colspan_var = "colspan_trt",
#'   trt_var = "TRT01A"
#' )
#'
#' colspan_map
create_colspan_map <- function(
  df,
  non_active_grp = c("Placebo"),
  non_active_grp_span_lbl = " ",
  active_grp_span_lbl = "Active Study Agent",
  colspan_var = "colspan_trt",
  trt_var = "TRT01A",
  active_first = TRUE
) {
  act_trtlv <- setdiff(levels(df[[trt_var]]), non_active_grp)
  act_map_df <- data.frame(a = active_grp_span_lbl, b = act_trtlv)
  nact_map_df <- data.frame(a = non_active_grp_span_lbl, b = non_active_grp)
  df <- if (active_first) {
    rbind(act_map_df, nact_map_df)
  } else {
    rbind(nact_map_df, act_map_df)
  }
  names(df) <- c(colspan_var, trt_var)

  return(df)
}

#' Simple Content Row Function to Count Rows
#'
#' @return a `VertalRowsSection` object (as returned by [rtables::in_rows()]
#'   containing counts from the data.
#' @keywords internal
c_row_counts <- function(df, labelstr, label_fstr) {
  in_rows(count = nrow(df), .formats = "xx", .labels = sprintf(label_fstr, labelstr))
}

#' Simple Content Row Function to Count Rows from Alternative Data
#' @return a `VertalRowsSection` object (as returned by [rtables::in_rows()]
#'   containing counts from the alt data.
#' @keywords internal
c_row_counts_alt <- function(df, labelstr, label_fstr, .alt_df) {
  c_row_counts(df = .alt_df, labelstr = labelstr, label_fstr = label_fstr)
}

#' Layout Creating Function Adding Row Counts
#'
#' This is a simple wrapper of [rtables::summarize_row_groups()] and the main
#' additional value is that we can choose whether we want to use the alternative
#' (usually ADSL) data set for the counts (default) or use the original data set.
#'
#' @inheritParams proposal_argument_convention
#' @param label_fstr (`string`)\cr a `sprintf` style format string.
#'   It can contain up to one `%s` which takes the current split value and
#'   generates the row label.
#' @param alt_counts (`flag`)\cr whether row counts should be taken from
#'   `alt_counts_df` (`TRUE`) or from `df` (`FALSE`).
#'
#' @return A modified layout where the latest row split now has a row group
#'   summaries (as created by [rtables::summarize_row_groups] for the counts).
#'
#' @export
#' @examples
#' basic_table() |>
#'   split_cols_by("ARM") |>
#'   add_colcounts() |>
#'   split_rows_by("RACE", split_fun = drop_split_levels) |>
#'   summarize_row_counts(label_fstr = "RACE value - %s") |>
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") |>
#'   build_table(DM, alt_counts_df = rbind(DM, DM))
#'
summarize_row_counts <- function(lyt, label_fstr = "%s", alt_counts = TRUE) {
  checkmate::assert_flag(alt_counts)

  summarize_row_groups(
    lyt,
    cfun = if (alt_counts) c_row_counts_alt else c_row_counts,
    extra_args = list(label_fstr = label_fstr)
  )
}

1		#' Helpers for Processing Least Square Means
2		#'
3		#' @inheritParams fit_mmrm_j
4		#' @param fit result of model fitting function, e.g. [mmrm::mmrm()] or [stats::lm()].
5		#' @param averages (`list`)\cr optional named list of visit levels which should be averaged
6		#' and reported along side the single visits.
7		#' @param weights (`string`)\cr argument from [emmeans::emmeans()], 'counterfactual' by default.
8		#' @param specs (`list`)\cr list of least square means specifications, with
9		#' elements `coefs` (coefficient list) and `grid` (corresponding `data.frame`).
10		#' @param emmeans_res (`list`)\cr initial `emmeans` result from [h_get_emmeans_res()].
11		#'
12		#' @name lsmeans_helpers
13		#' @keywords internal
14		NULL
15
16		#' @describeIn lsmeans_helpers partial matching of a set of `options` to a
17		#' character vector `x`. Here partial matching means that for each element of `x` we look for the
18		#' (first) element of `options` which is contained in the element of `x`. Then we return
19		#' the matched `options` in the same order as `x`.
20		#' @param options (`character`)\cr vector of options to match against `x`.
21		#' @param x (`character`)\cr vector of strings to be partially matched with `options`
22		h_partial_match <- function(options, x) {
23	7x	checkmate::assert_character(options)
24	7x	checkmate::assert_character(x)
25
26	7x	result <- sapply(x, function(xi) {
27	55x	matches <- vapply(
28	55x	options,
29	55x	function(opt) grepl(opt, xi, fixed = TRUE),
30	55x	logical(1)
31		)
32	55x	options[which(matches)[1L]]
33	7x	}, USE.NAMES = FALSE)
34	7x	if (anyNA(result)) {
35	1x	warning(
36	1x	"Some elements of 'x' did not match any of the 'options': ",
37	1x	paste(x[is.na(result)], collapse = ", ")
38		)
39		}
40	7x	result
41		}
42
43		#' @describeIn lsmeans_helpers returns a list with
44		#' `object` (`emmGrid` object containing `emmeans` results) and `grid`
45		#' (`data.frame` containing the (optional) subgroup, arm and the visit variables
46		#' together with the sample size `n` for each combination).
47		h_get_emmeans_res <- function(fit, vars, weights) {
48	60x	data_complete <- stats::model.frame(fit)
49	60x	checkmate::assert_data_frame(data_complete)
50	60x	checkmate::assert_list(vars)
51
52	60x	if (!is.null(vars$subgroup)) {
53	10x	checkmate::assert_factor(data_complete[[vars$subgroup]])
54		}
55	60x	emmeans_object <- emmeans::emmeans(
56	60x	fit,
57	60x	data = data_complete,
58	60x	specs = c(vars$subgroup, vars$visit, vars$arm),
59	60x	weights = weights
60		)
61
62		# Save grid with renamed number of subjects column.
63	60x	visit_arm_grid <- emmeans_object@grid
64	60x	wgt_index <- match(".wgt.", names(visit_arm_grid))
65	60x	names(visit_arm_grid)[wgt_index] <- "n"
66	60x	visit_arm_grid$n <- as.integer(visit_arm_grid$n)
67
68	60x	list(object = emmeans_object, grid = visit_arm_grid)
69		}
70
71		#' @describeIn lsmeans_helpers constructs average of visits specifications.
72		h_get_average_visit_specs <- function(emmeans_res, vars, averages, fit) {
73	12x	visit_grid <- emmeans_res$grid[[vars$visit]]
74	12x	model_frame <- stats::model.frame(fit)
75	12x	averages_list <- list()
76	12x	visit_vec <- n_vec <- c()
77	12x	if (!is.null(vars$subgroup)) {
78	3x	subgroup_grid <- emmeans_res$grid[[vars$subgroup]]
79	3x	subgroup_vec <- c()
80		}
81	12x	if (!is.null(vars$arm)) {
82	9x	arm_grid <- emmeans_res$grid[[vars$arm]]
83	9x	arm_vec <- c()
84		}
85	12x	for (i in seq_along(averages)) {
86	20x	average_label <- names(averages)[i]
87	20x	visits_average <- averages[[i]]
88	20x	checkmate::assert_subset(visits_average, choices = levels(visit_grid))
89	19x	which_visits_in_average <- visit_grid %in% visits_average
90	19x	average_coefs <- as.integer(which_visits_in_average) / length(visits_average)
91	19x	zero_coefs <- numeric(length = length(average_coefs))
92
93	19x	if (is.null(vars$arm) && is.null(vars$subgroup)) {
94	4x	averages_list[[average_label]] <- average_coefs
95	4x	visit_vec <- c(visit_vec, average_label)
96	4x	is_in_subset <- (model_frame[[vars$visit]] %in% visits_average)
97	4x	this_n <- length(unique(model_frame[is_in_subset, vars$id]))
98	4x	n_vec <- c(n_vec, this_n)
99	15x	} else if (is.null(vars$arm) && !is.null(vars$subgroup)) {
100	2x	for (this_subgroup in levels(subgroup_grid)) {
101	4x	this_coefs <- zero_coefs
102	4x	subgroup_average_label <- paste(this_subgroup, average_label, sep = ".")
103	4x	which_subgroup <- subgroup_grid == this_subgroup
104	4x	which_visits_and_subgroup <- which_visits_in_average & which_subgroup
105	4x	this_coefs[which_visits_and_subgroup] <- 1 / sum(which_visits_and_subgroup)
106	4x	averages_list[[subgroup_average_label]] <- this_coefs
107	4x	subgroup_vec <- c(subgroup_vec, this_subgroup)
108	4x	visit_vec <- c(visit_vec, average_label)
109	4x	is_in_subset <- (model_frame[[vars$subgroup]] == this_subgroup) &
110	4x	(model_frame[[vars$visit]] %in% visits_average)
111	4x	this_n <- length(unique(model_frame[is_in_subset, vars$id]))
112	4x	n_vec <- c(n_vec, this_n)
113		}
114	13x	} else if (!is.null(vars$arm) && is.null(vars$subgroup)) {
115	9x	for (this_arm in levels(arm_grid)) {
116	18x	this_coefs <- zero_coefs
117	18x	arm_average_label <- paste(this_arm, average_label, sep = ".")
118	18x	which_arm <- arm_grid == this_arm
119	18x	this_coefs[which_arm] <- average_coefs[which_arm]
120	18x	averages_list[[arm_average_label]] <- this_coefs
121	18x	arm_vec <- c(arm_vec, this_arm)
122	18x	visit_vec <- c(visit_vec, average_label)
123	18x	is_in_subset <- (model_frame[[vars$arm]] == this_arm) & (model_frame[[vars$visit]] %in% visits_average)
124	18x	this_n <- length(unique(model_frame[is_in_subset, vars$id]))
125	18x	n_vec <- c(n_vec, this_n)
126		}
127		} else {
128	4x	for (this_arm in levels(arm_grid)) {
129	8x	for (this_subgroup in levels(subgroup_grid)) {
130	16x	this_coefs <- zero_coefs
131	16x	arm_subgroup_average_label <- paste(this_subgroup, this_arm, average_label, sep = ".")
132	16x	which_arm <- arm_grid == this_arm
133	16x	which_subgroup <- subgroup_grid == this_subgroup
134	16x	which_visits_and_arm_and_subgroup <- which_visits_in_average & which_arm & which_subgroup
135	16x	this_coefs[which_visits_and_arm_and_subgroup] <- 1 / sum(which_visits_and_arm_and_subgroup)
136	16x	averages_list[[arm_subgroup_average_label]] <- this_coefs
137	16x	arm_vec <- c(arm_vec, this_arm)
138	16x	subgroup_vec <- c(subgroup_vec, this_subgroup)
139	16x	visit_vec <- c(visit_vec, average_label)
140	16x	is_in_subset <- (model_frame[[vars$arm]] == this_arm) &
141	16x	(model_frame[[vars$subgroup]] == this_subgroup) &
142	16x	(model_frame[[vars$visit]] %in% visits_average)
143	16x	this_n <- length(unique(model_frame[is_in_subset, vars$id]))
144	16x	n_vec <- c(n_vec, this_n)
145		}
146		}
147		}
148		}
149	11x	if (is.null(vars$arm) && is.null(vars$subgroup)) {
150	2x	averages_grid <- data.frame(visit = visit_vec, n = n_vec)
151	2x	names(averages_grid) <- c(vars$visit, "n")
152	9x	} else if (!is.null(vars$arm) && is.null(vars$subgroup)) {
153	6x	averages_grid <- data.frame(arm = arm_vec, visit = visit_vec, n = n_vec)
154	6x	names(averages_grid) <- c(vars$arm, vars$visit, "n")
155	3x	} else if (is.null(vars$arm) && !is.null(vars$subgroup)) {
156	1x	averages_grid <- data.frame(subgroup = subgroup_vec, visit = visit_vec, n = n_vec)
157	1x	names(averages_grid) <- c(vars$subgroup, vars$visit, "n")
158		} else {
159	2x	averages_grid <- data.frame(subgroup = subgroup_vec, arm = arm_vec, visit = visit_vec, n = n_vec)
160	2x	names(averages_grid) <- c(vars$subgroup, vars$arm, vars$visit, "n")
161		}
162	11x	list(coefs = averages_list, grid = averages_grid)
163		}
164
165		#' @describeIn lsmeans_helpers estimates least square means as a `data.frame`
166		#' given specifications.
167		#'
168		#' @note The difference here compared to the original tern.mmrm::h_get_spec_visit_estimates()
169		#' function is that additional arguments for [emmeans::contrast()] can be passed via the
170		#' dots (`...`) argument.
171		#' Once this has been added to the `tern.mmrm` package then its functions can be used instead.
172		#'
173		#' @param tests (`flag`)\cr whether to add test results to the estimates.
174		#' @param ... additional arguments for [emmeans::contrast()].
175		h_get_spec_visit_estimates <- function(emmeans_res, specs, conf_level, tests = FALSE, ...) {
176	58x	checkmate::assert_list(emmeans_res)
177	58x	checkmate::assert_list(specs)
178	58x	checkmate::assert_number(conf_level)
179	58x	checkmate::assert_flag(tests)
180
181	58x	conts <- emmeans::contrast(emmeans_res$object, specs$coefs, ...)
182	58x	cis <- stats::confint(conts, level = conf_level)
183	58x	res <- cbind(
184	58x	specs$grid,
185	58x	data.frame(estimate = cis$estimate, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL)
186		)
187	58x	if (tests) {
188	49x	conts_df <- as.data.frame(conts)
189	49x	res$t_stat <- conts_df$t.ratio
190	49x	res$p_value <- conts_df$p.value
191	49x	res$p_value_less <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = TRUE)
192	49x	res$p_value_greater <- stats::pt(conts_df$t.ratio, df = conts_df$df, lower.tail = FALSE)
193		}
194	58x	res
195		}
196
197		#' @describeIn lsmeans_helpers estimates least square means for single visits.
198		h_get_single_visit_estimates <- function(emmeans_res, conf_level) {
199	45x	checkmate::assert_list(emmeans_res)
200	45x	checkmate::assert_number(conf_level)
201
202	45x	cis <- stats::confint(emmeans_res$object, level = conf_level)
203	45x	cbind(
204	45x	emmeans_res$grid[, setdiff(names(emmeans_res$grid), "n"), drop = FALSE],
205	45x	data.frame(estimate = cis$emmean, se = cis$SE, df = cis$df, lower_cl = cis$lower.CL, upper_cl = cis$upper.CL),
206	45x	emmeans_res$grid[, "n", drop = FALSE]
207		)
208		}
209
210		#' @describeIn lsmeans_helpers constructs `data.frame` with
211		#' relative reduction vs. reference arm based on single visit estimates.
212		#' @param estimates (`data.frame`)\cr single visit least square mean estimates.
213		h_get_relative_reduc_df <- function(estimates, vars) {
214	42x	checkmate::assert_data_frame(estimates)
215	42x	checkmate::assert_list(vars)
216
217	42x	ref_arm_level <- estimates[[vars$arm]][1L]
218	42x	ref_estimates <- estimates[estimates[[vars$arm]] == ref_arm_level, c(vars$subgroup, vars$visit, "estimate")]
219	42x	names(ref_estimates)[names(ref_estimates) == "estimate"] <- "ref"
220	42x	result <- merge(
221	42x	estimates[estimates[[vars$arm]] != ref_arm_level, ],
222	42x	ref_estimates,
223	42x	by = c(vars$subgroup, vars$visit),
224	42x	sort = FALSE
225		)
226	42x	result$relative_reduc <- (result$ref - result$estimate) / result$ref
227	42x	result[, c(vars$subgroup, vars$visit, vars$arm, "relative_reduc")]
228		}
229
230		#' @describeIn lsmeans_helpers constructs single visit contrast specifications.
231		h_single_visit_contrast_specs <- function(emmeans_res, vars) {
232	25x	checkmate::assert_list(emmeans_res)
233	25x	checkmate::assert_list(vars)
234
235	25x	emmeans_res$grid$index <- seq_len(nrow(emmeans_res$grid))
236
237	25x	grid_by_subgroup_visit <- split(emmeans_res$grid, emmeans_res$grid[c(vars$subgroup, vars$visit)])
238
239	25x	arm_levels <- emmeans_res$object@levels[[vars$arm]]
240	25x	visit_levels <- emmeans_res$object@levels[[vars$visit]]
241	25x	if (!is.null(vars$subgroup)) {
242	7x	subgroup_levels <- emmeans_res$object@levels[[vars$subgroup]]
243		}
244	25x	ref_arm_level <- arm_levels[1L]
245	25x	zeros_coefs <- numeric(nrow(emmeans_res$grid))
246	25x	overall_list <- list()
247	25x	arm_vec <- visit_vec <- subgroup_vec <- c()
248	25x	for (j in seq_along(grid_by_subgroup_visit)) {
249	128x	this_grid <- grid_by_subgroup_visit[[j]]
250	128x	ref_index <- which(this_grid[[vars$arm]] == ref_arm_level)
251	128x	this_visit <- as.character(unique(this_grid[[vars$visit]]))
252	128x	checkmate::assert_true(length(this_visit) == 1L)
253	128x	if (!is.null(vars$subgroup)) {
254	56x	this_subgroup <- as.character(unique(this_grid[[vars$subgroup]]))
255	56x	checkmate::assert_true(length(this_subgroup) == 1L)
256		}
257	128x	this_ref_coefs <- zeros_coefs
258	128x	this_ref_coefs[this_grid$index[ref_index]] <- -1
259	128x	this_list <- list()
260	128x	for (i in seq_len(nrow(this_grid))[-ref_index]) {
261	172x	this_coefs <- this_ref_coefs
262	172x	this_coefs[this_grid$index[i]] <- 1
263	172x	this_arm <- as.character(this_grid[[vars$arm]][i])
264	172x	arm_vec <- c(arm_vec, this_arm)
265	172x	visit_vec <- c(visit_vec, this_visit)
266	172x	if (!is.null(vars$subgroup)) {
267	64x	subgroup_vec <- c(subgroup_vec, this_subgroup)
268		}
269	172x	this_label <- paste(this_arm, this_visit, sep = ".")
270	172x	if (!is.null(vars$subgroup)) {
271	64x	this_label <- paste(this_subgroup, this_label, sep = ".")
272		}
273	172x	this_list[[this_label]] <- this_coefs
274		}
275	128x	overall_list <- c(overall_list, this_list)
276		}
277
278	25x	grid <- data.frame(arm = arm_vec, visit = visit_vec)
279	25x	if (!is.null(vars$subgroup)) {
280	7x	grid[[vars$subgroup]] <- subgroup_vec
281		}
282	25x	names(grid) <- c(vars$arm, vars$visit, vars$subgroup)
283	25x	list(coefs = overall_list, grid = grid)
284		}
285
286		#' @describeIn lsmeans_helpers constructs average visits contrast specifications,
287		#' given the `specs` for single visit contrasts and the averages required.
288		h_average_visit_contrast_specs <- function(specs, averages, vars) {
289	9x	subgroup_arm_visit_grid <- specs$grid
290	9x	arm_levels <- unique(subgroup_arm_visit_grid[[vars$arm]])
291	9x	if (!is.null(vars$subgroup)) {
292	2x	subgroup_levels <- unique(subgroup_arm_visit_grid[[vars$subgroup]])
293		}
294	9x	subgroup_arm_visit_grid$index <- seq_len(nrow(subgroup_arm_visit_grid))
295	9x	grid_by_arm_subgroup <- split(subgroup_arm_visit_grid, subgroup_arm_visit_grid[c(vars$arm, vars$subgroup)])
296	9x	overall_list <- list()
297	9x	subgroup_vec <- arm_vec <- visit_vec <- c()
298	9x	for (j in seq_along(grid_by_arm_subgroup)) {
299	12x	this_grid <- grid_by_arm_subgroup[[j]]
300	12x	this_arm <- as.character(unique(this_grid[[vars$arm]]))
301	12x	checkmate::assert_true(length(this_arm) == 1L)
302	12x	if (!is.null(vars$subgroup)) {
303	4x	this_subgroup <- as.character(unique(this_grid[[vars$subgroup]]))
304	4x	checkmate::assert_true(length(this_subgroup) == 1L)
305		}
306	12x	for (i in seq_along(averages)) {
307	19x	average_label <- names(averages)[i]
308	19x	visits_average <- averages[[i]]
309	19x	which_visits_in_average <- this_grid[, vars$visit] %in% visits_average
310	19x	averaged_indices <- this_grid$index[which_visits_in_average]
311	19x	this_comb <- paste(this_arm, average_label, sep = ".")
312	19x	if (!is.null(vars$subgroup)) {
313	8x	this_comb <- paste(this_subgroup, this_comb, sep = ".")
314		}
315	19x	averaged_coefs <- colMeans(do.call(rbind, specs$coefs[averaged_indices]))
316	19x	overall_list[[this_comb]] <- averaged_coefs
317	19x	arm_vec <- c(arm_vec, this_arm)
318	19x	if (!is.null(vars$subgroup)) {
319	8x	subgroup_vec <- c(subgroup_vec, this_subgroup)
320		}
321	19x	visit_vec <- c(visit_vec, average_label)
322		}
323		}
324
325	9x	grid <- data.frame(arm = arm_vec, visit = visit_vec)
326	9x	if (!is.null(vars$subgroup)) {
327	2x	grid[[vars$subgroup]] <- subgroup_vec
328		}
329	9x	names(grid) <- c(vars$arm, vars$visit, vars$subgroup)
330
331	9x	list(coefs = overall_list, grid = grid)
332		}
333
334		#' @describeIn lsmeans_helpers Computes multiplicity-adjusted p-values and
335		#' confidence intervals for treatment-vs-reference contrasts using `multcomp`.
336		#' Returns a `data.frame` with the arm and visit grid columns plus
337		#' `p_value`, `p_value_less`, `p_value_greater`, `lower_cl`, and `upper_cl`.
338		#'
339		#' @param contrast_df (`numeric`)
340		#' Degrees of freedom from the unadjusted contrast estimates, used to derive
341		#' a single df for [emmeans::as.glht()].
342		h_get_mult_adj_estimates <- function(emmeans_res, vars, mult_adj, conf_level, contrast_df) {
343	5x	checkmate::assert_list(emmeans_res)
344	5x	checkmate::assert_list(vars)
345	5x	checkmate::assert_string(mult_adj)
346	5x	checkmate::assert_number(conf_level)
347	5x	checkmate::assert_numeric(contrast_df)
348
349	5x	emmeans_conts <- emmeans::contrast(
350	5x	emmeans_res$object,
351	5x	method = "trt.vs.ctrl",
352	5x	by = c(vars$subgroup, vars$visit),
353	5x	adjust = "none" # To avoid a note below. Does not matter.
354		)
355	5x	if (!requireNamespace("multcomp", quietly = TRUE)) {
356	!	stop("please install multcomp for multiplicity adjustment")
357		}
358	5x	glht_type <- switch(mult_adj,
359	5x	dunnett = "single-step",
360	5x	`step-down-dunnett` = "free"
361		)
362	5x	glht_test <- multcomp::adjusted(type = glht_type)
363		# We need a single df for the as.glht below. We give it explicitly to avoid a message.
364	5x	glht_df <- floor(mean(contrast_df, na.rm = TRUE))
365
366	5x	glht_conts_greater <- emmeans::as.glht(emmeans_conts, df = glht_df, alternative = "greater")
367	5x	glht_summary_greater <- summary(glht_conts_greater, test = glht_test)
368	5x	pvals_greater <- do.call(c, lapply(glht_summary_greater, function(x) x$test$pvalues))
369
370	5x	glht_conts_lower <- emmeans::as.glht(emmeans_conts, df = glht_df, alternative = "less")
371	5x	glht_summary_lower <- summary(glht_conts_lower, test = glht_test)
372	5x	pvals_lower <- do.call(c, lapply(glht_summary_lower, function(x) x$test$pvalues))
373
374	5x	glht_conts <- emmeans::as.glht(emmeans_conts, df = glht_df, alternative = "two.sided")
375	5x	glht_summary <- summary(glht_conts, test = glht_test)
376	5x	pvals <- do.call(c, lapply(glht_summary, function(x) x$test$pvalues))
377
378	5x	glht_ci <- stats::confint(glht_conts, level = conf_level)
379	5x	glht_ci_matrix <- do.call(rbind, lapply(glht_ci, function(x) x$confint[, c("lwr", "upr")]))
380
381	5x	arm_levels <- emmeans_res$object@levels[[vars$arm]]
382	5x	non_ref_arms <- arm_levels[-1L]
383
384	5x	grid <- emmeans_conts@grid
385	5x	arm_vec <- h_partial_match(options = non_ref_arms, x = as.character(grid$contrast))
386	5x	grid <- cbind(
387	5x	arm = arm_vec,
388	5x	grid[c(vars$subgroup, vars$visit)]
389		)
390	5x	names(grid) <- c(vars$arm, vars$subgroup, vars$visit)
391
392	5x	data.frame(
393	5x	grid,
394	5x	p_value = pvals,
395	5x	p_value_less = pvals_lower,
396	5x	p_value_greater = pvals_greater,
397	5x	lower_cl = glht_ci_matrix[, "lwr"],
398	5x	upper_cl = glht_ci_matrix[, "upr"],
399	5x	row.names = NULL
400		)
401		}

1		#' Odds ratio estimation
2		#'
3		#' @description `r lifecycle::badge('stable')`
4		#' A set of functions for Odds-Ratio (OR) calculation.
5		#'
6		#' @param method (`string`)\cr whether to use the correct (`'exact'`) calculation in the conditional likelihood or one
7		#' of the approximations, or the CMH method. See [survival::clogit()] for details.
8		#'
9		#' @param df (`data.frame`)\cr input data frame.
10		#' @param .var (`string`)\cr name of the response variable.
11		#' @param .df_row (`data.frame`)\cr data frame containing all rows.
12		#' @param ref_path (`character`)\cr path to the reference group.
13		#' @param .spl_context (`environment`)\cr split context environment.
14		#' @param ... Additional arguments passed to the statistics function.
15		#' @param .stats (`character`)\cr statistics to calculate.
16		#' @param .formats (`list`)\cr formats for the statistics.
17		#' @param .labels (`list`)\cr labels for the statistics.
18		#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
19		#' @param .ref_group (`data.frame`)\cr reference group data frame.
20		#' @param .in_ref_col (`logical`)\cr whether the current column is the reference column.
21		#' @param variables (`list`)\cr list with arm and strata variable names.
22		#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
23		#' @param groups_list (`list`)\cr list of groups for combination.
24		#'
25		#' @note
26		#' The `a_odds_ratio_j()` and `s_odds_ratio_j()` functions have the `_j` suffix to distinguish them
27		#' from [tern::a_odds_ratio()] and [tern::s_odds_ratio()], respectively.
28		#' These functions differ as follows:
29		#'
30		#' * Additional `method = 'cmh'` option is provided to calculate the Cochran-Mantel-Haenszel estimate.
31		#' * The p-value is returned as an additional statistic.
32		#'
33		#' Once these updates are contributed back to `tern`, they can later be replaced by the `tern` versions.
34		#'
35		#' @name odds_ratio
36		#' @order 1
37		NULL
38
39		#' @describeIn odds_ratio Statistics function which estimates the odds ratio
40		#' between a treatment and a control. A `variables` list with `arm` and `strata`
41		#' variable names must be passed if a stratified analysis is required.
42		#'
43		#' @param na_if_no_events (`flag`)\cr whether the point estimate should be `NA` if there
44		#' are no events in one arm. The p-value and confidence interval will still be computed.
45		#'
46		#' @return
47		#' * `s_odds_ratio_j()` returns a named list with the statistics `or_ci`
48		#' (containing `est`, `lcl`, and `ucl`), `pval` and `n_tot`.
49		#'
50		#' @examples
51		#' s_odds_ratio_j(
52		#' df = subset(dta, grp == "A"),
53		#' .var = "rsp",
54		#' .ref_group = subset(dta, grp == "B"),
55		#' .in_ref_col = FALSE,
56		#' .df_row = dta
57		#' )
58		#'
59		#' s_odds_ratio_j(
60		#' df = subset(dta, grp == "A"),
61		#' .var = "rsp",
62		#' .ref_group = subset(dta, grp == "B"),
63		#' .in_ref_col = FALSE,
64		#' .df_row = dta,
65		#' variables = list(arm = "grp", strata = "strata")
66		#' )
67		#'
68		#' s_odds_ratio_j(
69		#' df = subset(dta, grp == "A"),
70		#' method = "cmh",
71		#' .var = "rsp",
72		#' .ref_group = subset(dta, grp == "B"),
73		#' .in_ref_col = FALSE,
74		#' .df_row = dta,
75		#' variables = list(arm = "grp", strata = c("strata"))
76		#' )
77		#' @export
78		s_odds_ratio_j <- function(
79		df,
80		.var,
81		.ref_group,
82		.in_ref_col,
83		.df_row,
84		variables = list(arm = NULL, strata = NULL),
85		conf_level = 0.95,
86		groups_list = NULL,
87		na_if_no_events = TRUE,
88		method = c("exact", "approximate", "efron", "breslow", "cmh")) {
89	17x	checkmate::assert_flag(na_if_no_events)
90		# New: pval here
91	17x	y <- list(or_ci = list(), n_tot = list(), pval = list())
92	17x	method <- match.arg(method)
93	17x	one_group_empty <- nrow(df) == 0 \|\| nrow(.ref_group) == 0
94
95	17x	if (!.in_ref_col) {
96	15x	(assert_proportion_value)(conf_level)
97	15x	assert_df_with_variables(df, list(rsp = .var))
98	15x	assert_df_with_variables(.ref_group, list(rsp = .var))
99
100	15x	if (one_group_empty) {
101	1x	y <- list(or_ci = c(est = NA_real_, lcl = 0, ucl = Inf), n_tot = c(n_tot = nrow(df) + nrow(.ref_group)), pval = 1)
102	14x	} else if (is.null(variables$strata)) {
103	6x	data <- data.frame(
104	6x	rsp = c(.ref_group[[.var]], df[[.var]]),
105	6x	grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref"))
106		)
107	6x	y <- or_glm_j(data, conf_level = conf_level)
108		} else {
109	8x	assert_df_with_variables(.df_row, c(list(rsp = .var), variables))
110	8x	checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow", "cmh"), empty.ok = FALSE)
111		# The group variable prepared for stratified analysis must be synchronized with the combination groups
112		# definition.
113	8x	if (is.null(groups_list)) {
114	8x	ref_grp <- as.character(unique(.ref_group[[variables$arm]]))
115	8x	trt_grp <- as.character(unique(df[[variables$arm]]))
116	8x	grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)
117		} else {
118		# If more than one level in reference col.
119	!	reference <- as.character(unique(.ref_group[[variables$arm]]))
120	!	grp_ref_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(reference %in% x))
121	!	ref_grp <- names(groups_list)[grp_ref_flag]
122
123		# If more than one level in treatment col.
124	!	treatment <- as.character(unique(df[[variables$arm]]))
125	!	grp_trt_flag <- vapply(X = groups_list, FUN.VALUE = TRUE, FUN = function(x) all(treatment %in% x))
126	!	trt_grp <- names(groups_list)[grp_trt_flag]
127
128	!	grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)
129	!	grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)
130		}
131
132		# New: CMH method
133	8x	if (method == "cmh") {
134	7x	data <- data.frame(
135	7x	rsp = c(.ref_group[[.var]], df[[.var]]),
136	7x	grp = factor(rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "Not-ref")),
137	7x	strata = interaction(rbind(.ref_group[variables$strata], df[variables$strata]))
138		)
139
140	7x	y <- or_cmh(data, conf_level = conf_level)
141		} else {
142		# The reference level in `grp` must be the same as in the `rtables` column split.
143	1x	data <- data.frame(rsp = .df_row[[.var]], grp = grp, strata = interaction(.df_row[variables$strata]))
144
145	1x	y_all <- or_clogit_j(data, conf_level = conf_level, method = method)
146	1x	checkmate::assert_string(trt_grp)
147		# New: pval here
148	1x	checkmate::assert_subset(trt_grp, names(y_all$or_ci_pvals))
149	1x	y_or_ci_pval <- y_all$or_ci_pvals[[trt_grp]]
150	1x	y$or_ci <- y_or_ci_pval[c("est", "lcl", "ucl")]
151	1x	y$n_tot <- y_all$n_tot
152	1x	y$pval <- y_or_ci_pval["pval"]
153		}
154		}
155
156	15x	one_group_no_events <- (sum(.ref_group[[.var]]) == 0) \|\| (sum(df[[.var]]) == 0)
157	15x	if (na_if_no_events && one_group_no_events) {
158	4x	y$or_ci[["est"]] <- NA_real_
159		}
160
161	15x	na_because_sparse <- one_group_empty \|\| (na_if_no_events && one_group_no_events)
162	15x	if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && !na_because_sparse && method != "approximate") {
163	!	warning(
164	!	"Unable to compute the odds ratio estimate. Please try re-running the function with ",
165	!	"parameter `method` set to \"approximate\"."
166		)
167		}
168		}
169
170	17x	y$or_ci <- with_label(x = y$or_ci, label = paste0("Odds Ratio (", 100 * conf_level, "% CI)"))
171
172		# New: pval here
173	17x	y$pval <- unname(y$pval)
174
175	17x	y
176		}
177
178		#' @describeIn odds_ratio Formatted analysis function which is used as `afun`. Note that the
179		#' junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
180		#'
181		#' @return
182		#' * `a_odds_ratio_j()` returns the corresponding list with formatted [rtables::CellValue()].
183		#'
184		#' @examples
185		#' set.seed(12)
186		#' dta <- data.frame(
187		#' rsp = sample(c(TRUE, FALSE), 100, TRUE),
188		#' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
189		#' strata = factor(sample(c("C", "D"), 100, TRUE))
190		#' )
191		#'
192		#' a_odds_ratio_j(
193		#' df = subset(dta, grp == "A"),
194		#' .var = "rsp",
195		#' ref_path = c("grp", "B"),
196		#' .spl_context = data.frame(
197		#' cur_col_split = I(list("grp")),
198		#' cur_col_split_val = I(list(c(grp = "A"))),
199		#' full_parent_df = I(list(dta))
200		#' ),
201		#' .df_row = dta
202		#' )
203		#'
204		#'
205		#' l <- basic_table() \|>
206		#' split_cols_by(var = "grp") \|>
207		#' analyze(
208		#' "rsp",
209		#' afun = a_odds_ratio_j,
210		#' show_labels = "hidden",
211		#' extra_args = list(
212		#' ref_path = c("grp", "B"),
213		#' .stats = c("or_ci", "pval")
214		#' )
215		#' )
216		#'
217		#' build_table(l, df = dta)
218		#'
219		#' l2 <- basic_table() \|>
220		#' split_cols_by(var = "grp") \|>
221		#' analyze(
222		#' "rsp",
223		#' afun = a_odds_ratio_j,
224		#' show_labels = "hidden",
225		#' extra_args = list(
226		#' variables = list(arm = "grp", strata = "strata"),
227		#' method = "cmh",
228		#' ref_path = c("grp", "A"),
229		#' .stats = c("or_ci", "pval")
230		#' )
231		#' )
232		#'
233		#' build_table(l2, df = dta)
234		#' @export
235		#' @order 2
236		a_odds_ratio_j <- function(
237		df,
238		.var,
239		.df_row,
240		ref_path,
241		.spl_context,
242		...,
243		.stats = NULL,
244		.formats = NULL,
245		.labels = NULL,
246		.indent_mods = NULL) {
247		# Check for additional parameters to the statistics function
248	4x	dots_extra_args <- list(...)
249
250		# Only support default stats, not custom stats
251	4x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
252
253		# Obtain reference column information
254	4x	ref <- get_ref_info(ref_path, .spl_context)
255
256		# Apply statistics function
257	4x	x_stats <- .apply_stat_functions(
258	4x	default_stat_fnc = s_odds_ratio_j,
259	4x	custom_stat_fnc_list = NULL,
260	4x	args_list = c(
261	4x	df = list(df),
262	4x	.var = .var,
263	4x	.df_row = list(.df_row),
264	4x	.ref_group = list(ref$ref_group),
265	4x	.in_ref_col = ref$in_ref_col,
266	4x	dots_extra_args
267		)
268		)
269
270		# Format according to specifications
271	4x	format_stats(
272	4x	x_stats,
273	4x	method_groups = "odds_ratio",
274	4x	stats_in = .stats,
275	4x	formats_in = .formats,
276	4x	labels_in = .labels,
277	4x	indents_in = .indent_mods
278		)
279		}
280
281		#' Helper functions for odds ratio estimation
282		#'
283		#' @description `r lifecycle::badge('stable')`
284		#'
285		#' Functions to calculate odds ratios in [s_odds_ratio_j()].
286		#'
287		#' @inheritParams odds_ratio
288		#' @inheritParams proposal_argument_convention
289		#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally
290		#' `strata` for [or_clogit_j()].
291		#' @return A named `list` of elements `or_ci`, `n_tot` and `pval`.
292		#'
293		#' @seealso [odds_ratio]
294		#'
295		#' @name h_odds_ratio
296		NULL
297
298		#' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be
299		#' exactly 2 groups in `data` as specified by the `grp` variable.
300		#'
301		#' @examples
302		#' data <- data.frame(
303		#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),
304		#' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],
305		#' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],
306		#' stringsAsFactors = TRUE
307		#' )
308		#'
309		#' or_glm_j(data, conf_level = 0.95)
310		#'
311		#' @export
312		or_glm_j <- function(data, conf_level) {
313	7x	checkmate::assert_logical(data$rsp)
314	7x	(assert_proportion_value)(conf_level)
315	7x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
316	7x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
317
318	7x	data$grp <- as_factor_keep_attributes(data$grp)
319	7x	assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
320	7x	formula <- stats::as.formula("rsp ~ grp")
321	7x	model_fit <- stats::glm(formula = formula, data = data, family = stats::binomial(link = "logit"))
322
323		# Note that here we need to discard the intercept.
324	7x	or <- exp(stats::coef(model_fit)[-1])
325	7x	or_ci <- exp(stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE])
326
327	7x	values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
328	7x	n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")
329
330		# New: pval here
331	7x	pval <- summary(model_fit)$coef[-1, "Pr(>\|z\|)"]
332
333	7x	list(or_ci = values, n_tot = n_tot, pval = pval)
334		}
335
336		#' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for
337		#' the whole data set including all groups, since the results are not the same as when doing
338		#' pairwise comparisons between the groups.
339		#'
340		#' @examples
341		#' data <- data.frame(
342		#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),
343		#' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],
344		#' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],
345		#' stringsAsFactors = TRUE
346		#' )
347		#'
348		#' or_clogit_j(data, conf_level = 0.95)
349		#'
350		#' @export
351		#' @importFrom survival Surv
352		or_clogit_j <- function(data, conf_level, method = "exact") {
353	1x	checkmate::assert_logical(data$rsp)
354	1x	(assert_proportion_value)(conf_level)
355	1x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))
356	1x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
357	1x	checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
358	1x	checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
359
360	1x	data$grp <- as_factor_keep_attributes(data$grp)
361	1x	data$strata <- as_factor_keep_attributes(data$strata)
362
363		# Deviation from convention: `survival::strata` must be simply `strata`.
364	1x	strata <- survival::strata
365	1x	formula <- stats::as.formula("rsp ~ grp + strata(strata)")
366	1x	model_fit <- clogit_with_tryCatch(
367	1x	formula = formula,
368	1x	data = data,
369	1x	method = method
370		)
371
372		# New: pval here
373
374		# Create a list with one set of OR estimates, CI and p-value per coefficient, i.e. comparison of one group vs. the
375		# reference group.
376	1x	coef_est <- stats::coef(model_fit)
377	1x	ci_est <- stats::confint(model_fit, level = conf_level)
378	1x	pvals <- summary(model_fit)$coef[, "Pr(>\|z\|)", drop = FALSE]
379	1x	or_ci_pvals <- list()
380	1x	for (coef_name in names(coef_est)) {
381	1x	grp_name <- gsub("^grp", "", x = coef_name)
382	1x	or_ci_pvals[[grp_name]] <- stats::setNames(
383	1x	object = c(exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), pvals[coef_name, 1]),
384	1x	nm = c("est", "lcl", "ucl", "pval")
385		)
386		}
387	1x	list(or_ci_pvals = or_ci_pvals, n_tot = c(n_tot = model_fit$n))
388		}
389
390		#' @describeIn h_odds_ratio Estimates the odds ratio based on CMH. Note that there must be
391		#' exactly 2 groups in `data` as specified by the `grp` variable.
392		#'
393		#' @examples
394		#' set.seed(123)
395		#' data <- data.frame(
396		#' rsp = as.logical(rbinom(n = 40, size = 1, prob = 0.5)),
397		#' grp = letters[sample(1:2, size = 40, replace = TRUE)],
398		#' strata = LETTERS[sample(1:2, size = 40, replace = TRUE)],
399		#' stringsAsFactors = TRUE
400		#' )
401		#'
402		#' or_cmh(data, conf_level = 0.95)
403		#'
404		#' @export
405		or_cmh <- function(data, conf_level) {
406	7x	checkmate::assert_logical(data$rsp)
407	7x	assert_proportion_value(conf_level)
408	7x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
409	7x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
410
411	7x	data$grp <- as_factor_keep_attributes(data$grp)
412	7x	assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
413
414		# first dimension: treatment, control - therefore we reverse the levels order 2nd dimension: TRUE, FALSE 3rd
415		# dimension: levels of strata rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
416	7x	t_tbl <- table(
417	7x	factor(data$grp, levels = rev(levels(data$grp))),
418	7x	factor(data$rsp, levels = c("TRUE", "FALSE")),
419	7x	data$strata
420		)
421
422	7x	trt_ind <- 1
423	7x	ctrl_ind <- 2
424
425	7x	resp_ind <- 1
426	7x	nonresp_ind <- 2
427
428	7x	n1resp <- t_tbl[trt_ind, resp_ind, ]
429	7x	n2resp <- t_tbl[ctrl_ind, resp_ind, ]
430	7x	n1non <- t_tbl[trt_ind, nonresp_ind, ]
431	7x	n2non <- t_tbl[ctrl_ind, nonresp_ind, ]
432		# Example: n2non are the control patient non-responders per stratum.
433
434		# CMH statistic for odds ratio, Treatment over Control
435	7x	use_stratum <- (n1resp + n2resp + n1non + n2non) > 0
436	7x	n1resp <- n1resp[use_stratum]
437	7x	n2resp <- n2resp[use_stratum]
438	7x	n1non <- n1non[use_stratum]
439	7x	n2non <- n2non[use_stratum]
440	7x	n <- n1resp + n2resp + n1non + n2non
441
442	7x	or_num <- sum(n1resp * n2non / n)
443	7x	or_denom <- sum(n1non * n2resp / n)
444	7x	log_or <- log(or_num) - log(or_denom)
445	7x	or <- exp(log_or)
446
447	7x	term1_num <- sum((n1resp + n2non) * n1resp * n2non / n^2)
448	7x	term1_denom <- 2 * (sum(n1resp * n2non / n))^2
449
450	7x	term2_num <- sum(((n1resp + n2non) * n1non * n2resp + (n1non + n2resp) * n1resp * n2non) / n^2)
451	7x	term2_denom <- 2 * (sum(n1resp * n2non / n)) * (sum(n1non * n2resp / n))
452
453	7x	term3_num <- sum((n1non + n2resp) * n1non * n2resp / n^2)
454	7x	term3_denom <- 2 * (sum(n1non * n2resp / n))^2
455
456	7x	var_log_or <- term1_num / term1_denom + term2_num / term2_denom + term3_num / term3_denom
457	7x	se_log_or <- sqrt(var_log_or)
458
459	7x	z <- stats::qnorm((1 + conf_level) / 2)
460	7x	log_rel_or <- log_or + c(-1, +1) * z * se_log_or
461	7x	ci <- exp(log_rel_or)
462	7x	or_ci <- stats::setNames(c(or, ci), c("est", "lcl", "ucl"))
463
464	7x	pval <- stats::mantelhaen.test(t_tbl, correct = FALSE)$p.value
465
466	7x	n_tot <- stats::setNames(sum(n), "n_tot")
467
468	7x	list(or_ci = or_ci, n_tot = n_tot, pval = pval)
469		}

1		#' @name jj_complex_scorefun
2		#' @title Complex Scoring Function
3		#' @description
4		#' A function used for sorting AE tables (and others) as required.
5		#' @details
6		#' This sort function sorts as follows:
7		#' * Takes all the columns from a specified spanning column header (default= colspan_trt)
8		#' and sorts by the last treatment
9		#' column within this.
10		#' * If no spanning column header variable exists (e.g you have only one active treatment arm and have decided to
11		#' remove the spanning header from your layout), it will sort by the first treatment column in your table.
12		#'
13		#' This function is not really designed for tables that have sub-columns. However, if users wish to override any
14		#' default sorting behavior, they can simply specify their own colpath to use for sorting on (default = NULL)
15		#'
16		#' @param spanningheadercolvar (`character`)\cr
17		#' Name of spanning header variable that defines the active treatment columns.
18		#' If you do not have an active treatment spanning header column then user can define this as NA.
19		#' @param usefirstcol (`logical`)\cr
20		#' This allows you to just use the first column of the table to sort on.
21		#' @param colpath (`character`)\cr
22		#' Name of column path that is needed to sort by (default=NULL).
23		#' This overrides other arguments if specified
24		#' (except firstcat and lastcat which will be applied if requested on this colpath).
25		#' @param firstcat (`logical`)\cr
26		#' If you wish to put any category at the top of the list despite any n's, user can specify it here.
27		#' @param lastcat (`logical`)\cr
28		#' If you wish to put any category at the bottom of the list despite any n's, user can specify it here.
29		#' @param cellvalue_index (`integer`)\cr
30		#' Index of the cell value to perform the scoring on.
31		#' @export
32		#' @returns A function which can be used as a score function (scorefun in `sort_at_path`).
33		# @examples #result <- sort_at_path(result, c('root', 'AEBODSYS'), scorefun = jj_complex_scorefun())
34		#' @examples
35		#' library(dplyr)
36		#' ADAE <- data.frame(
37		#' USUBJID = c(
38		#' "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
39		#' "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
40		#' ),
41		#' AEBODSYS = c(
42		#' "SOC 1", "SOC 2", "SOC 1", "SOC 2", "SOC 2",
43		#' "SOC 2", "SOC 2", "SOC 1", "SOC 2", "SOC 1"
44		#' ),
45		#' AEDECOD = c(
46		#' "Coded Term 2", "Coded Term 1", "Coded Term 3", "Coded Term 4",
47		#' "Coded Term 4", "Coded Term 4", "Coded Term 5", "Coded Term 3",
48		#' "Coded Term 1", "Coded Term 2"
49		#' ),
50		#' TRT01A = c(
51		#' "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
52		#' "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
53		#' ),
54		#' TRTEMFL = c("Y", "Y", "N", "Y", "Y", "Y", "Y", "N", "Y", "Y")
55		#' )
56		#'
57		#' ADAE <- ADAE \|>
58		#' dplyr::mutate(TRT01A = as.factor(TRT01A))
59		#'
60		#' ADAE$colspan_trt <- factor(ifelse(ADAE$TRT01A == "Placebo", " ", "Active Study Agent"),
61		#' levels = c("Active Study Agent", " ")
62		#' )
63		#'
64		#' ADAE$rrisk_header <- "Risk Difference (%) (95% CI)"
65		#' ADAE$rrisk_label <- paste(ADAE$TRT01A, paste("vs", "Placebo"))
66		#'
67		#' colspan_trt_map <- create_colspan_map(ADAE,
68		#' non_active_grp = "Placebo",
69		#' non_active_grp_span_lbl = " ",
70		#' active_grp_span_lbl = "Active Study Agent",
71		#' colspan_var = "colspan_trt",
72		#' trt_var = "TRT01A"
73		#' )
74		#'
75		#' ref_path <- c("colspan_trt", " ", "TRT01A", "Placebo")
76		#'
77		#' ADSL <- unique(ADAE \|> select(USUBJID, "colspan_trt", "rrisk_header", "rrisk_label", "TRT01A"))
78		#'
79		#' lyt <- basic_table() \|>
80		#' split_cols_by(
81		#' "colspan_trt",
82		#' split_fun = trim_levels_to_map(map = colspan_trt_map)
83		#' ) \|>
84		#' split_cols_by("TRT01A") \|>
85		#' split_cols_by("rrisk_header", nested = FALSE) \|>
86		#' split_cols_by(
87		#' "TRT01A",
88		#' labels_var = "rrisk_label",
89		#' split_fun = remove_split_levels("Placebo")
90		#' ) \|>
91		#' analyze(
92		#' "TRTEMFL",
93		#' a_freq_j,
94		#' show_labels = "hidden",
95		#' extra_args = list(
96		#' method = "wald",
97		#' label = "Subjects with >=1 AE",
98		#' ref_path = ref_path,
99		#' .stats = "count_unique_fraction"
100		#' )
101		#' ) \|>
102		#' split_rows_by("AEBODSYS",
103		#' split_label = "System Organ Class",
104		#' split_fun = trim_levels_in_group("AEDECOD"),
105		#' label_pos = "topleft",
106		#' section_div = c(" "),
107		#' nested = FALSE
108		#' ) \|>
109		#' summarize_row_groups(
110		#' "AEBODSYS",
111		#' cfun = a_freq_j,
112		#' extra_args = list(
113		#' method = "wald",
114		#' ref_path = ref_path,
115		#' .stats = "count_unique_fraction"
116		#' )
117		#' ) \|>
118		#' analyze(
119		#' "AEDECOD",
120		#' afun = a_freq_j,
121		#' extra_args = list(
122		#' method = "wald",
123		#' ref_path = ref_path,
124		#' .stats = "count_unique_fraction"
125		#' )
126		#' )
127		#'
128		#' result <- build_table(lyt, ADAE, alt_counts_df = ADSL)
129		#'
130		#' result
131		#'
132		#' result <- sort_at_path(
133		#' result,
134		#' c("root", "AEBODSYS"),
135		#' scorefun = jj_complex_scorefun()
136		#' )
137		#'
138		#' result <- sort_at_path(
139		#' result,
140		#' c("root", "AEBODSYS", "*", "AEDECOD"),
141		#' scorefun = jj_complex_scorefun()
142		#' )
143		#'
144		#' result
145		#' @rdname complex_scoring_function
146		#' @aliases jj_complex_scorefun
147		jj_complex_scorefun <- function(
148		spanningheadercolvar = "colspan_trt",
149		usefirstcol = FALSE,
150		colpath = NULL,
151		firstcat = NULL,
152		lastcat = NULL,
153		cellvalue_index = 1
154		) {
155	12x	paths <- NULL
156
157	12x	function(tt) {
158	225x	if (is.null(paths)) {
159	12x	paths <<- col_paths(tt)
160	12x	if (is.null(colpath)) {
161	10x	if (is.na(spanningheadercolvar)) {
162	6x	atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
163	6x	use_paths <- atrt_paths
164	6x	act_trt_lst <- paths[use_paths]
165	6x	first_list <- sapply(act_trt_lst, utils::head, 1)
166	6x	first_at_value <- utils::head(first_list, n = 1)
167	6x	colpath <<- first_at_value
168		} else {
169	4x	atrt_paths <- vapply(paths, function(pth) pth[[1]] == spanningheadercolvar && pth[[2]] != " ", TRUE)
170	4x	use_paths <- atrt_paths
171	4x	act_trt_lst <- paths[use_paths]
172	4x	last_list <- sapply(act_trt_lst, utils::tail, 1)
173	4x	last_at_value <- utils::tail(last_list, n = 1)
174	4x	colpath <<- last_at_value
175		}
176
177	10x	if (usefirstcol) {
178	4x	atrt_paths <- vapply(paths, function(pth) pth[[1]] != " ", TRUE)
179	4x	use_paths <- atrt_paths
180	4x	act_trt_lst <- paths[use_paths]
181	4x	first_list <- sapply(act_trt_lst, utils::head, 1)
182	4x	first_at_value <- utils::head(first_list, n = 1)
183	4x	colpath <<- first_at_value
184		}
185		}
186		}
187	225x	unl_cv <- unlist(cell_values(tt, colpath = colpath), use.names = FALSE)
188	225x	if (length(unl_cv) < cellvalue_index) {
189	!	score <- NULL
190		} else {
191	225x	score <- unl_cv[cellvalue_index]
192		}
193
194	225x	if (length(score) == 0) {
195	!	score <- 1
196		}
197
198	225x	if (!is.null(firstcat)) {
199	30x	if (obj_name(tt) == firstcat) {
200	3x	score <- Inf
201		}
202		}
203	225x	if (!is.null(lastcat)) {
204	30x	if (obj_name(tt) == lastcat) {
205	3x	score <- -99999
206		}
207		}
208	225x	if (obj_name(tt) == " ") {
209	!	score <- -Inf
210		}
211
212	225x	return(score)
213		}
214		}

1		#' @name safe_prune_table
2		#'
3		#' @title Safely Prune Table With Empty Table Message If Needed
4		#'
5		#' @inheritParams rtables::prune_table
6		#'
7		#' @param empty_msg (`character(1)`)\cr The message to place in the table
8		#' if no rows were left after pruning
9		#'
10		#' @param spancols (`logical(1)`)\cr Should `empty_msg` be spanned
11		#' across the table's columns (`TRUE`) or placed in the
12		#' rows row label (`FALSE`). Defaults to `FALSE` currently.
13		#'
14		#' @rdname safe_prune_table
15		#' @return `tt` pruned based on the arguments, or, if
16		#' pruning would remove all rows, a TableTree with the
17		#' same column structure, and one row containing the
18		#' empty message spanning all columns.
19		#'
20		#' @export
21		#' @examples
22		#' prfun <- function(tt) TRUE
23		#'
24		#' lyt <- basic_table() \|>
25		#' split_cols_by("ARM") \|>
26		#' split_cols_by("STRATA1") \|>
27		#' split_rows_by("SEX") \|>
28		#' analyze("AGE")
29		#' tbl <- build_table(lyt, ex_adsl)
30		#'
31		#' safe_prune_table(tbl, prfun)
32		safe_prune_table <- function(
33		tt,
34		prune_func = prune_empty_level,
35		stop_depth = NA,
36		empty_msg = " - No Data To Display - ",
37		spancols = FALSE) {
38	9x	ret <- prune_table(tt = tt, prune_func = prune_func, stop_depth = stop_depth, depth = 0)
39	9x	if (is.null(ret)) {
40	3x	ret <- tt[integer(), , keep_titles = TRUE, keep_topleft = TRUE, keep_footers = TRUE]
41
42	3x	if (spancols) {
43		## this will eventually be the only option...
44	1x	ret <- sanitize_table_struct(ret, empty_msg = empty_msg)
45		} else {
46	2x	tree_children(ret) <- list(rrowl(empty_msg, rep(" ", ncol(tt))))
47		}
48		}
49	9x	ret
50		}
51
52		#' @name count_pruner
53		#'
54		#' @title Count Pruner
55		#'
56		#' @description
57		#' This is a pruning constructor function which identifies records to be pruned
58		#' based on the count (assumed to be the first statistic displayed when a compound
59		#' statistic (e.g., ## / ## (XX.X percent) is presented).
60		#'
61		#' @param count (`numeric`)\cr count threshold. Function will keep all records strictly greater
62		#' than this threshold.
63		#' @param cols (`character`)\cr column path (character or integer (column indices))
64		#' @param cat_include (`character`)\cr Category to be considered for pruning
65		#' @param cat_exclude (`character`)\cr Category to be excluded from pruning
66		#' @export
67		#'
68		#' @examples
69		#' ADSL <- data.frame(
70		#' USUBJID = c(
71		#' "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
72		#' "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
73		#' ),
74		#' TRT01P = factor(
75		#' c(
76		#' "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
77		#' "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
78		#' )
79		#' ),
80		#' FASFL = c("Y", "Y", "Y", "Y", "N", "Y", "Y", "Y", "Y", "Y"),
81		#' SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
82		#' PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
83		#' )
84		#'
85		#' lyt <- basic_table() \|>
86		#' split_cols_by("TRT01P") \|>
87		#' add_overall_col("Total") \|>
88		#' analyze("FASFL",
89		#' var_labels = "Analysis set:",
90		#' afun = a_freq_j,
91		#' extra_args = list(label = "Full", val = "Y"),
92		#' show_labels = "visible"
93		#' ) \|>
94		#' analyze("SAFFL",
95		#' var_labels = "Analysis set:",
96		#' afun = a_freq_j,
97		#' extra_args = list(label = "Safety", val = "Y"),
98		#' show_labels = "visible"
99		#' ) \|>
100		#' analyze("PKFL",
101		#' var_labels = "Analysis set:",
102		#' afun = a_freq_j,
103		#' extra_args = list(label = "PK", val = "Y"),
104		#' show_labels = "visible"
105		#' )
106		#'
107		#' result <- build_table(lyt, ADSL)
108		#'
109		#' result
110		#'
111		#' result <- prune_table(
112		#' result,
113		#' prune_func = count_pruner(cat_exclude = c("Safety"), cols = "Total")
114		#' )
115		#'
116		#' result
117		#' @rdname count_pruner
118		#' @returns Function that can be utilized as pruning function in prune_table.
119		#'
120		count_pruner <- function(count = 0, cat_include = NULL, cat_exclude = NULL, cols = c("TRT01A")) {
121	6x	colpaths <- NULL
122
123	6x	function(tt) {
124		# Do not ever prune the following rows. a row that should be kept in the table will get the value of FALSE
125
126	6x	if ( # nolint start
127	1089x	!methods::is(tt, "TableRow") \|\|
128	1089x	methods::is(tt, "LabelRow") \|\|
129	1089x	obj_label(tt) == " " \|\|
130	1089x	(!is.null(cat_include) &&
131	1089x	!obj_label(tt) %in% cat_include) \|\|
132	1089x	(!is.null(cat_exclude) && obj_label(tt) %in% cat_exclude)
133	6x	) { # nolint end
134	655x	return(FALSE)
135		}
136
137		# Check the remaining rows to see if any meet the specified threshold.
138
139	434x	if (!is.null(cols)) {
140	434x	tt <- subset_cols(tt, cols)
141		}
142
143		# init return value to FALSE (not remove row)
144	434x	remove <- FALSE
145
146	434x	if (is.null(colpaths)) {
147	5x	colpaths <<- col_paths(tt)
148		}
149
150		# identify non relative risk columns as in rrisk columns first element is not a count, but diff percentage with
151		# small total columns and count > 0 (eg count = 1, n per group = 10), you can run into count1 = 1, countpbo =
152		# 0, diffpct = 10, this row should not be considered though
153	434x	cp_nonrelrisk <- vapply(
154	434x	colpaths,
155	434x	function(pth) {
156	1308x	!any(grepl("rrisk", tolower(pth)))
157		},
158	434x	FUN.VALUE = TRUE
159		)
160
161		## only continue if at least one non relative risk column selected
162	434x	if (any(cp_nonrelrisk)) {
163		# get cell_values of non rel risk columns
164	434x	cell_vals <- cell_values(tt)[cp_nonrelrisk]
165
166	434x	len_cell_vals <- lapply(cell_vals, function(x) {
167	1302x	length(x)
168		})
169
170	434x	if (any(len_cell_vals == 0)) {
171	!	stop("column cell values has not appropriate structure (a column with NULL value).")
172		}
173
174		# get count (first element)
175	434x	counts <- unlist(
176	434x	lapply(cell_vals, function(x) {
177	1302x	x[[1]]
178		}),
179	434x	use.names = FALSE
180		)
181
182		# check that we do have counts only
183	434x	checkmate::assert_integerish(counts)
184
185	434x	keep <- counts > count
186		# the row should be kept if at least one column has count above threshold
187	434x	keep <- any(keep)
188
189		# pruning function should return TRUE if row has to be removed, ie opposite of keep
190	434x	remove <- !keep
191		}
192
193	434x	return(remove)
194		}
195		}
196
197
198		#' @name bspt_pruner
199		#'
200		#' @title Pruning Function for pruning based on a fraction and/or a difference from the control arm
201		#'
202		#' @description
203		#' This is a pruning constructor function which identifies records to be pruned
204		#' based on the the fraction from the percentages. In addition to just looking at a
205		#' fraction within an arm,
206		#' this function also allows further flexibility to also prune based on a comparison versus the control arm.
207		#' @param fraction (`proportion`)\cr Fraction threshold.
208		#' Function will keep all records strictly greater
209		#' than this threshold.
210		#' @param cols (`character`)\cr Column path.
211		#' @param keeprowtext (`character`)\cr Row to be excluded from pruning.
212		#' @param reg_expr (`logical`)\cr Apply keeprowtext as a regular expression (grepl with fixed = TRUE)
213		#' @param control (`character`)\cr Control Group
214		#' @param diff_from_control (`numeric`)\cr Difference from control threshold.
215		#' @param only_more_often (`logical`)\cr TRUE: Only consider when column pct is more often
216		#' than control. FALSE: Also select a row where column pct is less often than
217		#' control and abs(diff) above threshold
218		#'
219		#' @export
220		#'
221		#'
222		#' @examples
223		#' ADSL <- data.frame(
224		#' USUBJID = c(
225		#' "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
226		#' "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
227		#' ),
228		#' TRT01P = c(
229		#' "ARMA", "ARMB", "ARMA", "ARMB", "ARMB",
230		#' "Placebo", "Placebo", "Placebo", "ARMA", "ARMB"
231		#' ),
232		#' FASFL = c("Y", "Y", "Y", "Y", "N", "Y", "Y", "Y", "Y", "Y"),
233		#' SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
234		#' PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
235		#' )
236		#'
237		#' ADSL <- ADSL \|>
238		#' dplyr::mutate(TRT01P = as.factor(TRT01P)) \|>
239		#' dplyr::mutate(SAFFL = factor(SAFFL, c("Y", "N"))) \|>
240		#' dplyr::mutate(PKFL = factor(PKFL, c("Y", "N")))
241		#'
242		#' lyt <- basic_table() \|>
243		#' split_cols_by("TRT01P") \|>
244		#' add_overall_col("Total") \|>
245		#' split_rows_by(
246		#' "FASFL",
247		#' split_fun = drop_and_remove_levels("N"),
248		#' child_labels = "hidden"
249		#' ) \|>
250		#' analyze("FASFL",
251		#' var_labels = "Analysis set:",
252		#' afun = a_freq_j,
253		#' show_labels = "visible",
254		#' extra_args = list(label = "Full", .stats = "count_unique_fraction")
255		#' ) \|>
256		#' split_rows_by(
257		#' "SAFFL",
258		#' split_fun = remove_split_levels("N"),
259		#' child_labels = "hidden"
260		#' ) \|>
261		#' analyze("SAFFL",
262		#' var_labels = "Analysis set:",
263		#' afun = a_freq_j,
264		#' show_labels = "visible",
265		#' extra_args = list(label = "Safety", .stats = "count_unique_fraction")
266		#' ) \|>
267		#' split_rows_by(
268		#' "PKFL",
269		#' split_fun = remove_split_levels("N"),
270		#' child_labels = "hidden"
271		#' ) \|>
272		#' analyze("PKFL",
273		#' var_labels = "Analysis set:",
274		#' afun = a_freq_j,
275		#' show_labels = "visible",
276		#' extra_args = list(label = "PK", .stats = "count_unique_fraction")
277		#' )
278		#'
279		#' result <- build_table(lyt, ADSL)
280		#'
281		#' result
282		#'
283		#' result <- prune_table(
284		#' result,
285		#' prune_func = bspt_pruner(
286		#' fraction = 0.05,
287		#' keeprowtext = "Safety",
288		#' cols = c("Total")
289		#' )
290		#' )
291		#'
292		#' result
293		#' @rdname bspt_pruner
294		#' @returns Function that can be utilized as pruning function in prune_table.
295		#'
296		bspt_pruner <- function(
297		fraction = 0.05,
298		keeprowtext = "Analysis set: Safety",
299		reg_expr = FALSE,
300		control = NULL,
301		diff_from_control = NULL,
302		only_more_often = TRUE,
303		cols = c("TRT01A")) {
304	12x	if (is.null(fraction) && is.null(diff_from_control)) {
305	1x	stop("At least one of fraction or diff_from_control must be non-NULL.")
306		}
307	11x	if (!is.null(diff_from_control) && is.null(control)) {
308	1x	stop("control must be specified when diff_from_control is not NULL.")
309		}
310
311	10x	function(tt) {
312		# Do not ever prune the following rows.
313	137x	if (!methods::is(tt, "TableRow") \|\| methods::is(tt, "LabelRow")) {
314	24x	return(FALSE)
315		}
316
317	10x	if (
318	113x	reg_expr &&
319	113x	any(sapply(keeprowtext, function(x) {
320	!	grepl(x, obj_label(tt), fixed = TRUE)
321		}))
322		) {
323	!	return(FALSE)
324		}
325	113x	if (!reg_expr && obj_label(tt) %in% keeprowtext) {
326	10x	return(FALSE)
327		}
328
329		# init return value to FALSE (not remove row)
330	103x	remove <- FALSE
331
332		# needed later for control column
333	103x	tt_all_cols <- tt
334
335	103x	if (!is.null(cols)) {
336	103x	tt <- subset_cols(tt, cols)
337		}
338
339	103x	colpaths <- col_paths(tt)
340		# identify non relative risk columns
341	103x	cp_nonrelrisk <- vapply(
342	103x	colpaths,
343	103x	function(pth) {
344	329x	!any(grepl("rrisk", tolower(pth)))
345		},
346	103x	FUN.VALUE = TRUE
347		)
348
349		## only continue if at least one non relative risk column selected
350	103x	if (any(cp_nonrelrisk)) {
351		# get rid of rel risk columns (if present)
352	103x	cell_vals <- cell_values(tt)[cp_nonrelrisk]
353
354	103x	len_cell_vals <- lapply(cell_vals, function(x) {
355	296x	length(x)
356		})
357
358	103x	if (any(len_cell_vals < 2)) {
359	!	stop("column cell values has not appropriate structure (less than 2 values in cell).")
360		}
361
362		# get count and percentage columns counts in first col pcts in second col
363	103x	counts <- unname(lst_slicer(cell_vals, 1, numeric(1)))
364	103x	pcts <- unname(lst_slicer(cell_vals, 2, numeric(1)))
365
366	103x	checkmate::check_integerish(counts)
367		# similarly check that pcts is indeed a percentage
368	103x	if (!all(pcts >= 0 & pcts <= 1)) {
369	!	stop("second value column cell is not a percentage.")
370		}
371
372	103x	if (!is.null(fraction)) {
373		# avoid problems with FALSE for 0.05 >= 0.05
374	103x	check_pcts <- pcts >= fraction \|
375	103x	vapply(
376	103x	pcts,
377	103x	function(x) {
378	296x	isTRUE(all.equal(x, fraction))
379		},
380	103x	TRUE
381		)
382		}
383
384	103x	if (!is.null(diff_from_control)) {
385		# get control group from all columns tt (in case the columns selected would not include the control
386		# group)
387	78x	colpaths0 <- col_paths(subset_cols(tt_all_cols, c(control)))
388	78x	cp0_nonrelrisk <- vapply(
389	78x	colpaths0,
390	78x	function(pth) {
391	83x	!any(grepl("rrisk", tolower(pth)))
392		},
393	78x	FUN.VALUE = TRUE
394		)
395	78x	colpaths0 <- colpaths0[cp0_nonrelrisk]
396
397	78x	if (length(colpaths0) != 1) {
398	1x	stop("control group spec does not result in single column.")
399		} else {
400	77x	colpaths0 <- colpaths0[[1]]
401		# get percent from control group
402	77x	pct0 <- cell_values(tt_all_cols, colpath = c(control))[[1]][2]
403
404	77x	if (!(pct0 >= 0 && pct0 <= 1)) {
405	!	stop("second value of control column cell is not a percentage.")
406		}
407		}
408
409		# check if control group column was also present in main column selector
410	77x	colid0 <- which(sapply(colpaths, function(x) {
411	248x	all(x == colpaths0)
412		}))
413
414	77x	pctdiffs <- pcts - pct0
415
416		# exclude control column from this (would only be relevant if we want to check criteria on all columns
417		# rather than any column)
418	66x	if (!identical(colid0, integer(0))) pctdiffs <- pctdiffs[-colid0]
419
420		# if not only_more_often be equally strict on worse from control, better as control ie also select rows
421		# where column is less often than control pct = 0.07 pct0 = 0.10 (diff = -0.03 )
422	22x	if (!only_more_often) pctdiffs <- abs(pctdiffs)
423
424		# avoid problems with FALSE for 0.02 >= 0.02
425	77x	check_diffpcts <- pctdiffs >= diff_from_control \|
426	77x	vapply(
427	77x	pctdiffs,
428	77x	function(x) {
429	161x	isTRUE(all.equal(x, diff_from_control))
430		},
431	77x	TRUE
432		)
433		}
434
435		# final step to check if row should be kept in table
436	102x	if (!is.null(fraction) && is.null(diff_from_control)) {
437		# keep row in table if any column pct above threshold
438	25x	keep <- any(check_pcts)
439	77x	} else if ((!is.null(fraction) && !is.null(diff_from_control))) {
440		# if any column pct above threshold AND any diff pct above threshold note any is used in both
441		# expressions separately situation pct = 0.04 pct0 = 0.06 should be kept (fraction = 0.05, abs(diff
442		# control) = 0.02) this problem only arises in the non-default situation when only_more_often is FALSE
443		# (ie when column pct is less often than control) this would not be the case if we would any(check_pcts
444		# & check_diffpcts) as 0.04 is below fraction
445	77x	keep <- any(check_pcts) && any(check_diffpcts)
446	!	} else if ((is.null(fraction) && !is.null(diff_from_control))) {
447	!	keep <- any(check_diffpcts)
448		}
449
450		# pruning function should return TRUE if row has to be removed, ie opposite of keep
451	102x	remove <- !keep
452		}
453
454	102x	return(remove)
455		}
456		}
457
458		lst_slicer <- function(lst, ind, type) {
459	206x	vapply(lst, `[[`, i = ind, type)
460		}
461
462		#' @name remove_rows
463		#'
464		#' @title
465		#' Pruning function to remove specific rows of a table regardless of counts
466		#' @description
467		#' This function will remove all rows of a table based on the row text
468		#' provided by the user.
469		#' @param removerowtext (`character`)\cr Define a text string for which any row with row text will be removed.
470		#' @param reg_expr (`logical`)\cr Apply removerowtext as a regular expression
471		#' (grepl with fixed = TRUE)
472		#' @export
473		#' @rdname remove_rows
474		#'
475		#' @examples
476		#' ADSL <- data.frame(
477		#' USUBJID = c(
478		#' "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
479		#' "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
480		#' ),
481		#' TRT01P = c(
482		#' "ARMA", "ARMB", "ARMA", "ARMB", "ARMB", "Placebo",
483		#' "Placebo", "Placebo", "ARMA", "ARMB"
484		#' ),
485		#' Category = c(
486		#' "Cat 1", "Cat 2", "Cat 1", "Unknown", "Cat 2",
487		#' "Cat 1", "Unknown", "Cat 1", "Cat 2", "Cat 1"
488		#' ),
489		#' SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
490		#' PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
491		#' )
492		#'
493		#' ADSL <- ADSL \|>
494		#' dplyr::mutate(TRT01P = as.factor(TRT01P))
495		#'
496		#' lyt <- basic_table() \|>
497		#' split_cols_by("TRT01P") \|>
498		#' analyze(
499		#' "Category",
500		#' afun = a_freq_j,
501		#' extra_args = list(.stats = "count_unique_fraction")
502		#' )
503		#'
504		#' result <- build_table(lyt, ADSL)
505		#'
506		#' result
507		#'
508		#' result <- prune_table(result, prune_func = remove_rows(removerowtext = "Unknown"))
509		#'
510		#' result
511		#' @aliases remove_rows
512		#' @returns Function that can be utilized as pruning function in prune_table.
513		#'
514		remove_rows <- function(removerowtext = NULL, reg_expr = FALSE) {
515	5x	function(tt) {
516	97x	if (!methods::is(tt, "TableRow") \|\| methods::is(tt, "LabelRow")) {
517	5x	return(FALSE)
518		}
519
520	92x	ret <- FALSE
521	92x	if (!is.null(removerowtext)) {
522	72x	if (!reg_expr) {
523	37x	ret <- obj_label(tt) %in% removerowtext
524		} else {
525	35x	ret <- any(sapply(removerowtext, function(x) {
526	52x	grepl(x, obj_label(tt), fixed = TRUE)
527		}))
528		}
529		}
530
531	92x	ret
532		}
533		}
534
535		#' @name keep_non_null_rows
536		#'
537		#' @title Pruning Function to accommodate removal of completely NULL rows within a table
538		#'
539		#' @description
540		#' Condition function on individual analysis rows. Flag as FALSE when all
541		#' columns are NULL, as then the row should not be kept. To be utilized as a
542		#' row_condition in function tern::keep_rows
543		#'
544		#' @param tr (`TableTree`)\cr The TableTree object to prune.
545		#' @export
546		#'
547		#' @examples
548		#' library(dplyr)
549		#'
550		#' ADSL <- data.frame(
551		#' USUBJID = c(
552		#' "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
553		#' "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
554		#' ),
555		#' TRT01P = c(
556		#' "ARMA", "ARMB", "ARMA", "ARMB", "ARMB", "Placebo",
557		#' "Placebo", "Placebo", "ARMA", "ARMB"
558		#' ),
559		#' AGE = c(34, 56, 75, 81, 45, 75, 48, 19, 32, 31),
560		#' SAFFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N"),
561		#' PKFL = c("N", "N", "N", "N", "N", "N", "N", "N", "N", "N")
562		#' )
563		#'
564		#' ADSL <- ADSL \|>
565		#' mutate(TRT01P = as.factor(TRT01P))
566		#'
567		#' create_blank_line <- function(x) {
568		#' list(
569		#' "Mean" = rcell(mean(x), format = "xx.x"),
570		#' " " = rcell(NULL),
571		#' "Max" = rcell(max(x))
572		#' )
573		#' }
574		#'
575		#' lyt <- basic_table() \|>
576		#' split_cols_by("TRT01P") \|>
577		#' analyze("AGE", afun = create_blank_line)
578		#'
579		#' result <- build_table(lyt, ADSL)
580		#'
581		#' result
582		#' result <- prune_table(result, prune_func = tern::keep_rows(keep_non_null_rows))
583		#'
584		#' result
585		#' @rdname keep_non_null_rows
586		#' @returns A function that can be utilized as a row_condition in the tern::keep_rows function.
587		#'
588		keep_non_null_rows <- function(tr) {
589	55x	if (methods::is(tr, "DataRow")) {
590	54x	r_cellvalue_null <- unlist(lapply(cell_values(tr), is.null))
591	54x	check <- all(r_cellvalue_null)
592
593		### if check TRUE (all cell values NULL -- need to return FALSE as need to remove)
594	54x	ret <- !check
595		} else {
596	1x	ret <- TRUE
597		}
598	55x	ret
599		}

1		#' Conditional proportion with adaptive CI (exact vs. Wald)
2		#'
3		#' The analysis function [a_cond_proportion_j()] is used to create a layout
4		#' element that estimates a response proportion with confidence interval,
5		#' automatically selecting between exact and Wald methods based on observed
6		#' counts and user-defined limits.
7		#'
8		#' @description `r lifecycle::badge("experimental")`
9		#'
10		#' @details
11		#' The statistics function mirrors [tern::s_proportion()] usage and output but
12		#' removes the `method` argument and decides internally between
13		#' "clopper-pearson" and "wald".
14		#'
15		#' The exact method is used when any of these are true:
16		#' (a) the number of responders is `num_limit` (or less),
17		#' (b) all subjects except `num_limit` (or less) have observed response,
18		#' or (c) the observed group size is less than `denom_limit`.
19		#'
20		#' Depending on the `method_scope` choice, this decision is either taken
21		#' based on the response data for an individual cell (`method_scope = "cell"`),
22		#' or based on the response data for the entire row (`method_scope = "row"`):
23		#'
24		#' - With `method_scope = "cell"`, the counts used for the decision are:
25		#' - numerator: the number of responders in the current cell;
26		#' - denominator: the total number of observations in the cell (using `df`)
27		#' if `denom = "n"`, or across the row (using `.df_row`) if `denom = "N_row"`.
28		#' - With `method_scope = "row"`, the counts used for the decision are:
29		#' - numerator: the total number of responders across the row (using `.df_row`);
30		#' - denominator: the total number of observations across the row (from `.df_row`).
31		#'
32		#' CI computation follows [tern::s_proportion()] conventions: helper functions
33		#' are called with `n = denom`, so when `denom = "N_row"`, this row-level
34		#' denominator is used for the interval.
35		#'
36		#' @inheritParams proposal_argument_convention
37		#' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,
38		#' it indicates whether each subject is a responder or not. `TRUE` represents
39		#' a successful outcome. If a `data.frame` is provided, the logical vector of
40		#' responses must be indicated as a variable name in `.var`.
41		#' @param .var (`string`)
42		#' @param conf_level (`numeric`)
43		#' @param denom (`character`)\cr denominator to use for percentage and CI computation:
44		#' "n" (default, number of observed records), or "N_row" (number of observations in the row).
45		#' @param long (`flag`)\cr whether a long description is required.
46		#' @param na.rm (`flag`)\cr whether `NA` responses should be removed before analysis.
47		#' If `FALSE` and `NA` values are present, an error is raised.
48		#' Note that missing values are also removed from the row-wise counts
49		#' which is relevant when `method_scope = "row"` or `denom = "N_row"`.
50		#' @param num_limit (`int`)\cr numerator limit to trigger the exact method.
51		#' @param denom_limit (`int`)\cr denominator limit to trigger the exact method.
52		#' @param method_scope (`string`)\cr select the CI method using counts from the
53		#' current cell (`"cell"`) or all columns in the current row (`"row"`). See details.
54		#' @param .df_row (`data.frame`)\cr data for the current row across all columns,
55		#' automatically supplied by `rtables`.
56		#' @param method (`string` or `NULL`)\cr selected CI method to show in the
57		#' label. `NULL` retains the combined method description.
58		#' @param method_denom (`int`)\cr denominator used for the selected CI method.
59		#' @param method_rsp (`int`)\cr numerator used for the selected CI method.
60		#'
61		#' @name cond_proportion_j
62		NULL
63
64		#' Helper Function to Extract Count Responders
65		#'
66		#' Converts a response vector, or a response column from a data frame, to logical
67		#' values and returns its responder and observation counts.
68		#'
69		#' @param x (`vector` or `data.frame`)\cr Response data.
70		#' @param .var (`string`)\cr Response column in `x` when `x` is a data frame.
71		#' @param na.rm (`flag`)\cr Whether to remove missing responses before counting.
72		#'
73		#' @return A named list with `rsp` (logical response vector), `n_rsp` (responders) and `len_rsp`
74		#' (non-missing observations, when `na.rm = TRUE`).
75		#'
76		#' @keywords internal
77		h_get_rsp_counts <- function(x, .var, na.rm = FALSE) {
78	53x	rsp <- if (checkmate::test_atomic_vector(x)) {
79	20x	x
80		} else {
81	33x	tern::assert_df_with_variables(x, list(rsp = .var))
82	32x	x[[.var]]
83		}
84	52x	rsp <- safe_as_logical(rsp, na.rm = na.rm)
85	49x	list(rsp = rsp, n_rsp = sum(rsp), len_rsp = length(rsp))
86		}
87
88		#' @describeIn cond_proportion_j Statistics function estimating a proportion
89		#' along with its confidence interval, with adaptive method selection.
90		#'
91		#' @return
92		#' * `s_cond_proportion_j()` returns statistics `n_prop` (`n` responders and proportion)
93		#' and `prop_ci` (proportion CI), formatted consistently with [tern::s_proportion()].
94		#'
95		#' @examples
96		#' # Logical vector input
97		#' rsp_v <- c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)
98		#' s_cond_proportion_j(rsp_v)
99		#'
100		#' # Data frame input
101		#' dta <- data.frame(rsp = c(TRUE, TRUE, FALSE, TRUE, FALSE, NA))
102		#' s_cond_proportion_j(dta, .var = "rsp", na.rm = TRUE)
103		#'
104		#' # Using method_scope = "row" (requires .df_row in ...)
105		#' df_row <- data.frame(rsp = rep(rsp_v, 2))
106		#' s_cond_proportion_j(
107		#' dta, .var = "rsp", method_scope = "row",
108		#' .df_row = df_row, na.rm = TRUE
109		#' )
110		#'
111		#' @export
112		s_cond_proportion_j <- function(
113		df,
114		.var,
115		conf_level = 0.95,
116		long = FALSE,
117		na.rm = FALSE,
118		num_limit = 0,
119		denom_limit = 10,
120		denom = c("n", "N_row"),
121		method_scope = c("cell", "row"),
122		.df_row = NULL
123		) {
124	38x	checkmate::assert_flag(long)
125	38x	checkmate::assert_flag(na.rm)
126	38x	assert_proportion_value(conf_level)
127	38x	checkmate::assert_int(num_limit, lower = 0)
128	38x	checkmate::assert_int(denom_limit, lower = 0)
129	38x	denom <- match.arg(denom)
130	38x	method_scope <- match.arg(method_scope)
131
132	38x	rsp_counts <- h_get_rsp_counts(df, .var, na.rm = na.rm)
133	36x	rsp <- rsp_counts[["rsp"]]
134	36x	n_obs <- rsp_counts[["len_rsp"]]
135	36x	n_rsp <- rsp_counts[["n_rsp"]]
136
137	36x	if (method_scope == "row" \|\| denom == "N_row") {
138	15x	row_rsp_counts <- h_get_rsp_counts(.df_row, .var, na.rm = na.rm)
139		}
140	34x	denom_val <- switch(
141	34x	denom,
142	34x	n = n_obs,
143	34x	N_row = row_rsp_counts[["len_rsp"]]
144		)
145	34x	assert_int(denom_val, lower = n_obs)
146	34x	p_hat <- ifelse(denom_val > 0, n_rsp / denom_val, 0)
147
148		# Define the numerator and denominator used for the CI method selection.
149	34x	if (method_scope == "row") {
150	9x	method_denom <- row_rsp_counts[["len_rsp"]]
151	9x	method_rsp <- row_rsp_counts[["n_rsp"]]
152		} else {
153	25x	method_denom <- denom_val
154	25x	method_rsp <- n_rsp
155		}
156
157	34x	use_exact <- (method_denom < denom_limit) \|\|
158	34x	(method_rsp <= num_limit) \|\|
159	34x	(method_rsp >= (method_denom - num_limit))
160	34x	method <- if (use_exact) "clopper-pearson" else "wald"
161
162	34x	prop_ci <- switch(
163	34x	method,
164	34x	"clopper-pearson" = prop_clopper_pearson(rsp, n = denom_val, conf_level),
165	34x	"wald" = prop_wald(rsp, n = denom_val, conf_level)
166		)
167
168	32x	label <- d_cond_proportion_j(
169	32x	conf_level,
170	32x	long = long,
171	32x	num_limit = num_limit,
172	32x	denom_limit = denom_limit,
173	32x	method = if (method_scope == "row") method else NULL,
174	32x	method_denom = if (method_scope == "row") method_denom else NULL,
175	32x	method_rsp = if (method_scope == "row") method_rsp else NULL
176		)
177
178	32x	list(
179	32x	"n_prop" = formatters::with_label(c(n_rsp, p_hat), "Responders"),
180	32x	"prop_ci" = formatters::with_label(
181	32x	x = 100 * prop_ci,
182	32x	label = label
183		)
184		)
185		}
186
187		#' @describeIn cond_proportion_j Description helper function for the conditional
188		#' proportion summary label.
189		#'
190		#' @return
191		#' * `d_cond_proportion_j()` returns a string describing the analysis label.
192		#'
193		#' @examples
194		#' d_cond_proportion_j(conf_level = 0.90, long = FALSE, num_limit = 0, denom_limit = 10)
195		#'
196		#' # With dedicated row-wise method:
197		#' d_cond_proportion_j(
198		#' conf_level = 0.90, long = TRUE, num_limit = 0, denom_limit = 10,
199		#' method = "wald", method_denom = 10, method_rsp = 8)
200		#'
201		#' @export
202		d_cond_proportion_j <- function(
203		conf_level,
204		long = FALSE,
205		num_limit = NULL,
206		denom_limit = NULL,
207		method = NULL,
208		method_denom = NULL,
209		method_rsp = NULL
210		) {
211	40x	assert_proportion_value(conf_level)
212	40x	assert_flag(long)
213	40x	assert_string(method, null.ok = TRUE)
214
215	40x	label <- paste0(conf_level * 100, "% CI")
216
217	40x	if (long) {
218	15x	label <- paste(label, "for Response Rates")
219		}
220
221	40x	method_part <- if (!is.null(method)) {
222	14x	assert_choice(method, choices = c("wald", "clopper-pearson"))
223	14x	assert_count(num_limit)
224	14x	assert_count(denom_limit)
225	14x	assert_count(method_denom)
226	14x	assert_count(method_rsp)
227	14x	reason <- if (method == "wald") {
228	5x	paste0("n >= ", denom_limit, ", x = ", method_rsp)
229	14x	} else if (method_denom < denom_limit) {
230	2x	paste0("n < ", denom_limit)
231	14x	} else if (method_rsp <= num_limit) {
232	2x	if (num_limit == 0) "x = 0" else paste0("x <= ", num_limit)
233	14x	} else if (method_rsp >= (method_denom - num_limit)) {
234	2x	if (num_limit == 0) "x = n" else paste0("x >= n - ", num_limit)
235		} else {
236	!	stop("Selected Clopper-Pearson method has no matching selection criterion.")
237		}
238	14x	if (long) {
239	40x	switch(
240	12x	method,
241	4x	"wald" = paste0(
242	4x	"Wald because ",
243	4x	reason
244		),
245	8x	"clopper-pearson" = paste0(
246	8x	"Clopper-Pearson because ",
247	8x	reason
248		)
249		)
250		} else {
251	40x	switch(
252	2x	method,
253	1x	"wald" = "Wald",
254	1x	"clopper-pearson" = "Clopper-Pearson"
255		)
256		}
257	40x	} else if (long) {
258	3x	assert_count(num_limit)
259	3x	assert_count(denom_limit, positive = TRUE)
260	3x	paste0(
261	3x	"Wald if n >= ",
262	3x	denom_limit,
263	3x	", x > ",
264	3x	num_limit,
265	3x	", x < n - ",
266	3x	num_limit,
267	3x	"; else Clopper-Pearson"
268		)
269		} else {
270	23x	"Wald / Clopper-Pearson"
271		}
272
273	40x	paste0(label, " (", method_part, ")")
274		}
275
276		#' @describeIn cond_proportion_j Formatted analysis function which is used as
277		#' `afun` for conditional proportion with adaptive CI selection (exact vs. Wald).
278		#'
279		#' @return
280		#' * `a_cond_proportion_j()` returns the corresponding list with formatted [rtables::CellValue()].
281		#'
282		#' @examples
283		#' nex <- 100
284		#' dta <- data.frame(
285		#' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
286		#' "grp" = sample(c("A", "B"), nex, TRUE),
287		#' "f1" = sample(c("a1", "a2"), nex, TRUE),
288		#' stringsAsFactors = TRUE
289		#' )
290		#'
291		#' l <- basic_table() \|>
292		#' split_cols_by(var = "grp") \|>
293		#' analyze(
294		#' vars = "rsp",
295		#' afun = a_cond_proportion_j,
296		#' extra_args = list(
297		#' conf_level = 0.90,
298		#' num_limit = 0,
299		#' denom_limit = 10
300		#' )
301		#' )
302		#'
303		#' build_table(l, df = dta)
304		#'
305		#' @export
306		#' @order 2
307		a_cond_proportion_j <- function(
308		df,
309		.var,
310		...,
311		.stats = NULL,
312		.formats = NULL,
313		.labels = NULL,
314		.indent_mods = NULL,
315		.df_row = NULL
316		) {
317	10x	dots_extra_args <- list(...)
318
319		# Only support default stats, not custom stats
320	10x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
321
322	10x	x_stats <- .apply_stat_functions(
323	10x	default_stat_fnc = s_cond_proportion_j,
324	10x	custom_stat_fnc_list = NULL,
325	10x	args_list = c(
326	10x	df = list(df),
327	10x	.var = .var,
328	10x	.df_row = list(.df_row),
329	10x	dots_extra_args
330		)
331		)
332
333	10x	format_stats(
334	10x	x_stats,
335	10x	method_groups = "estimate_proportion",
336	10x	stats_in = .stats,
337	10x	formats_in = .formats,
338	10x	labels_in = .labels,
339	10x	indents_in = .indent_mods
340		)
341		}

1		## contribute to formatters
2		#' @name inches_to_spaces
3		#' @title Conversion of inches to spaces.
4		#' @param ins (`numeric`)\cr Vector of widths in inches.
5		#' @param fontspec (`font_spec`)\cr The font specification to use.
6		#' @param raw (`logical(1)`)\cr Should the answer be returned unrounded
7		#' (`TRUE`), or rounded to the nearest reasonable value (`FALSE`,
8		#' the default).
9		#' @param tol (`numeric(1)`)\cr The numeric tolerance. Values
10		#' between an integer `n`, and `n+tol` will be returned
11		#' as `n`, rather than `n+1`, if `raw == FALSE`. Ignored
12		#' when `raw` is `TRUE`.
13		#' @return The number of either fractional (`raw = TRUE`) or whole (`raw = FALSE`)
14		#' spaces that will fit within `ins` inches in the specified font.
15		#' @export
16		inches_to_spaces <- function(ins, fontspec, raw = FALSE, tol = sqrt(.Machine$double.eps)) {
17	110x	newdev <- open_font_dev(fontspec)
18	110x	if (newdev) {
19	8x	on.exit(close_font_dev())
20		}
21	110x	spcw <- grid::convertWidth(grid::unit(1, "strwidth", " "), "inches", valueOnly = TRUE)
22	110x	ans <- ins / spcw
23	110x	if (!raw) {
24	106x	win_tol <- ans - floor(ans) < tol
25	106x	ans[win_tol] <- floor(ans)
26	106x	ans[!win_tol] <- ceiling(ans)
27		}
28	110x	ans
29		}
30
31		#' @importFrom formatters wrap_string_ttype
32		ttype_wrap_vec <- function(vec, fontspec, width, wordbreak_ok = TRUE, ...) {
33	11x	lapply(
34	11x	vec,
35	11x	wrap_string_ttype,
36	11x	width = width,
37	11x	fontspec = fontspec,
38	11x	wordbreak_ok = wordbreak_ok,
39		...
40		)
41		}
42
43		#' @name check_wrap_nobreak
44		#' @title Check Word Wrapping
45		#' @description Check a set of column widths for word-breaking wrap behavior.
46		#' @param tt (`TableTree`)\cr TableTree object
47		#' @param colwidths (`numeric`)\cr Column widths (in numbers of spaces under `fontspec`)
48		#' @param fontspec (`font_spec`)\cr Font specification object
49		#'
50		#' @return `TRUE` if the wrap is able to be done without breaking words,
51		#' `FALSE` if wordbreaking is required to apply `colwidths`.
52		#' @rdname check_wrap_nobreak
53		#' @export
54		check_wrap_nobreak <- function(tt, colwidths, fontspec) {
55	2x	newdev <- open_font_dev(fontspec)
56	2x	if (newdev) {
57	2x	on.exit(close_font_dev())
58		}
59	2x	mpf <- matrix_form(tt, fontspec = fontspec)
60	2x	strs <- mf_strings(mpf)
61	2x	colok <- vapply(
62	2x	seq_len(ncol(strs)),
63	2x	function(i) {
64	10x	res <- tryCatch(
65	10x	ttype_wrap_vec(strs[, i, drop = TRUE], colwidths[i], fontspec = fontspec, wordbreak_ok = FALSE),
66	10x	error = function(e) e
67		)
68	10x	!methods::is(res, "error")
69		},
70	2x	TRUE
71		)
72	2x	all(colok)
73		}
74
75		#' Colwidths for all columns to be forced on one page.
76		#'
77		#' @param tt (`TableTree`)\cr TableTree object to calculate column widths for
78		#' @param fontspec (`font_spec`)\cr Font specification object
79		#' @param col_gap (`numeric`)\cr Column gap in spaces
80		#' @param rowlabel_width (`numeric`)\cr Width of row labels in spaces
81		#' @param print_width_ins (`numeric`)\cr Print width in inches
82		#' @param landscape (`logical`)\cr Whether the output is in landscape orientation
83		#' @param lastcol_gap (`logical`)\cr Whether to include a gap after the last column
84		#' @keywords internal
85		smart_colwidths_1page <- function(
86		tt,
87		fontspec,
88		col_gap = 6L,
89		rowlabel_width = inches_to_spaces(2, fontspec),
90		print_width_ins = ifelse(landscape, 11, 8.5) - 2.12,
91		landscape = FALSE,
92		lastcol_gap = TRUE) {
93	3x	total_cpp <- floor(inches_to_spaces(print_width_ins, fontspec = fontspec, raw = TRUE))
94
95	3x	nc <- ncol(tt)
96	3x	remain <- total_cpp - rowlabel_width - col_gap * (nc - !lastcol_gap)
97
98	3x	c(rowlabel_width - col_gap, spread_integer(remain, nc))
99		}
100
101		spaces_to_inches <- function(spcs, fontspec) {
102	1x	nchar_ttype(" ", fontspec, raw = TRUE) * spcs
103		}
104
105		no_cellwrap_colwidths <- function(tt, fontspec, col_gap = 4L, label_width_ins = 2) {
106	26x	if (is.null(col_gap)) {
107	!	col_gap <- 4L
108		}
109	26x	mpf <- matrix_form(tt, TRUE, FALSE, fontspec = fontspec, col_gap = col_gap)
110	26x	strmat <- mf_strings(mpf)
111	26x	label_width_max <- inches_to_spaces(label_width_ins, fontspec)
112
113	26x	nchar_mat <- nchar_ttype(strmat[-seq_len(mf_nlheader(mpf)), , drop = FALSE],
114	26x	fontspec = fontspec
115		)
116
117	26x	label_width <- min(
118	26x	label_width_max,
119	26x	max(nchar_mat[, 1, drop = TRUE])
120		)
121	26x	col_maxes <- apply(nchar_mat[, -1, drop = FALSE], 2, max)
122	26x	c(label_width, col_maxes + col_gap)
123		}
124
125		pack_into_lines2 <- function(strs, wrdwidths = nchar_ttype(strs), colwidth, fontspec) {
126	17526x	if (length(wrdwidths) == 0 \|\| (length(wrdwidths) == 1 && wrdwidths <= colwidth)) {
127	5585x	return(1)
128		}
129	11941x	newdev <- open_font_dev(fontspec)
130	11941x	if (newdev) {
131	!	on.exit(close_font_dev())
132		}
133
134	11941x	csums <- cumsum(wrdwidths + c(0, rep(1, length(wrdwidths) - 1)))
135	11941x	oneline_wdth <- sum(wrdwidths) + length(wrdwidths) - 1
136	11941x	if (colwidth >= ceiling(oneline_wdth)) {
137	8818x	return(1)
138		}
139	3123x	lines <- 0
140	3123x	wrdsused <- 0
141	3123x	widthused <- 0
142	3123x	index_seq <- seq_along(wrdwidths)
143	3123x	totwrds <- length(wrdwidths)
144	3123x	adj <- 0
145		## finite precision arithmetic is a dreamscape of infinite wonder
146	3123x	tol <- sqrt(.Machine$double.eps)
147	3123x	while (wrdsused < length(wrdwidths)) {
148	7428x	csums_i <- csums - widthused
149
150	7428x	fit <- which(index_seq > wrdsused & csums_i <= colwidth + tol)
151	7428x	widthused <- sum(widthused, wrdwidths[fit], length(fit))
152	7428x	wrdsused <- wrdsused + length(fit)
153	7428x	lines <- lines + 1
154		}
155	3123x	lines
156		}
157
158		recursive_add_poss <- function(
159		wlst,
160		cur_lst,
161		ubnd_width,
162		lbnd_width,
163		ubnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = ubnd_width)$lines,
164		lbnd_lines = calc_total_lns(wlst, fontspec = fontspec, colwidth = lbnd_width)$lines,
165		fontspec) {
166	459x	if (ubnd_width <= lbnd_width + 1 + sqrt(.Machine$double.eps)) {
167	109x	return(cur_lst)
168		}
169	350x	curw <- floor((ubnd_width + lbnd_width) / 2)
170	350x	curlnsdf <- calc_total_lns(wlst, fontspec = fontspec, colwidth = curw)
171	350x	to_add <- list(curlnsdf)
172
173	350x	if (curlnsdf$lines != lbnd_lines) {
174	227x	to_add <- c(
175	227x	to_add,
176	227x	recursive_add_poss(
177	227x	wlst = wlst,
178	227x	fontspec = fontspec,
179	227x	ubnd_width = curw,
180	227x	ubnd_lines = curlnsdf$lines,
181	227x	lbnd_width = lbnd_width,
182	227x	lbnd_lines = lbnd_lines,
183	227x	cur_lst = list()
184		)
185		)
186		}
187	350x	if (curlnsdf$lines != ubnd_lines) {
188	186x	to_add <- c(
189	186x	to_add,
190	186x	recursive_add_poss(
191	186x	wlst = wlst,
192	186x	fontspec = fontspec,
193	186x	ubnd_width = ubnd_width,
194	186x	ubnd_lines = ubnd_lines,
195	186x	lbnd_width = curw,
196	186x	lbnd_lines = curlnsdf$lines,
197	186x	cur_lst = list()
198		)
199		)
200		}
201
202	350x	c(cur_lst, to_add)
203		}
204
205		calc_total_lns <- function(wlst, colwidth, fontspec, lns_per_pg = 50) {
206	534x	lns <- vapply(
207	534x	seq_along(wlst),
208	534x	function(i) {
209	17526x	pack_into_lines2(wrdwidths = wlst[[i]], colwidth = colwidth, fontspec = fontspec)
210		},
211	534x	1
212		)
213	534x	nonblnks <- !vapply(wlst, function(x) length(x) == 0, TRUE)
214	534x	celllns <- lns[-1]
215	534x	cllsum <- sum(celllns)
216	534x	hdr <- lns[1]
217	534x	data.frame(
218	534x	colwidth = colwidth,
219	534x	lines = cllsum + ceiling(cllsum / lns_per_pg) * hdr,
220	534x	cell_lines = cllsum,
221	534x	lbl_lines = hdr,
222	534x	min_cell_lines = min(1, celllns[nonblnks], na.rm = TRUE),
223	534x	max_cell_lines = max(celllns)
224		)
225		}
226
227
228		calc_poss_lines <- function(wlst, lbound, avail_spc, fontspec) {
229	46x	minposs <- calc_total_lns(wlst, lbound + avail_spc, fontspec)
230	46x	maxposs <- calc_total_lns(wlst, lbound, fontspec)
231
232	46x	retlst <- list(minposs, maxposs)
233
234	46x	retlst <- recursive_add_poss(
235	46x	wlst = wlst,
236	46x	ubnd_width = lbound + avail_spc,
237	46x	lbnd_width = lbound,
238	46x	cur_lst = retlst,
239	46x	fontspec = fontspec
240		)
241	46x	do.call(rbind, retlst)
242		}
243
244
245		make_poss_wdf <- function(
246		mpf,
247		incl_header = FALSE,
248		col_gap = 3,
249		pg_width_ins = 8.88,
250		fontspec = font_spec("Times", 9, 1.2)) {
251	8x	newdev <- open_font_dev(fontspec)
252	8x	if (newdev) {
253	1x	on.exit(close_font_dev())
254		}
255	8x	if (!methods::is(mpf, "MatrixPrintForm")) {
256	6x	mpf <- matrix_form(mpf, fontspec = fontspec, col_gap = col_gap)
257		}
258	8x	strs <- mf_strings(mpf)
259	8x	if (!incl_header) {
260	1x	strs <- strs[-seq_len(mf_nlheader(mpf)), ]
261		}
262	8x	nc <- ncol(strs)
263	8x	nr <- nrow(strs)
264		## strip out markup so we are not over countin (by as much)
265	8x	strs <- matrix(gsub("~[{[][[:alpha:]]+ ([^]}]+)[]}]", "\\1", strs), ncol = nc, nrow = nr)
266
267	8x	possrows <- lapply(seq_len(ncol(strs)), function(ii) {
268	46x	res <- one_col_strs(strs[, ii, drop = TRUE], fontspec = fontspec, col_gap = col_gap)
269	46x	res$col_num <- ii
270	46x	res
271		})
272
273	8x	possdf <- do.call(rbind, possrows)
274	8x	o <- order(possdf$col_num, possdf$colwidth)
275	8x	possdf <- possdf[o, ]
276	8x	possdf
277		}
278
279		#'
280		#' @param mpf (`listing_df` or `MatrixPrintForm` derived thereof)\cr The listing
281		#' calculate column widths for.
282		#' @param incl_header (`logical(1)`)\cr Should the constraint to not break up
283		#' individual words be extended to words in the column labels? Defaults to `TRUE`
284		#' @param col_gap (`numeric(1)`)\cr Amount of extra space (in spaces) to
285		#' assume between columns. Defaults to `0.5`
286		#' @param pg_width_ins (`numeric(1)`)\cr Number of inches in width for
287		#' the portion of the page the listing will be printed to. Defaults to `8.88`
288		#' which corresponds to landscape orientation on a standard page after margins.
289		#' @param fontspec (`font_spec`)\cr Defaults to Times New Roman 8pt font with 1.2 line
290		#' height.
291		#' @param verbose (`logical(1)`)\cr Should additional information messages be
292		#' displayed during the calculation of the column widths? Defaults to `FALSE`.
293		#' @return
294		#' * `listing_column_widths`: a vector of column widths suitable to use in `tt_to_tlgrtf` and
295		#' other exporters.
296		#' @rdname def_colwidths
297		#' @export
298		listing_column_widths <- function(
299		mpf,
300		incl_header = TRUE,
301		col_gap = 0.5,
302		pg_width_ins = 8.88,
303		fontspec = font_spec("Times", 8, 1.2),
304		verbose = FALSE) {
305	7x	newdev <- open_font_dev(fontspec)
306	7x	if (newdev) {
307	3x	on.exit(close_font_dev())
308		}
309	7x	possdf <- make_poss_wdf(
310	7x	mpf = mpf,
311	7x	incl_header = incl_header,
312	7x	col_gap = col_gap,
313	7x	fontspec = fontspec,
314	7x	pg_width_ins = pg_width_ins
315		)
316	7x	optimal <- optimal_widths(
317	7x	possdf = possdf,
318	7x	tot_spaces = inches_to_spaces(pg_width_ins, fontspec = fontspec),
319	7x	verbose = verbose
320		)
321	7x	optimal$colwidth
322		}
323
324		find_free_colspc <- function(curposs, fullposs, thresh = 0.99, skip = integer(), verbose = FALSE) {
325	1x	orig_curposs <- curposs
326	1x	maxlns_ind <- which.max(curposs$cell_lines)
327	1x	longestcol <- curposs$col_num[maxlns_ind]
328	1x	maxlns <- curposs$cell_lines[maxlns_ind]
329	1x	adjrow_inds <- setdiff(which(curposs$cell_lines < thresh * maxlns), skip)
330	1x	for (arowi in adjrow_inds) {
331	2x	col <- curposs$col_num[arowi]
332	2x	colwidthii <- curposs$colwidth[arowi]
333	2x	fp_ind <- with(fullposs, min(which(col_num == col & cell_lines <= maxlns & colwidth < colwidthii)))
334	2x	if (is.finite(fp_ind)) {
335	!	if (verbose) {
336	!	oldwdth <- curposs$colwidth[arowi]
337	!	newwdth <- fullposs$colwidth[fp_ind]
338	!	msg <- sprintf("adjusting column %d width from %d to %d", col, oldwdth, newwdth)
339	!	message(msg)
340		}
341	!	curposs[arowi, ] <- fullposs[fp_ind, ]
342		}
343		}
344	1x	curposs
345		}
346
347		constrict_lbl_lns <- function(curdf, possdf, avail_spc = 0, verbose = TRUE) {
348	7x	old_lbl_lns <- max(curdf$lbl_lines)
349	7x	cols_to_pack <- which(curdf$lbl_lines == old_lbl_lns)
350	7x	olddf <- curdf
351	7x	success <- TRUE
352	7x	for (ii in cols_to_pack) {
353	7x	colii <- curdf$col_num[ii]
354	7x	cwidthii <- curdf$colwidth[ii]
355	7x	possdfii <- possdf[possdf$col_num == colii & possdf$lbl_lines < old_lbl_lns, ]
356	7x	if (nrow(possdfii) == 0) {
357	2x	success <- FALSE
358	2x	break
359		}
360	5x	newrow <- possdfii[ii, ]
361	5x	if (ii > nrow(possdfii)) {
362	1x	success <- FALSE
363	1x	break
364		}
365	4x	if (newrow$colwidth - cwidthii > avail_spc) {
366	4x	success <- FALSE
367	4x	break
368		}
369		## assuming sorted
370	!	curdf[ii, ] <- newrow
371	!	avail_spc <- avail_spc + cwidthii - newrow$colwidth
372		}
373
374	7x	if (verbose) {
375	1x	if (success) {
376	!	msg <- paste(
377	!	"overall number of label rows successfully reduced. Cols affected: ",
378	!	paste(curdf$col_num[cols_to_pack], collapse = ", ")
379		)
380		} else {
381	1x	msg <- paste("Unable to reduce label rows required.")
382		}
383		}
384
385	7x	if (!success) {
386	7x	curdf <- olddf
387		}
388	7x	curdf
389		}
390
391		optimal_widths <- function(possdf, tot_spaces = 320, max_lbl_lines = 3, verbose = FALSE) {
392	7x	odf <- order(possdf$col_num, possdf$colwidth)
393	7x	possdf <- possdf[odf, ]
394	7x	badlbl <- which(possdf$lbl_lines > max_lbl_lines)
395	7x	if (length(badlbl > 0)) {
396	2x	if (verbose) {
397	!	message("Excluding ", length(badlbl), " column widths for labels taking over ", max_lbl_lines, " lines.")
398		}
399	2x	possdf <- possdf[-badlbl, ]
400	2x	possdf <- possdf[possdf$lbl_lines <= max_lbl_lines, , drop = FALSE]
401		}
402	7x	full_possdf <- possdf
403		## already ordered by colnum then width so this the first of each colwidth is the min width for that col
404	7x	dups <- duplicated(possdf$col_num)
405	7x	curdf <- possdf[!dups, ]
406	7x	possdf <- possdf[dups, ] ## without rows for ones in curdf
407	7x	spcleft <- tot_spaces - sum(curdf$colwidth)
408	7x	if (verbose) {
409	1x	message(
410	1x	"Optimizng Column Widths\n",
411	1x	"Initial lines required: ",
412	1x	max(curdf$lines),
413	1x	"\n",
414	1x	"Available adjustment: ",
415	1x	spcleft,
416	1x	" spaces\n"
417		)
418		}
419	7x	done <- FALSE
420	7x	while (!done) {
421	7x	oldwdths <- curdf$colwidth
422	7x	curdf <- constrict_lbl_lns(curdf, possdf, verbose = verbose)
423	7x	if (all.equal(curdf$colwidth, oldwdths)) {
424	7x	done <- TRUE
425		}
426		}
427	7x	change <- TRUE
428	7x	while (spcleft > 0 && change && nrow(possdf) > 0) {
429	24x	change <- FALSE
430	24x	ii <- which.max(curdf$cell_lines)
431	24x	spcleft <- tot_spaces - sum(curdf$colwidth)
432	24x	colii <- curdf$col_num[ii]
433	24x	bef_lns <- curdf$cell_lines[ii]
434	24x	bef_width <- curdf$colwidth[ii]
435	24x	nextlns <- max(curdf$cell_lines[-ii])
436	24x	cand_row_cond <- possdf$col_num == colii & possdf$cell_lines < bef_lns & possdf$colwidth - bef_width <= spcleft
437	24x	canddf <- possdf[cand_row_cond, , drop = FALSE]
438	24x	if (nrow(canddf) > 0) {
439	18x	more_than_next <- canddf$cell_lines >= nextlns
440	18x	if (any(more_than_next)) {
441	9x	candrow <- canddf[max(which(more_than_next)), ]
442		} else {
443	9x	candrow <- canddf[nrow(canddf), ]
444		}
445
446	18x	if (verbose) {
447	4x	message(
448	4x	"COL ",
449	4x	colii,
450	4x	" width: ",
451	4x	bef_width,
452		"->",
453	4x	candrow$colwidth,
454	4x	" lines req: ",
455	4x	bef_lns,
456		"->",
457	4x	candrow$cell_lines
458		)
459		}
460	18x	change <- TRUE
461	18x	curdf[ii, ] <- candrow
462		}
463		}
464	7x	curdf
465		}
466
467
468		one_col_strs <- function(strcol, col_gap = 2, fontspec) {
469	46x	strspls <- strsplit(strcol, split = "(-\| (?=[^/]))", perl = TRUE)
470	46x	strspl_widths <- lapply(strspls, nchar_ttype, fontspec = fontspec, raw = TRUE)
471	46x	lbound_raw <- max(unlist(strspl_widths))
472	46x	lbound <- ceiling(lbound_raw + 2 * col_gap)
473	46x	ret <- calc_poss_lines(strspl_widths, lbound, 50, fontspec = fontspec)
474	46x	ret
475		}
476
477
478
479		#' @name def_colwidths
480		#'
481		#' @title Define Column Widths
482		#'
483		#' @description
484		#' `def_colwidths` uses heuristics to determine suitable column widths given a
485		#' table or listing, and a font.
486		#'
487		#' @param tt input TableTree
488		#' @param fontspec Font specification
489		#' @param label_width_ins Label Width in Inches.
490		#' @param col_gap Column gap in spaces. Defaults to `.5` for listings and `3`
491		#' for tables.
492		#' @param type Type of the TableTree, used to determine column width calculation method.
493		#'
494		#' @details Listings are assumed to be rendered landscape on standard A1 paper,
495		#' such that all columns are rendered on one page. Tables are allowed to
496		#' be horizontally paginated, and column widths are determined based only on
497		#' required word wrapping. See the `Automatic Column Widths` vignette for
498		#' a detailed discussion of the algorithms used.
499		#' @return
500		#' * `def_colwidths`: a vector of column widths (including the label row pseudo-column in the table
501		#' case) suitable for use rendering `tt` in the specified font.
502		#' @export
503		def_colwidths <- function(tt,
504		fontspec,
505		label_width_ins = 2,
506		col_gap = ifelse(type == "Listing", .5, 3),
507		type = tlg_type(tt)) {
508	32x	if (type == "Figure") {
509	!	ret <- NULL
510	32x	} else if (type == "Table") {
511		if (
512	26x	is.list(tt) &&
513	26x	!methods::is(tt, "MatrixPrintForm") &&
514	26x	!is.null(formatters::mf_col_widths(tt[[1]]))
515		) {
516	!	ret <- formatters::mf_col_widths(tt[[1]])
517		} else {
518	26x	ret <- no_cellwrap_colwidths(tt, fontspec, col_gap = col_gap, label_width_ins = label_width_ins)
519		}
520		} else {
521	6x	ret <- listing_column_widths(tt, fontspec = fontspec, col_gap = col_gap)
522		}
523	32x	ret
524		}

1		.h_s_eair_diff_scalar <- function(x1,
2		n1,
3		x2,
4		n2,
5		conf_type = c("wald", "waldcc", "mn", "scas"),
6		conf_level = 0.95) {
7	272x	conf_type <- match.arg(conf_type)
8	272x	diff_est <- switch(conf_type,
9	272x	waldcc = h_s_eair_diff_wald(x1, n1, x2, n2, conf_level, cc = TRUE),
10	272x	wald = h_s_eair_diff_wald(x1, n1, x2, n2, conf_level, cc = FALSE),
11	272x	mn = h_s_eair_diff_mn(x1, n1, x2, n2, conf_level, skew = FALSE),
12	272x	scas = h_s_eair_diff_mn(x1, n1, x2, n2, conf_level, skew = TRUE)
13		)
14	272x	list(diff_est = diff_est$est, diff_lcl = diff_est$ci[1], diff_ucl = diff_est$ci[2])
15		}
16
17		h_s_eair_diff <- function(x1,
18		n1,
19		x2,
20		n2,
21		conf_type,
22		conf_level = 0.95) {
23	146x	results <- mapply(
24	146x	.h_s_eair_diff_scalar,
25	146x	x1, n1, x2, n2,
26	146x	MoreArgs = list(conf_type = conf_type, conf_level = conf_level),
27	146x	SIMPLIFY = FALSE
28		)
29	146x	data.frame(
30	146x	diff_est = sapply(results, `[[`, "diff_est"),
31	146x	diff_lcl = sapply(results, `[[`, "diff_lcl"),
32	146x	diff_ucl = sapply(results, `[[`, "diff_ucl")
33		)
34		}
35
36		h_s_eair_diff_wald <- function(x1, n1, x2, n2, conf_level, cc = TRUE) {
37	197x	alpha <- 1 - conf_level
38	197x	est <- x1 / n1 - x2 / n2
39	197x	se <- sqrt(x1 / n1^2 + x2 / n2^2)
40
41	197x	coeff <- stats::qnorm(1 - alpha / 2)
42	197x	term2 <- coeff * se
43	197x	if (cc) {
44	30x	term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)
45		}
46	197x	lcl <- est - term2
47	197x	ucl <- est + term2
48
49	197x	eair_diff <- list()
50	197x	eair_diff$est <- est
51	197x	eair_diff$ci <- c(lcl, ucl)
52	197x	eair_diff
53		}
54
55		h_s_eair_diff_mn <- function(x1, n1, x2, n2, conf_level, skew = FALSE) {
56	75x	alpha <- 1 - conf_level
57	75x	z <- stats::qnorm(1 - alpha / 2)
58
59	75x	est <- x1 / n1 - x2 / n2
60
61	75x	lcl <- .conf_poi_rd(x1, n1, x2, n2, z, lower = TRUE, skew = skew, level = conf_level)
62	75x	ucl <- .conf_poi_rd(x1, n1, x2, n2, z, lower = FALSE, skew = skew, level = conf_level)
63
64	75x	eair_diff <- list()
65	75x	eair_diff$est <- est
66	75x	eair_diff$ci <- c(lcl, ucl)
67	75x	eair_diff
68		}
69
70		.score_poi_rd <- function(x1, n1, x2, n2, theta, skew = FALSE, level = 0.95) {
71	3512x	alpha <- 1 - level
72	3512x	p1hat <- x1 / n1
73	3512x	p2hat <- x2 / n2
74	3512x	Stheta <- (p1hat - p2hat) - theta
75	3512x	if (isTRUE(abs(Stheta) == 0)) {
76	!	return(0)
77		}
78	3512x	x <- x1 + x2
79	3512x	N <- n1 + n2
80	3512x	A <- N
81	3512x	B <- N * theta - x
82	3512x	C_ <- -x2 * theta
83	3512x	num <- (-B + sqrt(B^2 - 4 * A * C_))
84	3512x	p2d <- ifelse(isTRUE(num == 0), 0, num / (2 * A))
85	3512x	p1d <- p2d + theta
86	3512x	V <- p1d / n1 + p2d / n2
87	3512x	score1 <- Stheta / sqrt(V)
88
89	3512x	if (!skew) {
90	1400x	return(score1)
91		}
92
93		# Skewness correction (SCAS)
94	2112x	mu3 <- p1d / (n1^2) - p2d / (n2^2)
95	2112x	scterm <- mu3 / (6 * V^(3 / 2))
96	2112x	if (isTRUE(scterm == 0)) {
97	!	return(score1)
98		}
99
100	2112x	A_q <- scterm
101	2112x	B_q <- 1
102	2112x	C_q <- -(score1 + scterm)
103	2112x	dsct <- B_q^2 - 4 * A_q * C_q
104	2112x	if (dsct < 0) {
105		# Fallback to simplified skewness correction
106	!	qtnorm <- stats::qnorm(1 - alpha / 2)
107	!	score1 <- score1 - (qtnorm^2 - 1) * scterm
108		} else {
109	2112x	score1 <- (-B_q + sqrt(dsct)) / (2 * A_q)
110		}
111
112	2112x	return(score1)
113		}
114
115		.conf_poi_rd <- function(x1, n1, x2, n2, z, lower = FALSE,
116		skew = FALSE, level = 0.95) {
117	150x	p1 <- x1 / n1
118	150x	p2 <- x2 / n2
119	150x	p_hat <- p1 - p2
120	150x	dp <- 1 + ifelse(lower, 1, -1) * p_hat
121	150x	i <- 1
122	150x	while (i <= 50) {
123	3512x	dp <- 0.5 * dp
124	3512x	y <- p_hat + ifelse(lower, -1, 1) * dp
125	3512x	score <- .score_poi_rd(x1, n1, x2, n2, y, skew = skew, level = level)
126		# For lower bound: score decreases as y moves left, find where score = +z
127		# -> move y further left if score > z (still too close to estimate)
128		# For upper bound: score decreases as y moves right, find where score = -z
129		# -> move y further right if score > -z (still too close to estimate)
130	3512x	if (lower) {
131	755x	if (score < z) p_hat <- y
132		} else {
133	700x	if (score > -z) p_hat <- y
134		}
135	3512x	if ((dp < 1e-07) \|\| (abs(score - ifelse(lower, z, -z)) < 1e-06)) {
136	150x	break
137		} else {
138	3362x	i <- i + 1
139		}
140		}
141	150x	return(y)
142		}

1		#' @title Analysis Function: Sum and Ratio of Sums
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Computes one or more of the following statistics for use with
6		#' [rtables::analyze()]:
7		#' - `"sum"`: `sum(.var)`
8		#' - `"sum_unique"`: `sum(.var)` after keeping unique rows by `id_var`
9		#' - `"ratio"`: `sum(.var) / sum(denom_by)`
10		#' - `"ratio_unique"`: same ratio after keeping unique rows by `id_var`
11		#'
12		#' Both `.var` and `denom_by` columns must be numeric (integer, double, or
13		#' logical coerced to numeric).
14		#'
15		#' @inheritParams proposal_argument_convention
16		#' @param .stats (`character`)\cr one or more of `"sum"`, `"sum_unique"`,
17		#' `"ratio"`, `"ratio_unique"`. Default: `"sum"`.
18		#' @param denom_by (`string` or `NULL`)\cr denominator column; required for
19		#' `"ratio"` and `"ratio_unique"`.
20		#' @param id_var (`string` or `NULL`)\cr subject-id column for unique row selection;
21		#' required for `"sum_unique"` and `"ratio_unique"`.
22		#' @param .indent_mods (named `integer` or `NULL`)\cr indent modifiers for the
23		#' row labels. Defaults to `NULL` (no modification).
24		#' @param na_str (`character` or `NULL`)\cr string(s) used to replace `NA`
25		#' values in the formatted output. Defaults to `NULL` (no replacement).
26		#'
27		#' @return A `RowsVerticalSection` for use by rtables.
28		#'
29		#' @author VR
30		#'
31		#' @importFrom rtables in_rows
32		#' @export
33		#'
34		#' @examples
35		#' df <- data.frame(
36		#' USUBJID = c("S01", "S01", "S02", "S03"),
37		#' ARM = factor(c("A", "A", "A", "B")),
38		#' EVENTS = c(1, 1, 0, 1),
39		#' DAYS = c(10, 10, 20, 15)
40		#' )
41		#'
42		#' # All 4 stats in a layout (S01 duplicate tests unique logic)
43		#' lyt <- basic_table() \|>
44		#' split_cols_by("ARM") \|>
45		#' analyze(
46		#' "EVENTS",
47		#' afun = a_sum_ratio_j,
48		#' extra_args = list(
49		#' .stats = c("sum", "sum_unique", "ratio", "ratio_unique"),
50		#' denom_by = "DAYS",
51		#' id_var = "USUBJID"
52		#' )
53		#' )
54		#'
55		#' build_table(lyt, df)
56		a_sum_ratio_j <- function(
57		df,
58		.var,
59		.stats = "sum",
60		denom_by = NULL,
61		id_var = NULL,
62		.formats = NULL,
63		.labels = NULL,
64		.indent_mods = NULL,
65		na_str = NULL,
66		...
67		) {
68		# Data Validation ------------------------------------------------------------
69	18x	valid_stats <- c("sum", "sum_unique", "ratio", "ratio_unique")
70
71	18x	checkmate::assert_data_frame(df)
72	18x	checkmate::assert_string(.var)
73	18x	checkmate::assert_names(colnames(df), must.include = .var)
74	18x	checkmate::assert_numeric(df[[.var]], .var.name = .var)
75	17x	checkmate::assert_subset(.stats, choices = valid_stats)
76
77	16x	needs_ratio <- any(.stats %in% c("ratio", "ratio_unique"))
78	16x	needs_unique <- any(.stats %in% c("sum_unique", "ratio_unique"))
79
80	16x	if (needs_ratio) {
81	11x	checkmate::assert_string(denom_by)
82	10x	checkmate::assert_names(colnames(df), must.include = denom_by)
83	10x	checkmate::assert_numeric(df[[denom_by]], .var.name = denom_by)
84		}
85	14x	if (needs_unique) {
86	3x	checkmate::assert_string(id_var)
87	2x	checkmate::assert_names(colnames(df), must.include = id_var)
88		}
89
90		# Helper funcs -----------------------------------------------
91	13x	sum_plain <- function(v) {
92	22x	sum(df[[v]], na.rm = TRUE)
93		}
94
95	13x	sum_unique <- function(v) {
96	4x	d <- unique(df[!is.na(df[[v]]), c(id_var, v), drop = FALSE])
97	4x	sum(d[[v]], na.rm = TRUE)
98		}
99
100	13x	safe_ratio <- function(n, d) {
101	11x	if (is.na(d) \|\| d == 0) {
102	3x	c(n, NA_real_)
103		} else {
104	8x	c(n, n / d)
105		}
106		}
107
108		# Default formats and labels -------------------------------------------------
109	13x	default_fmt <- c(
110	13x	sum = "xx",
111	13x	sum_unique = "xx",
112	13x	ratio = "xx (xx.x%)",
113	13x	ratio_unique = "xx (xx.x%)"
114		)
115	13x	default_lbl <- c(
116	13x	sum = "Sum",
117	13x	sum_unique = "Sum (unique)",
118	13x	ratio = "Ratio",
119	13x	ratio_unique = "Ratio (unique)"
120		)
121
122		# Compute stats ---------------------------------------------------------------
123	13x	n_plain <- if (any(.stats %in% c("sum", "ratio"))) {
124	13x	sum_plain(.var)
125		} else {
126	!	NULL
127		}
128	13x	n_unique <- if (any(.stats %in% c("sum_unique", "ratio_unique"))) {
129	2x	sum_unique(.var)
130		} else {
131	11x	NULL
132		}
133	13x	d_plain <- if (any(.stats %in% c("ratio")) && !is.null(denom_by)) {
134	9x	sum_plain(denom_by)
135		} else {
136	4x	NULL
137		}
138	13x	d_unique <- if (any(.stats %in% c("ratio_unique")) && !is.null(denom_by)) {
139	2x	sum_unique(denom_by)
140		} else {
141	11x	NULL
142		}
143
144		# Build result list ---------------------------------------------------------------
145	13x	x_stats <- list()
146	13x	if ("sum" %in% .stats) {
147	10x	x_stats[["sum"]] <- n_plain
148		}
149	13x	if ("sum_unique" %in% .stats) {
150	2x	x_stats[["sum_unique"]] <- n_unique
151		}
152	13x	if ("ratio" %in% .stats) {
153	9x	x_stats[["ratio"]] <- safe_ratio(n_plain, d_plain)
154		}
155	13x	if ("ratio_unique" %in% .stats) {
156	2x	x_stats[["ratio_unique"]] <- safe_ratio(n_unique, d_unique)
157		}
158
159		# Resolve formats and labels ------------------------------------------
160	13x	fmts <- default_fmt[names(x_stats)]
161	13x	labels <- default_lbl[names(x_stats)]
162	13x	if (!is.null(.formats)) {
163	2x	fmts[names(.formats)] <- .formats
164		}
165	13x	if (!is.null(.labels)) {
166	2x	labels[names(.labels)] <- .labels
167		}
168
169	13x	.format_na_strs <- if (!is.null(na_str)) {
170	!	lapply(names(fmts), function(x) na_str)
171		} else {
172	13x	NULL
173		}
174
175	13x	in_rows(
176	13x	.list = x_stats,
177	13x	.formats = as.list(fmts),
178	13x	.names = labels,
179	13x	.labels = labels,
180	13x	.indent_mods = .indent_mods,
181	13x	.format_na_strs = .format_na_strs
182		)
183		}

1		#' Split Function Factory for the Response Tables (RESP01)
2		#'
3		#' The main purpose here is to have a column dependent split into either comparative
4		#' statistic (relative risk or odds ratio with p-value) in the 'Overall' column,
5		#' and count proportions and corresponding confidence intervals in the other treatment
6		#' arm columns.
7		#'
8		#' @inheritParams proposal_argument_convention
9		#' @param method (`string`)\cr which method to use for the comparative statistics.
10		#'
11		#' @return A split function for use in the response table RESP01 and similar ones.
12		#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
13		#' post-processing function.
14		#' @export
15		#'
16		#' @examples
17		#' split_fun <- resp01_split_fun_fct(
18		#' method = "or_cmh",
19		#' conf_level = 0.95
20		#' )
21		resp01_split_fun_fct <- function(method = c("rr", "or_logistic", "or_cmh"), conf_level) {
22	2x	method <- match.arg(method)
23	2x	(assert_proportion_value)(conf_level)
24
25	2x	post_fun <- function(ret, spl, fulldf, .spl_context) {
26	8x	all_expr <- expression(TRUE)
27		# Here check if we are in 'Overall' column or not.
28	8x	this_col <- .spl_context[nrow(.spl_context), "value"][[1]]
29	8x	in_overall <- this_col == "Overall"
30		# Accordingly, return left and right column labels and value identifiers.
31	8x	if (in_overall) {
32		# In the Overall column, we want the comparison statistic and corresponding p-value.
33	2x	comp_stat_name <- if (method == "rr") "Relative Risk" else "Odds Ratio"
34	2x	short_split_result(
35	2x	comp_stat_ci = paste0(comp_stat_name, " (", f_conf_level(conf_level), ")~[super a]"),
36	2x	pval = "p-value~[super b]",
37	2x	fulldf = fulldf
38		)
39		} else {
40		# In the treatment arm columns, we want counts and CI for proportions.
41	6x	short_split_result(
42	6x	count_prop = "n (%)",
43	6x	prop_ci = paste0(f_conf_level(conf_level), " for %"),
44	6x	fulldf = fulldf
45		)
46		}
47		}
48	2x	make_split_fun(post = list(post_fun))
49		}
50
51		#' Content Row Function for Counts of Subgroups in Response Tables (RESP01)
52		#'
53		#' @inheritParams proposal_argument_convention
54		#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
55		#' @param label_fstr (`string`)\cr format string for the label.
56		#'
57		#' @return The correct [rtables::in_rows()] result.
58		#' @export
59		#'
60		#' @examples
61		#' fake_spl_context <- data.frame(
62		#' cur_col_split_val = I(list(c(ARM = "A: Drug X", count_prop = "count_prop")))
63		#' )
64		#' resp01_counts_cfun(
65		#' df = DM,
66		#' labelstr = "Blue",
67		#' .spl_context = fake_spl_context,
68		#' .alt_df = DM,
69		#' label_fstr = "Color: %s"
70		#' )
71		resp01_counts_cfun <- function(df, labelstr, .spl_context, .alt_df, label_fstr) {
72	3x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
73	3x	if (this_col_split[1] != "Overall" && this_col_split[2] == "count_prop") {
74	1x	in_rows(nrow(.alt_df), .formats = "xx", .labels = sprintf(label_fstr, labelstr))
75		} else {
76	2x	NULL
77		}
78		}
79
80		#' Formatted Analysis Function for Comparative Statistic in Response Tables (RESP01)
81		#'
82		#' This function applies to a `logical` column called `.var` from `df`.
83		#' The response proportion is compared between the treatment arms identified
84		#' by column `arm`.
85		#'
86		#' @inheritParams proposal_argument_convention
87		#' @param include (`flag`)\cr whether to include the results for this variable.
88		#' @param arm (`string`)\cr column name in the data frame that identifies the treatment arms.
89		#' @param formats (`list`)\cr containing formats for `comp_stat_ci` and `pval`.
90		#' @param methods (`list`)\cr containing methods for comparative statistics. The element `comp_stat_ci` can be
91		#' 'rr' (relative risk), 'or_cmh' (odds ratio with CMH estimation and p-value) or 'or_logistic' (odds ratio
92		#' estimated by conditional or standard logistic regression). The element `pval` can be 'fisher' (Fisher's
93		#' exact test) or 'chisq' (chi-square test), only used when using unstratified analyses with 'or_logistic'.
94		#' @param stat (`string`)\cr the statistic to return, either `comp_stat_ci`
95		#' or `pval`.
96		#'
97		#' @return The formatted result as [rtables::rcell()].
98		#' @seealso [resp01_a_comp_stat_factor()] for the `factor` equivalent.
99		#' @export
100		#'
101		#' @examples
102		#' dm <- droplevels(subset(formatters::DM, SEX %in% c("F", "M")))
103		#' dm$RESP <- as.logical(sample(c(TRUE, FALSE), size = nrow(DM), replace = TRUE))
104		#'
105		#' resp01_a_comp_stat_logical(
106		#' dm,
107		#' .var = "RESP",
108		#' conf_level = 0.9,
109		#' include = TRUE,
110		#' arm = "SEX",
111		#' strata = "RACE",
112		#' stat = "comp_stat_ci",
113		#' methods = list(comp_stat_ci = "or_cmh"),
114		#' formats = list(
115		#' comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
116		#' pval = jjcsformat_pval_fct(0.05)
117		#' )
118		#' )
119		resp01_a_comp_stat_logical <- function(df,
120		.var,
121		conf_level,
122		include,
123		arm,
124		strata,
125		formats,
126		methods,
127		stat = c("comp_stat_ci", "pval")) {
128	31x	checkmate::assert_logical(df[[.var]])
129	31x	checkmate::assert_factor(df[[arm]], n.levels = 2L)
130	31x	checkmate::assert_flag(include)
131	31x	stat <- match.arg(stat)
132
133	31x	if (include) {
134	10x	checkmate::assert_list(methods)
135	10x	checkmate::assert_subset(methods$comp_stat_ci, c("rr", "or_cmh", "or_logistic"))
136
137	10x	df_by <- split(df, f = df[[arm]])
138	10x	this_df <- df_by[[1]]
139	10x	this_ref_group <- df_by[[2]]
140
141	10x	this_res <- if (methods$comp_stat_ci == "rr") {
142		# Stratified CMH test for point estimate and p-value, and Wald statistic for the confidence interval
143	1x	s_res <- s_relative_risk(
144	1x	this_df,
145	1x	.var = .var,
146	1x	.ref_group = this_ref_group,
147	1x	.in_ref_col = FALSE,
148	1x	variables = list(strata = strata),
149	1x	conf_level = conf_level
150		)
151	1x	list(comp_stat_ci = s_res$rel_risk_ci, pval = s_res$pval)
152	10x	} else if (methods$comp_stat_ci == "or_logistic") {
153		# Odds Ratio Variant 1: (Conditional/Standard) Logistic regression for odds ratio point estimate and
154		# confidence interval.
155	3x	s_res <- s_odds_ratio_j(
156	3x	this_df,
157	3x	.var = .var,
158	3x	.ref_group = this_ref_group,
159	3x	.in_ref_col = FALSE,
160	3x	.df_row = rbind(this_df, this_ref_group),
161	3x	variables = list(arm = arm, strata = strata),
162	3x	conf_level = conf_level,
163	3x	method = "exact" # Only used if strata are present.
164		)
165	3x	pval <- if (is.null(strata)) {
166	3x	checkmate::assert_subset(methods$pval, c("fisher", "chisq"))
167
168		# If not stratified, then the p-value can come either from Fisher's exact or chi-square test.
169	3x	p_res <- s_test_proportion_diff(
170	3x	this_df,
171	3x	.var = .var,
172	3x	.ref_group = this_ref_group,
173	3x	.in_ref_col = FALSE,
174	3x	method = methods$pval
175		)
176	3x	p_res$pval
177		} else {
178	!	s_res$pval
179		}
180	3x	list(comp_stat_ci = s_res$or_ci, pval = pval)
181	10x	} else if (methods$comp_stat_ci == "or_cmh") {
182		# Odds Ratio Variant 2: Stratified CMH test for odds ratio point estimate and confidence interval and
183		# corresponding CMH test p-value.
184	6x	s_res <- s_odds_ratio_j(
185	6x	this_df,
186	6x	.var = .var,
187	6x	.ref_group = this_ref_group,
188	6x	.in_ref_col = FALSE,
189	6x	.df_row = rbind(this_df, this_ref_group),
190	6x	variables = list(arm = arm, strata = strata),
191	6x	conf_level = conf_level,
192	6x	method = "cmh"
193		)
194	6x	list(comp_stat_ci = s_res$or_ci, pval = s_res$pval)
195		}
196	10x	rcell(this_res[[stat]], format = formats[[stat]])
197		} else {
198	21x	NULL
199		}
200		}
201
202		#' Formatted Analysis Function for Comparative Statistic in Response Tables (RESP01)
203		#'
204		#' This function applies to a `factor` column called `.var` from `df`.
205		#'
206		#' @inheritParams proposal_argument_convention
207		#' @param include (`character`)\cr for which factor levels to include the comparison
208		#' statistic results.
209		#' @param \dots see [resp01_a_comp_stat_logical()] for additional required arguments.
210		#'
211		#' @return The formatted result as [rtables::rcell()].
212		#' @export
213		#'
214		#' @examples
215		#' dm <- droplevels(subset(formatters::DM, SEX %in% c("F", "M")))
216		#'
217		#' resp01_a_comp_stat_factor(
218		#' dm,
219		#' .var = "COUNTRY",
220		#' conf_level = 0.9,
221		#' include = c("USA", "CHN"),
222		#' arm = "SEX",
223		#' strata = "RACE",
224		#' stat = "comp_stat_ci",
225		#' methods = list(comp_stat_ci = "or_cmh"),
226		#' formats = list(
227		#' comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
228		#' pval = jjcsformat_pval_fct(0.05)
229		#' )
230		#' )
231		resp01_a_comp_stat_factor <- function(df,
232		.var,
233		include,
234		...) {
235	3x	checkmate::assert_factor(df[[.var]])
236	3x	checkmate::assert_character(include, null.ok = TRUE)
237	3x	checkmate::assert_subset(x = include, choices = levels(df[[.var]]))
238
239	3x	design_df <- as.data.frame(h_get_design_mat(df, .var))
240
241	3x	res <- sapply(X = levels(df[[.var]]), simplify = FALSE, FUN = function(lvl) {
242	27x	df[[.var]] <- design_df[[lvl]]
243	27x	resp01_a_comp_stat_logical(df = df, .var = .var, include = lvl %in% include, ...)
244		})
245	3x	in_rows(.list = res, .labels = levels(df[[.var]]))
246		}
247
248		#' Formatted Analysis and Content Summary Function for Response Tables (RESP01)
249		#'
250		#' This function applies to both `factor` and `logical` columns called
251		#' `.var` from `df`. Depending on the position in the split, it returns the
252		#' right formatted results for the RESP01 and related layouts.
253		#'
254		#' @inheritParams proposal_argument_convention
255		#' @inheritParams resp01_a_comp_stat_logical
256		#' @param include_comp (`character` or `flag`)\cr whether to include comparative
257		#' statistic results, either `character` for factors or `flag` for logicals.
258		#' @param .alt_df (`data.frame`)\cr alternative data frame used for denominator calculation.
259		#' @param arm (`string`)\cr column name in the data frame that identifies the treatment arms.
260		#' @param label (`string`)\cr only for logicals, which label to use. (For factors, the
261		#' labels are the factor levels.)
262		#' @param formats (`list`)\cr containing formats for `prop_ci`, `comp_stat_ci`
263		#' and `pval`.
264		#' @param methods (`list`)\cr containing methods for comparative statistics. The element `comp_stat_ci` can be
265		#' 'rr' (relative risk), 'or_cmh' (odds ratio with CMH estimation and p-value) or 'or_logistic' (odds ratio
266		#' estimated by conditional or standard logistic regression). The element `pval` can be 'fisher' (Fisher's
267		#' exact test) or 'chisq' (chi-square test), only used when using unstratified analyses with 'or_logistic'.
268		#' The element `prop_ci` specifies the method for proportion confidence interval calculation.
269		#'
270		#' @return The formatted result as [rtables::in_rows()] result.
271		#' @export
272		#'
273		#' @examples
274		#' fake_spl_context <- data.frame(
275		#' cur_col_split_val = I(list(c(ARM = "A: Drug X", count_prop = "count_prop")))
276		#' )
277		#' dm <- droplevels(subset(DM, SEX %in% c("F", "M")))
278		#' resp01_acfun(
279		#' dm,
280		#' .alt_df = dm,
281		#' .var = "COUNTRY",
282		#' .spl_context = fake_spl_context,
283		#' conf_level = 0.9,
284		#' include_comp = c("USA", "CHN"),
285		#' arm = "SEX",
286		#' strata = "RACE",
287		#' methods = list(
288		#' comp_stat_ci = "or_cmh",
289		#' pval = "",
290		#' prop_ci = "wald"
291		#' ),
292		#' formats = list(
293		#' prop_ci = jjcsformat_xx("xx.% - xx.%"),
294		#' comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
295		#' pval = jjcsformat_pval_fct(0.05)
296		#' )
297		#' )
298		#' fake_spl_context2 <- data.frame(
299		#' cur_col_split_val = I(list(c(ARM = "Overall", comp_stat_ci = "comp_stat_ci")))
300		#' )
301		#' resp01_acfun(
302		#' dm,
303		#' .alt_df = dm,
304		#' .var = "COUNTRY",
305		#' .spl_context = fake_spl_context2,
306		#' conf_level = 0.9,
307		#' include_comp = c("USA", "CHN"),
308		#' arm = "SEX",
309		#' strata = "RACE",
310		#' methods = list(
311		#' comp_stat_ci = "or_cmh",
312		#' pval = "",
313		#' prop_ci = "wald"
314		#' ),
315		#' formats = list(
316		#' prop_ci = jjcsformat_xx("xx.% - xx.%"),
317		#' comp_stat_ci = jjcsformat_xx("xx.xx (xx.xx - xx.xx)"),
318		#' pval = jjcsformat_pval_fct(0.05)
319		#' )
320		#' )
321		resp01_acfun <- function(df,
322		labelstr = NULL,
323		label = NULL,
324		.var,
325		.spl_context,
326		include_comp,
327		.alt_df,
328		conf_level,
329		arm,
330		strata,
331		formats,
332		methods) {
333	3x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
334	3x	x <- df[[.var]]
335	3x	is_factor <- is.factor(x)
336	3x	res <- if (this_col_split[1] != "Overall") {
337	1x	if (this_col_split[2] == "count_prop") {
338	1x	if (is_factor) {
339	1x	s_proportion_factor(x, .alt_df = .alt_df)
340		} else {
341	!	s_proportion_logical(x, .alt_df = .alt_df)$n_prop
342		}
343		} else {
344	!	checkmate::assert_true(this_col_split[2] == "prop_ci")
345	!	if (is_factor) {
346	!	a_proportion_ci_factor(
347	!	df,
348	!	.var = .var,
349	!	.alt_df = .alt_df,
350	!	conf_level = conf_level,
351	!	formats = formats,
352	!	method = methods$prop_ci
353		)
354		} else {
355	!	a_proportion_ci_logical(
356	!	x,
357	!	.alt_df = .alt_df,
358	!	conf_level = conf_level,
359	!	formats = formats,
360	!	method = methods$prop_ci
361		)
362		}
363		}
364		} else {
365	2x	checkmate::assert_true(this_col_split[1] == "Overall")
366	2x	if (is_factor) {
367	1x	resp01_a_comp_stat_factor(
368	1x	df,
369	1x	.var = .var,
370	1x	conf_level = conf_level,
371	1x	include = include_comp,
372	1x	arm = arm,
373	1x	strata = strata,
374	1x	stat = this_col_split[2],
375	1x	formats = formats,
376	1x	methods = methods
377		)
378		} else {
379	1x	resp01_a_comp_stat_logical(
380	1x	df,
381	1x	.var = .var,
382	1x	conf_level = conf_level,
383	1x	include = include_comp,
384	1x	arm = arm,
385	1x	strata = strata,
386	1x	stat = this_col_split[2],
387	1x	formats = formats,
388	1x	methods = methods
389		)
390		}
391		}
392	3x	if (is_factor) {
393	2x	res
394		} else {
395	1x	if (!is.null(labelstr)) {
396	1x	label <- labelstr
397		}
398	1x	in_rows(res, .labels = label)
399		}
400		}

1		#' @name a_two_tier
2		#'
3		#' @title Two Tier Analysis Function
4		#'
5		#' @author GB, WW.
6		#'
7		#' @description `a_two_tier()`: The analysis function used as an `afun` in \link[rtables]{analyze}.
8		#' This function simulates a final additional level of nesting with a
9		#' traditional analyze call inside it.
10		#'
11		#' This makes it possible to create what appear to be group summary or
12		#' content rows and to optionally or conditionally generate one or more
13		#' "detail" rows underneath it.
14		#'
15		#' For example, in a disposition table, one might want counts for completed
16		#' and ongoing patients with no further detail underneath, but a breakdown of
17		#' specific reasons beneath the count of patients who discontinued treatment.
18		#'
19		#' @details `a_two_tier()`: Both the analysis variable and `inner_var` must be factors.
20		#' Detail rows are differentiated by having an indent mod of one, causing them
21		#' to hang indented under their corresponding group row.
22		#'
23		#' @note In its current form, this function may not retain any formatting or
24		#' labeling instructions added by `grp_fun` or `detail_fun`, and it will
25		#' override any `.indent_mods` values specified by them. This behavior may
26		#' change in future versions.
27		#'
28		#' @inheritParams proposal_argument_convention
29		#' @param inner_var (`string`)\cr single variable name to use when generating
30		#' the detail rows.
31		#' @param drill_down_levs (`character`)\cr the level(s) of `.var` under which
32		#' detail rows should be generated.
33		#' @param use_all_levels (`flag`)\cr controls which factor levels will be
34		#' present for `inner_var` (both in `df`/`x` and in `.df_row`) when calling
35		#' `detail_fun`.
36		#' If `TRUE`, all levels (those present on the factor `.df_row[[inner_var]]`,
37		#' *regardless if the level is observed in the row group or not) will be
38		#' present when creating detail rows.
39		#' Otherwise (the default), only the levels observed
40		#' anywhere in the row group, i.e., within `.df_row` will be present.
41		#' @param grp_fun (`function`)\cr analysis function to be used when generating
42		#' the "group summary" outer rows.
43		#' @param detail_fun (`function`)\cr analysis function to be used when generating
44		#' "detail" inner rows.
45		#' @param .alt_df_full (`dataframe`)\cr denominator dataset for fraction and
46		#' relative risk calculations.\cr
47		#' this argument gets populated by the rtables split machinery
48		#' (see [rtables::additional_fun_params]).
49		#' @param ... additional arguments passed directly to `grp_fun` and `detail_fun`.
50		#'
51		#' @return `a_two_tier()`: A `RowsVerticalSection` object including both the group row and all
52		#' detail rows, if applicable, for the facet.
53		#'
54		#' @import checkmate
55		#' @export
56		#'
57		#' @examples
58		#'
59		#' # Example 1
60		#'
61		#' lyt_obs_levels <- basic_table() \|>
62		#' split_cols_by("ARM") \|>
63		#' split_rows_by("EOSSTT", child_labels = "hidden") \|>
64		#' analyze("EOSSTT",
65		#' afun = a_two_tier,
66		#' extra_args = list(
67		#' grp_fun = simple_analysis,
68		#' detail_fun = simple_analysis,
69		#' inner_var = "DCSREAS",
70		#' drill_down_levs = "DISCONTINUED"
71		#' )
72		#' )
73		#'
74		#' tbl <- build_table(lyt_obs_levels, ex_adsl)
75		#' tbl
76		#'
77		#' lyt_all_levels <- basic_table() \|>
78		#' split_cols_by("ARM") \|>
79		#' split_rows_by("EOSSTT", child_labels = "hidden") \|>
80		#' analyze("EOSSTT",
81		#' afun = a_two_tier,
82		#' extra_args = list(
83		#' grp_fun = simple_analysis,
84		#' detail_fun = simple_analysis,
85		#' inner_var = "DCSREAS",
86		#' drill_down_levs = "DISCONTINUED",
87		#' use_all_levels = TRUE
88		#' )
89		#' )
90		#'
91		#' adsl_subset <- subset(ex_adsl, DCSREAS != "ADVERSE EVENT")
92		#' levels(adsl_subset$DCSREAS)
93		#'
94		#' tbl_all_levels <- build_table(lyt_all_levels, adsl_subset)
95		#' tbl_all_levels
96		#'
97		#' tbl_obs_levels <- build_table(lyt_obs_levels, adsl_subset)
98		#' tbl_obs_levels
99		#'
100		#' # Example 2
101		#'
102		#' library(dplyr)
103		#'
104		#' trtvar <- "ARM"
105		#' ctrl_grp <- "B: Placebo"
106		#'
107		#' adsl <- ex_adsl \|> select(c("USUBJID", "STRATA1", "EOSSTT", "DCSREAS", all_of(trtvar)))
108		#' adsl$colspan_trt <- factor(
109		#' ifelse(adsl[[trtvar]] == ctrl_grp, " ", "Active Study Agent"),
110		#' levels = c("Active Study Agent", " ")
111		#' )
112		#' adsl$rrisk_header <- "Risk Difference (%) (95% CI)"
113		#' adsl$rrisk_label <- paste(adsl[[trtvar]], paste("vs", ctrl_grp))
114		#'
115		#' colspan_trt_map <- create_colspan_map(
116		#' df = adsl,
117		#' non_active_grp = ctrl_grp,
118		#' non_active_grp_span_lbl = " ",
119		#' active_grp_span_lbl = "Active Study Agent",
120		#' colspan_var = "colspan_trt",
121		#' trt_var = trtvar
122		#' )
123		#'
124		#' a_freq_j_args <- list(
125		#' .stats = "count_unique_fraction",
126		#' denom = "n_altdf",
127		#' ref_path = c("colspan_trt", " ", trtvar, ctrl_grp)
128		#' )
129		#'
130		#' two_tier_args <- list(
131		#' grp_fun = a_freq_j,
132		#' detail_fun = a_freq_j,
133		#' inner_var = "DCSREAS",
134		#' drill_down_levs = "DISCONTINUED"
135		#' )
136		#'
137		#' lyt_rrisk <- basic_table() \|>
138		#' split_cols_by("colspan_trt", split_fun = trim_levels_to_map(map = colspan_trt_map)) \|>
139		#' split_cols_by(trtvar) \|>
140		#' split_cols_by("rrisk_header", nested = FALSE) \|>
141		#' split_cols_by(trtvar, labels_var = "rrisk_label", split_fun = remove_split_levels(ctrl_grp)) \|>
142		#' split_rows_by("STRATA1") \|>
143		#' split_rows_by("EOSSTT", child_labels = "hidden") \|>
144		#' analyze("EOSSTT", afun = a_two_tier, extra_args = c(two_tier_args, a_freq_j_args))
145		#'
146		#' adsl_subset <- subset(
147		#' adsl,
148		#' EOSSTT != "COMPLETED" & (is.na(DCSREAS) \| DCSREAS != "PROTOCOL VIOLATION")
149		#' )
150		#'
151		#' tbl_rrisk <- build_table(lyt_rrisk, adsl_subset, alt_counts_df = adsl_subset)
152		#' tbl_rrisk
153		#'
154		a_two_tier <- function(df,
155		labelstr = NULL,
156		.var,
157		.N_col,
158		.df_row,
159		inner_var,
160		drill_down_levs,
161		.spl_context,
162		use_all_levels = FALSE,
163		grp_fun,
164		detail_fun,
165		.alt_df_full = NULL,
166		...) {
167	72x	assert_string(inner_var)
168	72x	assert_character(drill_down_levs)
169	72x	assert_flag(use_all_levels)
170	72x	assert_function(grp_fun)
171	72x	assert_function(detail_fun)
172
173	72x	if (!all(sapply(c(.var, inner_var), \(x) is.factor(df[[x]])))) {
174	!	stop("a_two_tier requires both input variables .var and inner_var as factor")
175		}
176
177	72x	cur_grp <- tail(.spl_context$value, 1)
178	72x	df[[.var]] <- factor(df[[.var]], levels = cur_grp)
179	72x	.df_row[[.var]] <- factor(.df_row[[.var]], levels = cur_grp)
180	72x	args <- list(
181	72x	labelstr = labelstr,
182	72x	.var = .var,
183	72x	.N_col = .N_col,
184	72x	.df_row = .df_row,
185	72x	.spl_context = .spl_context,
186	72x	.alt_df_full = .alt_df_full,
187		...
188		)
189	72x	if (names(formals(grp_fun))[1] == "df") {
190	!	args <- c(list(df = df), args)
191		} else {
192	72x	args <- c(list(x = df[[.var]]), args)
193		}
194	72x	if (identical(grp_fun, a_freq_j)) {
195		# this will ensure row with cur_grp will be presented
196		# even if 0 observed in current row
197	!	args[["drop_levels"]] <- FALSE
198	!	args <- c(list(val = cur_grp), args)
199		}
200	72x	cell_vals <- unclass(
201	72x	do.call(grp_fun, args)
202		)
203	72x	names(cell_vals) <- attr(cell_vals, "row_label")
204
205		## calculate the drill-down values if necessary
206	72x	if (cur_grp %in% drill_down_levs && any(!is.na(.df_row[[inner_var]]))) {
207		## have to make sure we use all levels for the whole row group
208		## so that each column gets the same number of values in the same order
209	12x	all_inner_levs <- levels(df[[inner_var]])
210	12x	if (use_all_levels) {
211	3x	detail_levs <- all_inner_levs
212		} else {
213	9x	detail_levs <- all_inner_levs[all_inner_levs %in% all_inner_levs[.df_row[[inner_var]]]]
214		}
215
216	12x	inner_vec <- factor(df[[inner_var]], levels = detail_levs)
217	12x	df[[inner_var]] <- factor(df[[inner_var]], levels = detail_levs)
218	12x	.df_row[[inner_var]] <- factor(.df_row[[inner_var]], levels = detail_levs)
219	12x	det_args <- list(
220	12x	.var = inner_var,
221	12x	.N_col = .N_col,
222	12x	.df_row = .df_row,
223	12x	.spl_context = .spl_context,
224	12x	.alt_df_full = .alt_df_full,
225		...
226		)
227	12x	if (names(formals(detail_fun))[1] == "df") {
228	!	det_args <- c(list(df = df), det_args)
229		} else {
230	12x	det_args <- c(list(x = df[[inner_var]]), det_args)
231		}
232
233	12x	detail_vals <- unclass(
234	12x	do.call(detail_fun, det_args)
235		)
236
237	12x	names(detail_vals) <- attr(detail_vals, "row_label")
238		} else {
239	60x	detail_vals <- list()
240		}
241	72x	in_rows(
242	72x	.list = c(cell_vals, detail_vals),
243	72x	.indent_mods = c(0, rep(1, length.out = length(detail_vals)))
244		)
245		}
246
247
248		#' @rdname a_two_tier
249		#'
250		#' @description `a_three_tier()`: Extends `a_two_tier()` by adding a third level
251		#' of nesting: a group summary outer row, mid-level detail rows (one per level
252		#' of `inner_var1`), and innermost detail rows (one per level of `inner_var2`)
253		#' nested beneath each mid-level row.
254		#'
255		#' @details `a_three_tier()`: The analysis variable, `inner_var1`, and `inner_var2` must all be
256		#' factors. Mid-level rows are indented by one and innermost rows by two,
257		#' relative to the group summary row.
258		#'
259		#' @inheritParams a_two_tier
260		#' @param inner_var1 (`string`)\cr single variable name to use when generating
261		#' the mid-level (second tier) detail rows.
262		#' @param inner_var2 (`string`)\cr single variable name to use when generating
263		#' the innermost (third tier) detail rows, nested under each level of `inner_var1`.
264		#'
265		#' @return `a_three_tier()`: A `RowsVerticalSection` object including the group row, mid-level
266		#' detail rows, and innermost detail rows, if applicable, for the facet.
267		#'
268		#' @import checkmate
269		#' @export
270		#'
271		a_three_tier <- function(df,
272		labelstr = NULL,
273		.var,
274		.N_col,
275		.df_row,
276		inner_var1,
277		inner_var2,
278		drill_down_levs,
279		.spl_context,
280		use_all_levels = FALSE,
281		grp_fun,
282		detail_fun,
283		.alt_df_full = NULL,
284		...) {
285	72x	assert_string(inner_var1)
286	72x	assert_string(inner_var2)
287	72x	assert_character(drill_down_levs)
288	72x	assert_flag(use_all_levels)
289	72x	assert_function(grp_fun)
290	72x	assert_function(detail_fun)
291
292	72x	if (!all(sapply(c(.var, inner_var1, inner_var2), \(x) is.factor(df[[x]])))) {
293	!	stop("a_three_tier requires all input variables .var, inner_var1 and inner_var2 as factor")
294		}
295
296	72x	cur_grp <- tail(.spl_context$value, 1)
297	72x	df[[.var]] <- factor(df[[.var]], levels = cur_grp)
298	72x	.df_row[[.var]] <- factor(.df_row[[.var]], levels = cur_grp)
299	72x	args <- list(
300	72x	labelstr = labelstr,
301	72x	.var = .var,
302	72x	.N_col = .N_col,
303	72x	.df_row = .df_row,
304	72x	.spl_context = .spl_context,
305	72x	.alt_df_full = .alt_df_full,
306		...
307		)
308	72x	if (names(formals(grp_fun))[1] == "df") {
309	!	args <- c(list(df = df), args)
310		} else {
311	72x	args <- c(list(x = df[[.var]]), args)
312		}
313
314	72x	if (identical(grp_fun, a_freq_j)) {
315		# this will ensure row with cur_grp will be presented
316		# even if 0 observed in current row
317	!	args[["drop_levels"]] <- FALSE
318	!	args <- c(list(val = cur_grp), args)
319		}
320		# perform calculation for outer level values
321	72x	cell_vals <- unclass(
322	72x	do.call(grp_fun, args)
323		)
324	72x	names(cell_vals) <- attr(cell_vals, "row_label")
325
326		## calculate the drill-down values if necessary
327	72x	if (cur_grp %in% drill_down_levs && any(!is.na(.df_row[[inner_var1]]))) {
328		## have to make sure we use all levels for the whole row group
329		## so that each column gets the same number of values in the same order
330	12x	all_inner_levs <- levels(df[[inner_var1]])
331
332	12x	if (use_all_levels) {
333	3x	detail_levs <- all_inner_levs
334		} else {
335	9x	detail_levs <- all_inner_levs[all_inner_levs %in% all_inner_levs[.df_row[[inner_var1]]]]
336		}
337
338	12x	inner_vec <- factor(df[[inner_var1]], levels = detail_levs)
339	12x	df[[inner_var1]] <- factor(df[[inner_var1]], levels = detail_levs)
340	12x	.df_row[[inner_var1]] <- factor(.df_row[[inner_var1]], levels = detail_levs)
341
342		# inner_vec will be looped over each level separately to act as a row_group
343		# .df_row_inner will reflect .df_row + filter to level of inner_var
344		# inner_vec2 can be done at once
345		# .df_row_inner
346	12x	df_orig <- df
347	12x	df_row_orig <- .df_row
348	12x	detail_vals <- c()
349	12x	indentmods <- c()
350	12x	detail_vals_lbl <- c()
351	12x	for (i in seq_along(detail_levs)) {
352	33x	inner_lev_i <- detail_levs[i]
353		# restrict to current row & i-th level of inner_va1
354	33x	.df_row <- df_row_orig[df_row_orig[[inner_var1]] == inner_lev_i, ]
355	33x	.df_row[[inner_var1]] <- factor(.df_row[[inner_var1]], levels = inner_lev_i)
356	33x	df <- df_orig[df_orig[[inner_var1]] == inner_lev_i, ]
357	33x	df[[inner_var1]] <- factor(df[[inner_var1]], levels = inner_lev_i)
358
359		# get levels of inner_var2
360	33x	all_inner_levs2 <- levels(df[[inner_var2]])
361	33x	if (use_all_levels) {
362	9x	detail_levs2 <- all_inner_levs2
363		} else {
364		# restrict to observed levels of inner_var2 in this updated df_row
365		# cur_grp (level of outer var (.var)) and inner_lev_i (level of mid level var (inner_var1))
366	24x	detail_levs2 <- all_inner_levs2[all_inner_levs2 %in% all_inner_levs2[.df_row[[inner_var2]]]]
367		}
368	33x	inner_vec2 <- factor(df[[inner_var2]], levels = detail_levs2)
369	33x	df[[inner_var2]] <- factor(df[[inner_var2]], levels = detail_levs2)
370	33x	.df_row[[inner_var2]] <- factor(.df_row[[inner_var2]], levels = detail_levs2)
371
372	33x	det_args <- list(
373	33x	.var = inner_var1,
374	33x	.N_col = .N_col,
375	33x	.df_row = .df_row,
376	33x	.spl_context = .spl_context,
377	33x	.alt_df_full = .alt_df_full,
378		...
379		)
380	33x	if (names(formals(detail_fun))[1] == "df") {
381	!	det_args <- c(list(df = df), det_args)
382		} else {
383	33x	det_args <- c(list(x = df[[inner_var1]]), det_args)
384		}
385
386		# mid level values at level inner_lev_i
387	33x	detail_vals_i <- unclass(
388	33x	do.call(detail_fun, det_args)
389		)
390
391	33x	names(detail_vals_i) <- attr(detail_vals_i, "row_label")
392
393		# now get the inner level ones
394	33x	if (any(!is.na(.df_row[[inner_var2]]))) {
395	30x	det_args2 <- list(
396	30x	.var = inner_var2,
397	30x	.N_col = .N_col,
398	30x	.df_row = .df_row,
399	30x	.spl_context = .spl_context,
400	30x	.alt_df_full = .alt_df_full,
401		...
402		)
403	30x	if (names(formals(detail_fun))[1] == "df") {
404	!	det_args2 <- c(list(df = df), det_args2)
405		} else {
406	30x	det_args2 <- c(list(x = df[[inner_var2]]), det_args2)
407		}
408	30x	detail_vals2 <- unclass(
409	30x	do.call(detail_fun, det_args2)
410		)
411	30x	detail_vals2_lbl <- attr(detail_vals2, "row_label")
412	30x	if (i > 1) {
413	21x	names(detail_vals2) <- paste0(attr(detail_vals2, "row_label"), "[[", i, "]]")
414		} else {
415	9x	names(detail_vals2) <- attr(detail_vals2, "row_label")
416		}
417	30x	detail_vals <- c(detail_vals, detail_vals_i, detail_vals2)
418	30x	indentmods <- c(indentmods, c(1, rep(2, length.out = length(detail_vals2))))
419	30x	detail_vals_lbl <- c(detail_vals_lbl, names(detail_vals_i), detail_vals2_lbl)
420		}
421		}
422		} else {
423	60x	detail_vals <- list()
424	60x	indentmods <- NULL
425	60x	detail_vals_lbl <- c()
426		}
427
428	72x	in_rows(
429	72x	.list = c(cell_vals, detail_vals),
430	72x	.indent_mods = c(0, indentmods),
431	72x	.labels = c(names(cell_vals), detail_vals_lbl)
432		)
433		}

1		#' @name a_freq_subcol_j
2		#'
3		#' @title Analysis function count and percentage with extra column-subsetting in
4		#' selected columns (controlled by subcol_* arguments)
5		#'
6		#' @inheritParams proposal_argument_convention
7		#' @inheritParams a_freq_j
8		#' @param subcol_split (`string`)\cr text to search colid to determine whether further subsetting
9		#' should be performed.
10		#' @param subcol_var (`string`)\cr name of variable containing to be searched for the text
11		#' identified in subcol_val argument.
12		#' @param subcol_val (`string`)\cr value to use to perform further data sub-setting.
13		#' @param denom (`string`)\cr
14		#' One of \cr
15		#' \itemize{
16		#' \item \strong{N_col} Column count, \cr
17		#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
18		#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
19		#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
20		#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
21		#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
22		#' (`.row_df` from the rtables splitting machinery).\cr
23		#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
24		#' This higher row-level split is specified in the argument `denom_by`.\cr
25		#' }
26		#' @param .formats (named 'character' or 'list')\cr
27		#' formats for the statistics.
28		#' @seealso [a_freq_j()] for extensive `label_map` usage examples.
29		#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
30		#' @export
31		#'
32		#' @examples
33		#' library(dplyr)
34		#'
35		#' ADSL <- ex_adsl \|>
36		#' select(USUBJID, ARM)
37		#'
38		#' ADSL$COLSPAN_REL <- "AEs"
39		#'
40		#' ADAE <- ex_adae \|>
41		#' select(USUBJID, ARM, AEDECOD, AREL)
42		#'
43		#' ADAE <- ADAE \|>
44		#' mutate(
45		#' AEREL = case_when(
46		#' AREL == "Y" ~ "RELATED",
47		#' AREL == "N" ~ "NOT RELATED"
48		#' ),
49		#' AEREL = factor(AEREL),
50		#' COLSPAN_REL = "AEs"
51		#' )
52		#'
53		#' combodf <- tribble(
54		#' ~valname, ~label, ~levelcombo, ~exargs,
55		#' "RELATED", "Related AEs", c("AEs"), list()
56		#' )
57		#'
58		#' lyt <- basic_table(show_colcounts = TRUE) \|>
59		#' split_cols_by("COLSPAN_REL", split_fun = rtables::add_combo_levels(combodf, trim = TRUE)) \|>
60		#' split_cols_by("ARM") \|>
61		#' analyze("AEDECOD",
62		#' afun = a_freq_subcol_j,
63		#' extra_args = list(
64		#' subcol_split = "RELATED",
65		#' subcol_var = "AEREL",
66		#' subcol_val = "RELATED"
67		#' )
68		#' )
69		#'
70		#' result <- build_table(lyt, ADAE, alt_counts_df = ADSL)
71		#'
72		#' result
73		a_freq_subcol_j <- function(
74		df,
75		labelstr = NULL,
76		.var = NA,
77		val = NULL,
78		# arguments specific to a_freq_subcol_j
79		subcol_split = NULL,
80		subcol_var = NULL,
81		subcol_val = NULL,
82		# arguments specific to a_freq_subcol_j till here
83		.df_row,
84		.spl_context,
85		.N_col,
86		id = "USUBJID",
87		denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
88		label = NULL,
89		label_fstr = NULL,
90		label_map = NULL,
91		.alt_df_full = NULL,
92		denom_by = NULL,
93		.stats = c("count_unique_denom_fraction"),
94		.formats = NULL,
95		.labels_n = NULL,
96		.indent_mods = NULL,
97		na_str = rep("NA", 3)
98		) {
99	6x	denom <- match.arg(denom)
100
101	6x	if (!is.null(labelstr) && is.na(.var)) {
102	!	stop(
103	!	"Argument var must be specified in call to summarize_row_groups when using cfun = a_freq_subcol_j."
104		)
105		}
106
107	6x	check_alt_df_full(denom, "n_altdf", .alt_df_full)
108
109	6x	res_dataprep <- h_a_freq_dataprep(
110	6x	df = df,
111	6x	labelstr = labelstr,
112	6x	.var = .var,
113	6x	val = val,
114	6x	drop_levels = FALSE,
115	6x	excl_levels = NULL,
116	6x	new_levels = NULL,
117	6x	new_levels_after = FALSE,
118	6x	.df_row = .df_row,
119	6x	.spl_context = .spl_context,
120	6x	.N_col = .N_col,
121	6x	id = id,
122	6x	denom = denom,
123	6x	variables = NULL,
124	6x	label = label,
125	6x	label_fstr = label_fstr,
126	6x	label_map = label_map,
127	6x	.alt_df_full = .alt_df_full,
128	6x	denom_by = denom_by,
129	6x	.stats = .stats
130		)
131		# res_dataprep is list with elements
132		# df .df_row val
133		# drop_levels excl_levels
134		# alt_df parentdf new_denomdf
135		# .stats
136		# make these elements available in current environment
137	6x	df <- res_dataprep$df
138	6x	.df_row <- res_dataprep$.df_row
139	6x	val <- res_dataprep$val
140	6x	alt_df <- res_dataprep$alt_df
141	6x	parentdf <- res_dataprep$parentdf
142	6x	new_denomdf <- res_dataprep$new_denomdf
143	6x	.stats <- res_dataprep$.stats
144
145		## colid can be used to figure out if we're in subcolum
146	6x	colid <- .spl_context$cur_col_id[[1]]
147
148		### this is the core code for subsetting to appropriate subcol_val
149	6x	insubcol <- grepl(subcol_split, colid, fixed = TRUE)
150	6x	if (insubcol) {
151	3x	df <- subset(df, df[[subcol_var]] == subcol_val)
152		}
153
154		## the same s-function can be used as in a_freq_j
155	6x	x_stats <- s_freq_j(
156	6x	df,
157	6x	.var = .var,
158	6x	.df_row = .df_row,
159	6x	val = val,
160	6x	alt_df = new_denomdf,
161	6x	parent_df = new_denomdf,
162	6x	id = id,
163	6x	denom = denom,
164	6x	.N_col = .N_col,
165	6x	countsource = "df"
166		)
167
168	6x	.stats_adj <- .stats
169
170	6x	res_prepinrows <- h_a_freq_prepinrows(
171	6x	x_stats,
172	6x	.stats_adj,
173	6x	.formats,
174	6x	labelstr,
175	6x	label_fstr,
176	6x	label,
177	6x	.indent_mods,
178	6x	.labels_n,
179	6x	na_str
180		)
181		# res_prepinrows is list with elements
182		# x_stats .formats .labels .indent_mods .format_na_strs
183		# make these elements available in current environment
184	6x	x_stats <- res_prepinrows$x_stats
185	6x	.formats <- res_prepinrows$.formats
186	6x	.labels <- res_prepinrows$.labels
187	6x	.indent_mods <- res_prepinrows$.indent_mods
188	6x	.format_na_strs <- res_prepinrows$.format_na_strs
189
190		### final step: turn requested stats into rtables rows
191	6x	inrows <- in_rows(
192	6x	.list = x_stats,
193	6x	.formats = .formats,
194	6x	.labels = .labels,
195	6x	.indent_mods = .indent_mods,
196	6x	.format_na_strs = .format_na_strs
197		)
198
199	6x	return(inrows)
200		}

1		#' @keywords internal
2		formatter_references <- list(
3		"jjcsformat_xx" =
4		jjcsformat_xx("xx.xxxxxxxxx"),
5		"jjcsformat_fraction" =
6		jjcsformat_cnt_den_fract_fct(type = "count_fraction"),
7		"jjcsformat_pval" =
8		jjcsformat_pval_fct(alpha = 0),
9		"jjcsformat_range" =
10		jjcsformat_range_fct("xx.xx"),
11		"format_xx" =
12		format_xx("xx"),
13		"format_extreme_values" =
14		format_extreme_values(2L),
15		"format_extreme_values_ci" =
16		format_extreme_values_ci(2L),
17		"format_count_fraction_fixed_dp" =
18		format_count_fraction_fixed_dp,
19		"format_count_fraction" =
20		format_count_fraction,
21		"format_fraction_fixed_dp" =
22		format_fraction_fixed_dp,
23		"format_sigfig_j" = format_sigfig_j(sigfig = 3, "xx")
24		)
25
26		#' @keywords internal
27		body_matches <- function(fmtfun, reference_fun) {
28	!	identical(deparse(body(fmtfun)), deparse(body(reference_fun)))
29		}
30
31		#' @keywords internal
32		get_input_jjcs_fmtfun <- function(fmtfun) {
33	!	if (length(fmtfun) != 1) {
34	!	stop("fmtfun should be of length 1")
35		}
36
37	!	if (is.list(fmtfun)) {
38	!	fmtfun <- fmtfun[[1]]
39		}
40
41	!	result <- list(
42	!	fun_fact = "",
43	!	str = "",
44	!	d = NA_integer_,
45	!	str_formatters = NA,
46	!	type = "",
47	!	alpha = "",
48	!	message = "",
49	!	fmt_package = "",
50	!	is_fun = FALSE,
51	!	fun = fmtfun,
52	!	round_type = FALSE,
53	!	whole_integer = NA,
54	!	drop0trailing = NA,
55	!	zero_threshold = 0
56		)
57
58	!	valid_fmt_str <- unlist(list_valid_format_labels(), use.names = FALSE)
59
60		# Handle character inputs separately.
61	!	if (is.character(fmtfun)) {
62	!	if (fmtfun %in% valid_fmt_str) {
63	!	result$fun_fact <- ""
64	!	result$str <- fmtfun
65	!	result$str_formatters <- TRUE
66	!	result$fmt_package <- "formatters"
67	!	result$round_type <- TRUE
68		} else {
69	!	result$fun_fact <- "string"
70	!	result$str <- fmtfun
71	!	result$str_formatters <- FALSE
72	!	result$message <- paste(
73	!	"fmtfun is a string but not a supported formatting value"
74		)
75		}
76
77	!	return(result)
78		}
79
80	!	if (!is.function(fmtfun)) {
81	!	result$message <- paste(
82	!	"fmtfun is not a function/character"
83		)
84
85	!	message(result$message)
86
87	!	return(result)
88		}
89
90		# from here on fmtfun is a function
91	!	x_body_matches <- sapply(formatter_references, body_matches, fmtfun = fmtfun)
92	!	formatter_key <- if (any(x_body_matches)) {
93	!	names(formatter_references)[which(x_body_matches)[1L]]
94		} else {
95	!	"unknown"
96		}
97
98	!	result$is_fun <- TRUE
99	!	if (formatter_key != "unknown") {
100	!	result$round_type <- "round_type" %in% names(formals(fmtfun))
101		}
102	!	switch(formatter_key,
103		"jjcsformat_xx" = {
104	!	result$fun_fact <- "jjcsformat_xx"
105	!	result$str <- get0(
106	!	"str",
107	!	envir = environment(fmtfun),
108	!	ifnotfound = ""
109		)
110	!	result$str_formatters <- FALSE
111	!	result$fmt_package <- "junco"
112		},
113		"jjcsformat_fraction" = {
114	!	result$fun_fact <- "jjcsformat_fraction"
115	!	result$type <- get0(
116	!	"type",
117	!	envir = environment(fmtfun),
118	!	ifnotfound = ""
119		)
120	!	result$fmt_package <- "junco"
121		},
122		"jjcsformat_pval" = {
123	!	result$fun_fact <- "jjcsformat_pval"
124	!	result$alpha <- as.character(
125	!	get0(
126	!	"alpha",
127	!	envir = environment(fmtfun),
128	!	ifnotfound = ""
129		)
130		)
131	!	result$fmt_package <- "junco"
132		},
133		"jjcsformat_range" = {
134	!	result$fun_fact <- "jjcsformat_range"
135	!	result$str <- as.character(
136	!	get0(
137	!	"str",
138	!	envir = environment(fmtfun),
139	!	ifnotfound = ""
140		)
141		)
142	!	result$fmt_package <- "junco"
143		},
144		"format_xx" = {
145	!	result$fun_fact <- "format_xx"
146	!	result$str <- as.character(
147	!	get0(
148	!	"str",
149	!	envir = environment(fmtfun),
150	!	ifnotfound = ""
151		)
152		)
153	!	result$fmt_package <- "tern"
154		},
155		"format_extreme_values" = {
156	!	result$fun_fact <- "format_extreme_values"
157	!	result$str <- "???"
158	!	result$fmt_package <- "tern"
159		},
160		"format_extreme_values_ci" = {
161	!	result$fun_fact <- "format_extreme_values_ci"
162	!	result$str <- "???"
163	!	result$fmt_package <- "tern"
164		},
165		"format_count_fraction_fixed_dp" = {
166	!	result$fun_fact <- "format_count_fraction_fixed_dp"
167	!	result$fmt_package <- "tern"
168		},
169		"format_count_fraction" = {
170	!	result$fun_fact <- "format_count_fraction"
171	!	result$fmt_package <- "tern"
172		},
173		"format_fraction_fixed_dp" = {
174	!	result$fun_fact <- "format_fraction_fixed_dp"
175	!	result$fmt_package <- "tern"
176		},
177		"format_sigfig_j" = {
178	!	result$fun_fact <- "format_sigfig_j"
179	!	result$str <- as.character(
180	!	get0(
181	!	"format",
182	!	envir = environment(fmtfun),
183	!	ifnotfound = ""
184		)
185		)
186	!	result$d <- as.numeric(
187	!	get0(
188	!	"sigfig",
189	!	envir = environment(fmtfun),
190	!	ifnotfound = ""
191		)
192		)
193	!	result$whole_integer <-
194	!	get0(
195	!	"whole_integer",
196	!	envir = environment(fmtfun),
197	!	ifnotfound = FALSE
198		)
199	!	result$drop0trailing <-
200	!	get0(
201	!	"drop0trailing",
202	!	envir = environment(fmtfun),
203	!	ifnotfound = FALSE
204		)
205	!	result$zero_threshold <-
206	!	get0(
207	!	"zero_threshold",
208	!	envir = environment(fmtfun),
209	!	ifnotfound = 0L
210		)
211	!	result$fmt_package <- "junco"
212		},
213		"unknown" = {
214	!	result$fun_fact <- "???"
215	!	result$fmt_package <- "???"
216	!	result$message <- paste(
217	!	"fmtfun is an unknown formatting function not defined",
218	!	"in formatters/tern/junco"
219		)
220		}
221		)
222
223	!	result
224		}
225
226
227		#' @name fmt_utils
228		#'
229		#' @title Utilities for reviewing format specification objects
230		#'
231		#' @details fmt_utils general details
232		#'
233		#' @description `r lifecycle::badge("experimental")`
234		#'
235		#' @param myfmts A named list of either formatting specifications (ie stats with its associated formats)
236		#' or a list of variables with formatting specifications.
237		#'
238		#' @param recursive `logical(1)`
239		#' Set to `TRUE` when requesting details from named list of variables with specifications.
240		#' Set to `FALSE` when requesting details from named list of statistics with format specifications.
241		#'
242		#' @param as_tibble `logical(1)` When `TRUE`, convert the information into a tibble for ease of reviewing.
243		#'
244		#'
245		#' @param fmt1 A named list of formatting specifications (ie stats with its associated format)
246		#' @param fmt2 Another named list of formatting specifications (ie stats with its associated format),
247		#' to compare against `fmt1`
248		NULL
249
250		#' @describeIn fmt_utils A utility function to collect information on formatting specification in list or tibble format.
251		#'
252		#' The following information is collected:
253		#' - var (variable name): Only applicable if the format specification is a named list with formattings specs
254		#' (eg list("AGE" = c("mean" = "xx", "se" = "xx.x"), "BMI" = c("mean" = "xx.x", "se" = "xx.xx"))), eg processed via
255		#' `fmt_spec_var_d` function.
256		#' - stat (name of statistic)
257		#' - fun_fact : name of function factory that has produced the format specification
258		#' (if spec is from formatting function, blank if spec is string).\cr
259		#' Only the following known formatting functions are supported:
260		#'
261		#' - jjcsformat_xx
262		#' - jjcsformat_cnt_den_fract_fct,
263		#' - jjcsformat_pval_fct,
264		#' - jjcsformat_range_fct,
265		#' - tern::format_xx,
266		#' - tern::format_extreme_values,
267		#' - tern::format_extreme_values_ci,
268		#' - tern::format_count_fraction_fixed_dp,
269		#' - tern::format_count_fraction,
270		#' - tern::format_fraction_fixed_dp,
271		#' - format_sigfig_j
272		#'
273		#' - str: string from specification, or str from formatting function factory (`jjcsformat_xx`, ....)
274		#' - str_formatters: (`logical`) Is the str value a valid format string as in ([list_valid_format_labels()])?
275		#' - type: when formatting function factory `jjcsformat_cnt_den_fract_fct` is used
276		#' - alpha: when formatting function factory `jjcsformat_pval_fct` is used
277		#' - message: Message when formatting function is unknown, or input string was
278		#' not valid format string as in ([list_valid_format_labels()])
279		#' - fmt_package: In which package was the formatting specification defined.
280		#' - is_fun: (`logical`) Is the formatting specification a function?
281		#' - round_type: (`logical`) Does the formatting support `round_type` argument/behavior?
282		#' - fun: Formatting string or body of the formatting function.
283		#'
284		#' Only when one of the formats provided is based upon formatting function factory `format_sigfig_j` setup:
285		#' - d: value used for `sigfig`
286		#' - whole_integer: value used for `whole_integer`
287		#' - drop0trailing: value used for `drop0trailing`
288		#' - zero_threshold: value used for `zero_threshold`
289		#' @examples
290		#' # Example for get_fmt_details --
291		#' junco_def_d <- c(
292		#' "mean" = "xx.dx",
293		#' "mean_sd" = "xx.dx (xx.dxx)",
294		#' "range" = "(xx.d, xx.d)"
295		#' )
296		#'
297		#' myfmts <- fmt_spec_single_d(
298		#' d = 1,
299		#' stats_in = c("mean", "mean_sd"),
300		#' fmt_d_def = junco_def_d,
301		#' fmt_d_in = NULL
302		#' )
303		#'
304		#' fmt_details <- get_fmt_details(myfmts, as_tibble = TRUE)
305		#'
306		#' myfmts2 <- fmt_spec_single_d(
307		#' d = 3,
308		#' stats_in = c("mean", "mean_sd"),
309		#' fmt_d_def = junco_def_d,
310		#' fmt_d_in = NULL
311		#' )
312		#' fmt_details2 <- get_fmt_details(myfmts2, as_tibble = TRUE)
313		#' fmt_details2
314		#'
315		#' # Example for get_fmt_details using format specs for variables --
316		#' # processed with fmt_spec_var_d
317		#' var <- c("AGE" = 0, "BMI" = 1, "BMRKR1" = 2)
318		#' vars_fmt <- fmt_spec_var_d(var,
319		#' stats_in = NULL,
320		#' fmt_d_def = junco_def_d,
321		#' fmt_d_in = NULL
322		#' )
323		#' fmt_details2 <- get_fmt_details(vars_fmt, as_tibble = TRUE, recursive = TRUE)
324		#'
325		#' @export
326		get_fmt_details <- function(myfmts, recursive = FALSE, as_tibble = TRUE) {
327	!	lst <- if (recursive) {
328	!	lapply(myfmts, get_fmt_details, as_tibble = as_tibble)
329		} else {
330	!	lapply(myfmts, get_input_jjcs_fmtfun)
331		}
332
333	!	names(lst) <- names(myfmts)
334
335	!	if (!recursive && as_tibble) {
336	!	df <- do.call(
337	!	rbind,
338	!	lapply(names(lst), function(nm) {
339	!	xx <- lst[[nm]]
340	!	xx$fun <- NULL
341	!	data.frame(
342	!	stat = nm,
343	!	as.data.frame(xx, stringsAsFactors = FALSE)
344		)
345		})
346		)
347	!	df <- dplyr::as_tibble(df)
348
349	!	df$fun <- lapply(lst, `[[`, "fun")
350	!	lst <- df
351		}
352
353	!	if (recursive && as_tibble) {
354	!	lst <- dplyr::bind_rows(lst, .id = "var")
355		}
356
357	!	if (as_tibble && !any(lst[["fun_fact"]] == "format_sigfig_j")) {
358		# drop format_sigfig_j specific columns
359	!	dropcols <- c("d", "whole_integer", "drop0trailing", "zero_threshold")
360	!	lst <- lst[, setdiff(names(lst), dropcols), drop = FALSE]
361		}
362	!	lst
363		}
364
365
366		#' @noRd
367		#' @param fmt_t1 Tibble information from specification 1
368		#' @param fmt_t2 Tibble information from specification 2
369		#' @keywords internal
370		compare_fmt_tibble <- function(fmt_t1, fmt_t2) {
371	!	nms <- names(fmt_t1)
372	!	nms <- nms[nms != "fun"]
373	!	fmt_t1_x <- fmt_t1[, nms]
374	!	fmt_t2_x <- fmt_t2[, nms]
375	!	c1 <- identical(fmt_t1_x, fmt_t2_x)
376
377	!	fmt_t1_y <- fmt_t1[["fun"]][[1]]
378	!	fmt_t2_y <- fmt_t2[["fun"]][[1]]
379	!	if (is.function(fmt_t1_y) && is.function(fmt_t2_y)) {
380	!	c2 <- body_matches(fmt_t1_y, fmt_t2_y)
381	!	} else if (is.character(fmt_t1_y) && is.character(fmt_t2_y)) {
382	!	c2 <- identical(fmt_t1_y, fmt_t2_y)
383		} else {
384	!	c2 <- FALSE
385		}
386
387	!	rslt <- c1 & c2
388		}
389
390		#' @describeIn fmt_utils A utility to report findings in differences between 2 formatting specification vectors.
391		#' It returns a list object with the following information:
392		#' - spec1 : For statistics with a different specification, tibble with specification details from `fmt1`.
393		#' - spec2 : For statistics with a different specification, tibble with specification details from `fmt2`.
394		#' The tibbles in `spec1` and `spec2` contain information as described in `get_fmt_details()`.
395		#' - msg: Message on how many stats have a difference in specification.
396		#' - comm_stats: Vector of stats in common between `fmt1` and `fmt2`.
397		#' - diff_stats: Vector of stats with any difference identified.
398		#' @examples
399		#'
400		#' # Example for compare_fmt_specs --
401		#' test1_target <- junco_default_formats
402		#' # junco_def_d_all has been constructed with d = 1 as reference
403		#' # compare against junco_default_formats
404		#' test1_d <- fmt_spec_single_d(
405		#' d = 1,
406		#' stats_in = NULL,
407		#' fmt_d_def = junco_def_d_all,
408		#' fmt_d_in = NULL
409		#' )
410		#'
411		#' check1 <- compare_fmt_specs(test1_d, test1_target)
412		#' check1
413		#'
414		#' # more differences when using other d
415		#' test2_d <- fmt_spec_single_d(
416		#' d = 2,
417		#' stats_in = NULL,
418		#' fmt_d_def = junco_def_d_all,
419		#' fmt_d_in = NULL
420		#' )
421		#'
422		#' check2 <- compare_fmt_specs(test2_d, test1_target)
423		#'
424		#' @export
425		#'
426		compare_fmt_specs <- function(fmt1, fmt2) {
427	!	result <- list(
428	!	spec1 = NULL,
429	!	spec2 = NULL,
430	!	msg = NULL,
431	!	comm_stats = NULL,
432	!	diff_stats = NULL
433		)
434	!	stats_diff <- NULL
435
436	!	stats1 <- names(fmt1)
437	!	stats2 <- names(fmt2)
438	!	stats <- intersect(stats1, stats2)
439	!	if (length(stats) == 0) {
440	!	result$msg <- "No stats in common"
441	!	result$comm_stats <- NULL
442		} else {
443	!	result$comm_stats <- stats
444	!	fmt1 <- fmt1[stats]
445	!	fmt2 <- fmt2[stats]
446
447	!	check <- sapply(names(fmt1), \(stat) {
448	!	fmt_t1 <- get_fmt_details(list(stat = fmt1[[stat]]))
449	!	fmt_t2 <- get_fmt_details(list(stat = fmt2[[stat]]))
450	!	fmt_t1[["stat"]] <- stat
451	!	fmt_t2[["stat"]] <- stat
452
453	!	compare_fmt_tibble(fmt_t1, fmt_t2)
454		})
455
456	!	if (sum(!check) == 0) {
457	!	result$msg <- "All common stats specs identical"
458		} else {
459	!	stats_diff <- check[!check]
460	!	stats_diff <- names(stats_diff)
461	!	result$spec1 <- get_fmt_details(fmt1[stats_diff])
462	!	result$spec2 <- get_fmt_details(fmt2[stats_diff])
463	!	result$msg <- paste0(length(stats_diff), " common stats with differences in specs")
464	!	result$diff_stats <- stats_diff
465		}
466		}
467
468	!	if (!is.null(result$msg)) {
469	!	message(result$msg)
470	!	message("More details are available in created object.")
471		}
472	!	return(result)
473		}

1		#' Relative risk estimation
2		#'
3		#' The analysis function [a_relative_risk()] is used to create a layout element
4		#' to estimate the relative risk for response within a studied population using
5		#' stratified CMH or unstratified Wald methods.
6		#' The primary analysis variable, `vars`, is a logical variable indicating
7		#' whether a response has occurred for each record.
8		#' For CMH, a stratification variable must be supplied via the
9		#' `strata` element of the `variables` argument.
10		#'
11		#' @details The variance of the CMH relative risk estimate is calculated using
12		#' the Greenland and Robins (1985) variance estimation.
13		#' The unstratified `wald` and `waldcc` methods use a normal approximation
14		#' for the log relative risk.
15		#' `waldcc` adds 0.5 to
16		#' each response count and each group total in both the estimate and variance.
17		#' With `wald`, a zero response count gives undefined confidence limits and
18		#' p-value (`NA`).
19		#'
20		#' @param df (`data.frame`)\cr input data frame.
21		#' @param .var (`string`)\cr name of the response variable.
22		#' @param ref_path (`character`)\cr path to the reference group.
23		#' @param .spl_context (`environment`)\cr split context environment.
24		#' @param ... Additional arguments passed to the statistics function.
25		#' @param .stats (`character`)\cr statistics to calculate.
26		#' @param .formats (`list`)\cr formats for the statistics.
27		#' @param .labels (`list`)\cr labels for the statistics.
28		#' @param .indent_mods (`list`)\cr indentation modifications for the statistics.
29		#' @param .ref_group (`data.frame`)\cr reference group data frame.
30		#' @param .in_ref_col (`logical(1)`)\cr whether the current column is the reference column.
31		#' @param variables (`list`)\cr list with strata variable names.
32		#' @param conf_level (`numeric`)\cr confidence level for the confidence interval.
33		#' @param complete_cases (`logical(1)`) \cr whether to remove incomplete rows from `df`
34		#' before constructing the response, group, strata, and contingency table.
35		#' @param method (`string`)\cr relative risk method: `cmh`, `wald`, or `waldcc`.
36		#' @param weights_method (`string`)\cr method to use for weights calculation in stratified analysis.
37		#'
38		#' @name relative_risk
39		NULL
40
41		#' @describeIn relative_risk Statistics function estimating the relative risk for response.
42		#'
43		#' @return
44		#' * `s_relative_risk()` returns a named list of elements `rel_risk_ci` and `pval`.
45		#'
46		#' @examples
47		#' nex <- 100
48		#' dta <- data.frame(
49		#' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
50		#' "grp" = sample(c("A", "B"), nex, TRUE),
51		#' "f1" = sample(c("a1", "a2"), nex, TRUE),
52		#' "f2" = sample(c("x", "y", "z"), nex, TRUE),
53		#' stringsAsFactors = TRUE
54		#' )
55		#'
56		#' s_relative_risk(
57		#' df = subset(dta, grp == "A"),
58		#' .var = "rsp",
59		#' .ref_group = subset(dta, grp == "B"),
60		#' .in_ref_col = FALSE,
61		#' variables = list(strata = c("f1", "f2")),
62		#' conf_level = 0.90
63		#' )
64		#' @export
65		s_relative_risk <- function(
66		df,
67		.var,
68		.ref_group = NULL,
69		.in_ref_col = NULL,
70		variables = list(strata = NULL),
71		conf_level = 0.95,
72		complete_cases = FALSE,
73		method = c("cmh", "wald", "waldcc"),
74		weights_method = "cmh"
75		) {
76	17x	checkmate::assert_flag(.in_ref_col, null.ok = TRUE)
77	17x	method <- match.arg(method)
78	16x	weights_method <- match.arg(weights_method)
79
80	16x	y <- if (is.null(.in_ref_col) \|\| .in_ref_col) {
81	5x	list(
82	5x	rel_risk_ci = c(est = NA_real_, lcl = NA_real_, ucl = NA_real_),
83	5x	pval = NA_real_
84		)
85		} else {
86	11x	prepared <- tern::h_prepare_rsp_table(
87	11x	df = df,
88	11x	df_ref = .ref_group,
89	11x	var = .var,
90	11x	strata_vars = if (method == "cmh") variables$strata else NULL,
91	11x	complete_cases = complete_cases
92		)
93
94	11x	if (method == "cmh") {
95	5x	prop_ratio_cmh(tbl = prepared$tbl, conf_level = conf_level)
96		} else {
97	6x	prop_ratio_wald(tbl = prepared$tbl, conf_level = conf_level, correction = (method == "waldcc"))
98		}
99		}
100
101	15x	y$rel_risk_ci <- with_label(
102	15x	x = y$rel_risk_ci,
103	15x	label = paste0("Relative risk (", f_conf_level(conf_level), ")")
104		)
105	15x	y$pval <- unname(y$pval)
106
107	15x	y
108		}
109
110		#' @describeIn relative_risk Formatted analysis function which is used as `afun`. Note that the
111		#' junco specific `ref_path` and `.spl_context` arguments are used for reference column information.
112		#'
113		#' @return
114		#' * `a_relative_risk()` returns the corresponding list with formatted [rtables::CellValue()].
115		#'
116		#' @examples
117		#' nex <- 100
118		#' dta <- data.frame(
119		#' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
120		#' "grp" = sample(c("A", "B"), nex, TRUE),
121		#' "f1" = sample(c("a1", "a2"), nex, TRUE),
122		#' "f2" = sample(c("x", "y", "z"), nex, TRUE),
123		#' stringsAsFactors = TRUE
124		#' )
125		#'
126		#' l <- basic_table() \|>
127		#' split_cols_by(var = "grp") \|>
128		#' analyze(
129		#' vars = "rsp",
130		#' afun = a_relative_risk,
131		#' extra_args = list(
132		#' conf_level = 0.90,
133		#' variables = list(strata = "f1"),
134		#' ref_path = c("grp", "B")
135		#' )
136		#' )
137		#'
138		#' build_table(l, df = dta)
139		#' @export
140		#' @order 2
141		a_relative_risk <- function(
142		df,
143		.var,
144		ref_path,
145		.spl_context,
146		...,
147		.stats = NULL,
148		.formats = NULL,
149		.labels = NULL,
150		.indent_mods = NULL
151		) {
152		# Check for additional parameters to the statistics function
153	6x	dots_extra_args <- list(...)
154
155		# Only support default stats, not custom stats
156	6x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
157
158		# Obtain reference column information
159	6x	ref <- get_ref_info(ref_path, .spl_context)
160
161		# Apply statistics function
162	6x	x_stats <- .apply_stat_functions(
163	6x	default_stat_fnc = s_relative_risk,
164	6x	custom_stat_fnc_list = NULL,
165	6x	args_list = c(
166	6x	df = list(df),
167	6x	.var = .var,
168	6x	.ref_group = list(ref$ref_group),
169	6x	.in_ref_col = ref$in_ref_col,
170	6x	dots_extra_args
171		)
172		)
173
174		# Format according to specifications
175	6x	format_stats(
176	6x	x_stats,
177	6x	method_groups = "relative_risk",
178	6x	stats_in = .stats,
179	6x	formats_in = .formats,
180	6x	labels_in = .labels,
181	6x	indents_in = .indent_mods
182		)
183		}
184
185
186		#' @keywords internal
187		safe_mh_test <- function(...) {
188	13x	tryCatch(
189	13x	stats::mantelhaen.test(...),
190	13x	error = function(e) list(p.value = NA_real_)
191		)
192		}
193
194		#' Relative Risk CMH Statistic
195		#'
196		#' Calculates the relative risk which is defined as the ratio between the
197		#' response rates between the experimental treatment group and the control treatment group, adjusted
198		#' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights.
199		#'
200		#' @inheritParams proposal_argument_convention
201		#' @param tbl (`array`)\cr a 2 by 2 by number of strata contingency table, as returned
202		#' in the `tbl` element of [tern::h_prepare_rsp_table()]. Rows (first dimension) are reference
203		#' then treatment; columns (second dimension) are responders then nonresponders;
204		#' the third dimension represents the strata.
205		#'
206		#' @return A list with elements `rel_risk_ci` and `pval`.
207		#' @examples
208		#'
209		#' set.seed(2)
210		#' rsp <- factor(
211		#' sample(c(TRUE, FALSE), 100, TRUE),
212		#' levels = c(TRUE, FALSE)
213		#' )
214		#' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
215		#' grp <- factor(grp, levels = c("Placebo", "Treatment"))
216		#' strata_data <- data.frame(
217		#' "f1" = sample(c("a", "b"), 100, TRUE),
218		#' "f2" = sample(c("x", "y", "z"), 100, TRUE),
219		#' stringsAsFactors = TRUE
220		#' )
221		#'
222		#' tbl <- table(grp, rsp, interaction(strata_data))
223		#' prop_ratio_cmh(
224		#' tbl = tbl,
225		#' conf_level = 0.90
226		#' )
227		#'
228		#' @export
229		prop_ratio_cmh <- function(tbl, conf_level = 0.95) {
230	13x	assert_response_table(tbl, stratified = TRUE)
231	10x	checkmate::assert_number(conf_level, lower = 0, upper = 1)
232	10x	if (any(apply(tbl, 3L, sum) < 5)) {
233	!	warning("Less than 5 observations in some strata.")
234		}
235		# Rows are reference then treatment; columns are strata, including a single stratum.
236	10x	n_resp <- matrix(tbl[, 1L, ], nrow = 2)
237	10x	n <- margin.table(tbl, margin = c(1L, 3L))
238	10x	checkmate::assert_integerish(as.vector(n), lower = 0)
239
240		# CMH statistic for relative risk, Treatment over Control
241	10x	use_stratum <- colSums(n > 0) == 2L
242	10x	n <- n[, use_stratum, drop = FALSE]
243	10x	n_resp <- n_resp[, use_stratum, drop = FALSE]
244	10x	n_total <- colSums(n)
245
246	10x	rel_risk_num <- sum(n_resp[2L, ] * n[1L, ] / n_total)
247	10x	rel_risk_denom <- sum(n_resp[1L, ] * n[2L, ] / n_total)
248	10x	log_rel_risk <- log(rel_risk_num) - log(rel_risk_denom)
249	10x	rel_risk <- exp(log_rel_risk)
250
251	10x	var_num <- sum((n[1L, ] * n[2L, ] * colSums(n_resp) - n_resp[1L, ] * n_resp[2L, ] * n_total) / n_total^2)
252	10x	var_denom <- rel_risk_num * rel_risk_denom
253	10x	var_log_rel_risk <- var_num / var_denom
254	10x	se_log_rel_risk <- sqrt(var_log_rel_risk)
255
256	10x	z <- stats::qnorm((1 + conf_level) / 2)
257	10x	log_rel_risk_ci <- log_rel_risk + c(-1, +1) * z * se_log_rel_risk
258	10x	ci <- exp(log_rel_risk_ci)
259	10x	rel_risk_ci <- stats::setNames(c(rel_risk, ci), c("est", "lcl", "ucl"))
260
261	10x	if (any(rowSums(tbl[, 1L, , drop = FALSE]) == 0)) {
262	4x	rel_risk_ci <- c(est = NA_real_, lcl = 0, ucl = Inf)
263		}
264
265	10x	pval <- safe_mh_test(tbl, correct = FALSE)$p.value
266
267	10x	list(
268	10x	rel_risk_ci = rel_risk_ci,
269	10x	pval = pval
270		)
271		}
272
273
274		#' Relative Risk Wald Statistic
275		#'
276		#' Estimates the relative response risk in the second group divided by that in the first
277		#' group, with log-scale Wald confidence limits and a two-sided Wald p-value.
278		#'
279		#' @inheritParams proposal_argument_convention
280		#' @param tbl (`matrix`)\cr a 2 by 2 contingency table, as returned in the
281		#' `tbl` element of [tern::h_prepare_rsp_table()]. Rows are reference then
282		#' treatment; columns are responders then nonresponders.
283		#' @param correction (`flag`)\cr whether to add 0.5 to the response counts and
284		#' group totals, in order to support the case where there are zero responses in either group
285		#' (Haldane-Anscombe correction).
286		#' @return A `list` containing two elements:
287		#' * `rel_risk_ci`: A named numeric vector (`est`, `lcl`, `ucl`) specifying the point estimate,
288		#' lower confidence limit, and upper confidence limit of the relative risk.
289		#' * `pval`: A numeric scalar representing the two-sided Wald p-value.
290		#'
291		#' @examples
292		#' prop_ratio_wald(
293		#' tbl = rbind(ref = c(1, 1), trt = c(2, 1)),
294		#' correction = TRUE
295		#' )
296		#' @export
297		prop_ratio_wald <- function(tbl, conf_level = 0.95, correction = FALSE) {
298	28x	assert_response_table(tbl)
299	25x	checkmate::assert_number(conf_level, lower = 0, upper = 1)
300	24x	checkmate::assert_flag(correction)
301
302	23x	n_resp <- tbl[, 1L]
303	23x	n <- rowSums(tbl)
304	23x	checkmate::assert_true(all(n > 0))
305
306	22x	if (correction) {
307	11x	add_on <- 0.5
308	11x	n_resp <- n_resp + add_on
309	11x	n <- n + add_on
310		}
311	22x	estimate <- (n_resp[2L] / n[2L]) / (n_resp[1L] / n[1L])
312
313	22x	if (any(n_resp == 0)) {
314	3x	if (is.nan(estimate)) {
315	1x	estimate <- NA_real_
316		}
317	3x	ci <- c(NA_real_, NA_real_)
318	3x	pval <- NA_real_
319		} else {
320	19x	se <- sqrt(sum(1 / n_resp - 1 / n))
321	19x	log_rr <- log(estimate)
322	19x	z <- stats::qnorm((1 + conf_level) / 2)
323	19x	ci <- exp(log_rr + c(-1, 1) * z * se)
324	19x	pval <- if (se == 0) 1 else 2 * stats::pnorm(-abs(log_rr / se))
325		}
326
327	22x	list(
328	22x	rel_risk_ci = stats::setNames(
329	22x	c(estimate, ci),
330	22x	c("est", "lcl", "ucl")
331		),
332	22x	pval = unname(pval)
333		)
334		}

1		#' Stratified Exposure-Adjusted Incidence Rate (EAIR)
2		#' @name a_eair_strat_j
3		#' @description
4		#' Statistical/Analysis function for presenting a stratified exposure-adjusted
5		#' incidence rate (EAIR) and its Wald confidence interval across strata
6		#' (e.g., study size weighted exposure).
7		#'
8		#' This function is an extension to the unstratified function `a_eair100_j()`.
9		#'
10		#' @details
11		#' The weighting method uses raw event counts `n_ti` in both the rate and variance.
12		#' \deqn{\hat r_{ti} = \texttt{num\_p\_year} \times \frac{n_{ti}}{T_{ti}}}
13		#'
14		#'
15		#' The strata weight is `w_i = T_0i + T_1i` (total person-years across
16		#' all groups in strata `i`), and the pooled weighted rate is:
17		#' \deqn{\hat r_t = \sum_i \frac{w_i}{W} \hat r_{ti}, \quad W = \sum_i w_i}
18		#'
19		#' The Wald 95% CI for the pooled rate is:
20		#' \deqn{\hat r_t \pm z_{1-\alpha/2} \times \frac{\texttt{num\_p\_year}}{W}
21		#' \sqrt{\sum_i w_i^2 \frac{n_{ti}}{T_{ti}^2}}}.
22		#'
23		#' The weighted rate difference and its Wald CI are:
24		#' \deqn{\hat\delta = \sum_i \frac{w_i}{W}(\hat r_{1i} - \hat r_{0i})}
25		#' \deqn{\hat\delta \pm z_{1-\alpha/2} \times \frac{\texttt{num\_p\_year}}{W}
26		#' \sqrt{\sum_i w_i^2 \left(\frac{n_{1i}+c}{T_{1i}^2} + \frac{n_{0i}}{T_{0i}^2}\right)}}
27		#'
28		#' @inherit a_eair100_j params
29		#' @inherit s_eair100_levii_j params
30		#'
31		#' @param strata (`string`)\cr variable identifying strata (e.g., study identifier).
32		#'
33		#' @return
34		#' * `s_eair_strat_levii_j()` returns a list containing the following statistics:
35		#'
36		#' \itemize{
37		#' \item `n_event_total`: total event count across strata (current arm)
38		#' \item `person_years_total`: total person-years across strata (current arm)
39		#' \item `eair_strat`: stratified pooled EAIR per `num_p_year` person-years
40		#' \item `n_eair_strat`: composite of `n_event_total` and `eair_strat`
41		#' \item `eair_strat_ci`: Wald CI for `eair_strat`
42		#' \item `eair_strat_est_ci`: composite of `eair_strat` and `eair_strat_ci`
43		#' \item `eair_strat_n`: composite of `eair_strat` and `n_event_total`
44		#' \item `eair_strat_n_py`: composite of `eair_strat`, `n_event_total` and `person_years_total`
45		#' \item `eair_strat_diff_est_ci`: stratified rate difference with Wald CI
46		#' (only when `vs_ref_group = TRUE`, otherwise `NULL`)
47		#' \item `eair_strat_diff_est`: estimate for the difference in stratified rate
48		#' \item `eair_strat_diff_ci`: CI (Wald type) for the difference in stratified rate
49		#' }
50		#'
51		#'
52		#' The list of available statistics (core columns) can also be viewed by
53		#' running `junco_get_stats("a_eair_strat_j")`.
54		#' @seealso [a_eair100_j()]
55		#' @references
56		#' Scosyrev, E & Pethe, A (2022). Confidence intervals for exposure-adjusted rate
57		#' differences in randomized trials.
58		#' Pharmaceutical Statistics, 2022;21:103–121.
59		#' doi: 10.1002/pst.2155
60		#'
61		#' Crowe, B., Chuang-Stein, C., Lettis, S., & Brueckner, A. (2016).
62		#' Reporting adverse drug reactions in product labels.
63		#' Therapeutic Innovation & Regulatory Science, 50(4), 455-463.
64		#' doi: 10.1177/2168479016628574
65
66
67		#'
68		#'
69		#' @keywords internal
70		s_eair_strat_levii_j <- function(
71		levii,
72		df,
73		.df_row,
74		.alt_df_full,
75		.var,
76		strata,
77		id = "USUBJID",
78		fup_var,
79		occ_var = NULL,
80		occ_dy = NULL,
81		num_p_year = 100,
82		count_multiple_events = FALSE,
83		conf_level = 0.95,
84		vs_ref_group = FALSE,
85		.in_ref_col,
86		cur_col_expr,
87		ref_col_expr,
88		inriskdiffcol = FALSE
89		) {
90	40x	checkmate::assert_string(strata)
91	40x	checkmate::assert_string(fup_var)
92	40x	checkmate::assert_string(occ_var, null.ok = TRUE)
93	40x	checkmate::assert_flag(vs_ref_group)
94	40x	if (!is.null(occ_var)) {
95	36x	checkmate::assert_string(occ_dy, null.ok = FALSE)
96		}
97	40x	checkmate::assert_names(colnames(.alt_df_full), must.include = c(id, fup_var, strata))
98
99	40x	denom_df_full_mod <- h_get_eair_df(
100	40x	levii = levii,
101	40x	df = .df_row,
102	40x	denom_df = .alt_df_full,
103	40x	.var = .var,
104	40x	id = id,
105	40x	fup_var = fup_var,
106	40x	occ_var = occ_var,
107	40x	occ_dy = occ_dy,
108	40x	count_multiple_events = count_multiple_events,
109	40x	strata = strata
110		)
111	40x	denom_df_full_mod <- denom_df_full_mod$df_denom
112
113		# study weights from FULL denominator (all arms combined per study)
114	40x	w_by_strata <- tapply(
115	40x	denom_df_full_mod[["mod_fup_var"]],
116	40x	denom_df_full_mod[[strata]],
117	40x	sum,
118	40x	na.rm = TRUE
119		)
120	40x	strata_levels <- names(w_by_strata)
121
122		# gather common arguments for .get_stratum
123	40x	.alt_df_full_cur_group <- subset(.alt_df_full, eval(cur_col_expr))
124	40x	args_get_stratum <- list(
125	40x	strata = strata,
126	40x	strata_levels = strata_levels,
127	40x	levii = levii,
128	40x	.var = .var,
129	40x	id = id,
130	40x	fup_var = fup_var,
131	40x	occ_var = occ_var,
132	40x	occ_dy = occ_dy,
133	40x	count_multiple_events = count_multiple_events
134		)
135	40x	stratum_stats <- do.call(
136	40x	.get_stratum_stats,
137	40x	args = append(
138	40x	list(
139	40x	df_arm = df,
140	40x	denom_arm = .alt_df_full_cur_group
141		),
142	40x	args_get_stratum
143		)
144		)
145
146		# gather common arguments for h_s_eair_strat_numbers
147	40x	args_get_numbers <- list(
148	40x	strata = strata,
149	40x	w_by_strata = w_by_strata,
150	40x	num_p_year = num_p_year
151		)
152
153	40x	curcore <- do.call(
154	40x	h_s_eair_strat_numbers,
155	40x	args = append(
156	40x	list(stratum_stats = stratum_stats),
157	40x	args_get_numbers
158		)
159		)
160
161	40x	n_vec <- curcore$n_vec
162	40x	py_vec <- curcore$py_vec
163	40x	r_vec <- curcore$r_vec
164	40x	w_vec <- curcore$w_vec
165
166	40x	.stats <- h_s_eair_strat_estimates(
167	40x	n_vec = n_vec,
168	40x	py_vec = py_vec,
169	40x	r_vec = r_vec,
170	40x	w_vec = w_vec,
171	40x	conf_level = conf_level,
172	40x	num_p_year = num_p_year
173		)
174
175		# rate difference vs reference arm
176	40x	diff_stats <- list()
177	40x	if (vs_ref_group) {
178	25x	ref_denom_df <- subset(.alt_df_full, eval(ref_col_expr))
179	25x	ref_df <- subset(.df_row, eval(ref_col_expr))
180
181	25x	ref_stratum_stats <- do.call(
182	25x	.get_stratum_stats,
183	25x	args = append(
184	25x	list(
185	25x	df_arm = ref_df,
186	25x	denom_arm = ref_denom_df
187		),
188	25x	args_get_stratum
189		)
190		)
191
192	25x	refcore <- do.call(
193	25x	h_s_eair_strat_numbers,
194	25x	args = append(
195	25x	list(stratum_stats = ref_stratum_stats),
196	25x	args_get_numbers
197		)
198		)
199
200	25x	ref_n_vec <- refcore$n_vec
201	25x	ref_py_vec <- refcore$py_vec
202	25x	ref_r_vec <- refcore$r_vec
203
204	25x	diff_stats <- h_s_eair_strat_diff_estimates(
205	25x	n_vec = n_vec,
206	25x	py_vec = py_vec,
207	25x	r_vec = r_vec,
208	25x	w_vec = w_vec,
209	25x	ref_n_vec = ref_n_vec,
210	25x	ref_py_vec = ref_py_vec,
211	25x	ref_r_vec = ref_r_vec,
212	25x	num_p_year = num_p_year,
213	25x	conf_level = conf_level
214		)
215		} else {
216	15x	diff_stats$eair_strat_diff_est_ci <- numeric(0)
217		}
218
219	40x	attr(diff_stats$eair_strat_diff_est_ci, "label") <- paste0(
220	40x	"Difference in stratified EAIR (",
221	40x	formatC(conf_level * 100, format = "f", digits = 0), "% CI, Wald)"
222		)
223
224	40x	.stats <- append(.stats, diff_stats)
225	40x	.stats
226		}
227
228		#' @describeIn a_eair_strat_j
229		#' Formatted analysis function for stratified (eg study size-weighted) EAIR, used as `afun`
230		#' in [rtables::analyze()].
231		#'
232		#'
233		#' @return
234		#' * `a_eair_strat_j()` returns a list of formatted [rtables::CellValue()] rows.
235		#' Within a risk difference column,
236		#' the statistics `eair_strat` and `n_eair_strat` are replaced by `eair_strat_diff_est_ci`
237		#' (difference in EAIR between current group and reference group,
238		#' together with it's confidence interval).
239		#' @export
240		#'
241		#' @examples
242		#' library(tern)
243		#' library(dplyr)
244		#'
245		#' set.seed(42)
246		#' n <- 120
247		#' adsl <- data.frame(
248		#' USUBJID = paste0("S", seq_len(n)),
249		#' ARM = rep(c("Treatment", "Placebo"), each = n / 2),
250		#' STUDY = rep(c("Study1", "Study2", "Study3"), times = n / 3),
251		#' TRTDURY = runif(n, 0.5, 3),
252		#' stringsAsFactors = FALSE
253		#' )
254		#' adae <- data.frame(
255		#' USUBJID = sample(adsl$USUBJID, 40),
256		#' AEDECOD = "Headache",
257		#' ASTDY = sample(30:500, 40, replace = TRUE),
258		#' AOCCPFL = "Y",
259		#' stringsAsFactors = FALSE
260		#' )
261		#' aefup <- merge(adae, adsl, by = "USUBJID")
262		#'
263		#' # Standard method (matches rdcomaeinci SAS macro)
264		#' lyt <- basic_table() \|>
265		#' split_cols_by("ARM") \|>
266		#' analyze(
267		#' "AEDECOD",
268		#' afun = a_eair_strat_j,
269		#' extra_args = list(
270		#' strata = "STUDY",
271		#' fup_var = "TRTDURY",
272		#' occ_var = "AOCCPFL",
273		#' occ_dy = "ASTDY",
274		#' .stats = c("eair_strat", "eair_strat_ci")
275		#' )
276		#' )
277		#' result <- build_table(lyt, aefup, alt_counts_df = adsl)
278		#' result
279		a_eair_strat_j <- function(
280		df,
281		labelstr = NULL,
282		.var,
283		.df_row,
284		.spl_context,
285		.alt_df_full = NULL,
286		id = "USUBJID",
287		strata,
288		fup_var,
289		occ_var = NULL,
290		occ_dy = NULL,
291		num_p_year = 100,
292		count_multiple_events = FALSE,
293		drop_levels = FALSE,
294		riskdiff = FALSE,
295		ref_path = NULL,
296		conf_level = 0.95,
297		.stats = "eair_strat",
298		.formats = NULL,
299		.labels = NULL,
300		.indent_mods = NULL,
301		na_str = rep("NA", 3),
302		row_labels_adj = FALSE,
303		riskdiff_setup = c("horizontal", "vertical")
304		) {
305	33x	riskdiff_setup <- match.arg(riskdiff_setup)
306
307	33x	if (is.null(.alt_df_full)) {
308	!	stop("a_eair_strat_j: .alt_df_full cannot be NULL. Specify `alt_counts_df` in `build_table`.")
309		}
310	33x	if (riskdiff && is.null(ref_path)) {
311	1x	stop("a_eair_strat_j: ref_path cannot be NULL when riskdiff = TRUE.")
312		}
313	32x	checkmate::assert_string(strata)
314	32x	checkmate::assert_names(colnames(.alt_df_full), must.include = c(id, fup_var, strata))
315
316		# if no stats requested, get all stats
317	31x	.stats <- junco_get_stats(
318	31x	"a_eair_strat_j",
319	31x	stats_in = .stats,
320	31x	custom_stats_in = NULL
321		)
322		if (
323	31x	any(
324	31x	.stats %in% c("eair_strat_diff_est_ci", "eair_strat_diff_est", "eair_strat_diff_ci")
325		) &&
326	31x	riskdiff_setup == "horizontal"
327		) {
328	!	.stats <-
329	!	.stats[!(.stats %in% c("eair_strat_diff_est_ci", "eair_strat_diff_est", "eair_strat_diff_ci"))]
330		}
331
332	31x	cur_col_expr <- .spl_context$cur_col_expr[[1]]
333	31x	colid <- .spl_context$cur_col_id[[1]]
334	31x	inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)
335
336		# reference group expressions and data (for rate difference)
337	31x	ref_col_expr <- NULL
338	31x	ref_df <- NULL
339	31x	ref_denom_df <- NULL
340	31x	.in_ref_col <- NULL
341
342	31x	ref_info <- get_ref_info_expanded(
343	31x	df,
344	31x	.var,
345	31x	.df_row,
346	31x	.spl_context,
347	31x	ref_path,
348	31x	riskdiff,
349	31x	riskdiff_setup
350		)
351
352	31x	perform_vs_ref_stats <- ref_info$perform_vs_ref_stats
353	31x	ref_col_expr <- ref_info$ref_col_expr
354	31x	.in_ref_col <- ref_info$.in_ref_col
355
356	31x	if (riskdiff) {
357	29x	ref_denom_df <- subset(.alt_df_full, eval(ref_col_expr))
358	29x	ref_df <- subset(.df_row, eval(ref_col_expr))
359		}
360
361	31x	inrowsplit <- FALSE
362	31x	if (.var == tail(.spl_context$split, 1L)) {
363		# note: this will catch the rowsplit only if parent_name in split_rows_by call is .var (default)
364	24x	drop_levels <- TRUE
365	24x	inrowsplit <- TRUE
366		}
367
368		### combine all preprocessing of incoming df/.df_row in one function
369		### do this outside stats derivation functions (s_freq_j/)
370		### use all of val/excl_levels/drop_levels//new_levels/label/label_map/labelstr/label_fstr
371	31x	upd_dfrow <- h_upd_dfrow(
372	31x	.df_row,
373	31x	.var,
374	31x	val = NULL,
375	31x	excl_levels = NULL,
376	31x	drop_levels = drop_levels,
377	31x	new_levels = NULL,
378	31x	new_levels_after = FALSE,
379	31x	label = NULL,
380	31x	label_map = NULL,
381	31x	labelstr = labelstr,
382	31x	label_fstr = NULL,
383	31x	.spl_context = .spl_context
384		)
385
386	31x	.df_row <- upd_dfrow$df_row
387	31x	df <- upd_dfrow$df
388
389	31x	levs <- levels(.df_row[[.var]])
390	!	if (is.null(levs)) levs <- unique(.df_row[[.var]])
391
392	31x	fn_Args <- list(
393	31x	strata = strata,
394	31x	df = df,
395	31x	.df_row = .df_row,
396	31x	.var = .var,
397	31x	id = id,
398	31x	fup_var = fup_var,
399	31x	occ_var = occ_var,
400	31x	occ_dy = occ_dy,
401	31x	num_p_year = num_p_year,
402	31x	count_multiple_events = count_multiple_events,
403	31x	cur_col_expr = cur_col_expr,
404	31x	ref_col_expr = ref_col_expr,
405	31x	vs_ref_group = perform_vs_ref_stats,
406	31x	.in_ref_col = !perform_vs_ref_stats,
407	31x	inriskdiffcol = riskdiff_setup == "horizontal" && inriskdiffcol,
408	31x	conf_level = conf_level,
409	31x	.alt_df_full = .alt_df_full
410		)
411
412	31x	y <- mapply(
413	31x	s_eair_strat_levii_j,
414	31x	levii = levs,
415	31x	MoreArgs = fn_Args,
416	31x	SIMPLIFY = FALSE
417		)
418
419		### rearrange list y to list to x_stats
420		# y is a nested list with
421		# outer elements levels of incoming variable
422		# inner elements stat elements statistics from
423
424		#### this is to ensure the remainder of the code can stay the same as in a_freq_j
425	31x	stnms <- junco_get_stats("a_eair_strat_j")
426	31x	x_stats <- extract_x_stats(y, stnms)
427
428		# x_stats is a nested list with
429		# outer elements stat elements statistics (all 5 from stnms)
430		# inner elements levels of incoming variable
431		# this will ensure we can perform subsetting on .stats
432		# like x_stats[.stats]
433
434		# transpose_named_list cannot be used as this will not ensure all 5 poss stats are in
435	31x	if (inriskdiffcol && riskdiff_setup == "horizontal") {
436	!	.stats_adj <-
437	!	replace(
438	!	.stats,
439	!	.stats %in%
440	!	c("eair_strat", "n_eair_strat", "eair_strat_n", "eair_strat_n_py"),
441	!	"eair_strat_diff_est_ci"
442		)
443		} else {
444	31x	.stats_adj <- .stats
445		}
446
447	31x	.stats <- .stats_adj
448
449		# Fill in formatting defaults
450
451
452	31x	x_stats <- x_stats[.stats]
453	31x	x_stats_orig <- x_stats
454		# from now onwards, retransform x_stats back into structure
455		# list with outer elements stats levels from incoming variable
456		# inner elements statistics
457	31x	x_stats <- transpose_named_list(x_stats)
458
459	31x	levels_per_stats <- lapply(x_stats, names)
460		# in case no default label get the label from the x_stats directly
461		# this is to cover statistics with dynamic label, such as
462		# n_event Either Number of events or Number of subjects with events
463	31x	.labels_pre <- junco_get_labels_from_attrib(.stats, .labels, x_stats)
464
465	31x	.formats <- junco_get_formats_from_stats(.stats, .formats, levels_per_stats)
466	31x	.labels <- junco_get_labels_from_stats(.stats, .labels_pre, levels_per_stats)
467	31x	.labels <- .unlist_keep_nulls(.labels)
468
469		# make adjustments to rowlabels when not inrowsplit
470	31x	if (!inrowsplit && length(.stats) > 1) {
471		# if more than one stat requested and variable is not in a prior splitrowscall
472		# prepend the level of the incoming variable (which is now in names of x_stats) to the label
473	5x	.labels <- paste(rep(names(x_stats), each = length(.stats)), .labels)
474	26x	} else if (!inrowsplit && length(.stats) == 1 && row_labels_adj) {
475		# if one stat requested and variable is not in a prior splitrowscall
476		# show the levels of the incoming variable, rather than the statistic
477	!	.labels <- names(x_stats)
478		}
479	31x	.labels <- gsub("^\\s+", "", .labels)
480
481	31x	.indent_mods <- junco_get_indents_from_stats(
482	31x	.stats,
483	31x	.indent_mods,
484	31x	levels_per_stats
485		)
486	31x	.indent_mods <- .unlist_keep_nulls(.indent_mods)
487
488		# .format_na_strs processing
489		# if na_str = c(NA, NA, NA)
490		# this will ensure the ci (NA, NA, NA) will be represented as NE (NE, NE)
491		# the value NE is defined as the default to replace NA in our jjcs format
492
493	31x	if (!is.null(na_str)) {
494	31x	.format_na_strs <- lapply(names(.formats), FUN = function(x) {
495	152x	na_str
496		})
497		} else {
498	!	.format_na_strs <- NULL
499		}
500
501		# Unlist stats + names
502	31x	x_stats <- .unlist_keep_nulls(x_stats)
503	31x	names(x_stats) <- names(.formats)
504
505		### final step: turn requested stats into rtables rows
506	31x	inrows <- in_rows(
507	31x	.list = x_stats,
508	31x	.formats = .formats,
509	31x	.labels = .labels,
510	31x	.indent_mods = .indent_mods,
511	31x	.format_na_strs = .format_na_strs
512		)
513		}
514
515
516		h_s_eair_strat_numbers <- function(strata,
517		w_by_strata,
518		stratum_stats,
519		num_p_year) {
520	65x	w_vec <- as.numeric(w_by_strata)
521	65x	W <- sum(w_vec)
522	65x	cur_stats <- stratum_stats
523	65x	n_vec <- sapply(cur_stats, `[[`, "n")
524	65x	py_vec <- sapply(cur_stats, `[[`, "py")
525
526		# per-study rates
527	65x	r_vec <- num_p_year * (n_vec) / py_vec
528
529	65x	return(list(
530	65x	n_vec = n_vec,
531	65x	py_vec = py_vec,
532	65x	r_vec = r_vec,
533	65x	w_vec = w_vec
534		))
535		}
536
537		h_s_eair_strat_estimates <- function(n_vec,
538		py_vec,
539		r_vec,
540		w_vec,
541		conf_level,
542		num_p_year) {
543	40x	W <- sum(w_vec)
544
545		# weighted pooled rate
546	40x	eair_strat <- if (W > 0) sum(w_vec * r_vec) / W else NA_real_
547
548		# Wald variance for pooled rate: (num_p_year/W)^2 * sum(w_i^2 * (n_i) / T_i^2)
549	40x	root_sum <- sum(w_vec^2 * (n_vec) / py_vec^2)
550	40x	z <- stats::qnorm(1 - (1 - conf_level) / 2)
551	40x	se_rate <- (num_p_year / W) * sqrt(root_sum)
552	40x	eair_ci <- c(max(0, eair_strat - z * se_rate), eair_strat + z * se_rate)
553	40x	n_total <- sum(n_vec)
554	40x	py_total <- sum(py_vec)
555
556		# assemble return list
557	40x	x <- list()
558
559	40x	x$n_event_total <- stats::setNames(n_total, "n_event_total")
560	40x	attr(x$n_event_total, "label") <- "n (events)"
561
562	40x	x$person_years_total <- stats::setNames(py_total, "person_years_total")
563	40x	attr(x$person_years_total, "label") <- "Total person-years"
564
565	40x	x$eair_strat <- stats::setNames(eair_strat, "eair_strat")
566	40x	attr(x$eair_strat, "label") <- paste0(
567	40x	"Stratified EAIR per ", num_p_year, " PY"
568		)
569
570	40x	x$n_eair_strat <- stats::setNames(
571	40x	c(n_total, eair_strat),
572	40x	c("n_event_total", "eair_strat")
573		)
574	40x	attr(x$n_eair_strat, "label") <- paste0("n (stratified EAIR per ", num_p_year, " PY)")
575
576	40x	x$eair_strat_ci <- stats::setNames(eair_ci, c("lcl", "ucl"))
577	40x	attr(x$eair_strat_ci, "label") <- paste0(
578	40x	formatC(conf_level * 100, format = "f", digits = 0), "% CI (Wald)"
579		)
580
581	40x	x$eair_strat_est_ci <- stats::setNames(
582	40x	c(eair_strat, eair_ci),
583	40x	c("eair_strat", "lcl", "ucl")
584		)
585	40x	attr(x$eair_strat_est_ci, "label") <- paste0(
586	40x	"Stratified EAIR (", formatC(conf_level * 100, format = "f", digits = 0), "% CI)"
587		)
588
589	40x	x$eair_strat_n <- stats::setNames(
590	40x	c(eair_strat, n_total),
591	40x	c("eair_strat", "n_event_total")
592		)
593	40x	attr(x$eair_strat_n, "label") <- paste0("stratified EAIR per ", num_p_year, " PY (n)")
594
595	40x	x$eair_strat_n_py <- stats::setNames(
596	40x	c(eair_strat, n_total),
597	40x	c("eair_strat", "n_event_total")
598		)
599	40x	attr(x$eair_strat_n_py, "label") <- paste0("stratified EAIR per ", num_p_year, " PY (n/person-years)")
600
601	40x	x
602		}
603
604		h_s_eair_strat_diff_estimates <- function(n_vec,
605		py_vec,
606		r_vec,
607		w_vec,
608		ref_n_vec,
609		ref_py_vec,
610		ref_r_vec,
611		num_p_year,
612		conf_level) {
613	25x	W <- sum(w_vec)
614	25x	z <- stats::qnorm(1 - (1 - conf_level) / 2)
615
616	25x	d_vec <- r_vec - ref_r_vec
617	25x	d_adj <- if (W > 0) sum(w_vec * d_vec) / W else NA_real_
618
619	25x	root_diff <- sum(w_vec^2 * ((n_vec) / py_vec^2 + (ref_n_vec) / ref_py_vec^2))
620	25x	se_diff <- (num_p_year / W) * sqrt(root_diff)
621
622	25x	diff_ci <- c(d_adj - z * se_diff, d_adj + z * se_diff)
623
624	25x	x <- list()
625	25x	x$eair_strat_diff_est_ci <- stats::setNames(
626	25x	c(d_adj, diff_ci),
627	25x	c("estimate", "lcl", "ucl")
628		)
629	25x	attr(x$eair_strat_diff_est_ci, "label") <- paste0(
630	25x	"Difference in stratified EAIR (",
631	25x	formatC(conf_level * 100, format = "f", digits = 0), "% CI, Wald)"
632		)
633
634	25x	x$eair_strat_diff_est <- stats::setNames(
635	25x	c(d_adj),
636	25x	c("estimate")
637		)
638	25x	attr(x$eair_strat_diff_est, "label") <- "Difference in stratified EAIR"
639
640	25x	x$eair_strat_diff_ci <- stats::setNames(
641	25x	c(diff_ci),
642	25x	c("lcl", "ucl")
643		)
644	25x	attr(x$eair_strat_diff_ci, "label") <- paste0(
645	25x	formatC(conf_level * 100, format = "f", digits = 0), "% CI (Wald)"
646		)
647
648	25x	x
649		}

1		#' Impute missing binary responses and analyze each imputed data set
2		#'
3		#' Performs independent Bernoulli imputations for missing binary responses in
4		#' the control and treatment groups, then calculates a CMH risk difference and
5		#' p-value for each imputed data set. Only observations in `ctrlab` and
6		#' `trtlab` are included in the analysis.
7		#'
8		#' @param dat (`data.frame`)
9		#' Analysis data containing treatment, response, and stratification variables.
10		#' @param p_ctrl (`numeric(1)`)
11		#' Probability of response used to impute missing control-group responses.
12		#' @param p_trt (`numeric(1)`)
13		#' Probability of response used to impute missing treatment-group responses.
14		#' @param trtvar (`string`)
15		#' Name of the treatment variable in `dat`.
16		#' @param ctrlab (`string`)
17		#' Value of `trtvar` identifying the control group.
18		#' @param trtlab (`string`)
19		#' Value of `trtvar` identifying the treatment group.
20		#' @param respvar (`string`)
21		#' Name of a logical binary response variable in `dat`. Missing values are
22		#' imputed; observed values are retained.
23		#' @param stratvar (`character`)
24		#' Names of one or more stratification variables in `dat`. Stratification
25		#' variables must not be missing in the analysis groups.
26		#' @param n_imputations (`count`)
27		#' Number of independently imputed data sets to analyze.
28		#'
29		#' @return A tibble with one row per imputation and the following columns:
30		#'
31		#' * `rd_est`: CMH risk-difference estimate.
32		#' * `rd_se`: standard error of the risk-difference estimate.
33		#' * `rd_var`: variance of the risk-difference estimate.
34		#' * `p_cmh`: CMH p-value using the Wilson-Hilferty transformation.
35		#' * `z_stat`: Wilson-Hilferty z statistic used to calculate `p_cmh`.
36		#'
37		#' @keywords internal
38		h_impute_analyze_resp <- function(
39		dat,
40		p_ctrl,
41		p_trt,
42		trtvar,
43		ctrlab,
44		trtlab,
45		respvar,
46		stratvar,
47		n_imputations
48		) {
49	3x	checkmate::assert_data_frame(dat)
50	3x	checkmate::assert_number(p_ctrl, lower = 0, upper = 1, finite = TRUE)
51	3x	checkmate::assert_number(p_trt, lower = 0, upper = 1, finite = TRUE)
52	3x	checkmate::assert_string(trtvar)
53	3x	checkmate::assert_string(ctrlab)
54	3x	checkmate::assert_string(trtlab)
55	3x	checkmate::assert_string(respvar)
56	3x	checkmate::assert_character(stratvar, min.len = 1, any.missing = FALSE, unique = TRUE)
57	3x	checkmate::assert_count(n_imputations, positive = TRUE)
58	3x	checkmate::assert_subset(c(trtvar, respvar, stratvar), choices = names(dat))
59	3x	checkmate::assert_logical(dat[[respvar]], any.missing = TRUE)
60	3x	checkmate::assert_true(ctrlab != trtlab)
61
62	3x	treatment <- as.character(dat[[trtvar]])
63	3x	ctrl_data <- dat[which(treatment == ctrlab), , drop = FALSE]
64	3x	trt_data <- dat[which(treatment == trtlab), , drop = FALSE]
65
66	3x	checkmate::assert_true(nrow(ctrl_data) > 0)
67	3x	checkmate::assert_true(nrow(trt_data) > 0)
68
69	3x	analysis_data <- rbind(ctrl_data, trt_data)
70	3x	strata <- interaction(analysis_data[stratvar], drop = TRUE)
71	3x	response <- c(ctrl_data[[respvar]], trt_data[[respvar]])
72	3x	group <- factor(
73	3x	rep(c("ref", "Not-ref"), c(nrow(ctrl_data), nrow(trt_data))),
74	3x	levels = c("ref", "Not-ref")
75		)
76	3x	missing_response <- is.na(response)
77	3x	missing_ctrl_response <- group == "ref" & missing_response
78	3x	missing_trt_response <- group == "Not-ref" & missing_response
79	3x	n_missing_ctrl <- sum(missing_ctrl_response)
80	3x	n_missing_trt <- sum(missing_trt_response)
81
82	3x	results <- vector("list", n_imputations)
83	3x	for (i in seq_len(n_imputations)) {
84	7x	imputed_response <- response
85	7x	if (n_missing_ctrl > 0) {
86	7x	imputed_response[missing_ctrl_response] <- as.logical(stats::rbinom(
87	7x	n = n_missing_ctrl,
88	7x	size = 1,
89	7x	prob = p_ctrl
90		))
91		}
92	7x	if (n_missing_trt > 0) {
93	7x	imputed_response[missing_trt_response] <- as.logical(stats::rbinom(
94	7x	n = n_missing_trt,
95	7x	size = 1,
96	7x	prob = p_trt
97		))
98		}
99	7x	rd_result <- tern::prop_diff_cmh(imputed_response, group, strata, diff_se = "standard")
100	7x	cmh_result <- tern::prop_cmh(
101	7x	table(group, imputed_response, strata),
102	7x	transform = "wilson_hilferty"
103		)
104	7x	results[[i]] <- c(
105	7x	rd_est = rd_result$diff,
106	7x	rd_se = rd_result$se_diff,
107	7x	p_cmh = as.numeric(cmh_result),
108	7x	z_stat = attr(cmh_result, "z_stat")
109		)
110		}
111
112	3x	results <- as.data.frame(do.call(rbind, results))
113	3x	tibble::tibble(
114	3x	rd_est = results$rd_est,
115	3x	rd_se = results$rd_se,
116	3x	rd_var = results$rd_se^2,
117	3x	p_cmh = results$p_cmh,
118	3x	z_stat = results$z_stat
119		)
120		}
121
122		#' Calculate results across binary-imputation scenarios
123		#'
124		#' Runs `h_impute_analyze_resp()` for each paired control and treatment response
125		#' probability, pools estimates across imputations using Rubin's rules, and
126		#' pools Wilson-Hilferty z statistics to obtain a p-value. A scenario where both
127		#' probabilities are zero or one is deterministic and is therefore analyzed
128		#' once rather than repeatedly imputed.
129		#'
130		#' @param dat (`data.frame`)
131		#' Analysis data containing treatment, response, and stratification variables.
132		#' @param p_ctrl (`numeric`)
133		#' Control-group response probabilities, one for each scenario.
134		#' @param p_trt (`numeric`)
135		#' Treatment-group response probabilities, paired with `p_ctrl` by position.
136		#' @param trtvar (`string`)
137		#' Name of the treatment variable in `dat`.
138		#' @param ctrlab (`string`)
139		#' Value of `trtvar` identifying the control group.
140		#' @param trtlab (`string`)
141		#' Value of `trtvar` identifying the treatment group.
142		#' @param respvar (`string`)
143		#' Name of a logical binary response variable in `dat`.
144		#' @param stratvar (`character`)
145		#' Names of one or more stratification variables in `dat`.
146		#' @param n_imputations (`count`)
147		#' Number of imputations for non-deterministic scenarios.
148		#' @param pvalcat (named `list`)
149		#' P-value categories passed to [categorize_pval()].
150		#'
151		#' @return A tibble with one row per scenario. `rd` and `rd_se` are the pooled
152		#' risk-difference estimate and standard error; `p_value` and `p_cat` are the
153		#' pooled p-value and its category. `marker_flag` and `effect_label` contain
154		#' `"*"` when a deterministic scenario or a single-imputation p-value fallback
155		#' was used.
156		#'
157		#' @examples
158		#' dat <- data.frame(
159		#' arm = rep(c("Control", "Treatment"), each = 4),
160		#' response = c(TRUE, FALSE, NA, TRUE, TRUE, FALSE, NA, FALSE),
161		#' strata = rep(c("A", "B"), 4)
162		#' )
163		#' pvalcat <- list("<0.05" = c(0, 0.05), ">=0.05" = c(0.05, 1))
164		#'
165		#' set.seed(123)
166		#' resp_multiple_imputation(
167		#' dat,
168		#' p_ctrl = c(0, 0.25),
169		#' p_trt = c(1, 0.75),
170		#' trtvar = "arm",
171		#' ctrlab = "Control",
172		#' trtlab = "Treatment",
173		#' respvar = "response",
174		#' stratvar = "strata",
175		#' n_imputations = 5,
176		#' pvalcat = pvalcat
177		#' )
178		#' @export
179		resp_multiple_imputation <- function(
180		dat,
181		p_ctrl,
182		p_trt,
183		trtvar,
184		ctrlab,
185		trtlab,
186		respvar,
187		stratvar,
188		n_imputations,
189		pvalcat
190		) {
191	1x	checkmate::assert_numeric(p_ctrl, min.len = 1, lower = 0, upper = 1, finite = TRUE)
192	1x	checkmate::assert_numeric(p_trt, min.len = 1, lower = 0, upper = 1, finite = TRUE)
193	1x	checkmate::assert_true(length(p_ctrl) == length(p_trt))
194	1x	checkmate::assert_count(n_imputations, positive = TRUE)
195	1x	checkmate::assert_list(h_normalize_pvalcat(pvalcat)) # Just to check that it works.
196
197	1x	results <- lapply(seq_along(p_ctrl), function(i) {
198	2x	control_probability <- p_ctrl[[i]]
199	2x	treatment_probability <- p_trt[[i]]
200	2x	m <- if (all(c(control_probability, treatment_probability) %in% c(0, 1))) 1L else n_imputations
201
202	2x	per_imputation <- h_impute_analyze_resp(
203	2x	dat = dat,
204	2x	p_ctrl = control_probability,
205	2x	p_trt = treatment_probability,
206	2x	trtvar = trtvar,
207	2x	ctrlab = ctrlab,
208	2x	trtlab = trtlab,
209	2x	respvar = respvar,
210	2x	stratvar = stratvar,
211	2x	n_imputations = m
212		)
213
214	2x	if (m == 1) {
215	1x	estimate <- per_imputation$rd_est[[1]]
216	1x	standard_error <- per_imputation$rd_se[[1]]
217	1x	p_value <- per_imputation$p_cmh[[1]]
218	1x	used_fallback <- TRUE
219		} else {
220	1x	pooled_rd <- pool_rubin_scalar(per_imputation$rd_est, per_imputation$rd_var)
221	1x	estimate <- pooled_rd$est
222	1x	standard_error <- pooled_rd$se
223	1x	pooled_p_value <- pool_z_stat(per_imputation$z_stat)$p
224	1x	used_fallback <- is.na(pooled_p_value) \|\| !is.finite(pooled_p_value)
225	1x	p_value <- if (used_fallback) per_imputation$p_cmh[[1]] else pooled_p_value
226		}
227
228	2x	marker_flag <- if (m == 1 \|\| used_fallback) "*" else ""
229	2x	tibble::tibble(
230	2x	p_ctrl = control_probability,
231	2x	p_trt = treatment_probability,
232	2x	m = m,
233	2x	rd = estimate,
234	2x	rd_se = standard_error,
235	2x	p_value = p_value,
236	2x	p_cat = categorize_pval(p_value, pvalcat),
237	2x	marker_flag = marker_flag,
238	2x	effect_label = paste0(
239	2x	formatC(100 * estimate, format = "f", digits = 1),
240		"%",
241	2x	marker_flag
242		)
243		)
244		})
245
246	1x	tibble::as_tibble(do.call(rbind, results))
247		}

1		#' Tabulation of RBMI Results
2		#'
3		#' @description `r lifecycle::badge('stable')`
4		#'
5		#' These functions can be used to produce tables from RBMI.
6		#'
7		#' @name tabulate_rbmi
8		#'
9		#' @note These functions have been forked from `tern.rbmi`. Additional features are:
10		#'
11		#' * Additional `ref_path` argument.
12		#' * Extraction of variance statistics in the `tidy()` method.
13		#' * Adapted to `rbmi` forked functions update with more than two treatment groups.
14		NULL
15
16		#' @describeIn tabulate_rbmi Helper function to produce data frame with results
17		#' of pool for a single visit.
18		#'
19		#' @param x (`list`)\cr is a list of pooled object from `rbmi` analysis results.
20		#' This list includes analysis results, confidence level, hypothesis testing type.
21		#' @param visit_name (`string`)\cr single visit level.
22		#' @param group_names (`character`)\cr group levels.
23		#' @return
24		#' * `h_tidy_pool()` returns a `data.frame` with results of pooled analysis for a single visit.
25		#'
26		#' @export
27		h_tidy_pool <- function(x, visit_name, group_names) {
28	13x	checkmate::assert_list(x)
29	13x	checkmate::assert_string(visit_name)
30	13x	checkmate::assert_character(group_names)
31
32	13x	ref_name <- paste0("lsm_", group_names[1], "_", visit_name)
33	13x	ref <- x[[ref_name]]
34
35	13x	list2df <- \(l) with(l, data.frame(est, ci_l = ci[1], ci_u = ci[2], se, pvalue, df))
36
37	13x	var_name <- paste0("var_", visit_name)
38	13x	var <- if (var_name %in% names(x)) {
39		# This is the case for ANCOVA.
40	11x	list2df(x[[var_name]])
41		} else {
42		# This is the case for MMRM.
43	2x	var_names <- paste0("var_", group_names[-1], "_", visit_name)
44	2x	checkmate::assert_subset(var_names, names(x))
45	2x	var_dfs <- lapply(x[var_names], list2df)
46	2x	var <- do.call(rbind, var_dfs)
47		}
48
49	13x	contr_names <- paste0("trt_", group_names[-1], "_", visit_name)
50	13x	contr_dfs <- lapply(x[contr_names], list2df)
51	13x	contr <- do.call(rbind, contr_dfs)
52
53	13x	alt_names <- paste0("lsm_", group_names[-1], "_", visit_name)
54	13x	alt_dfs <- lapply(x[alt_names], list2df)
55	13x	alt <- do.call(rbind, alt_dfs)
56
57	13x	df_ref <- data.frame(
58	13x	visit = visit_name,
59	13x	group = group_names[1],
60	13x	est = ref$est,
61	13x	se_est = ref$se,
62	13x	lower_cl_est = ref$ci[1],
63	13x	upper_cl_est = ref$ci[2],
64	13x	est_contr = NA_real_,
65	13x	se_contr = NA_real_,
66	13x	lower_cl_contr = NA_real_,
67	13x	upper_cl_contr = NA_real_,
68	13x	p_value = NA_real_,
69	13x	relative_reduc = NA_real_,
70	13x	mse = NA_real_,
71	13x	df = NA_real_,
72	13x	stringsAsFactors = FALSE
73		)
74	13x	df_alt <- data.frame(
75	13x	visit = visit_name,
76	13x	group = group_names[-1],
77	13x	est = alt$est,
78	13x	se_est = alt$se,
79	13x	lower_cl_est = alt$ci_l,
80	13x	upper_cl_est = alt$ci_u,
81	13x	est_contr = contr$est,
82	13x	se_contr = contr$se,
83	13x	lower_cl_contr = contr$ci_l,
84	13x	upper_cl_contr = contr$ci_u,
85	13x	p_value = contr$pvalue,
86	13x	relative_reduc = contr$est / df_ref$est,
87	13x	mse = var$est,
88	13x	df = var$df,
89	13x	stringsAsFactors = FALSE
90		)
91	13x	rbind(df_ref, df_alt)
92		}
93
94		#' Helper method (for [`broom::tidy()`]) to prepare a data frame from an
95		#' `pool` `rbmi` object containing the LS means and contrasts and multiple visits
96		#'
97		#' @method tidy pool
98		#' @param x (`pool`) is a list of pooled object from `rbmi` analysis results. This list includes
99		#' analysis results, confidence level, hypothesis testing type.
100		#' @param visits (`character`)\cr all visit levels. Otherwise too hard to guess this.
101		#' @param ... Additional arguments. Not used. Needed to match generic signature only.
102		#' @importFrom generics tidy
103		#' @export
104		#' @keywords internal
105		#' @return A `data.frame`.
106		tidy.pool <- function(x, visits, ...) {
107	6x	ls_raw <- x$pars
108
109	6x	has_lsm <- grepl("^lsm_", names(ls_raw))
110	6x	has_first_visit <- grepl(paste0("_", visits[1]), names(ls_raw), fixed = TRUE)
111	6x	is_lsm_first_visit <- has_lsm & has_first_visit
112
113	6x	group_names <- names(ls_raw)[is_lsm_first_visit]
114	6x	group_names <- gsub(pattern = "^lsm_", replacement = "", x = group_names)
115	6x	group_names <- gsub(pattern = paste0("_", visits[1]), replacement = "", x = group_names, fixed = TRUE)
116
117	6x	spl <- rep(visits, each = length(ls_raw) / length(visits))
118
119	6x	ls_split <- split(ls_raw, spl)
120
121	6x	ls_df <- mapply(
122	6x	FUN = h_tidy_pool,
123	6x	x = ls_split,
124	6x	visit_name = visits,
125	6x	MoreArgs = list(group_names = group_names),
126	6x	SIMPLIFY = FALSE
127		)
128
129	6x	result <- do.call(rbind, unname(ls_df))
130
131	6x	result$visit <- factor(result$visit, levels = visits)
132	6x	result$group <- factor(result$group, levels = group_names)
133	6x	result$conf_level <- x$conf.level
134
135	6x	result
136		}
137
138		#' @describeIn tabulate_rbmi Statistics function which is extracting estimates
139		#' from a tidied RBMI results data frame.
140		#'
141		#' @param df (`data.frame`)\cr input with LS means results.
142		#' @param .in_ref_col (`flag`)\cr whether reference column is specified.
143		#' @param show_relative (`string`)\cr 'reduction' if (`control - treatment`, default)
144		#' or 'increase' (`treatment - control`) of relative change from baseline?
145		#' @return
146		#' * `s_rbmi_lsmeans()` returns a list of statistics extracted from a tidied LS means data frame.
147		#' @export
148		s_rbmi_lsmeans <- function(df, .in_ref_col, show_relative = c("reduction", "increase")) {
149	7x	checkmate::assert_flag(.in_ref_col)
150
151	7x	show_relative <- match.arg(show_relative)
152	7x	if_not_ref <- function(x) if (.in_ref_col) character() else x
153	7x	list(
154	7x	adj_mean_se = c(df$est, df$se_est),
155	7x	adj_mean_ci = with_label(c(df$lower_cl_est, df$upper_cl_est), f_conf_level(df$conf_level)),
156	7x	diff_mean_se = if_not_ref(c(df$est_contr, df$se_contr)),
157	7x	diff_mean_ci = with_label(
158	7x	if_not_ref(c(df$lower_cl_contr, df$upper_cl_contr)),
159	7x	f_conf_level(df$conf_level)
160		),
161	7x	change = switch(show_relative,
162	7x	reduction = with_label(if_not_ref(df$relative_reduc), "Relative Reduction (%)"),
163	7x	increase = with_label(if_not_ref(-df$relative_reduc), "Relative Increase (%)")
164		),
165	7x	p_value = if_not_ref(df$p_value),
166	7x	additional_title_row = NULL
167		)
168		}
169
170		#' @describeIn tabulate_rbmi Formatted Analysis function which is used as `afun`.
171		#'
172		#' @inheritParams proposal_argument_convention
173		#' @export
174		a_rbmi_lsmeans <- function(
175		df,
176		ref_path,
177		.spl_context,
178		...,
179		.stats = NULL,
180		.formats = NULL,
181		.labels = NULL,
182		.indent_mods = NULL
183		) {
184		# Check for additional parameters to the statistics function
185	4x	dots_extra_args <- list(...)
186
187		# Only support default stats, not custom stats
188	4x	.stats <- .split_std_from_custom_stats(.stats)$default_stats
189
190		# Obtain reference column information
191	4x	ref <- get_ref_info(ref_path, .spl_context)
192
193		# Apply statistics function
194	4x	x_stats <- .apply_stat_functions(
195	4x	default_stat_fnc = s_rbmi_lsmeans,
196	4x	custom_stat_fnc_list = NULL,
197	4x	args_list = c(df = list(df), .in_ref_col = ref$in_ref_col, dots_extra_args)
198		)
199
200		# Format according to specifications
201	4x	format_stats(
202	4x	x_stats,
203	4x	method_groups = "tabulate_rbmi",
204	4x	stats_in = .stats,
205	4x	formats_in = .formats,
206	4x	labels_in = .labels,
207	4x	indents_in = .indent_mods
208		)
209		}

1		#' Extract Estimates from Multivariate Cox Regression Model Fit Object
2		#'
3		#' @param x (`coxreg.multivar`)\cr from [tern::fit_coxreg_multivar()].
4		#' @export
5		#' @return A data frame containing Cox regression results with columns for term,
6		#' coef_se (coefficient and standard error), p.value, hr (hazard ratio),
7		#' hr_ci (confidence interval for hazard ratio), and labels (formatted term labels).
8		#' @keywords internal
9		#'
10		#' @examples
11		#' anl <- tern::tern_ex_adtte \|>
12		#' dplyr::mutate(EVENT = 1 - CNSR)
13		#'
14		#' variables <- list(
15		#' time = "AVAL",
16		#' event = "EVENT",
17		#' arm = "ARM",
18		#' covariates = c("SEX", "AGE")
19		#' )
20		#'
21		#' control <- tern::control_coxreg(
22		#' conf_level = 0.9,
23		#' ties = "efron"
24		#' )
25		#'
26		#' fit <- tern::fit_coxreg_multivar(
27		#' data = anl,
28		#' variables = variables,
29		#' control = control
30		#' )
31		#'
32		#' h_extract_coxreg_multivar(fit)
33		h_extract_coxreg_multivar <- function(x) {
34	22x	checkmate::assert_class(x, "coxreg.multivar")
35	22x	vars <- c(x$vars$arm, x$vars$covariates)
36
37		# Extract the table.
38	22x	tab <- broom::tidy(x$mod, exponentiate = FALSE, conf.int = TRUE, conf.level = x$control$conf_level)
39	22x	tab$hr <- exp(tab$estimate)
40	22x	tab$hr_ci <- Map(lcl = exp(tab$conf.low), ucl = exp(tab$conf.high), f = function(lcl, ucl) c(lcl, ucl))
41	22x	tab$coef_se <- Map(coef = tab$estimate, se = tab$std.error, f = function(coef, se) c(coef, se))
42	22x	colnms <- c("term", "coef_se", "p.value", "hr", "hr_ci")
43	22x	tab <- tab[, colnms, drop = FALSE]
44
45		# Format nicely the term labels.
46	22x	var_to_term <- sapply(vars, function(v) which(startsWith(tab$term, v)), USE.NAMES = TRUE, simplify = FALSE)
47	22x	tab$labels <- unlist(lapply(vars, function(v) {
48	67x	inds <- var_to_term[[v]]
49	67x	strip_term <- gsub(paste0("^", v), "", tab$term[inds])
50	67x	this_df <- x$dat[v]
51	67x	if (is.character(this_df[[1]])) {
52	1x	this_df[[1]] <- as.factor(this_df[[1]])
53		}
54	67x	if (is.factor(this_df[[1]])) {
55	45x	ref_level <- levels(this_df[[1]])[1]
56	45x	var_name <- if (v == x$vars$arm) "Treatment" else labels_or_names(this_df)
57	45x	paste0(var_name, " (", strip_term, " vs. ", ref_level, ")")
58		} else {
59	22x	labels_or_names(this_df)
60		}
61		}))
62	22x	tab
63		}
64
65		#' First Level Column Split Function for TEFOS03 (mmy) Table Layout
66		#' @seealso [rtables::make_split_fun()] for details.
67		#' @keywords internal
68		tefos03_first_post_fun <- function(ret, spl, fulldf, .spl_context) {
69	5x	all_expr <- expression(TRUE)
70	5x	short_split_result(model_fit = "Model Fit", hazard_ratio = "Hazard Ratio", fulldf = fulldf)
71		}
72		tefos03_first_split_fun <- make_split_fun(post = list(tefos03_first_post_fun))
73
74		#' Second Level Column Split Function Factory for TEFOS03 (mmy) Table Layout
75		#'
76		#' @inheritParams proposal_argument_convention
77		#'
78		#' @return Split function to use in the TEFOS03 (mmy) and related table layouts.
79		#'
80		#' @seealso [tefos03_first_post_fun()] for the first level split.
81		#' @keywords internal
82		tefos03_second_split_fun_fct <- function(conf_level) {
83	4x	post_fun <- function(ret, spl, fulldf, .spl_context) {
84	8x	all_expr <- expression(TRUE)
85	8x	colset <- .spl_context[nrow(.spl_context), "value"][[1]]
86	8x	if (colset == "model_fit") {
87	4x	short_split_result(coef_se = "Coeff. (SE)", pval = "p-value", fulldf = fulldf)
88		} else {
89	4x	short_split_result(hr_est = "Estimate", hr_ci = f_conf_level(conf_level), fulldf = fulldf)
90		}
91		}
92	4x	make_split_fun(post = list(post_fun))
93		}
94
95		#' @importFrom tern fit_coxreg_multivar
96		#' @keywords internal
97		memoised_fit_coxreg_multivar <- memoise::memoise(fit_coxreg_multivar)
98
99		#' Analysis Function for TEFOS03 and Related Table Layouts
100		#'
101		#' @inheritParams proposal_argument_convention
102		#' @param control (`list`)\cr from [tern::control_coxreg()].
103		#' @param formats (`list`)\cr including `coef_se`, `hr_est`, `hr_ci` and `pval` formats.
104		#' @param variables (`list`)\cr see [tern::fit_coxreg_multivar()] for required variable
105		#' specifications.
106		#'
107		#' @keywords internal
108		tefos03_afun <- function(df, .var, .spl_context, variables, control, formats) {
109	21x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
110	21x	model_fit <- memoised_fit_coxreg_multivar(data = df, variables = variables, control = control)
111	21x	tab <- h_extract_coxreg_multivar(model_fit)
112	21x	if (this_col_split[1] == "model_fit") {
113	11x	if (this_col_split[2] == "coef_se") {
114	5x	in_rows(.list = tab$coef_se, .formats = formats$coef_se, .labels = tab$labels)
115		} else {
116	6x	in_rows(.list = tab$p.value, .formats = formats$pval, .labels = tab$labels)
117		}
118		} else {
119	10x	if (this_col_split[2] == "hr_est") {
120	5x	in_rows(.list = tab$hr, .formats = formats$hr_est, .labels = tab$labels)
121		} else {
122	5x	in_rows(.list = tab$hr_ci, .formats = formats$hr_ci, .labels = tab$labels)
123		}
124		}
125		}
126
127		#' Layout Generating Function for TEFOS03 and Related Cox Regression Layouts
128		#'
129		#' @inheritParams proposal_argument_convention
130		#' @inheritParams tefos03_afun
131		#' @param var (`string`)\cr any variable from the data, because this is not used.
132		#'
133		#' @return `lyt` modified to add the desired cox regression table section.
134		#' @export
135		#' @examples
136		#' anl <- tern::tern_ex_adtte \|>
137		#' dplyr::mutate(EVENT = 1 - CNSR)
138		#'
139		#' variables <- list(
140		#' time = "AVAL",
141		#' event = "EVENT",
142		#' arm = "ARM",
143		#' covariates = c("SEX", "AGE")
144		#' )
145		#'
146		#' basic_table() \|>
147		#' summarize_coxreg_multivar(
148		#' var = "STUDYID",
149		#' variables = variables
150		#' ) \|>
151		#' build_table(df = anl)
152		summarize_coxreg_multivar <- function(
153		lyt,
154		var,
155		variables,
156		control = control_coxreg(),
157		formats = list(
158		coef_se = jjcsformat_xx("xx.xx (xx.xx)"),
159		hr_est = jjcsformat_xx("xx.xx"),
160		hr_ci = jjcsformat_xx("(xx.xx, xx.xx)"),
161		pval = jjcsformat_pval_fct(0)
162		)
163		) {
164	3x	second_split_fun <- tefos03_second_split_fun_fct(conf_level = control$conf_level)
165	3x	lyt \|>
166	3x	split_cols_by(var = var, split_fun = tefos03_first_split_fun) \|>
167	3x	split_cols_by(var = var, split_fun = second_split_fun) \|>
168	3x	analyze(
169	3x	vars = var,
170	3x	var_labels = "Model Parameter",
171	3x	show_labels = "visible",
172	3x	afun = tefos03_afun,
173	3x	extra_args = list(variables = variables, control = control, formats = formats)
174		)
175		}

1		#' Split Function for Compliance Columns
2		#'
3		#' Here we just split into 3 columns for expected, received and missing visits.
4		#'
5		#' @inheritParams proposal_argument_convention
6		#' @param ret (`list`)\cr result from previous split function steps.
7		#' @param spl (`split`)\cr split object.
8		#' @param fulldf (`data.frame`)\cr full data frame.
9		#' @param vals (`character`)\cr values to use for the split.
10		#' @param trim (`logical`)\cr whether to trim the values.
11		#'
12		#' @seealso [rtables::make_split_fun()] describing the requirements for this kind of
13		#' post-processing function.
14		cmp_post_fun <- function(ret, spl, fulldf, .spl_context) {
15	1x	short_split_result(
16	1x	expected = "Expected, N",
17	1x	received = "Received, n (%)",
18	1x	missing = "Missing, n (%)",
19	1x	fulldf = fulldf
20		)
21		}
22		#' @rdname cmp_post_fun
23		#' @return a split function for use with [rtables::split_rows_by]
24		#' when creating proportion-based tables with compliance columns.
25		#' @export
26		cmp_split_fun <- make_split_fun(post = list(cmp_post_fun))
27
28		#' @title Summary Analysis Function for Compliance Columns
29		#' @description A simple statistics function which prepares the numbers with percentages
30		#' in the required format, for use in a split content row. The denominator here is
31		#' from the expected visits column.
32		#' @inheritParams proposal_argument_convention
33		#' @param variables (`list`)\cr with variable names of logical columns for
34		#' `expected`, `received` and `missing` visits.
35		#' @param formats (`list`)\cr with the `count_percent` format to use for the received
36		#' and missing visits columns.
37		#' @return The [rtables::in_rows()] result with the counts and proportion statistics.
38		#' @seealso [cmp_post_fun()] for the corresponding split function.
39		#' @export
40		cmp_cfun <- function(df, labelstr, .spl_context, variables, formats) {
41	3x	this_col_split <- .spl_context[nrow(.spl_context), "cur_col_split_val"][[1]]
42	3x	this_afun_col <- this_col_split[2]
43
44	3x	exp <- df[[variables$expected]]
45	3x	checkmate::assert_logical(exp)
46	3x	n_exp <- sum(exp)
47	3x	rec <- df[[variables$received]]
48	3x	mis <- df[[variables$missing]]
49
50	3x	if (this_afun_col == "expected") {
51	1x	in_rows(n_exp, .labels = labelstr, .formats = "xx.")
52	2x	} else if (this_afun_col == "received") {
53	1x	checkmate::assert_logical(rec)
54	1x	checkmate::assert_true(all(exp[rec]))
55
56		# Check if count_percent format is available
57	1x	if (!is.null(formats) && !("count_percent" %in% names(formats))) {
58	!	stop("'count_percent' format must be provided in the formats argument")
59		}
60
61	1x	in_rows(sum(rec) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
62	1x	} else if (this_afun_col == "missing") {
63	1x	checkmate::assert_logical(mis)
64	1x	checkmate::assert_true(all(exp[mis]))
65	1x	checkmate::assert_true(!any(rec[mis]))
66
67		# Check if count_percent format is available
68	1x	if (!is.null(formats) && !("count_percent" %in% names(formats))) {
69	!	stop("'count_percent' format must be provided in the formats argument")
70		}
71
72	1x	in_rows(sum(mis) * c(1, 1 / n_exp), .formats = formats$count_percent, .labels = labelstr)
73		}
74		}

1		make_dps_regex <- function(keyword, type = c("[", "{")) {
2	1092x	mustart <- match.arg(type)
3	1092x	muend <- ifelse(mustart == "[", "]", "}")
4
5	1092x	paste0("[~][", mustart, "]", keyword, " ([^", muend, "]+)[", muend, "]")
6		}
7
8		handle_one_markup <- function(strs, keyword, rtfstart, rtfend) {
9	546x	start <- ifelse(nzchar(rtfstart), paste0("\\", rtfstart, " "), "")
10	546x	end <- ifelse(nzchar(rtfstart), paste0("\\", rtfend, " "), "")
11	546x	out <- gsub(make_dps_regex(keyword), paste0(start, "\\1", end), strs)
12	546x	out <- gsub(make_dps_regex(keyword, "{"), paste0(start, "\\1", end), out)
13	546x	out
14		}
15
16
17		dps_markup_df <- tibble::tribble(
18		~keyword,
19		~rtfstart,
20		~rtfend,
21		"super",
22		"\\super",
23		"\\nosupersub",
24		"sub",
25		"\\sub",
26		"\\nosupersub",
27		"optional",
28		"",
29		""
30		)
31
32
33		#' Default String Mapping for Special Characters
34		#'
35		#' A tibble that maps special characters to their UTF-8 equivalents for use in RTF output.
36		#' Currently it maps ">=" and "<=" to the Unicode characters.
37		#'
38		#' @return A tibble with columns 'pattern' and 'value', where 'pattern' contains
39		#' the string to be replaced and 'value' contains the replacement.
40		#'
41		#' @export
42		#' @keywords internal
43		default_str_map <- tibble::tribble(
44		~pattern,
45		~value,
46		">=",
47		intToUtf8(strtoi(2265, base = 16)),
48		"<=",
49		intToUtf8(strtoi(2264, base = 16))
50		)
51
52		convert_dps_markup <- function(strs, markup_df = dps_markup_df) {
53	182x	for (i in seq_len(nrow(markup_df))) {
54	546x	strs <- handle_one_markup(strs, markup_df$keyword[i], markup_df$rtfstart[i], markup_df$rtfend[i])
55		}
56	182x	strs
57		}
58
59		strmodify <- function(strs, replacement_str = default_str_map) {
60	182x	map_tbl <- replacement_str
61	182x	if (!is.null(map_tbl) && nrow(map_tbl) > 0) {
62	178x	for (i in seq_len(nrow(map_tbl))) {
63	356x	pattern <- map_tbl$pattern[[i]]
64	356x	value <- map_tbl$value[i]
65	356x	strs <- gsub(pattern, value, strs, fixed = TRUE)
66		}
67		}
68	182x	return(strs)
69		}
70
71		prep_strs_for_rtf <- function(strs, string_map = default_str_map, markup_df = dps_markup_df) {
72	182x	strs <- convert_dps_markup(strs, markup_df)
73	182x	strs <- strmodify(strs, string_map)
74	182x	return(strs)
75		}
76
77
78		#' Relabel Variables in a Dataset
79		#'
80		#' This function relabels variables in a dataset based on a provided list of labels.
81		#' It can either replace existing labels or only add labels to variables without them.
82		#'
83		#' @param x (`data.frame`)\cr dataset containing variables to be relabeled.
84		#' @param lbl_list (`list`)\cr named list of labels to apply to variables.
85		#' @param replace_existing (`logical`)\cr if TRUE, existing labels will be replaced;
86		#' if FALSE, only variables without labels will be updated.
87		#'
88		#' @return The dataset with updated variable labels.
89		#'
90		#' @export
91		#' @keywords internal
92		var_relabel_list <- function(x, lbl_list, replace_existing = TRUE) {
93	!	if (replace_existing) {
94	!	vars_to_relabel <- intersect(names(x), names(lbl_list))
95		} else {
96	!	get_variables_with_empty_labels <- function(x) {
97	!	labels <- var_labels(x)
98	!	mask <- lapply(labels, is.na) \|> unlist()
99	!	return(names(labels[mask]))
100		}
101
102	!	vars_without_labels <- get_variables_with_empty_labels(x)
103	!	vars_to_relabel <- intersect(vars_without_labels, names(lbl_list))
104		}
105	!	do.call(var_relabel, c(list(x = x), lbl_list[vars_to_relabel]))
106		}

1		#' Adding Labels To Variables For Model
2		#'
3		#' @param vars (`list`)\cr variables to use.
4		#' @param data (`data.frame`)\cr data to use.
5		#' @param x (`character`)\cr an element in vars.
6		#'
7		#' @name labels
8		#' @keywords internal
9		NULL
10
11		#' @describeIn labels checks if element in `vars` is not `NULL` and not empty.
12		h_is_specified <- function(x, vars) {
13	165x	!is.null(vars[[x]]) && (length(vars[[x]]) > 0)
14		}
15
16		#' @describeIn labels checks if element in vars is not NULL and exists in dataset.
17		h_is_specified_and_in_data <- function(x, vars, data) {
18	93x	h_is_specified(x, vars) && all(vars[[x]] %in% names(data))
19		}
20
21		#' @describeIn labels gets label for each element in vars.
22		h_check_and_get_label <- function(x, vars, data) {
23	93x	checkmate::assert_true(h_is_specified_and_in_data(x, vars, data))
24	93x	res <- NULL
25	93x	for (v in vars[[x]]) {
26	108x	label <- attr(data[[v]], "label")
27	108x	string <- ifelse(!is.null(label), label, v)
28	108x	res <- c(res, stats::setNames(string, v))
29		}
30	93x	res
31		}
32
33		#' Extraction of Covariate Parts from Character Vector
34		#'
35		#' @description
36		#' Extraction of Covariate Parts from Character Vector.
37		#'
38		#' @param covariates (`character`)\cr specification in the usual way, see examples.
39		#'
40		#' @return Character vector of the covariates involved in `covariates` specification.
41		#' @keywords internal
42		h_get_covariate_parts <- function(covariates) {
43	18x	checkmate::assert_character(covariates, null.ok = TRUE)
44	18x	if (is.null(covariates)) {
45	!	NULL
46		} else {
47	18x	unique(unlist(strsplit(covariates, split = "\\*\|:")))
48		}
49		}
50
51		#' @describeIn labels returns the list of variables with labels.
52		h_labels <- function(vars, data) {
53	18x	checkmate::assert_list(vars)
54	18x	checkmate::assert_data_frame(data)
55	18x	labels <- list()
56	18x	labels$response <- h_check_and_get_label("response", vars, data)
57	18x	labels$id <- h_check_and_get_label("id", vars, data)
58	18x	labels$visit <- h_check_and_get_label("visit", vars, data)
59	18x	if (h_is_specified("arm", vars)) {
60	18x	labels$arm <- h_check_and_get_label("arm", vars, data)
61		}
62	18x	if (h_is_specified("covariates", vars)) {
63	18x	vars$parts <- h_get_covariate_parts(vars$covariates)
64	18x	labels$parts <- h_check_and_get_label("parts", vars, data)
65		}
66	18x	if (h_is_specified("weights", vars)) {
67	!	labels$weights <- h_check_and_get_label("weights", vars, data)
68		}
69	18x	if (h_is_specified("subgroup", vars)) {
70	3x	labels$subgroup <- h_check_and_get_label("subgroup", vars, data)
71		}
72	18x	return(labels)
73		}
74
75		#' Building Model Formula
76		#'
77		#' This builds the model formula which is used inside [fit_mmrm_j()] and provided
78		#' to [mmrm::mmrm()] internally. It can be instructive to look at the resulting
79		#' formula directly sometimes. In particular, if a `subgroup` variable is included
80		#' in `vars`, then the formula will include the interaction of `subgroup` with
81		#' `arm` and `visit`.
82		#'
83		#' @param vars (`list`)\cr variables to use in the model.
84		#' @param cor_struct (`string`)\cr specify the covariance structure to use.
85		#' @return Formula to use in [mmrm::mmrm()].
86		#' @export
87		#'
88		#' @examples
89		#' vars <- list(
90		#' response = "AVAL",
91		#' covariates = c("RACE", "SEX"),
92		#' id = "USUBJID",
93		#' arm = "ARMCD",
94		#' visit = "AVISIT",
95		#' subgroup = "REGION"
96		#' )
97		#' build_formula(vars, "auto-regressive")
98		#' build_formula(vars)
99		build_formula <- function(
100		vars,
101		cor_struct = c(
102		"unstructured",
103		"toeplitz",
104		"heterogeneous toeplitz",
105		"ante-dependence",
106		"heterogeneous ante-dependence",
107		"auto-regressive",
108		"heterogeneous auto-regressive",
109		"compound symmetry",
110		"heterogeneous compound symmetry"
111		)
112		) {
113	14x	checkmate::assert_list(vars)
114	14x	cor_struct <- match.arg(cor_struct)
115	14x	covariates_part <- paste(vars$covariates, collapse = " + ")
116	14x	arm_visit_part <- if (is.null(vars$arm)) {
117	!	vars$visit
118		} else {
119	14x	paste0(vars$arm, "*", vars$visit)
120		}
121	14x	if (!is.null(vars$subgroup)) {
122	4x	arm_visit_part <- paste0(arm_visit_part, "*", vars$subgroup)
123		}
124	14x	random_effects_fun <- switch(cor_struct,
125	14x	unstructured = "us",
126	14x	toeplitz = "toep",
127	14x	`heterogeneous toeplitz` = "toeph",
128	14x	`ante-dependence` = "ad",
129	14x	`heterogeneous ante-dependence` = "adh",
130	14x	`auto-regressive` = "ar1",
131	14x	`heterogeneous auto-regressive` = "ar1h",
132	14x	`compound symmetry` = "cs",
133	14x	`heterogeneous compound symmetry` = "csh"
134		)
135	14x	random_effects_part <- paste0(random_effects_fun, "(", vars$visit, " \| ", vars$id, ")")
136	14x	rhs_formula <- paste(arm_visit_part, "+", random_effects_part)
137	14x	if (covariates_part != "") {
138	14x	rhs_formula <- paste(covariates_part, "+", rhs_formula)
139		}
140	14x	stats::as.formula(paste(vars$response, "~", rhs_formula))
141		}
142
143		#' Extract Least Square Means from `MMRM`
144		#'
145		#' Extracts the least square means from an `MMRM` fit.
146		#'
147		#' @inheritParams fit_mmrm_j
148		#' @param fit (`mmrm`)\cr result of [mmrm::mmrm()].
149		#' @param averages (`list`)\cr named list of visit levels which should be averaged
150		#' and reported along side the single visits.
151		#' @param weights (`string`)\cr type of weights to be used for the least square means,
152		#' see [emmeans::emmeans()] for details.
153		#' @param mult_adj (`string`)\cr multiplicity adjustment within visits for the contrasts.
154		#' @return A list with data frames `estimates` and `contrasts`.
155		#' The attributes `averages`, `weights` and `mult_adj` save the settings used.
156		#'
157		#' @note This is modified from `tern.mmrm` and has the additional `mult_adj` argument.
158		#' @export
159		get_mmrm_lsmeans <- function(
160		fit, vars, conf_level, weights, averages = list(),
161		mult_adj = c("none", "dunnett", "step-down-dunnett")
162		) {
163	22x	checkmate::assert_class(fit, "mmrm")
164	22x	checkmate::assert_list(averages, types = "character")
165	22x	mult_adj <- match.arg(mult_adj)
166	22x	emmeans_res <- h_get_emmeans_res(fit, vars, weights)
167
168		# Get least square means estimates for single visits, and possibly averaged visits.
169	22x	estimates <- h_get_single_visit_estimates(emmeans_res, conf_level)
170	22x	if (length(averages)) {
171	7x	average_specs <- h_get_average_visit_specs(emmeans_res, vars, averages, fit)
172	7x	average_estimates <- h_get_spec_visit_estimates(emmeans_res, average_specs, conf_level)
173	7x	estimates <- rbind(estimates, average_estimates)
174		}
175	22x	has_arm_var <- !is.null(vars$arm)
176	22x	if (!has_arm_var) {
177	1x	return(list(estimates = estimates))
178		}
179		# Continue with contrasts when we have an arm variable.
180	21x	if (mult_adj != "none" && !identical(averages, list())) {
181	!	stop("Multiplicity adjustment within visits cannot be combined with averages across visits")
182		}
183
184	21x	contrast_specs <- h_single_visit_contrast_specs(emmeans_res, vars)
185	21x	contrast_estimates <- h_get_spec_visit_estimates(emmeans_res, contrast_specs, conf_level, tests = TRUE)
186
187	21x	if (length(averages)) {
188	6x	average_contrast_specs <- h_average_visit_contrast_specs(contrast_specs, averages, vars)
189	6x	average_contrasts <- h_get_spec_visit_estimates(emmeans_res, average_contrast_specs, conf_level, tests = TRUE)
190	6x	contrast_estimates <- rbind(contrast_estimates, average_contrasts)
191		}
192
193	21x	if (mult_adj != "none") {
194		# We just calculate the adjusted p-values and confidence intervals here and replace them
195		# in the contrast_estimates data frame. The estimates and t-stats remain unchanged.
196	3x	mult_adj_df <- h_get_mult_adj_estimates(
197	3x	emmeans_res = emmeans_res,
198	3x	vars = vars,
199	3x	mult_adj = mult_adj,
200	3x	conf_level = conf_level,
201	3x	contrast_df = contrast_estimates$df
202		)
203	3x	contrast_estimates$p_value <- mult_adj_df$p_value
204	3x	contrast_estimates$p_value_less <- mult_adj_df$p_value_less
205	3x	contrast_estimates$p_value_greater <- mult_adj_df$p_value_greater
206	3x	contrast_estimates$lower_cl <- mult_adj_df$lower_cl
207	3x	contrast_estimates$upper_cl <- mult_adj_df$upper_cl
208		}
209
210	21x	relative_reduc_df <- h_get_relative_reduc_df(estimates, vars)
211	21x	contrast_estimates <- merge(
212	21x	contrast_estimates,
213	21x	relative_reduc_df,
214	21x	by = c(vars$subgroup, vars$arm, vars$visit),
215	21x	sort = FALSE
216		)
217	21x	if (!is.null(vars$subgroup)) {
218	6x	contrast_estimates[[vars$subgroup]] <- factor(
219	6x	contrast_estimates[[vars$subgroup]],
220	6x	levels = intersect(levels(estimates[[vars$subgroup]]), contrast_estimates[[vars$subgroup]])
221		)
222		}
223	21x	contrast_estimates[[vars$arm]] <- factor(
224	21x	contrast_estimates[[vars$arm]],
225	21x	levels = intersect(levels(estimates[[vars$arm]]), contrast_estimates[[vars$arm]])
226		)
227	21x	contrast_estimates[[vars$visit]] <- factor(
228	21x	contrast_estimates[[vars$visit]],
229	21x	levels = intersect(levels(estimates[[vars$visit]]), contrast_estimates[[vars$visit]])
230		)
231	21x	structure(
232	21x	list(estimates = estimates, contrasts = contrast_estimates),
233	21x	averages = averages,
234	21x	weights = weights,
235	21x	mult_adj = mult_adj
236		)
237		}
238
239		#' `MMRM` Analysis
240		#'
241		#' Does the `MMRM` analysis. Multiple other functions can be called on the result to produce
242		#' tables and graphs.
243		#'
244		#' @param vars (named `list` of `string` or `character`)\cr specifying the variables in the `MMRM`.
245		#' The following elements need to be included as character vectors and match corresponding columns
246		#' in `data`:
247		#'
248		#' - `response`: the response variable.
249		#' - `covariates`: the additional covariate terms (might also include interactions).
250		#' - `id`: the subject ID variable.
251		#' - `arm`: the treatment group variable (factor).
252		#' - `visit`: the visit variable (factor).
253		#' - `weights`: optional weights variable (if `NULL` or omitted then no weights will be used).
254		#'
255		#' Note that the main effects and interaction of `arm` and `visit` are by default
256		#' included in the model.
257		#' @param data (`data.frame`)\cr with all the variables specified in
258		#' `vars`. Records with missing values in any independent variables
259		#' will be excluded.
260		#' @param conf_level (`proportion`)\cr confidence level of the interval.
261		#' @param cor_struct (`string`)\cr specifying the covariance structure, defaults to
262		#' `'unstructured'`. See the details.
263		#' @param averages_emmeans (`list`)\cr optional named list of visit levels which should be averaged
264		#' and reported along side the single visits.
265		#' @param weights_emmeans (`string`)\cr argument from [emmeans::emmeans()], `'counterfactual'` by default.
266		#' @param mult_adj_emmeans (`string`)\cr whether to multiplicity adjust LS means contrast p-values and
267		#' confidence intervals within visits when there are more than 2 treatment arms. Note that this cannot
268		#' be combined with `averages_emmeans`. Either "none", "dunnett" or "step-down-dunnett".
269		#' @param ... additional arguments for [mmrm::mmrm()], in particular `reml` and options listed in
270		#' [mmrm::mmrm_control()].
271		#'
272		#' @details Multiple different degree of freedom adjustments are available via the `method` argument
273		#' for [mmrm::mmrm()]. In addition, covariance matrix adjustments are available via `vcov`.
274		#' Please see [mmrm::mmrm_control()] for details and additional useful options.
275		#'
276		#' For the covariance structure (`cor_struct`), the user can choose among the following options.
277		#'
278		#' - `unstructured`: Unstructured covariance matrix. This is the most flexible choice and default.
279		#' If there are `T` visits, then `T * (T+1) / 2` variance parameters are used.
280		#' - `toeplitz`: Homogeneous Toeplitz covariance matrix, which uses `T` variance parameters.
281		#' - `heterogeneous toeplitz`: Heterogeneous Toeplitz covariance matrix,
282		#' which uses `2 * T - 1` variance parameters.
283		#' - `ante-dependence`: Homogeneous Ante-Dependence covariance matrix, which uses `T` variance parameters.
284		#' - `heterogeneous ante-dependence`: Heterogeneous Ante-Dependence covariance matrix,
285		#' which uses `2 * T - 1` variance parameters.
286		#' - `auto-regressive`: Homogeneous Auto-Regressive (order 1) covariance matrix,
287		#' which uses 2 variance parameters.
288		#' - `heterogeneous auto-regressive`: Heterogeneous Auto-Regressive (order 1) covariance matrix,
289		#' which uses `T + 1` variance parameters.
290		#' - `compound symmetry`: Homogeneous Compound Symmetry covariance matrix, which uses 2
291		#' variance parameters.
292		#' - `heterogeneous compound symmetry`: Heterogeneous Compound Symmetry covariance matrix, which uses
293		#' `T + 1` variance parameters.
294		#'
295		#' @return A `tern_model` object which is a list with model results:
296		#'
297		#' - `fit`: The `mmrm` object which was fitted to the data. Note that via `mmrm::component(fit, 'optimizer')`
298		#' the finally used optimization algorithm can be obtained, which can be useful for refitting the model
299		#' later on.
300		#' - `cov_estimate`: The matrix with the covariance matrix estimate.
301		#' - `diagnostics`: A list with model diagnostic statistics (REML criterion, AIC, corrected AIC, BIC).
302		#' - `lsmeans`: This is a list with data frames `estimates` and `contrasts`.
303		#' The attributes `averages`, `weights` and `mult_adj` save the settings used
304		#' (`averages_emmeans`, `weights_emmeans` and `mult_adj_emmeans`).
305		#' - `vars`: The variable list.
306		#' - `labels`: Corresponding list with variable labels extracted from `data`.
307		#' - `cor_struct`: input.
308		#' - `ref_level`: The reference level for the arm variable, which is always the first level.
309		#' - `treatment_levels`: The treatment levels for the arm variable.
310		#' - `conf_level`: The confidence level which was used to construct the `lsmeans` confidence intervals.
311		#' - `additional`: List with any additional inputs passed via `...`
312		#'
313		#' @export
314		#'
315		#' @note This function has the `_j` suffix to distinguish it from [mmrm::fit_mmrm()].
316		#' It is modified from the `tern.mmrm` package.
317		#' The new features are:
318		#'
319		#' - the `mult_adj_emmeans` argument and its functionality
320		#' - the `subgroup` variable in `vars` and its functionality
321		#'
322		#' These could later be contributed upstream in `tern.mmrm`.
323		#'
324		#' @examples
325		#' mmrm_results <- fit_mmrm_j(
326		#' vars = list(
327		#' response = "FEV1",
328		#' covariates = c("RACE", "SEX"),
329		#' id = "USUBJID",
330		#' arm = "ARMCD",
331		#' visit = "AVISIT"
332		#' ),
333		#' data = mmrm::fev_data,
334		#' cor_struct = "unstructured",
335		#' weights_emmeans = "equal",
336		#' averages_emmeans = list(
337		#' "VIS1+2" = c("VIS1", "VIS2")
338		#' )
339		#' )
340		fit_mmrm_j <- function(
341		vars = list(
342		response = "AVAL",
343		covariates = c(),
344		id = "USUBJID",
345		arm = "ARM",
346		visit = "AVISIT",
347		subgroup = NULL
348		),
349		data,
350		conf_level = 0.95,
351		cor_struct = "unstructured",
352		weights_emmeans = "counterfactual",
353		averages_emmeans = list(),
354		mult_adj_emmeans = c("none", "dunnett", "step-down-dunnett"),
355		...
356		) {
357	13x	labels <- h_labels(vars, data)
358	13x	formula <- build_formula(vars, cor_struct)
359	13x	weights <- if (!is.null(vars$weights)) data[[vars$weights]] else NULL
360
361	13x	fit <- mmrm::mmrm(formula = formula, data = data, weights = weights, reml = TRUE, ...)
362	13x	lsmeans <- get_mmrm_lsmeans(
363	13x	fit = fit,
364	13x	vars = vars,
365	13x	conf_level = conf_level,
366	13x	averages = averages_emmeans,
367	13x	weights = weights_emmeans,
368	13x	mult_adj = mult_adj_emmeans
369		)
370	13x	cov_estimate <- mmrm::VarCorr(fit)
371	13x	visit_levels <- rownames(cov_estimate)
372	13x	contrasts_from_visits <- match(visit_levels, lsmeans$contrasts[[vars$visit]])
373	13x	df <- stats::setNames(lsmeans$contrasts$df[contrasts_from_visits], visit_levels)
374	13x	results <- list(
375	13x	fit = fit,
376	13x	cov_estimate = cov_estimate,
377	13x	lsmeans = lsmeans,
378	13x	vars = vars,
379	13x	labels = labels,
380	13x	mse = diag(cov_estimate),
381	13x	df = df,
382	13x	cor_struct = cor_struct,
383	13x	ref_level = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[1],
384	13x	treatment_levels = if (is.null(vars$arm)) NULL else levels(data[[vars$arm]])[-1],
385	13x	conf_level = conf_level,
386	13x	additional = list(...)
387		)
388	13x	class(results) <- "tern_model"
389	13x	return(results)
390		}

1		#' Pool analysis results obtained from the imputed datasets
2		#'
3		#' @details This has been forked from the `rbmi` package, mainly to support in
4		#' addition the pooling of variance estimates. See pool() for more details.
5		#'
6		#' @param results an analysis object created by analyse().
7		#'
8		#' @param conf.level confidence level of the returned confidence interval.
9		#' Must be a single number between 0 and 1. Default is 0.95.
10		#'
11		#' @param alternative a character string specifying the alternative hypothesis,
12		#' must be one of `"two.sided"` (default), `"greater"` or `"less"`.
13		#'
14		#' @param type a character string of either `"percentile"` (default) or
15		#' `"normal"`. Determines what method should be used to calculate the bootstrap
16		#' confidence intervals. See details.
17		#' Only used if `method_condmean(type = "bootstrap")` was specified
18		#' in the original call to draws().
19		#'
20		#' @returns A list of class `pool`.
21		#'
22		#' @export
23		rbmi_pool <- function(
24		results,
25		conf.level = 0.95,
26		alternative = c("two.sided", "less", "greater"),
27		type = c("percentile", "normal")
28		) {
29	6x	rbmi::validate(results)
30
31	6x	alternative <- match.arg(alternative)
32	6x	type <- match.arg(type)
33
34	6x	pool_type <- class(results$results)[[1]]
35	6x	checkmate::assert_true(identical(pool_type, "rubin"))
36
37	6x	results_transpose <- (utils::getFromNamespace("transpose_results", "rbmi"))(
38	6x	results$results,
39	6x	(utils::getFromNamespace("get_pool_components", "rbmi"))(pool_type)
40		)
41
42	6x	pars <- lapply(
43	6x	results_transpose,
44	6x	function(x, ...) mod_pool_internal_rubin(x, ...),
45	6x	conf.level = conf.level,
46	6x	alternative = alternative,
47	6x	type = type,
48	6x	D = results$method$D
49		)
50
51	6x	method <- pool_type
52
53	6x	ret <- list(
54	6x	pars = pars,
55	6x	conf.level = conf.level,
56	6x	alternative = alternative,
57	6x	N = length(results$results),
58	6x	method = method
59		)
60	6x	class(ret) <- "pool"
61	6x	return(ret)
62		}
63
64		mod_pool_internal_rubin <- function(results, conf.level, alternative, type, D) {
65	9x	ests <- results$est
66	9x	ses <- results$se
67	9x	dfs <- results$df
68	9x	alpha <- 1 - conf.level
69
70		# Note: Need to take median here, because in the MMRM case the d.f. will be slightly different for each imputed
71		# data set analysis.
72	9x	v_com <- stats::median(dfs)
73
74	9x	res_rubin <- if (utils::packageVersion("rbmi") > "1.6.1") {
75	9x	(utils::getFromNamespace("rubin_rules", "rbmi"))(
76	9x	ests = ests,
77	9x	ses = ses,
78	9x	v_com = v_com,
79	9x	method = "barnard-rubin"
80		)
81		} else {
82	!	(utils::getFromNamespace("rubin_rules", "rbmi"))(
83	!	ests = ests,
84	!	ses = ses,
85	!	v_com = v_com
86		)
87		}
88
89	9x	ret <- (utils::getFromNamespace("parametric_ci", "rbmi"))(
90	9x	point = res_rubin$est_point,
91	9x	se = sqrt(res_rubin$var_t),
92	9x	alpha = alpha,
93	9x	alternative = alternative,
94	9x	qfun = stats::qt,
95	9x	pfun = stats::pt,
96	9x	df = res_rubin$df
97		)
98		# Here also return the pooled d.f.:
99	9x	ret$df <- res_rubin$df
100
101	9x	return(ret)
102		}

1		#' Tabulation for Exposure Tables
2		#'
3		#'
4		#' @details
5		#' Creates statistics needed for standard exposure table.
6		#' This includes differences and 95% CI and total treatment years.
7		#' This is designed to be used as an analysis (afun in `analyze`) function.
8		#'
9		#' @name a_summarize_ex_j
10		NULL
11
12		#' @inheritParams proposal_argument_convention
13		#' @describeIn a_summarize_ex_j Statistics function needed for the exposure tables.
14		#'
15		#' @param daysconv (`numeric`)\cr conversion required to get the values into days
16		#' (i.e 1 if original PARAMCD unit is days, 30.4375 if original PARAMCD unit is in months)
17		#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
18		#' If TRUE, ANCOVA methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
19		#' @param comp_btw_group (`logical`)\cr If TRUE, comparison between groups will be performed.
20		#' \cr When ancova = FALSE, the estimate of between group difference (on CHG) will be based upon two-sample t-test.
21		#' \cr When ancova = TRUE, the same ANCOVA model will be used for the estimate of between group difference (on CHG).
22		#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
23		#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
24		#' @param conf_level (`proportion`)\cr Confidence level of the interval
25		#' @param variables (named list of strings)\cr
26		#' list of additional analysis variables, with expected elements:
27		#' * arm (string)\cr
28		#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
29		#' Specifically, the first level of arm variable is taken as the reference group.
30		#' * covariates (character)\cr
31		#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
32		s_summarize_ex_j <- function(
33		df,
34		.var,
35		.df_row,
36		.spl_context,
37		comp_btw_group = TRUE,
38		ref_path = NULL,
39		ancova = FALSE,
40		interaction_y,
41		interaction_item,
42		conf_level,
43		daysconv,
44		variables
45		) {
46	5x	control <- control_analyze_vars()
47	5x	control$conf_level <- conf_level
48	5x	x_stats <- s_summary(df[[.var]], na.rm = TRUE, .var, control = control)
49		## add extra for subject years
50	5x	subj_years <- x_stats[["sum"]] * daysconv / 365.25
51	5x	x_stats[["total_subject_years"]] <- c(x_stats[["sum"]], subj_years)
52	5x	names(x_stats[["total_subject_years"]]) <- c("total", "subject_years")
53
54	5x	cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
55	5x	indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)
56
57	5x	if (indiffcol) {
58		# blank out all stats
59	2x	x_stats <- sapply(
60	2x	names(x_stats),
61	2x	FUN = function(x) {
62	60x	x_stats[[x]] <- NULL
63		},
64	2x	simplify = FALSE,
65	2x	USE.NAMES = TRUE
66		)
67		# diff between group will be updated in mean_sd stat
68	2x	if (comp_btw_group) {
69	2x	trt_var <- ref_path[length(ref_path) - 1L]
70	2x	ctrl_grp <- ref_path[length(ref_path)]
71	2x	cur_trt_grp <- h_get_cur_trt_grp(trt_var, .spl_context)
72
73	2x	.in_ref_col <- FALSE
74	!	if (cur_trt_grp == ctrl_grp) .in_ref_col <- TRUE
75
76	2x	.ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]
77
78	2x	if (ancova) {
79		# ancova method for diff between group
80	2x	x_stats2 <- s_summarize_ancova_j(
81	2x	df = df,
82	2x	.var = .var,
83	2x	.ref_group = .ref_group,
84	2x	.in_ref_col = .in_ref_col,
85	2x	.df_row = .df_row,
86	2x	conf_level = conf_level,
87	2x	interaction_y = interaction_y,
88	2x	interaction_item = interaction_item,
89	2x	variables = variables
90		)
91	2x	diffstat <- x_stats2[["lsmean_diff_with_ci"]]
92		} else {
93		# descriptive method for diff between group
94	!	x_stats2 <- s_summarize_desc_j(
95	!	df = df,
96	!	.var = .var,
97	!	.ref_group = .ref_group,
98	!	.in_ref_col = .in_ref_col,
99	!	control = control
100		)
101	!	diffstat <- x_stats2[["mean_diff_with_ci"]]
102		}
103		# actual update with the diffstat
104	2x	x_stats[["mean_sd"]] <- diffstat
105		}
106		}
107
108	5x	return(x_stats)
109		}
110
111		#' @title Analysis Function For Exposure Tables
112		#' @description
113		#' A function to create the appropriate statistics needed for exposure table
114		#' @inheritParams proposal_argument_convention
115		#'
116		#' @describeIn a_summarize_ex_j Formatted analysis function which is used as `afun`.
117		#'
118		#' @return
119		#' * `a_summarize_ex_j()` returns the corresponding list with formatted [rtables::CellValue()].
120		#'
121		#' @aliases a_summarize_ex_j
122		#' @examples
123		#' library(dplyr)
124		#' ADEX <- ex_adsl \|> select(USUBJID, ARM, TRTSDTM, EOSSTT, EOSDY)
125		#'
126		#' trtvar <- "ARM"
127		#' ctrl_grp <- "B: Placebo"
128		#' cutoffd <- as.Date("2023-09-24")
129		#'
130		#' ADEX <- ADEX \|>
131		#' create_colspan_var(
132		#' non_active_grp = ctrl_grp,
133		#' non_active_grp_span_lbl = " ",
134		#' active_grp_span_lbl = "Active Study Agent",
135		#' colspan_var = "colspan_trt",
136		#' trt_var = trtvar
137		#' ) \|>
138		#' mutate(
139		#' diff_header = "Difference in Means (95% CI)",
140		#' diff_label = paste(!!rlang::sym(trtvar), "vs", ctrl_grp),
141		#' TRTDURY = case_when(
142		#' !is.na(EOSDY) ~ EOSDY,
143		#' TRUE ~ as.integer(cutoffd - as.Date(TRTSDTM) + 1)
144		#' )
145		#' )
146		#'
147		#' colspan_trt_map <- create_colspan_map(ADEX,
148		#' non_active_grp = ctrl_grp,
149		#' non_active_grp_span_lbl = " ",
150		#' active_grp_span_lbl = "Active Study Agent",
151		#' colspan_var = "colspan_trt",
152		#' trt_var = trtvar
153		#' )
154		#'
155		#' ref_path <- c("colspan_trt", "", trtvar, ctrl_grp)
156		#'
157		#' lyt <- basic_table() \|>
158		#' split_cols_by(
159		#' "colspan_trt",
160		#' split_fun = trim_levels_to_map(map = colspan_trt_map)
161		#' ) \|>
162		#' split_cols_by(trtvar) \|>
163		#' split_cols_by("diff_header", nested = FALSE) \|>
164		#' split_cols_by(
165		#' trtvar,
166		#' split_fun = remove_split_levels(ctrl_grp),
167		#' labels_var = "diff_label"
168		#' ) \|>
169		#' analyze("EOSDY",
170		#' afun = a_summarize_ex_j, var_labels = "Duration of treatment (Days)",
171		#' show_labels = "visible",
172		#' indent_mod = 0L,
173		#' extra_args = list(
174		#' daysconv = 1,
175		#' ref_path = ref_path,
176		#' variables = list(arm = trtvar, covariates = NULL),
177		#' ancova = TRUE,
178		#' comp_btw_group = TRUE
179		#' )
180		#' )
181		#'
182		#' result <- build_table(lyt, ADEX, alt_counts_df = ADEX)
183		#' result
184		#' @export
185		a_summarize_ex_j <- function(
186		df,
187		.var,
188		.df_row,
189		.spl_context,
190		comp_btw_group = TRUE,
191		ref_path = NULL,
192		ancova = FALSE,
193		interaction_y = FALSE,
194		interaction_item = NULL,
195		conf_level = 0.95,
196		variables,
197		.stats = c("mean_sd", "median", "range", "quantiles", "total_subject_years"),
198		.formats = c(diff_mean_est_ci = jjcsformat_xx("xx.xx (xx.xx, xx.xx)")),
199		.labels = c(quantiles = "Interquartile range"),
200		.indent_mods = NULL,
201		na_str = rep("NA", 3),
202		daysconv = 1
203		) {
204	5x	checkmate::check_character(ref_path, min.len = 2L)
205	5x	checkmate::assert_true(length(ref_path) %% 2L == 0L)
206
207	5x	if (!is.numeric(df[[.var]])) {
208	!	stop("a_summarize_ex_j issue: input variable must be numeric.")
209		}
210
211	5x	if (comp_btw_group && is.null(ref_path)) {
212	!	stop("a_summarize_ex_j issue: argument ref_path cannot be NULL.")
213		}
214
215	5x	if (comp_btw_group && ancova && is.null(variables)) {
216	!	stop("a_summarize_ex_j issue: argument variables must be defined when ancova is requested.")
217		}
218
219	5x	x_stats <- s_summarize_ex_j(
220	5x	df = df,
221	5x	.var = .var,
222	5x	.df_row = .df_row,
223	5x	.spl_context = .spl_context,
224	5x	comp_btw_group = comp_btw_group,
225	5x	ref_path = ref_path,
226	5x	ancova = ancova,
227	5x	interaction_y = interaction_y,
228	5x	interaction_item = interaction_item,
229	5x	conf_level = conf_level,
230	5x	daysconv = daysconv,
231	5x	variables = variables
232		)
233
234		# Fill in formatting defaults
235	5x	.stats_in <- .stats
236	5x	.stats <- tern_get_stats("analyze_vars_numeric", stats_in = .stats, custom_stats_in = NULL)
237	5x	if ("total_subject_years" %in% .stats_in) {
238		# place the extra statistic at the appropriate place within .stats vector
239	5x	i <- match("total_subject_years", .stats_in)
240	5x	x <- .stats_in[i:length(.stats_in)]
241	5x	if (length(x) == 1) {
242	5x	.stats <- c(.stats, "total_subject_years")
243		} else {
244	!	i2 <- min(match(x, .stats), na.rm = TRUE)
245	!	if (i2 == 1) {
246	!	.stats <- c("total_subject_years", .stats)
247		} else {
248	!	.stats <- c(.stats[1:(i2 - 1)], "total_subject_years", .stats[i2:length(.stats)])
249		}
250		}
251		}
252
253	5x	.stats_ext <- c(.stats, "diff_mean_est_ci")
254
255	5x	.formats <- junco_get_formats_from_stats(.stats_ext, .formats)
256	5x	.labels <- junco_get_labels_from_stats(.stats, .labels, label_attr_from_stats = get_label_attr_from_stats(x_stats))
257	5x	.indent_mods <- junco_get_indents_from_stats(.stats, .indent_mods)
258
259	5x	.names <- names(.labels)
260	5x	.labels <- .unlist_keep_nulls(.labels)
261	5x	.indent_mods <- .unlist_keep_nulls(.indent_mods)
262
263	5x	cur_col_id <- .spl_context$cur_col_id[[length(.spl_context$split)]]
264	5x	indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)
265
266	5x	if (indiffcol && comp_btw_group) {
267	2x	.formats[["mean_sd"]] <- .formats[["diff_mean_est_ci"]]
268		}
269	5x	.formats[["diff_mean_est_ci"]] <- NULL
270
271	5x	if (!is.null(na_str)) {
272	5x	.format_na_strs <- lapply(names(.formats), FUN = function(x) {
273	25x	na_str
274		})
275		} else {
276	!	.format_na_strs <- NULL
277		}
278
279	5x	x_stats <- x_stats[.stats]
280	5x	ret <- in_rows(
281	5x	.list = x_stats,
282	5x	.formats = .formats,
283	5x	.names = .names,
284	5x	.labels = .labels,
285	5x	.indent_mods = .indent_mods,
286	5x	.format_na_strs = .format_na_strs
287		)
288	5x	return(ret)
289		}

1		s_summarize_desc_j <- function(df, .var, .ref_group, .in_ref_col, control = control_analyze_vars()) {
2	175x	x <- df[[.var]]
3	175x	y1 <- s_summary(x)
4	175x	y2 <- NULL
5
6		# diff in means versus control group, based upon 2 sample t.test
7	175x	y2$mean_diff_with_ci <- numeric()
8	175x	if (!is.null(.ref_group) && !.in_ref_col) {
9	101x	x1 <- df[[.var]]
10	101x	x2 <- .ref_group[[.var]]
11
12	101x	x1 <- x1[!is.na(x1)]
13	101x	x2 <- x2[!is.na(x2)]
14
15	101x	ttest_stat <- safe_t_test(x1, x2, conf.level = control$conf_level)
16
17	101x	stat <- ttest_stat[c("estimate", "conf.int")]
18	101x	stat$diff <- stat$estimate[1] - stat$estimate[2]
19	101x	stat <- c(stat$diff, stat$conf.int)
20
21	101x	y2$mean_diff_with_ci <- with_label(
22	101x	c(mean_diff_with_ci = stat),
23	101x	paste("Difference in Mean + ", f_conf_level(control$conf_level))
24		)
25		}
26	175x	y <- c(y1, y2)
27
28	175x	return(y)
29		}
30
31		s_aval_chg_col1 <- function(df, .var, denom, .N_col, id, indatavar) {
32		## First column AVAL - show n/N (%)
33	100x	mystat <- "n"
34
35	100x	if (!is.null(indatavar)) {
36	!	df <- subset(df, !is.na(df[[indatavar]]))
37		}
38
39	100x	x <- df[[.var]]
40
41	100x	x_stats <- s_summary(x)
42	100x	x_stats <- x_stats[mystat]
43
44		### Ndenom derivation in case denom = N
45	100x	Ndenom <- .N_col
46	100x	if (denom == "N") {
47		### as our input dataset has ensured we have unique subjects we can just use the length of x here still safer
48		### to use id variable
49	100x	nsub <- length(unique(df[[id]]))
50	100x	Ndenom <- nsub
51		}
52
53	100x	count_denom_frac <- c(x_stats$n, Ndenom, x_stats$n / Ndenom)
54	100x	names(count_denom_frac) <- c("n", "N", "fraction")
55
56	100x	count_frac <- count_denom_frac[c("n", "fraction")]
57	100x	count <- count_denom_frac[c("n")]
58
59	100x	y <- list()
60	100x	y$count_denom_frac <- count_denom_frac
61	100x	y$count_frac <- count_frac
62	100x	y$count <- count
63
64	100x	return(y)
65		}
66
67		s_aval_chg_col23_diff <- function(
68		df,
69		.var,
70		.df_row,
71		.ref_group,
72		.in_ref_col,
73		ancova,
74		interaction_y,
75		interaction_item,
76		conf_level,
77		variables,
78		trt_var,
79		ctrl_grp,
80		cur_param,
81		cur_lvl,
82		weights_emmeans,
83		method_combo,
84		weights_combo
85		) {
86	244x	.df_row <- subset(.df_row, !is.na(.df_row[[.var]]))
87	244x	df <- subset(df, !is.na(df[[.var]]))
88	244x	.ref_group <- subset(.ref_group, !is.na(.ref_group[[.var]]))
89
90	244x	if (nrow(.df_row) == 0) {
91		#### this is only when input row no non-missing records in any of the columns expected to occur for baseline
92		#### timepoint for analysis variable change only here we want a blank cell, not a cell with all NA's NULL is
93		#### generating a blank cell
94	!	x_stats <- NULL
95	!	mystat1 <- c("mean_ci_3d", "mean_diff_with_ci")
96	244x	} else if (!ancova) {
97	173x	mystat1 <- c("mean_ci_3d", "mean_diff_with_ci")
98
99	173x	control <- control_analyze_vars()
100	173x	control$conf_level <- conf_level
101	173x	x_stats <- s_summarize_desc_j(
102	173x	df = df,
103	173x	.var = .var,
104	173x	.ref_group = .ref_group,
105	173x	.in_ref_col = .in_ref_col,
106	173x	control = control
107		)
108		} else {
109	71x	mystat1 <- c("lsmean_ci", "lsmean_diff_with_ci")
110
111		### sparse data problems with underlying ancova function 1/ if nrow(.df_row) = 0 NULL (blank columns)
112
113		### 2/ if nrow(df) = 0 no ancova - lsmean and lsmean diff should be na
114
115		### 3/ if nrow(df) > 0, & nrow(.ref_group) = 0 ancova for ls mean only, NULL .ref_group -- lsmean diff should
116		### be na
117
118		### 4/ if nrow(df) > 0, & nrow(.ref_group) > 0 and at least one group with 0 data update levels in
119		### .df_row/df/.ref_group to avoid problems for contrast
120
121		#### by making updates to .df_row/df/.ref_group, situation 3 and 4 could be used together with general case
122
123	71x	.df_row_trtlevels <- unique(.df_row[[trt_var]])
124
125	71x	if (NROW(.df_row_trtlevels) == 0) {
126		### No data at all
127	!	x_stats <- NULL
128	71x	} else if (NROW(df) == 0 \|\| NROW(.df_row_trtlevels) == 1) {
129		### current column no data/less than 2 treatment levels
130
131	!	x_stats <- list()
132	!	x_stats[[mystat1[1]]] <- rep(NA, 3)
133	!	x_stats[[mystat1[2]]] <- rep(NA, 3)
134		} else {
135		### ancova situation, and some updates to prevent problems with sparse data
136	71x	if ((!ctrl_grp %in% .df_row_trtlevels)) {
137		# LS means for current group can be estimated from model, but not difference in LS means set .ref_group
138		# to NULL to proceed with s_summarize_ancova_j function update to underlying s_ancova_j to cover NULL
139		# ref_group in call
140	!	.ref_group <- NULL
141		}
142	71x	if (NROW(.df_row_trtlevels) < length(levels(.df_row[[trt_var]]))) {
143		# missing levels need to be removed from the factor, in order to have the correct estimates, and avoid
144		# errors with underlying tern:::s_ancova function
145	!	.df_row[[trt_var]] <- droplevels(.df_row[[trt_var]])
146	!	df[[trt_var]] <- factor(as.character(df[[trt_var]]), levels = levels(.df_row[[trt_var]]))
147	!	.ref_group[[trt_var]] <- factor(as.character(.ref_group[[trt_var]]), levels = levels(.df_row[[trt_var]]))
148		}
149
150	71x	x_stats <- s_summarize_ancova_j(
151	71x	df = df,
152	71x	.var = .var,
153	71x	.ref_group = .ref_group,
154	71x	.in_ref_col = .in_ref_col,
155	71x	.df_row = .df_row,
156	71x	conf_level = conf_level,
157	71x	interaction_y = interaction_y,
158	71x	interaction_item = interaction_item,
159	71x	variables = variables,
160	71x	weights_emmeans = weights_emmeans,
161	71x	method_combo = method_combo,
162	71x	weights_combo = weights_combo
163		)
164		}
165		}
166
167	244x	y <- list(mean_ci_3d = x_stats[[mystat1[1]]], mean_diff_with_ci = x_stats[[mystat1[2]]])
168	244x	return(y)
169		}
170
171
172		#' @name a_summarize_aval_chg_diff_j
173		#'
174		#' @title Analysis function 3-column presentation
175		#'
176		#' @description Analysis functions to produce a 1-row summary presented in
177		#' a 3-column layout in the columns (column 1 = N, column 2 = Value, column 3 = Change).\cr
178		#' In the difference columns, only 1 column will be presented : difference + CI\cr
179		#' When ancova = `TRUE`, the presented statistics will be based on ANCOVA method (`s_summarize_ancova_j`).\cr
180		#' mean and ci (both for Value (column 2) and CHG (column 3)) using statistic `lsmean_ci`\cr
181		#' mean and ci for the difference column are based on same ANCOVA model using statistic `lsmean_diff_with_ci`\cr
182		#' When ancova = `FALSE`, descriptive statistics will be used instead.\cr
183		#' In the difference column, the 2-sample t-test will be used.
184		#'
185		#' @details See Description
186		#'
187		#' @inheritParams proposal_argument_convention
188		#' @inheritParams s_ancova_j
189		#' @param denom (`string`)\cr choice of denominator for proportions. Options are:
190		#' * `N`: number of records in this column/row split.
191		#' \cr There is no check in place that the current split only has one record per subject.
192		#' Users should be careful with this.
193		#' * `.N_col`: number of records in this column intersection (based on alt_counts_df dataset)
194		#' \cr (when alt_counts_df is a single record per subjects, this will match number of subjects)
195		#'
196		#' @param d (default = 1) \cr choice of Decimal precision.
197		#' Note that one extra precision will be added, as means are presented.
198		#' \cr Options are:
199		#' * numerical(1)
200		#' * variable name containing information on the precision, this variable
201		#' should be available on input dataset. The content of this variable should
202		#' then be an integer.
203		#'
204		#' @param ancova (`logical`)\cr If FALSE, only descriptive methods will be used. \cr
205		#' If TRUE, ANCOVA methods will be used for each of the columns : AVAL, CHG, DIFF. \cr
206		#' @param comp_btw_group (`logical`)\cr If TRUE, comparison between groups will be performed.
207		#' \cr When ancova = FALSE, the estimate of between group difference (on CHG)
208		#' will be based upon a two-sample t-test.
209		#' \cr When ancova = TRUE, the same ANCOVA model will be used for the estimate of between group difference (on CHG).
210		#'
211		#' @param interaction_y (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
212		#' @param interaction_item (`character`)\cr Will be passed onto the `tern` function `s_ancova`, when ancova = TRUE.
213		#' @param conf_level (`proportion`)\cr Confidence level of the interval
214		#' @param variables (named list of strings)\cr
215		#' list of additional analysis variables, with expected elements:
216		#' * arm (string)\cr
217		#' group variable, for which the covariate adjusted means of multiple groups will be summarized.
218		#' Specifically, the first level of arm variable is taken as the reference group.
219		#' * covariates (character)\cr
220		#' a vector that can contain single variable names (such as 'X1'), and/or interaction terms indicated by 'X1 * X2'.
221		#'
222		#'
223		#' @param format_na_str (`string`)\cr
224		#'
225		#' @param indatavar (`string`)\cr If not null, variable name to extra subset
226		#' incoming df to non-missing values of this variable.
227		#' @param multivars (`string(3)`)\cr Variables names to use in 3-col layout.
228		#'
229		#' @param .stats (named `list`)\cr column statistics to select for the table.
230		#' The following column names are to be used: `col1`, `col23`, `coldiff`.\cr
231		#' For `col1`, the following stats can be specified.\cr
232		#' For `col23`, only `mean_ci_3d` is available. When ancova = `TRUE` these are LS Means, otherwise, arithmetic means.\cr
233		#' For `coldiff`, only `mean_diff_with_ci` is available. When ancova = `TRUE` these
234		#' are LS difference in means, otherwise, difference in means based upon 2-sample t-test.\cr
235		#' @param .formats (named `list`)\cr formats for the column statistics. `xx.d` style formats can be used.
236		#' @param .formats_fun (named `list`)\cr formatting functions for the column
237		#' statistics, to be applied after the conversion of `xx.d` style to the
238		#' appropriate precision.
239		#'
240		#' @rdname a_summarize_aval_chg_diff_j
241		#' @return A function that can be used in an analyze function call
242		#' @export
243		#'
244		#'
245		#' @examples
246		#' library(dplyr)
247		#'
248		#' ADEG <- data.frame(
249		#' STUDYID = c(
250		#' "DUMMY", "DUMMY", "DUMMY", "DUMMY", "DUMMY",
251		#' "DUMMY", "DUMMY", "DUMMY", "DUMMY", "DUMMY"
252		#' ),
253		#' USUBJID = c(
254		#' "XXXXX01", "XXXXX02", "XXXXX03", "XXXXX04", "XXXXX05",
255		#' "XXXXX06", "XXXXX07", "XXXXX08", "XXXXX09", "XXXXX10"
256		#' ),
257		#' TRT01A = c(
258		#' "ARMA", "ARMA", "ARMA", "ARMA", "ARMA", "Placebo",
259		#' "Placebo", "Placebo", "ARMA", "ARMA"
260		#' ),
261		#' PARAM = c("BP", "BP", "BP", "BP", "BP", "BP", "BP", "BP", "BP", "BP"),
262		#' AVISIT = c(
263		#' "Visit 1", "Visit 1", "Visit 1", "Visit 1", "Visit 1",
264		#' "Visit 1", "Visit 1", "Visit 1", "Visit 1", "Visit 1"
265		#' ),
266		#' AVAL = c(56, 78, 67, 87, 88, 93, 39, 87, 65, 55),
267		#' CHG = c(2, 3, -1, 9, -2, 0, 6, -2, 5, 2)
268		#' )
269		#'
270		#' ADEG <- ADEG \|>
271		#' mutate(
272		#' TRT01A = as.factor(TRT01A),
273		#' STUDYID = as.factor(STUDYID)
274		#' )
275		#'
276		#' ADEG$colspan_trt <- factor(ifelse(ADEG$TRT01A == "Placebo", " ", "Active Study Agent"),
277		#' levels = c("Active Study Agent", " ")
278		#' )
279		#' ADEG$rrisk_header <- "Risk Difference (%) (95% CI)"
280		#' ADEG$rrisk_label <- paste(ADEG$TRT01A, paste("vs", "Placebo"))
281		#'
282		#' colspan_trt_map <- create_colspan_map(ADEG,
283		#' non_active_grp = "Placebo",
284		#' non_active_grp_span_lbl = " ",
285		#' active_grp_span_lbl = "Active Study Agent",
286		#' colspan_var = "colspan_trt",
287		#' trt_var = "TRT01A"
288		#' )
289		#' ref_path <- c("colspan_trt", " ", "TRT01A", "Placebo")
290		#'
291		#' lyt <- basic_table() \|>
292		#' split_cols_by(
293		#' "colspan_trt",
294		#' split_fun = trim_levels_to_map(map = colspan_trt_map)
295		#' ) \|>
296		#' split_cols_by("TRT01A") \|>
297		#' split_rows_by(
298		#' "PARAM",
299		#' label_pos = "topleft",
300		#' split_label = "Blood Pressure",
301		#' section_div = " ",
302		#' split_fun = drop_split_levels
303		#' ) \|>
304		#' split_rows_by(
305		#' "AVISIT",
306		#' label_pos = "topleft",
307		#' split_label = "Study Visit",
308		#' split_fun = drop_split_levels,
309		#' child_labels = "hidden"
310		#' ) \|>
311		#' split_cols_by_multivar(
312		#' c("AVAL", "AVAL", "CHG"),
313		#' varlabels = c("n/N (%)", "Mean (CI)", "CFB (CI)")
314		#' ) \|>
315		#' split_cols_by("rrisk_header", nested = FALSE) \|>
316		#' split_cols_by(
317		#' "TRT01A",
318		#' split_fun = remove_split_levels("Placebo"),
319		#' labels_var = "rrisk_label"
320		#' ) \|>
321		#' split_cols_by_multivar(c("CHG"), varlabels = c(" ")) \|>
322		#' analyze("STUDYID",
323		#' afun = a_summarize_aval_chg_diff_j,
324		#' extra_args = list(
325		#' format_na_str = "-", d = 0,
326		#' ref_path = ref_path, variables = list(arm = "TRT01A", covariates = NULL)
327		#' )
328		#' )
329		#'
330		#' result <- build_table(lyt, ADEG)
331		#'
332		#' result
333		#' @family Inclusion of ANCOVA Functions
334		a_summarize_aval_chg_diff_j <- function(
335		df,
336		.df_row,
337		.spl_context,
338		ancova = FALSE,
339		comp_btw_group = TRUE,
340		ref_path = NULL,
341		.N_col,
342		denom = c("N", ".N_col"),
343		indatavar = NULL,
344		d = 0,
345		id = "USUBJID",
346		interaction_y = FALSE,
347		interaction_item = NULL,
348		conf_level = 0.95,
349		variables = list(arm = "TRT01A", covariates = NULL),
350		format_na_str = "",
351		.stats = list(col1 = "count_denom_frac", col23 = "mean_ci_3d", coldiff = "mean_diff_with_ci"),
352		.formats = list(col1 = NULL, col23 = "xx.dx (xx.dx, xx.dx)", coldiff = "xx.dx (xx.dx, xx.dx)"),
353		.formats_fun = list(col1 = jjcsformat_count_denom_fraction, col23 = jjcsformat_xx, coldiff = jjcsformat_xx),
354		multivars = c("AVAL", "AVAL", "CHG"),
355		weights_emmeans = NULL,
356		method_combo = c("contrasts", "collapse"),
357		weights_combo = NULL
358		) {
359	344x	checkmate::check_character(ref_path, min.len = 2L)
360	344x	checkmate::assert_true(length(ref_path) %% 2L == 0L)
361
362	344x	denom <- match.arg(denom)
363	344x	method_combo <- match.arg(method_combo)
364
365	344x	if (comp_btw_group && is.null(ref_path)) {
366	!	stop("ref_path cannot be NULL, please specify it. See ?get_ref_info for details.")
367		}
368
369	344x	if (!(length(multivars) == 3)) {
370	!	stop("argument multivars must be of length 3.")
371		}
372
373	344x	if (!(all(multivars %in% names(df)))) {
374	!	stop("all variables specified in multivars must be available on input dataset df.")
375		}
376
377	344x	if (multivars[1] == multivars[2]) {
378	344x	multivars[2] <- paste0(multivars[2], "._[[2]]_.")
379		}
380
381		if (
382	344x	!is.list(.stats) \|\|
383	344x	!all(c("col1", "col23", "coldiff") %in% names(.stats)) \|\|
384	344x	!is.list(.formats) \|\|
385	344x	!all(c("col1", "col23", "coldiff") %in% names(.formats)) \|\|
386	344x	!is.list(.formats_fun) \|\|
387	344x	!all(c("col1", "col23", "coldiff") %in% names(.formats_fun))
388		) {
389	!	stop(paste(
390	!	"Issue a_summarize_aval_chg_diff_j \n.stats/.formats/.formats_fun must",
391	!	"be a list with names c(\"col1\", \"col23\", \"coldiff\")."
392		))
393		}
394
395	344x	row_vars <- .spl_context$split
396	344x	row_val <- .spl_context$cur_col_split_val
397
398	344x	col_split <- .spl_context$cur_col_split
399
400		## treatment group value/variable KEY assumption : treatment variable is the last split_col prior to
401		## split_cols_by_multivar
402	344x	colvars <- col_split[[NROW(.spl_context)]]
403	344x	colvars_multivars <- which(colvars == "multivars")
404	344x	if (identical(colvars_multivars, integer(0))) {
405	!	stop("Layout must at least contain a split_cols_by_multivar call.")
406		}
407	344x	if (colvars_multivars == 1) {
408	!	stop("Layout must at least contain a split_cols_by prior to split_cols_by_multivar call.")
409		}
410		## KEY assumption : treatment variable is the last split_col prior to split_cols_by_multivar
411	344x	trt_var <- .spl_context$cur_col_split[[NROW(.spl_context)]][colvars_multivars - 1]
412	344x	trt_val <- .spl_context$cur_col_split_val[[NROW(.spl_context)]][colvars_multivars - 1]
413
414	344x	mysplitlevel <- length(.spl_context$split)
415	344x	cur_lvl <- .spl_context$value[[mysplitlevel]]
416	344x	cur_col_id <- .spl_context$cur_col_id[[mysplitlevel]]
417
418	344x	cur_param <- .spl_context$value[[mysplitlevel - 1]]
419
420	344x	indiffcol <- grepl("difference", tolower(cur_col_id), fixed = TRUE)
421
422		# Early return if we're not comparing between groups but we're in a difference column
423	344x	if (!comp_btw_group && indiffcol) {
424	!	return(rcell(NULL, format = NULL, label = cur_lvl, format_na_str = format_na_str))
425		}
426
427		## variable that is analyzed
428	344x	last_val <- utils::tail(.spl_context$cur_col_split_val[[NROW(.spl_context)]], 1)
429
430		# as AVAL will be utilized twice, the second call results in last_val == 'AVAL._[[2]]_.' take the first part of it
431		# in flast_val (will become AVAL) flast_val <- stringr::str_split_1(last_val, pattern = '._')[1]
432	344x	flast_val <- unlist(strsplit(last_val, "._"))[1]
433
434	344x	x_stats <- NULL
435	344x	fmt_d <- NULL
436
437	344x	.in_ref_col <- FALSE
438	344x	.ref_group <- NULL
439	344x	ctrl_grp <- NULL
440	344x	if (comp_btw_group) {
441	290x	checkmate::assert_true(identical(trt_var, ref_path[length(ref_path) - 1L]))
442	290x	ctrl_grp <- ref_path[length(ref_path)]
443	290x	stopifnot(ctrl_grp %in% levels(df[[trt_var]]))
444
445	78x	if (trt_val == ctrl_grp) .in_ref_col <- TRUE
446
447	290x	.ref_group <- .df_row[.df_row[[trt_var]] == ctrl_grp, ]
448		}
449
450	344x	if (last_val == multivars[1] && !indiffcol) {
451	100x	mystat <- .stats[["col1"]]
452	100x	if (is.null(.formats[["col1"]])) {
453	100x	fmt <- .formats_fun[["col1"]]
454		} else {
455	!	fmt <- .formats[["col1"]]
456		}
457
458	100x	x_stats <- s_aval_chg_col1(
459	100x	df = df,
460	100x	.var = flast_val,
461	100x	denom = denom,
462	100x	.N_col = .N_col,
463	100x	id = id,
464	100x	indatavar = indatavar
465		)
466	244x	} else if (last_val %in% multivars[2:3]) {
467	244x	x_stats <- s_aval_chg_col23_diff(
468	244x	df = df,
469	244x	.var = flast_val,
470	244x	.df_row = .df_row,
471	244x	.ref_group = .ref_group,
472	244x	.in_ref_col = .in_ref_col,
473	244x	ancova = ancova,
474	244x	interaction_y = interaction_y,
475	244x	interaction_item = interaction_item,
476	244x	conf_level = conf_level,
477	244x	variables = variables,
478	244x	trt_var = trt_var,
479	244x	ctrl_grp = ctrl_grp,
480	244x	cur_param = cur_param,
481	244x	cur_lvl = cur_lvl,
482	244x	weights_emmeans = weights_emmeans,
483	244x	method_combo = method_combo,
484	244x	weights_combo = weights_combo
485		)
486
487	244x	if (comp_btw_group && indiffcol) {
488	44x	mystat1 <- "coldiff"
489		} else {
490	200x	mystat1 <- "col23"
491		}
492	244x	mystat <- .stats[[mystat1]]
493
494	244x	fmt_d <- .formats[[mystat1]]
495	244x	formatting_fun <- .formats_fun[[mystat1]]
496
497	244x	fmt <- format_xxd(fmt_d, d = d, .df_row = .df_row, formatting_fun = formatting_fun)
498		}
499	344x	x_stats <- x_stats[[mystat]]
500
501	344x	ret <- rcell(x_stats, format = fmt, label = cur_lvl, format_na_str = format_na_str)
502	344x	return(ret)
503		}

1		#' Calculate Count and Percentage of the Maximum Level of an Ordered Factor per
2		#' Subject.
3		#'
4		#' @description A formatted analysis function used as an `afun` in
5		#' \link[rtables]{analyze} and as a `cfun` in \link[rtables]{summarize_row_groups}.
6		#'
7		#' It computes count and proportion statistics for the maximum level of an
8		#' ordered factor, `df[[.var]]`, for each unique subject in `df[[id]]`.
9		#' Specifically, for each subject, the function identifies the highest level
10		#' of `df[[.var]]`, producing one value per subject.
11		#' Then, if `any_level = TRUE`, the function reports the total number of
12		#' maximum values, excluding those specified in `any_level_exclude`.
13		#' Otherwise, it tabulates the frequency of each maximum level across all
14		#' subjects.
15		#'
16		#' This function is particularly useful for identifying the maximum severity of
17		#' adverse events in a treatment sequence, where the most severe event
18		#' experienced by a subject is used for reporting.
19		#'
20		#' @note The denominator for proportions is computed using the `denom_df`
21		#' argument. This serves as a temporary workaround until the next version of
22		#' `rtables` is released, which will support `.alt_count_df` for use in
23		#' `afun`/`cfun`.
24		#'
25		#' @details For each unique subject, only the maximum level of the ordered factor
26		#' `df[[.var]]` is included in the final count and percentage statistics.
27		#'
28		#' @inheritParams proposal_argument_convention
29		#' @param .alt_df_full (`dataframe`)\cr A dataset used to compute the
30		#' denominator for proportions. This is required when the same subject appears
31		#' multiple times in the dataset due to treatment sequences.
32		#' `colnames(.alt_df_full)` must be a superset of `id`.
33		#' This argument gets populated by the rtables split machinery
34		#' (see [rtables::additional_fun_params]).
35		#' @param any_level (`flag`)\cr
36		#' Should be set to `TRUE` when the function is used as a `cfun`.
37		#' @param any_level_exclude (`character`)\cr
38		#' Applicable only when `any_level = TRUE`. Specifies levels of `df[[.var]]`
39		#' to exclude from the statistic (default = "Missing").
40		#'
41		#' @returns A `RowsVerticalSection` object.
42		#'
43		#' @author WW
44		#'
45		#' @export
46		#'
47		#' @examples
48		#' treatments <- factor(c("a", "b", "c"))
49		#' ae_severities <- c("Missing", "Mild", "Moderate", "Severe")
50		#' ae_severities <- ordered(ae_severities, levels = ae_severities)
51		#' my_adae <- data.frame(
52		#' ID = c(1, 1, 1, 2, 2, 3, 3, 3, 3, 4),
53		#' TRT = factor(c("a", "b", "b", "b", "c", "c", "a", "c", "b", "b")),
54		#' AESEV = ae_severities[c(4L, 1L, 2L, 1L, 2L, 1L, 2L, 3L, 1L, 2L)]
55		#' )
56		#' my_adsl <- data.frame(
57		#' ID = rep(1:5, each = 3),
58		#' TRT = factor(rep(c("a", "b", "c"), times = 5))
59		#' )
60		#'
61		#' aesevall_spf <- make_combo_splitfun(
62		#' nm = "AESEV_ALL",
63		#' label = "Any AE",
64		#' levels = NULL,
65		#' )
66		#'
67		#' lyt <- basic_table() \|>
68		#' split_cols_by("TRT") \|>
69		#' add_overall_col("Total") \|>
70		#' split_rows_by("AESEV", split_fun = aesevall_spf) \|>
71		#' summarize_row_groups(
72		#' "AESEV",
73		#' cfun = a_maxlev,
74		#' extra_args = list(id = "ID", any_level = TRUE)
75		#' ) \|>
76		#' analyze(
77		#' "AESEV",
78		#' afun = a_maxlev,
79		#' extra_args = list(id = "ID")
80		#' )
81		#' build_table(lyt, my_adae, alt_counts_df = my_adsl)
82		a_maxlev <- function(df,
83		labelstr = NULL,
84		.var,
85		.spl_context,
86		id = "USUBJID",
87		.alt_df_full = NULL,
88		any_level = FALSE,
89		any_level_exclude = "Missing",
90		...) {
91	29x	checkmate::assert_factor(df[[.var]], ordered = TRUE, any.missing = FALSE)
92	28x	checkmate::assert_string(id)
93	28x	checkmate::assert_subset(id, choices = colnames(df))
94	28x	checkmate::assert_subset(id, choices = colnames(.alt_df_full))
95	28x	checkmate::assert_flag(any_level)
96	28x	checkmate::assert_character(any_level_exclude, any.missing = FALSE, unique = TRUE)
97
98	28x	varvec <- df[[.var]]
99	28x	levs <- levels(varvec)
100	28x	levs_lab <- if (any_level) {
101	16x	labelstr
102		} else {
103	12x	levs
104		}
105
106	28x	N_row <- nrow(df)
107	28x	count_pct <- if (N_row != 0) {
108	28x	max_per_id <- tapply(varvec, df[[id]], max)
109	28x	max_per_id <- ordered(levs[max_per_id], levels = levs) # tapply loses levels of varvec.
110
111	28x	count_max <- if (any_level) {
112	16x	sum(max_per_id != any_level_exclude)
113		} else {
114	12x	table(max_per_id)
115		}
116
117	28x	cur_col <- subset(.alt_df_full, eval(.spl_context$cur_col_expr[[1]]))
118	28x	N <- length(unique(cur_col[[id]]))
119	28x	as.list(data.frame(rbind(count_max, count_max / N)))
120		} else {
121	!	rep(list(NA), length(levs_lab))
122		}
123
124	28x	count_pct <- setNames(count_pct, levs_lab)
125
126	28x	in_rows(
127	28x	.list = count_pct,
128	28x	.formats = jjcsformat_count_fraction,
129	28x	.format_na_strs = "-"
130		)
131		}

1		#' @title Descriptive Statistics for Univariate Data with Optional Reference
2		#' Comparison
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' Computes descriptive statistics for a single variable `df[[.var]]` using
7		#' [tern::s_summary()], which dispatches type-specific methods depending on the
8		#' S3 class of the input (e.g., character, factor, logical, numeric).
9		#'
10		#' Optionally, it computes estimates and associated inferential statistics for
11		#' the difference in population means between two underlying distributions,
12		#' based on observed samples `df[[.var]]` and `.ref_group[[.var]]` using
13		#' [s_diff_means()].
14		#' These statistics are applicable only to numeric data.
15		#'
16		#' @inheritParams proposal_argument_convention
17		#' @param .var (`character(1)`)\cr Name of the column in `df` containing the
18		#' values for which statistics are computed. The variable type is handled by
19		#' the corresponding methods of [tern::s_summary()].
20		#' If difference-in-means statistics are requested, `df[[.var]]` must be
21		#' numeric.
22		#' @param .stats (`character` or `NULL`)\cr Names of statistics to be computed.
23		#' For numerical data, the names of supported statistics are listed via
24		#' [tern::get_stats()] for statistics for a single variable and
25		#' `junco_get_stats("diff_means")` for difference-in-means statistics.
26		#' If `NULL`, all available statistics for numerical data are computed.
27		#' @param control (`list`)\cr List of control options passed to
28		#' [tern::s_summary()].
29		#' If difference-in-means statistics are requested, `control$conf_level`
30		#' specifies the confidence level of the interval.
31		#' @param ... Additional named arguments passed to [s_diff_means()], except
32		#' `df1`, `df2`, `.var`, and `conf.level`, which are already passed.
33		#'
34		#' @importFrom tern control_analyze_vars s_summary get_stats
35		#'
36		#' @returns A named `list` with the requested statistics.
37		#'
38		#' @author WW
39		#'
40		#' @export
41		#'
42		#' @examples
43		#' df <- data.frame(
44		#' USUBJID = c("X01", "X02", "X03", "X04", "X05"),
45		#' TRT01A = rep("ARM_A", 5),
46		#' PARAMCD = rep("SYSBP", 5),
47		#' AVISIT = rep("Visit 1", 5),
48		#' CHG = c(4, 1, -1, 9, -2)
49		#' )
50		#' df
51		#'
52		#' rg <- data.frame(
53		#' USUBJID = c("X06", "X07", "X08", "X09", "X10"),
54		#' TRT01A = rep("Placebo", 5),
55		#' PARAMCD = rep("SYSBP", 5),
56		#' AVISIT = rep("Visit 1", 5),
57		#' CHG = c(-2, 6, -2, 5, 2)
58		#' )
59		#' rg
60		#'
61		#' .stats <- c("n", "mean_sd", "diff_means_n1", "diff_means_n2", "diff_means_est_ci")
62		#'
63		#' # With reference group.
64		#' s_summary_diff(df, "CHG", .stats, rg)
65		#'
66		#' # Using df as reference.
67		#' s_summary_diff(df, "CHG", .stats, df, .in_ref_col = TRUE)
68		#'
69		s_summary_diff <- function(df,
70		.var,
71		.stats = NULL,
72		.ref_group = NULL,
73		.in_ref_col = FALSE,
74		control = tern::control_analyze_vars(),
75		...) {
76	!	checkmate::assert_data_frame(df, null.ok = FALSE)
77	!	checkmate::assert_string(.var)
78	!	checkmate::assert_names(colnames(df), must.include = .var)
79	!	checkmate::assert_character(
80	!	x = .stats, any.missing = FALSE, min.len = 1, unique = TRUE, null.ok = TRUE
81		)
82	!	checkmate::assert_flag(.in_ref_col, null.ok = FALSE)
83	!	checkmate::assert_list(control, null.ok = FALSE)
84
85	!	if (is.null(.stats)) {
86	!	.stats <- unique(c(tern::get_stats(), junco_get_stats("diff_means")))
87		}
88
89	!	y <- tern::s_summary(df[[.var]], control = control)
90
91	!	.stats_diff <- .stats[startsWith(.stats, "diff_means_")]
92	!	if (length(.stats_diff) >= 1) {
93	!	dm <- if (.in_ref_col) {
94	!	setNames(vector(mode = "list", length = length(.stats_diff)), .stats_diff)
95		} else {
96	!	if (!checkmate::test_data_frame(.ref_group, null.ok = FALSE)) {
97	!	stop(".ref_group must be a data.frame for diff_means_* stats when .in_ref_col = FALSE")
98		}
99	!	checkmate::assert_names(names(control), must.include = "conf_level")
100	!	s_diff_means(df, .ref_group, .var, conf.level = control$conf_level, ...)
101		}
102	!	y <- c(y, dm)
103		}
104
105	!	y[.stats]
106		}

1		#' Analysis of Covariance
2		#'
3		#' Performs an analysis of covariance between two groups returning the estimated
4		#' "treatment effect" (i.e. the contrast between the two treatment groups) and
5		#' the least square means estimates in each group.
6		#'
7		#' @param data A `data.frame` containing the data to be used in the model.
8		#' @param vars A `vars` object as generated by the set_vars() function from the rbmi package. Only the `group`,
9		#' `visit`, `outcome` and `covariates` elements are required. See details.
10		#' @param visits An optional character vector specifying which visits to
11		#' fit the ancova model at. If `NULL`, a separate ancova model will be fit to the
12		#' outcomes for each visit (as determined by `unique(data[[vars$visit]])`).
13		#' See details.
14		#' @param weights Character, either `"counterfactual"` (default), `"equal"`,
15		#' `"proportional_em"` or `"proportional"`.
16		#' Specifies the weighting strategy to be used when calculating the lsmeans.
17		#' See the weighting section for more details.
18		#'
19		#' @details
20		#' The function works as follows:
21		#'
22		#' 1. Select the first value from `visits`.
23		#' 2. Subset the data to only the observations that occurred on this visit.
24		#' 3. Fit a linear model as `vars$outcome ~ vars$group + vars$covariates`.
25		#' 4. Extract the "treatment effect" & least square means for each treatment group.
26		#' 5. Repeat points 2-3 for all other values in `visits`.
27		#'
28		#' If no value for `visits` is provided then it will be set to
29		#' `unique(data[[vars$visit]])`.
30		#'
31		#' In order to meet the formatting standards set by [rbmi_analyse()] the results will be collapsed
32		#' into a single list suffixed by the visit name, e.g.:
33		#' ```
34		#' list(
35		#' var_visit_1 = list(est = ...),
36		#' trt_B_visit_1 = list(est = ...),
37		#' lsm_A_visit_1 = list(est = ...),
38		#' lsm_B_visit_1 = list(est = ...),
39		#' var_visit_2 = list(est = ...),
40		#' trt_B_visit_2 = list(est = ...),
41		#' lsm_A_visit_2 = list(est = ...),
42		#' lsm_B_visit_2 = list(est = ...),
43		#' ...
44		#' )
45		#' ```
46		#' Please note that "trt" refers to the treatment effects, and "lsm" refers to the least
47		#' square mean results. In the above example `vars$group` has two factor levels A and B.
48		#' The new "var" refers to the model estimated variance of the residuals.
49		#'
50		#' If you want to include interaction terms in your model this can be done
51		#' by providing them to the `covariates` argument of the set_vars() function from the rbmi package
52		#' e.g. `set_vars(covariates = c("sex*age"))`.
53		#'
54		#' @return a list of variance (`var_`), treatment effect (`trt_`), and
55		#' least square mean (`lsm_*`) estimates for each visit, organized as
56		#' described in Details above.
57		#'
58		#' @note These functions have the `rbmi_` prefix to distinguish them from the corresponding
59		#' `rbmi` package functions, from which they were copied from. Additional features here
60		#' include:
61		#'
62		#' * Support for more than two treatment groups.
63		#' * Variance estimates are returned.
64		#'
65		#' @seealso [rbmi_analyse()]
66		#' @seealso [stats::lm()]
67		#' @seealso The set_vars() function from the rbmi package
68		#' @export
69		rbmi_ancova <- function(
70		data,
71		vars,
72		visits = NULL,
73		weights = c("counterfactual", "equal", "proportional_em", "proportional")
74		) {
75	4x	outcome <- vars[["outcome"]]
76	4x	group <- vars[["group"]]
77	4x	covariates <- vars[["covariates"]]
78	4x	visit <- vars[["visit"]]
79	4x	weights <- match.arg(weights)
80
81	4x	expected_vars <- c(
82	4x	utils::getFromNamespace("extract_covariates", "rbmi")(covariates),
83	4x	outcome,
84	4x	group
85		)
86
87	4x	if (is.null(visits)) {
88	1x	visits <- unique(data[[visit]])
89		}
90
91	4x	res <- lapply(
92	4x	visits,
93	4x	function(x) {
94	6x	data2 <- data[data[[visit]] == x, ]
95	6x	res <- rbmi_ancova_single(data2, outcome, group, covariates, weights)
96	6x	names(res) <- paste0(names(res), "_", x)
97	6x	return(res)
98		}
99		)
100	4x	return(unlist(res, recursive = FALSE))
101		}
102
103
104		#' Implements an Analysis of Covariance (ANCOVA)
105		#'
106		#' @description
107		#' Performance analysis of covariance. See [rbmi_ancova()] for full details.
108		#'
109		#' @param outcome string, the name of the outcome variable in `data`.
110		#' @param group string, the name of the group variable in `data`.
111		#' @param covariates character vector containing the name of any additional covariates
112		#' to be included in the model as well as any interaction terms.
113		#'
114		#' @inheritParams rbmi_ancova
115		#'
116		#' @details
117		#' - `group` must be a factor variable with only 2 levels.
118		#' - `outcome` must be a continuous numeric variable.
119		#' @export
120		#' @return a list containing `var` with variance estimates as well as
121		#' `trt_` and `lsm_` entries. See [rbmi_ancova()] for full details.
122		#' @examples
123		#'
124		#' iris2 <- iris[iris$Species %in% c("versicolor", "virginica"), ]
125		#' iris2$Species <- factor(iris2$Species)
126		#' rbmi_ancova_single(iris2, "Sepal.Length", "Species", c("Petal.Length * Petal.Width"))
127		#'
128		#'
129		#' @seealso [rbmi_ancova()]
130		rbmi_ancova_single <- function(
131		data,
132		outcome,
133		group,
134		covariates,
135		weights = c("counterfactual", "equal", "proportional_em", "proportional")
136		) {
137	7x	checkmate::assert_string(outcome)
138	7x	checkmate::assert_string(group)
139	7x	weights <- match.arg(weights)
140
141	7x	checkmate::assert_factor(data[[group]], n.levels = 2L)
142	7x	checkmate::assert_numeric(data[[outcome]])
143	7x	data2 <- data[, c(
144	7x	utils::getFromNamespace("extract_covariates", "rbmi")(covariates),
145	7x	outcome,
146	7x	group
147		)]
148
149	7x	frm <- utils::getFromNamespace("as_simple_formula", "rbmi")(
150	7x	outcome,
151	7x	c(group, covariates)
152		)
153
154	7x	mod <- stats::lm(formula = frm, data = data2)
155
156	7x	args <- list(model = mod, .weights = weights)
157
158	7x	grp_levels <- levels(data2[[group]])
159
160	7x	all_lsm <- lapply(
161	7x	grp_levels,
162	7x	\(x) {
163	14x	do.call(
164	14x	utils::getFromNamespace("lsmeans", "rbmi"),
165	14x	c(args, stats::setNames(x, group))
166		)
167		}
168		)
169	7x	names(all_lsm) <- paste0("lsm_", grp_levels)
170
171	7x	var_est <- summary(mod)$sigma^2
172	7x	var_df <- stats::df.residual(mod)
173
174	7x	all_trt <- lapply(
175	7x	paste0(group, grp_levels[-1]),
176	7x	\(x) {
177	7x	list(
178	7x	est = stats::coef(mod)[x],
179	7x	se = sqrt(stats::vcov(mod)[x, x]),
180	7x	df = var_df
181		)
182		}
183		)
184	7x	names(all_trt) <- paste0("trt_", grp_levels[-1])
185
186	7x	var_res <- list(
187	7x	var = list(
188	7x	est = var_est,
189		# Reference: Davison, Statistical Methods, p. 371 (just above 8.3.2)
190	7x	se = var_est / sqrt(var_df / 2),
191	7x	df = var_df
192		)
193		)
194
195	7x	c(var_res, all_trt, all_lsm)
196		}

1		#' Get default statistical methods and their associated formats, labels, and indent modifiers
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' @note These functions have been copied from the `tern` package file
6		#' `utils_default_stats_formats_labels.R` from GitHub development version 0.9.7.9017.
7		#' Slight modifications have been applied to enhance functionality:
8		#'
9		#' * `tern_get_stats` added the `tern_stats` argument to avoid hardcoding within the function's body.
10		#' * `tern_get_labels_from_stats` is more careful when receiving partial `labels_in`
11		#' and partial `label_attr_from_stats`.
12		#'
13		#' Once these features are included in the `tern` package, this file could be removed from
14		#' the `junco` package, and the functions could be used from the `tern` namespace directly.
15		#'
16		#' @name tern_default_stats_formats_labels
17		NULL
18
19
20		#' @keywords internal
21		.split_std_from_custom_stats <- function(stats_in) {
22	290x	out <- list(default_stats = NULL, custom_stats = NULL, all_stats = NULL)
23	290x	if (is.list(stats_in)) {
24	1x	is_custom_fnc <- sapply(stats_in, is.function)
25	1x	checkmate::assert_list(
26	1x	stats_in[is_custom_fnc],
27	1x	types = "function",
28	1x	names = "named"
29		)
30	1x	out[["custom_stats"]] <- stats_in[is_custom_fnc]
31	1x	out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc])
32	1x	all_stats <- names(stats_in) # to keep the order
33	1x	all_stats[!is_custom_fnc] <- out[["default_stats"]]
34	1x	out[["all_stats"]] <- all_stats
35		} else {
36	289x	out[["default_stats"]] <- out[["all_stats"]] <- stats_in
37		}
38	290x	out
39		}
40
41		#' @keywords internal
42		.apply_stat_functions <- function(
43		default_stat_fnc,
44		custom_stat_fnc_list,
45		args_list) {
46		# Default checks
47	294x	checkmate::assert_function(default_stat_fnc)
48	294x	checkmate::assert_list(
49	294x	custom_stat_fnc_list,
50	294x	types = "function",
51	294x	null.ok = TRUE,
52	294x	names = "named"
53		)
54	294x	checkmate::assert_list(args_list)
55
56		# Checking custom stats have same formals
57	294x	if (!is.null(custom_stat_fnc_list)) {
58	1x	fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]]
59	1x	for (fnc in custom_stat_fnc_list) {
60	1x	if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) {
61	!	stop(
62	!	"The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ",
63	!	"as the default statistical function. In this case your custom function has ",
64	!	names(formals(fnc))[[1]],
65	!	" as first parameter, while the default function has ",
66	!	fundamental_call_to_data,
67		"."
68		)
69		}
70	1x	if (!any(names(formals(fnc)) == "...")) {
71	!	stop(
72	!	"The custom statistical function needs to have `...` as a parameter to accept additional arguments. ",
73	!	"In this case your custom function does not have `...`."
74		)
75		}
76		}
77		}
78
79		# Applying
80	294x	out_default <- do.call(default_stat_fnc, args = args_list)
81	290x	out_custom <- lapply(
82	290x	custom_stat_fnc_list,
83	290x	function(fnc) do.call(fnc, args = args_list)
84		)
85
86		# Merging
87	290x	c(out_default, out_custom)
88		}
89
90		#' @describeIn tern_default_stats_formats_labels Get statistics available for a given method
91		#' group (analyze function).
92		#' @keywords internal
93		tern_get_stats <- function(
94		method_groups = "analyze_vars_numeric",
95		stats_in = NULL,
96		custom_stats_in = NULL,
97		add_pval = FALSE,
98		tern_defaults = tern_default_stats) {
99	1747x	checkmate::assert_character(method_groups)
100	1747x	checkmate::assert_character(stats_in, null.ok = TRUE)
101	1747x	checkmate::assert_character(custom_stats_in, null.ok = TRUE)
102	1747x	checkmate::assert_flag(add_pval)
103
104		# Default is still numeric
105	1747x	if (any(method_groups == "analyze_vars")) {
106	3x	method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"
107		}
108
109	1747x	type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks
110
111		# Defaults for loop
112	1747x	out <- NULL
113
114		# Loop for multiple method groups
115	1747x	for (mgi in method_groups) {
116	1748x	if (mgi %in% names(tern_defaults)) {
117	1747x	out_tmp <- tern_defaults[[mgi]]
118		} else {
119	1x	stop(
120	1x	"The selected method group (",
121	1x	mgi,
122	1x	") has no default statistical method."
123		)
124		}
125	1747x	out <- unique(c(out, out_tmp))
126		}
127
128		# Add custom stats
129	1746x	out <- c(out, custom_stats_in)
130
131		# If you added pval to the stats_in you certainly want it
132	1746x	if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
133	34x	stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
134
135		# Must be only one value between choices
136	34x	checkmate::assert_choice(
137	34x	stats_in_pval_value,
138	34x	c("pval", "pval_counts", "pvalue")
139		)
140
141		# Mismatch with counts and numeric
142		if (
143	33x	any(grepl("counts", method_groups)) &&
144	33x	stats_in_pval_value != "pval_counts" \|\|
145	33x	any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval"
146		) {
147		# nolint
148	2x	stop(
149	2x	"Inserted p-value (",
150	2x	stats_in_pval_value,
151	2x	") is not valid for type ",
152	2x	type_tmp,
153	2x	". Use ",
154	2x	paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),
155	2x	" instead."
156		)
157		}
158
159		# Lets add it even if present (thanks to unique)
160	31x	add_pval <- TRUE
161		}
162
163		# Mainly used in "analyze_vars" but it could be necessary elsewhere
164	1743x	if (isTRUE(add_pval)) {
165	34x	if (any(grepl("counts", method_groups))) {
166	1x	out <- unique(c(out, "pval_counts"))
167		} else {
168	33x	out <- unique(c(out, "pval"))
169		}
170		}
171
172		# Filtering for stats_in (character vector)
173	1743x	if (!is.null(stats_in)) {
174	908x	out <- intersect(stats_in, out) # It orders them too
175		}
176
177		# If intersect did not find matches (and no pval?) -> error
178	1743x	if (length(out) == 0) {
179	2x	stop(
180	2x	"The selected method group(s) (",
181	2x	paste0(method_groups, collapse = ", "),
182		")",
183	2x	" do not have the required default statistical methods:\n",
184	2x	paste0(stats_in, collapse = " ")
185		)
186		}
187
188	1741x	out
189		}
190
191		#' @describeIn tern_default_stats_formats_labels Get formats corresponding to a list of statistics.
192		#' @keywords internal
193		tern_get_formats_from_stats <- function(
194		stats,
195		formats_in = NULL,
196		levels_per_stats = NULL,
197		tern_defaults = tern_default_formats) {
198	1051x	checkmate::assert_character(stats, min.len = 1)
199		# It may be a list if there is a function in the formats
200	1051x	if (checkmate::test_list(formats_in, null.ok = TRUE)) {
201	1043x	checkmate::assert_list(formats_in, null.ok = TRUE)
202		# Or it may be a vector of characters
203		} else {
204	8x	checkmate::assert_character(formats_in, null.ok = TRUE)
205		}
206	1051x	checkmate::assert_list(levels_per_stats, null.ok = TRUE)
207
208		# If unnamed formats given as formats_in and same number of stats, use one format per stat
209		if (
210	1051x	!is.null(formats_in) &&
211	1051x	length(formats_in) == length(stats) &&
212	1051x	is.null(names(formats_in)) &&
213	1051x	is.null(levels_per_stats)
214		) {
215	3x	out <- as.list(formats_in) \|> stats::setNames(stats)
216	3x	return(out)
217		}
218
219		# If levels_per_stats not given, assume one row per statistic
220	356x	if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) \|> stats::setNames(stats)
221
222		# Apply custom formats
223	1048x	out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults)
224
225		# Default to NULL if no format
226	1048x	case_input_is_not_stat <- unlist(out, use.names = FALSE) == unlist(levels_per_stats, use.names = FALSE)
227	1048x	out[names(out) == out \| case_input_is_not_stat] <- list(NULL)
228
229	1048x	out
230		}
231
232		#' @describeIn tern_default_stats_formats_labels Get labels corresponding to a list of statistics.
233		#' @keywords internal
234		tern_get_labels_from_stats <- function(
235		stats,
236		labels_in = NULL,
237		levels_per_stats = NULL,
238		label_attr_from_stats = NULL,
239		tern_defaults = tern_default_labels) {
240	1115x	checkmate::assert_character(stats, min.len = 1)
241
242		# Modification:
243		# If any label_attr_from_stats is available and valid, save in labels_in
244		# if not specified there already (so don't overwrite labels_in).
245	1115x	if (!is.null(label_attr_from_stats)) {
246	344x	valid_label_attr_from_stats <- label_attr_from_stats[
247	344x	nzchar(label_attr_from_stats) &
248	344x	!sapply(label_attr_from_stats, is.null) &
249	344x	!is.na(label_attr_from_stats)
250		]
251	344x	if (length(valid_label_attr_from_stats)) {
252	316x	do_save <- setdiff(
253	316x	names(valid_label_attr_from_stats),
254	316x	names(labels_in)
255		)
256	316x	labels_in <- c(labels_in, valid_label_attr_from_stats[do_save])
257		}
258		}
259
260		# It may be a list
261	1115x	if (checkmate::test_list(labels_in, null.ok = TRUE)) {
262	845x	checkmate::assert_list(labels_in, null.ok = TRUE)
263		# Or it may be a vector of characters
264		} else {
265	270x	checkmate::assert_character(labels_in, null.ok = TRUE)
266		}
267	1115x	checkmate::assert_list(levels_per_stats, null.ok = TRUE)
268
269		# If unnamed labels given as labels_in and same number of stats, use one label per stat
270		if (
271	1115x	!is.null(labels_in) &&
272	1115x	length(labels_in) == length(stats) &&
273	1115x	is.null(names(labels_in)) &&
274	1115x	is.null(levels_per_stats)
275		) {
276	!	out <- as.list(labels_in) \|> stats::setNames(stats)
277	!	return(out)
278		}
279
280		# If levels_per_stats not given, assume one row per statistic
281	352x	if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) \|> stats::setNames(stats)
282
283		# Apply custom labels
284	1115x	out <- .fill_in_vals_by_stats(levels_per_stats, labels_in, tern_defaults)
285	1115x	out
286		}
287
288		# Function to loop over each stat and levels to set correct values
289		.fill_in_vals_by_stats <- function(levels_per_stats, user_in, tern_defaults) {
290	3171x	out <- list()
291
292	3171x	levels_per_stats_list <- NULL
293	3171x	for (stat_i in names(levels_per_stats)) {
294		# Get all levels of the statistic
295	7344x	all_lvls <- levels_per_stats[[stat_i]]
296
297	7344x	if ((length(all_lvls) == 1 && all_lvls == stat_i) \|\| is.null(all_lvls)) {
298		# One row per statistic
299	4641x	out[[stat_i]] <- if (stat_i %in% names(user_in)) {
300		# 1. Check for stat_i in user input
301	1519x	user_in[[stat_i]]
302	4641x	} else if (stat_i %in% names(tern_defaults)) {
303		# 2. Check for stat_i in tern defaults
304	2941x	tern_defaults[[stat_i]]
305		} else {
306		# 3. Otherwise stat_i
307	181x	stat_i
308		}
309	4641x	levels_per_stats_list <- c(levels_per_stats_list, stat_i)
310		} else {
311		# One row per combination of variable level and statistic
312		# Loop over levels for each statistic
313	2703x	for (lev_i in all_lvls) {
314		# Construct row name (stat_i.lev_i)
315	9047x	row_nm <- paste(stat_i, lev_i, sep = ".")
316
317	9047x	out[[row_nm]] <- if (row_nm %in% names(user_in)) {
318		# 1. Check for stat_i.lev_i in user input
319	1x	user_in[[row_nm]]
320	9047x	} else if (lev_i %in% names(user_in)) {
321		# 2. Check for lev_i in user input
322	626x	user_in[[lev_i]]
323	9047x	} else if (stat_i %in% names(user_in)) {
324		# 3. Check for stat_i in user input
325	1x	user_in[[stat_i]]
326	9047x	} else if (lev_i %in% names(tern_defaults)) {
327		# 4. Check for lev_i in tern defaults (only used for labels)
328	1200x	tern_defaults[[lev_i]]
329	9047x	} else if (stat_i %in% names(tern_defaults)) {
330		# 5. Check for stat_i in tern defaults
331	4786x	tern_defaults[[stat_i]]
332		} else {
333		# 6. Otherwise lev_i
334	2433x	lev_i
335		}
336	9047x	levels_per_stats_list <- c(levels_per_stats_list, row_nm)
337		}
338		}
339		}
340
341	3171x	if (any(duplicated(levels_per_stats_list))) {
342		# this is to cover the same stat more than once
343		# in risk diff column more than one stat transformed into same riskdiff stat
344	72x	out <- out[levels_per_stats_list]
345		}
346
347	3171x	out
348		}
349
350		#' @describeIn tern_default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.
351		#' @keywords internal
352		tern_get_indents_from_stats <- function(stats,
353		indents_in = NULL,
354		levels_per_stats = NULL,
355		tern_defaults = as.list(rep(0L, length(stats))) \|> stats::setNames(stats)) {
356	1028x	checkmate::assert_character(stats, min.len = 1)
357		# It may be a list
358	1028x	if (checkmate::test_list(indents_in, null.ok = TRUE)) {
359	990x	checkmate::assert_list(indents_in, null.ok = TRUE)
360		# Or it may be a vector of integers
361		} else {
362	38x	checkmate::assert_integerish(indents_in, null.ok = TRUE)
363		}
364	1028x	checkmate::assert_list(levels_per_stats, null.ok = TRUE)
365
366		# If levels_per_stats not given, assume one row per statistic
367	348x	if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) \|> stats::setNames(stats)
368
369		# Single indentation level for all rows
370	1028x	if (is.null(names(indents_in)) && length(indents_in) == 1) {
371	20x	out <- rep(indents_in, length(levels_per_stats \|> unlist()))
372	20x	return(out)
373		}
374
375		# Apply custom indentation
376	1008x	out <- .fill_in_vals_by_stats(levels_per_stats, indents_in, tern_defaults)
377	1008x	out
378		}
379
380		# tern_default_labels ----
381
382		#' @describeIn tern_default_stats_formats_labels Named `character` vector of default labels for `tern`.
383		#' This is only copied here from the latest GitHub version, because otherwise a tern test fails.
384		#'
385		#' @keywords internal
386		tern_default_labels <- c(
387		cv = "CV (%)",
388		iqr = "IQR",
389		geom_cv = "CV % Geometric Mean",
390		geom_mean = "Geometric Mean",
391		geom_mean_sd = "Geometric Mean (SD)",
392		geom_mean_ci = "Geometric Mean 95% CI",
393		geom_mean_ci_3d = "Geometric Mean (95% CI)",
394		geom_sd = "Geometric SD",
395		mad = "Median Absolute Deviation",
396		max = "Maximum",
397		mean = "Mean",
398		mean_ci = "Mean 95% CI",
399		mean_ci_3d = "Mean (95% CI)",
400		mean_pval = "Mean p-value (H0: mean = 0)",
401		mean_sd = "Mean (SD)",
402		mean_sdi = "Mean -/+ 1xSD",
403		mean_se = "Mean (SE)",
404		mean_sei = "Mean -/+ 1xSE",
405		median = "Median",
406		median_ci = "Median 95% CI",
407		median_ci_3d = "Median (95% CI)",
408		median_range = "Median (Min - Max)",
409		min = "Minimum",
410		n = "n",
411		n_blq = "n_blq",
412		nonunique = "Number of events",
413		pval = "p-value (t-test)", # Default for numeric
414		pval_counts = "p-value (chi-squared test)", # Default for counts
415		quantiles = "25% and 75%-ile",
416		quantiles_lower = "25%-ile (95% CI)",
417		quantiles_upper = "75%-ile (95% CI)",
418		range = "Min - Max",
419		range_censor = "Range (censored)",
420		range_event = "Range (event)",
421		rate = "Adjusted Rate",
422		rate_ratio = "Adjusted Rate Ratio",
423		sd = "SD",
424		se = "SE",
425		sum = "Sum",
426		unique = "Number of patients with at least one event"
427		)
428
429
430		# utility function to get labels from x_stats label attribute (or name if no label present)
431		#' @keywords internal
432		junco_get_labels_from_attrib <- function(.stats, .labels, x_stats) {
433	114x	.labels_out <- unlist(junco_get_labels_from_stats(.stats, .labels, setNames(as.list(.stats), .stats)))
434	114x	.labels_out <- .labels_out[.stats]
435
436	114x	if (!all(names(x_stats) %in% .stats)) {
437		# assumption: incoming x_stats has .stats in inner list
438		# key assumption, all inner lists have same structure
439	114x	inner_names <- unique(lapply(x_stats, names))
440	114x	if (length(inner_names) > 1 \|\| !(all(inner_names[[1]] %in% .stats))) {
441	!	stop("incorrect .stats/x_stats structure assumption")
442		}
443		# now we can more safely take the first element to retrieve labels
444	114x	nms_stats_pre <- x_stats[[1]]
445		} else {
446	!	nms_stats_pre <- x_stats
447		}
448
449	114x	nms_stats <- vapply(seq_along(nms_stats_pre), function(i) {
450	317x	el <- nms_stats_pre[[i]]
451	317x	attr(el, "label") %\|\|% names(nms_stats_pre)[i]
452	114x	}, character(1))
453
454	114x	names(nms_stats) <- .stats
455
456	114x	.labels_out[.labels_out == .stats] <- nms_stats[.labels_out == .stats]
457
458	114x	.labels_out
459		}

1		#' @title Safe Wrapper for `stats::t.test()`
2		#'
3		#' @noRd
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' A robust wrapper around [stats::t.test()] that prevents errors from
8		#' interrupting execution.
9		#'
10		#' Instead of failing, the function returns an object of class `"htest"`
11		#' containing `NA` values for inferential statistics together with the computed
12		#' sample mean(s) and an informative error message embedded in the `method`
13		#' field.
14		#'
15		#' This is particularly useful in pipelines, simulations, or batch analyses
16		#' where occasional invalid inputs (e.g., constant vectors or insufficient
17		#' observations) would otherwise stop execution.
18		#'
19		#' @details
20		#' Inputs `x` and `y` must be numeric vectors containing only finite,
21		#' non-missing values. In particular, `NA`, `NaN`, `Inf`, and `-Inf` values are
22		#' not allowed and will trigger an error before [stats::t.test()] is evaluated.
23		#'
24		#' When [stats::t.test()] succeeds, the resulting `"htest"` object is returned
25		#' unchanged except that `data.name` is reconstructed from the original
26		#' expressions supplied to `x` and `y`.
27		#'
28		#' When an error occurs, the function returns an object of class `"htest"` with:
29		#'
30		#' \itemize{
31		#' \item `NA_real` values for `statistic`, `parameter`, `p.value`, `stderr`,
32		#' and `conf.int`
33		#' \item computed sample mean(s) stored in `estimate`
34		#' \item the original null hypothesis value stored in `null.value`
35		#' \item the original test type and error message appended to `method`.
36		#' }
37		#'
38		#' @inheritParams stats::t.test
39		#' @param x (`numeric`)\cr A numeric vector containing only finite, non-missing
40		#' values.
41		#' @param y (`numeric`)\cr An optional numeric vector containing only finite,
42		#' non-missing values.
43		#'
44		#' @return
45		#' An object of class `"htest"`.
46		#'
47		#' If [stats::t.test()] succeeds, the standard `"htest"` object is returned.
48		#' If an error occurs, an `"htest"` object with `NA` inferential statistics and
49		#' computed sample mean(s) in `estimate` is returned instead.
50		#'
51		#' @author WW
52		#'
53		#' @importFrom stats t.test
54		#'
55		#' @examples
56		#' # Standard usage
57		#' x <- 1:10
58		#' y <- 11:20
59		#'
60		#' t.test(x, y)
61		#' safe_t_test(x, y)
62		#'
63		#' # Paired test with constant differences
64		#' x <- rep(10, 5)
65		#'
66		#' t.test(x, x, paired = TRUE)
67		#' safe_t_test(x, x, paired = TRUE)
68		#'
69		#' # Example triggering an error (constant data)
70		#' t.test(x, x)
71		#' safe_t_test(x, x)
72		safe_t_test <- function(
73		x,
74		y = NULL,
75		alternative = c("two.sided", "less", "greater"),
76		mu = 0,
77		paired = FALSE,
78		var.equal = FALSE,
79		conf.level = 0.95,
80		...
81		) {
82	188x	x_expr <- substitute(x)
83	188x	y_expr <- substitute(y)
84	188x	alternative <- match.arg(alternative)
85
86	188x	checkmate::assert_numeric(x, any.missing = FALSE, finite = TRUE)
87	173x	if (paired) {
88	20x	checkmate::assert_numeric(y, finite = TRUE, any.missing = FALSE, len = length(x))
89		} else {
90	153x	checkmate::assert_numeric(y, finite = TRUE, any.missing = FALSE, null.ok = TRUE)
91		}
92	171x	checkmate::assert_choice(alternative, choices = c("two.sided", "less", "greater"))
93	171x	checkmate::assert_number(mu, finite = TRUE)
94	171x	checkmate::assert_flag(paired)
95	171x	checkmate::assert_flag(var.equal)
96	171x	checkmate::assert_number(conf.level, lower = 0, upper = 1, finite = TRUE)
97
98	171x	tryCatch(
99		{
100	171x	res <- stats::t.test(
101	171x	x = x,
102	171x	y = y,
103	171x	alternative = alternative,
104	171x	mu = mu,
105	171x	paired = paired,
106	171x	var.equal = var.equal,
107	171x	conf.level = conf.level,
108		...
109		)
110
111	146x	res$data.name <- if (is.null(y)) {
112	5x	deparse1(x_expr)
113		} else {
114	141x	paste(deparse1(x_expr), "and", deparse1(y_expr))
115		}
116
117	146x	res
118		},
119	171x	error = function(e) {
120	25x	if (paired) {
121	5x	x <- x - y
122	5x	y <- NULL
123		}
124
125	25x	if (is.null(y)) {
126	6x	estimate <- mean(x)
127	6x	dname <- deparse1(x_expr)
128	6x	method <- ifelse(paired, "Paired t-test", "One Sample t-test")
129	6x	names(estimate) <- ifelse(paired, "mean difference", "mean of x")
130		} else {
131	19x	estimate <- c(mean(x), mean(y))
132	19x	dname <- paste(deparse1(x_expr), "and", deparse1(y_expr))
133	19x	method <- paste(if (!var.equal) "Welch", "Two Sample t-test")
134	19x	names(estimate) <- c("mean of x", "mean of y")
135		}
136	25x	estimate[is.nan(estimate)] <- NA_real_
137
138	25x	names(mu) <- if (paired) {
139	5x	"mean difference"
140	25x	} else if (!is.null(y)) {
141	19x	"difference in means"
142		} else {
143	1x	"mean"
144		}
145
146	25x	out <- list(
147	25x	statistic = setNames(NA_real_, "t"),
148	25x	parameter = setNames(NA_real_, "df"),
149	25x	p.value = NA_real_,
150	25x	conf.int = c(NA_real_, NA_real_),
151	25x	estimate = estimate,
152	25x	null.value = mu,
153	25x	stderr = NA_real_,
154	25x	alternative = alternative,
155	25x	method = paste0(method, " (failed: ", e$message, ")"),
156	25x	data.name = dname
157		)
158	25x	attr(out$conf.int, "conf.level") <- conf.level
159
160	25x	class(out) <- "htest"
161	25x	out
162		}
163		)
164		}

1		#' @name a_freq_combos_j
2		#'
3		#' @title Analysis function count and percentage in column design controlled by combosdf
4		#'
5		#' @inheritParams proposal_argument_convention
6		#' @inheritParams a_freq_j
7		#'
8		#' @param combosdf The df which provides the mapping of column facets to produce cumulative counts for .N_col.\cr
9		#' In the cell facet, these cumulative records must then be removed from the numerator,
10		#' which can be done via the filter_var parameter
11		#' to avoid unwanted counting of events.
12		#' @param do_not_filter A vector of facets (i.e., column headers), identifying headers for which
13		#' no filtering of records should occur.
14		#' That is, the numerator should contain cumulative counts. Generally, this will be used for a
15		#' "Total" column, or something similar.
16		#' @param filter_var The variable which identifies the records to count in the numerator for any given column.
17		#' Generally, this will contain text matching the column header for the column associated with a given record.
18		#' @param flag_var Variable which identifies the occurrence (or first occurrence) of an event.
19		#' The flag variable is expected to have a value of "Y" identifying that the event should be counted, or NA otherwise.
20		#' @param denom (`string`)\cr
21		#' One of \cr
22		#' \itemize{
23		#' \item \strong{N_col} Column count, \cr
24		#' \item \strong{n_df} Number of patients (based upon the main input dataframe `df`),\cr
25		#' \item \strong{n_altdf} Number of patients from the secondary dataframe (`.alt_df_full`),\cr
26		#' Note that argument `denom_by` will perform a row-split on the `.alt_df_full` dataframe.\cr
27		#' It is a requirement that variables specified in `denom_by` are part of the row split specifications. \cr
28		#' \item \strong{n_rowdf} Number of patients from the current row-level dataframe
29		#' (`.row_df` from the rtables splitting machinery).\cr
30		#' \item \strong{n_parentdf} Number of patients from a higher row-level split than the current split.\cr
31		#' This higher row-level split is specified in the argument `denom_by`.\cr
32		#' }
33		#' @param .formats (named 'character' or 'list')\cr
34		#' formats for the statistics.
35		#' @seealso [a_freq_j()] for extensive `label_map` usage examples.
36		#' @return list of requested statistics with formatted `rtables::CellValue()`.\cr
37		#'
38		#' @examples
39		#' library(dplyr)
40		#' ADSL <- ex_adsl \|> select(USUBJID, ARM, EOSSTT, EOSDT, EOSDY, TRTSDTM)
41		#'
42		#' cutoffd <- as.Date("2023-09-24")
43		#'
44		#' ADSL <- ADSL \|>
45		#' mutate(
46		#' TRTDURY = case_when(
47		#' !is.na(EOSDY) ~ EOSDY,
48		#' TRUE ~ as.integer(cutoffd - as.Date(TRTSDTM) + 1)
49		#' )
50		#' ) \|>
51		#' mutate(ACAT1 = case_when(
52		#' TRTDURY < 183 ~ "0-6 Months",
53		#' TRTDURY < 366 ~ "6-12 Months",
54		#' TRUE ~ "+12 Months"
55		#' )) \|>
56		#' mutate(ACAT1 = factor(ACAT1, levels = c("0-6 Months", "6-12 Months", "+12 Months")))
57		#'
58		#'
59		#' ADAE <- ex_adae \|> select(USUBJID, ARM, AEBODSYS, AEDECOD, ASTDY)
60		#'
61		#' ADAE <- ADAE \|>
62		#' mutate(TRTEMFL = "Y") \|>
63		#' mutate(ACAT1 = case_when(
64		#' ASTDY < 183 ~ "0-6 Months",
65		#' ASTDY < 366 ~ "6-12 Months",
66		#' TRUE ~ "+12 Months"
67		#' )) \|>
68		#' mutate(ACAT1 = factor(ACAT1, levels = c("0-6 Months", "6-12 Months", "+12 Months")))
69		#'
70		#' combodf <- tribble(
71		#' ~valname, ~label, ~levelcombo, ~exargs,
72		#' "Tot", "Total", c("0-6 Months", "6-12 Months", "+12 Months"), list(),
73		#' "A_0-6 Months", "0-6 Months", c("0-6 Months", "6-12 Months", "+12 Months"), list(),
74		#' "B_6-12 Months", "6-12 Months", c("6-12 Months", "+12 Months"), list(),
75		#' "C_+12 Months", "+12 Months", c("+12 Months"), list()
76		#' )
77		#'
78		#'
79		#' lyt <- basic_table(show_colcounts = TRUE) \|>
80		#' split_cols_by("ARM") \|>
81		#' split_cols_by("ACAT1",
82		#' split_fun = rtables::add_combo_levels(
83		#' combosdf = combodf,
84		#' trim = FALSE, keep_levels = combodf$valname
85		#' )
86		#' ) \|>
87		#' analyze("TRTEMFL",
88		#' show_labels = "hidden",
89		#' afun = a_freq_combos_j,
90		#' extra_args = list(
91		#' val = "Y",
92		#' label = "Subjects with >= 1 AE",
93		#' combosdf = combodf,
94		#' filter_var = "ACAT1",
95		#' do_not_filter = "Tot"
96		#' )
97		#' )
98		#'
99		#'
100		#' result <- build_table(lyt, df = ADAE, alt_counts_df = ADSL)
101		#'
102		#' result
103		#' @export
104		a_freq_combos_j <- function(
105		df,
106		labelstr = NULL,
107		.var = NA,
108		val = NULL,
109		# arguments specific to a_freq_combos_j
110		combosdf = NULL,
111		do_not_filter = NULL,
112		filter_var = NULL,
113		flag_var = NULL,
114		# arguments specific to a_freq_combos_j till here
115		.df_row,
116		.spl_context,
117		.N_col,
118		id = "USUBJID",
119		denom = c("N_col", "n_df", "n_altdf", "n_rowdf", "n_parentdf"),
120		label = NULL,
121		label_fstr = NULL,
122		label_map = NULL,
123		.alt_df_full = NULL,
124		denom_by = NULL,
125		.stats = "count_unique_denom_fraction",
126		.formats = NULL,
127		.labels_n = NULL,
128		.indent_mods = NULL,
129		na_str = rep("NA", 3)
130		) {
131	12x	denom <- match.arg(denom)
132
133	12x	check_alt_df_full(denom, "n_altdf", .alt_df_full)
134
135	12x	if (!is.null(combosdf) && !all(c("valname", "label") %in% names(combosdf))) {
136	!	stop("a_freq_combos_j: combosdf must have variables valname and label.")
137		}
138
139	12x	res_dataprep <- h_a_freq_dataprep(
140	12x	df = df,
141	12x	labelstr = labelstr,
142	12x	.var = .var,
143	12x	val = val,
144	12x	drop_levels = FALSE,
145	12x	excl_levels = NULL,
146	12x	new_levels = NULL,
147	12x	new_levels_after = FALSE,
148	12x	.df_row = .df_row,
149	12x	.spl_context = .spl_context,
150	12x	.N_col = .N_col,
151	12x	id = id,
152	12x	denom = denom,
153	12x	variables = NULL,
154	12x	label = label,
155	12x	label_fstr = label_fstr,
156	12x	label_map = label_map,
157	12x	.alt_df_full = .alt_df_full,
158	12x	denom_by = denom_by,
159	12x	.stats = .stats
160		)
161		# res_dataprep is list with elements
162		# df .df_row val
163		# drop_levels excl_levels
164		# alt_df parentdf new_denomdf
165		# .stats
166		# make these elements available in current environment
167	12x	df <- res_dataprep$df
168	12x	.df_row <- res_dataprep$.df_row
169	12x	val <- res_dataprep$val
170	12x	drop_levels <- res_dataprep$drop_levels
171	12x	excl_levels <- res_dataprep$excl_levels
172	12x	alt_df <- res_dataprep$alt_df
173	12x	parentdf <- res_dataprep$parentdf
174	12x	new_denomdf <- res_dataprep$new_denomdf
175	12x	.stats <- res_dataprep$.stats
176
177		## colid can be used to figure out if we're in the combo column or not
178	12x	colid <- .spl_context$cur_col_id[[1]]
179
180		### this is the core code for subsetting to appropriate combo level
181	12x	df <- h_subset_combo(
182	12x	df = df,
183	12x	combosdf = combosdf,
184	12x	do_not_filter = do_not_filter,
185	12x	filter_var = filter_var,
186	12x	flag_var = flag_var,
187	12x	colid = colid
188		)
189
190		## the same s-function can be used as in a_freq_j
191	12x	x_stats <- s_freq_j(
192	12x	df,
193	12x	.var = .var,
194	12x	.df_row = .df_row,
195	12x	val = val,
196	12x	alt_df = new_denomdf,
197	12x	parent_df = new_denomdf,
198	12x	id = id,
199	12x	denom = denom,
200	12x	.N_col = .N_col,
201	12x	countsource = "df"
202		)
203
204	12x	.stats_adj <- .stats
205
206	12x	res_prepinrows <- h_a_freq_prepinrows(
207	12x	x_stats,
208	12x	.stats_adj,
209	12x	.formats,
210	12x	labelstr,
211	12x	label_fstr,
212	12x	label,
213	12x	.indent_mods,
214	12x	.labels_n,
215	12x	na_str
216		)
217		# res_prepinrows is list with elements
218		# x_stats .formats .labels .indent_mods .format_na_strs
219		# make these elements available in current environment
220	12x	x_stats <- res_prepinrows$x_stats
221	12x	.formats <- res_prepinrows$.formats
222	12x	.labels <- res_prepinrows$.labels
223	12x	.indent_mods <- res_prepinrows$.indent_mods
224	12x	.format_na_strs <- res_prepinrows$.format_na_strs
225
226		### final step: turn requested stats into rtables rows
227	12x	in_rows(
228	12x	.list = x_stats,
229	12x	.formats = .formats,
230	12x	.labels = .labels,
231	12x	.indent_mods = .indent_mods,
232	12x	.format_na_strs = .format_na_strs
233		)
234		}

1		#' Analysis Function for Response Variables
2		#'
3		#' This function calculates counts and percentages for response variables (Y/N values),
4		#' with optional risk difference calculations.
5		#'
6		#' @param df (`data.frame`)\cr data set containing all analysis variables.
7		#' @param .var (`string`)\cr variable name that is passed by `rtables`.
8		#' @param .df_row (`data.frame`)\cr data frame across all of the columns for the given row split.
9		#' @param .N_col (`integer`)\cr column-wise N (column count) for the full column being analyzed.
10		#' @param .spl_context (`data.frame`)\cr gives information about ancestor split states.
11		#' @param resp_var (`string`)\cr response variable name containing Y/N values.
12		#' @param id (`string`)\cr subject variable name.
13		#' @param drop_levels (`logical`)\cr if TRUE, non-observed levels will not be included.
14		#' @param riskdiff (`logical`)\cr if TRUE, risk difference calculations will be performed.
15		#' @param ref_path (`string`)\cr column path specifications for the control group.
16		#' @param variables (`list`)\cr variables to include in the analysis.
17		#' @param conf_level (`proportion`)\cr confidence level of the interval.
18		#' @param method (`character`)\cr method for calculating confidence intervals.
19		#' @param weights_method (`character`)\cr method for calculating weights.
20		#' @param .formats (`character` or NULL)\cr formats to apply to the statistics. If NULL, default formats will be used.
21		#' @param na_str (`character`)\cr string to use for NA values. Defaults to `rep("NA", 3)`.
22		#' @param legacy (`logical(1)`)\cr To allow for backward compatibility default of used format.
23		#' @return Formatted analysis function which is used as `afun` in `analyze_vars()`
24		#' and as `cfun` in `summarize_row_groups()`.
25		#'
26		#' @export
27		#'
28		#' @examples
29		#' library(dplyr)
30		#' ADSL <- ex_adsl \|> select(USUBJID, ARM, SEX)
31		#'
32		#' ADAE <- ex_adae \|> select(USUBJID, ARM, SEX, AEBODSYS, AEDECOD)
33		#'
34		#' ADAE <- ADAE \|>
35		#' mutate(TRTEMFL = "Y")
36		#'
37		#' lyt <- basic_table(show_colcounts = TRUE) \|>
38		#' split_cols_by("ARM") \|>
39		#' analyze("SEX",
40		#' show_labels = "visible",
41		#' afun = a_freq_resp_var_j,
42		#' extra_args = list(resp_var = "TRTEMFL", riskdiff = FALSE)
43		#' )
44		#'
45		#' result <- build_table(lyt, df = ADAE, alt_counts_df = ADSL)
46		#'
47		#' result
48		a_freq_resp_var_j <- function(
49		df,
50		.var,
51		.df_row,
52		.N_col,
53		.spl_context,
54		resp_var = NULL,
55		id = "USUBJID",
56		drop_levels = FALSE,
57		riskdiff = TRUE,
58		ref_path = NULL,
59		variables = list(strata = NULL),
60		conf_level = formals(s_proportion_diff)$conf_level,
61		method = c(
62		"wald",
63		"waldcc",
64		"cmh",
65		"ha",
66		"newcombe",
67		"newcombecc",
68		"strat_newcombe",
69		"strat_newcombecc",
70		"cmh_sato",
71		"cmh_mn",
72		"uncond_exact_diff"
73		),
74		weights_method = formals(s_proportion_diff)$weights_method,
75		.formats = NULL,
76		na_str = rep("NA", 3),
77		legacy = FALSE
78		) {
79		# ---- Derive statistics: xx / xx (xx.x%)
80
81	24x	if (is.null(resp_var)) {
82	1x	stop(
83	1x	"afun a_freq_resp_var_j: resp_var cannot be NULL."
84		)
85		}
86
87	23x	resp_var_values <- unique(df[[resp_var]][!is.na(df[[resp_var]])])
88		if (
89	23x	is.character(df[[resp_var]]) &&
90	23x	any(is.na(df[[resp_var]])) &&
91	23x	all(resp_var_values == "Y")
92		) {
93	!	stop(
94	!	paste0(
95	!	"afun a_freq_resp_var_j: it is not clear if missing resp_var should be considered non-response. ",
96	!	"Please make it a factor with appropriate Y(/N) levels."
97		)
98		)
99		}
100
101	23x	if (length(setdiff(resp_var_values, c("Y", "N"))) > 0) {
102	1x	stop("afun a_freq_resp_var_j: resp_var must contain only Y/N values.")
103		}
104
105	22x	if (is.character(df[[resp_var]])) {
106	19x	df[[resp_var]] <- factor(df[[resp_var]], levels = c("Y", "N"))
107		}
108
109	22x	df <- df[!is.na(df[[.var]]), ]
110
111		# nolint start
112	22x	if ((is.factor(df[[resp_var]]) &&
113	22x	(identical(levels(df[[resp_var]]), c("Y", "N")) \|\| identical(levels(df[[resp_var]]), c("N", "Y")))) \|\|
114	22x	is.character(df[[resp_var]])
115		) { # nolint end
116		# missing values in resp_var should be excluded, not considered as not met response
117		# subject will then not contribute to denominator
118	22x	df <- df[!is.na(df[[resp_var]]), ]
119	22x	.df_row <- .df_row[!is.na(.df_row[[resp_var]]), ]
120		}
121
122	22x	if (drop_levels) {
123	13x	obs_levs <- unique(.df_row[[.var]])
124	13x	obs_levs <- intersect(levels(.df_row[[.var]]), obs_levs)
125
126	13x	val_var <- obs_levs
127		# restrict the levels to the ones specified in val_var
128	13x	df <- df[df[[.var]] %in% val_var, ]
129	13x	.df_row <- .df_row[.df_row[[.var]] %in% val_var, ]
130
131	13x	df <- h_update_factor(df, .var, val_var)
132		}
133
134	22x	varvec <- df[[.var]]
135
136	22x	levs <- if (is.factor(varvec)) levels(varvec) else sort(unique(varvec))
137
138	22x	colid <- .spl_context$cur_col_id[[1]]
139	22x	inriskdiffcol <- grepl("difference", tolower(colid), fixed = TRUE)
140
141	22x	if (riskdiff) {
142	10x	trt_var <- ref_path[length(ref_path) - 1L]
143	10x	ctrl_grp <- ref_path[length(ref_path)]
144	10x	cur_trt_grp <- h_get_cur_trt_grp(trt_var, .spl_context)
145		}
146
147	22x	fn <- function(levii) {
148	82x	dfii <- df[df[[.var]] == levii, ]
149	82x	dfrowii <- .df_row[.df_row[[.var]] == levii, ]
150
151	82x	if (!inriskdiffcol) {
152		# use the core s_freq_j function on the current level of the incoming variable (.var)
153		# note that the response variable will become .var in the below call
154		# val is restricted to Y to show number of response on the current level of .var
155	70x	rslt <- s_freq_j(
156	70x	dfii,
157	70x	.df_row = dfrowii,
158	70x	.var = resp_var,
159	70x	alt_df = NULL,
160	70x	parent_df = NULL,
161	70x	val = "Y",
162	70x	denom = "n_df"
163		)
164
165	70x	.stat <- "count_unique_denom_fraction"
166	70x	x_stat <- rslt[[.stat]]$Y
167		# use .formats if provided, otherwise default to jjcsformat_count_denom_fraction
168	70x	if (!legacy) {
169	70x	fmt <- if (is.null(.formats)) jjcsformat_count_denom_fraction else .formats
170		} else {
171	!	fmt <- if (is.null(.formats)) jjcsformat_count_denom_fraction_legacy else .formats
172		}
173
174	70x	rslt <- rcell(x_stat, format = fmt)
175		} else {
176		# use the risk difference function s_risk_diff_val_j on the current level of the incoming variable (.var)
177		# note that the response variable will become .var in the below call
178		# val is restricted to Y to show number of response on the current level of .var
179	12x	denom_df <- dfrowii
180		# for combined facet, denom_df value for the treatment group needs update
181	12x	denom_df <- upd_denom_df_combo(
182	12x	denom_df,
183	12x	trt_var,
184	12x	cur_trt_grp,
185	12x	.spl_context
186		)
187
188	12x	rslt <- s_risk_diff_val_j(
189	12x	df = dfii,
190	12x	.var = resp_var,
191	12x	.df_row = dfrowii,
192	12x	val = "Y",
193	12x	denom_df = denom_df,
194	12x	id = id,
195	12x	riskdiff = riskdiff,
196		# treatment/ref group related arguments
197	12x	trt_var = trt_var,
198	12x	ctrl_grp = ctrl_grp,
199	12x	cur_trt_grp = cur_trt_grp,
200		# relrisk specific arguments
201	12x	variables = variables,
202	12x	conf_level = conf_level,
203	12x	method = method,
204	12x	weights_method = weights_method
205		)
206	12x	x_stat <- rslt[["rr_ci_3d"]]$Y
207		# use .formats if provided, otherwise default to rr format
208	12x	fmt <- if (is.null(.formats)) jjcsformat_xx("xx.x (xx.x, xx.x)") else .formats
209	12x	rslt <- rcell(
210	12x	x_stat,
211	12x	format = fmt,
212	12x	format_na_str = na_str
213		)
214		}
215
216		# rslt is a single rcell row
217	82x	return(rslt)
218		}
219
220		### apply function fn to all levels of incoming .var
221		### cls is a list of single rcell rows - ie one line per level is presented
222	22x	cls <- lapply(levs, fn)
223
224	22x	names(cls) <- levs
225	22x	return(cls)
226		}