Nothing
############################################
# Add to NAMESPACE
# S3method(toLatex, marssMODEL)
# S3method(toLatex, marssMLE)
#############################################
toLatex.marssMLE <- function(object, ..., file = NULL, digits = 2, greek = TRUE, orientation = "landscape", math.sty = "amsmath", output = c("pdf", "tex", "rawtex"), replace = TRUE, simplify = TRUE) {
toLatex.marssMODEL(object$model, ..., file = file, digits = digits, greek = greek, orientation = orientation, math.sty = math.sty, output = output, replace = replace, simplify = simplify)
}
toLatex.marssMODEL <- function(object, ..., file = NULL, digits = 2, greek = TRUE, orientation = "landscape", math.sty = "amsmath", output = c("pdf", "tex", "rawtex"), replace = TRUE, simplify = TRUE) {
output <- match.arg(output)
# by default uses geometry package and amsmath
requireNamespace("Hmisc")
x <- object
# set the environment of the subfunction to this function since I want them to have access to the passed in variables
# environment(build.eqn.tex)=environment()
# environment(get.mat.tex)=environment()
# environment(parameters.time.varying)=environment()
# set up the headers and footers
eqn.head <- "\\begin{gather*}"
eqn.foot <- "\\end{gather*}"
mat.head <- "\\begin{bmatrix}"
mat.foot <- "\\end{bmatrix}"
marssMODEL <- x # used below
# get the model from x (x is a marssMODEL object)
fixed <- x$fixed
free <- x$free
# btw, this is not robust to name changes
m <- dim(fixed$x0)[1]
n <- dim(x$data)[1]
TT <- dim(x$data)[2]
model.dims <- attr(x, "model.dims")
model.el <- attr(x, "par.names")
# read in the equation from the attributes. This will be used to construct the tex
# needs to look like x=A*x+B*C*D+E+..+w, w~MVN(E+F+..,G+H+...)\n next eqn
eqns <- attr(x, "equation")
eqns <- strsplit(eqns, "\n")[[1]]
# Build a vector of all the special names in all the equations; lhs of = and ~
# Do some testing too and determine if time will be expanded
eqn.special <- c()
# the default behavior is no time expansion
eqn.ts <- 1
time.expand <- FALSE
for (i in 1:length(eqns)) {
eqn <- eqns[i]
if (!str_detect(eqn, "=")) stop("toLatex.marssMODEL: the atttibute, equation, must have the form x=... or y=....")
eqn.name <- str_trim(strsplit(eqn, "=")[[1]][1])
# the part to the left of , is the deterministic part + random bit in last term
# the eqn for the errors is after the ,
eqn.stoc <- str_trim(strsplit(eqn, ";")[[1]][2])
# the name is before the ~
err.name <- str_trim(strsplit(eqn.stoc, "~")[[1]][1])
# the eqn.name (like x or y) and the err.name (like w or v) are treated differently
eqn.special <- c(eqn.special, str_trim(strsplit(eqn.name, "_")[[1]][1]), str_trim(strsplit(err.name, "_")[[1]][1]))
if (!str_detect(eqn, "=")) stop("toLatex.marssMODEL: the atttibute, equation, must have the form x=... or y=....")
eqn.name <- str_trim(strsplit(eqn, "=")[[1]][1])
# the part to the left of , is the deterministic part + random bit in last term
eqn.det <- str_trim(strsplit(eqn, ";")[[1]][1])
# the eqn for the errors is after the ,
eqn.stoc <- str_trim(strsplit(eqn, ";")[[1]][2])
# the name is before the ~
err.name <- str_trim(strsplit(eqn.stoc, "~")[[1]][1])
# check that the name of the errors matches before and after the ,
tmp <- strsplit(eqn.det, "[+]")[[1]] # tmp[length(tmp)] should be error part
tmp <- strsplit(tmp[length(tmp)], "[*]")[[1]] # tmp[length(tmp)] should be err.name
if (err.name != str_trim(tmp[length(tmp)])) stop("toLatex.marssMODEL: in the attribute, equation, the name of the errors after the , does not match the name before the ,")
# these 2 lines get the bit between ( and ,
eqn.stoc.mean <- strsplit(eqn.stoc, ",")[[1]][1]
eqn.stoc.mean <- str_trim(strsplit(eqn.stoc.mean, "[(]")[[1]][2])
# these 2 lines get the bit between , and )
eqn.stoc.var <- strsplit(eqn.stoc, "[)]")[[1]][1]
eqn.stoc.var <- str_trim(strsplit(eqn.stoc.var, ",")[[1]][2])
# If any of the equation is time-varying then will have 1 equation for each time
# Determine if that is necessary
if (!simplify && (parameters.time.varying(eqn.det, eqn.special, marssMODEL) |
parameters.time.varying(eqn.stoc.mean, eqn.special, marssMODEL) |
parameters.time.varying(eqn.stoc.var, eqn.special, marssMODEL))) {
eqn.ts <- TT
time.expand <- TRUE
}
}
all.t.eqn.tex <- c() # this will be all the equations
for (t in 1:eqn.ts) { # one eqn for each time step; default is to simplify and not time expand
eqn.tex <- c() # this is just for time=t
# eqns is from the equation attribute of marssMODEL
for (i in 1:length(eqns)) {
eqn <- eqns[i]
##############################################################
# First read in and parse the equation attribute of marssMODEL
##############################################################
eqn.name <- str_trim(strsplit(eqn, "=")[[1]][1])
# the part to the left of , is the deterministic part + random bit in last term
eqn.det <- str_trim(strsplit(eqn, ";")[[1]][1])
# the eqn for the errors is after the ,
eqn.stoc <- str_trim(strsplit(eqn, ";")[[1]][2])
# the name is before the ~
err.name <- str_trim(strsplit(eqn.stoc, "~")[[1]][1])
# check that the name of the errors matches before and after the ,
tmp <- strsplit(eqn.det, "[+]")[[1]] # tmp[length(tmp)] should be error part
tmp <- strsplit(tmp[length(tmp)], "[*]")[[1]] # tmp[length(tmp)] should be err.name
# these 2 lines get the bit between ( and ,
eqn.stoc.mean <- strsplit(eqn.stoc, ",")[[1]][1]
eqn.stoc.mean <- str_trim(strsplit(eqn.stoc.mean, "[(]")[[1]][2])
# these 2 lines get the bit between , and )
eqn.stoc.var <- strsplit(eqn.stoc, "[)]")[[1]][1]
eqn.stoc.var <- str_trim(strsplit(eqn.stoc.var, ",")[[1]][2])
# Set up and test the time designation for the equation term
if (!str_detect(eqn.name, "_")) stop(paste("toLatex.marssMODEL: in the attribute, equation, ", eqn.name, " is missing the time designation. should look like _{t}.", sep = ""))
eqn.name.time <- str_trim(strsplit(eqn.name, "_")[[1]][2])
eqn.name <- str_trim(strsplit(eqn.name, "_")[[1]][1])
eqn.labs <- attr(x, paste(toupper(eqn.name), ".names", sep = ""))
# get rid of the bit before the =
eqn.det <- str_trim(strsplit(eqn.det, "=")[[1]][2])
# Set up and test the time designation for error term
if (!str_detect(err.name, "_")) stop(paste("toLatex.marssMODEL: in the attribute, equation, ", err.name, " is missing the time designation. should look like _{t}.", sep = ""))
err.name.time <- str_trim(strsplit(err.name, "_")[[1]][2])
err.name <- str_trim(strsplit(err.name, "_")[[1]][1])
#############################################################
# Build the latex for equation
#############################################################
#########################################
# start with the eqn name (left of =)
#########################################
if (!time.expand) {
time.sub <- eqn.name.time
} else {
time.sub <- paste("{", as.character(t), "}", sep = "")
}
mat.body <- paste(paste(eqn.name, "_{", eqn.labs, "}", sep = ""), collapse = "\\\\\n")
mat.tex <- paste(mat.head, "\n", mat.body, "\n", mat.foot, "_", time.sub, "=", sep = "")
eqn.tex <- c(eqn.tex, mat.tex)
headfoot <- list(eqn.name = eqn.name, mat.head = mat.head, mat.foot = mat.foot)
#############################################################
# send the deterministic part to right of = as char string like Bx_t+U
# and build the latex for the equation
##############################################################
if (time.expand) {
eqn.tex <- c(eqn.tex, build.eqn.tex(eqn.det, eqn.special, marssMODEL, greek, digits, simplify, headfoot, t = t))
} else {
eqn.tex <- c(eqn.tex, build.eqn.tex(eqn.det, eqn.special, marssMODEL, greek, digits, simplify, headfoot))
}
# put the stochastic part on it's own line
eqn.tex <- c(eqn.tex, "\\\\")
##############################################################
# build the stochastic part of the equation
##############################################################
# start with the eqn name (left of ~)
if (!time.expand) {
time.sub <- err.name.time
} else {
time.sub <- paste("{", as.character(t), "}", sep = "")
}
mat.body <- paste(paste(err.name, "_{", eqn.labs, "}", sep = ""), collapse = "\\\\\n")
mat.tex <- paste(mat.head, "\n", mat.body, "\n", mat.foot, "_", time.sub, " \\sim", sep = "")
eqn.tex <- c(eqn.tex, mat.tex)
# add the distribution designation. will be in front of (
tmp <- strsplit(eqn.stoc, "[(]")[[1]][1]
tmp <- str_trim(strsplit(tmp, "~")[[1]][2])
# wrap in pmatrix
eqn.tex <- c(eqn.tex, tmp, "\\begin{pmatrix}")
# add the mean
if (!time.expand) {
eqn.tex <- c(eqn.tex, build.eqn.tex(eqn.stoc.mean, eqn.special, marssMODEL, greek, digits, simplify, headfoot))
} else {
eqn.tex <- c(eqn.tex, build.eqn.tex(eqn.stoc.mean, eqn.special, marssMODEL, greek, digits, simplify, headfoot, t = t))
}
# separate from variance with a ,
eqn.tex <- c(eqn.tex, ", ")
# add the variance
if (!time.expand) {
eqn.tex <- c(eqn.tex, build.eqn.tex(eqn.stoc.var, eqn.special, marssMODEL, greek, digits, simplify, headfoot))
} else {
eqn.tex <- c(eqn.tex, build.eqn.tex(eqn.stoc.var, eqn.special, marssMODEL, greek, digits, simplify, headfoot, t = t))
}
# close
eqn.tex <- c(eqn.tex, "\\end{pmatrix}")
# end of equation i
eqn.tex <- c(eqn.tex, "\\\\\n \\\\")
} # end of equation (like x=..., w ~ MVN(...)
# get rid of trailing two \\\\ after the last eqn
eqn.tex <- eqn.tex[-1 * length(eqn.tex)]
# add the header and footer for the equation
all.t.eqn.tex <- c(all.t.eqn.tex, eqn.head, eqn.tex, eqn.foot)
} # over all t for which we should print
if(output=="rawtex") return(all.t.eqn.tex)
##############################################################
# Create the latex file
##############################################################
if (length(math.sty)) {
sty <- paste("\\usepackage{", math.sty, "}", sep = "")
}
sty <- c(sty, paste("\\usepackage[", orientation, "]{geometry}", sep = ""))
if ("Rnw" %in% output) {
sty <- c(sty, "\\usepackage{Sweave}")
}
# Set up the file name
if (is.null(file) & replace) tmp <- "marssMODEL"
if (is.null(file) & !replace) tmp <- tempfile("marssMODEL", tmpdir = ".")
if (!is.null(file)) tmp <- file
# If the user put on a extension of .tex, .dvi or .pdf remove that
if (tolower(str_sub(tmp, -4)) == ".tex") tmp <- str_sub(tmp, -4)
if (tolower(str_sub(tmp, -4)) == ".pdf") tmp <- str_sub(tmp, -4)
if (tolower(str_sub(tmp, -4)) == ".dvi") tmp <- str_sub(tmp, -4)
tmptex.filename <- paste(tmp, "tex", sep = ".")
cat("\\documentclass{report}", sty, "\\begin{document}\\pagestyle{empty}",
all.t.eqn.tex, "\\end{document}\n",
file = tmptex.filename, sep = "\n"
)
if ("pdf" %in% output) latexcmd <- "pdflatex"
if ("dvi" %in% output) latexcmd <- "latex"
if ("pdf" %in% output | "dvi" %in% output) {
# sys(paste(latexcmd, "-interaction=scrollmode", shQuote(tmp)), output = FALSE)
system(paste(latexcmd, shQuote(tmp)))
system(paste("rm", paste(str_replace(tmp, "[\\]", "/"), "aux", sep = ".")))
system(paste("rm", paste(str_replace(tmp, "[\\]", "/"), "log", sep = ".")))
}
if ("Rnw" %in% output) {
system(paste("cp", paste(str_replace(tmp, "[\\]", "/"), "tex", sep = "."), paste(str_replace(tmp, "[\\]", "/"), "Rnw", sep = ".")))
}
if (!("tex" %in% output)) {
system(paste("rm", paste(str_replace(tmp, "[\\]", "/"), "tex", sep = ".")))
}
} # end of toLatex.marssMODEL
get.mat.tex <- function(x, greek, digits) {
# called by build.eqn.tex
# x is a matrix for the parameter
# use Hmisc util to convert to tabular form
mat <- array(list(), dim = dim(x))
tmp.fun <- function(x, digits = 2, greek = greek) {
ifelse(is.numeric(x[[1]]), round(x[[1]], digits = digits), Hmisc::latexTranslate(x[[1]], greek = greek))
}
# this will be a list matrix whether or not x is a list matrix
mat[, ] <- lapply(x, tmp.fun, digits = digits, greek = greek)
# now deal with any +,*,-1* in the matrices
tmp.fun.2 <- function(x) {
if (is.character(x[[1]])) {
x <- str_replace_all(x, "[+][-]", "-")
x <- str_replace_all(x, "[-]1[*]", "-")
x <- str_replace_all(x, "[+]1[*]", "+")
x <- str_replace_all(x, "[*]", "$\\\\\\times$")
x <- str_replace_all(x, "[+]", "$+$")
x <- str_replace_all(x, "[-]", "$-$")
# get rid of all the $ because the matrix will be wrapped in equation
x <- str_replace_all(x, "[$]", " ")
} else {
x[[1]]
}
}
# mat is still a list matrix
mat[, ] <- lapply(mat, tmp.fun.2)
# now use the Hmisc util to translate to tabular form
tmp.tex <- Hmisc::latexTabular(mat)[[1]]
# latexTabular is replacing _ with \\\\_
tmp.tex <- str_replace_all(tmp.tex, "[\\][\\]_", "_")
tmp.tex <- strsplit(tmp.tex, "\n")[[1]]
tmp.tex <- tmp.tex[-1]
tmp.tex <- tmp.tex[-1 * length(tmp.tex)]
# tmp.tex <- tmp.tex[-1 * length(tmp.tex)]
tmp.tex[length(tmp.tex)] <- str_replace_all(tmp.tex[length(tmp.tex)], "[\\]", "")
tmp.body <- paste(tmp.tex, collapse = "\n")
return(tmp.body)
}
build.eqn.tex <- function(eqn, eqn.special, x, greek, digits, simplify, headfoot, t = NULL) {
# if simplify is FALSE, then will need t if parameters are time-varying
# eqn.special are the terms like x, y, v, w
# greek means whether to turn things like alpha into \alpha
tmp.eqn.tex <- c()
# get the model from x (x is a marssMODEL object)
fixed <- x$fixed
free <- x$free
model.dims <- attr(x, "model.dims")
m <- model.dims[["x"]][1]
n <- model.dims[["y"]][1]
model.el <- attr(x, "par.names")
eqn.name <- headfoot$eqn.name
mat.head <- headfoot$mat.head
mat.foot <- headfoot$mat.foot
# this takes a text form of an equation and builds the tex
for (el in strsplit(eqn, "[+]")[[1]]) {
show.el <- TRUE
for (el2 in strsplit(el, "[*]")[[1]]) {
show.el2 <- TRUE
# if el2 has a time subscript, get the time (usually t or t-1 but might be anything)
# el2.time is the time subscript and el2 is the parameter name
if (str_detect(el2, "_")) {
if (missing(t)) { # then not time.expand
el2.time <- str_trim(strsplit(el2, "_")[[1]][2])
} else {
el2.time <- paste("{", as.character(t), "}", sep = "")
}
el2 <- strsplit(el2, "_")[[1]][1]
} else {
el2.time <- NULL
}
el2 <- str_trim(el2) # strip any extra while space
# Detect if el2 is a number, like 0, and print as a number
options(warn = -1) # don't print warnings if el2 cannot be converted to numeric
if (!is.na(as.numeric(el2))) el2 <- as.numeric(el2)
options(warn = 0)
if (!is.numeric(el2) & !(el2 %in% c(model.el, eqn.special))) stop("toLatex.marssMODEL: in the attribute, equation, one of the names does not match a name in fixed or model.dims.")
# if els is a number, just print as a number
if (is.numeric(el2)) {
mat.tex <- as.character(el2)
} else {
if (el2 %in% eqn.special) {
######################################
# if el2 is something like x, y, v or w
######################################
# if el2 is a eqn.name then use its names, otherwise it is a error name
if (el2 %in% eqn.special[seq(1, length(eqn.special), 2)]) {
el2.names <- el2
} else {
el2.names <- eqn.special[which(eqn.special == el2) - 1]
}
labs <- attr(x, paste(toupper(el2.names), ".names", sep = ""))
mat.body <- paste(paste(el2, "_{", labs, "}", sep = ""), collapse = "\\\\\n")
if (is.null(el2.time)) stop(paste("toLatex.marssMODEL: in the attribute, equation, ", el2, " is missing the time designation. should look like _{t}.", sep = ""))
mat.tex <- paste(mat.head, "\n", mat.body, "\n", mat.foot, "_", el2.time, sep = "")
} else {
######################################
# el2 is a parameter name
######################################
if (!is.null(colnames(free[[el2]]))) { # this adds the parameter name to the element name, like B.1
colnames(free[[el2]]) <- paste(el2, colnames(free[[el2]]), sep = ".")
}
if (model.dims[[el2]][3] == 1) {
mat <- fixed.free.to.formula(fixed[[el2]], free[[el2]], model.dims[[el2]][1:2])
} else {
mat <- array(NA, dim = model.dims[[el2]])
for (i in 1:model.dims[[el2]][3]) {
mat[, , i] <- fixed.free.to.formula(fixed[[el2]], free[[el2]], model.dims[[el2]][1:2])
}
}
# if simplify=TRUE only show mats that are not all 0 and that are not identity
if (simplify) show.el <- show.el & !(all(sapply(mat, identical, 0)))
if (simplify) {
if (length(dim(mat)) == 3) show.el2 <- !all(apply(mat, 3, is.identity))
if (length(dim(mat)) == 2) show.el2 <- !is.identity(mat)
}
if (show.el2 & show.el) {
# if mat is 2D then it is not time-varying so no time subscript
if (!is.matrix(mat)) { # then it is 3D
# if mat is 3D but all the mats are equal, then it is not time-varying
# The following tests for that
mat2D <- array(mat, dim = c(dim(mat)[1] * dim(mat)[2], dim(mat)[3])) # reform to be 2D
# test equality within row; will return TRUE if dim 3 = 1
if (all(apply(mat, 1, vector.all.equal))) { # not time-varying
mat <- sub3D(mat, t = 1) # not time-varying so just use the mat at t=1
} else { # is time-varying
if (!simplify) { # then there will be an equation for each parameter at time t
if (missing(t)) stop("build.eqn.tex: if simplify is FALSE and parameters are time-varying, need to specify t")
mat <- sub3D(mat, t = t)
} else { # do simplify
# step 1: figure out which parameter elements are time-varying
mat2D <- array(mat, dim = c(dim(mat)[1] * dim(mat)[2], dim(mat)[3])) # reform to be 2D, matrix(vec(mat),t)
tv.elem <- !apply(mat2D, 1, vector.all.equal) # which elements are time varying
# step 2: replace that element with the name el2(i)_t
tv.name <- paste(el2, "(", 1:dim(mat2D)[1], ")_", el2.time, sep = "")
# step 3: set up a mat to be t=1; will replace time=varying ones
mat <- sub3D(mat, t = 1)
# replace any time-varying elements with tv.name
mat[tv.elem] <- tv.name[tv.elem]
}
}
}
mat.body <- get.mat.tex(mat, greek, digits)
mat.tex <- paste(mat.head, "\n", mat.body, "\n", mat.foot, sep = "")
}
}
}
if (show.el & show.el2) tmp.eqn.tex <- c(tmp.eqn.tex, mat.tex)
}
if (show.el) tmp.eqn.tex <- c(tmp.eqn.tex, "+")
}
tmp.eqn.tex <- tmp.eqn.tex[-1 * length(tmp.eqn.tex)]
return(tmp.eqn.tex)
}
parameters.time.varying <- function(eqn, eqn.special, x) {
# this will search through the equation parameters and determine if any parameters are time-varying
# get the model from x (x is a marssMODEL object)
fixed <- x$fixed
free <- x$free
if (!is.null(attr(x, "model.dims"))) {
model.dims <- attr(x, "model.dims")
} else {
model.dims <- x$model.dims
}
model.el <- names(fixed)
# this finds the bits between + in the equation
for (el in strsplit(eqn, "[+]")[[1]]) {
for (el2 in strsplit(el, "[*]")[[1]]) { # this finds the bits between * in el
if (str_detect(el2, "_")) {
el2.time <- str_trim(strsplit(el2, "_")[[1]][2])
el2 <- strsplit(el2, "_")[[1]][1]
} else {
el2.time <- NULL # no time subscript
# the parameter should not be time-varying then....
}
el2 <- str_trim(el2) # strip any extra while space
# Detect if el2 is a number, like 0, and print as a number
options(warn = -1) # don't print warnings if el2 cannot be converted to numeric
if (!is.na(as.numeric(el2))) {
el2 <- as.numeric(el2)
if (!is.null(el2.time)) stop("toLatex.marssMODEL: equation has a number with a time-subscript. That doesn't make sense.\nCheck the equation attribute for the marssMODEL.\n")
}
options(warn = 0)
if (!is.numeric(el2) & !(el2 %in% c(model.el, eqn.special))) stop("toLatex.marssMODEL: in the attribute, equation, one of the names does not match a name in fixed or model.dims.")
# if els is a number, just print as a number
if (is.numeric(el2)) {
next # go to next parameter in model
}
if (el2 %in% eqn.special) {
next # ignore the specials. They always are time-varying
}
if (model.dims[[el2]][3] == 1) next # it is not time-varying
# Even if 3D, it might not be time-varying if all elements are the same
testtv <- FALSE
if (!all(apply(fixed[[el2]], 1, vector.all.equal))) testtv <- TRUE # time-varying
mat2D <- array(free[[el2]], dim = c(dim(free[[el2]])[1] * dim(free[[el2]])[2], dim(free[[el2]])[3]))
if (!all(apply(mat2D, 1, vector.all.equal))) testtv <- TRUE # time-varying
if (!testtv) { # not time-varying
next
} else {
if (is.null(el2.time)) stop(paste("toLatex.marssMODEL: something is wrong. ", el2, " in the equation attributes has no time subscript, yet it is time-varying in the marssMODEL object.\nCannot make latex because the correct time-subscript label is unknown.\n", sep = ""))
return(TRUE)
}
} # el2 the bits between * for el's
} # el the bits between +
return(FALSE)
} # end of function
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.