#' Add titles, footnotes, page Number, and a bounding box to a grid grob

#'

#' @description `r lifecycle::badge("stable")`

#'

#' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)

#' with title, footnote, and page numbers.

#'

#' @inheritParams grid::grob

#' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.

#' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped

#'   according to the page width.

#' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`.

#' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed.

#' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space

#'   `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`)

#'   need to be subtracted to the allowed width.

#' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`.

#' @param border (`flag`)\cr whether a border should be drawn around the plot or not.

#' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`)

#'   and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults

#'   to `grid::unit(rep(1, 4), "lines")`.

#' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other

#'   elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the

#'   lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`.

#' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of

#'   the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to

#'   `grid::unit(c(2, 1.5, 3, 1.5), "cm")`.

#' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.

#' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.

#'

#' @return A grid grob (`gTree`).

#'

#' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.

#'

#' @examples

#' library(grid)

#'

#' titles <- c(

#'   "Edgar Anderson's Iris Data",

#'   paste(

#'     "This famous (Fisher's or Anderson's) iris data set gives the measurements",

#'     "in centimeters of the variables sepal length and width and petal length",

#'     "and width, respectively, for 50 flowers from each of 3 species of iris."

#'   )

#' )

#'

#' footnotes <- c(

#'   "The species are Iris setosa, versicolor, and virginica.",

#'   paste(

#'     "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",

#'     "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."

#'   )

#' )

#'

#' ## empty plot

#' grid.newpage()

#'

#' grid.draw(

#'   decorate_grob(

#'     NULL,

#'     titles = titles,

#'     footnotes = footnotes,

#'     page = "Page 4 of 10"

#'   )

#' )

#'

#' # grid

#' p <- gTree(

#'   children = gList(

#'     rectGrob(),

#'     xaxisGrob(),

#'     yaxisGrob(),

#'     textGrob("Sepal.Length", y = unit(-4, "lines")),

#'     textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),

#'     pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)

#'   ),

#'   vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))

#' )

#' grid.newpage()

#' grid.draw(p)

#'

#' grid.newpage()

#' grid.draw(

#'   decorate_grob(

#'     grob = p,

#'     titles = titles,

#'     footnotes = footnotes,

#'     page = "Page 6 of 129"

#'   )

#' )

#'

#' ## with ggplot2

#' library(ggplot2)

#'

#' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) +

#'   ggplot2::geom_point()

#' p_gg

#' p <- ggplotGrob(p_gg)

#' grid.newpage()

#' grid.draw(

#'   decorate_grob(

#'     grob = p,

#'     titles = titles,

#'     footnotes = footnotes,

#'     page = "Page 6 of 129"

#'   )

#' )

#'

#' ## with lattice

#' library(lattice)

#'

#' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)

#' p <- grid.grab()

#' grid.newpage()

#' grid.draw(

#'   decorate_grob(

#'     grob = p,

#'     titles = titles,

#'     footnotes = footnotes,

#'     page = "Page 6 of 129"

#'   )

#' )

#'

#' # with gridExtra - no borders

#' library(gridExtra)

#' grid.newpage()

#' grid.draw(

#'   decorate_grob(

#'     tableGrob(

#'       head(mtcars)

#'     ),

#'     titles = "title",

#'     footnotes = "footnote",

#'     border = FALSE

#'   )

#' )

#'

#' @export

decorate_grob <- function(grob,

                          titles,

                          footnotes,

                          page = "",

                          width_titles = grid::unit(1, "npc"),

                          width_footnotes = grid::unit(1, "npc"),

                          border = TRUE,

                          padding = grid::unit(rep(1, 4), "lines"),

                          margins = grid::unit(c(1, 0, 1, 0), "lines"),

                          outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),

                          gp_titles = grid::gpar(),

                          gp_footnotes = grid::gpar(fontsize = 8),

                          name = NULL,

                          gp = grid::gpar(),

                          vp = NULL) {

  # External margins need to be taken into account when defining the width of titles and footers

  # because the text is split in advance depending on only the width of the viewport.

  }

  )

  )

  )

  # Initial decoration of the grob -> border, paddings, and margins are used here

        ),

      )

    ),

    )

  )

        ),

              )

            )

          )

        )

      )

    ),

  )

}

# nocov start

#' @importFrom grid validDetails

#' @exportS3Method

