#' Cumulative counts of numeric variable by thresholds

#'

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

#'

#' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a

#' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified

#' threshold values.

#'

#' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds`

#' argument as a numeric vector. Whether counts should include the threshold values, and whether to count

#' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail`

#' parameters, respectively.

#'

#' @inheritParams h_count_cumulative

#' @inheritParams argument_convention

#' @param thresholds (`numeric`)\cr vector of cutoff values for the counts.

#' @param .stats (`character`)\cr statistics to select for the table.

#'

#'   Options are: ``r shQuote(get_stats("count_cumulative"), type = "sh")``

#'

#' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].

#'

#' @name count_cumulative

#' @order 1

NULL

#' Helper function for `s_count_cumulative()`

#'

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

#'

#' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.

#'

#' @inheritParams argument_convention

#' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`.

#' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`.

#' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in

#'   count, default is `TRUE`.

#'

#' @return A named vector with items:

#'   * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold

#'     of user specification.

#'   * `fraction`: the fraction of the count.

#'

#' @seealso [count_cumulative]

#'

#' @examples

#' set.seed(1, kind = "Mersenne-Twister")

#' x <- c(sample(1:10, 10), NA)

#' .N_col <- length(x)

#'

#' h_count_cumulative(x, 5, denom = .N_col)

#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na_rm = FALSE, denom = .N_col)

#' h_count_cumulative(x, 0, lower_tail = FALSE, denom = .N_col)

#' h_count_cumulative(x, 100, lower_tail = FALSE, denom = .N_col)

#'

#' @export

h_count_cumulative <- function(x,

                               threshold,

                               lower_tail = TRUE,

                               include_eq = TRUE,

                               na_rm = TRUE,

                               denom) {

  }

  )

}

#' Description of cumulative count

#'

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

#'

#' This is a helper function that describes the analysis in [s_count_cumulative()].

#'

#' @inheritParams h_count_cumulative

#'

#' @return Labels for [s_count_cumulative()].

#'

#' @export

d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {

}

#' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.

#'

#' @return

#' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a

#'   component, each component containing a vector for the count and fraction.

#'

#' @keywords internal

s_count_cumulative <- function(x,

                               thresholds,

                               lower_tail = TRUE,

                               include_eq = TRUE,

                               denom = c("N_col", "n", "N_row"),

                               .N_col, # nolint

                               .N_row, # nolint

                               na_rm = TRUE,

                               ...) {

    )

}

#' @describeIn count_cumulative Formatted analysis function which is used as `afun`

#'   in `count_cumulative()`.

#'

#' @return

#' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].

#'

#' @keywords internal

a_count_cumulative <- function(x,

                               ...,

                               .stats = NULL,

                               .stat_names = NULL,

                               .formats = NULL,

                               .labels = NULL,

                               .indent_mods = NULL) {

  # Check if there are user-defined functions

  # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params)

  )

  # Main statistical functions application

    )

  )

  # Fill in with stats defaults if needed

  )

  # Fill in formats/indents/labels with custom input and defaults

  )

  # Unlist stats

  # Auto format handling

  )

  # Get and check statistical names from defaults

  )

}

#' @describeIn count_cumulative Layout-creating function which can take statistics function arguments

#'   and additional format arguments. This function is a wrapper for [rtables::analyze()].

#'

#' @return

#' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,

#'   or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing

#'   the statistics from `s_count_cumulative()` to the table layout.

#'

#' @examples

#' basic_table() %>%

#'   split_cols_by("ARM") %>%

#'   add_colcounts() %>%

#'   count_cumulative(

#'     vars = "AGE",

#'     thresholds = c(40, 60)

#'   ) %>%

#'   build_table(tern_ex_adsl)

#'

#' @export

#' @order 2

count_cumulative <- function(lyt,

                             vars,

                             thresholds,

                             lower_tail = TRUE,

                             include_eq = TRUE,

                             var_labels = vars,

                             show_labels = "visible",

                             na_str = default_na_str(),

                             nested = TRUE,

                             table_names = vars,

                             ...,

                             na_rm = TRUE,

                             .stats = c("count_fraction"),

                             .stat_names = NULL,

                             .formats = NULL,

                             .labels = NULL,

                             .indent_mods = NULL) {

  # Depending on main functions

    ...

  )

  # Needed defaults

  # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params)

  )

  # Main {rtables} structural call

  )

}

