R/bugs.script.R

In MultiBUGS/R2MultiBUGS: Running MultiBUGS from R

#' Writes script for running MultiBUGS
#'
#' Write file \file{script.txt} for \pkg{MultiBUGS} to read - intended for
#' internal use
#'
#' @param parameters.to.save parameters that should be monitored
#' @param n.chains number of Markov chains
#' @param n.iter number of total iterations (including burn in)
#' @param n.burnin length of burn in
#' @param n.thin thinning parameter
#' @param n.workers number of worker processes to distribute computation across
#' @param saveExec If TRUE, a re-startable image of the MultiBUGS execution is
#' saved with \code{basename(model.file)} and extension .bug in the working
#' directory, which must be specified.  The .bug files can be large, so users
#' should monitor them carefully and remove them when not needed.
#' @param restart If TRUE, execution resumes with the final status from the
#' previous execution stored in the .bug file in the working directory.
#'
#' If \code{n.burnin=0}, additional iterations are performed and all iterations
#' since the previous burnin are used (including those from past executions).
#' If \code{n.burnin>0}, a new burnin is performed, and the previous iterations
#' are discarded, but execution continues from the status at the end of the
#' previous execution. When \code{restart=TRUE}, only \code{n.burnin},
#' \code{n.iter}, and \code{saveExec} inputs should be changed from the call
#' creating the .bug file, otherwise failed or erratic results may be produced.
#' @param model.file.bug If saveExec or restart is TRUE, then
#' \code{model.file.bug} receives/contains the MultiBUGS program image for
#' restarting the program. \code{model.file.bug} is the name of the file with
#' its full path
#' @param model.file file containing the model written in \pkg{MultiBUGS} code
#' @param debug if \code{FALSE}, \pkg{MultiBUGS} is closed automatically,
#' otherwise \pkg{MultiBUGS} remains open for further investigation. With
#' \code{debug} = \code{TRUE}, no modelQuit() command is added to the end of
#' the script, which can cause an infinite loop with linux execution.
#' @param is.inits logical; whether initial values are given by the user
#' (\code{TRUE}) or have to be generated by \pkg{MultiBUGS}
#' @param DIC logical; if \code{TRUE}, compute deviance, pD, and DIC
#' automatically in \pkg{MultiBUGS}
#' @param useWINE as in \code{\link{bugs}} meta function
#' @param newWINE as in \code{\link{bugs}} meta function
#' @param WINEPATH as in \code{\link{bugs}} meta function
#' @param bugs.seed random seed for \pkg{MultiBUGS} (default is no seed
#' specified)
#' @param summary.only If \code{TRUE}, only a parameter summary for very quick
#' analyses is given, temporary created files are not removed in that case.
#' @param save.history If \code{TRUE} (the default), trace plots are generated
#' at the end.
#' @param bugs.data.file character name of the data file
#' @param bugs.inits.files character vector of names of the inits files
#' @param over.relax If \code{TRUE}, over-relaxed form of MCMC is used if
#' available from MultiBUGS.
#' @return Nothing, but as a side effect, the script file \file{script.txt} is
#' written
#' @seealso The main function to be called by the user is \code{\link{bugs}}.
#' @keywords internal file IO
bugs.script <- function(parameters.to.save,
                        n.chains,
                        n.iter,
                        n.burnin,
                        n.thin,
                        n.workers,
                        saveExec,
                        restart,
                        model.file.bug,
                        model.file,
                        debug = FALSE,
                        is.inits,
                        fix.founders,
                        DIC = FALSE,
                        useWINE = FALSE,
                        newWINE = TRUE,
                        WINEPATH = NULL,
                        bugs.seed = NULL,
                        summary.only = FALSE,
                        save.history = (.Platform$OS.type == "windows" |
                                          useWINE == TRUE),
                        bugs.data.file,
                        bugs.inits.files,
                        over.relax = FALSE){
  # restart not suppored in MultiBUGS at the moment afaik
  if (restart){
    stop("restart = TRUE is not yet supported by R2MultiBUGS")
  }

  ## Write file script.txt for Bugs
  if (n.iter - n.burnin < 2){
    stop("(n.iter-n.burnin) must be at least 2")
  }
  working.directory <- getwd()
  script <- "script.txt"

  model <- if (length(grep("\\\\", model.file)) ||
                 length(grep("/", model.file))){
    gsub("\\\\", "/", model.file)
  } else {
    file.path(working.directory, model.file)
  }
  model <- native2win(model,
                      useWINE = useWINE,
                      newWINE = newWINE,
                      WINEPATH = WINEPATH)

  data <- file.path(working.directory, bugs.data.file)
  data <- native2win(data,
                     useWINE = useWINE,
                     newWINE = newWINE,
                     WINEPATH = WINEPATH)

  coda <- file.path(working.directory, "/")
  coda <- native2win(coda,
                     useWINE = useWINE,
                     newWINE = newWINE,
                     WINEPATH = WINEPATH)

  model.file.bug <- file.path(working.directory, model.file.bug)
  model.file.bug <- native2win(model.file.bug,
                               useWINE = useWINE,
                               newWINE = newWINE,
                               WINEPATH = WINEPATH)

  logFile <- file.path(working.directory, "log.odc")
  logFile <- native2win(logFile,
                        useWINE = useWINE,
                        newWINE = newWINE,
                        WINEPATH = WINEPATH)
  logFileTxt <- file.path(working.directory, "log.txt")
  logFileTxt <- native2win(logFileTxt,
                           useWINE = useWINE,
                           newWINE = newWINE,
                           WINEPATH = WINEPATH)

  inits <- paste(working.directory, "/", bugs.inits.files, sep = "")
  inits <- sapply(inits,
                  useWINE = useWINE,
                  newWINE = newWINE,
                  WINEPATH = WINEPATH,
                  function(x, useWINE, newWINE, WINEPATH){
                    native2win(x,
                               useWINE = useWINE,
                               newWINE = newWINE,
                               WINEPATH = WINEPATH)
                  })

  initlist <- paste("modelInits(", "'", inits, "',", 1:n.chains, ")\n",
                    sep = "")

  if (fix.founders){
    geninitlist <- "modelGenInits()\n"
  } else {
    geninitlist <- "modelGenInits(\"F\")\n"
  }

  savelist <- paste("samplesSet(", parameters.to.save, ")\n", sep = "")
  summarylist <- paste("summarySet(", parameters.to.save, ")\n", sep = "")

  bugs.seed.cmd <- ""
  if (!is.null(bugs.seed)){
    bugs.seed.cmd <- paste("modelSetRN(", bugs.seed, ")\n", sep = "")
  }

  thinUpdate <- paste("modelUpdate(",
                      formatC(n.burnin, format = "d"),
                      ",",
                      n.thin,
                      ",",
                      formatC(n.burnin, format = "d"), ")\n",
                      sep = "")

  cat(
    "modelDisplay('log')\n",
    if (restart){
      c("modelInternalize('", model.file.bug, "')\n")
    },
    if (restart && n.burnin > 0){
      c("samplesClear('*')\n", "summaryClear('*')\n")
    },
    if (!restart){
      c("modelCheck('", model, "')\n",
        "modelData('", data, "')\n",
        "modelCompile(", n.chains, ")\n")
    },
    if (!restart){
      bugs.seed.cmd
    },
    if (!restart && is.inits){
      initlist
    },
    if (!restart){
      geninitlist
    },
    if (!restart){
      c("modelDistribute(", n.workers, ")\n")
    },
    if (!restart && over.relax){
      "over.relax(\"yes\")\n"
    },
    if ((!restart) || (n.burnin > 0)){
      c(thinUpdate, savelist, summarylist)
    },
    if (((!restart) || (n.burnin > 0)) && DIC){
      "dicSetS()\n"
    },
    "modelUpdate(",
    formatC(n.iter - n.burnin, format = "d"),
    ",",
    n.thin,
    ",",
    formatC(n.iter - n.burnin, format = "d"),
    ")\n",
    "samplesCoda('*', '",
    coda,
    "')\n",
    "summaryStats('*')\n",
    if (DIC){
      "dicStats()\n"
    },
    if (save.history){
      "samplesHistory('*')\n"
    },
    if (saveExec){
      c("modelExternalize('", model.file.bug, "')\n")
    },
    c("modelSaveLog('",
      logFile,
      "')\n", "modelSaveLog('",
      logFileTxt,
      "')\n"),
    file = script,
    sep = "",
    append = FALSE
  )

  if (!debug){
    cat("modelQuit('y')\n", file = script, append = TRUE)
  }

  sims.files <- paste("CODAchain", 1:n.chains, ".txt", sep = "")
  for (i in 1:n.chains){
    cat("MultiBUGS did not run correctly.\n",
        file = sims.files[i],
        append = FALSE)
  }
}