validDetails.decoratedGrob <- function(x) {

  checkmate::assert_character(x$titles)

  checkmate::assert_character(x$footnotes)

  if (!is.null(x$grob)) {

    checkmate::assert_true(grid::is.grob(x$grob))

  }

  if (length(x$page) == 1) {

    checkmate::assert_character(x$page)

  }

  if (!grid::is.unit(x$outer_margins)) {

    checkmate::assert_vector(x$outer_margins, len = 4)

  }

  if (!grid::is.unit(x$margins)) {

    checkmate::assert_vector(x$margins, len = 4)

  }

  if (!grid::is.unit(x$padding)) {

    checkmate::assert_vector(x$padding, len = 4)

  }

  x

}

#' @importFrom grid widthDetails

#' @exportS3Method

widthDetails.decoratedGrob <- function(x) {

  grid::unit(1, "null")

}

#' @importFrom grid heightDetails

#' @exportS3Method

heightDetails.decoratedGrob <- function(x) {

  grid::unit(1, "null")

}

#' Split text according to available text width

#'

#' Dynamically wrap text.

#'

#' @inheritParams grid::grid.text

#' @param text (`string`)\cr the text to wrap.

#' @param width (`grid::unit`)\cr a unit object specifying maximum width of text.

#'

#' @return A text `grob`.

#'

#' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`

#'

#' @keywords internal

split_text_grob <- function(text,

                            x = grid::unit(0.5, "npc"),

                            y = grid::unit(0.5, "npc"),

                            width = grid::unit(1, "npc"),

                            just = "centre",

                            hjust = NULL,

                            vjust = NULL,

                            default.units = "npc", # nolint

                            name = NULL,

                            gp = grid::gpar(),

                            vp = NULL) {

  text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)

  if (!grid::is.unit(x)) x <- grid::unit(x, default.units)

  if (!grid::is.unit(y)) y <- grid::unit(y, default.units)

  if (!grid::is.unit(width)) width <- grid::unit(width, default.units)

  if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)

  if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)

  if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)

  if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty

    horizontal_npc_width_no_gp <- grid::convertWidth(

      grid::grobWidth(

        grid::textGrob(

          paste0(text, collapse = "\n")

        )

      ), "npc",

      valueOnly = TRUE

    )

    horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth(

      grid::textGrob(

        paste0(text, collapse = "\n"),

        gp = gp

      )

    ), "npc", valueOnly = TRUE)

    # Adapting width to the input gpar (it is normalized so does not matter what is text)

    width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp

  }

  ## if it is a fixed unit then we do not need to recalculate when viewport resized

  if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) &&

    attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint

    attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")

  }

  # Fix for split_string in case of residual \n (otherwise is counted as character)

  text2 <- unlist(

    strsplit(

      paste0(text, collapse = "\n"), # for "" cases

      "\n"

    )

  )

  # Final grid text with cat-friendly split_string

  grid::grid.text(

    label = split_string(text2, width),

    x = x, y = y,

    just = just,

    hjust = hjust,

    vjust = vjust,

    rot = 0,

    check.overlap = FALSE,

    name = name,

    gp = gp,

    vp = vp,

    draw = FALSE

  )

}

#' @importFrom grid validDetails

#' @exportS3Method

validDetails.dynamicSplitText <- function(x) {

  checkmate::assert_character(x$text)

  checkmate::assert_true(grid::is.unit(x$width))

  checkmate::assert_vector(x$width, len = 1)

  x

}

#' @importFrom grid heightDetails

#' @exportS3Method

heightDetails.dynamicSplitText <- function(x) {

  txt <- if (!is.null(attr(x$text, "fixed_text"))) {

    attr(x$text, "fixed_text")

  } else {

    paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")

  }

  grid::stringHeight(txt)

}

#' @importFrom grid widthDetails

#' @exportS3Method

widthDetails.dynamicSplitText <- function(x) {

  x$width

}

#' @importFrom grid drawDetails

#' @exportS3Method

drawDetails.dynamicSplitText <- function(x, recording) {

  txt <- if (!is.null(attr(x$text, "fixed_text"))) {

    attr(x$text, "fixed_text")

  } else {

    paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")

  }

  x$width <- NULL

  x$label <- txt

  x$text <- NULL

  class(x) <- c("text", class(x)[-1])

  grid::grid.draw(x)

}

# nocov end

# Adapted from Paul Murell R Graphics 2nd Edition

# https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R

split_string <- function(text, width) {

    }

        # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion

        } else {

        }

      }

    }

  }

}

