# 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

#'

#' Internal 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.

#'

#' @keywords internal

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("stable")`

#'

#' 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) {

  )

    )

  }

}

#' Create a STEP graph

#'

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

#'

#' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR

#' along the continuous biomarker value subgroups.

#'

#' @param df (`tibble`)\cr result of [tidy.step()].

#' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual

#'   biomarker values.

#' @param est (named `list`)\cr `col` and `lty` settings for estimate line.

#' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval

#'   ribbon area, or `NULL` to not plot a CI ribbon.

#' @param col (`character`)\cr color(s).

#'

#' @return A `ggplot` STEP graph.

#'

#' @seealso Custom tidy method [tidy.step()].

#'

#' @examples

#' library(survival)

#' lung$sex <- factor(lung$sex)

#'

#' # Survival example.

#' vars <- list(

#'   time = "time",

#'   event = "status",

#'   arm = "sex",

#'   biomarker = "age"

#' )

#'

#' step_matrix <- fit_survival_step(

#'   variables = vars,

#'   data = lung,

#'   control = c(control_coxph(), control_step(num_points = 10, degree = 2))

#' )

#' step_data <- broom::tidy(step_matrix)

#'

#' # Default plot.

#' g_step(step_data)

#'

#' # Add the reference 1 horizontal line.

#' library(ggplot2)

#' g_step(step_data) +

#'   ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)

#'

#' # Use actual values instead of percentiles, different color for estimate and no CI,

#' # use log scale for y axis.

#' g_step(

#'   step_data,

#'   use_percentile = FALSE,

#'   est = list(col = "blue", lty = 1),

#'   ci_ribbon = NULL

#' ) + scale_y_log10()

#'

#' # Adding another curve based on additional column.

#' step_data$extra <- exp(step_data$`Percentile Center`)

#' g_step(step_data) +

#'   ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")

#'

#' # Response example.

#' vars <- list(

#'   response = "status",

#'   arm = "sex",

#'   biomarker = "age"

#' )

#'

#' step_matrix <- fit_rsp_step(

#'   variables = vars,

#'   data = lung,

#'   control = c(

#'     control_logistic(response_definition = "I(response == 2)"),

#'     control_step()

#'   )

#' )

#' step_data <- broom::tidy(step_matrix)

#' g_step(step_data)

#'

#' @export

g_step <- function(df,

                   use_percentile = "Percentile Center" %in% names(df),

                   est = list(col = "blue", lty = 1),

                   ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),

                   col = getOption("ggplot2.discrete.colour")) {

  # Set legend names. To be modified also at call level

  }

    }

      ),

    ) +

      )

  }

    ) +

    ))

  }

}

#' Custom tidy method for STEP results

#'

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

#'

#' Tidy the STEP results into a `tibble` format ready for plotting.

#'

#' @param x (`matrix`)\cr results from [fit_survival_step()].

#' @param ... not used.

#'

#' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,

#'   respectively. Additional attributes carry metadata also used for plotting.

#'

#' @seealso [g_step()] which consumes the result from this function.

#'

#' @method tidy step

#'

#' @examples

#' library(survival)

#' lung$sex <- factor(lung$sex)

#' vars <- list(

#'   time = "time",

#'   event = "status",

#'   arm = "sex",

#'   biomarker = "age"

#' )

#' step_matrix <- fit_survival_step(

#'   variables = vars,

#'   data = lung,

#'   control = c(control_coxph(), control_step(num_points = 10, degree = 2))

#' )

#' broom::tidy(step_matrix)

#'

#' @export

tidy.step <- function(x, ...) { # nolint

    ))

  }

    ))

  }

  }

  )

}

#' Confidence intervals for a difference of binomials

#'

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

#'

#' Several confidence intervals for the difference between proportions.

#'

#' @name desctools_binom

NULL

#' Recycle list of parameters

#'

#' This function recycles all supplied elements to the maximal dimension.

#'

#' @param ... (`any`)\cr elements to recycle.

#'

#' @return A `list`.

#'

#' @keywords internal

#' @noRd

h_recycle <- function(...) {

}

#' @describeIn desctools_binom Several confidence intervals for the difference between proportions.

#'

#' @return A `matrix` of 3 values:

#'   * `est`: estimate of proportion difference.

#'   * `lwr.ci`: estimate of lower end of the confidence interval.

#'   * `upr.ci`: estimate of upper end of the confidence interval.

#'

#' @keywords internal

desctools_binom <- function(x1,

                            n1,

                            x2,

                            n2,

                            conf.level = 0.95, # nolint

                            sides = c("two.sided", "left", "right"),

                            method = c(

                              "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"

                            )) {

  }

  }

    }

      },

      },

      },

      },

        )

        )

      },

        )

        )

      },

          } else {

          }

        }

        }

      },

      },

      },

            }

            } else {

            }

          }

        }

          } else {

          }

        }

      },

      },

      },

      },

    )

    )

    }

  }

  )

    )

  }))

  } else {

  } else {

  } else {

  } else {

}

#' @describeIn desctools_binom Compute confidence intervals for binomial proportions.

#'

#' @param x (`integer(1)`)\cr number of successes.

#' @param n (`integer(1)`)\cr number of trials.

#' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.

#' @param sides (`string`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default),

#'   `"left"`, or `"right"`.

#' @param method (`string`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`,

#' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`,

#' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`.

#'

#' @return A `matrix` with 3 columns containing:

#'   * `est`: estimate of proportion difference.

#'   * `lwr.ci`: lower end of the confidence interval.

#'   * `upr.ci`: upper end of the confidence interval.

#'

#' @keywords internal

desctools_binomci <- function(x,

                              n,

                              conf.level = 0.95, # nolint

                              sides = c("two.sided", "left", "right"),

                              method = c(

                                "wilson", "wald", "waldcc", "agresti-coull",

                                "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",

                                "clopper-pearson", "arcsine", "logit", "witting", "pratt",

                                "midp", "lik", "blaker"

                              ),

                              rand = 123,

                              tol = 1e-05) {

  }

  }

                       ),

    }

    }

    }

    }

    }

    )),

    },

    },

    },

    },

    },

      } else {

        )

      }

      } else {

      }

    },

      } else {

      }

      } else {

      }

    },

      } else {

        } else {

          )

        }

      }

      } else {

        } else {

        }

      }

    },

    },

    },

    },

      }

        }

      }

    },

      } else {

      }

    },

        ) -

      }

      }

      }

      }

    },

                         ...) {

        ))

        ))

      }

            } else {

        }

      }

            } else {

          }

        } else {

            } else {

        }

      }

    },

        )

      }

        }

      }

        }

      }

    }

    )

    ))

    }

  }

  )

  } else {

  } else {

    )

  }))

}

#' 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",