From 4823e451cf389973bc96af7f8f2568906b5a04b3 Mon Sep 17 00:00:00 2001 From: "Julian D. Otalvaro" Date: Thu, 28 Mar 2024 18:40:44 +0000 Subject: [PATCH] artifacts flag for RUN, default True. If True the etc folder will be created and all the artifacts produced during compilation will be stored there --- R/NPrun.R | 4 +- R/PM_fit.R | 9 + R/PM_model.R | 1562 +++++++++++++++++++++++++------------------------- 3 files changed, 796 insertions(+), 779 deletions(-) diff --git a/R/NPrun.R b/R/NPrun.R index 34664615..13f7af40 100644 --- a/R/NPrun.R +++ b/R/NPrun.R @@ -62,6 +62,8 @@ #' in the first cycle, with a speed-up of approximately 80\% of the number of available cores on your machine, e.g. an 8-core machine #' will speed up the first cycle by 0.8 * 8 = 6.4-fold. Subsequent cycles approach about 50\%, e.g. 4-fold increase on an 8-core #' machine. Overall speed up for a run will therefore depend on the number of cycles run and the number of cores. +#' @param artifacts Default is \code{TRUE}. Set to \code{FALSE} to suppress creating the \code{etc} folder. This folder +#' will contain all the compilation artifacts created during the compilation and run steps. #' @param alq For internal developer use only. Should be set to \code{FALSE}. #' @param remote Default is \code{FALSE}. Set to \code{TRUE} if loading results of an NPAG run on remote server. #' @param server_address If missing, will use the default server address returned by getPMoptions(). @@ -98,7 +100,7 @@ NPrun <- function(model = "model.txt", data = "data.csv", run, indpts, icen = "median", aucint, idelta = 12, prior, auto = TRUE, intern = FALSE, quiet = FALSE, overwrite = FALSE, nocheck = FALSE, parallel = NA, - alq = FALSE, remote = FALSE, server_address, report = TRUE) { + alq = FALSE, remote = FALSE, server_address, report = TRUE, artifacts = TRUE) { if (missing(run)) run <- NULL if (missing(include)) include <- NULL if (missing(exclude)) exclude <- NULL diff --git a/R/PM_fit.R b/R/PM_fit.R index 5ef58222..796612b2 100644 --- a/R/PM_fit.R +++ b/R/PM_fit.R @@ -149,6 +149,14 @@ PM_fit <- R6::R6Class("PM_fit", } dir.create(newdir) setwd(newdir) + ### Move temp folder to ect/PMcore ### + # check if temp folder exist, create if not + if (arglist$artifacts) { + if (!file.exists("etc")) { + dir.create("etc") + } + system(sprintf("cp -R %s etc/PMcore", getPMoptions()$rust_template)) + } # Include or exclude subjects according to data_filtered <- self$data$standard_data if (!is.symbol(arglist$include)) { @@ -288,6 +296,7 @@ PM_fit <- R6::R6Class("PM_fit", } } else { system2("./NPcore", args = "&") + # TODO: The code to generate the report is missing here } setwd(cwd) }, diff --git a/R/PM_model.R b/R/PM_model.R index b7a9f8cf..e8751fd3 100644 --- a/R/PM_model.R +++ b/R/PM_model.R @@ -14,74 +14,74 @@ #' #' @export PM_model <- R6::R6Class("PM_Vmodel", - public = list( - #' @description - #' Build a new PM_model from a variety of inputs. - #' @param model This can be a quoted name of a model text file in the - #' working directory which will be read and passed to Fortran engines unless - #' \code{julia = TRUE} in which case is will be passed as a Julia model. - #' It can be a list of lists that defines the model directly in R. Similarly, - #' it can be a function that defines a Julia model directly in R. See the user - #' manual for more help on directly defining models in R. - #' @param julia Controls whether a filename defines a Fortran or Julia model. - #' Default is \code{FALSE}, i.e. using Fortran. - #' @param ... Additional arguments passed to creation of new Julia model. - - # the following functions are dummy to permit documentation - new = function(model, ..., julia = F) { - return(invisible()) - }, - #' @description - #' Print a model object to the console in readable format - #' @param ... Not used currently. - print = function(...) { - return(invisible()) - }, - #' @description - #' Update selected elements of a model object - #' @param changes_list The named list containing elements and values to update. - #' Because R6 objects are mini-environments, using typical - #' R notation to copy an object like mod2 <- mod1 can lead to unexpected - #' results since this syntax simply creates a copied object in the same - #' environment. Therefore updating any one object (e.g., mod1 or mod2) - #' will update the other. To avoid this behavior, use the $clone() function - #' first if you want to create a copied, yet independent new model. - #' @examples - #' mod2 <- modEx$clone() #create an independent copy of modEx called mod2 - #' mod2$update(list( - #' pri = list( - #' Ke = ab(0, 1), #change the range - #' V = NULL, #this deletes the variable - #' V0 = ab(10, 100) #add a new variable - #' ), - #' sec = "V = V0 * WT" #add a new secondary equation - #' )) - #' #note that they are different now - #' mod2 - #' modEx - update = function(changes_list) { - return(invisible()) - }, - #' @description Write a `PM_model` object to a text file - #' @param model_path Full name of the file to be created, including the path - #' relative to the current working directory - #' @param engine Currently only "npag". - #' @examples - #' \dontrun{ - #' modEx$write("model.txt") - #' } - write = function(model_path = "genmodel.txt", engine = "npag") { - return(invisible()) - }, - #' @description - #' Plot method - #' @details - #' See [plot.PM_model]. - #' @param ... Arguments passed to [plot.PM_model] - plot = function(...) { - return(invisible()) - } - ) + public = list( + #' @description + #' Build a new PM_model from a variety of inputs. + #' @param model This can be a quoted name of a model text file in the + #' working directory which will be read and passed to Fortran engines unless + #' \code{julia = TRUE} in which case is will be passed as a Julia model. + #' It can be a list of lists that defines the model directly in R. Similarly, + #' it can be a function that defines a Julia model directly in R. See the user + #' manual for more help on directly defining models in R. + #' @param julia Controls whether a filename defines a Fortran or Julia model. + #' Default is \code{FALSE}, i.e. using Fortran. + #' @param ... Additional arguments passed to creation of new Julia model. + + # the following functions are dummy to permit documentation + new = function(model, ..., julia = F) { + return(invisible()) + }, + #' @description + #' Print a model object to the console in readable format + #' @param ... Not used currently. + print = function(...) { + return(invisible()) + }, + #' @description + #' Update selected elements of a model object + #' @param changes_list The named list containing elements and values to update. + #' Because R6 objects are mini-environments, using typical + #' R notation to copy an object like mod2 <- mod1 can lead to unexpected + #' results since this syntax simply creates a copied object in the same + #' environment. Therefore updating any one object (e.g., mod1 or mod2) + #' will update the other. To avoid this behavior, use the $clone() function + #' first if you want to create a copied, yet independent new model. + #' @examples + #' mod2 <- modEx$clone() #create an independent copy of modEx called mod2 + #' mod2$update(list( + #' pri = list( + #' Ke = ab(0, 1), #change the range + #' V = NULL, #this deletes the variable + #' V0 = ab(10, 100) #add a new variable + #' ), + #' sec = "V = V0 * WT" #add a new secondary equation + #' )) + #' #note that they are different now + #' mod2 + #' modEx + update = function(changes_list) { + return(invisible()) + }, + #' @description Write a `PM_model` object to a text file + #' @param model_path Full name of the file to be created, including the path + #' relative to the current working directory + #' @param engine Currently only "npag". + #' @examples + #' \dontrun{ + #' modEx$write("model.txt") + #' } + write = function(model_path = "genmodel.txt", engine = "npag") { + return(invisible()) + }, + #' @description + #' Plot method + #' @details + #' See [plot.PM_model]. + #' @param ... Arguments passed to [plot.PM_model] + plot = function(...) { + return(invisible()) + } + ) ) @@ -246,114 +246,114 @@ covariate <- function(name, constant = FALSE) { # Virtual Class # Here is where the model_list is printed to the console PM_Vmodel <- R6::R6Class("PM_model", - public = list( - name = NULL, # used by PM_model_legacy - # error = NULL, - initialize = function() { - stop("Unable to initialize abstract class") - }, - print = function(...) { - cat("$model_list\n") - mlist <- self$model_list - blockNames <- names(mlist) - - # internal function to add space blocks - sp <- function(n) { - paste0(rep(" ", n), collapse = "") - } - - sapply(blockNames, function(x) { - if (x == "pri") { - # cat("\t$pri\n") - cat(sp(1), "$pri\n") - for (i in 1:length(mlist$pri)) { - thispri <- mlist$pri[[i]] - thisname <- names(mlist$pri)[i] - if (is.null(thispri$fixed)) { - cat(paste0( - sp(2), "$", thisname, "\n", sp(3), "$min: ", round(thispri$min, 3), - "\n", sp(3), "$max: ", round(thispri$max, 3), - "\n", sp(3), "$mean: ", round(thispri$mean, 3), - "\n", sp(3), "$sd: ", round(thispri$sd, 3), - "\n", sp(3), "$gtz: ", thispri$gtz, "\n" - )) - } else { - cat(paste0( - sp(2), "$", thisname, "\n", sp(3), "$fixed: ", round(thispri$fixed, 3), - "\n", sp(3), "$contant: ", thispri$constant, - "\n" - )) - } - } - } else if (x == "cov") { - cat("\n", sp(1), "$cov\n") - for (i in 1:length(mlist$cov)) { - thisout <- mlist$cov[[i]] - cat(paste0( - sp(2), "$covariate: ", thisout$covariate, "\n", - sp(3), "$constant: ", thisout$constant, "\n", - "\n" - )) - } - } else if (x == "ext") { - cat("\n", sp(1), "$ext\n", paste0(sp(2), "[", 1:length(mlist$ext), "] \"", mlist$ext, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "sec") { - cat("\n", sp(1), "$sec\n", paste0(sp(2), "[", 1:length(mlist$sec), "] \"", mlist$sec, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "dif" | x == "eqn") { - if (is.null(mlist$eqn)) { - cat("Please change the name of your #dif block to #eqn.") - mlist$eqn <- mlist$dif - } - cat("\n", sp(1), "$eqn\n", paste0(sp(2), "[", 1:length(mlist$eqn), "] \"", mlist$eqn, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "lag") { - cat("\n", sp(1), "$lag\n", paste0(sp(2), "[", 1:length(mlist$lag), "] \"", mlist$lag, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "bol") { - cat("\n", sp(1), "$bol\n", paste0(sp(2), "[", 1:length(mlist$bol), "] \"", mlist$bol, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "fa") { - cat("\n", sp(1), "$fa\n", paste0(sp(2), "[", 1:length(mlist$fa), "] \"", mlist$fa, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "ini") { - cat("\n", sp(1), "$ini\n", paste0(sp(2), "[", 1:length(mlist$ini), "] \"", mlist$ini, "\"", collapse = "\n ")) - cat("\n") - } else if (x == "out") { - cat("\n", sp(1), "$out\n") - for (i in 1:length(mlist$out)) { - thisout <- mlist$out[[i]] - cat(paste0( - sp(2), "$Y", i, "\n", - sp(3), "$val: \"", thisout[[1]], "\"\n", - sp(3), "$err\n", - sp(4), "$model\n", - sp(5), "$additive: ", thisout$err$model$additive, "\n", - sp(5), "$proportional: ", thisout$err$model$proportional, "\n", - sp(5), "$constant: ", thisout$err$model$constant, "\n", - sp(4), "$assay\n", - sp(5), "$coefficients: ", - paste0("[", 1:length(thisout$err$assay$coefficients), "] ", thisout$err$assay$coefficients, collapse = ", "), "\n", - sp(5), "$constant: ", thisout$err$assay$constant, "\n", - "\n" - )) - } - cat("\n") - } - }) # end sapply - - invisible(self) - }, - plot = function(...) { - plot.PM_model(self, ...) - } - ), - private = list( - validate = function() { - # add checks here - } - ) + public = list( + name = NULL, # used by PM_model_legacy + # error = NULL, + initialize = function() { + stop("Unable to initialize abstract class") + }, + print = function(...) { + cat("$model_list\n") + mlist <- self$model_list + blockNames <- names(mlist) + + # internal function to add space blocks + sp <- function(n) { + paste0(rep(" ", n), collapse = "") + } + + sapply(blockNames, function(x) { + if (x == "pri") { + # cat("\t$pri\n") + cat(sp(1), "$pri\n") + for (i in 1:length(mlist$pri)) { + thispri <- mlist$pri[[i]] + thisname <- names(mlist$pri)[i] + if (is.null(thispri$fixed)) { + cat(paste0( + sp(2), "$", thisname, "\n", sp(3), "$min: ", round(thispri$min, 3), + "\n", sp(3), "$max: ", round(thispri$max, 3), + "\n", sp(3), "$mean: ", round(thispri$mean, 3), + "\n", sp(3), "$sd: ", round(thispri$sd, 3), + "\n", sp(3), "$gtz: ", thispri$gtz, "\n" + )) + } else { + cat(paste0( + sp(2), "$", thisname, "\n", sp(3), "$fixed: ", round(thispri$fixed, 3), + "\n", sp(3), "$contant: ", thispri$constant, + "\n" + )) + } + } + } else if (x == "cov") { + cat("\n", sp(1), "$cov\n") + for (i in 1:length(mlist$cov)) { + thisout <- mlist$cov[[i]] + cat(paste0( + sp(2), "$covariate: ", thisout$covariate, "\n", + sp(3), "$constant: ", thisout$constant, "\n", + "\n" + )) + } + } else if (x == "ext") { + cat("\n", sp(1), "$ext\n", paste0(sp(2), "[", 1:length(mlist$ext), "] \"", mlist$ext, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "sec") { + cat("\n", sp(1), "$sec\n", paste0(sp(2), "[", 1:length(mlist$sec), "] \"", mlist$sec, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "dif" | x == "eqn") { + if (is.null(mlist$eqn)) { + cat("Please change the name of your #dif block to #eqn.") + mlist$eqn <- mlist$dif + } + cat("\n", sp(1), "$eqn\n", paste0(sp(2), "[", 1:length(mlist$eqn), "] \"", mlist$eqn, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "lag") { + cat("\n", sp(1), "$lag\n", paste0(sp(2), "[", 1:length(mlist$lag), "] \"", mlist$lag, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "bol") { + cat("\n", sp(1), "$bol\n", paste0(sp(2), "[", 1:length(mlist$bol), "] \"", mlist$bol, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "fa") { + cat("\n", sp(1), "$fa\n", paste0(sp(2), "[", 1:length(mlist$fa), "] \"", mlist$fa, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "ini") { + cat("\n", sp(1), "$ini\n", paste0(sp(2), "[", 1:length(mlist$ini), "] \"", mlist$ini, "\"", collapse = "\n ")) + cat("\n") + } else if (x == "out") { + cat("\n", sp(1), "$out\n") + for (i in 1:length(mlist$out)) { + thisout <- mlist$out[[i]] + cat(paste0( + sp(2), "$Y", i, "\n", + sp(3), "$val: \"", thisout[[1]], "\"\n", + sp(3), "$err\n", + sp(4), "$model\n", + sp(5), "$additive: ", thisout$err$model$additive, "\n", + sp(5), "$proportional: ", thisout$err$model$proportional, "\n", + sp(5), "$constant: ", thisout$err$model$constant, "\n", + sp(4), "$assay\n", + sp(5), "$coefficients: ", + paste0("[", 1:length(thisout$err$assay$coefficients), "] ", thisout$err$assay$coefficients, collapse = ", "), "\n", + sp(5), "$constant: ", thisout$err$assay$constant, "\n", + "\n" + )) + } + cat("\n") + } + }) # end sapply + + invisible(self) + }, + plot = function(...) { + plot.PM_model(self, ...) + } + ), + private = list( + validate = function() { + # add checks here + } + ) ) @@ -502,400 +502,406 @@ PM_Vinput <- R6::R6Class( PM_model_list <- R6::R6Class("PM_model_list", - inherit = PM_Vmodel, - public = list( - model_list = NULL, - initialize = function(model_list) { - # guarantees primary keys are lowercase and max first 3 characters - orig_names <- names(model_list) - names(model_list) <- private$lower3(names(model_list)) - model_blocks <- names(model_list) - if (!identical(model_blocks, orig_names)) cat("Model block names standardized to 3 lowercase characters.\n") - if (!"pri" %in% model_blocks) stop("Model must have a PRImary block.") - if (!"out" %in% model_blocks) stop("Model must have an OUTput block.") - n_out <- length(names(model_list$out)) - for (i in 1:n_out) { - out_names <- private$lower3(names(model_list$out[[i]])) - names(model_list$out[[i]]) <- out_names - if (!"err" %in% out_names) { - stop("Ensure all outputs have an ERRor block.") - } - if (!"model" %in% names(model_list$out[[i]]$err) || - !"assay" %in% names(model_list$out[[i]]$err)) { - stop("ERRor blocks need 'model' and 'assay' components.") - } - if (!"proportional" %in% names(model_list$out[[i]]$err$model) || - !"additive" %in% names(model_list$out[[i]]$err$model)) { - stop("ERRor model block must be either proportional or additive.") - } - } - - self$model_list <- model_list - }, - write = function(model_path = "genmodel.txt", engine = "npag") { - engine <- tolower(engine) - keys <- names(self$model_list) - lines <- c() - for (i in 1:length(keys)) { - lines <- private$write_block(lines, keys[i], self$model_list[[i]], engine) - } - fileConn <- file(model_path) - writeLines(lines, fileConn) - close(fileConn) - - return(model_path) - }, - write_rust = function() { - model_file <- system.file("Rust/template.rs", package = "Pmetrics") - content <- readr::read_file(model_file) - parameter_alias <- c() - self_parameter_alias <- c() - parameter_definition <- c() - index <- 0 - for (key in tolower(names(self$model_list$pri))) { - parameter_alias <- append(parameter_alias, sprintf("let %s = system.get_param(\"%s\");", key, key)) - self_parameter_alias <- append(self_parameter_alias, sprintf("let %s = self.get_param(\"%s\");", key, key)) - parameter_definition <- append(parameter_definition, sprintf("params.insert(\"%s\".to_string(), parameters[%i].clone());", key, index)) - index <- index + 1 - } - content <- gsub("", parameter_alias %>% paste(collapse = "\n"), content) - content <- gsub("", self_parameter_alias %>% paste(collapse = "\n"), content) - content <- gsub("", parameter_definition %>% paste(collapse = "\n"), content) - - eqs <- self$model_list$eqn %>% tolower() - #look for xp() or dx[] - neqs <- sum(sapply(stringr::str_extract_all(eqs, "xp\\(\\d+\\)|dx\\[\\d+\\]"), function(x) length(x) > 0)) - if (neqs == 0) {stop("Error: PMcore does not support analytic equations, provide a eqn block.")} - content <- gsub("", neqs, content) - - cov <- self$model_list$cov %>% purrr::map(function(c) { - val <- c$covariate - paste0("let ", val %>% tolower(), " = cov.get(\"", val, "\").unwrap().interp(t);\n") - }) - content <- gsub("", cov %>% paste0(collapse = ""), content) - - seq <- self$model_list$sec %>% purrr::map(function(l) { - l <- private$rust_up(l) #convert fortran/R to rust - if(stringr::str_detect(l, regex("if|else|[{}]", ignore_case = TRUE))){ - return(l) #return the corrected line - } else { - #contruct the variable declaration - splitted <- stringr::str_split(l, "=")[[1]] - lhs <- splitted[1] %>% tolower() - rhs <- splitted[2] %>% tolower() - return(paste0("let ", lhs, " = ", rhs, ";\n")) - } - }) #end line by line mapping of seq - - content <- gsub("", seq %>% paste(collapse = ""), content) - - eqs <- eqs %>% - stringr::str_replace_all("\\((\\d)\\)", function(a) { - paste0("[", as.integer(substring(a, 2, 2)) - 1, "]") - }) %>% - stringr::str_replace_all("xp", "dx") %>% - purrr::map(\(l) private$rust_up(l)) - - content <- gsub("", paste0(eqs %>% paste(collapse = ";\n"), ";"), content) - - lags <- "scenario.reorder_with_lag(vec![" - for (line in self$model_list$lag %>% tolower()) { - match <- stringr::str_match(line, "tlag\\((\\d+)\\)\\s*=\\s*(\\w+)") - lags <- append(lags, sprintf("(%s,%i),", match[3], strtoi(match[2]))) - } - lags <- append(lags, "])") - lags <- if (self$model_list$lag %>% length() > 0) { - lags - } else { - "scenario" - } - lags <- lags %>% purrr::map(\(l) private$rust_up(l)) - content <- gsub("", lags %>% paste0(collapse = ""), content) - out <- "match outeq {" - n_out <- 1 - for (outeq in self$model_list$out) { - out <- append(out, paste(n_out, " => ")) - out <- append(out, stringr::str_replace_all(tolower(outeq[[1]][[1]]), "\\((\\d)\\)", function(a) { - paste0("[", as.integer(substring(a, 2, 2)) - 1, "]") - })) - out <- append(out, ",") - n_out <- n_out + 1 - } - out <- append(out, "_ => panic!(\"Invalid output equation\")") - out <- append(out, "}") - out <- out %>% purrr::map(\(l) private$rust_up(l)) - - content <- gsub("", out %>% paste(collapse = "\n"), content) - readr::write_file(content, "main.rs") - }, - update = function(changes_list) { - keys <- names(changes_list) - stopifnot(private$lower3(keys) %in% c("pri", "sec", "dif", "eqn", "ini", "cov", "lag", "bol", "out", "err", "fa", "ext")) - self$model_list <- modifyList(self$model_list, changes_list) - } - ), - private = list( - #converts fortran/R to rust - rust_up <- function(.l){ - #sequentially modify for operators - pattern1 <- "(\\((?:[^)(]+|(?1))*+\\))" - #this pattern recursively finds nested parentheses - #and returns contents of outer - for(x in c("abs", "exp", "ln", "log", "log10", "sqrt")){ - .l <- gsub(pattern = paste0(x, pattern1), - replacement = paste0("\\1\\.", x, "\\(\\)"), - x = .l, - perl = TRUE) - } - - .l <- gsub("log", "ln", .l) #log in R and Fortran is ln in Rust - - #deal with exponents - pattern2 <- "[\\*\\^]+([+-]?([0-9]*[.])?[0-9]+)" - replace2 <- "\\.powf\\(\\1\\)" - .l <- gsub(pattern2, replace2, .l, perl = TRUE) - - #deal with integers - pattern3 = "(? -1){ #found something - found <- regmatches(x = .l, m = n_found) - repl <- paste(gsub("[()]", " ", regmatches(x = .l, m = n_found)), "{") - .l <- gsub(pattern = found, replacement = repl, x = .l, fixed = TRUE) - if(grepl("then", .l, ignore.case = TRUE)){ #remove 'then' - .l <- paste(gsub(pattern = "then", replacement = "", x = .l, ignore.case = TRUE), "\n") - } else { #single line if - .l <- paste(.l,"}\n") - } - } - } - if(code == "else"){ - .l <- gsub(pattern = "^&*else", - replacement = "\\} else \\{\n", - x = .l, ignore.case = TRUE) - } - if(code == "end if"){ - .l <- gsub(pattern = "^&*end if", - replacement = "}\n", - x = .l, ignore.case = TRUE) - } - return(.l) - } #end if_fix function - - #fix if and if-else blocks - for(i in c("if", "else if", "else", "end if")){ - .l <- if_fix(i, .l) - } - - return(.l) - - }, #end rust_up function - - lower3 = function(chr) { - purrr::map_chr(chr, function(x) { - substr(tolower(x), 1, 3) - }) - }, - write_block = function(lines, key, block, engine) { - if (private$lower3(key) == "fa") { - key <- "f" - } - lines <- append(lines, sprintf("#%s", key)) - if (private$lower3(key) == "pri") { - i <- 1 - for (param in names(block)) { - lines <- append( - lines, - if (is.numeric(block[[i]])) { - sprintf("%s, %f", param, block[[i]]) - } else { - sprintf("%s, %s", param, block[[i]]$print_to("ab", engine)) - } - ) - i <- i + 1 - } - } else if (private$lower3(key) == "cov") { - for (i in 1:length(block)) { - lines <- append( - lines, - if (block[[i]]$constant) { - sprintf("%s!", block[[i]]$covariate) - } else { - sprintf("%s", block[[i]]$covariate) - } - ) - } - } else if (private$lower3(key) %in% c("bol", "ext")) { - stopifnot(is.null(names(block))) - for (i in 1:length(block)) { - lines <- append(lines, sprintf("%s", block[[i]])) - } - } else if (private$lower3(key) == "sec") { - names <- names(block) - for (i in 1:length(block)) { - key <- toupper(names[i]) - lines <- append( - lines, - if (is.null(names[i]) || nchar(names[i]) == 0) { - sprintf("%s", block[[i]]) - } else { - sprintf("%s = %s", key, block[[i]][1]) - } - ) - } - } else if (private$lower3(key) == "lag") { - names <- names(block) - for (i in 1:length(block)) { - key <- toupper(names[i]) - lines <- append( - lines, - if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list - if (stringr::str_starts(block[[i]], "&")) { # add on statement - block[[i]] - } else { - # grab right side of equation if there - rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] - if (!is.na(rhs)) { - rhs <- stringr::str_replace_all(rhs, " ", "") - } else { # no "=" detected - stop(sprintf("Error: No equation detected for lag expression: %s", block[[i]][1])) - } - lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] - eqn <- stringr::str_extract(lhs, "\\d+") - if (is.na(eqn)) { # no number in lhs - stop(sprintf("Error: No equation number detected for lag expression: %s", block[[i]][1])) - } - sprintf("TLAG[%s] = %s", eqn, rhs) - } - } else { # named list - eqn <- stringr::str_extract(names[i], "\\d+") # standardize - sprintf("TLAG[%s] = %s", eqn, block[[i]][1]) - } - ) - } - } else if (private$lower3(key) == "ini") { - names <- names(block) - for (i in 1:length(block)) { - key <- toupper(names[i]) - lines <- append( - lines, - if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list - if (stringr::str_starts(block[[i]], "&")) { # add on statement - block[[i]] - } else { # grab right side of equation if there - rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] - if (!is.na(rhs)) { - rhs <- stringr::str_replace_all(rhs, " ", "") - } else { # no "=" detected - stop(sprintf("Error: No equation detected for initial conditions: %s", block[[i]][1])) - } - lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] - eqn <- stringr::str_extract(lhs, "\\d+") - if (is.na(eqn)) { # no number in lhs - stop(sprintf("Error: No equation number detected for initial conditions: %s", block[[i]][1])) - } - sprintf("X[%s] = %s", eqn, rhs) - } - } else { # named list - eqn <- stringr::str_extract(names[i], "\\d+") # standardize - sprintf("X[%s] = %s", eqn, block[[i]][1]) - } - ) - } - } else if (private$lower3(key) == "f") { - names <- names(block) - for (i in 1:length(block)) { - key <- toupper(names[i]) - lines <- append( - lines, - if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list - if (stringr::str_starts(block[[i]], "&")) { # add on statement - block[[i]] - } else { # grab right side of equation if there - rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] - if (!is.na(rhs)) { - rhs <- stringr::str_replace_all(rhs, " ", "") - } else { # no "=" detected - stop(sprintf("Error: No equation detected for bioavailability: %s", block[[i]][1])) - } - lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] - eqn <- stringr::str_extract(lhs, "\\d+") - if (is.na(eqn)) { # no number in lhs - stop(sprintf("Error: No equation number detected for bioavailabilty: %s", block[[i]][1])) - } - sprintf("FA[%s] = %s", eqn, rhs) - } - } else { # named list - eqn <- stringr::str_extract(names[i], "\\d+") # standardize - sprintf("FA[%s] = %s", eqn, block[[i]][1]) - } - ) - } - } else if (private$lower3(key) == "dif" | private$lower3(key) == "eqn") { - # names <- names(block) - for (i in 1:length(block)) { - # key <- toupper(names[i]) - lines <- append( - lines, - block[[i]] - # if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list - # # grab right side of equation if there - # rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] - # if (!is.na(rhs)) { - # rhs <- stringr::str_replace_all(rhs, " ", "") - # } else { # no "=" detected - # stop(sprintf("Error: No differential equation(s) detected for: %s", block[[i]][1])) - # } - # lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] - # eqn <- stringr::str_extract(lhs, "\\d+") - # if (is.na(eqn)) { # no number in lhs - # stop(sprintf("Error: No differential equation number detected for: %s", block[[i]][1])) - # } - # sprintf("XP(%s) = %s", eqn, rhs) - # } else { # named list - # eqn <- stringr::str_extract(names[i], "\\d+") # standardize - # sprintf("XP(%s) = %s", eqn, block[[i]][1]) - # } - ) - } - } else if (private$lower3(key) == "out") { - i <- 1 # keep track of the first outeq - err_lines <- "#err" - for (param in names(block)) { - stopifnot(nchar(param) == 2 || nchar(param) == 0) - key <- toupper(names(block)[i]) - lines <- append( - lines, - if (nchar(param) == 2) { - sprintf("%s[%s]=%s", substr(key, 1, 1), substr(key, 2, 2), block[[i]][1]) - } else { - sprintf("%s", block[[i]][1]) - } - ) - err_block <- block[[i]]$err - if (i == 1) { - err_lines <- append(err_lines, err_block$model$print_to("ab", engine)) - } - err_lines <- append(err_lines, err_block$assay$print_to("ab", engine)) - - i <- i + 1 - } - lines <- append(lines, "") - lines <- append(lines, err_lines) - } else { - stop(sprintf("Error: Unsupported block named: %s", key)) - } - lines <- append(lines, "") - return(lines) - } - ) + inherit = PM_Vmodel, + public = list( + model_list = NULL, + initialize = function(model_list) { + # guarantees primary keys are lowercase and max first 3 characters + orig_names <- names(model_list) + names(model_list) <- private$lower3(names(model_list)) + model_blocks <- names(model_list) + if (!identical(model_blocks, orig_names)) cat("Model block names standardized to 3 lowercase characters.\n") + if (!"pri" %in% model_blocks) stop("Model must have a PRImary block.") + if (!"out" %in% model_blocks) stop("Model must have an OUTput block.") + n_out <- length(names(model_list$out)) + for (i in 1:n_out) { + out_names <- private$lower3(names(model_list$out[[i]])) + names(model_list$out[[i]]) <- out_names + if (!"err" %in% out_names) { + stop("Ensure all outputs have an ERRor block.") + } + if (!"model" %in% names(model_list$out[[i]]$err) || + !"assay" %in% names(model_list$out[[i]]$err)) { + stop("ERRor blocks need 'model' and 'assay' components.") + } + if (!"proportional" %in% names(model_list$out[[i]]$err$model) || + !"additive" %in% names(model_list$out[[i]]$err$model)) { + stop("ERRor model block must be either proportional or additive.") + } + } + + self$model_list <- model_list + }, + write = function(model_path = "genmodel.txt", engine = "npag") { + engine <- tolower(engine) + keys <- names(self$model_list) + lines <- c() + for (i in 1:length(keys)) { + lines <- private$write_block(lines, keys[i], self$model_list[[i]], engine) + } + fileConn <- file(model_path) + writeLines(lines, fileConn) + close(fileConn) + + return(model_path) + }, + write_rust = function() { + model_file <- system.file("Rust/template.rs", package = "Pmetrics") + content <- readr::read_file(model_file) + parameter_alias <- c() + self_parameter_alias <- c() + parameter_definition <- c() + index <- 0 + for (key in tolower(names(self$model_list$pri))) { + parameter_alias <- append(parameter_alias, sprintf("let %s = system.get_param(\"%s\");", key, key)) + self_parameter_alias <- append(self_parameter_alias, sprintf("let %s = self.get_param(\"%s\");", key, key)) + parameter_definition <- append(parameter_definition, sprintf("params.insert(\"%s\".to_string(), parameters[%i].clone());", key, index)) + index <- index + 1 + } + content <- gsub("", parameter_alias %>% paste(collapse = "\n"), content) + content <- gsub("", self_parameter_alias %>% paste(collapse = "\n"), content) + content <- gsub("", parameter_definition %>% paste(collapse = "\n"), content) + + eqs <- self$model_list$eqn %>% tolower() + # look for xp() or dx[] + neqs <- sum(sapply(stringr::str_extract_all(eqs, "xp\\(\\d+\\)|dx\\[\\d+\\]"), function(x) length(x) > 0)) + if (neqs == 0) { + stop("Error: PMcore does not support analytic equations, provide a eqn block.") + } + content <- gsub("", neqs, content) + + cov <- self$model_list$cov %>% purrr::map(function(c) { + val <- c$covariate + paste0("let ", val %>% tolower(), " = cov.get(\"", val, "\").unwrap().interp(t);\n") + }) + content <- gsub("", cov %>% paste0(collapse = ""), content) + + seq <- self$model_list$sec %>% purrr::map(function(l) { + l <- private$rust_up(l) # convert fortran/R to rust + if (stringr::str_detect(l, regex("if|else|[{}]", ignore_case = TRUE))) { + return(l) # return the corrected line + } else { + # contruct the variable declaration + splitted <- stringr::str_split(l, "=")[[1]] + lhs <- splitted[1] %>% tolower() + rhs <- splitted[2] %>% tolower() + return(paste0("let ", lhs, " = ", rhs, ";\n")) + } + }) # end line by line mapping of seq + + content <- gsub("", seq %>% paste(collapse = ""), content) + + eqs <- eqs %>% + stringr::str_replace_all("\\((\\d)\\)", function(a) { + paste0("[", as.integer(substring(a, 2, 2)) - 1, "]") + }) %>% + stringr::str_replace_all("xp", "dx") %>% + purrr::map(\(l) private$rust_up(l)) + + content <- gsub("", paste0(eqs %>% paste(collapse = ";\n"), ";"), content) + + lags <- "scenario.reorder_with_lag(vec![" + for (line in self$model_list$lag %>% tolower()) { + match <- stringr::str_match(line, "tlag\\((\\d+)\\)\\s*=\\s*(\\w+)") + lags <- append(lags, sprintf("(%s,%i),", match[3], strtoi(match[2]))) + } + lags <- append(lags, "])") + lags <- if (self$model_list$lag %>% length() > 0) { + lags + } else { + "scenario" + } + lags <- lags %>% purrr::map(\(l) private$rust_up(l)) + content <- gsub("", lags %>% paste0(collapse = ""), content) + out <- "match outeq {" + n_out <- 1 + for (outeq in self$model_list$out) { + out <- append(out, paste(n_out, " => ")) + out <- append(out, stringr::str_replace_all(tolower(outeq[[1]][[1]]), "\\((\\d)\\)", function(a) { + paste0("[", as.integer(substring(a, 2, 2)) - 1, "]") + })) + out <- append(out, ",") + n_out <- n_out + 1 + } + out <- append(out, "_ => panic!(\"Invalid output equation\")") + out <- append(out, "}") + out <- out %>% purrr::map(\(l) private$rust_up(l)) + + content <- gsub("", out %>% paste(collapse = "\n"), content) + readr::write_file(content, "main.rs") + }, + update = function(changes_list) { + keys <- names(changes_list) + stopifnot(private$lower3(keys) %in% c("pri", "sec", "dif", "eqn", "ini", "cov", "lag", "bol", "out", "err", "fa", "ext")) + self$model_list <- modifyList(self$model_list, changes_list) + } + ), + private = list( + # converts fortran/R to rust + rust_up = function(.l) { + # sequentially modify for operators + pattern1 <- "(\\((?:[^)(]+|(?1))*+\\))" + # this pattern recursively finds nested parentheses + # and returns contents of outer + for (x in c("abs", "exp", "ln", "log", "log10", "sqrt")) { + .l <- gsub( + pattern = paste0(x, pattern1), + replacement = paste0("\\1\\.", x, "\\(\\)"), + x = .l, + perl = TRUE + ) + } + + .l <- gsub("log", "ln", .l) # log in R and Fortran is ln in Rust + + # deal with exponents + pattern2 <- "[\\*\\^]+([+-]?([0-9]*[.])?[0-9]+)" + replace2 <- "\\.powf\\(\\1\\)" + .l <- gsub(pattern2, replace2, .l, perl = TRUE) + + # deal with integers + pattern3 <- "(? -1) { # found something + found <- regmatches(x = .l, m = n_found) + repl <- paste(gsub("[()]", " ", regmatches(x = .l, m = n_found)), "{") + .l <- gsub(pattern = found, replacement = repl, x = .l, fixed = TRUE) + if (grepl("then", .l, ignore.case = TRUE)) { # remove 'then' + .l <- paste(gsub(pattern = "then", replacement = "", x = .l, ignore.case = TRUE), "\n") + } else { # single line if + .l <- paste(.l, "}\n") + } + } + } + if (code == "else") { + .l <- gsub( + pattern = "^&*else", + replacement = "\\} else \\{\n", + x = .l, ignore.case = TRUE + ) + } + if (code == "end if") { + .l <- gsub( + pattern = "^&*end if", + replacement = "}\n", + x = .l, ignore.case = TRUE + ) + } + return(.l) + } # end if_fix function + + # fix if and if-else blocks + for (i in c("if", "else if", "else", "end if")) { + .l <- if_fix(i, .l) + } + + return(.l) + }, # end rust_up function + lower3 = function(chr) { + purrr::map_chr(chr, function(x) { + substr(tolower(x), 1, 3) + }) + }, + write_block = function(lines, key, block, engine) { + if (private$lower3(key) == "fa") { + key <- "f" + } + lines <- append(lines, sprintf("#%s", key)) + if (private$lower3(key) == "pri") { + i <- 1 + for (param in names(block)) { + lines <- append( + lines, + if (is.numeric(block[[i]])) { + sprintf("%s, %f", param, block[[i]]) + } else { + sprintf("%s, %s", param, block[[i]]$print_to("ab", engine)) + } + ) + i <- i + 1 + } + } else if (private$lower3(key) == "cov") { + for (i in 1:length(block)) { + lines <- append( + lines, + if (block[[i]]$constant) { + sprintf("%s!", block[[i]]$covariate) + } else { + sprintf("%s", block[[i]]$covariate) + } + ) + } + } else if (private$lower3(key) %in% c("bol", "ext")) { + stopifnot(is.null(names(block))) + for (i in 1:length(block)) { + lines <- append(lines, sprintf("%s", block[[i]])) + } + } else if (private$lower3(key) == "sec") { + names <- names(block) + for (i in 1:length(block)) { + key <- toupper(names[i]) + lines <- append( + lines, + if (is.null(names[i]) || nchar(names[i]) == 0) { + sprintf("%s", block[[i]]) + } else { + sprintf("%s = %s", key, block[[i]][1]) + } + ) + } + } else if (private$lower3(key) == "lag") { + names <- names(block) + for (i in 1:length(block)) { + key <- toupper(names[i]) + lines <- append( + lines, + if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list + if (stringr::str_starts(block[[i]], "&")) { # add on statement + block[[i]] + } else { + # grab right side of equation if there + rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] + if (!is.na(rhs)) { + rhs <- stringr::str_replace_all(rhs, " ", "") + } else { # no "=" detected + stop(sprintf("Error: No equation detected for lag expression: %s", block[[i]][1])) + } + lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] + eqn <- stringr::str_extract(lhs, "\\d+") + if (is.na(eqn)) { # no number in lhs + stop(sprintf("Error: No equation number detected for lag expression: %s", block[[i]][1])) + } + sprintf("TLAG[%s] = %s", eqn, rhs) + } + } else { # named list + eqn <- stringr::str_extract(names[i], "\\d+") # standardize + sprintf("TLAG[%s] = %s", eqn, block[[i]][1]) + } + ) + } + } else if (private$lower3(key) == "ini") { + names <- names(block) + for (i in 1:length(block)) { + key <- toupper(names[i]) + lines <- append( + lines, + if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list + if (stringr::str_starts(block[[i]], "&")) { # add on statement + block[[i]] + } else { # grab right side of equation if there + rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] + if (!is.na(rhs)) { + rhs <- stringr::str_replace_all(rhs, " ", "") + } else { # no "=" detected + stop(sprintf("Error: No equation detected for initial conditions: %s", block[[i]][1])) + } + lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] + eqn <- stringr::str_extract(lhs, "\\d+") + if (is.na(eqn)) { # no number in lhs + stop(sprintf("Error: No equation number detected for initial conditions: %s", block[[i]][1])) + } + sprintf("X[%s] = %s", eqn, rhs) + } + } else { # named list + eqn <- stringr::str_extract(names[i], "\\d+") # standardize + sprintf("X[%s] = %s", eqn, block[[i]][1]) + } + ) + } + } else if (private$lower3(key) == "f") { + names <- names(block) + for (i in 1:length(block)) { + key <- toupper(names[i]) + lines <- append( + lines, + if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list + if (stringr::str_starts(block[[i]], "&")) { # add on statement + block[[i]] + } else { # grab right side of equation if there + rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] + if (!is.na(rhs)) { + rhs <- stringr::str_replace_all(rhs, " ", "") + } else { # no "=" detected + stop(sprintf("Error: No equation detected for bioavailability: %s", block[[i]][1])) + } + lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] + eqn <- stringr::str_extract(lhs, "\\d+") + if (is.na(eqn)) { # no number in lhs + stop(sprintf("Error: No equation number detected for bioavailabilty: %s", block[[i]][1])) + } + sprintf("FA[%s] = %s", eqn, rhs) + } + } else { # named list + eqn <- stringr::str_extract(names[i], "\\d+") # standardize + sprintf("FA[%s] = %s", eqn, block[[i]][1]) + } + ) + } + } else if (private$lower3(key) == "dif" | private$lower3(key) == "eqn") { + # names <- names(block) + for (i in 1:length(block)) { + # key <- toupper(names[i]) + lines <- append( + lines, + block[[i]] + # if (is.null(names[i]) || nchar(names[i]) == 0) { # not named list + # # grab right side of equation if there + # rhs <- stringr::str_split(block[[i]][1], "=")[[1]][2] + # if (!is.na(rhs)) { + # rhs <- stringr::str_replace_all(rhs, " ", "") + # } else { # no "=" detected + # stop(sprintf("Error: No differential equation(s) detected for: %s", block[[i]][1])) + # } + # lhs <- stringr::str_split(block[[i]][1], "=")[[1]][1] + # eqn <- stringr::str_extract(lhs, "\\d+") + # if (is.na(eqn)) { # no number in lhs + # stop(sprintf("Error: No differential equation number detected for: %s", block[[i]][1])) + # } + # sprintf("XP(%s) = %s", eqn, rhs) + # } else { # named list + # eqn <- stringr::str_extract(names[i], "\\d+") # standardize + # sprintf("XP(%s) = %s", eqn, block[[i]][1]) + # } + ) + } + } else if (private$lower3(key) == "out") { + i <- 1 # keep track of the first outeq + err_lines <- "#err" + for (param in names(block)) { + stopifnot(nchar(param) == 2 || nchar(param) == 0) + key <- toupper(names(block)[i]) + lines <- append( + lines, + if (nchar(param) == 2) { + sprintf("%s[%s]=%s", substr(key, 1, 1), substr(key, 2, 2), block[[i]][1]) + } else { + sprintf("%s", block[[i]][1]) + } + ) + err_block <- block[[i]]$err + if (i == 1) { + err_lines <- append(err_lines, err_block$model$print_to("ab", engine)) + } + err_lines <- append(err_lines, err_block$assay$print_to("ab", engine)) + + i <- i + 1 + } + lines <- append(lines, "") + lines <- append(lines, err_lines) + } else { + stop(sprintf("Error: Unsupported block named: %s", key)) + } + lines <- append(lines, "") + return(lines) + } + ) ) @@ -903,183 +909,183 @@ PM_model_list <- R6::R6Class("PM_model_list", # Read model.txt file ----------------------------------------------------- PM_model_file <- R6::R6Class("PM_model_file", - inherit = PM_model_list, - public = list( - content = NULL, - initialize = function(model_filename) { - self$name <- basename(model_filename)[1] - self$model_list <- private$makeR6model(model_filename) - self$content <- readChar(model_filename, file.info(model_filename)$size) - } - ), - private = list( - makeR6model = function(file) { - msg <- "" - - blocks <- parseBlocks(file) # this function is in PMutilities - - # check for reserved variable names - reserved <- c( - "ndim", "t", "x", "xp", "rpar", "ipar", "p", "r", "b", "npl", "numeqt", "ndrug", "nadd", "rateiv", "cv", - "n", "nd", "ni", "nup", "nuic", "np", "nbcomp", "psym", "fa", "lag", "tin", "tout" - ) - conflict <- c(match(tolower(blocks$primVar), reserved, nomatch = -99), match(tolower(blocks$secVar), reserved, nomatch = -99), match(tolower(blocks$covar), reserved, nomatch = -99)) - nconflict <- sum(conflict != -99) - if (nconflict > 0) { - msg <- paste("\n", paste(paste("'", reserved[conflict[conflict != -99]], "'", sep = ""), collapse = ", "), " ", c("is a", "are")[1 + as.numeric(nconflict > 1)], " reserved ", c("name", "names")[1 + as.numeric(nconflict > 1)], ", regardless of case.\nPlease choose non-reserved parameter/covariate names.\n", sep = "") - return(list(status = -1, msg = msg)) - } - - if (length(grep(";", blocks$primVar)) > 0) { - # using ';' as separator - sep <- ";" - } else { - if (length(grep(",", blocks$primVar)) > 0) { - # using ',' as separator - sep <- "," - } else { - return(list(status = -1, msg = "\nPrimary variables should be defined as 'var,lower_val,upper_val' or 'var,fixed_val'.\n")) - } - } - - # build model_list to be given to PM_model_list - model_list <- list() - # this function makes pri for PM_model - model_list$pri <- sapply(strsplit(blocks$primVar, sep), function(x) { - # find out if constrained to be positive - const_pos <- any(grepl("\\+", x)) - if (const_pos) { - x <- gsub("\\+", "", x) - gtz <- TRUE - msg <- c(msg, "Truncating variables to positive ranges is not recommended.\n + inherit = PM_model_list, + public = list( + content = NULL, + initialize = function(model_filename) { + self$name <- basename(model_filename)[1] + self$model_list <- private$makeR6model(model_filename) + self$content <- readChar(model_filename, file.info(model_filename)$size) + } + ), + private = list( + makeR6model = function(file) { + msg <- "" + + blocks <- parseBlocks(file) # this function is in PMutilities + + # check for reserved variable names + reserved <- c( + "ndim", "t", "x", "xp", "rpar", "ipar", "p", "r", "b", "npl", "numeqt", "ndrug", "nadd", "rateiv", "cv", + "n", "nd", "ni", "nup", "nuic", "np", "nbcomp", "psym", "fa", "lag", "tin", "tout" + ) + conflict <- c(match(tolower(blocks$primVar), reserved, nomatch = -99), match(tolower(blocks$secVar), reserved, nomatch = -99), match(tolower(blocks$covar), reserved, nomatch = -99)) + nconflict <- sum(conflict != -99) + if (nconflict > 0) { + msg <- paste("\n", paste(paste("'", reserved[conflict[conflict != -99]], "'", sep = ""), collapse = ", "), " ", c("is a", "are")[1 + as.numeric(nconflict > 1)], " reserved ", c("name", "names")[1 + as.numeric(nconflict > 1)], ", regardless of case.\nPlease choose non-reserved parameter/covariate names.\n", sep = "") + return(list(status = -1, msg = msg)) + } + + if (length(grep(";", blocks$primVar)) > 0) { + # using ';' as separator + sep <- ";" + } else { + if (length(grep(",", blocks$primVar)) > 0) { + # using ',' as separator + sep <- "," + } else { + return(list(status = -1, msg = "\nPrimary variables should be defined as 'var,lower_val,upper_val' or 'var,fixed_val'.\n")) + } + } + + # build model_list to be given to PM_model_list + model_list <- list() + # this function makes pri for PM_model + model_list$pri <- sapply(strsplit(blocks$primVar, sep), function(x) { + # find out if constrained to be positive + const_pos <- any(grepl("\\+", x)) + if (const_pos) { + x <- gsub("\\+", "", x) + gtz <- TRUE + msg <- c(msg, "Truncating variables to positive ranges is not recommended.\n Consider log transformation instead.\n") - } else { - gtz <- FALSE - } - - # find out if constant - const_var <- any(grepl("!", x)) - if (const_var) { - x <- gsub("!", "", x) - } - - values <- as.numeric(x[-1]) - - if (length(x[-1]) == 1) { # fixed - thisItem <- list(fixed(values[1], constant = const_var, gtz = gtz)) - } else { # range - thisItem <- list(ab(values[1], values[2], gtz = gtz)) - } - names(thisItem) <- x[1] - thisItem - }) # end sapply - - # covariates - # process constant covariates - covar <- blocks$covar - const_covar <- grepl("!", covar) # returns boolean vector, length = nout - covar <- gsub("!", "", covar) # remove "!" - # cycle through covariates - if (covar[1] != "") { - covar_list <- list() - for (i in 1:length(covar)) { - covar_list[[i]] <- covariate(name = covar[i], constant = const_covar[i]) - } - } else { - covar_list <- NULL - } - # add to model_list - model_list$cov <- covar_list - - # extra - if (blocks$extra[1] != "") { - model_list$ext <- blocks$extra - } - - # secondary variables - if (blocks$secVar[1] != "") { - model_list$sec <- as.list(blocks$secVar) - } - - # bioavailability - if (blocks$f[1] != "") { - model_list$fa <- as.list(blocks$f) - } - - # bolus - if (blocks$bol[1] != "") { - model_list$bol <- as.list(blocks$bol) - } - - # initial conditions - if (blocks$ini[1] != "") { - model_list$ini <- as.list(blocks$ini) - } - - # lag time - if (blocks$lag[1] != "") { - model_list$lag <- as.list(blocks$lag) - } - - # differential equations - legacy - if (!is.null(blocks$diffeq) && blocks$diffeq[1] != "") { - model_list$eqn <- as.list(blocks$diffeq) - } - - # model equations - will eventually replace diffeq above - if (blocks$eqn[1] != "") { - model_list$eqn <- as.list(blocks$eqn) - } - - # out/err - n_outputLines <- length(blocks$output) - outputLines <- grep("Y\\([[:digit:]]+\\)|Y\\[[[:digit:]]+\\]", blocks$output) - if (length(outputLines) == 0) { - return(list(status = -1, msg = "\nYou must have at least one output equation of the form 'Y[1] = ...'\n")) - } - otherLines <- (1:n_outputLines)[!(1:n_outputLines) %in% outputLines] # find other lines - if (length(otherLines) > 0) { - model_list$sec <- c(model_list$sec, blocks$output[otherLines]) # append to #sec block - } - output <- blocks$output[outputLines] - remParen <- stringr::str_replace(output, regex("Y(?:\\[|\\()(\\d+)(?:\\]|\\))", ignore_case = TRUE), "Y\\1") - diffeq <- stringr::str_split(remParen, "\\s*=\\s*") - diffList <- sapply(diffeq, function(x) x[2]) - num_out <- length(diffList) - - err <- tolower(gsub("[[:space:]]", "", blocks$error)) - # process constant gamma/lambda - gamma <- grepl("^g", err[1]) - const_gamlam <- grepl("!", err[1]) - gamlam_value <- as.numeric(stringr::str_match(err[1], "\\d+\\.?\\d*")) - # process constant coefficients - const_coeff <- grepl("!", err[-1]) # returns boolean vector, length = nout - err <- gsub("!", "", err) # remove "!" - - - out <- list() - for (i in 1:num_out) { - out[[i]] <- list( - val = diffList[i], - err = list( - model = if ((1 + as.numeric(gamma)) == 1) { - additive(gamlam_value, constant = const_gamlam) - } else { - proportional(gamlam_value, constant = const_gamlam) - }, - assay = errorPoly(stringr::str_split(err[i + 1], ",")[[1]] %>% as.numeric(), const_coeff[i]) - ) - ) - } - names(out) <- sapply(diffeq, function(x) x[1]) - model_list$out <- out - - cat(msg) - flush.console() - - return(model_list) - } - ) # end private list + } else { + gtz <- FALSE + } + + # find out if constant + const_var <- any(grepl("!", x)) + if (const_var) { + x <- gsub("!", "", x) + } + + values <- as.numeric(x[-1]) + + if (length(x[-1]) == 1) { # fixed + thisItem <- list(fixed(values[1], constant = const_var, gtz = gtz)) + } else { # range + thisItem <- list(ab(values[1], values[2], gtz = gtz)) + } + names(thisItem) <- x[1] + thisItem + }) # end sapply + + # covariates + # process constant covariates + covar <- blocks$covar + const_covar <- grepl("!", covar) # returns boolean vector, length = nout + covar <- gsub("!", "", covar) # remove "!" + # cycle through covariates + if (covar[1] != "") { + covar_list <- list() + for (i in 1:length(covar)) { + covar_list[[i]] <- covariate(name = covar[i], constant = const_covar[i]) + } + } else { + covar_list <- NULL + } + # add to model_list + model_list$cov <- covar_list + + # extra + if (blocks$extra[1] != "") { + model_list$ext <- blocks$extra + } + + # secondary variables + if (blocks$secVar[1] != "") { + model_list$sec <- as.list(blocks$secVar) + } + + # bioavailability + if (blocks$f[1] != "") { + model_list$fa <- as.list(blocks$f) + } + + # bolus + if (blocks$bol[1] != "") { + model_list$bol <- as.list(blocks$bol) + } + + # initial conditions + if (blocks$ini[1] != "") { + model_list$ini <- as.list(blocks$ini) + } + + # lag time + if (blocks$lag[1] != "") { + model_list$lag <- as.list(blocks$lag) + } + + # differential equations - legacy + if (!is.null(blocks$diffeq) && blocks$diffeq[1] != "") { + model_list$eqn <- as.list(blocks$diffeq) + } + + # model equations - will eventually replace diffeq above + if (blocks$eqn[1] != "") { + model_list$eqn <- as.list(blocks$eqn) + } + + # out/err + n_outputLines <- length(blocks$output) + outputLines <- grep("Y\\([[:digit:]]+\\)|Y\\[[[:digit:]]+\\]", blocks$output) + if (length(outputLines) == 0) { + return(list(status = -1, msg = "\nYou must have at least one output equation of the form 'Y[1] = ...'\n")) + } + otherLines <- (1:n_outputLines)[!(1:n_outputLines) %in% outputLines] # find other lines + if (length(otherLines) > 0) { + model_list$sec <- c(model_list$sec, blocks$output[otherLines]) # append to #sec block + } + output <- blocks$output[outputLines] + remParen <- stringr::str_replace(output, regex("Y(?:\\[|\\()(\\d+)(?:\\]|\\))", ignore_case = TRUE), "Y\\1") + diffeq <- stringr::str_split(remParen, "\\s*=\\s*") + diffList <- sapply(diffeq, function(x) x[2]) + num_out <- length(diffList) + + err <- tolower(gsub("[[:space:]]", "", blocks$error)) + # process constant gamma/lambda + gamma <- grepl("^g", err[1]) + const_gamlam <- grepl("!", err[1]) + gamlam_value <- as.numeric(stringr::str_match(err[1], "\\d+\\.?\\d*")) + # process constant coefficients + const_coeff <- grepl("!", err[-1]) # returns boolean vector, length = nout + err <- gsub("!", "", err) # remove "!" + + + out <- list() + for (i in 1:num_out) { + out[[i]] <- list( + val = diffList[i], + err = list( + model = if ((1 + as.numeric(gamma)) == 1) { + additive(gamlam_value, constant = const_gamlam) + } else { + proportional(gamlam_value, constant = const_gamlam) + }, + assay = errorPoly(stringr::str_split(err[i + 1], ",")[[1]] %>% as.numeric(), const_coeff[i]) + ) + ) + } + names(out) <- sapply(diffeq, function(x) x[1]) + model_list$out <- out + + cat(msg) + flush.console() + + return(model_list) + } + ) # end private list ) @@ -1087,35 +1093,35 @@ PM_model_file <- R6::R6Class("PM_model_file", PM_model_julia <- R6::R6Class("PM_model_julia", - inherit = PM_Vmodel, - public = list( - model_function = NULL, - # prior: created based on user input that needs to include possible values - # for means, SDs, mins, maxes, and initial support points (which could be a function) - min = NULL, # this will be folded into prior bin - max = NULL, # this will be folded into prior bin - n_points0 = NULL, # this will be folded into prior bin - initialize = function(model, ...) { - dots <- list(...) - if (!exists("max", where = dots) || !exists("min", where = sdots)) { - stop("Error: Running using the Julia solver requires sufficient information to create a prior, e.g. min, max or mean/SD.") - } - self$min <- dots$min - self$max <- dots$max - self$error <- if (is.null(dots$error)) c(0.1, 0.01, 0) else dots$error # will need dynamic function to detect poisson, etc. - self$n_points0 <- if (is.null(dots$n_points0)) 100 else dots$n_points0 - if (is.function(model)) { - private$julia_type <- "function" - self$name <- "Dyn function(...){...}" - self$model_function <- model - } else { - private$julia_type <- "Str function" - self$name <- "Str function(...){...}" - } - }, - print = function() {} - ), - private = list( - julia_type = NULL - ) -) \ No newline at end of file + inherit = PM_Vmodel, + public = list( + model_function = NULL, + # prior: created based on user input that needs to include possible values + # for means, SDs, mins, maxes, and initial support points (which could be a function) + min = NULL, # this will be folded into prior bin + max = NULL, # this will be folded into prior bin + n_points0 = NULL, # this will be folded into prior bin + initialize = function(model, ...) { + dots <- list(...) + if (!exists("max", where = dots) || !exists("min", where = sdots)) { + stop("Error: Running using the Julia solver requires sufficient information to create a prior, e.g. min, max or mean/SD.") + } + self$min <- dots$min + self$max <- dots$max + self$error <- if (is.null(dots$error)) c(0.1, 0.01, 0) else dots$error # will need dynamic function to detect poisson, etc. + self$n_points0 <- if (is.null(dots$n_points0)) 100 else dots$n_points0 + if (is.function(model)) { + private$julia_type <- "function" + self$name <- "Dyn function(...){...}" + self$model_function <- model + } else { + private$julia_type <- "Str function" + self$name <- "Str function(...){...}" + } + }, + print = function() {} + ), + private = list( + julia_type = NULL + ) +)