#' Update page number

#'

#' Automatically updates page number.

#'

#' @param npages (`numeric(1)`)\cr total number of pages.

#' @param ... arguments passed on to [decorate_grob()].

#'

#' @return Closure that increments the page number.

#'

#' @keywords internal

decorate_grob_factory <- function(npages, ...) {

    }

  }

}

#' Decorate set of `grob`s and add page numbering

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Note that this uses the [decorate_grob_factory()] function.

#'

#' @param grobs (`list` of `grob`)\cr a list of grid grobs.

#' @param ... arguments passed on to [decorate_grob()].

#'

#' @return A decorated grob.

#'

#' @examples

#' library(ggplot2)

#' library(grid)

#' g <- with(data = iris, {

#'   list(

#'     ggplot2::ggplotGrob(

#'       ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) +

#'         ggplot2::geom_point()

#'     ),

#'     ggplot2::ggplotGrob(

#'       ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) +

#'         ggplot2::geom_point()

#'     ),

#'     ggplot2::ggplotGrob(

#'       ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) +

#'         ggplot2::geom_point()

#'     ),

#'     ggplot2::ggplotGrob(

#'       ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) +

#'         ggplot2::geom_point()

#'     ),

#'     ggplot2::ggplotGrob(

#'       ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) +

#'         ggplot2::geom_point()

#'     ),

#'     ggplot2::ggplotGrob(

#'       ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) +

#'         ggplot2::geom_point()

#'     )

#'   )

#' })

#' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")

#'

#' draw_grob(lg[[1]])

#' draw_grob(lg[[2]])

#' draw_grob(lg[[6]])

#'

#' @export

decorate_grob_set <- function(grobs, ...) {

}

#' Multivariate logistic regression table

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Layout-creating function which summarizes a logistic variable regression for binary outcome with

#' categorical/continuous covariates in model statement. For each covariate category (if categorical)

#' or specified values (if continuous), present degrees of freedom, regression parameter estimate and

#' standard error (SE) relative to reference group or category. Report odds ratios for each covariate

#' category or specified values and corresponding Wald confidence intervals as default but allow user

#' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis

#' that covariate has no effect on response in model containing all specified covariates.

#' Allow option to include one two-way interaction and present similar output for

#' each interaction degree of freedom.

#'

#' @inheritParams argument_convention

#' @param drop_and_remove_str (`string`)\cr string to be dropped and removed.

#'

#' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].

#'   Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout.

#'

#' @note For the formula, the variable names need to be standard `data.frame` column names without

#'   special characters.

#'

#' @examples

#' library(dplyr)

#' library(broom)

#'

#' adrs_f <- tern_ex_adrs |>

#'   filter(PARAMCD == "BESRSPI") |>

#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) |>

#'   mutate(

#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),

#'     RACE = factor(RACE),

#'     SEX = factor(SEX)

#'   )

#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")

#' mod1 <- fit_logistic(

#'   data = adrs_f,

#'   variables = list(

#'     response = "Response",

#'     arm = "ARMCD",

#'     covariates = c("AGE", "RACE")

#'   )

#' )

#' mod2 <- fit_logistic(

#'   data = adrs_f,

#'   variables = list(

#'     response = "Response",

#'     arm = "ARMCD",

#'     covariates = c("AGE", "RACE"),

#'     interaction = "AGE"

#'   )

#' )

#'

#' df <- tidy(mod1, conf_level = 0.99)

#' df2 <- tidy(mod2, conf_level = 0.99)

#'

#' # flagging empty strings with "_"

#' df <- df_explicit_na(df, na_level = "_")

#' df2 <- df_explicit_na(df2, na_level = "_")

#'

#' result1 <- basic_table() |>

#'   summarize_logistic(

#'     conf_level = 0.95,

#'     drop_and_remove_str = "_"

#'   ) |>

#'   build_table(df = df)

#' result1

#'

#' result2 <- basic_table() |>

#'   summarize_logistic(

#'     conf_level = 0.95,

#'     drop_and_remove_str = "_"

#'   ) |>

#'   build_table(df = df2)

#' result2

#'

#' @export

#' @order 1

summarize_logistic <- function(lyt,

                               conf_level,

                               drop_and_remove_str = "",

                               .indent_mods = NULL) {

  # checks

}

#' Fit for logistic regression

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Fit a (conditional) logistic regression model.

#'

#' @inheritParams argument_convention