#' Univariate formula special term

#'

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

#'

#' The special term `univariate` indicate that the model should be fitted individually for

#' every variable included in univariate.

#'

#' @param x (`character`)\cr a vector of variable names separated by commas.

#'

#' @return When used within a model formula, produces univariate models for each variable provided.

#'

#' @details

#' If provided alongside with pairwise specification, the model

#' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models

#' + `y ~ ARM`

#' + `y ~ ARM + SEX`

#' + `y ~ ARM + AGE`

#' + `y ~ ARM + RACE`

#'

#' @export

univariate <- function(x) {

}

# Get the right-hand-term of a formula

rht <- function(x) {

}

#' Hazard ratio estimation in interactions

#'

#' This function estimates the hazard ratios between arms when an interaction variable is given with

#' specific values.

#'

#' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of

#'   the levels of `variable` given the levels of `given`.

#' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()].

#' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix.

#' @param coef (`numeric`)\cr vector of estimated coefficients.

#' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model.

#' @param conf_level (`proportion`)\cr confidence level of estimate intervals.

#'

#' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)

#'   and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.

#'   The cox regression estimates the coefficients along with a variance-covariance matrix for:

#'

#'   - b1 (arm b), b2 (arm c)

#'   - b3 (sex m)

#'   - b4 (arm b: sex m), b5 (arm c: sex m)

#'

#'   Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation

#'   will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),

#'   therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained

#'   as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.

#'

#' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of

#'   `variable` and `given`, with columns:

#'   * `coef_hat`: Estimation of the coefficient.

#'   * `coef_se`: Standard error of the estimation.

#'   * `hr`: Hazard ratio.

#'   * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.

#'

#' @seealso [s_cox_multivariate()].

#'

#' @examples

#' library(dplyr)

#' library(survival)

#'

#' ADSL <- tern_ex_adsl %>%

#'   filter(SEX %in% c("F", "M"))

#'

#' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")

#' adtte$ARMCD <- droplevels(adtte$ARMCD)

#' adtte$SEX <- droplevels(adtte$SEX)

#'

#' mod <- coxph(

#'   formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,

#'   data = adtte

#' )

#'

#' mmat <- stats::model.matrix(mod)[1, ]

#' mmat[!mmat == 0] <- 0

#'

#' @keywords internal

estimate_coef <- function(variable, given,

                          lvl_var, lvl_given,

                          coef,

                          mmat,

                          vcov,

                          conf_level = 0.95) {

    }

  )

    }

  )

  })

  })

  )

}

#' `tryCatch` around `car::Anova`

#'

#' Captures warnings when executing [car::Anova].

#'

#' @inheritParams car::Anova

#'

#' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.

#'

#' @examples

#' # `car::Anova` on cox regression model including strata and expected

#' # a likelihood ratio test triggers a warning as only Wald method is

#' # accepted.

#'

#' library(survival)

#'

#' mod <- coxph(

#'   formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),

#'   data = ovarian

#' )

#'

#' @keywords internal

try_car_anova <- function(mod,

                          test.statistic) { # nolint

          ),

        )

      },

        # If a warning is detected it is handled as "w".

        # A warning is sometimes expected, then, we want to restart

        # the execution while ignoring the warning.

      }

    ),

    }

  )

}

#' Fit a Cox regression model and ANOVA

#'

#' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results.

#'

#' @inheritParams t_coxreg

#'

#' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and

#'   `aov` (result of [car::Anova()]).

#'

#' @noRd

fit_n_aov <- function(formula,

                      data = data,

                      conf_level = conf_level,

                      pval_method = c("wald", "likelihood"),

                      ...) {

    # We expect some warnings due to coxph which fails strict programming.

  })

    )

  )

}

# argument_checks

check_formula <- function(formula) {

  }

}

