Update DSL

.Rprofile

@@ -0,0 +1 @@
+options(pkg.build_extra_flags = FALSE)

CRAN-SUBMISSION

@@ -1,3 +1,3 @@
-Version: 1.1.0
-Date: 2025-05-16 08:32:30 UTC
-SHA: 5bffcb29721b4c7f8d2a876aadb3bbf99b197511
+Version: 1.2.1
+Date: 2025-06-02 07:51:53 UTC
+SHA: 4f2bc2b974fe84b46895036a04980c02584faee9

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: denim
 Type: Package
 Title: Generate and Simulate Deterministic Discrete-Time Compartmental Models
-Version: 1.1.0
-Date: 2025-05-16
+Version: 1.2.1
+Date: 2025-06-02
 Authors@R: c(
     person("Thinh", "Ong", , "thinhop@oucru.org", role = c("aut", "cph"),
            comment = c(ORCID = "0000-0001-6772-9291")),
@@ -20,9 +20,12 @@ License: MIT + file LICENSE
 URL: https://drthinhong.com/denim/,
     https://github.com/thinhong/denim
 BugReports: https://github.com/thinhong/denim/issues
+Depends: R (>= 4.1.0)
 Imports:
     Rcpp (>= 1.0.6),
-    viridisLite
+    colorspace,
+    rlang,
+    glue
 Suggests:
     covr,
     knitr,
@@ -31,6 +34,7 @@ Suggests:
     waldo,
     xml2,
     deSolve,
+    tidyverse,
     DiagrammeR
 LinkingTo: 
     Rcpp,

NAMESPACE

@@ -6,8 +6,12 @@ export(d_exponential)
 export(d_gamma)
 export(d_lognormal)
 export(d_weibull)
+export(denim_dsl)
 export(mathexpr)
 export(nonparametric)
 export(sim)
 import(Rcpp)
+import(colorspace)
+import(glue)
+import(rlang)
 useDynLib(denim, .registration = TRUE)

NEWS.md

@@ -1,3 +1,11 @@
+# denim 1.2.1
+* Minor runtime improvement
+* Add option to select color palette for plot
+
+# denim 1.2.0
+* Add denim DSL support
+* Add error handlers 
+
 # denim 1.1.0
 * Fix multinomial vs competing risks transition
 * Add distribute initial value feature

R/distribution.R

@@ -1,4 +1,15 @@
 # Constructors for distributions
+evaluate_par <- function(par){
+
+  if(is.symbol(par) | is.character(par)) {
+    par <- as.character(par)
+  } else{
+    par <- as.numeric(eval(par))
+  }
+
+  par
+}
+
 
 #' Discrete gamma distribution
 #' 
@@ -9,8 +20,19 @@
 #' 
 #' @examples
 #' transitions <- list("S -> I" = d_gamma(rate = 1, shape = 5))
+#' transitions_dsl <- denim_dsl({S -> I = d_gamma(rate = 1, shape = 5)})
+#' # define model parameters as distributional parameters
+#' transitions_dsl <- denim_dsl({S -> I = d_gamma(rate = i_rate, shape = i_shape)})
 #' @export
 d_gamma <- function(rate, shape, dist_init = FALSE) {
+  # capture expression for evaluation
+  rate <- substitute(rate)
+  shape <- substitute(shape)
+
+  # check whether it is a fixed value (numeric) or a model parameter (string or expression)
+  rate <- evaluate_par(rate)
+  shape <- evaluate_par(shape)
+
   distr <- list(
     distribution = "gamma",
     rate = rate,
@@ -31,8 +53,17 @@ d_gamma <- function(rate, shape, dist_init = FALSE) {
 #' 
 #' @examples
 #' transitions <- list("I -> D" = d_weibull(0.6, 2))
+#' transitions <- denim_dsl({ I -> D = d_weibull(0.6, 2) })
 #' @export
 d_weibull <- function(scale, shape, dist_init = FALSE) {
+  # capture expression for evaluation
+  scale <- substitute(scale)
+  shape <- substitute(shape)
+
+  # check whether it is a fixed value (numeric) or a model parameter (string or expression)
+  scale <- evaluate_par(scale)
+  shape <- evaluate_par(shape)
+
   distr <- list(
     distribution = "weibull",
     scale = scale,
@@ -52,10 +83,14 @@ d_weibull <- function(scale, shape, dist_init = FALSE) {
 #' 
 #' @examples
 #' transitions <- list("I -> D" = d_exponential(0.3))
-#' 
-#'
+#' transitions <- denim_dsl({I -> D = d_exponential(0.3)})
 #' @export
 d_exponential <- function(rate, dist_init = FALSE) {
+  # capture expression for evaluation
+  rate <- substitute(rate)
+  # check whether it is a fixed value (numeric) or a model parameter (string or expression)
+  rate <- evaluate_par(rate)
+
   distr <- list(
     distribution = "exponential",
     rate = rate,
@@ -75,8 +110,17 @@ d_exponential <- function(rate, dist_init = FALSE) {
 #' 
 #' @examples
 #' transitions <- list("I -> D" = d_lognormal(3, 0.6))
+#' transitions <- denim_dsl({I -> D = d_lognormal(3, 0.6)})
 #' @export
 d_lognormal <- function(mu, sigma, dist_init = FALSE) {
+  # capture expression for evaluation
+  mu <- substitute(mu)
+  sigma <- substitute(sigma)
+
+  # check whether it is a fixed value (numeric) or a model parameter (string or expression)
+  mu <- evaluate_par(mu)
+  sigma <- evaluate_par(sigma)
+
   distr <- list(
     distribution = "lognormal",
     mu = mu,
@@ -97,7 +141,8 @@ d_lognormal <- function(mu, sigma, dist_init = FALSE) {
 #' @return a Distribution object for simulator
 #' 
 #' @examples
-#' transitions <- list("S->I"=mathexpr("beta*S/N"))
+#' transitions <- list("S->I"="beta*S/N")
+#' transitions <- denim_dsl({S->I=beta*S/N})
 #' # definition for parameters in the expression required
 #' params <- c(N = 1000, beta = 0.3)
 #' @export
@@ -136,17 +181,49 @@ constant <- function(x) {
 #' 
 #' Convert a vector of frequencies, percentages... into a distribution
 #' 
-#' @param ... a vector of values
+#' @param x a vector of values
 #' @return a Distribution object for simulator
 #' @param dist_init whether to distribute initial value across subcompartments following this distribution. (default to FALSE, meaning init value is always in the first compartment))
 #' 
 #' @examples
-#' transitions <- list("S->I"=nonparametric(0.1, 0.2, 0.5, 0.2))
+#' transitions <- list("S->I"=nonparametric( c(0.1, 0.2, 0.5, 0.2) ))
+#' transitions <- denim_dsl({S->I=nonparametric( c(0.1, 0.2, 0.5, 0.2) )})
+#' # you can also define a model parameter for the distribution
+#' transitions <- denim_dsl({S->I=nonparametric( dwelltime_dist )})
 #' @export
-nonparametric <- function(..., dist_init = FALSE) {
+nonparametric <- function(x, dist_init = FALSE) {
+  # x <- substitute(c(...))
+  # 
+  # # remove "c" 
+  # x <- as.character(x)[-1]
+  # 
+  # # try parsing ... 
+  # failed_parse <- FALSE
+  # try_eval <- sapply(parse(text = x), \(expr){
+  #   tryCatch(
+  #     eval(expr),
+  #     error = \(e) {
+  #       failed_parse <<- TRUE
+  #     }
+  #   )
+  # })
+  # x <- if(!failed_parse) {
+  #   try_eval
+  # } else{
+  #   x
+  # }
+  # 
+  # # if ... is a parameter and more than 1 parameter is given -> throw error
+  # if(all(is.character(x)) && length(x) > 1){
+  #   stop("nonparametric only takes 1 parameter as input")
+  # }
+  # 
+
+  x <- substitute(x)
+  x <- evaluate_par(x)
   distr <- list(
     distribution = "nonparametric",
-    waitingTime = c(...),
+    waitingTime = x,
     dist_init = as.numeric(dist_init))
 
   class(distr) <- c("Distribution", class(distr))

R/dsl.R

@@ -0,0 +1,75 @@
+#' Define transitions using denim's domain-specific language (DSL)
+#' 
+#' This function parses model transitions defined in denim's DSL syntax
+#'
+#' @param x - an expression written in denim's DSL syntax. Each line should be a transition written in the 
+#' format `compartment -> out_compartment = expression` where expression can be either a math expression
+#' or one of denim's built-in dwell time distribution function
+#'
+#' @return denim_transition object
+#' @import rlang
+#' @export
+#'
+#' @examples
+#' transitions <- denim_dsl({
+#'   S -> I = beta * (I/N) * S * timeStep
+#'   I -> R = d_gamma(rate = 1/4, shape = 3)
+#' })
+denim_dsl <- function(x) {
+  # Capture the expression as a quoted expression
+  expr <- substitute(x)
+  # Convert the expression into a list of individual expressions
+  expr_list <- as.list(expr)[-1]
+
+  transitions <- list()
+
+  # helper function to flip the -> assigment which is non-standard in R
+  flip_assignment <- function(expr) {
+    # Split the string at "<-"
+    comps <- strsplit(expr, "<-")[[1]]
+    # Trim whitespace from both sides
+    comps <- trimws(comps)
+
+    # Check that the expression is valid
+    if (length(comps) != 2) {
+      stop("Transition must be of the form 'comp_A -> comp_B' or 'weight*comp_A -> comp_B'")
+    }
+
+    # Rearrange the parts and return
+    paste(comps[2], "->", comps[1])
+  }
+
+  for (expr in expr_list) {
+    # Each DSL argument should be an assignment (i.e. a call to `=`)
+    if (!is_call(expr, "=")) {
+      stop("Each argument must be an assignment using '='.")
+    }
+
+    expr <- as.character(expr)
+
+    # Extract lhs and rhs of the assignment
+    lhs_expr <- expr[2]
+    rhs_expr <- expr[3]
+
+    # Convert the LHS to a string (e.g., "S -> I" or "36 * I -> R")
+    # lhs_str <- paste(deparse(lhs_expr), collapse = " ")
+    lhs_str <- flip_assignment(lhs_expr)
+
+    # Check whether rhs is mathematical formula or call to d_* function
+    # If the rhs is a math formula, deparse it into a string.
+    # Otherwise (e.g., a call to d_gamma or d_exponential) leave it as an expression.
+    rhs_val <- if (grepl("^d_", rhs_expr) | grepl("^nonparametric", rhs_expr)) {
+      # If the call is to a function starting with "d_", leave it as an expression.
+      rhs_expr <- eval(parse_expr(rhs_expr))
+    } else {
+      # Otherwise, deparse the expression to convert it to a string.
+      rhs_expr
+    }
+
+    transitions[[lhs_str]] <- rhs_val
+  }
+
+  class(transitions) <- "denim_transition"
+
+  transitions
+}

R/model.R

@@ -1,4 +1,5 @@
 # Constructor
+#' @import glue
 newModel <- function(simulationDuration, errorTolerance, initialValues, 
                      parameters=NULL, transitions, timeStep = 1) {
 
@@ -13,14 +14,40 @@ newModel <- function(simulationDuration, errorTolerance, initialValues,
       transitions[[i]] <- constant(transitions[[i]])
     }
 
-    # if transition -> get parameters from Distribution object
     if( (class(transitions[[i]])=="Distribution")[[1]] ){
-      if((transitions[[i]]$distribution) == "nonparametric" | 
-               (transitions[[i]]$distribution) == "constant"|
+      if((transitions[[i]]$distribution) == "constant"|
                (transitions[[i]]$distribution) == "multinomial"){
-        # dont do anything to non parametric model
         next
+      }else if((transitions[[i]]$distribution) == "nonparametric"){
+        # check whether the distribution 
+        # parameters are numeric or string, if it is a string (i.e. model input)
+        # make sure that value is provided as one of the parameters
+        if(is.character(transitions[[i]]$waitingTime)){
+          par_val <- transitions[[i]]$waitingTime
+
+          if(!(transitions[[i]]$waitingTime %in% names(parameters))){
+            stop(glue::glue("Value for {par_val} of transition {names(transitions)[i]} must provided as one of the model parameters"))
+          }
+          transitions[[i]]$waitingTime <- parameters[[par_val]]
+          # remove waiting dist from parameters list
+          parameters[[par_val]] <- NULL
+        }
       }else if((transitions[[i]]$distribution) != "mathExpression"){
+        # check whether the distribution 
+        # parameters are numeric or string, if it is a string (i.e. model input)
+        # make sure that value is provided as one of the parameters
+        sapply(names(transitions[[i]][-1]), \(par_name){
+          par_val <- transitions[[i]][[par_name]]
+
+          if(is.character(par_val)){
+            if(!(par_val %in% names(parameters))){
+              stop(glue::glue("Value for {par_val} of transition {names(transitions)[i]} must provided as one of the model parameters"))
+            }
+            transitions[[i]][[par_name]] <<- parameters[[par_val]]
+          }
+        })
+
+        # also get parameters from Distribution objects
         parameters <- c(parameters, transitions[[i]][-1])
       }else{
         has_math_dist <- TRUE
@@ -86,45 +113,3 @@ modelToJson <- function(mod) {
 
 }
 
-
-# experimental DSL
-# TODO: test across various test case
-# denim_transitions <- function(...) {
-#   exprs <- enexprs(...)
-#   transitions <- list()
-# 
-#   for (expr in exprs) {
-#     # Each DSL argument should be an assignment (i.e. a call to `=`)
-#     if (!is_call(expr, "=")) {
-#       stop("Each argument must be an assignment using '='.")
-#     }
-# 
-#     # Extract lhs and rhs of the assignment
-#     lhs_expr <- expr[[2]]
-#     rhs_expr <- expr[[3]]
-# 
-#     # Convert the LHS to a string (e.g., "S -> I" or "36 * I -> R")
-#     lhs_str <- paste(deparse(lhs_expr), collapse = " ")
-# 
-#     # Check whether rhs is mathematical formula or call to d_* function
-#     # If the rhs is a math formula, deparse it into a string.
-#     # Otherwise (e.g., a call to d_gamma or d_exponential) leave it as an expression.
-#     rhs_val <- if (is.call(rhs_expr)) {
-#       fn <- as.character(rhs_expr[[1]])
-#       if (grepl("^d_", fn) | grepl("^nonparametric", fn)) {
-#         # If the call is to a function starting with "d_", leave it as an expression.
-#         rhs_expr
-#       } else {
-#         # Otherwise, deparse the expression to convert it to a string.
-#         paste(deparse(rhs_expr), collapse = " ")
-#       }
-#     } else {
-#       # For non-call objects (names, numbers), deparse them to a string.
-#       paste(deparse(rhs_expr), collapse = " ")
-#     }
-# 
-#     transitions[[lhs_str]] <- rhs_val
-#   }
-# 
-#   class(transitions) <- "denim_transition"
-# }