diff --git a/NEWS.md b/NEWS.md index 0fedaabb5..9debd4f96 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # rxode2 (development version) +- Bug fix for `.copyUi()` with the new format (5.0+) of rxode2 ui models + - With new versions of R, `getOption()` is no longer a bottleneck, so syncing to local variables is no longer done internally diff --git a/R/piping.R b/R/piping.R index 1544f48a4..a303139e9 100644 --- a/R/piping.R +++ b/R/piping.R @@ -1,3 +1,33 @@ +#' Copy an environment and all of its contents +#' +#' This is a recursive copy that creates a new environment for every +#' environment in the original environment. This is used to copy the +#' rxUi object so that it can be modified without modifying the +#' original. +#' +#' @param env Environment to copy +#' +#' @return Copied environment +#' @author Matthew L. Fidler +#' @noRd +.copyEnv <- function(env, visited=new.env(hash=TRUE, parent=emptyenv())) { + .addr <- environmentName(env) + if (identical(.addr, "") || is.na(.addr)) .addr <- format(env) + if (exists(.addr, envir=visited, inherits=FALSE)) { + return(get(.addr, envir=visited, inherits=FALSE)) + } + .ret <- new.env(parent=emptyenv()) + assign(.addr, .ret, envir=visited) + lapply(ls(envir=env, all.names=TRUE), function(item){ + if (is.environment(get(item, envir=env))) { + assign(item, .copyEnv(get(item, envir=env), visited), envir=.ret) + } else { + assign(item, get(item, envir=env), envir=.ret) + } + }) + .ret +} + #' This copies the rxode2 UI object so it can be modified #' #' @param ui Original UI object @@ -10,8 +40,13 @@ return(rxUiDecompress(ui)) } .ret <- new.env(parent=emptyenv()) + .visited <- new.env(hash=TRUE, parent=emptyenv()) lapply(ls(envir=ui, all.names=TRUE), function(item){ - assign(item, get(item, envir=ui), envir=.ret) + if (is.environment(get(item, envir=ui))) { + assign(item, .copyEnv(get(item, envir=ui), .visited), envir=.ret) + } else { + assign(item, get(item, envir=ui), envir=.ret) + } }) class(.ret) <- class(ui) .ret diff --git a/R/ui-assign-parts.R b/R/ui-assign-parts.R index 798b6cfb9..4cb431231 100644 --- a/R/ui-assign-parts.R +++ b/R/ui-assign-parts.R @@ -121,7 +121,9 @@ newModel <- rxUiDecompress(newModel) oldModel <- rxUiDecompress(oldModel) lapply(c("meta", "sticky", "model", "modelName"), function(x) { - if (exists(x, envir=oldModel)) assign(x, get(x, envir=oldModel), envir=newModel) + if (exists(x, envir=oldModel)) { + assign(x, get(x, envir=oldModel), envir=newModel) + } }) if (rename || .modelsNearlySame(newModel, oldModel)) { lapply(.getAllSigEnv(oldModel), @@ -136,9 +138,11 @@ assign(v, get(v, envir=oldModel), envir=newModel) }) lapply(.drop, function(v) { - if (exists(v, envir=newModel)) rm(list=v, envir=newModel) + if (exists(v, envir=newModel)) { + rm(list=v, envir=newModel) + } }) - if ( length(.drop) > 0 ) { + if (length(.drop) > 0) { cli::cli_alert("significant model change detected") if (length(.keep) > 0) { cli::cli_alert(sprintf("kept in model: '%s'", diff --git a/R/ui-rename.R b/R/ui-rename.R index a84828549..e4849d855 100644 --- a/R/ui-rename.R +++ b/R/ui-rename.R @@ -31,7 +31,9 @@ .var.name2 <- as.character(line[[3]]) } if (.var.name %in% vars) { - stop("the new variable '", .var.name, "' is already present in the model; cannot replace '", .var.name2, "' with '", + stop("the new variable '", .var.name, + "' is already present in the model; cannot replace '", + .var.name2, "' with '", .var.name, "'", call.=FALSE) } @@ -263,7 +265,6 @@ rxRename <- function(.data, ..., envir=parent.frame()) { .rxRenameAll(rxui, .lst) .ret <- rxui$fun() if (inherits(.data, "rxUi")) { - ## .x <- rxUiDecompress(.data) .ret <- .newModelAdjust(.ret, rxui, rename=TRUE) if (.inCompress) { .ret <- rxUiCompress(.ret) diff --git a/man/reexports.Rd b/man/reexports.Rd index 13ad4d055..8c3f4b22c 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -3,8 +3,6 @@ \docType{import} \name{reexports} \alias{reexports} -\alias{\%fin\%} -\alias{\%!fin\%} \alias{scale_type} \alias{ggplot} \alias{aes} @@ -32,11 +30,8 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{fastmatch}{\code{\link[fastmatch:fmatch]{\%!fin\%}}, \code{\link[fastmatch:fmatch]{\%fin\%}}} - \item{ggplot2}{\code{\link[ggplot2]{aes}}, \code{\link[ggplot2]{expand_limits}}, \code{\link[ggplot2]{facet_wrap}}, \code{\link[ggplot2:geom_path]{geom_line}}, \code{\link[ggplot2]{ggplot}}, \code{\link[ggplot2:labellers]{label_both}}, \code{\link[ggplot2:labellers]{label_context}}, \code{\link[ggplot2:labellers]{label_context}}, \code{\link[ggplot2:labellers]{label_value}}, \code{\link[ggplot2:labellers]{label_wrap_gen}}, \code{\link[ggplot2]{scale_type}}, \code{\link[ggplot2:scale_continuous]{scale_x_continuous}}, \code{\link[ggplot2:scale_date]{scale_x_date}}, \code{\link[ggplot2:scale_discrete]{scale_x_discrete}}, \code{\link[ggplot2:scale_continuous]{scale_y_continuous}}, \code{\link[ggplot2:scale_date]{scale_y_date}}, \code{\link[ggplot2:scale_discrete]{scale_y_discrete}}, \code{\link[ggplot2]{waiver}}, \code{\link[ggplot2:labs]{xlab}}, \code{\link[ggplot2:labs]{ylab}}} \item{lotri}{\code{\link[lotri]{lotri}}} }} -\value{ Inherited from parent routine } diff --git a/tests/testthat/test-ui-rename.R b/tests/testthat/test-ui-rename.R index d405f161a..c3c17fbba 100644 --- a/tests/testthat/test-ui-rename.R +++ b/tests/testthat/test-ui-rename.R @@ -256,5 +256,123 @@ rxTest({ }) + test_that("rename doesn't change parent ui", { + + f <- function() { + description <- "BOLUS_2CPT_CLV1QV2 SINGLE DOSE FOCEI (120 Ind/2280 Obs) runODE032" + dfObs <- 2280 + dfSub <- 120 + sigma <- lotri({ + eps1 ~ 1 + }) + thetaMat <- lotri({ + theta1 ~ c(theta1 = 0.000887681) + theta2 ~ c(theta1 = -0.00010551, theta2 = 0.000871409) + theta3 ~ c(theta1 = 0.000184416, theta2 = -0.000106195, + theta3 = 0.00299336) + theta4 ~ c(theta1 = -0.000120234, theta2 = -5.06663e-05, + theta3 = 0.000165252, theta4 = 0.00121347) + RSV ~ c(theta1 = 5.2783e-08, theta2 = -1.56562e-05, theta3 = 5.99331e-06, + theta4 = -2.53991e-05, RSV = 9.94218e-06) + eps1 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0) + eta1 ~ c(theta1 = -4.71273e-05, theta2 = 4.69667e-05, + theta3 = -3.64271e-05, theta4 = 2.54796e-05, RSV = -8.16885e-06, + eps1 = 0, eta1 = 0.000169296) + omega.2.1 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0, eta1 = 0, omega.2.1 = 0) + eta2 ~ c(theta1 = -7.37156e-05, theta2 = 2.56634e-05, + theta3 = -8.08349e-05, theta4 = 1.37e-05, RSV = -4.36564e-06, + eps1 = 0, eta1 = 8.75181e-06, omega.2.1 = 0, eta2 = 0.00015125) + omega.3.1 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0, eta1 = 0, omega.2.1 = 0, eta2 = 0, + omega.3.1 = 0) + omega.3.2 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0, eta1 = 0, omega.2.1 = 0, eta2 = 0, + omega.3.1 = 0, omega.3.2 = 0) + eta3 ~ c(theta1 = 6.63383e-05, theta2 = -8.19002e-05, + theta3 = 0.000548985, theta4 = 0.000168356, RSV = 1.59122e-06, + eps1 = 0, eta1 = 3.48714e-05, omega.2.1 = 0, eta2 = 4.31593e-07, + omega.3.1 = 0, omega.3.2 = 0, eta3 = 0.000959029) + omega.4.1 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0, eta1 = 0, omega.2.1 = 0, eta2 = 0, + omega.3.1 = 0, omega.3.2 = 0, eta3 = 0, omega.4.1 = 0) + omega.4.2 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0, eta1 = 0, omega.2.1 = 0, eta2 = 0, + omega.3.1 = 0, omega.3.2 = 0, eta3 = 0, omega.4.1 = 0, + omega.4.2 = 0) + omega.4.3 ~ c(theta1 = 0, theta2 = 0, theta3 = 0, theta4 = 0, + RSV = 0, eps1 = 0, eta1 = 0, omega.2.1 = 0, eta2 = 0, + omega.3.1 = 0, omega.3.2 = 0, eta3 = 0, omega.4.1 = 0, + omega.4.2 = 0, omega.4.3 = 0) + eta4 ~ c(theta1 = -9.49661e-06, theta2 = 0.000110108, + theta3 = -0.000306537, theta4 = -9.12897e-05, RSV = 3.1877e-06, + eps1 = 0, eta1 = 1.36628e-05, omega.2.1 = 0, eta2 = -1.95096e-05, + omega.3.1 = 0, omega.3.2 = 0, eta3 = -0.00012977, + omega.4.1 = 0, omega.4.2 = 0, omega.4.3 = 0, eta4 = 0.00051019) + }) + validation <- c("IPRED relative difference compared to Nonmem IPRED: 0%; 95% percentile: (0%,0%); rtol=6.43e-06", + "IPRED absolute difference compared to Nonmem IPRED: 95% percentile: (2.19e-05, 0.0418); atol=0.00167", + "IWRES relative difference compared to Nonmem IWRES: 0%; 95% percentile: (0%,0.01%); rtol=8.99e-06", + "IWRES absolute difference compared to Nonmem IWRES: 95% percentile: (1.82e-07, 4.63e-05); atol=3.65e-06", + "PRED relative difference compared to Nonmem PRED: 0%; 95% percentile: (0%,0%); rtol=6.41e-06", + "PRED absolute difference compared to Nonmem PRED: 95% percentile: (1.41e-07,0.00382) atol=6.41e-06") + ini({ + theta1 <- 1.37034036528946 + label("log Cl") + theta2 <- 4.19814911033061 + label("log Vc") + theta3 <- 1.38003493562413 + label("log Q") + theta4 <- 3.87657341967489 + label("log Vp") + RSV <- c(0, 0.196446108190896, 1) + label("RSV") + eta1 ~ 0.101251418415006 + eta2 ~ 0.0993872449483344 + eta3 ~ 0.101302674763154 + eta4 ~ 0.0730497519364148 + }) + model({ + cmt(CENTRAL) + cmt(PERI) + cl <- exp(theta1 + eta1) + v <- exp(theta2 + eta2) + q <- exp(theta3 + eta3) + v2 <- exp(theta4 + eta4) + v1 <- v + scale1 <- v + k21 <- q/v2 + k12 <- q/v + d/dt(CENTRAL) <- k21 * PERI - k12 * CENTRAL - cl * CENTRAL/v1 + d/dt(PERI) <- -k21 * PERI + k12 * CENTRAL + f <- CENTRAL/scale1 + ipred <- f + rescv <- RSV + w <- ipred * rescv + ires <- DV - ipred + iwres <- ires/w + y <- ipred + w * eps1 + }) + } + + f <- f() + + f2 <- f %>% rxRename(err1=eps1) + expect_equal(dimnames(f2$sigma)[[1]], "err1") + expect_equal(dimnames(f$sigma)[[1]], "eps1") + expect_true(any(dimnames(f2$thetaMat)[[1]] == "err1")) + expect_false(any(dimnames(f2$thetaMat)[[1]] == "eps1")) + expect_false(any(dimnames(f$thetaMat)[[1]] == "err1")) + expect_true(any(dimnames(f$thetaMat)[[1]] == "eps1")) + + f3 <- f %>% rxRename(Vp=theta4) + expect_true(any(dimnames(f3$thetaMat)[[1]] == "Vp")) + expect_false(any(dimnames(f3$thetaMat)[[1]] == "theta4")) + expect_false(any(dimnames(f$thetaMat)[[1]] == "Vp")) + expect_true(any(dimnames(f$thetaMat)[[1]] == "theta4")) + + }) + })