Skip to content

Commit

Permalink
More tests and fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
@mattfidler
mattfidler committed Oct 9, 2024
1 parent 296199f commit d0f7290
Show file tree
Hide file tree
Showing 6 changed files with 148 additions and 52 deletions.
6 changes: 6 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -157,7 +157,13 @@ S3method(rxSolve,rxUi)
S3method(rxSolve,rxode2tos)
S3method(rxTrans,character)
S3method(rxTrans,default)
S3method(rxUdfUi,default)
S3method(rxUdfUi,linMod)
S3method(rxUdfUi,linMod0)
S3method(rxUdfUi,linModA)
S3method(rxUdfUi,linModA0)
S3method(rxUdfUi,linModB)
S3method(rxUdfUi,linModB0)
S3method(rxUiDeparse,default)
S3method(rxUiDeparse,lotriFix)
S3method(rxUiDeparse,rxControl)
Expand Down
2 changes: 1 addition & 1 deletion R/err.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1134,7 +1134,7 @@ rxErrTypeCombine <- function(oldErrType, newErrType) {
}))
if (length(.y) != .len) {
# Update the lengths of lstChr, lstErr, lstExpr
.len <- length(.cur)+ length(.env$before) + length(.env$after)
.len <- length(.env$before) + length(.env$after)
.env$lstChr <- c(.env$lstChr, character(.len))
.env$lstErr <- c(.env$lstErr, vector(.len, mode="list"))
.env$lstExpr <- c(.env$lstExpr, vector(.len, mode="list"))
Expand Down
76 changes: 60 additions & 16 deletions R/rudf.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -610,9 +610,14 @@ rxUdfUi <- function(num, fun, iniDf) {
UseMethod("rxUdfUi")
}

.linMod <- function(num, fun, iniDf, intercept=TRUE) {
.linMod <- function(num, fun, iniDf, intercept=TRUE, type=c("replace", "before", "after")) {
type <- match.arg(type)
.var <- fun[[2]]
.pow <- fun[[3]]
if (!checkmate::testIntegerish(.pow, lower=ifelse(intercept, 0L, 1L), len=1L)) {
stop("linCmt(", .var, ", ", .pow, ") needs to have an integer >= ", ifelse(intercept, 0L, 1L),
call.=FALSE)
}
.pre <- paste0("rx.linMod.", .var, num, base::letters[seq_len(.pow+ifelse(intercept, 1L, 0L))])
.theta <- iniDf[!is.na(iniDf$ntheta),,drop=FALSE]
if (length(.theta$ntheta) > 0L) {
Expand All @@ -639,34 +644,73 @@ rxUdfUi <- function(num, fun, iniDf) {
}
.eta <- iniDf[is.na(iniDf$neta),,drop=FALSE]
.iniDf <- rbind(.theta, .eta)
list(replace=paste(vapply(seq_along(.pre),
function(i) {
if (intercept) {
if (i == 1) return(.pre[i])
if (i == 2) return(paste0(.pre[i], "*", .var))
paste0(.pre[i], "*", paste0(.var,"^", i-1L))
} else {
if (i == 1) return(paste0(.pre[i], "*", .var))
paste0(.pre[i], "*", paste0(.var,"^", i))
}
}, character(1)), collapse="+"),
iniDf=.iniDf)
.linMod <- paste(vapply(seq_along(.pre),
function(i) {
if (intercept) {
if (i == 1) return(.pre[i])
if (i == 2) return(paste0(.pre[i], "*", .var))
paste0(.pre[i], "*", paste0(.var,"^", i-1L))
} else {
if (i == 1) return(paste0(.pre[i], "*", .var))
paste0(.pre[i], "*", paste0(.var,"^", i))
}
}, character(1)), collapse="+")
if (type == "replace") {
list(replace=.linMod,
iniDf=.iniDf )
} else if (type == "before") {
.replace <- paste0("rx.linMod.", .var, ".f", num)
list(before=paste0(.replace, " <- ", .linMod),
replace=.replace,
iniDf=.iniDf)
} else if (type == "after") {
.replace <- paste0("rx.linMod.", .var, ".f", num)
list(after=paste0(.replace, " <- ", .linMod),
replace="0",
iniDf=.iniDf)
}

}

#' @export
rxUdfUi.linMod <- function(num, fun, iniDf) {
.linMod(num, fun, iniDf, intercept=TRUE)
.linMod(num, fun, iniDf, intercept=TRUE, type="replace")
}
attr(rxUdfUi.linMod, "nargs") <- 2L

#' @export
rxUdfUi.linMod0 <- function(num, fun, iniDf) {
.linMod(num, fun, iniDf, intercept=FALSE)
.linMod(num, fun, iniDf, intercept=FALSE, type="replace")
}
attr(rxUdfUi.linMod, "nargs") <- 2L

#' @export
rxUdfUi.linModB <- function(num, fun, iniDf) {
.linMod(num, fun, iniDf, intercept=TRUE, type="before")
}
attr(rxUdfUi.linMod, "nargs") <- 2L

#' @export
rxUdfUi.linModB0 <- function(num, fun, iniDf) {
.linMod(num, fun, iniDf, intercept=FALSE, type="before")
}
attr(rxUdfUi.linMod, "nargs") <- 2L

#' @export
rxUdfUi.linModA <- function(num, fun, iniDf) {
.linMod(num, fun, iniDf, intercept=TRUE, type="after")
}
attr(rxUdfUi.linMod, "nargs") <- 2L

#' @export
rxUdfUi.linModA0 <- function(num, fun, iniDf) {
.linMod(num, fun, iniDf, intercept=FALSE, type="after")
}
attr(rxUdfUi.linMod, "nargs") <- 2L

#' @export
rxUdfUi.default <- function(num, fun, iniDf) {
stop("rxode2 user defined function '", fun, "' not supported", call.=FALSE)
stop("rxode2 user defined function '", fun, "' not supported", call.=FALSE) # nocov
}

#' Get the number of arguments for user defined functions for ui
Expand Down
2 changes: 1 addition & 1 deletion R/rxUiBlessed.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,5 +5,5 @@
"modelName", "mu2RefCovariateReplaceDataFrame", "muRefCovariateDataFrame",
"muRefCovariateEmpty", "muRefCurEval", "muRefDataFrame",
"muRefDropParameters", "muRefExtra", "muRefExtraEmpty", "mv0",
"mvL", "nonMuEtas", "oneTheta", "predDf", "singleTheta",
"mvL", "nonMuEtas", "oneTheta", "predDf", "redo", "singleTheta",
"sticky", "thetaLhsDf")
27 changes: 1 addition & 26 deletions man/rxode2.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

87 changes: 79 additions & 8 deletions tests/testthat/test-udf.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -394,14 +394,13 @@ test_that("udf type 2 (that changes ui models upon parsing)", {
tmp <- f()

expect_equal(tmp$iniDf$name,
c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c",
"rx.linMod.time1d"))
c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c",
"rx.linMod.time1d"))

expect_equal(modelExtract(tmp, a),
"a <- (rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3)")

# Test a linear model construction without an intercept

f <- function() {
ini({
d <- 4
Expand All @@ -414,7 +413,7 @@ test_that("udf type 2 (that changes ui models upon parsing)", {
tmp <- f()

expect_equal(tmp$iniDf$name,
c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c"))
c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c"))


expect_equal(modelExtract(tmp, a),
Expand All @@ -438,10 +437,82 @@ test_that("udf type 2 (that changes ui models upon parsing)", {
c("d", "rx.linMod.time1a", "rx.linMod.time1b", "rx.linMod.time1c", "rx.linMod.time1d",
"rx.linMod.time2a", "rx.linMod.time2b", "rx.linMod.time2c", "rx.linMod.time2d"))

expect_equal(modelExtract(tmp, a),
"a <- (rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3)")
expect_equal(modelExtract(tmp, a),
"a <- (rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3)")

expect_equal(modelExtract(tmp, b),
"b <- (rx.linMod.time2a + rx.linMod.time2b * time + rx.linMod.time2c * time^2 + rx.linMod.time2d * time^3)")


f <- function() {
ini({
d <- 4
})
model({
a <- linModB(time, 3)
b <- d
})
}

tmp <- f()

expect_equal(modelExtract(tmp, rx.linMod.time.f1),
"rx.linMod.time.f1 <- rx.linMod.time1a + rx.linMod.time1b * time + rx.linMod.time1c * time^2 + rx.linMod.time1d * time^3")

expect_equal(modelExtract(tmp, a),
"a <- (rx.linMod.time.f1)")

f <- function() {
ini({
d <- 4
})
model({
a <- linModB0(time, 3) + d
})
}

tmp <- f()

expect_equal(modelExtract(tmp, rx.linMod.time.f1),
"rx.linMod.time.f1 <- rx.linMod.time1a * time + rx.linMod.time1b * time^2 + rx.linMod.time1c * time^3")

expect_equal(modelExtract(tmp, a),
"a <- (rx.linMod.time.f1) + d")

f <- function() {
ini({
d <- 4
})
model({
a <- linModA(time, 1) + d
})
}

tmp <- f()

expect_equal(modelExtract(tmp, rx.linMod.time.f1),
"rx.linMod.time.f1 <- rx.linMod.time1a + rx.linMod.time1b * time")

expect_equal(modelExtract(tmp, a),
"a <- (0) + d")

f <- function() {
ini({
d <- 4
})
model({
a <- linModA0(time, 1) + d
})
}

tmp <- f()

expect_equal(modelExtract(tmp, rx.linMod.time.f1),
"rx.linMod.time.f1 <- rx.linMod.time1a * time")

expect_equal(modelExtract(tmp, a),
"a <- (0) + d")


expect_equal(modelExtract(tmp, b),
"b <- (rx.linMod.time2a + rx.linMod.time2b * time + rx.linMod.time2c * time^2 + rx.linMod.time2d * time^3)")

})

0 comments on commit d0f7290

Please sign in to comment.