R/cox_table_time_dependent_cov.R

In MBender1992/emR: Dictionary for EuMelaReg functions (analysis of clinical studies)

#' Print results from univariate or multivariate cox regression
#'
#' This function combines the results from multiple calls of \code{cox_output} and prints the output
#' as an htmlTable generated with the \code{htmlTable} package or the output of multivariate cox regression.
#' @param data data.frame or data.table containing survival data.
#' @param time1 the time interval from start of observation until date of event (e.g. disease progression or death)
#' or censoring.
#' @param time2 ending time of the interval for interval censored or counting process data only. Intervals are assumed to be open on the left and closed on the right, (start, end]. For counting process data, event indicates whether an event o
#' @param status variable specifying if event occured or data has been censored.
#' @param vars one or more variables defined as character strings to be included in the table
#' @param rgroup a vector of character strings containing headings for row groups.
#' @param footnote character string passed on to \code{tfoot} argument of \code{htmlTable}
#' @param printHTML Logical value. If TRUE output is printed as htmlTable. Default is TRUE.
#' @param weights character variable specifying the name of the weights column. Weights have to be added to the original dataframe in order to be applied correctly.
#' @param univariate Logical value. If TRUE output of univariate cox regression is printed. Else output of multivariate
#' cox regression is printed. Default is TRUE.
#' @param ... additional arguments to be passed on to \code{cox_output}
#' @export


cox_table_time_dependent_cov <- function(data, time1, time2, status, vars, rgroup = NULL, footnote = NULL,
                      printHTML = TRUE, univariate = TRUE, weights = NULL, ...){

  if(is.null(rgroup)){
    rgroup <- vars
  }

  n <- length(vars)
  tmp <- lapply(vars, cox_output_time_dependent_cov, data = data, time1 = time1, time2 = time2, status = status, weights = weights, ...)
  res <- lapply(1:n, function(x){
    if(dim(tmp[[x]])[1] == 1) {
      tmp[[x]]
    }
    else {
      tmp[[x]][-1,]
    }
  })
  out <- dplyr::bind_rows(res)
  n.rgroup <- unlist(lapply(1:n, function(x) dim(res[[x]])[1]))
  pvals <- unlist(lapply(1:n, function(x){tmp[[x]][1,]$pvalue}))

  # set attribute argument of rgroup to add global pvalues to the end of the column (wald-test)
  attr_pval <- sapply(1:n, function(x){list(pvals[x])})
  names(attr_pval) <- 1:n
  attr(rgroup, "add") <- attr_pval

  if (univariate == FALSE){
    out <- cox_output_time_dependent_cov(data = data, time1 = time1, time2 = time2, status = status, vars = vars, ...)
    attr(rgroup, "add") <- NULL
  }

  rownames(out) <- gsub(">=", "&#8805", rownames(out))
  if (printHTML == TRUE){
    htmlTable::htmlTable(out, tfoot = footnote, rgroup = rgroup, n.rgroup = n.rgroup)
  } else{
    list(res = out, rgroup = rgroup, n.group = n.rgroup)
  }
}