Merge pull request #1042 from metrumresearchgroup/release/1.0.7

Release/1.0.7

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: mrgsolve
 Title: Simulate from ODE-Based Models
-Version: 1.0.6
+Version: 1.0.7
 Authors@R: 
     c(person(given = "Kyle T", family = "Baron",
              role = c("aut", "cre"),
@@ -65,7 +65,7 @@ Encoding: UTF-8
 Language: en-US
 LazyLoad: yes
 NeedsCompilation: yes
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.3
 SystemRequirements: C++11
 Collate: 
     'RcppExports.R'

NAMESPACE

@@ -269,6 +269,8 @@ importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)
 importFrom(tidyselect,everything)
 importFrom(tidyselect,vars_select)
+importFrom(tools,file_path_sans_ext)
+importFrom(tools,md5sum)
 importFrom(utils,.DollarNames)
 importFrom(utils,assignInMyNamespace)
 importFrom(utils,capture.output)

NEWS.md

@@ -1,3 +1,22 @@
+# mrgsolve 1.0.7
+
+- `$NMXML` and `$NMEXT` now accept the `run` argument set to `"@cppstem"` (i.e  
+  `run = "@cppstem"`); in this case, the stem of the NONMEM run will be assumed
+  to be the same as the stem of the mrgsolve model file (#1025).
+
+- Missing values (`NA`) in input data sets will be replaced with 0 for the
+  following columns: `AMT`, `CMT`, `EVID`, `II`, `ADDL`, `RATE`, `SS` as well as
+  their lower case counterparts (#1030).
+
+- Refactored include order when building a model; this is an internal update and
+  not expected to be visible to the user (#1038).
+
+## Bugs Fixed
+
+- Fix bug in generating certain model definitions when using the `nm-vars`
+  plugin; the bug would have resulted in a warning from the pre-processor and
+  did not affect function of the model (#1039).
+
 # mrgsolve 1.0.6
 
 ## Bugs Fixed

R/Aaaa.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2020  Metrum Research Group
+# Copyright (C) 2013 - 2023  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -33,6 +33,7 @@
 #' @importFrom lifecycle deprecate_soft deprecate_warn
 #' @importFrom glue glue
 #' @importFrom Rcpp evalCpp
+#' @importFrom tools md5sum file_path_sans_ext
 #  @importFrom RcppArmadillo armadillo_version
 
 #' @include Aaaa.R
@@ -65,8 +66,12 @@ GLOBALS$CARRY_TRAN_UC <- c("AMT", "CMT", "EVID", "II", "ADDL", "RATE", "SS")
 GLOBALS$CARRY_TRAN_LC <- tolower(GLOBALS[["CARRY_TRAN_UC"]])
 GLOBALS$CARRY_TRAN <- c("a.u.g", GLOBALS[["CARRY_TRAN_UC"]], GLOBALS[["CARRY_TRAN_LC"]])
 GLOBALS$PKMODEL_NOT_FOUND <- "Required PK parameters not found: "
-GLOBALS$TRAN_UPPER <- c("AMT", "II", "SS", "CMT", "ADDL", "RATE", "EVID","TIME")
+GLOBALS$TRAN_UPPER <- c("AMT", "II", "SS", "CMT", "ADDL", "RATE", "EVID", "TIME")
 GLOBALS$TRAN_LOWER <- tolower(GLOBALS$TRAN_UPPER)
+GLOBALS$TRAN_FILL_NA <- c(
+  "AMT", "CMT", "EVID", "II", "ADDL", "RATE", "SS", 
+  "amt", "cmt", "evid", "ii", "addl", "rate", "ss"
+)
 GLOBALS[["version"]] <- utils::packageVersion("mrgsolve")
 
 block_list <- c("ENV", "PROB", "PARAM", "INIT",

R/class_build.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2022  Metrum Research Group
+# Copyright (C) 2013 - 2023  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -50,6 +50,7 @@ new_build <- function(file=NULL, model, project, soloc=getwd(), code = NULL,
 
   env$win <- .Platform$OS.type=="windows"
 
+
   ## Both project and soloc get normalized
   if(!file_writeable(soloc)) {
     if(file_writeable(dirname(soloc))) {
@@ -93,8 +94,10 @@ new_build <- function(file=NULL, model, project, soloc=getwd(), code = NULL,
     }
   }
 
-  env$md5 <- tools::md5sum(env$modfile)
+  env$md5 <- md5sum(env$modfile)
 
+  env$root <- file_path_sans_ext(basename(env$modfile))
+
   env$package <- ifelse(udll, rfile(model), new_model)
 
   env$compfile <- compfile(new_model)

R/modspec.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2021  Metrum Research Group
+# Copyright (C) 2013 - 2023  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -630,10 +630,9 @@ scrape_and_call <- function(x,env,pass,...) {
   do.call(pass,o)
 }
 
-dump_opts <- function(x,env,block,...) {
-  hasopt <- unique(c(grep(">>", x, fixed=TRUE),grep("@", x, fixed=TRUE))) 
+dump_opts <- function(x, env, block, ...) {
+  hasopt <- grep("^\\s*(>>|@)", x, perl = TRUE)
   if(length(hasopt)==0) return(x)
-  hasopt <- grep("^\\s*(>>|@)", x[hasopt], perl=TRUE)
   x[-hasopt]
 }
 
@@ -650,10 +649,12 @@ eval_ENV_block <- function(x,where,envir=new.env(),...) {
   return(envir)
 }  
 
-parse_env <- function(spec, incoming_names = names(spec),project,ENV=new.env()) {
+parse_env <- function(spec, incoming_names = names(spec),build,ENV=new.env()) {
   n <- length(spec)
   mread.env <- new.env()
-  mread.env$project <- project
+  mread.env$project <- build[["project"]]
+  mread.env$root <- build[["root"]]
+  mread.env$ext <- build[["ext"]]
   mread.env$param <- vector("list", n)
   mread.env$fixed <- vector("list", n)
   mread.env$init  <- vector("list", n)

R/mread.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2021 Metrum Research Group
+# Copyright (C) 2013 - 2023 Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -214,7 +214,7 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
   mread.env <- parse_env(
     spec,
     incoming_block_names,
-    project = build[["project"]], 
+    build,
     ENV
   )
 
@@ -476,7 +476,8 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
   }
 
   cat(
-    paste0("// Source MD5: ", build[["md5"]], "\n"),
+    paste0("// Source MD5: ", build[["md5"]]),
+    "\n// PLUGINS:",
     plugin_code(plugin),
     ## This should get moved to rd
     "\n// FIXED:",
@@ -488,9 +489,9 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
     "\n// MODEL HEADER FILES:",
     incl("mrgsolv.h"), 
     incl("modelheader.h"),
-    "\n//INCLUDE databox functions:",
+    "\n// INCLUDE databox functions:",
     incl("databox_cpp.h"),
-    "\n//USING plugins",
+    "\n// USING plugins:",
     plugin_using(plugin),
     "\n// GLOBAL CODE BLOCK:",
     "// GLOBAL VARS FROM BLOCKS & TYPEDEFS:",

R/mrgindata.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2021  Metrum Research Group
+# Copyright (C) 2013 - 2023  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -180,7 +180,11 @@ valid_data_set <- function(x, m = NULL, verbose = FALSE, quiet = FALSE) {
     signal_drop(dm, x, to_signal, context = "[data-set]")
   }
 
-  check_data_set_na(dm,m)
+  has_na <- check_data_set_na(dm,m)
+
+  if(has_na) {
+    dm <- fill_tran_na(dm)  
+  }
 
   dm <- cbind(dm, matrix(0,
                          ncol=1,
@@ -224,7 +228,7 @@ valid_idata_set <- function(x, m, verbose = FALSE, quiet = FALSE) {
     stop("ID is a required column for idata_set.",call.=FALSE)
   }
 
-  if(any(duplicated(x[["ID"]]))) {
+  if(anyDuplicated(x[["ID"]])) {
     stop("Duplicate IDs not allowed in idata_set.",call.=FALSE) 
   }
 
@@ -241,8 +245,8 @@ valid_idata_set <- function(x, m, verbose = FALSE, quiet = FALSE) {
   dm
 }
 
-##' @rdname valid_data_set
-##' @export
+#' @rdname valid_data_set
+#' @export
 valid_data_set.matrix <- function(x,verbose=FALSE) {
   if(is.valid_data_set(x)) return(x)
   if(is.numeric(x)) {
@@ -252,44 +256,46 @@ valid_data_set.matrix <- function(x,verbose=FALSE) {
 }
 
 check_data_set_na <- function(data,m) {
-  if(!anyNA(data)) return(invisible(NULL))
+  if(!anyNA(data)) return(invisible(FALSE))
   err <- FALSE
-  flagged <- check_column_na(
-    data,
-    Pars(m)
-  )
+  flagged <- check_column_na(data, Pars(m))
   for(col in flagged) {
     warning(
       "Parameter column ", col, " must not contain missing values.", 
       call.=FALSE, immediate.=TRUE
     ) 
   }
-  flagged <- check_column_na(
-    data,
-    c("ID","TIME", "time", "RATE", "rate")
-  )
+  flagged <- check_column_na(data, c("ID", "TIME", "time"))
   for(col in flagged) {
     message(
       col, 
       " column must not contain missing values.", 
-      call.=FALSE,immediate.=TRUE
+      call.=FALSE, immediate.=TRUE
     ) 
     err <- TRUE
   }  
   if(err) stop("Found missing values in input data.", call.=FALSE)
-  return(invisible(NULL))
+  return(invisible(TRUE))
+}
+
+#' Look for TRAN columns replace NA with 0
+#' Columns to scan are found in `GLOBALS$TRAN_FILL_NA`
+#' @noRd
+fill_tran_na <- function(data) {
+  cols_to_zero <- check_column_na(data, GLOBALS[["TRAN_FILL_NA"]])
+  data[, cols_to_zero][is.na(data[, cols_to_zero])] <- 0
+  data
 }
 
 check_column_na <- function(data, cols) {
-  check <- unique(cols[cols %in% dimnames(data)[[2]]])
-  if(length(check)==0) return(character(0))
-  if(!anyNA(data[,check])) return(character(0))
+  to_check <- unique(cols[cols %in% dimnames(data)[[2L]]])
+  if(length(to_check)==0L) return(character(0))
+  if(!anyNA(data[,to_check])) return(character(0))
   flagged <- character(0)
-  for(col in check) {
+  for(col in to_check) {
     if(anyNA(data[,col])) {
-      flagged <- c(flagged,col)
+      flagged <- c(flagged, col)
     }
   }
-  return(flagged)
+  flagged
 }
-

R/nm-mode.R

@@ -35,6 +35,7 @@ find_nm_vars <- function(spec) {
     is_frda <- as.integer(m[["prefix"]] %in% FRDA)
     m <- m[order(is_frda, m[["prefix"]], m[["cmt"]]),, drop = FALSE]
     ans[["frda"]] <- m[m[["prefix"]] %in% FRDA,,drop=FALSE]    
+    ans[["found_frda"]] <- nrow(ans[["frda"]]) > 0
     rownames(m) <- NULL
     ans[["match"]] <- m
     ans[["cmtn"]] <- sort(unique(m[["cmt"]]))
@@ -64,7 +65,7 @@ find_nm_vars_impl <- function(code) {
 }
 
 generate_nmdefs <- function(x) {
-  if(isFALSE(x[["found_any"]])) return(NULL)
+  if(isFALSE(x[["found_frda"]])) return(NULL)
   ans <- paste0(
     "#define ", 
     x[["frda"]][["match"]],

R/nmxml.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2020  Metrum Research Group
+# Copyright (C) 2013 - 2023  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -95,13 +95,16 @@ nmxml <- function(run = numeric(0), project = character(0),
     on.exit(setwd(cwd))
     setwd(env[["project"]])
   }
-  
+
   if(!missing(path)) {
     target <- path
   } else {
     if(missing(run) | missing(project)) {
       wstop("both file and run or project are missing")
     }
+    if(run=="@cppstem") {
+      run <- env$root
+    }
     target <- file.path(project, run, paste0(run, ".xml"))
   }
 
@@ -243,6 +246,10 @@ nmext <- function(run = NA_real_, project = getwd(),
     setwd(env[["project"]])
   }
 
+  if(run=="@cppstem") {
+    run <- env$root
+  }
+
   ans <- read_nmext(
     run = run,
     project = project,

R/utils.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2022  Metrum Research Group
+# Copyright (C) 2013 - 2023  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #

inst/WORDLIST

@@ -146,3 +146,4 @@ KA
 pkgdown
 Rcpp
 df
+MPN

inst/base/databox_cpp.h

@@ -1,4 +1,4 @@
-// Copyright (C) 2013 - 2020  Metrum Research Group
+// Copyright (C) 2013 - 2023  Metrum Research Group
 //
 // This file is part of mrgsolve.
 //
@@ -15,6 +15,10 @@
 // You should have received a copy of the GNU General Public License
 // along with mrgsolve.  If not, see <http://www.gnu.org/licenses/>.
 
+
+#ifndef DATABOX_CPP_H
+#define DATABOX_CPP_H
+
 void databox::mevent(double time, int evid) {
   mrgsolve::evdata ev(time,evid);
   mevector.push_back(ev);
@@ -39,3 +43,5 @@ double databox::tad() {
   if((evid == 1) || (evid == 4)) told = time;
   return told < 0 ? -1.0 : time - told;
 }
+
+#endif

inst/base/mrgsolv.h

@@ -1,4 +1,4 @@
-// Copyright (C) 2013 - 2019  Metrum Research Group, LLC
+// Copyright (C) 2013 - 2023  Metrum Research Group
 //
 // This file is part of mrgsolve.
 //
@@ -77,6 +77,7 @@ namespace mrg = mrgsolve;
 
 //! member functions mevent and tad come in via housemodel; see inst/base/databox.cpp
 
+
 /**
  * Model data passed to the model.  
  * 

inst/maintenance/build_housemodel.R

@@ -2,6 +2,7 @@
 suppressPackageStartupMessages(library(dplyr))
 suppressPackageStartupMessages(library(methods))
 suppressPackageStartupMessages(library(glue))
+suppressPackageStartupMessages(library(tools))
 fun <- function() {
   setClass("mrgsims")
   source("R/utils.R")

inst/maintenance/tests.R

@@ -9,10 +9,7 @@ a$result <- NULL
 message("\ninst/maintenance/unit")
 b <- test_dir("inst/maintenance/unit/")
 b$result <- NULL
-message("\ninst/validation")
-c <- test_dir("inst/validation/")
-c$result <- NULL
-results <- dplyr::bind_rows(as_tibble(a),as_tibble(b),as_tibble(c))
+results <- dplyr::bind_rows(as_tibble(a),as_tibble(b))
 results$user <- NULL
 results$system <- NULL
 results$real <- NULL