Merge pull request #16 from nlmixr2/15-lotriaslotriasdataframelotri

15 lotriaslotriasdataframelotri

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: lotri
 Title: A Simple Way to Specify Symmetric, Block Diagonal Matrices
-Version: 0.4.2
+Version: 0.4.3
 Authors@R: 
     person("Matthew L.", "Fidler", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-8538-6691"))

NEWS.md

@@ -1,3 +1,7 @@
+# lotri 0.4.3
+
+* Bug fix for etas that were not named correctly for large order problems
+
 # lotri 0.4.2
 
 * Bug fix for etas that are inconsistently numbered

R/as.lotri.R

@@ -24,7 +24,7 @@ as.lotri.matrix <- function(x, ..., default = "") {
 
 .as.lotri.data.frame.mat <- function(x) {
   x <- x[order(x$neta1, x$neta2), ]
-  x$neta1 <- factor(paste(x$neta1))
+  x$neta1 <- factor(paste(x$neta1), levels=paste(sort(unique(x$neta1))))
   x$neta2 <- factor(paste(x$neta2), levels=levels(x$neta1))
   x$neta1 <- as.integer(x$neta1)
   x$neta2 <- as.integer(x$neta2)
@@ -39,9 +39,12 @@ as.lotri.matrix <- function(x, ..., default = "") {
     .matF[x$neta1[.i] - .min, x$neta2[.i] - .min] <- x$fix[.i]
     .matF[x$neta2[.i] - .min, x$neta1[.i] - .min] <- x$fix[.i]
   }
-  .n <- which(x$neta1 == x$neta2)
-  dimnames(.mat) <- list(x$name[.n], x$name[.n])
-  dimnames(.matF) <- list(x$name[.n], x$name[.n])
+  .names <- vapply(seq_len(dim(.mat)[1]),
+                   function(.i) {
+                     x$name[x$neta1==.i & x$neta2 == .i]
+                   }, character(1), USE.NAMES = FALSE)
+  dimnames(.mat) <- list(.names, .names)
+  dimnames(.matF) <- list(.names, .names)
   if(any(.matF)) {
     attr(.mat, "lotriFix") <- .matF
     class(.mat) <- c("lotriFix", class(.mat))
@@ -63,7 +66,7 @@ as.lotri.data.frame <- function(x, ..., default="") {
   if (length(.cnd) == 1) {
     .mat <- .as.lotri.data.frame.mat(.lotriMatDf)
   } else {
-    .mat <- setNames(lapply(.cnd, function(.cur){
+    .mat <- setNames(lapply(.cnd, function(.cur) {
       .x <- .lotriMatDf[which(.lotriMatDf$condition == .cur), ]
       .as.lotri.data.frame.mat(.x)
     }), .cnd)
@@ -76,7 +79,7 @@ as.lotri.data.frame <- function(x, ..., default="") {
 ##' @rdname as.lotri
 ##' @export
 as.lotri.default <- function(x, ..., default = "") {
-  if (inherits(x, "list") | inherits(x, "lotri")) {
+  if (inherits(x, "list") || inherits(x, "lotri")) {
     .ret <- x
     class(.ret) <- NULL
     .n <- names(.ret)

tests/testthat/test-as.lotri.R

@@ -69,3 +69,71 @@ test_that("as.lotri", {
   expect_error(as.lotri(df), NA)
 
 })
+
+test_that("no mangling of etas #",{
+
+  m <- lotri({
+    Ktr_pop = 0.1
+    MTT_pop = 0.2
+    KA_pop = 0.3
+    CL_pop = 0.4
+    V1_pop = 0.5
+    beta_WT_V1 = 0.6
+    WT = 70
+    DRUG = 2
+    TLAG_pop = 0
+    Q_pop = 0
+    V2_pop = 1
+    FU_pop = 1
+    PLTZ_pop = 0.7
+    MMT_pop = 0.8
+    SPW_pop = 0.9
+    EMAX_PLT_pop = 1.0
+    EC50_PLT_pop = 0
+    SG_pop = 1.1
+    KOUT_pop = 1.2
+    GDFZ_pop = 1.3
+    KIN_pop = 1.4
+    KPRO_pop = -1
+    KP5_pop = 1
+    KP1_pop = 0
+    TRTPLT = 0
+    TRTGDF = 0
+    SLPD_pop = 0
+    SLPI_pop = 0
+    KE0_pop = 0
+    SEP_pop = 0
+    CFR_pop = 0
+    LPW_pop = 0
+    etaKtr ~ sd(0.1)
+    etaMTT ~ sd(0.2)
+    etaKA ~  sd(0.3)
+    etaV1 + etaCL ~ sd(cor(0.4,
+                           0.5, 0.6))
+    etaPLTZ ~ sd(0.7)
+    etaMMT  ~ sd(0.8)
+    etaSPW  ~ sd(0.9)
+    etaEMAX ~ sd(1.1)
+    etaV2 ~ 1e-8
+    etaQ ~ 1e-8
+    etaKE0 ~ 1e-8
+    etaSLPD ~ 1e-8
+    etaSLPI ~ 1e-8
+    etaCFR  ~ 1e-8
+    etaLPW  ~ 1e-8
+    etaEC50 ~ 1e-8
+    etaKPRO ~ 1e-8
+    etaKP5 ~ 1e-8
+    etaSG   ~ sd(1.1)
+    etaKOUT ~ sd(1.2)
+    etaGDFZ ~ sd(1.3)
+    etaKIN  ~ sd(1.4)
+  })
+
+  expect_equal(m["etaMTT", "etaMTT"], 0.2^2)
+
+  m2 <- as.lotri(as.data.frame(m))
+
+  expect_equal(m, m2)
+
+})