# Copyright (C) 2013 - 2020 Metrum Research Group
#
# This file is part of mrgsolve.
#
# mrgsolve is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# mrgsolve is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with mrgsolve. If not, see <http://www.gnu.org/licenses/>.
##' Methods for working with the model compartment list
##'
##' Calling \code{init} with the model object as the first argument
##' will return the model initial conditions as a \code{numericlist}
##' object. See \code{\link{numericlist}} for methods to deal with
##' \code{cmt_list} objects.
##'
##' @aliases init
##' @param .x the model object
##' @param .y list to be merged into parameter list
##' @param .pat a regular expression (character) to be applied as
##' a filter when printing compartments to the screen
##' @param ... passed along
##' @return an object of class \code{cmt_list} (see
##' \code{\link{numericlist}})
##' @details
##' Can be used to either get a compartment list object from a
##' \code{mrgmod} model object or to update the compartment initial
##' conditions in a model object. For both uses, the return value
##' is a \code{cmt_list} object. For the former use, \code{init}
##' is usually called to print the compartment initial conditions
##' to the screen, but the \code{cmt_list} object can also be coerced
##' to a list or numeric R object.
##'
##' @examples
##' ## example("init")
##' mod <- mrgsolve::house()
##'
##' init(mod)
##' init(mod, .pat="^C") ## may be useful for large models
##'
##' class(init(mod))
##'
##' init(mod)$CENT
##'
##' as.list(init(mod))
##' as.data.frame(init(mod))
##' @export
setGeneric("init", function(.x,...) standardGeneric("init"))
##' @export
##' @rdname init
setMethod("init", "mrgmod", function(.x,.y=list(),..., .pat="*") {
args <- c(as.list(.y),list(...))
if(length(args)>0) return(update(.x,init=args))
.x@init@pattern <- .pat
if(!main_loaded(.x)) {
return(.x@init)
}
if(neq(.x)==0) return(as.init())
## Otherwise call function:
.x@init <- as.init(touch_funs(.x)$init)
slot(.x@init,"pattern") <- .pat
return(.x@init)
})
##' @rdname init
##' @export
setMethod("init", "mrgsims", function(.x,...) {
init(mod(.x),...)
})
##' @rdname init
##' @export
setMethod("init", "missing", function(...) {
init(list(...))
})
##' @rdname init
##' @export
setMethod("init", "list", function(.x,...) {
create_numeric_list(.x,"cmt_list",...)
})
##' @rdname init
##' @export
setMethod("init", "ANY", function(.x,...) {
init(as.list(.x),...)
})
setGeneric("as.init", function(.x,...) {
standardGeneric("as.init")
})
setMethod("as.init", "list", function(.x,...) {
create_numeric_list(.x,"cmt_list",...)
})
setMethod("as.init", "numeric", function(.x,...) {
create_numeric_list(as.list(.x),"cmt_list",...)
})
setMethod("as.init", "cmt_list", function(.x,...) .x)
setMethod("as.init", "missing", function(.x,...) {
create_numeric_list(list(), "cmt_list",...)
})
setMethod("as.init", "NULL", function(.x,...) {
create_numeric_list(list(), "cmt_list",...)
})
showinit <- function(x,digits=3,ncols=NULL,right=FALSE,...) {
if(is.mt(x@data)) {
message("No compartments in the model.")
return(invisible(NULL))
}
pattern <- x@pattern
ini <- as.list(x)
showN <- length(ini)
x <- names(ini)
y <- prettyNum(unlist(ini), digits=digits)
n <- 1:length(x)
if(pattern !="*") {
take <- grepl(pattern,x)
x <- x[take]
y <- y[take]
n <- n[take]
}
##if(length(x)==0) stop("No initial conditions to show with pat = ", pattern)
if(length(x)==0) {message("No matching compartments were found."); return(invisible(NULL))}
ord <- order(x)
x <- x[ord]
y <- y[ord]
n <- n[ord]
if(is.null(ncols)) {
ncols <- ifelse(length(x) > 20, 3,2)
}
N <- ceiling(length(x)/ncols)
target <- N*ncols
x <- c(x, rep(".", target-length(x)))
n <- c(n, rep(".", target-length(n)))
y <- c(y, rep(".", target-length(y)))
x <- paste(x, " (", n, ") ", sep="")
x <- gsub("\\(\\.\\)", "...", x)
grps <- ceiling(seq_along(x)/N)
x <- split(x,grps)
x <- data.frame(do.call('cbind',x))
y <- split(y,grps)
y <- data.frame(do.call('cbind',y))
sep <- data.frame(`.` = rep("|", N))
df <- cbind(x[,1],y[,1],sep)
for(i in 2:ncol(x)) {
df <- cbind(df,x[,i], y[,i],sep)
}
names(df) <- rep(c("name", "value", "."), ncols)
df[,ncol(df)] <- NULL
output <- df
cat("\n Model initial conditions (N=", showN, "):\n", sep="")
print(output, row.names=FALSE, right=right)
return(invisible(NULL))
}
##' Show the compartment list
##' @param object the object to show
##' @export
##' @keywords internal
setMethod("show", "cmt_list", function(object) showinit(object))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.