Nothing
## This file is part of SimInf, a framework for stochastic
## disease spread simulations.
##
## Copyright (C) 2015 Pavol Bauer
## Copyright (C) 2017 -- 2019 Robin Eriksson
## Copyright (C) 2015 -- 2019 Stefan Engblom
## Copyright (C) 2015 -- 2023 Stefan Widgren
##
## SimInf 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 3 of the License, or
## (at your option) any later version.
##
## SimInf 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 this program. If not, see <https://www.gnu.org/licenses/>.
##' Create a DESCRIPTION file for the package skeleton
##' @noRd
create_DESCRIPTION_file <- function(path, name, author, maintainer,
email, license) {
lines <- c(
paste0("Package: ", name),
"Type: Package",
paste0("Title: Model ('", name, "') Interface to the 'SimInf' Package"),
"Version: 1.0",
paste0("Author: ", author),
paste0("Maintainer: ", maintainer, " <", email, ">"),
"Description: Generated by 'SimInf'. Provides an interface",
paste0(" to the 'SimInf' package for the '", name, "' model."),
paste0("License: ", license),
"NeedsCompilation: yes",
paste0("Depends: SimInf (>= ", utils::packageVersion("SimInf"), ")"),
"Imports: methods",
"LinkingTo: SimInf",
"Collate:",
" 'model.R'")
writeLines(lines, con = file.path(path, "DESCRIPTION"))
invisible(NULL)
}
##' Create a NAMESPACE file for the package skeleton
##' @noRd
create_NAMESPACE_file <- function(path, name) {
lines <- c(paste0("export(", name, ")"),
paste0("exportClasses(", name, ")"),
"exportMethods(run)",
"import(SimInf)",
"import(methods)",
paste0("useDynLib(", name, ", .registration=TRUE)"))
writeLines(lines, con = file.path(path, "NAMESPACE"))
invisible(NULL)
}
create_model_C_file <- function(path, model, name) {
## Write the model C code to a file.
filename <- file.path(path, "src", "model.c")
writeLines(model@C_code, filename)
invisible(NULL)
}
create_valid_C_entry_point <- function(name) {
## A valid C entry point cannot contain '.'
gsub("[.]", "_", name)
}
create_Makevars_files <- function(path, name) {
name <- create_valid_C_entry_point(name)
lines <- paste0("PKG_CPPFLAGS =",
" -DSIMINF_MODEL_RUN=", name, "_run",
" -DSIMINF_R_INIT=R_init_", name,
" -DSIMINF_FORCE_SYMBOLS=TRUE")
writeLines(lines, file.path(path, "src", "Makevars"))
writeLines(lines, file.path(path, "src", "Makevars.win"))
invisible(NULL)
}
create_model_R_class <- function(name) {
c(paste0("##' Class \\code{", name, "}"),
"##'",
paste0("##' Class to handle the \\code{", name,
"} \\code{SimInf_model}."),
"##' @export",
paste0("setClass(\"", name, "\", contains = \"SimInf_model\")"),
"")
}
create_model_R_object_roxygen <- function(model) {
lines <- c("##' Create a model for the SimInf framework",
"##'",
"##' Create a model to be used by the SimInf framework.")
if (length(rownames(model@ldata)) > 0) {
lines <- c(
lines,
"##' @param ldata Data specific to each node in the model.",
"##' Can be specified either as a numeric matrix where",
"##' column \\code{ldata[, j]} contains the local data",
"##' vector for the node \\code{j} or as a",
"##' \\code{data.frame} with one row per node.")
}
if (length(names(model@gdata)) > 0) {
lines <- c(
lines,
"##' @param gdata Data that are common to all nodes in the model.",
"##' Can be specified either as a named numeric vector or as",
"##' a one-row data.frame.")
}
lines <- c(
lines,
"##' @param u0 A data.frame with the initial state in each node.")
if (length(rownames(model@v0)) > 0) {
lines <- c(
lines,
"##' @param v0 Data with the initial continuous state in each",
"##' node. Can be specified either as a \\code{data.frame}",
"##' with one row per node or as a numeric matrix where",
"##' column \\code{v0[, j]} contains the initial state",
"##' vector for the node \\code{j}.")
}
lines <- c(
lines,
"##' @param tspan A vector of increasing time points",
"##' where the state of each node is to be returned.",
"##' @param events A data.frame with scheduled events.",
"##' @import SimInf",
"##' @import methods",
"##' @export",
"##' @examples",
"##' ## Please add example(s) how to use the model")
lines
}
create_model_R_object_function <- function(model, name) {
fn <- paste0(name, " <- function(")
if (length(rownames(model@ldata)) > 0)
fn <- paste0(fn, "ldata = NULL, ")
if (length(names(model@gdata)) > 0)
fn <- paste0(fn, "gdata = NULL, ")
fn <- paste0(fn, "u0 = NULL, ")
if (length(rownames(model@v0)) > 0)
fn <- paste0(fn, "v0 = NULL, ")
paste0(fn, "tspan = NULL, events = NULL) {")
}
create_model_R_object_u0 <- function(model) {
compartments <- paste0(rownames(model@S), collapse = "\", \"")
compartments <- paste0(" compartments <- c(\"", compartments, "\")")
c(" ## Check u0",
compartments,
" if (is.null(u0))",
" stop(\"'u0' must be specified.\")",
" if (!is.data.frame(u0))",
" u0 <- as.data.frame(u0)",
" if (!all(compartments %in% names(u0)))",
" stop(\"Missing columns in u0.\")",
" u0 <- u0[, compartments, drop = FALSE]",
"")
}
create_model_R_object_ldata <- function(model) {
if (length(rownames(model@ldata)) < 1)
return(NULL)
ldata_names <- paste0(rownames(model@ldata), collapse = "\", \"")
ldata_names <- paste0(" ldata_names <- c(\"", ldata_names, "\")")
c(" ## Check ldata",
ldata_names,
" if (is.data.frame(ldata)) {",
" if (!all(ldata_names %in% colnames(ldata)))",
" stop(\"Missing parameter(s) in 'ldata'.\")",
" ldata <- ldata[, ldata_names, drop = FALSE]",
" } else if (is.matrix(ldata)) {",
" if (!all(ldata_names %in% rownames(ldata)))",
" stop(\"Missing parameter(s) in 'ldata'.\")",
" ldata <- ldata[ldata_names, , drop = FALSE]",
" } else {",
" stop(\"'ldata' must either be a 'data.frame' or a 'matrix'.\")",
" }",
"")
}
create_model_R_object_gdata <- function(model) {
if (length(names(model@gdata)) < 1)
return(NULL)
gdata_names <- paste0(names(model@gdata), collapse = "\", \"")
gdata_names <- paste0(" gdata_names <- c(\"", gdata_names, "\")")
c(" ## Check gdata",
gdata_names,
" if (is.data.frame(gdata)) {",
" if (!all(gdata_names %in% colnames(gdata)))",
" stop(\"Missing parameter(s) in 'gdata'\")",
" gdata <- gdata[, gdata_names, drop = FALSE]",
" } else if (is.atomic(gdata) && is.numeric(gdata)) {",
" if (!all(gdata_names %in% names(gdata)))",
" stop(\"Missing parameter(s) in 'gdata'\")",
" gdata <- gdata[gdata_names]",
" } else {",
paste0(" stop(\"'gdata' must either be a 'data.frame' or ",
"a 'numeric' vector.\")"),
" }",
"")
}
create_model_R_object_v0 <- function(model) {
if (length(rownames(model@v0)) < 1)
return(NULL)
v0_names <- paste0(rownames(model@v0), collapse = "\", \"")
v0_names <- paste0(" v0_names <- c(\"", v0_names, "\")")
c(" ## Check v0",
v0_names,
" if (is.data.frame(v0)) {",
" if (!all(v0_names %in% colnames(v0)))",
" stop(\"Missing parameter(s) in 'v0'\")",
" v0 <- v0[, v0_names, drop = FALSE]",
" } else if (is.matrix(v0)) {",
" if (!all(v0_names %in% rownames(v0)))",
" stop(\"Missing parameter(s) in 'v0'\")",
" v0 <- v0[v0_names, , drop = FALSE]",
" } else {",
" stop(\"'v0' must either be a 'data.frame' or a 'matrix'.\")",
" }",
"")
}
## Dependency graph
create_model_R_object_G <- function(model) {
G <- utils::capture.output(dput(as.matrix(model@G)))
G <- c(paste0("G <- ", G[1]), G[-1])
c(paste0(" ", G), "")
}
## State change matrix
create_model_R_object_S <- function(model) {
S <- utils::capture.output(dput(as.matrix(model@S)))
S <- c(paste0("S <- ", S[1]), S[-1])
c(paste0(" ", S), "")
}
## Select matrix
create_model_R_object_E <- function(model) {
E <- utils::capture.output(dput(as.matrix(model@events@E)))
E <- c(paste0("E <- ", E[1]), E[-1])
c(paste0(" ", E), "")
}
## Shift matrix
create_model_R_object_N <- function(model) {
N <- utils::capture.output(dput(as.matrix(model@events@N)))
N <- c(paste0("N <- ", N[1]), N[-1])
c(paste0(" ", N), "")
}
create_model_R_object_model <- function(model, name) {
lines <- " model <- SimInf_model("
if (length(rownames(model@ldata)) > 0)
lines <- paste0(lines, "ldata = ldata, ")
if (length(names(model@gdata)) > 0)
lines <- paste0(lines, "gdata = gdata, ")
if (length(rownames(model@v0)) > 0)
lines <- paste0(lines, "v0 = v0, ")
lines <- paste0(lines, "G = G, S = S, E = E, N = N,")
lines <- c(
lines,
" tspan = tspan, events = events, u0 = u0)",
"",
paste0(" as(model, \"", name, "\")"))
lines
}
create_model_R_object <- function(model, name) {
c(create_model_R_object_roxygen(model),
create_model_R_object_function(model, name),
create_model_R_object_ldata(model),
create_model_R_object_gdata(model),
create_model_R_object_u0(model),
create_model_R_object_v0(model),
create_model_R_object_G(model),
create_model_R_object_S(model),
create_model_R_object_E(model),
create_model_R_object_N(model),
create_model_R_object_model(model, name),
"}",
"")
}
create_model_run_fn <- function(name) {
c("##' Run the model",
"##'",
"##' @rdname run-methods",
"##' @param model The model to run.",
"##' @param solver Which numerical solver to utilize. Default is 'ssm'.",
"##' @param ... Additional arguments.",
paste0("##' @return A model with a single stochastic ",
"solution trajectory attached to it."),
"##' @export",
"##' @import methods",
paste0("##' @useDynLib ", name, ", .registration=TRUE"),
"setMethod(\"run\",",
paste0(" signature(model = \"", name, "\"),"),
" function(model, solver = c(\"ssm\", \"aem\"), ...) {",
" solver <- match.arg(solver)",
" validObject(model)",
paste0(" .Call(",
create_valid_C_entry_point(name),
"_run, model, solver)"),
" })")
}
create_model_R_timestamp <- function() {
c(sprintf("## Generated by SimInf (v%s) %s",
utils::packageVersion("SimInf"),
format(Sys.time(), "%Y-%m-%d %H:%M")),
"")
}
create_model_R_file <- function(path, model, name) {
lines <- c(create_model_R_timestamp(),
create_model_R_class(name),
create_model_R_object(model, name),
create_model_run_fn(name))
writeLines(lines, con = file.path(path, "R", "model.R"))
invisible(NULL)
}
create_model_class_man_file <- function(path, name) {
lines <- c("\\docType{class}",
paste0("\\name{", name, "-class}"),
paste0("\\alias{", name, "-class}"),
paste0("\\title{Class \\code{", name, "}}"),
"\\description{",
paste0("Class to handle the \\code{",
name, "} \\code{SimInf_model}."),
"}")
writeLines(lines, con = file.path(path, "man", paste0(name, "-class.Rd")))
invisible(NULL)
}
create_model_man_file <- function(path, model, name) {
lines <- c(paste0("\\name{", name, "}"),
paste0("\\alias{", name, "}"),
"\\title{Create a model for the SimInf framework}",
"\\usage{")
fn <- paste0(name, "(")
if (length(rownames(model@ldata)) > 0)
fn <- paste0(fn, "ldata = NULL, ")
if (length(names(model@gdata)) > 0)
fn <- paste0(fn, "gdata = NULL, ")
fn <- paste0(fn, "u0 = NULL, ")
if (length(rownames(model@v0)) > 0)
fn <- paste0(fn, "v0 = NULL, ")
fn <- paste0(fn, "tspan = NULL, events = NULL)")
lines <- c(lines,
fn,
"}",
"\\arguments{")
if (length(rownames(model@ldata)) > 0) {
lines <- c(
lines,
"\\item{ldata}{Data specific to each node in the model.",
"Can be specified either as a numeric matrix where column",
"\\code{ldata[, j]} contains the local data vector for the",
"node \\code{j} or as a \\code{data.frame} with one row per",
"node.}")
}
if (length(names(model@gdata)) > 0) {
lines <- c(
lines,
"\\item{gdata}{Data that are common to all nodes in the model.",
"Can be specified either as a named numeric vector or as a",
"one-row data.frame.}")
}
lines <- c(
lines,
"\\item{u0}{A \\code{data.frame} with the initial state in each node.}")
if (length(rownames(model@v0)) > 0) {
lines <- c(
lines,
"\\item{v0}{Data with the initial continuous state in each",
"node. Can be specified either as a \\code{data.frame} with",
"one row per node or as a numeric matrix where column",
"\\code{v0[, j]} contains the initial state vector for the",
"node \\code{j}.}")
}
lines <- c(
lines,
"\\item{tspan}{A vector of increasing time points",
"where the state of each node is to be returned.}",
"\\item{events}{A data.frame with scheduled events.}",
"}",
"\\description{",
"Create a model to be used by the SimInf framework.",
"}",
"\\examples{",
"## Please add example(s) how to use the model",
"}")
writeLines(lines, con = file.path(path, "man", paste0(name, ".Rd")))
invisible(NULL)
}
create_model_run_man_file <- function(path, name) {
lines <- c(
"\\docType{methods}",
paste0("\\name{run,", name, "-method}"),
paste0("\\alias{run,", name, "-method}"),
"\\title{Run the model}",
"\\usage{",
paste0("\\S4method{run}{", name,
"}(model, solver = c(\"ssm\", \"aem\"), ...)"),
"}",
"\\arguments{",
"\\item{model}{The model to run.}",
"",
paste0("\\item{solver}{Which numerical solver to utilize. ",
"Default is 'ssm'.}"),
"",
"\\item{...}{Additional arguments.}",
"}",
"\\value{",
"A model with a single stochastic solution trajectory attached to it.",
"}",
"\\description{",
"Run the model",
"}")
writeLines(lines, con = file.path(path, "man", "run-methods.Rd"))
invisible(NULL)
}
##' Create a package skeleton from a \code{SimInf_model}
##'
##' Describe your model in a logical way in R, then \code{mparse}
##' creates a \code{\linkS4class{SimInf_model}} object with your model
##' definition that can be installed as an add-on R package.
##' @param model The \code{model} \code{\linkS4class{SimInf_model}}
##' object with your model to create the package skeleton from.
##' @param name Character string with the package name. It should
##' contain only (ASCII) letters, numbers and dot, have at least
##' two characters and start with a letter and not end in a dot.
##' The package name is also used for the class name of the model
##' and the directory name of the package.
##' @param path Path to put the package directory in. Default is '.'
##' i.e. the current directory.
##' @param author Author of the package.
##' @param email Email of the package maintainer.
##' @param maintainer Maintainer of the package.
##' @param license License of the package. Default is 'GPL-3'.
##' @return invisible \code{NULL}.
##' @export
##' @references Read the \emph{Writing R Extensions} manual for more
##' details.
##'
##' Once you have created a \emph{source} package you need to install
##' it: see the \emph{R Installation and Administration} manual,
##' \code{\link{INSTALL}} and \code{\link{install.packages}}.
package_skeleton <- function(model, name = NULL, path = ".",
author = NULL, email = NULL,
maintainer = NULL, license = "GPL-3") {
check_model_argument(model)
check_package_name(name)
stopifnot(!is.null(path), is.character(path), length(path) == 1,
nchar(path) > 0)
path <- file.path(path, name)
if (!is.na(file.info(path)$size))
stop(paste0("'", path, "' already exists."), call. = FALSE)
if (is.null(author))
author <- "Your Name"
stopifnot(is.character(author), length(author) == 1, nchar(author) > 0)
if (is.null(email))
email <- "your@email.com"
stopifnot(is.character(email), length(email) == 1, nchar(email) > 0)
if (is.null(maintainer))
maintainer <- author
stopifnot(is.character(maintainer),
length(maintainer) == 1,
nchar(maintainer) > 0)
## Create folder structure
message("Creating directories ...", domain = NA)
dir.create(path, recursive = TRUE)
dir.create(file.path(path, "man"))
dir.create(file.path(path, "src"))
dir.create(file.path(path, "R"))
## Create files
message("Creating DESCRIPTION ...", domain = NA)
create_DESCRIPTION_file(path, name, author, maintainer, email,
license)
message("Creating NAMESPACE ...", domain = NA)
create_NAMESPACE_file(path, name)
message("Creating C file ...", domain = NA)
create_model_C_file(path, model, name)
create_Makevars_files(path, name)
message("Creating R file ...", domain = NA)
create_model_R_file(path, model, name)
message("Creating help files ...", domain = NA)
create_model_man_file(path, model, name)
create_model_class_man_file(path, name)
create_model_run_man_file(path, name)
invisible(NULL)
}
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.