From 9edd95d1c938290a57b595a769a0b7f7a55e5729 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Fri, 13 Sep 2024 18:21:54 -0500 Subject: [PATCH 1/4] Add failing test --- tests/testthat/test-line-form.R | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/tests/testthat/test-line-form.R b/tests/testthat/test-line-form.R index 399d997..44e466c 100644 --- a/tests/testthat/test-line-form.R +++ b/tests/testthat/test-line-form.R @@ -271,4 +271,32 @@ test_that("lotri lower triangular matrix specification 2", { expect_equal(fix1, fix2) + test_that("Issue #28", { + + expect_equal(lotri({ + eta1 ~ 0.175278 + eta2 ~ c(0.115896, 0.112362) + eta3 ~ c(0) + }), + lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), + eta3 ~ 0)) + + expect_equal(lotri({ + eta1 ~ 0.175278 + eta2 ~ c(0.115896, 0.112362) + eta3 ~ fix(0) + }), + lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), + eta3 ~ fix(0))) + + expect_equal(lotri({ + eta1 ~ 0.175278 + eta2 ~ c(0.115896, 0.112362) + eta3 ~ 0 + }), + lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), + eta3 ~ 0)) + + }) + }) From 337202e3539100d3275bb3c9c6e7565cc2cdafe6 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Fri, 13 Sep 2024 19:19:13 -0500 Subject: [PATCH 2/4] Fix line form issue --- R/lotri.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/lotri.R b/R/lotri.R index 5f21c72..989d4f6 100644 --- a/R/lotri.R +++ b/R/lotri.R @@ -364,7 +364,7 @@ NULL #' @return Returns `TRUE` if the processing is successful and the data #' frame is updated, otherwise returns `FALSE`. #' @noRd -.handleSingleLineEstInForm2 <- function(x2, values, fixed, unfixed, env) { +.handleSingleLineEstInLineForm <- function(x2, values, fixed, unfixed, env) { .r <- values .rf <- fixed .ru <- unfixed @@ -425,7 +425,7 @@ NULL .r <- .rl[[1]] .rf <- .rl[[2]] .ru <- .rl[[3]] - if (.handleSingleLineEstInForm2(x2, values=.r, fixed=.rf, unfixed=.ru, env)) { + if (.handleSingleLineEstInLineForm(x2, values=.r, fixed=.rf, unfixed=.ru, env)) { return(NULL) } if (env$lastN != 0 && length(x2) == 1L && length(.r) == env$lastN + 1) { From 6a48a7d1003e2451ac5c5de3d80535f629720ee1 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Fri, 13 Sep 2024 21:03:14 -0500 Subject: [PATCH 3/4] Fixes for restart type 1 --- R/lotri.R | 78 ++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 54 insertions(+), 24 deletions(-) diff --git a/R/lotri.R b/R/lotri.R index 989d4f6..adb4e14 100644 --- a/R/lotri.R +++ b/R/lotri.R @@ -127,23 +127,31 @@ NULL .ret } +.isFixedElt <- function(x) { + (identical(x, quote(`fix`)) || + identical(x, quote(`fixed`)) || + identical(x, quote(`Fixed`)) || + identical(x, quote(`FIXED`)) || + identical(x, quote(`Fix`)) || + identical(x, quote(`FIX`))) +} + +.isUnfixedElt <- function(x) { + (identical(x, quote(`unfix`)) || + identical(x, quote(`unfixed`)) || + identical(x, quote(`Unfixed`)) || + identical(x, quote(`UNFIXED`)) || + identical(x, quote(`Unfix`)) || + identical(x, quote(`UNFIX`))) +} + .repFixedWithC <- function(x, env=new.env(parent=emptyenv())) { if (is.call(x)) { - if (identical(x[[1]], quote(`fix`)) || - identical(x[[1]], quote(`fixed`)) || - identical(x[[1]], quote(`Fixed`)) || - identical(x[[1]], quote(`FIXED`)) || - identical(x[[1]], quote(`Fix`)) || - identical(x[[1]], quote(`FIX`))) { + if (.isFixedElt(x[[1]])) { env$fix <- TRUE x[[1]] <- quote(`c`) return(x) - } else if (identical(x[[1]], quote(`unfix`)) || - identical(x[[1]], quote(`unfixed`)) || - identical(x[[1]], quote(`Unfixed`)) || - identical(x[[1]], quote(`UNFIXED`)) || - identical(x[[1]], quote(`Unfix`)) || - identical(x[[1]], quote(`UNFIX`))) { + } else if (.isUnfixedElt(x[[1]])) { env$unfix <- TRUE x[[1]] <- quote(`c`) return(x) @@ -213,16 +221,10 @@ NULL #' @author Matthew L. Fidler #' @noRd .lotriParseMatCalculateFixedProps <- function(x, env=NULL) { - if (identical(x[[1]], quote(`fix`)) || - identical(x[[1]], quote(`fixed`)) || - identical(x[[1]], quote(`FIX`)) || - identical(x[[1]], quote(`FIX`))) { + if (.isFixedElt(x[[1]])) { env$globalFix <- TRUE } - if (identical(x[[1]], quote(`unfix`)) || - identical(x[[1]], quote(`unfixed`)) || - identical(x[[1]], quote(`UNFIX`)) || - identical(x[[1]], quote(`UNFIX`))) { + if (.isUnfixedElt(x[[1]])) { env$globalUnfix <- TRUE } } @@ -641,10 +643,38 @@ NULL exists(as.character(x[[3]]), envir=.lotriParentEnv)) { x[[3]] <- str2lang(deparse1(get(as.character(x[[3]]), envir=.lotriParentEnv))) } - if (length(x[[3]]) == 1) { + .fix <- FALSE + .unfix <- FALSE + .x3 <- x[[3]] + if (length(.x3) == 2L && + identical(.x3[[1]], quote(`c`))) { + .x3t <- eval(.x3, envir=.lotriParentEnv) + if (length(.x3t) == 1L && is.numeric(.x3t)) { + .x3 <- .x3t + } + } else if (length(.x3) == 2L && + .isFixedElt(.x3[[1]])) { + .x3t <- .x3 + .x3t[[1]] <- quote(`c`) + .x3t <- eval(.x3t, envir=.lotriParentEnv) + if (length(.x3t) == 1L && is.numeric(.x3t)) { + .x3 <- .x3t + .fix <- TRUE + } + } else if (length(.x3) == 2L && + .isUnfixedElt(.x3[[1]])) { + .x3t <- .x3 + .x3t[[1]] <- quote(`c`) + .x3t <- eval(.x3t, envir=.lotriParentEnv) + if (length(.x3t) == 1L && is.numeric(.x3t)) { + .x3 <- .x3t + .unfix <- TRUE + } + } + if (length(.x3) == 1) { .resetLastN(env) ## et1 ~ 0.2 - if (is.numeric(x[[3]])) { + if (is.numeric(.x3)) { env$lastN <- 1 env$netas <- 1 env$eta1 <- env$eta1 + 1 @@ -654,8 +684,8 @@ NULL data.frame( i = env$eta1, j = env$eta1, - x = setNames(eval(x[[3]], envir=.lotriParentEnv), NULL), - fix=FALSE, unfix=FALSE)) + x = setNames(eval(.x3, envir=.lotriParentEnv), NULL), + fix=.fix, unfix=.unfix)) } else { stop("cannot figure out expression `", deparse1(x), "` in lotri while handling `~`") } From 829dd5bf920780962b31af2b3fb547de7f83468d Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Fri, 13 Sep 2024 21:04:45 -0500 Subject: [PATCH 4/4] Add some more line forms that could occur --- tests/testthat/test-line-form.R | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/testthat/test-line-form.R b/tests/testthat/test-line-form.R index 44e466c..29d0599 100644 --- a/tests/testthat/test-line-form.R +++ b/tests/testthat/test-line-form.R @@ -281,6 +281,14 @@ test_that("lotri lower triangular matrix specification 2", { lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), eta3 ~ 0)) + expect_equal(lotri({ + eta1 ~ 0.175278 + eta2 ~ c(0.115896, 0.112362) + eta3 ~ c(eta3=0) + }), + lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), + eta3 ~ 0)) + expect_equal(lotri({ eta1 ~ 0.175278 eta2 ~ c(0.115896, 0.112362) @@ -289,6 +297,14 @@ test_that("lotri lower triangular matrix specification 2", { lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), eta3 ~ fix(0))) + expect_equal(lotri({ + eta1 ~ 0.175278 + eta2 ~ c(0.115896, 0.112362) + eta3 ~ fix(0) + }), + lotri(eta1+eta2 ~ c(0.175278, 0.115896, 0.112362), + eta3 ~ fix(eta3=0))) + expect_equal(lotri({ eta1 ~ 0.175278 eta2 ~ c(0.115896, 0.112362)