Bug fixes for getting and copyUi

nlmixr2 · Jul 30, 2024 · e50f87e · e50f87e
1 parent e8b34f9
commit e50f87e
Show file tree

Hide file tree

Showing 4 changed files with 32 additions and 12 deletions.
diff --git a/R/piping-ini.R b/R/piping-ini.R
@@ -767,7 +767,9 @@ ini.rxUi <- function(x, ..., envir=parent.frame(), append = NULL) {
   .ret <- rxUiDecompress(.copyUi(x)) # copy so (as expected) old UI isn't affected by the call
   .iniDf <- .ret$iniDf
   .iniLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir, iniDf= .iniDf)
-  if (length(.iniLines) == 0L) return(.ret$iniFun)
+  if (length(.iniLines) == 0L) {
+    return(.ret$iniFun)
+  }
   lapply(.iniLines, function(line) {
     .iniHandleLine(expr = line, rxui = .ret, envir = envir, append=append)
   })

diff --git a/R/piping.R b/R/piping.R
@@ -8,10 +8,20 @@
   if (inherits(ui, "raw")) {
     return(rxUiDecompress(ui))
   }
-  .ret <- new.env(parent=emptyenv())
-  lapply(ls(envir=ui, all.names=TRUE), function(item){
-    assign(item, get(item, envir=ui), envir=.ret)
-  })
+  if (is.environment(ui)) {
+    .ret <- new.env(parent=emptyenv())
+    lapply(ls(envir=ui, all.names=TRUE), function(item){
+      assign(item, get(item, envir=ui), envir=.ret)
+    })
+  } else if (is.list(ui)) {
+    .n <- names(ui)
+    .ret <- lapply(.n, function(item){
+      ui[[item]]
+    })
+    names(.ret) <- .n
+  } else {
+    stop("ui must be a list or environment")
+  }
   class(.ret) <- class(ui)
   .ret
 }

diff --git a/R/rxUiGet.R b/R/rxUiGet.R
@@ -32,15 +32,17 @@ rxUiExists <- function(x, envir) {
 #' @export
 #' @keywords internal
 #' @author Matthew L. Fidler
-getRxUiRo <- function(x, ui) {
-  if (is.environment(ui)) {
-    get(x, envir=ui)
-  } else if (is.list(ui)) {
-    .ui <- ui
+getRxUiRo <- function(x, envir) {
+  if (is.environment(envir)) {
+    if (exists(x, envir=envir)) {
+      get(x, envir=envir)
+    } else {
+      NULL
+    }
+  } else if (is.list(envir)) {
+    .ui <- envir
     class(.ui) <- NULL
     .ui[[x]]
-  } else {
-    stop("ui must be an environment or list for getRxUiRo()")
   }
 }
 
@@ -489,6 +491,9 @@ rxUiGet.default <- function(x, ...) {
   .ui <- x[[1]]
   if (!rxUiExists(.arg, envir=.ui)) {
     .meta <- getRxUiRo("meta", envir=.ui)
+    if (is.null(.meta)) {
+      return(NULL)
+    }
     if (is.environment(.meta)) {
       if (exists(.arg, envir=.meta)) {
         return(getRxUiRo(.arg, envir=.meta))

diff --git a/R/ui.R b/R/ui.R
@@ -508,6 +508,9 @@ rxUiCompress <- function(ui, type=c("list","qs")) {
   }
   if (is.environment(ui) && type=="list") {
     .m <- get("meta", envir=ui)
+    if (is.null(.m)) {
+      .m <- new.env(parent=emptyenv())
+    }
     .n <- ls(get("meta", envir=ui), all=TRUE)
     .meta <- lapply(.n, function(x) {
       get(x, .m)