#' @param data (`data.frame`)\cr the data frame on which the model was fit.

#' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.

#'   This will be used when fitting the (conditional) logistic regression model on the left hand

#'   side of the formula.

#'

#' @return A fitted logistic regression model.

#'

#' @section Model Specification:

#'

#' The `variables` list needs to include the following elements:

#'   * `arm`: Treatment arm variable name.

#'   * `response`: The response arm variable name. Usually this is a 0/1 variable.

#'   * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names.

#'   * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already

#'     included in `covariates`. Then the interaction with the treatment arm is included in the model.

#'

#' @examples

#' library(dplyr)

#'

#' adrs_f <- tern_ex_adrs |>

#'   filter(PARAMCD == "BESRSPI") |>

#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) |>

#'   mutate(

#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),

#'     RACE = factor(RACE),

#'     SEX = factor(SEX)

#'   )

#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")

#' mod1 <- fit_logistic(

#'   data = adrs_f,

#'   variables = list(

#'     response = "Response",

#'     arm = "ARMCD",

#'     covariates = c("AGE", "RACE")

#'   )

#' )

#' mod2 <- fit_logistic(

#'   data = adrs_f,

#'   variables = list(

#'     response = "Response",

#'     arm = "ARMCD",

#'     covariates = c("AGE", "RACE"),

#'     interaction = "AGE"

#'   )

#' )

#'

#' @export

fit_logistic <- function(data,

                         variables = list(

                           response = "Response",

                           arm = "ARMCD",

                           covariates = NULL,

                           interaction = NULL,

                           strata = NULL

                         ),

                         response_definition = "response") {

  )

  }

  }

    } else {

    }

  }

    )

  } else {

    )

  }

}

#' Custom tidy method for binomial GLM results

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object

#' with `binomial` family.

#'

#' @inheritParams argument_convention

#' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used.

#' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.

#'

#' @return A `data.frame` containing the tidied model.

#'

#' @method tidy glm

#'

#' @seealso [h_logistic_regression] for relevant helper functions.

#'

#' @examples

#' library(dplyr)

#' library(broom)

#'

#' adrs_f <- tern_ex_adrs |>

#'   filter(PARAMCD == "BESRSPI") |>

#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) |>

#'   mutate(

#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),

#'     RACE = factor(RACE),

#'     SEX = factor(SEX)

#'   )

#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")

#' mod1 <- fit_logistic(

#'   data = adrs_f,

#'   variables = list(

#'     response = "Response",

#'     arm = "ARMCD",

#'     covariates = c("AGE", "RACE")

#'   )

#' )

#' mod2 <- fit_logistic(

#'   data = adrs_f,

#'   variables = list(

#'     response = "Response",

#'     arm = "ARMCD",

#'     covariates = c("AGE", "RACE"),

#'     interaction = "AGE"

#'   )

#' )

#'

#' df <- tidy(mod1, conf_level = 0.99)

#' df2 <- tidy(mod2, conf_level = 0.99)

#'

#' @export

tidy.glm <- function(x, # nolint

                     conf_level = 0.95,

                     at = NULL,

                     ...) {

    )

  } else {

    )

  }

  }

}

#' Logistic regression multivariate column layout function

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Layout-creating function which creates a multivariate column layout summarizing logistic

#' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].

#'

#' @inheritParams argument_convention

#'

#' @return A layout object suitable for passing to further layouting functions. Adding this

#'   function to an `rtable` layout will split the table into columns corresponding to

#'   statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.

#'

#' @export

logistic_regression_cols <- function(lyt,

                                     conf_level = 0.95) {

  )

  )

}

#' Logistic regression summary table

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Constructor for content functions to be used in [`summarize_logistic()`] to summarize

#' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].

#'

#' @inheritParams argument_convention

#' @param flag_var (`string`)\cr variable name identifying which row should be used in this

#'   content function.

#'

#' @return A content function.

#'

#' @export

logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {

    )

    )

  }

}

# Utility functions to cooperate with {rtables} package

#' Convert table into matrix of strings

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Helper function to use mostly within tests. `with_spaces`parameter allows

#' to test not only for content but also indentation and table structure.

#' `print_txt_to_copy` instead facilitate the testing development by returning a well

#' formatted text that needs only to be copied and pasted in the expected output.

#'

#' @inheritParams formatters::toString

#' @param x (`VTableTree`)\cr `rtables` table object.

#' @param with_spaces (`flag`)\cr whether the tested table should keep the indentation and other relevant spaces.