check_covariate_formulas <- function(covariates) {

  }

}

name_covariate_names <- function(covariates) {

}

check_increments <- function(increments, covariates) {

            )

          )

        }

      }

    )

  }

}

#' Multivariate Cox model - summarized results

#'

#' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or

#' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually

#' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the

#' covariates included in the model.

#' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the

#' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,

#' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,

#' `NEST's bookdown`)

#'

#' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model

#'   including covariates.

#' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates.

#' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95.

#' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of

#'   `"wald"` (default) or `"likelihood"`.

#' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the

#'   method for tie handling, one of `exact` (default), `efron`, `breslow`.

#'

#' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.

#'

#' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms

#'   but is out of scope as defined by the  Global Data Standards Repository

#'   (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).

#'

#' @seealso [estimate_coef()].

#'

#' @examples

#' library(dplyr)

#'

#' adtte <- tern_ex_adtte

#' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered

#' adtte_f <- filter(

#'   adtte_f,

#'   PARAMCD == "OS" &

#'     SEX %in% c("F", "M") &

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

#' )

#' adtte_f$SEX <- droplevels(adtte_f$SEX)

#' adtte_f$RACE <- droplevels(adtte_f$RACE)

#'

#' @keywords internal

s_cox_multivariate <- function(formula, data,

                               conf_level = 0.95,

                               pval_method = c("wald", "likelihood"),

                               ...) {

      }

    }

  )

  # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)

    ...

  )

      )

    }

      }

    )

  }

}

#' Stack multiple grobs

#'

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

#'

#' Stack grobs as a new grob with 1 column and multiple rows layout.

#'

#' @param ... grobs.

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

#' @param padding (`grid::unit`)\cr unit of length 1, space between each grob.

#' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).

#' @param name (`string`)\cr a character identifier for the grob.

#' @param gp (`gpar`)\cr a [gpar()] object.

#'

#' @return A `grob`.

#'

#' @examples

#' library(grid)

#'

#' g1 <- circleGrob(gp = gpar(col = "blue"))

#' g2 <- circleGrob(gp = gpar(col = "red"))

#' g3 <- textGrob("TEST TEXT")

#' grid.newpage()

#' grid.draw(stack_grobs(g1, g2, g3))

#'

#' showViewport()

#'

#' grid.newpage()

#' pushViewport(viewport(layout = grid.layout(1, 2)))

#' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)

#' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))

#'

#' showViewport()

#' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)

#'

#' @export

stack_grobs <- function(...,

                        grobs = list(...),

                        padding = grid::unit(2, "line"),

                        vp = NULL,

                        gp = NULL,

                        name = NULL) {

  )

  )

  }

      } else {

      }

    }

  )

  )

    )

  )

  )

}

#' Arrange multiple grobs

#'

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

#'

#' Arrange grobs as a new grob with `n * m (rows * cols)` layout.

#'

#' @inheritParams stack_grobs

#' @param ncol (`integer(1)`)\cr number of columns in layout.

#' @param nrow (`integer(1)`)\cr number of rows in layout.

#' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob.

#' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob.

#'

#' @return A `grob`.

#'

#' @examples

#' library(grid)

#'

#' \donttest{

#' num <- lapply(1:9, textGrob)

#' grid::grid.newpage()

#' grid.draw(arrange_grobs(grobs = num, ncol = 2))

#'

#' showViewport()

#'

#' g1 <- circleGrob(gp = gpar(col = "blue"))

#' g2 <- circleGrob(gp = gpar(col = "red"))

#' g3 <- textGrob("TEST TEXT")

#' grid::grid.newpage()

#' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))

#'

#' showViewport()

#'

#' grid::grid.newpage()

#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))

#'

#' grid::grid.newpage()

#' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))

#' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)

#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))

#'

#' showViewport()

#' }

#' @export

arrange_grobs <- function(...,

                          grobs = list(...),

                          ncol = NULL, nrow = NULL,

                          padding_ht = grid::unit(2, "line"),

                          padding_wt = grid::unit(2, "line"),

                          vp = NULL,

                          gp = NULL,

                          name = NULL) {

  )