R/write.functions.R

In MBNMAdose: Dose-Response MBNMA Models

# Functions for writing MBNMA models
# Author: Hugo Pedder
# Date created: 2019-04-16

## quiets concerns of R CMD check re: the .'s that appear in pipelines
if(getRversion() >= "2.15.1")  utils::globalVariables(c(".", "studyID", "agent", "dose", "Var1", "value",
                                                        "Parameter", "fupdose", "groupvar", "y",
                                                        "network", "a", "param", "med", "l95", "u95", "value",
                                                        "Estimate", "2.5%", "50%", "97.5%", "treatment"))






#' Writes insert points for RegEx in MBNMA JAGS code
#'
#' @return A list with named elements containing character strings that match
#'   points in MBNMA JAGS code. These points can therefore be used to insert
#'   other lines of JAGS code into the correct section within the overall model
#'   code.
#' @noRd
#' @examples
#' inserts <- write.inserts()
#'
write.inserts <- function() {
  insert.start <- "(+.# Begin Model Code\n)(+.)"
  insert.study <- "(+.# Run through all NS trials\n)(+.)"
  insert.arm <- "(+.# Run through all arms within a study\n)(+.)"
  insert.te <- "(+.# Treatment effects\n)(+.)"
  insert.te.priors <- "(+.# Priors on relative treatment effects\n)(+.)"
  insert.end <- "(.+)(\n# Model ends)"
  insert.class.priors <- "(+.# Priors on relative class effects\n)(+.)"
  insert.ume.ref.priors <- "(+.# UME prior ref\n)(+.)"
  insert.ume.priors <- "(+.# UME priors\n)(+.)"

  return(inserts <- list("insert.start"=insert.start,
                         "insert.study"=insert.study,
                         "insert.arm"=insert.arm,
                         "insert.te"=insert.te,
                         "insert.te.priors"=insert.te.priors,
                         "insert.end"=insert.end,
                         "insert.class.priors"=insert.class.priors,
                         "insert.ume.ref.priors"=insert.ume.ref.priors,
                         "insert.ume.priors"=insert.ume.priors
  ))
}






#' Get current priors from JAGS model code
#'
#' Identical to `get.prior()` in `MBNMAtime` package.
#' This function takes JAGS model presented as a string and identifies what
#' prior values have been used for calculation.
#'
#' @param model A character object of JAGS MBNMA model code
#'
#' @return A character vector, each element of which is a line of JAGS code
#'   corresponding to a prior in the JAGS code.
#'
#' @details Even if an MBNMA model that has not initialised successfully and
#'   results have not been calculated, the JAGS model for it is saved in
#'   `mbnma$model.arg$jagscode` and therefore priors can still be obtained.
#'   This allows for priors to be changed even in failing models, which may help
#'   solve issues with compiling or updating.
#'
#' @examples
#' \donttest{
#' # Using the triptans data
#' network <- mbnma.network(triptans)
#'
#' # Run an Emax dose-response MBNMA
#' result <- mbnma.run(network, fun=demax(), method="random")
#'
#' # Obtain model prior values
#' print(result$model.arg$priors)
#'
#' # Priors when using mbnma.run with an exponential function
#' result <- mbnma.run(network, fun=dexp(), method="random")
#' print(result$model.arg$priors)
#' }
#'
#' @export
get.prior <- function(model) {

  # Run Checks
  checkmate::assertCharacter(model)

  #model <- strsplit(mbnma$model.arg$jagscode, split="\n")[[1]]
  # model <- strsplit(model, split="\n")[[1]]
  #priors <- model[grep(".+~ [A-z]+\\([-?0-9]", model)]

  priorcode <- model[c(grep("^.+~ [A-z]+\\([-?0-9]", model),
                       grep("^.+~ [A-z]+\\(omega", model))]

  priorlist <- strsplit(priorcode, split=" +?~ +?")
  priors <- list()
  for (i in seq_along(priorlist)) {
    priorname <- unlist(strsplit(priorlist[[i]][1], split="\\["))[1]
    priors[[priorname]] <- priorlist[[i]][2]
  }

  return(priors)
}






#' Replace original priors in an MBNMA model with new priors
#'
#' Identical to `get.prior()` in `MBNMAtime` package.
#'
#' This function takes new priors, as specified by the user, and adds them to
#' the JAGS code from an MBNMA model. New priors replace old priors in the JAGS
#' model.
#'
#' @inheritParams get.prior
#' @param mbnma An S3 object of class `c("mbnma", "rjags")` generated by running a
#'   dose-response MBNMA model.
#'
#' @details Values in `priors` can include any JAGS functions/distributions
#'   (e.g. censoring/truncation).
#' @noRd
#'
#' @return A character object of JAGS MBNMA model code that includes the new
#'   priors in place of original priors
#'
replace.prior <- function(priors, model=NULL, mbnma=NULL) {

  # Run Checks
  argcheck <- checkmate::makeAssertCollection()
  checkmate::assertClass(mbnma, "mbnma", null.ok=TRUE, add=argcheck)
  checkmate::assertCharacter(model, null.ok=TRUE, add=argcheck)
  checkmate::assertList(priors, add=argcheck)
  checkmate::reportAssertions(argcheck)

  if (!is.null(mbnma) & !is.null(model)) {
    stop("Must provide EITHER an existing MBNMA model (using `mbnma`) OR MBNMA JAGS code (using `model`)")
  }

  if (!is.null(mbnma)) {
    # model <- strsplit(mbnma$model.arg$jagscode, split="\n")[[1]]
    model <- mbnma$model.arg$jagscode
  } else if (!is.null(model)) {
  } else {
    stop("Must provide EITHER an existing MBNMA model (using `mbnma`) OR MBNMA JAGS code (using `model`)")
  }

  for (i in seq_along(priors)) {
    # Checks
    if (length(grep(paste0("^( +)?", names(priors)[i]), model))==0) {
      stop("Prior named ", names(priors)[i], " not found in the model code. Check priors currently present in model code using get.prior()")
    }

    line <- grep(paste0("^( +)?", names(priors)[i], ".+~"), model)
    state <- model[line]

    if (length(priors[[i]])==1) {
      model[line] <- gsub("(^.+~ )(.+$)", paste0("\\1", priors[[i]]), state)

    } else {
      # What if length of priors[[i]]>1 ?
      # Find previous { in code and add priors as new lines there

      # Identifies loop above which to insert
      insert <- max(grep("\\{", model)[grep("\\{", model) < line])

      # Indentifies starting index in the loop (e.g. from 1: or 2:)
      loopind <- as.numeric(gsub("\\D", "", model[insert]))

      # Creates vector of priors
      priors.insert <- paste0(names(priors)[i], "[",
                              loopind:(length(priors[[i]])+loopind-1),
                              "] ~ ", priors[[i]])

      # Drop previous prior line
      model <- model[-line]
      model <- c(model[1:(insert-1)],
                 priors.insert,
                 model[insert:length(model)])

    }
  }

  # Cut irrelevant section from JAGS code
  start <- grep("^model\\{", model)
  end <- grep("# Model ends", model) + 1

  # model <- paste(model[start:end], collapse="\n")
  model <- model[start:end]

  return(model)
}