#' @param print_txt_to_copy (`flag`)\cr utility to have a way to copy the input table directly

#'   into the expected variable instead of copying it too manually.

#'

#' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the

#'   table will be printed to console, ready to be copied as a expected value.

#'

#' @examples

#' tbl <- basic_table() |>

#'   split_rows_by("SEX") |>

#'   split_cols_by("ARM") |>

#'   analyze("AGE") |>

#'   build_table(tern_ex_adsl)

#'

#' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2))

#'

#' @export

to_string_matrix <- function(x, widths = NULL, max_width = NULL,

                             hsep = formatters::default_hsep(),

                             with_spaces = TRUE, print_txt_to_copy = FALSE) {

  } else {

  }

  }

  # Producing the matrix to test

  } else {

  }

  # Printing to console formatted output that needs to be copied in "expected"

    }

  }

  # Return values

}

#' Blank for missing input

#'

#' Helper function to use in tabulating model results.

#'

#' @param x (`vector`)\cr input for a cell.

#'

#' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise

#'   the unlisted version of `x`.

#'

#' @keywords internal

unlist_and_blank_na <- function(x) {

  } else {

  }

}

#' Constructor for content functions given a data frame with flag input

#'

#' This can be useful for tabulating model results.

#'

#' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the

#'   content function.

#' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned.

#' @param format (`string`)\cr `rtables` format to use.

#'

#' @return A content function which gives `df$analysis_var` at the row identified by

#'   `.df_row$flag` in the given format.

#'

#' @keywords internal

cfun_by_flag <- function(analysis_var,

                         flag_var,

                         format = "xx",

                         .indent_mods = NULL) {

    )

  }

}

#' Content row function to add row total to labels

#'

#' This takes the label of the latest row split level and adds the row total from `df` in parentheses.

#' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than

#' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`.

#'

#' @inheritParams argument_convention

#'

#' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.

#'

#' @note It is important here to not use `df` but rather `.N_row` in the implementation, because

#'   the former is already split by columns and will refer to the first column of the data only.

#'

#' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from

#'   `alt_counts_df` instead of `df`.

#'

#' @keywords internal

c_label_n <- function(df,

                      labelstr,

                      .N_row) { # nolint

  )

}

#' Content row function to add `alt_counts_df` row total to labels

#'

#' This takes the label of the latest row split level and adds the row total from `alt_counts_df`

#' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df`

#' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`.

#'

#' @inheritParams argument_convention

#'

#' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.

#'

#' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead

#'   of `alt_counts_df`.

#'

#' @keywords internal

c_label_n_alt <- function(df,

                          labelstr,

                          .alt_df_row) {

  )

}

#' Layout-creating function to add row total counts

#'

#' @description `r lifecycle::badge("stable")`

#'

#' This works analogously to [rtables::add_colcounts()] but on the rows. This function

#'  is a wrapper for [rtables::summarize_row_groups()].

#'

#' @inheritParams argument_convention

#' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`)

#'   or from `df` (`FALSE`). Defaults to `FALSE`.

#'

#' @return A modified layout where the latest row split labels now have the row-wise

#'   total counts (i.e. without column-based subsetting) attached in parentheses.

#'

#' @note Row count values are contained in these row count rows but are not displayed

#'   so that they are not considered zero rows by default when pruning.

#'

#' @examples

#' basic_table() |>

#'   split_cols_by("ARM") |>

#'   add_colcounts() |>

#'   split_rows_by("RACE", split_fun = drop_split_levels) |>

#'   add_rowcounts() |>

#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") |>

#'   build_table(DM)

#'

#' @export

add_rowcounts <- function(lyt, alt_counts = FALSE) {

  )

}

#' Obtain column indices

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Helper function to extract column indices from a `VTableTree` for a given

#' vector of column names.

#'

#' @param table_tree (`VTableTree`)\cr `rtables` table object to extract the indices from.

#' @param col_names (`character`)\cr vector of column names.

#'

#' @return A vector of column indices.

#'

#' @export

h_col_indices <- function(table_tree, col_names) {

}

#' Labels or names of list elements

#'

#' Helper function for working with nested statistic function results which typically

#' don't have labels but names that we can use.

#'

#' @param x (`list`)\cr a list.

#'

#' @return A `character` vector with the labels or names for the list elements.

#'

#' @examples

#' x <- data.frame(

#'   a = 1:10,

