R/relative.array-class.R

In MBNMAdose: Dose-Response MBNMA Models

##############################################
#### Functions for class("relative.array") ####
##############################################


#' Print posterior medians (95% credible intervals) for table of relative effects/mean
#' differences between treatments/classes
#'
#' @param x An object of class `"relative.array"` generated by `get.relative()`
#' @param digits An integer indicating the number of significant digits to be used.
#' @param ... further arguments passed to `knitr::kable`
#'
#' @export
print.relative.array <- function(x, digits=2, ...) {

  attrs <- attributes(x)
  xmat <- x$relarray

  if (attrs$lim=="cred") {
    lim <- "credible"
  } else if (attrs$lim=="pred") {
    lim <- "prediction"
  }

  outmat <- matrix(nrow=nrow(xmat), ncol=ncol(xmat))
  # dimnames(outmat)[[1]] <- dimnames(xmat)[[1]]
  # dimnames(outmat)[[2]] <- dimnames(xmat)[[2]]

  for (i in 1:nrow(xmat)) {
    for (k in 1:ncol(xmat)) {
      if (!is.na(xmat[i,k,1])) {
        outmat[i,k] <- neatCrI(stats::quantile(xmat[i,k,], probs=c(0.025, 0.5, 0.975)), digits = digits)
      }
    }
  }
  diag(outmat) <- dimnames(xmat)[[1]]

  cat(crayon::bold(paste0("============================================================\nRelative treatment comparisons (95% ", lim, " intervals)\n============================================================\n")))
  cat("\n")
  #knitr::kable(outmat, ...)

  utils::write.table(format(outmat, justify="centre"), row.names = FALSE, col.names = FALSE, quote=FALSE)
}





#' Rank relative effects obtained between specific doses
#'
#' Ranks `"relative.table"` objects generated by `get.relative()`.
#'
#' @inheritParams rank.mbnma
#' @inheritParams plot.mbnma.predict
#'
#' @return An object of `class("mbnma.rank")` which is a list containing a summary data
#' frame, a matrix of rankings for each MCMC iteration, and a matrix of probabilities
#' that each agent has a particular rank, for each parameter that has been ranked.
#'
#' @examples
#' \donttest{
#' # Using the triptans data
#' network <- mbnma.network(triptans)
#'
#' # Rank selected predictions from an Emax dose-response MBNMA
#' emax <- mbnma.run(network, fun=demax(), method="random")
#' rels <- get.relative(emax)
#' rank <- rank(rels, lower_better=TRUE)
#'
#' # Print and generate summary data frame for `mbnma.rank` object
#' summary(rank)
#' print(rank)
#'
#' # Plot `mbnma.rank` object
#' plot(rank)
#' }
#'
#' @export
rank.relative.array <- function(x, lower_better=TRUE, ...) {

  # Checks
  argcheck <- checkmate::makeAssertCollection()
  checkmate::assertClass(x, classes="relative.array", add=argcheck)
  checkmate::assertLogical(lower_better, add=argcheck)
  checkmate::reportAssertions(argcheck)

  # Generate matrix of rankings
  treats <- colnames(x$mean)
  rank.mat <- t(x$relarray[1,,])

  # Assign ranks
  rank.mat <- t(apply(rank.mat, MARGIN=1, FUN=function(x) {
    order(order(x, decreasing = lower_better), decreasing=FALSE)
  }))

  sumrank <- sumrank(rank.mat)
  sumrank$rank.param <- treats[as.numeric(sumrank$rank.param)]

  colnames(rank.mat) <- treats

  # Probability matrix
  prob.mat <- calcprob(rank.mat, treats=treats)

  # Calculate cumulative ranking probabilities
  cum.mat <- apply(prob.mat, MARGIN=2,
                   FUN=function(col) {cumsum(col)})

  result <- list("summary"=sumrank,
                 "prob.matrix"=prob.mat,
                 "rank.matrix"=rank.mat,
                 "cum.matrix"=cum.mat)
  result <- list("RelativeEffects"=result)

  attributes(result) <- list("class"="mbnma.rank",
                             "names"=names(result),
                             "lower_better"=lower_better,
                             "level"="relefs"
  )

  return(result)

}