Update more piping for collapsing to plus form

R/piping.R

@@ -235,8 +235,69 @@
   .expandedForm
 }
 
-.nsEnv <- new.env(parent=emptyenv())
+#' This function collapses the lotri line form to the plus form
+#'
+#' @param expressionList Expression list that is input to change into
+#'   matrix expression form the new line expressions to the classic
+#'   plus expressions.
+#' @return expression list where lotri line for covariance matrices
+#'   are translated to classic plus form.
+#' @author Matthew L. Fidler
+#' @noRd
+#' @examples
+#'
+#' tmp <- list(str2lang("d ~ 1"),
+#'             str2lang("e ~ c(0.5, 3)"))
+#'
+#' .collapseLotriLineFormToPlusForm(tmp)
+.collapseLotriLineFormToPlusForm <- function(expressionList) {
+  .env <- new.env(parent=emptyenv())
+  .env$ret <- expressionList
+  .env$lst <- list()
+  .env$last <- NA_integer_
+
+  .f <- function() {
+    if (!is.na(.env$last)) {
+      .val <- as.call(c(list(quote(`{`)), .env$lst))
+      .val <- as.call(c(str2lang("lotri::lotri"), .val))
+      .val <- eval(.val)
+      .val <- lotri::lotriAsExpression(.val, plusNames=TRUE)
+      .val <- lapply(seq_along(.val)[-1],
+                     function(i){
+                       .val[[i]]
+                     })[[1]]
+      .val <- lapply(seq_along(.val)[-1],
+                     function(i){
+                       .val[[i]]
+                     })
+      for (.j in seq_along(.val)) {
+        .env$ret[[.env$last + .j - 1L]] <- .val[[.j]]
+      }
+      .env$lst <- list()
+      .env$last <- NA_integer_
+    }
+  }
+  for (.i in seq_along(.env$ret)) {
+    .cur <- .env$ret[[.i]]
+    if (is.call(.cur) && identical(.cur[[1]], quote(`~`)) &&
+          length(.cur) == 3L) {
+      if (is.na(.env$last)) {
+        .env$last <- .i
+      }
+      .env$ret[[.i]] <- NA
+      .env$lst <- c(.env$lst, .cur)
+    } else {
+      .f()
+    }
+  }
+  .f()
+  .w <- which(vapply(seq_along(.env$ret), function(i) {
+    !(length(.env$ret[[i]]) == 1L && is.na(.env$ret[[i]]))
+  }, logical(1), USE.NAMES=FALSE))
+  lapply(.w, function(i) { .env$ret[[i]]})
+}
 
+.nsEnv <- new.env(parent=emptyenv())
 
 .nsEnv$.quoteCallInfoLinesAppend <- NULL
 #' Returns quoted call information
@@ -326,8 +387,7 @@
     }
     .ret[[i]]
   })
-
-  .ret[vapply(seq_along(.ret), function(i) {
+  .collapseLotriLineFormToPlusForm(.ret[vapply(seq_along(.ret), function(i) {
     !is.null(.ret[[i]])
-  }, logical(1), USE.NAMES=FALSE)]
+  }, logical(1), USE.NAMES=FALSE)])
 }

tests/testthat/test-piping-ini.R

@@ -276,6 +276,7 @@ if (!.Call(`_rxode2_isIntel`)) {
 
   test_that(".iniAddCovarianceBetweenTwoEtaValues", {
     # Promote a covariate to a correlated eta
+
     mod <- function() {
       ini({
         a <- 1
@@ -292,27 +293,59 @@ if (!.Call(`_rxode2_isIntel`)) {
         b ~ add(addSd)
       })
     }
+
     suppressMessages(
       expect_message(
         ini(mod, d + e ~ c(1, 0.5, 3)),
         regexp = "promote `e` to between subject variability"
       )
     )
 
+    suppressMessages(
+      expect_message(
+        ini(mod, d ~ 1,  e ~ c(0.5, 3)),
+        regexp = "promote `e` to between subject variability"
+      )
+    )
+
+    suppressMessages(
+      expect_message(
+        ini(mod, {
+          d ~ 1
+          e ~ c(0.5, 3)})
+      ))
+
     # Non-existent correlated eta
     suppressMessages(
       expect_error(
         ini(mod, d + g ~ c(1, 0.5, 3)),
         regexp = "cannot find parameter 'g'"
       )
     )
+
+    suppressMessages(
+      expect_error(
+        ini(mod, d ~ 1, g ~ c(0.5, 3)),
+        regexp = "cannot find parameter 'g'"
+      )
+    )
+
+
     # Update eta order
     suppressMessages(
       expect_equal(
         ini(mod, h + d ~ c(1, 0.5, 3))$iniDf$name,
         c("a", "b", "c", "addSd", "h", "d", "(h,d)")
       )
     )
+
+    suppressMessages(
+      expect_equal(
+        ini(mod, h ~ 1,  d ~ c(0.5, 3))$iniDf$name,
+        c("a", "b", "c", "addSd", "h", "d", "(h,d)")
+      )
+    )
+
   })
 
   test_that(".iniHandleLabel", {