#'   b = rnorm(10)

#' )

#' labels_or_names(x)

#' var_labels(x) <- c(b = "Label for b", a = NA)

#' labels_or_names(x)

#'

#' @export

labels_or_names <- function(x) {

}

#' Convert to `rtable`

#'

#' @description `r lifecycle::badge("stable")`

#'

#' This is a new generic function to convert objects to `rtable` tables.

#'

#' @param x (`data.frame`)\cr the object which should be converted to an `rtable`.

#' @param ... additional arguments for methods.

#'

#' @return An `rtables` table object. Note that the concrete class will depend on the method used.

#'

#' @export

as.rtable <- function(x, ...) { # nolint

}

#' @describeIn as.rtable Method for converting a `data.frame` that contains numeric columns to `rtable`.

#'

#' @param format (`string` or `function`)\cr the format which should be used for the columns.

#'

#' @method as.rtable data.frame

#'

#' @examples

#' x <- data.frame(

#'   a = 1:10,

#'   b = rnorm(10)

#' )

#' as.rtable(x)

#'

#' @export

as.rtable.data.frame <- function(x, format = "xx.xx", ...) {

      ),

            )

          )

        },

      )

    )

  )

}

#' Split parameters

#'

#' @description `r lifecycle::badge("deprecated")`

#'

#' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant

#' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to

#' specific analysis function.

#'

#' @param param (`vector`)\cr the parameter to be split.

#' @param value (`vector`)\cr the value used to split.

#' @param f (`list`)\cr the reference to make the split.

#'

#' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`.

#'

#' @examples

#' f <- list(

#'   surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),

#'   surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")

#' )

#'

#' .stats <- c("pt_at_risk", "rate_diff")

#' h_split_param(.stats, .stats, f = f)

#'

#' # $surv

#' # [1] "pt_at_risk"

#' #

#' # $surv_diff

#' # [1] "rate_diff"

#'

#' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")

#' h_split_param(.formats, names(.formats), f = f)

#'

#' # $surv

#' # pt_at_risk event_free_rate

#' # "xx"           "xxx"

#' #

#' # $surv_diff

#' # NULL

#'

#' @export

h_split_param <- function(param,

                          value,

                          f) {

}

#' Get selected statistics names

#'

#' Helper function to be used for creating `afun`.

#'

#' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means

#'   in this context that all default statistics should be used.

#' @param all_stats (`character`)\cr all statistics which can be selected here potentially.

#'

#' @return A `character` vector with the selected statistics.

#'

#' @keywords internal

afun_selected_stats <- function(.stats, all_stats) {

  } else {

  }

}

#' Add variable labels to top left corner in table

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Helper layout-creating function to append the variable labels of a given variables vector

#' from a given dataset in the top left corner. If a variable label is not found then the

#' variable name itself is used instead. Multiple variable labels are concatenated with slashes.

#'

#' @inheritParams argument_convention

#' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.

#' @param indent (`integer(1)`)\cr non-negative number of nested indent space, default to 0L which means no indent.

#'   1L means two spaces indent, 2L means four spaces indent and so on.

#'

#' @return A modified layout with the new variable label(s) added to the top-left material.

#'

#' @note This is not an optimal implementation of course, since we are using here the data set

#'   itself during the layout creation. When we have a more mature `rtables` implementation then

#'   this will also be improved or not necessary anymore.

#'

#' @examples

#' lyt <- basic_table() |>

#'   split_cols_by("ARM") |>

#'   add_colcounts() |>

#'   split_rows_by("SEX") |>

#'   append_varlabels(DM, "SEX") |>

#'   analyze("AGE", afun = mean) |>

#'   append_varlabels(DM, "AGE", indent = 1)

#' build_table(lyt, DM)

#'

#' lyt <- basic_table() |>

#'   split_cols_by("ARM") |>

#'   split_rows_by("SEX") |>

#'   analyze("AGE", afun = mean) |>

#'   append_varlabels(DM, c("SEX", "AGE"))

#' build_table(lyt, DM)

#'

#' @export

append_varlabels <- function(lyt, df, vars, indent = 0L) {

  }

}

#' Default string replacement for `NA` values

#'

#' @description `r lifecycle::badge("stable")`

#'

#' The default string used to represent `NA` values. This value is used as the default

#' value for the `na_str` argument throughout the `tern` package, and printed in place

#' of `NA` values in output tables. If not specified for each `tern` function by the user

