From 9b916a0d7c1580cf78d740870f9bb856d837bb86 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 10 Apr 2024 15:11:00 -0500 Subject: [PATCH 1/5] Add rxFPixPGop --- NAMESPACE | 1 + R/ui-fix.R | 132 ++++++++++++++++++++++++++++++++++++ data/rxReservedKeywords.rda | Bin 733 -> 732 bytes data/rxResidualError.rda | Bin 1694 -> 1697 bytes data/rxSyntaxFunctions.rda | Bin 2446 -> 2444 bytes man/reexports.Rd | 1 - man/rxFixPop.Rd | 65 ++++++++++++++++++ man/rxode2.Rd | 12 ++-- tests/testthat/test-rxFix.R | 49 +++++++++++++ 9 files changed, 253 insertions(+), 7 deletions(-) create mode 100644 R/ui-fix.R create mode 100644 man/rxFixPop.Rd create mode 100644 tests/testthat/test-rxFix.R diff --git a/NAMESPACE b/NAMESPACE index 2a66d8860..77cfd01a3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -355,6 +355,7 @@ export(rxExpandGrid_) export(rxExpandIfElse) export(rxExpandSens2_) export(rxExpandSens_) +export(rxFixPop) export(rxForget) export(rxFromSE) export(rxFun) diff --git a/R/ui-fix.R b/R/ui-fix.R new file mode 100644 index 000000000..0174c97b3 --- /dev/null +++ b/R/ui-fix.R @@ -0,0 +1,132 @@ +#' Hard fix population variables +#' +#' @param item expression to consider +#' @param var variable list to fix +#' @param isLhs is the expression a lhs expression? +#' @return expression with variables replaced with constants +#' @noRd +#' @author Matthew L. Fidler +.rxFixPopVar <- function(item, var, isLhs=FALSE) { + if (is.atomic(item)) { + return(item) + } + if (is.name(item)) { + .n <- as.character(item) + .n <- var[.n] + if (!is.na(.n)) { + return(setNames(.n, NULL)) + } + return(item) + } else if (is.call(item)) { + if (isLhs && identical(item[[1]], quote(`/`))) { + # handle d/dt() differently so that d doesn't get renamed + .num <- item[[2]] + .denom <- item[[3]] + if (is.call(.num)) .num <- as.call(lapply(.num, .rxFixPopVar, var=var, isLhs=TRUE)) + if (is.call(.denom)) .denom <- as.call(lapply(.denom, .rxFixPopVar, var=var, isLhs=TRUE)) + return(as.call(c(list(item[[1]]), .num, .denom))) + } else if (isLhs && length(item) == 2L && + is.numeric(item[[2]])) { + .env <- new.env(parent=emptyenv()) + .env$new <- NULL + lapply(seq_along(var), + function(i) { + if (!is.null(.env$new)) return(NULL) + .curVar <- var[[i]] + .old <- .curVar[[2]] + if (identical(item[[1]], .old)) { + .env$new <- .curVar[[1]] + } + return(NULL) + }) + if (!is.null(.env$new)) { + # handle x(0) = items + return(as.call(c(.env$new, lapply(item[-1], .rxFixPopVar, var=var, isLhs=isLhs)))) + } + } + if (identical(item[[1]], quote(`=`)) || + identical(item[[1]], quote(`<-`)) || + identical(item[[1]], quote(`~`))) { + .elhs <- lapply(item[c(-1, -3)], .rxFixPopVar, var=var, isLhs=TRUE) + .erhs <- lapply(item[c(-1, -2)], .rxFixPopVar, var=var, isLhs=FALSE) + return(as.call(c(item[[1]], .elhs, .erhs))) + } else { + return(as.call(c(list(item[[1]]), lapply(item[-1], .rxFixPopVar, var=var, isLhs=isLhs)))) + } + } else { + stop("unknown expression", call.=FALSE) + } +} + +#' Apply the fixed population estimated parameters +#' +#' @param ui rxode2 ui function +#' @return NULL if nothing was changed, or the model UI +#' @export +#' @author Matthew L. Fidler +#' @examples +#' +#' One.comp.transit.allo <- function() { +#' ini({ +#' # Where initial conditions/variables are specified +#' lktr <- log(1.15) #log k transit (/h) +#' lcl <- log(0.15) #log Cl (L/hr) +#' lv <- log(7) #log V (L) +#' ALLC <- fix(0.75) #allometric exponent cl +#' ALLV <- fix(1.00) #allometric exponent v +#' prop.err <- 0.15 #proportional error (SD/mean) +#' add.err <- 0.6 #additive error (mg/L) +#' eta.ktr ~ 0.5 +#' eta.cl ~ 0.1 +#' eta.v ~ 0.1 +#' }) +#' model({ +#' #Allometric scaling on weight +#' cl <- exp(lcl + eta.cl + ALLC * logWT70) +#' v <- exp(lv + eta.v + ALLV * logWT70) +#' ktr <- exp(lktr + eta.ktr) +#' # RxODE-style differential equations are supported +#' d/dt(depot) = -ktr * depot +#' d/dt(central) = ktr * trans - (cl/v) * central +#' d/dt(trans) = ktr * depot - ktr * trans +#' ## Concentration is calculated +#' cp = central/v +#' # And is assumed to follow proportional and additive error +#' cp ~ prop(prop.err) + add(add.err) +#' }) +#' } +#' +#' m <- rxFixPop(One.comp.transit.allo) +#' m +#' +#' # now everything is already fixed, so calling again will do nothing +#' +#' rxFixPop(m) +#' +#' # if you call it with returnNull=TRUE when no changes have been +#' # performed, the function will return NULL +#' +#' rxFixPop(m, returnNull=TRUE) +#' +rxFixPop <- function(ui, returnNull=FALSE) { + .model <- rxUiDecompress(assertRxUi(ui)) + .model <- .copyUi(.model) + .iniDf <- .model$iniDf + .w <- which(!is.na(.iniDf$ntheta) & is.na(.iniDf$err) & .iniDf$fix) + if (length(.w) == 0L) { + if (returnNull) return(NULL) + return(.model) + } + .v <- setNames(.iniDf$est[.w], .iniDf$name[.w]) + .lst <- lapply(.model$lstExpr, + function(e) { + .rxFixPopVar(e, .v) + }) + .iniDf <- .iniDf[-.w, ] + .iniDf$ntheta <- ifelse(is.na(.iniDf$ntheta), NA_integer_, seq_along(.iniDf$ntheta)) + assign("iniDf", .iniDf, envir=.model) + suppressMessages({ + model(.model) <- .lst + .model + }) +} diff --git a/data/rxReservedKeywords.rda b/data/rxReservedKeywords.rda index 80fc13cd1332ee7e68cacfe73ae72df8290d41e0..ddeded968346ca4be65a87743d8d4c260ed33188 100644 GIT binary patch delta 653 zcmV;80&@M`1>6M=LRx4!F+o`-Q(4N|K!XD@7?C?%K)8!pnEi86NLJJ7<7k%c-CJ zFL7=ZVT$Y4g{>u<@E|@0h$wFeW%Igu!X8HCgv_Qp>JFS>LRx4!F+o`-Q(0HNVYZPDL=4gy88jIg0000027r-X9Dj{9J*r}0 zm}m)rm?H$kB-0~L)Cq*HgrQq-2}PMnTB3MWnnEwMyO<3{_*D~LzTUP(BC}rd>x2SW zO(Vy1=c#n!sXnySeH~jh=#A`RmZ8GLQM-0m$oB+e6A_J;i_GYlLdcLxhAE_kJ#gJo zp$1?eOhN_~ALH3IJ~sXitg12kWLO}?A-qs2 z;Auo4LJ(L-oV+hKVL&+IU~#LKyW(7#CK5zjh7kzLwuVR6RuR)PBAbg!^tA%{yMe@X zF?)+}qYPJGv@K~Y-+=+}G(kiX%+%_T71%1C8&sU_T=UN^$URJQcz;6_ryid=T&)#n zIxGwMu@|WUjLJ>@tBn9N4Jq@|S_rHwW7qF$)*>d6EwAB&#a0#!-=_-Mw~ryV)gmq4 zq(vDsh_RL4H4s#+=1}u|MbK4y}Ta_uY;);Rvr6B;E(ire9&CB}bzOjp{!op?|I%5h6 z=V;o#Y#bJop+xzc%qqK*3vB|)4TBb8r0t~$=!s~?)~niM%4dlvQJlzO>VSn(ioSNM zTq6<1G%5TD8rUP5N@?DS@8(;kFFrJXYul^};t~mf%DqlmsUSzOq6Z1p<%ZS|Ep1$t oB^~k@uZ?d4_d#<&f-v(`>&8E0<-=uw41fSPh$U4IDdi0Y zK+y3|A~eW7On}fd0i!@@8X6i0q--b+>W2UT&;ZZ|fB+2`fB~QY0004?1XK2|qDah=vfW47BdoT3txMu|2^7lFGe9BV}GOl ze0Va(Vj?0disjr{ml;+@QDtQoH4(qTz2@Cher9H6mKYLDKnt16%Z$w7R9Qu3%H03} zBme*m%#2LPx0gpSlWMDh8x~2=l}zP-NmAdf=9$^O8)7)NLZh2_Y7%DC1n6X#34z(fnF-l2ojOCf z85XVMca6&9cGnIT?$(QjV~wr^Wfu&sVVRuenVgp=BY7NfxZyj%Foy)0(SHJD!~y^k z2Xux&AY)o??6)(B7{mffnM`INV-N`{Wiyj3w=DNU+jUblZDTcUX69wO(`}hz)wMCE zGz~P&-McZ2-HA6EVVx(AA$PnZE6cf4fl_v<`KWX{%XG8)zQvLm+RYalu6ksxPPnb{0LqLAp2qU zg9G^k;tu&dJqnDRjk0OkO)0J>0FfG#L8OPw~}WH%Eh#X5hn&@o7r9Xf{g@0Ybra^l|oB8KMEMUx0=L$Hq>J^Vy6&8zoEMUx$>tmk!{)iAv`5)hUekDup8r}&;kD-K5%1%(QCTe=e; z?le_g_jaLOLQY?|j&{GoT)bQhIIjOJRZY%($tO?KXNpbLWq*q%ODG}~phyx@fB+Z( z0wGl_%;v1gaNZ@umFL?b%L_(A^T|8h!cU8R@%@h&g`ROI9YXPbt={;PxqrY(?Chy(75Z=^0bq|S+x+dq zI7|1sd1ub~{?LQd5^cKg>Z-eoVJ7!BjW$LR+g6Jr(O_vWL28rN6{?1~twJ|j`H{Ag z>ld?t#za5}FryqaSKvwsMtcfR_NnR|kR)FBmyg^A-Otk+gynGdCh5mi%g&^U|%fq|x)ea7+1r^w+v zx)xEq6)!TSNzxF1A7nBZ%WGTRu9EAjs(*y-bRv*}1l+uwKoKW^kIfJXv!Mk-g#b|4 jL+Jvb(L|9|$3&!wDkMcJQvluRo>0(a z4G$FZBTR$T$PEKP8Z-uhp`oC9M#6yJsBi!c01W_W007a502%-Q000^QML%j(fB};r z02&P%00Te(05kvq001RFRHY=*7zwou000nR00009h`})!001JSQhG9&Oan=@6B9-N zHGdffnWibU5u;215#&SEG-3rQLI@|J0256oskEA&Q`Ge|^%E%t=F1~Iyq?ErwkF?;i9B`c%vT|`*QeqN>#mocgy?wVNcPDbaZoSkq*2|=tc77 zO#K_Li5QK3d*kNVwg0~k?bqt7b(Y%>H-GL%$m4@=)5o8#e4K^#!quR(3zuu2w`s*4 zH;49fjt9An?B&inhP(HTbgeotHg$E>OwjAzG$!jP%Rt~bjYDS+RR8|XjvsqQIsL5-?dv2mWK0H41ckh zh=_{fxpx+2##ND&Sy@GmL~rhIc{fzwnVFeoh6Ixk0_Jk^<1;u_7ExJpw?F_10009s zBNH+$<B1V)WX zHmc>>Wzc43bo}?*(Q+`0Fk(zFuz!joHkWw z+D(;tqCQT?b!qzfce78irgm>e*p4lbsOH`pgqgI#IvFMcV0LjPLUv3iPLS>fMXPw- z<8rv&wZnzGwW8se<7phVok=FXG!6RU9RxT@$P0C4MPUQl5PdC+P7Nennt06ec|ajgm3M?x5vWt@x#Bz zyPd4f)tf4`-PN+n(|1?WB21AH2_%w9B$69$?Z###Mr4e}Wmv{zGPh5I zT@3=*FMkSYw$oijl`vQ>y!sT^cJAIv>C`Tq0NGXv(klff2#_hkwwn@4(1{Q5s=@Ed z^)h)CdlGlaHFqGe_W66-r_lIxE*$K7IyuQQ{o8Hw2|Fb>6@5Q-3xBxeAJ`vAFh1aW z;oEe2!!j7iUe`~ON&K5VcAd0*p(mbO`~DAXxUeh5;I{K&C#S=2V_{QXPwU*_RJVyf zoSMQ~lA#m<^Z>FzT{v5SE>JPcp+02jucuLtg&$MJ=nJ^Jd5p6aXcn4TVvZ%@UWM~l zlgW4`KA?jNyaJ{{dVl1b`R79{V9ZhF3OKat6^}<17K?iaOV zU&GK_(x_*t$DhHdzkFhR!c`;!QQF!xA>Xm+Dh(wEfrTi z;M6OqNz3_h&e!UfF8>0~E4RxPQ*)m(Nz?P$-;;G&V#$)q2!Dkr5(Jc>00sa6h*e87 zIjb^UH;HiNd3MNh!qJetvQF19li%NbA6vuE?X}iT@@KQ+7eyASI(z7MGE*3nQF&J4A$c=sJFt@_3$mMjxH7rRzuTTGR$BtQsVVGuF zlPbckH-vA(4~Zw4CuB#xMG_PE4sB;s5IaS@?cvL2AY{_%nD4lVxb zI8kVd!5hZ#?~D&P!02>&1)fnS9YXK^t={01z~ChHc7Ig03jH_{fUrl6?0$CP93}ld zJhSF}-&{fGi8kGK^;KR1*h#(3qfL>7cWTjOS}YAE<}FfsVzp4$6{tq*e=;`GU1Ifc z83bej1|(!fRz-B0&;{}sao@}OZgZb=tmY~oW0BJofOvp_r%J}RceIR3srI;>tmL`f zC74Asy?*!9gv;C%9-#=VG%QaUEoQp249I;fIEt#9hJnOj3=9o4)9yEpRX#@v<J{##>t6?R1x2Ra5*YYoQc`2qw+W$pI3G2<;*PK7>H1QlttSC~d(| fX`)G0a}g>ccwGh<^aKErT_=A{PgKoAN1-yBWB?5^4FCWPfM_&m4H+_e zPg6}a8~^|f000>p82|tP0079y00SUMkRS*M6AE}#{Y|84Jt?sRC}hyn(ho_KXpJ$W z)X|VlHRuu~wmATii_?87E0~0jnTZWY$siIWnp=Cjbch9AiRwUvkXUIK%64bVHX(nz z_%0X8mCcqts`4+iJy=^5>$gIy1Q^c=lrS6TF>1**4ER}#1B(@Lf=}YRS^sRkbqdx7 zRxhqHo>BBM8<}D7_}PWiDayWC^Qpyi*6K`$^hu`2Sb&HiZdnwQl=1%zI+u$9FJwsw z7yttX5c(XL91;PrZLk|an@O>Wuo8b85*q~AkTHlvn2?e+uRs7zfUevAiWbc_kZkjP z>2=U4$A%LNVFj)k1QF9SsT8q8iD*84((|cJTnsDzcX_C<9&1ukSfT@GQ8LWwI5SCn z>@oe=7Kxx!t3HsSef);}W#dStDJoBGrw}G2aDxkmcysJECvgj4%@L5mZLojDmO#V5 z=7DsKME9~C!O0R8%|W!xB(08`C!$N9v_s}n!wzaL53s&`NHn^()*L|%i)|!r2n|(( zEXXeljlpHMge**iVBXBdp4SAY3ijG5;#XNuS0669R(q?95+Pp5bI_`rR}##LmKw+8 zwY1n^>$fucOyeoN?Hw3Yv59~3)Qp?dD?6Uzk6^E4t9BD1gPX~h6EiI-7M1mGxi;#K z4LBU?SW!t)WHAZ`S|>58)u;>qPp+;tdXoH2d>96PKz_{izg|uFvZFfZ!d2xl?Zo=U z{yiCB+tUJaG?g}HVPM0ibWe|WjbQBC!{;en@`^uD(AmGDHdBO&vldg_gBOE4D;KrD$o>RnoerFG!gvooW=~%2 znc8;{&g&|UMbJch5#LUADksdI)>BiB;XJj0Xr1~yWtKfg9QT(D*SNG(ZMy7!T5vdl zV7neCQ`bsIkEA?_!Qg+z`DuxA^W@0)>};H2M%Z&`bSh&2LJDLEj2bjRSt-|!oq#DI zC{04UX;g%+TMZviv!sKtMnThP=+spR3=A_iOxR&G?asDtQ(o;YxDl^D8C}ifg$iRd z4BK!_@4{JfBIn{x%+*7P7Mb2u1+&a@5NSy7qrp-)*W%)dor{0I*u$Eaw|8stdql)5 zpMHERCxcC950PMPu$VY*AR)Fu-h>ViXvmO`D>G7}JN})11&wP$M}}bq>A(45fndi_ z`}Bs2q*vo@qLB%&kWLYX#I*_fEs%oXmvM<640Kt=FrYetBDi)Whysf!tP6Ungh^?Y zUAV9`t1UTmWK4fZ#1bIKPe{6vGx8fG0}jgu@>}1jYA8YL@o!HG9y=poP}ro8vZjQ| zh$Iai9okQ=44S4gG?;RBm?T-GRxJd>0ebt*y?NidDj zl^bw5G0Vlh?gr$zT^peZKz5xU&(BS+<`x)`(lUV?@z8(CBSo;~zrm)rbMOjyNbBOM z5kU3_Ih>3kqX8j=hb3S`f)L4@pvcw5n*8PWm@=jVoY91>K_al5R=zG%fs@j+206pA zSP0%EYOm1ng8x=ZS%9b)bQv zu`Akvh%MS3q_H>g+1L{Gpml6SV2kHB=NiUDxsywC(GcyF$1~>-8#F@#w zER>#-m78YfrRaPZH<*Z z(CGh-Jv0;o7(nCdW=&jE*(<3i4wS`T?}EUJ3=Xyppe@VtU|ObHPe!o~T1IE@AGd)*Q#dkhST1T~T-L<$-6L=6>7 zIY1kx(_>)YmALYw&*+A47o4DAgu$Rh%%DDVi13FbVY3mc?<%`hS!hhckc5OBOlX zqZ1OT=s|6Pe&8fXXxyg8hBn6h^AJ?o{W6sC^XCIixe+m?BN4}KIFp&{sWl&e`cj9)$7HHFrxg6IeD~2@^Aq)kolp=aja|3NF%6nhVU!R`*HBLDQLMD9ISS8tX1)w4a-C SpXP=a_`8xR!i0uUsCanx-Cy7U delta 2402 zcmV-o37z(g6OI!OLRx4!F+o`-Q(22D1LlzqBrAAI003DA00BT1LW)oe5mVZP(?r5# zVj5sfLjXh6$aw%Ek&wobfXZMKOp#wFe-l$oiIdSXr|M+`BQ(^(JwOJ76AeL-^lBIx zPf7ZjO*Hif0009(00u^eKmY&$05UQF0LT&~CV(I$%}gc~^&XLvNWvI~O#z_EqX^Jw z^)fPK7a&NI)Z_w24?VQ7REHDd3JKBIaHmUB+2l%CoKM=u?Ve#a&Y&@kyq~NPvhSZdjC)l<@pl^DcG*UTBgK zFaQP|ASB5!HzWgK+h8_&W*_$z40AdXp_$fZgf%E9yWmmJD!&|zogx4%Vj@>&v-!4Mj`iIrz5xtYu7 zVTaLqSegYp8T5qq&R{b7P?5*5E?3m zIS^bHn*ys{2v``1y}elrEp7=;70t9$w6jT1M;{iL**%tE#E4fi9P=zwYSLK|GNV{~ z)vkJr-J0?)q|Nf1+R?)Me+rl%6@+5mfn@D_3Oz!(lCs<8LkBmDEhc1EQY$O0Zqml} z$AbT**{xPDHJOGahHNabYLt+DA20I$dRwh8fv;BZ%eW8kmX~S8w+2`D;=0 zn%BdO556rJe(tzESIONJenFwLZwS>*(k9FqPaGIK+0kTN*52dlBOIu5;f?dWd1*3w zb!y79w1#z6SUDEK5#Wxxaw$)Z%q;I?f4KxrA0Te_~K%$hEpr=Iav-=xD%*-3yON+d&!-zswq*e~|0W(7yJ|+Mxb|FxKY`ARU@)rwcf764==;8JFZK9v+$>{!b z_KXE*o8N_~b@x`#`PatV3Im4X0vluv_F!;>wK8Ho#&i;tb-ykTX8!%cM`D2m^xx>h z!th&&J9R@v5-GUbMNtW^@SGydX>Sz#au9r z1eiw1N{zT2nC05u*8_4}t&Na`pgK+;XPr%M))g3#f6_658*t3UBQ>b+UD(rGIX4A6 zBy;anh@f}}Ih;%(qVXYwhb2%$f)L4@AjHwdTKP+^FJ*<}oY8!%K_bXas@)c;z{%%i z!H#h1SpgeFjTPCQkX_`wx}#@eF_~+^&o?4^<_3JT+oy1minxrq z_RNGye_AAJy;x-=tPOe=o50Np*Q@u4gGUZal~|&eA|G0sTF>B$w#)tVeXgWMp2NpvM5% zc9S@^g;JBwQmbs()Vwcuqpl+yk=oU{WM?xke+g(+BEyLAj2J7%k#7_7O2g!;NE1G1j6K0iOn-`pU~& zZLzY$(heW9KNST4h7dUOGA6Al=9Xwm1C=pZ_+Y3ag9Dv|XbShe>%hFU39x7I?Cs1q ze-sLm5MSiY^>kuRB{n`&fL11MM1EDVlZ?PFLM>skR7&EcRCcc+ei`RD|JT}9j z`k*$Wl3`lG@OPDSXkzc4D){du=yM$AK9g58jpiaUIfjF42hiytL>vQiI*=U0NkR?H z5Ql(i_N_rYs)ogR$cGXeK?P_jAqBHYf6~&21W>gZR;?hlp$!v)AHyh-q#`6XJsVR0 zwV!G1yu#~%fhr=`1TsLzl7S(nOh|+i0z^glR=$4hMq>2+J`yQ&3(QFbHHs!g3K{c6 z4HhMopbMtcV_@Gt_O^6v?L#sPWT-4cV9+9R1?@KImqMA5RFbLBBa}y}sUT2Le@M8z znK-={a)7D^?Rp2GFKLOkiy@~{@Ys6o1O{d3u*1rB8D4vh9+9jslmu#ppMi4^gZ|9S zk;WY=K*qQsodL>u@UEQql~LI3XFCG|Ch# zAwo@ekn9;^3qJQ=2TVa$jQ7`x&2du8@UTdPFcykXiRVSe4YaN)=lzoTc`pedM)w-b zR7oq2J|v(PfDI6nOW2`$e=P_o4>pa@Sb|5hD}n50O2d?;XcvZ|uhZ-GByyI7F0-u$ z%&#U?HcJUo8}*uA*=Ty3K|4jLYYY@fIMI=`0|ahm62S^W)-g;8?h+)CazyTo8n8oa zTS~&A|0J&A-)Ki@&^DL4z*dyc&l*t6z#AVYKzC*&L5C$Zf_lft979uF(VRFI#SDo* Uztqq9p@iNp Date: Wed, 10 Apr 2024 15:13:46 -0500 Subject: [PATCH 2/5] Add to news --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index 545036d89..f600f968a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,9 @@ - Create a function to see if a rxode2 solve is loaded in memory (`rxode2::rxSolveSetup()`) +- Create a new function that fixes the rxode2 population values in the + model (and drops them in the initial estimates); `rxFixPop()` + # rxode2 2.1.2 ## Other changes From c56a9c1798104006f062b7b054ea3cd9ff1c7d04 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 10 Apr 2024 18:48:23 -0500 Subject: [PATCH 3/5] Update documentation & add check for logical --- R/ui-fix.R | 7 ++++++- man/rxFixPop.Rd | 7 ++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/R/ui-fix.R b/R/ui-fix.R index 0174c97b3..9ba691a44 100644 --- a/R/ui-fix.R +++ b/R/ui-fix.R @@ -61,7 +61,11 @@ #' Apply the fixed population estimated parameters #' #' @param ui rxode2 ui function -#' @return NULL if nothing was changed, or the model UI +#' @param returnNull boolean for if unchanged values should return the +#' original ui (`FALSE`) or null (`TRUE`) +#' @return when `returnNull` is TRUE, NULL if nothing was changed, or +#' the changed model ui. When `returnNull` is FALSE, return a ui no +#' matter if it is changed or not. #' @export #' @author Matthew L. Fidler #' @examples @@ -109,6 +113,7 @@ #' rxFixPop(m, returnNull=TRUE) #' rxFixPop <- function(ui, returnNull=FALSE) { + checkmate::assertLogical(returnNull, any.missing = FALSE, len=1, null.ok=FALSE) .model <- rxUiDecompress(assertRxUi(ui)) .model <- .copyUi(.model) .iniDf <- .model$iniDf diff --git a/man/rxFixPop.Rd b/man/rxFixPop.Rd index 9f3e4837f..e0791249e 100644 --- a/man/rxFixPop.Rd +++ b/man/rxFixPop.Rd @@ -8,9 +8,14 @@ rxFixPop(ui, returnNull = FALSE) } \arguments{ \item{ui}{rxode2 ui function} + +\item{returnNull}{boolean for if unchanged values should return the +original ui (\code{FALSE}) or null (\code{TRUE})} } \value{ -NULL if nothing was changed, or the model UI +when \code{returnNull} is TRUE, NULL if nothing was changed, or +the changed model ui. When \code{returnNull} is FALSE, return a ui no +matter if it is changed or not. } \description{ Apply the fixed population estimated parameters From 3311264aafde392457e13f339d1020b1d0500476 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 12 Apr 2024 19:52:08 -0500 Subject: [PATCH 4/5] New test case for rxFixPop() --- R/ui-fix.R | 6 +-- tests/testthat/test-rxFix.R | 84 +++++++++++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+), 3 deletions(-) diff --git a/R/ui-fix.R b/R/ui-fix.R index 9ba691a44..aac9198a1 100644 --- a/R/ui-fix.R +++ b/R/ui-fix.R @@ -32,10 +32,10 @@ lapply(seq_along(var), function(i) { if (!is.null(.env$new)) return(NULL) - .curVar <- var[[i]] - .old <- .curVar[[2]] + .curVal <- setNames(var[i], NULL) + .old <- str2lang(names(var[i])) if (identical(item[[1]], .old)) { - .env$new <- .curVar[[1]] + .env$new <- .curVal } return(NULL) }) diff --git a/tests/testthat/test-rxFix.R b/tests/testthat/test-rxFix.R index 55157bf75..5afe3e6fb 100644 --- a/tests/testthat/test-rxFix.R +++ b/tests/testthat/test-rxFix.R @@ -46,4 +46,88 @@ test_that("rxFix", { expect_true(is.null(tmp3)) + nlmixr_threecmt_mm_no_add_wtcl_pdtg_kout_delay2 <- function() { + ini({ + tf_sc <- log(999) + tf_infilt <- log(999) + tka_sc <- log(999) + tka_infilt <- log(999) + tcl_low <- log(999) + tcl_high <- log(999) + tcl_c50 <- log(3000) + e_wt_cl <- fixed(999) + tv <- log(999) + tq1 <- log(999) + tvp1 <- log(10) + tq2 <- log(999) + tvp2 <- log(20) + eta_cl~999 + eta_v~999 + prop_err <- 999 + tg_bl <- log(999) + eta_tg_bl~999 + tg_kel <- log(999) + tg_ec50 <- log(5000) + tg_emax_kel <- log(2) + ktr_tg <- log(999) + prop_err_tg <- 999 + }) + model({ + # PK setup + f_sc <- exp(tf_sc) + f_infilt <- exp(tf_infilt) + ka_sc <- exp(tka_sc) + ka_infilt <- exp(tka_infilt) + cl_low <- exp(tcl_low + eta_cl)*(WEIGHT_BL/85)^e_wt_cl + cl_high <- exp(tcl_high + eta_cl)*(WEIGHT_BL/85)^e_wt_cl + cl_c50 <- exp(tcl_c50) + v <- exp(tv + eta_v) + q1 <- exp(tq1) + vp1 <- exp(tvp1) + q2 <- exp(tq2) + vp2 <- exp(tvp2) + # PK micro-parameters + ke_low <- cl_low/v + ke_high <- cl_high/v + kc_p1 <- q1/v + kp1_c <- q1/vp1 + kc_p2 <- q2/v + kp2_c <- q2/vp2 + # TG setup + tgbl <- exp(tg_bl + eta_tg_bl) + kin_tg <- tgbl*exp(tg_kel) + ktr_TG <- exp(ktr_tg) + TG(0) <- tgbl + # differential equations + cp <- CENTRAL/v*1e3 # 1e3 is for unit conversion + ke <- ke_low + (ke_high - ke_low)*cp/(cp + cl_c50) + kout_tg <- exp(tg_kel) + exp(tg_emax_kel)*TG_TR/(TG_TR + exp(tg_ec50)) + d/dt(IVINFILT) = - ka_infilt * IVINFILT + d/dt(SC) = -ka_sc * SC + d/dt(CENTRAL) = ka_sc * SC + ka_infilt * IVINFILT - ke*CENTRAL - kc_p1*CENTRAL + kp1_c*P1 - kc_p2*CENTRAL + kp2_c*P2 + d/dt(P1) = kc_p1*CENTRAL - kp1_c*P1 + d/dt(P2) = kc_p2*CENTRAL - kp2_c*P2 + f(SC) <- f_sc + f(IVINFILT) <- f_infilt + # TG transit model + d/dt(TG_TR) = ktr_tg*cp - ktr_tg*TG_TR + d/dt(TG) = kin_tg - kout_tg*TG + # Residual error models + cp ~ prop(prop_err) + TG ~ prop(prop_err_tg) + }) + } + + tmp <- rxFixPop(nlmixr_threecmt_mm_no_add_wtcl_pdtg_kout_delay2) + + expect_equal(tmp$theta, + c(tf_sc = 6.90675477864855, tf_infilt = 6.90675477864855, tka_sc = 6.90675477864855, + tka_infilt = 6.90675477864855, tcl_low = 6.90675477864855, tcl_high = 6.90675477864855, + tcl_c50 = 8.00636756765025, tv = 6.90675477864855, tq1 = 6.90675477864855, + tvp1 = 2.30258509299405, tq2 = 6.90675477864855, tvp2 = 2.99573227355399, + prop_err = 999, tg_bl = 6.90675477864855, tg_kel = 6.90675477864855, + tg_ec50 = 8.51719319141624, tg_emax_kel = 0.693147180559945, + ktr_tg = 6.90675477864855, prop_err_tg = 999)) + + }) From a9bc4109233db5624ff2ae2a820e7f98784e10d6 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 13 Apr 2024 13:20:11 -0500 Subject: [PATCH 5/5] Add rxFixPop --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index da8be4eda..198af0332 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -38,6 +38,7 @@ reference: - zeroRe - assertRxUi - rxAppendModel + - rxFixPop - rxRename - update.rxUi - as.rxUi