R/package_skeleton.R

In SimInf: A Framework for Data-Driven Stochastic Disease Spread Simulations

## 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 -- 2022 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
##' @importFrom utils packageVersion
##' @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(>= ", 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 <- 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 <- 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 <- 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 <- 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
}

##' @importFrom utils capture.output
##' @noRd
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)"),
      "    })")
}

##' @importFrom utils packageVersion
##' @noRd
create_model_R_timestamp <- function() {
    c(sprintf("## Generated by SimInf (v%s) %s",
            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)
}