#' via the `na_str` argument, or in the R environment options via [set_default_na_str()],

#' then `NA` is used.

#'

#' @param na_str (`string`)\cr single string value to set in the R environment options as

#'   the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the

#'   current value set in the R environment (defaults to `NULL` if not set).

#'

#' @name default_na_str

NULL

#' @describeIn default_na_str Accessor for default `NA` value replacement string.

#'

#' @return

#' * `default_na_str` returns the current value if an R environment option has been set

#'   for `"tern_default_na_str"`, or `NA_character_` otherwise.

#'

#' @examples

#' # Default settings

#' default_na_str()

#' getOption("tern_default_na_str")

#'

#' # Set custom value

#' set_default_na_str("<Missing>")

#'

#' # Settings after value has been set

#' default_na_str()

#' getOption("tern_default_na_str")

#'

#' @export

default_na_str <- function() {

}

#' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the

#'   option `"tern_default_na_str"` within the R environment.

#'

#' @return

#' * `set_default_na_str` has no return value.

#'

#' @export

set_default_na_str <- function(na_str) {

}

#' Utilities to handle extra arguments in analysis functions

#'

#' @description `r lifecycle::badge("stable")`

#' Important additional parameters, useful to modify behavior of analysis and summary

#' functions are listed in [rtables::additional_fun_params]. With these utility functions

#' we can retrieve a curated list of these parameters from the environment, and pass them

#' to the analysis functions with dedicated `...`; notice that the final `s_*` function

#' will get them through argument matching.

#'

#' @param extra_afun_params (`list`)\cr list of additional parameters (`character`) to be

#'   retrieved from the environment. Curated list is present in [rtables::additional_fun_params].

#' @param add_alt_df (`logical`)\cr if `TRUE`, the function will also add `.alt_df` and `.alt_df_row`

#'   parameters.

#'

#' @name util_handling_additional_fun_params

NULL

#' @describeIn util_handling_additional_fun_params Retrieve additional parameters from the environment.

#'

#' @return

#' * `retrieve_extra_afun_params` returns a list of the values of the parameters in the environment.

#'

#' @keywords internal

retrieve_extra_afun_params <- function(extra_afun_params) {

  }

}

#' @describeIn util_handling_additional_fun_params Curated list of additional parameters for

#'   analysis functions. Please check [rtables::additional_fun_params] for precise descriptions.

#'

#' @return

#' * `get_additional_afun_params` returns a list of additional parameters.

#'

#' @keywords internal

get_additional_afun_params <- function(add_alt_df = FALSE) {

  )

    )

  }

}

#' Apply 1/3 or 1/2 imputation rule to data

#'

#' @description `r lifecycle::badge("stable")`

#'

#' @inheritParams argument_convention

#' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()].

#' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation

#'   rule applied.

#' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation

#'   rule or `"1/2"` to implement 1/2 imputation rule.

#' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).

#'   This parameter is only used when `imp_rule` is set to `"1/3"`.

#' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds

#'   to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above

#'   (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.

#'

#' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed

#'   according to the specified imputation rule.

#'

#' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`

#'   argument.

#'

#' @examples

#' set.seed(1)

#' df <- data.frame(

#'   AVAL = runif(50, 0, 1),

#'   AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)

#' )

#' x_stats <- s_summary(df$AVAL)

#' imputation_rule(df, x_stats, "max", "1/3")

#' imputation_rule(df, x_stats, "geom_mean", "1/3")

#' imputation_rule(df, x_stats, "mean", "1/2")

#'

#' @export

imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {

  # defaults

    }

    }

  }

}

#' Control function for descriptive statistics

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify

#' details for [s_summary()]. This function family is mainly used by [analyze_vars()].

#'

#' @inheritParams argument_convention

#' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate.

#' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used.

#'   Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.

#'   This differs from R's default. See more about `type` in [stats::quantile()].

#' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating

#'   p-value.

#'

#' @return A list of components with the same names as the arguments.

#'

#' @export

control_analyze_vars <- function(conf_level = 0.95,

                                 quantiles = c(0.25, 0.75),

                                 quantile_type = 2,

                                 test_mean = 0) {

}

# Helper function to fix numeric or counts pval if necessary

.correct_num_or_counts_pval <- function(type, .stats) {

    }

  } else {

    }

  }

}

#' Analyze variables

#'

#' @description `r lifecycle::badge("stable")`

#'

#' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3