#
GNU General Public License
################################################################
################################################################
#
# BRugs a minimal R interface to OpenBUGS
#
###############################################################
###############################################################
###############################################################
#
# The directory structure of the OpenBUGS software must be preseved. The
# path variable "root" must be set to the root directory where OpenBUGS is installed.
# The path variable "brugs" is the location of the dynamic link library / shared
# object
# file that allows R to access OpenBUGS. The path variable "buffer" is the location of
# a buffer file that OpenBUGS write to and R reads from. The path variable "examples"
# is where the OpenBUGS model specification, data and initial value files are stored.
#
# The R function .First.lib loads the BRugs package and the function .Last.lib
# cleans up any tempory R objects that BRugs has created.
#
# The following R function provide the user interface to BRugs
#
# model.check, model.data, model.compile, model.inits, model.gen.inits,
#
# model.adaptivePhase, model.iteration, model.update,
#
# model.set.seed, model.get.seed, model.precision, model.save.state,
#
# model.setAP, model.setIts, model.setOR,
#
# samples.set, samples.clear, samples.stats, samples.history, samples.autoC,
# samples.density, samples.bgr, samples.correl, samples.coda,
#
# samples.size, samples.sample, samples.monitors,
# samples.set.beg, samples.set.end, samples.set.firstChain, samples.set.lastChain,
# samples.set.thin,
#
# samples.get.beg, samples.get.end, samples.get.firstChain, samples.get.lastChain,
# samples.get.thin,
#
# summary.set, summary.stats, summary.clear,
#
# ranks.set, ranks.stats, ranks.clear,
#
# dic.set, dic.stats, dic.clear
#
# In general these function correspond to buttons in the dialog boxes of the OpenBUGS GUI.
# The arguments of these functions correspond to text entry fields in the dialog boxes.
# See the OpenBUGS documentation for details. Usually there are two R function for
# each OpenBUGS text entry field one to set the value of the field and the other to get
# the value of the field.
#
###############################################################
###############################################################
#
# List loaded OpenBUGS components
#
###############################################################
"model.modules"
<- function()
# List loaded OpenBUGS components
{
command <- "BugsEmbed.Modules"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
read.table(buffer)
}
###############################################################
#
# Load module
#
###############################################################
"loadModule"
<- function(module)
# Load module
{
command <- as.character(module)
len <- nchar(command)
.C("Load", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
###############################################################
#
# Loading and unloading BRugs
#
###############################################################
"examples"
<- "" # examples directory
"root"
<- "c:/OpenBUGS" # root of OpenBUGS directory structure
"tempDir"
<- "c:/temp" # temp directory used for buffer file
#
# Set the root of OpenBUGS directory structure
#
"setRootDir"
<- function(root)
# Set the root of OpenBUGS directory structure
{
len <- nchar(root)
.C("SetRootDir", as.character(root), as.integer(len))
}
#
# Set the temp directory used by OpenBUGS
#
"setTempDir"
<- function(temp)
# Set the temp directory used by OpenBUGS
{
len <- nchar(tempDir)
.C("SetTempDir", as.character(tempDir), as.integer(len))
}
#
# load BRugs library, sets path / file variables and initializes subsystems
#
".First.lib"
<- function(){
# load BRugs library, sets path / file variables and initializes subsystems
brugs <- paste(root, "/brugs", .Platform$dynlib.ext, sep = "")
dyn.load(brugs)
setRootDir(root)
setTempDir(tempDir)
command <- "INIT()"
len <- nchar(command)
.C("EmbedCommand", as.character(command), as.integer(len), integer(1))
cat("Wecome to BRugs running on OpenBUGS version 2.0", "\n")
}
#
# unload BRugs and deleteR objects corresponding to names in OpenBUGS model
#
".Last.lib"
<- function(){
# unload BRugs library
deleteRObjs()
brugs <- paste(root, "/brugs", .Platform$dynlib.ext, sep = "")
dyn.unload(brugs)
}
#############################################################
#
# Linking between quantities in OpenBUGS model and R
#
# R objects of the correct dimensions are created for each name in the OpenBUGS
# model. This allows R objects to be used as arguments of BRugs functions instead
# of having to use character strings.
# There is a problem here if names in the OpenBUGS model collide with names
# of other R objects!
#
#############################################################
#
# gets names in OpenBUGS model
#
"model.names"
<- function()
{
# gets names in OpenBUGS model
command <- "BugsRobjects.Names"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
readLines(buffer)
}
#
# Get dimension information for quantity in OpenBUGS model
#
"dimensions"
<- function(node)
# Get dimension information for quantity in OpenBUGS model
{
nodeLabel <- as.character(node)
lenLabel <- nchar(nodeLabel)
command <- "BugsRobjects.Set"
len <- nchar(command)
.C("CharArray", as.character(command), as.integer(len), as.character(nodeLabel),
as.integer(lenLabel), integer(1))
command <- "BugsRobjects.NumSlots"
len <- nchar(command)
numSlots <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
dimensions <- integer(numSlots)
command <- "BugsRobjects.Dimensions"
len <- nchar(command)
if (numSlots > 0) dimensions <- .C("IntegerArray", as.character(command), as.integer(len),
as.integer(dimensions), as.integer(numSlots), integer(1))[[3]]
else dimensions <- NULL
dimensions
}
#
# create an R object to represent name in OpenBUGS model
#
"createRObj"
<- function(name)
# create an R object to represent name in OpenBUGS model
{
dimens <- dimensions(name)
numSlots <- length(dimens)
size <- 1
if (numSlots > 0) for(i in 1:numSlots) {size <- size * dimens[i]}
indices <- ""
if (numSlots > 0) indices <- as.character(dimens[1])
if (numSlots > 1) for (i in 2:numSlots) { indices <- paste(indices, ",", as.character(dimens[i])) }
if (numSlots == 0) string <- paste(name, " <- real(1)", sep = "")
else string <- paste(name, " <- structure(real(", as.character(size), "), dim = c(",
indices, "))",sep = "")
e <- parse(text = string)
eval(e, envir = .GlobalEnv)
}
#
# Create R objects for each name in OpenBUGS model
#
"createRObjs"
<- function()
# Create R objects for each name in OpenBUGS model
{
names <- model.names()
junk <- lapply(names, createRObj)
}
#
# Delete R object corresponding to name in OpenBUGS model
#
"deleteRObj"
<- function(name)
# Delete R object corresponding to name in OpenBUGS model
{
string <- paste("rm(", name, ")", sep = "")
e <- parse(text = string)
eval(e, envir = .GlobalEnv)
}
#
# Delete all R objects corresponding to a name in OpenBUGS model
#
"deleteRObjs"
<- function()
# Delete all R objects corresponding to a name in OpenBUGS model
{
names <- model.names()
junk <- lapply(names, deleteRObj)
}
##########################################################
#
# Model specification
#
##########################################################
#
# Check that OpenBUGS model is sytaxticaly correct
#
"model.check"
<- function(fileName)
# Check that OpenBUGS model is sytaxticaly correct
{
deleteRObjs()
file <- paste("'", as.character(examples), as.character(fileName), "'", sep = "")
command <- paste("BugsEmbed.SetFilePath(", file,
");BugsEmbed.ParseGuard;BugsEmbed.Parse", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Load data for OpenBUGS model
#
"model.data"
<- function(fileName)
{
# Load data for OpenBUGS model
file <- paste("'", as.character(examples), as.character(fileName), "'", sep = "")
command <- paste("BugsEmbed.SetFilePath(", file,
");BugsEmbed.LoadDataGuard;BugsEmbed.LoadData", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Compile OpenBUGS model
#
"model.compile"
<- function(numChains = 1)
# Compile OpenBUGS model
{
command <- paste("BugsEmbed.CompileGuard",
";BugsEmbed.Compile(", as.character(numChains), ")", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
samples.set.firstChain(1)
samples.set.lastChain(numChains)
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
createRObjs()
}
#
# Get numChains field
#
"get.num.chains"
<- function()
# Get numChains field
{
command<- paste("BugsInterface.numChains")
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
}
#
# Get chain field
#
"get.chain"
<- function()
# Get chain field
{
command<- paste("BugsEmbed.chain")
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
}
#
# Load initial values for OpenBUGS model
#
"model.inits"
<- function(fileName, chainNum = get.chain())
# Load initial values for OpenBUGS model
{
file <- paste("'", as.character(examples), as.character(fileName), "'", sep = "")
command <- paste("BugsEmbed.SetFilePath(", file,
"); BugsEmbed.LoadInitsGuard; BugsEmbed.chain := ",
as.character(chainNum), "; BugsEmbed.LoadInits")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Generate initial values for OpenBUGS model
#
"model.gen.inits"
<- function()
# Generate initial values for OpenBUGS model
{
command <- paste("BugsEmbed.GenerateInitsGuard;", "BugsEmbed.GenerateInits")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
############################################################
#
# MCMC updates
#
############################################################
#
# Get iteration field
#
"model.iteration"
<- function()
# Get iteration field
{
command <- paste("BugsEmbed.iteration")
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Get endOfAdapting field
#
"model.adaptivePhase"
<- function()
# Get endOfAdapting field
{
command <- paste("BugsInterface.endOfAdapting")
len <- nchar(command)
(as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]) -1
}
#
# Update the each chain in OpenBUGS model numUpdates * thin times
#
"model.update"
<- function(numUpdates, thin = 1, overRelax = FALSE)
# Update the each chain in OpenBUGS model numUpdates * thin time
{
intOverRelax <- 0;
if(overRelax) intOverRelax <- 1
command <- paste("BugsEmbed.UpdateGuard",
";BugsEmbed.thin := ", as.character(as.integer(thin)),
";BugsEmbed.overRelax := ", as.character(as.integer(intOverRelax)),
";BugsEmbed.Update(",as.character(as.integer(numUpdates)),")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Saves the sate of each chain in OpenBUGS model
#
"model.save.state"
<- function(stem)
# Update the each chain in OpenBUGS model numUpdates * thin time
{
fileStem <- paste("'", as.character(stem), "'", sep = "")
command <- paste("BugsEmbed.UpdateGuard",
";BugsEmbed.WriteChains(", fileStem, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
###############################################################
#
# Manipulate seed of random number generator.
#
################################################################
#
# Set the seed of random number generator
#
"model.set.seed"
<- function(newSeed)
# Set the seed of random number generator
{
command <- paste("BugsEmbed.newSeed := ",
as.character(as.integer(newSeed)))
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "BugsEmbed.SetSeedGuard; BugsEmbed.SetSeed"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Get the seed of random number generator
#
"model.get.seed"
<- function()
# Get the seed of random number generator
{
command <- "BugsEmbed.GetSeed"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "BugsEmbed.newSeed"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Set the precision to which results are displayed
#
"model.precision"
<- function(prec)
# Set the precision to which results are displayed
{
command <- paste("BugsDialog.displayDialog.precision := ",
as.character(as.integer(prec)))
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#################################################################
#
# Set properties of updater
#
#################################################################
#
# Sets the adaptive phase
#
"model.setAP"
<- function(factoryName, adaptivePhase)
# Set the length of adaptive phase
{
name <- paste("'", as.character(factoryName), "'", sep = "")
command <- paste("UpdaterMethods.SetFactory(",
name,
") ;UpdaterMethods.AdaptivePhaseGuard;",
"UpdaterMethods.SetAdaptivePhase(",
as.character(adaptivePhase),
")", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
}
#
# Sets the number of iterations
#
"model.setIts"
<- function(factoryName, iterations)
# Set the length of adaptive phase
{
name <- paste("'", as.character(factoryName), "'", sep = "")
command <- paste("UpdaterMethods.SetFactory(",
name,
") ;UpdaterMethods.IterationsGuard;",
"UpdaterMethods.SetIterations(",
as.character(iterations),
")", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
}
#
# Sets over relaxation
#
"model.setOR"
<- function(factoryName, overRelaxation)
# Set the length of adaptive phase
{
name <- paste("'", as.character(factoryName), "'", sep = "")
command <- paste("UpdaterMethods.SetFactory(",
name,
") ;UpdaterMethods.OverRelaxationGuard;",
"UpdaterMethods.SetOverRelaxation(",
as.character(overRelaxation),
")", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
}
############################################################
#
# Sample monitors
#
############################################################
#
# Set the beg field
#
"samples.set.beg"
<- function(begIt)
# Set the beg field
{
command <- paste("SamplesEmbed.beg := ", as.character(as.integer(begIt)));
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Set the end field
#
"samples.set.end"
<- function(endIt)
# Set the end field
{
command <- paste("SamplesEmbed.end := ", as.character(as.integer(endIt)));
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Set the firstChain field
#
"samples.set.firstChain"
<- function(first)
# Set the firstChain field
{
command <- paste("SamplesEmbed.firstChain := ", as.character(as.integer(first)));
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Set the lastChain field
#
"samples.set.lastChain"
<- function(last)
# Set the lastChain field
{
command <- paste("SamplesEmbed.lastChain := ", as.character(as.integer(last)));
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Set the thin field
#
"samples.set.thin"
<- function(thin)
# Set the thin field
{
command <- paste("SamplesEmbed.thin := ", as.character(as.integer(thin)));
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Get the beg field
#
"samples.get.beg"
<- function()
# Get the beg field
{
command <- "SamplesEmbed.beg"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Get the end field
#
"samples.get.end"
<- function()
# Get the end field
{
command <- "SamplesEmbed.end"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Get the firstChain field
#
"samples.get.firstChain"
<- function()
# Get the firstChain field
{
command <- "SamplesEmbed.firstChain"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Get the lastChain field
#
"samples.get.lastChain"
<- function()
# Get the lastChain field
{
command <- "SamplesEmbed.lastChain"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Get the thin field
#
"samples.get.thin"
<- function()
# Get the thin field
{
command <- "SamplesEmbed.thin"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1)))[3]
}
#
# Set a sample monitor
#
"samples.set"
<- function(node)
# Set a sample monitor
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName,
");SamplesEmbed.SetGuard;SamplesEmbed.Set")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Clear a sample monitor
#
"samples.clear"
<- function(node)
# Clear a sample monitor
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName,
");SamplesEmbed.HistoryGuard;SamplesEmbed.Clear")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# List all sample monitors corresponding to node
#
"samples.monitors"
<- function(node)
# List all sample monitors corresponding to node
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName,
");SamplesEmbed.StatsGuard;SamplesEmbed.Labels")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
lines <- readLines(buffer)
len <- length(lines)
if (len == 1)
if (lines == "command is not allowed (greyed out)")
cat(readLines(buffer), "\n")
else
scan(buffer, what = "character", quiet = TRUE)
else
scan(buffer, what = "character", quiet = TRUE)
}
#
# Size of stored sample of single component of OpenBUGS name
#
"samples.size"
<- function(node)
# Size of stored sample of single component of OpenBUGS name
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "SamplesEmbed.SampleSize"
len <- nchar(command)
as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
}
#
# Get stored sample for single component of OpenBUGS name
#
"samples.sample"
<- function(node)
# Get stored sample for single component of OpenBUGS name
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "SamplesEmbed.SampleSize"
len <- nchar(command)
sampleSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
x <- real(sampleSize)
command <- "SamplesEmbed.Sample"
len <- nchar(command)
.C("RealArray", as.character(command), as.integer(len), x, as.integer(sampleSize), integer(1))[3][[1]]
}
#
# Plot auto correlation function for single component of OpenBUGS name
#
"plot.autoC"
<- function(node)
# Plot auto correlation function for single component of OpenBUGS name
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "SamplesEmbed.SampleSize"
len <- nchar(command)
sampleSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
x <- real(sampleSize)
command <- "SamplesEmbed.Sample"
len <- nchar(command)
sample <- .C("RealArray", as.character(command), as.integer(len), x,
as.integer(sampleSize), integer(1))[3][[1]]
colour <- c("red", "blue", "green", "yellow", "black")
chain <- samples.get.firstChain()
if (sd(sample) > 1.0E-10)
acf(sample, col = colour[chain], main = nodeName, lwd = 5, demean = TRUE)
}
#
# Calculate the bgr statistic at iteration
#
"bgr.point"
<- function(node, iteration)
# Calculate the bgr statistic at iteration
{
oldEnd <- samples.get.end()
samples.set.end(as.integer(iteration))
numChains <- get.num.chains()
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "SamplesEmbed.SampleSize"
len <- nchar(command)
sampleSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
x <- real(sampleSize)
command <- "SamplesEmbed.Sample"
len <- nchar(command)
sample <- .C("RealArray", as.character(command), as.integer(len), x,
as.integer(sampleSize), integer(1))[3][[1]]
lenChain <- sampleSize %/% numChains
dq <- quantile(sample, c(0.1, 0.9), names = FALSE)
d.delta <- dq[2] - dq[1]
n.delta <- 0.0
for (i in 1:numChains) {
nq <- quantile(sample[((i - 1) * lenChain + 1) : (i * lenChain)], c(0.1, 0.9), names = FALSE)
n.delta <- n.delta + nq[2] - nq[1]
}
n.delta <- n.delta / numChains
bgr.stat <- d.delta / n.delta
samples.set.end(oldEnd)
c(iteration, n.delta, d.delta, bgr.stat)
}
#
# Calculate grid of points at which to evaluate bgr statistic
#
"bgr.grid"
<- function(node)
# Calculate grid of points at which to evaluate bgr statistic
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ") END")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- paste("SamplesEmbed.SampleSize")
len <- nchar(command)
sampleSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
beg <- samples.get.beg()
end <- min(c(samples.get.end(), model.iteration()))
numChains <- samples.get.lastChain() - samples.get.firstChain() + 1
sampleSize <- sampleSize %/% numChains
beg <- end - (sampleSize - 1)
bins <- 50
delta <- sampleSize %/% bins
grid<- ((1 : (bins - 1)) * delta) + beg
grid <- c(grid, end)
grid
}
#
# Plot bgr diagnostic for single component of OpenBUGS name
#
"plot.bgr"
<- function(node)
# Plot bgr diagnostic for single component of OpenBUGS name
{
if (is.character(node)) nodeName <- as.character(node)
else nodeName <- deparse(substitute(node))
grid <- bgr.grid(nodeName)
bgr <- sapply(grid, bgr.point, node = nodeName)
yRange <- range(bgr[4,])
yRange <- c(0, max(c(1.2, yRange[2])))
nRange <- range(bgr[2,])
nRange <- c(min(c(0, nRange[1])), nRange[2])
nDelta <- nRange[2] - nRange[1]
dRange <- range(bgr[3,])
dRange <- c(min(c(0, dRange[1])), dRange[2])
dDelta <- dRange[2] - dRange[1]
max <- 2 * max(c(nDelta, dDelta))
bgr[2,] <- bgr[2,] / max
bgr[3,] <- bgr[3,] / max
plot(grid, bgr[4,], ylim = yRange, type = "n", main = nodeName, xlab = "iteration", ylab = "bgr")
lines(grid, bgr[4,], col = "red")
lines(grid, bgr[2,], col = "blue")
lines(grid, bgr[3,], col = "green")
}
#
# Plot history for single component of OpenBUGS name
#
"plot.history"
<- function(node)
# Plot history for single component of OpenBUGS name
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "SamplesEmbed.SampleSize"
len <- nchar(command)
sampleSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
x <- real(sampleSize)
command <- "SamplesEmbed.Sample"
len <- nchar(command)
sample <- .C("RealArray", as.character(command), as.integer(len), x,
as.integer(sampleSize), integer(1))[3][[1]]
end <- min(c(model.iteration(), samples.get.end()))
thin <- samples.get.thin()
numChains <- samples.get.lastChain() - samples.get.firstChain() + 1
sampleSize <- sampleSize %/% numChains
beg <- end - (sampleSize - 1) * thin
beg <- beg %/% thin
end <- end %/% thin
x <- c(beg:end) * thin
y <- sample[1:sampleSize]
plot(x, y, ylim = range(sample), type = "n", main = nodeName, xlab = "iteration", ylab = "")
colour <- c("red", "blue", "green", "yellow", "black")
for (chain in 1:numChains){
y <- sample[(1 + (chain - 1) * sampleSize):(sampleSize * chain)]
lines(x, y, col = colour[chain])
}
}
#
# Plot posterior density for single component of OpenBUGS name
#
"plot.density"
<- function(node)
# Plot posterior density for single component of OpenBUGS name
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName, ")")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
command <- "SamplesEmbed.SampleSize"
len <- nchar(command)
sampleSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1), integer(1))[3])
x <- real(sampleSize)
command <- "SamplesEmbed.Sample"
len <- nchar(command)
sample <- .C("RealArray", as.character(command), as.integer(len), x,
as.integer(sampleSize), integer(1))[3][[1]]
absSample <- abs(sample)
intSample <- as.integer(absSample + 1.0E-10)
zero <- absSample - intSample
intSample <- as.integer(sample)
if (sum(zero) > 0){
d <- density(sample, adjust = 1.25)
plot(d$x, d$y, type = "l", main = nodeName, xlab = "" , ylab = "", col = "red")}
else{
histogram <- table(intSample) / sampleSize
xRange <- range(intSample)
xLim <- c(xRange[1] - 0.5, xRange[2] + 0.5)
plot(histogram, type = "h", xlim = xLim, ylim = c(0, 1), main = nodeName, xlab = "" , ylab = "",
col = "red", lwd = 5)
}
}
#
# Plot auto correlation function
#
"samples.autoC"
<- function(node, chain, beg = samples.get.beg(), end = samples.get.end(),
thin = samples.get.thin())
# Plot auto correlation function
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
beg <- max(beg, model.adaptivePhase())
samples.set.beg(beg)
samples.set.end(end)
chain <- max(c(1, chain))
chain <- min(c(get.num.chains(), chain))
samples.set.firstChain(chain)
samples.set.lastChain(chain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node)) nodeName <- as.character(node)
else nodeName <- deparse(substitute(node))
mons <- samples.monitors(nodeName)
par(mfrow = c(3, 2), ask = TRUE, ann = TRUE)
junk <- sapply(mons, plot.autoC)
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
}
#
# Plot bgr statistic
#
"samples.bgr"
<- function(node, beg = samples.get.beg(), end = samples.get.end(),
firstChain = samples.get.firstChain(), lastChain = samples.get.lastChain(),
thin = samples.get.thin())
# Plot bgr statistic
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
beg <- max(beg, model.adaptivePhase())
samples.set.beg(beg)
samples.set.end(end)
samples.set.firstChain(firstChain)
samples.set.lastChain(lastChain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node)) nodeName <- as.character(node)
else nodeName <- deparse(substitute(node))
mons <- samples.monitors(nodeName)
par(mfrow = c(3, 2), ask = TRUE, ann = TRUE)
junk <- sapply(mons, plot.bgr)
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
}
#
# Plot history
#
"samples.history"
<- function(node, beg = samples.get.beg(), end = samples.get.end(),
firstChain = samples.get.firstChain(), lastChain = samples.get.lastChain(),
thin = samples.get.thin())
# Plot history
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
samples.set.beg(beg)
samples.set.end(end)
samples.set.firstChain(firstChain)
samples.set.lastChain(lastChain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node)) nodeName <- as.character(node)
else nodeName <- deparse(substitute(node))
mons <- samples.monitors(nodeName)
par(mfrow = c(3, 1), ask = TRUE, ann = TRUE)
junk <- sapply(mons, plot.history)
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
}
#
# Plot posterior density
#
"samples.density"
<- function(node, beg = samples.get.beg(), end = samples.get.end(),
firstChain = samples.get.firstChain(), lastChain = samples.get.lastChain(),
thin = samples.get.thin())
# Plot posterior density
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
beg <- max(beg, model.adaptivePhase())
samples.set.beg(beg)
samples.set.end(end)
samples.set.firstChain(firstChain)
samples.set.lastChain(lastChain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node)) nodeName <- as.character(node)
else nodeName <- deparse(substitute(node))
mons <- samples.monitors(nodeName)
par(mfrow = c(3, 2), ask = TRUE, ann = TRUE)
junk <- sapply(mons, plot.density)
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
}
#
# Calculate statistics for monitored node
#
"samples.stats"
<- function(node, beg = samples.get.beg(), end = samples.get.end(),
firstChain = samples.get.firstChain(), lastChain = samples.get.lastChain(),
thin = samples.get.thin())
# Calculate statistics for monitored node
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
samples.set.beg(beg)
samples.set.end(end)
samples.set.firstChain(firstChain)
samples.set.lastChain(lastChain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName,
");SamplesEmbed.StatsGuard", "SamplesEmbed.Stats")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
buffer <- paste(tempDir, "/buffer.txt", sep = "")
len <- length(readLines(buffer))
if (len > 1)
read.table(buffer)
else
cat(readLines(buffer), "\n")
}
#
# Write out CODA files
#
"samples.coda"
<- function(node, stem, beg = samples.get.beg(), end = samples.get.end(),
firstChain = samples.get.firstChain(), lastChain = samples.get.lastChain(),
thin = samples.get.thin())
# Write out CODA files
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
beg <- max(beg, model.adaptivePhase())
samples.set.beg(beg)
samples.set.end(end)
samples.set.firstChain(firstChain)
samples.set.lastChain(lastChain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
fileStem <- paste("'", as.character(stem), "'", sep = "")
command <- paste("SamplesEmbed.SetVariable(", nodeName,
");SamplesEmbed.StatsGuard", "SamplesEmbed.CODA(",
fileStem, ")", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
}
#
# Correlation matrix of two quantities in OpenBUGS model
#
"samples.correl"
<- function(node0, node1,beg = samples.get.beg(), end = samples.get.end(),
firstChain = samples.get.firstChain(), lastChain = samples.get.lastChain(),
thin = samples.get.thin())
# Correlation matrix of two quantities in OpenBUGS model
# is brocken not getting beg end etc set in CorrelEmbed
{
oldBeg <- samples.get.beg()
oldEnd <- samples.get.end()
oldFirstChain <- samples.get.firstChain()
oldLastChain <- samples.get.lastChain()
oldThin <- samples.get.thin()
samples.set.beg(beg)
samples.set.end(end)
samples.set.firstChain(firstChain)
samples.set.lastChain(lastChain)
thin <- max(c(thin, 1))
samples.set.thin(thin)
if (is.character(node0)) nodeName0 <- paste("'", as.character(node0), "'", sep = "")
else nodeName0 <- paste("'", deparse(substitute(node0)), "'", sep = "")
if (is.character(node1)) nodeName1 <- paste("'", as.character(node1), "'", sep = "")
else nodeName1 <- paste("'", deparse(substitute(node1)), "'", sep = "")
command <- paste("CorrelEmbed.SetVariable0(", nodeName0,
");CorrelEmbed.SetVariable1(", nodeName1,
");CorrelEmbed.Guard", ";CorrelEmbed.PrintMatrix", sep = "")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
samples.set.beg(oldBeg)
samples.set.end(oldEnd)
samples.set.firstChain(oldFirstChain)
samples.set.lastChain(oldLastChain)
samples.set.thin(oldThin)
buffer <- paste(tempDir, "/buffer.txt", sep = "")
len <- length(readLines(buffer))
if (len > 1)
read.table(buffer)
else
cat(readLines(buffer), "\n")
}
####################################################################
#
# Summary statistics
#
####################################################################
#
# Set summary monitor for node in OpenBUGS model
#
"summary.set"
<- function(node)
# Set summary monitor for node in OpenBUGS model
{
if(is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SummaryEmbed.SetVariable(", nodeName, "); SummaryEmbed.SetGuard",
"SummaryEmbed.Set")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Clear summary monitor for node in OpenBUGS model
#
"summary.clear"
<- function(node)
# Clear summary monitor for node in WQinBUGS model
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SummaryEmbed.SetVariable(", nodeName, ") SummaryEmbed.StatsGuard",
"SummaryEmbed.Clear")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Calculates statistics for summary monitor associated with node in OpenBUGS model
#
"summary.stats"
<- function(node)
# Calculates statistics for summary monitor associated with node in OpenBUGS model
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("SummaryEmbed.SetVariable(", nodeName, ") SummaryEmbed.StatsGuard",
"SummaryEmbed.Stats")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
len <- length(readLines(buffer))
if (len > 1)
read.table(buffer)
else
cat(readLines(buffer), "\n")
}
################################################################
#
# Rank monitor
#
#################################################################
#
# Set a ranks monitor for vector quantity node in OpenBUGS model
#
"ranks.set"
<- function(node)
# Set a ranks monitor for vector quantity node in OpenBUGS model
{
if(is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("RanksEmbed.SetVariable(", nodeName, ") RanksEmbed.SetGuard",
"RanksEmbed.Set")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Clears a ranks monitor for vector quantity in OpenBUGS model
#
"ranks.clear"
<- function(node)
# Clears a ranks monitor for vector quantity in OpenBUGS model
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("RanksEmbed.SetVariable(", nodeName, ") RanksEmbed.StatsGuard",
"RanksEmbed.Clear")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Calculates ranks statistics for vector valued node in OpenBUGS model
#
"ranks.stats"
<- function(node)
# Calculates ranks statistics for vector valued node in OpenBUGS model
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("RanksEmbed.SetVariable(", nodeName, ") RanksEmbed.StatsGuard",
"RanksEmbed.Stats")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
len <- length(readLines(buffer))
if (len > 1)
read.table(buffer)
else
cat(readLines(buffer), "\n")
}
#################################################################
#
# Deviance information
#
#################################################################
#
# Set a monitor for dic
#
"dic.set"
<- function()
# Set a monitor for dic
{
command <- "DevianceEmbed.SetGuard;DevianceEmbed.Set"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
cat(readLines(buffer), "\n")
}
#
# Clear monitor for dic
#
"dic.clear"
<- function()
# Clear monitor for dic
{
command <- "DevianceEmbed.StatsGuard;DevianceEmbed.Clear"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
cat("")
}
#
# Calculate dic statistics
#
"dic.stats"
<- function()
# Calculate dic statistics
{
command <- "DevianceEmbed.StatsGuard;DevianceEmbed.Stats"
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
len <- length(readLines(buffer))
if (len > 1)
read.table(buffer)
else
cat(readLines(buffer), "\n")
}
##################################################################
#
# Set values and get values of quanties in OpenBUGS model
#
##################################################################
"current.values"
<- function(nodeLabel)
# Get current value of node
{
nodeLabel <- as.character(nodeLabel)
lenLabel <- nchar(nodeLabel)
command <- paste("BugsRobjects.Set")
len <- nchar(command)
.C("CharArray", as.character(command), as.integer(len), as.character(nodeLabel),
as.integer(lenLabel), integer(1))
command <- paste("BugsRobjets.Size");
len <- nchar(command)
nodeSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1),
integer(1))[3])
command <- paste("BugsRobjects.Values")
len <- nchar(command)
values <- real(nodeSize);
for (i in 1: nodeSize){ values[i] <- NA }
.C("RealArray", as.character(command), as.integer(len), values, as.integer(nodeSize),
integer(1))[[3]]
}
"set.values"
<- function(nodeLabel, values)
# set value of node
{
nodeLabel <- as.character(nodeLabel)
lenLabel <- nchar(nodeLabel)
command <- paste("BugsRobjects.Set")
len <- nchar(command)
.C("CharArray", as.character(command), as.integer(len), as.character(nodeLabel),
as.integer(lenLabel), integer(1))
command <- paste("BugsRobjets.Size");
len <- nchar(command)
nodeSize <- as.integer(.C("Integer", as.character(command), as.integer(len), integer(1),
# check length(values) == nodeSize
command <- paste("BugsRobjects.SetValues")
len <- nchar(command)
.C("RealArray", as.character(command), as.integer(len), values, as.integer(nodeSize),
integer(1))[[4]]
}
#####################################################################
#
# Get type info about OpenBUGS objects
#
#####################################################################
#
# Get type of GraphNode objects
#
"get.graphObj"
<- function(node)
# Get type of GraphNode objects
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("BugsEmbed.SetVariable(", nodeName, "); BugsEmbed.Nodes")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
read.table(buffer)
}
#
# Get type of UpdaterUpdaters objects
#
"get.updaterObj"
<- function(node)
# Get type of UpdaterUpdaters objects
{
if (is.character(node)) nodeName <- paste("'", as.character(node), "'", sep = "")
else nodeName <- paste("'", deparse(substitute(node)), "'", sep = "")
command <- paste("BugsEmbed.SetVariable(", nodeName, "); BugsEmbed.Methods")
len <- nchar(command)
.C("CmdInterpreter", as.character(command), as.integer(len), integer(1))
buffer <- paste(tempDir, "/buffer.txt", sep = "")
read.table(buffer)
}