From c9e8fd69b3d11d59e7e4054028081a24a9c42360 Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Tue, 14 Nov 2023 07:44:51 -0500 Subject: [PATCH 1/3] caching functions in helper file --- tests/testthat/helper-cache.R | 65 +++++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 tests/testthat/helper-cache.R diff --git a/tests/testthat/helper-cache.R b/tests/testthat/helper-cache.R new file mode 100644 index 00000000..086889d0 --- /dev/null +++ b/tests/testthat/helper-cache.R @@ -0,0 +1,65 @@ +# tools for caching results within testthat. + +is_object_available <- function(object, fail = FALSE, save_path = "saved_objects") { + cl <- match.call() + file_name <- paste0(cl$object, ".RData") + file_path <- file.path(save_path, file_name) + has_file <- file.exists(file_path) + if (fail && !has_file) { + msg <- paste0("File '", file_name, "' is not in '", save_path, "'.") + cli::cli_abort(msg) + } + has_file +} + +save_object <- function(object, save_path = "saved_objects") { + cl <- match.call() + file_name <- paste0(cl$object, ".RData") + file_path <- file.path(save_path, file_name) + res <- try(save(object, file = file_path), silent = TRUE) + # returned NULL if it worked + if (is.null(res)) { + # verify + res <- file.exists(file_path) + } else { + # save failed + print(as.character(res)) + res <- FALSE + } + res +} + +return_object <- function(object, save_path = "saved_objects") { + cl <- match.call() + file_name <- paste0(cl$object, ".RData") + file_path <- file.path(save_path, file_name) + load(file_path) + object +} + +purge_objects <- function(save_path = "saved_objects") { + all_files <- list.files(save_path, pattern = "RData$", full.names = TRUE) + res <- vapply(all_files, unlink, integer(1)) + df_res <- tibble::tibble(file = names(res)) + df_res$deleted <- ifelse(res == 0, TRUE, FALSE) + invisible(df_res) +} + +# Example usage +if (FALSE) { + pkg <- "tune" + is_object_available(pkg) + + save_object(pkg) + is_object_available(pkg) + + rm(pkg) + pkg <- return_object(pkg) + pkg + + file_86 <- purge_objects() + file_86 + is_object_available(pkg) + + is_object_available(some_other_pkg, fail = TRUE) +} From 03ef64114482370ca2f10c6384beffa07d15621d Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Tue, 14 Nov 2023 07:45:04 -0500 Subject: [PATCH 2/3] caching example --- .../saved_objects/grid_static_res.RData | Bin 0 -> 21283 bytes tests/testthat/test-survival-tune-grid.R | 93 +++++++++++------- 2 files changed, 59 insertions(+), 34 deletions(-) create mode 100644 tests/testthat/saved_objects/grid_static_res.RData diff --git a/tests/testthat/saved_objects/grid_static_res.RData b/tests/testthat/saved_objects/grid_static_res.RData new file mode 100644 index 0000000000000000000000000000000000000000..00db0adc3d26df24e94958bf62b86b34cfaf4f91 GIT binary patch literal 21283 zcmeFZbyQqU_a=%23j|0=AS5`!r2`$@f+U3C4#9#o!QC1U1eXMB8fg*;?(UM{+PJ&B zH_(ku=l$OIn|s%t-?!%8xqr+b!#bHMvWYJ}%QPH?=QoFIGJcQddoW)nIaCwKxAX%D^;+sjMM)IJeAH+a@&p2^&Mk zN&1(xQ=RGA`GyXO9{ck+meoCxtLDT0y?!hpywTvpS-$N^Ul1L>&+pepZ?~TR_IngO z-%ypm;7><%_VMl8r=*=P`NC-gH7K8v$bT4pL$@^+)bsphp7?bMgXC5dE`Mfr$QbS<8jHg?G44yd;20roB-OjX)%_nr;&25t(M4eqrc_37!^a9{Ul z(BXj}tcq9=l%%gTvq7{c&PPR??(x~X#j4ZZx_S_Ud4A9)uYC0x@)tv9pLm8)Y0skA zyv;|JkGs#s4=;tJPi~sLGz*9av9u^~YkGUm^JxZBSg=pY>o^|FdHc&=33K`S+)`@bH{0C`cjIWFEK{Zfgk}BhQD=u(i`N81 zPh<~4MD>0#OBk|?G0j1Gk{g!BsI3L*&?k?*+~VD}!O8v& zX;UZ}sugUr9yt_e*Xp*u@`ct=2=j(72I3?9 zr2B>GIQ@1!b}SB)>1HRpjRvh*4x+W=hQy+NZlZSuqp#^Ad=L4IEzOrc+LP2C&cQ?^84jbfdf` zrh-v7?Jf9IjEt=MxgF$Y} z+XnwpaSM}=D@LuqDyCd(- zh*s;jq=^YpJf*G|DQIiQ{O)wpJl-ZfiP@6)99Ki{nS!rcr6}y-3eH~r__pZPh|X8t#uzQZr?Sb zUfXMR2`ay_Uh*_Sb=Yn$tei8?lpIK;Tx znFD0f{@y#k;zxZRw*s~-7E7f^{q;x=lig~fF;bK>ebZu3MRK2=85`Jo3g^c2boI1o zseepdtZXPhR$Mw3r~?#tJYITKIN5g$ez0Ub$8K43?D%n_=R(Czk{l@m??7}O{%958 zIvVS(<_a*lk{E0sH&OZu(bwA5T!g|Mn1wCbJY(xKmfr!41) zFyml6e={yFAb|4?hZ}axZEArPqsmngvU7-cp29Lw%(_Te7^9SKHSf;oz$mqlO-+L1 z+xIyctRas5nWj^@9=ZDBBai*}`S6yw9+D@{p*{)4*bU2sb2h=30rx}pirECXu&Q&C zE4?>K{BK|A>E+BE`AB%pd#-c|E;+e3_MHSi_lIv-JjCnl4Jh;esyiAk)=jk;fx4ni z!Q5=Z6~ldShKn2b+~w2b4a`07!9l7LBcWLQM6^o#|2aRq@>yvil#!hE8kO zgXYbC1q_^e!Naf;A#frGJ^rUjM$c@ke3bP*Zs@iZ4{g43xb?FA!Y;1cI^TUURY!1t z$*H#N=1_Yy;3Anq^K-*2X2u3W2-p30z!zgkQo{uZ19`9zvYEb(xo5X9*e`E{k?O4` z;RZgV>E?G8p9EbRFQu~kHJJ}QqdWCRF>n6@ePlRntZeC0pu=-^(w}_T%FncpV(?@* zDxz@WJo3Or8on)V6a@3;YBsr#=ExsnK5Qsg4aNfTW_%alIaD+d9b#vwfa{Fi2$xE2LBhl3mj1oOsW|#NUw%>Gy@Q3dXP-%iP-eu6a%@Z!Vh&Kr(9hO7rjsRVP(4)A1<(&M{6XS z_)9Rhnq2eLJ;tcV@bv_M-zNx{s2=-T8o=KzdB~S+pJ#^jY{EfBe1{%nIvNM1`_mh~ ztvfPtK!WH9|ESZEtSc681|T*k{HFF66FR)++qCb{>~fr(;?gUE`P4x9c6GW*v-O85 z!nCabfXjThw`Cl!POVd%JNxF~?xDw*;=W5eDZP{R(&=Hv9VIN{POqj-s#8oD?#&Jf zel>13r9~oM_bvu>J3-Ul+_?3Hzz%G#kmIFLol$fDCS&fw=#K8|B`dmu5|&*J2u4ua zZKlB~F$VS|NyHtNh5sqXO`(LdnEz%Pm&irrG(jqu<^tI87~|ShJAIL-6+>hDXQ~KU zP#m&H+N-1Z9D9&HVlX&)8YAU=c|I@Jn8R3gTzpdNKzXduS5^3wf8z@i^b-WPZZOK5|@9wN) zo(jm;$29VhYv?rCPO6RI=(Gsw^4ZwEba*P3|EoRz@yAb9KZ9=?2U@q6jmSP2p5nBR zW)ontjY_tL#cdWu?&0q-JcB;1?#HWcXm}#Se}(~`4j7%SLSl~z@b~jaWj5=zgTo@M~!nS;(%ImbN&U8?Ymf7fcwVnYD|k4&eC(Wp+gg!* zbB3*s!UV3yI~PUovz&rluDxV-6hFS}KwXpXlAOUU#!nv{5MDP0@tRFlY3@ILC4vm=s|C`HO!klFDR$F~eUGPC z>wnTLngH^;pw(bkYT219^_3C??s29`{L3np28*Z9#Xa7M7JT>B@pz%oPrqb49lBB} z^H7NMQC6r%=fe)a(;V}3%6Txm*Ydabm1?9EC85fprj|TJQ7Y{nW%|5Z$)qXWxdq)x zlX*feO>ph#0#S(mEF3r8P+UanW;r&Z3Z5gIZ>g~ZPt&+P+BROK5V?^<(1aso^(0(x zY#b6e0Px)zT5oOLN%`5^Z>TOZ@dl|rOOb=D1HUrgumpKNdjcOry#}=^ZQTJD@AWJz zi66d}B1)In4@K~5x%?O{omYVv(HmQBW@q+!@@gevdiIzC!nmr)zv4j+;#n5co zT_CFW9wirrTa(Ou|0g@46+iVJye{Uorif#f(Q|Kmw^!~|hz#9JWTlJ`uj%2vmA7Ar zcnzxopimPA*CNzNB+mhAt>V|9HeOMaf_RDpXl?Z2EJoQ}UdHIOp@vdN$hM=aem7wn zxyYe|0-by6q1c-2&J(ECaY)zmYb`Yn@;8dkY2WD9A<2DfuY zzbrKi?rle*T7e;XQQoD~>gQw8w+3Dsi@vdqdVckuIc(sykWD_>uiSQHUFT>@?Top}p*aHq8Tee8|$iy{3wZhhtagVi20}Jz0bFCteMu-?)&h zD~-PIsu>fiR<{m4X-|4=1+vqQ3}(W?qUJlbJLFN_c#MJkuOicA&DVrQB=+ZmuJvc> zKc5vU8z?q!*H#WIo&1RD`NnRW6IY_l_fm%p^sdQ;FiatTI1cP-HM;+(ur7QW}ugcnYTS$1) z^je=UVN}Yz=-YL^5)&Zf(AWC$_OmL*37eDEqN4ekxvkghoHNj870zN+*5h+;5s`k1 z6V~dkx3xKwxw|d(uV7=Dv```E!@XjPs9Z7t^-fW4`djfvjZBLtv!uLz)p|EzJUlgf zYrjSsCNJgr8_}BW@HZAcF-6?Zp2k4m8ay8waU!Yv*1I!*b@)YYw0kVs0Pmm_73U3{ zu!8N~itfxLbmQeUV7gjL9$uX9cd1*FShw&p7ONf7e2$Q0PPTO_O11>fY^6}5!AI}w)+v2CMd)6`QB2M9yR93!M_ z{dpscbCh?}g8m>&L+!olUKe{Aao^f*#;r4!9oxN}>hI}fu86MA<6XCLdVA{B1}Fbx z6Q`K@Lv0DOnCz46$pw%7%FkdM)ZW3tg{Q`b5m1EcgL4G9;BLjd;`h^&U)3l}T)jhe zoRDMzDxFRKI%C78nZAC5o(2l_P5wzExilK*aqGwi8fbOp{Pod#PPdopSbXJJ$XeKi zq=ob>)(OMqrf`BpRO5}4bDOzOMt4mG?({Yn@%Q3!ope6u7%`*@{CnF*T-{g!|HUk0MtvMi*hP~KFdHE2w4GC-X zvtv80lA4O6|T+eu(=V9LAY9;e9Sv7F5m zexs!NR zFRq1v#^DZB(&%sbv8Hu!%iYUY(T#lI=Cqs>CRd=##FrUr@vjysH`GTSAR=VG^Ou%K zxJhv(n^EFk)4$S$Cyc?Dk%}U@DFVdGirdDD3;Mj`FA-q-6OfzYC?hCB?#)V7?Jo=O z+~?y_fj0Nqzt(ZoWItA*RxwVX17ycU^V$*OsI)kCNA764*5e*cAZZl zNBk=wQAHJVtbm>C=Gjx_@BBHcKWOdEV{1OM)X8cKziU3cZarKN%^X{$xzXd=sl3-+ zZ!_BxSufT6pqGxED>|ci+~%R<&pv_^VW>4g50Tht2Tg0Rd8fDo9i}}^Z+R-mHPvJr zKkH82lj7#smMD7nT8vt_GiL>0o9DGSdB3rUC|g|I1$hg}Yc_kE215qI6f+hUnm>)4 zy~czpCr3YZwxB?0Q*fl)9^7;7@|yc{%jVPb9LLmlO|!oT3Az5TuL+}DY?>M2WGb~N zpEK#-9xzOgL(Fx$qlETexUOgY_IVvmuluof=ajYypc+H|rGxTtN2&7}QEn6aY-<0` zH?g?->WF&s#QLn8!J@T@G&rizmr^S2mg+jAxAn!z^azK~etuDQd6e(;_2_4Av)jr< z&CMJEI-@sz^C>=u@3MP*!=iVZKQ|i4-O5(!lI7w#-#$H?(5yS$;xIU3K30^l zo6{)l5UsFy#cjMDBoT1?nSdG3$4ku;Qk)K49Q7C0Z!k*lOjE|V0mn&$MeAij^Uq*= zx}Rj%lVXysllPSk#YcC$jy2uYNRoXl#yoVnPCBE9zFsw)cEjfrMQC{IrHX3oCFcsj z$=(-(F6CtlPA7+91qb>~pJbS04rw5uWXZHwmON+G(`3BX&4w4%yB2W}+GMDmQF(~> zjltlW_Jn)4EHY$Ig7YGS=AwVFMd|_LqMO8}v)vo%6V=i5=V`O^q3M;q_+Qp6!Q^N~Hjn=`o)KGio~gS7&ULfcgEC64_V)h zXC-z1Q({bO@XpL-chjxn`!UJtEDOT2v!d65U{Fh|@ATA$#^8dpX1{yXJ7y)81!~Vb zR!tArr6bKgBlS9nLTAcY!CNt1C$L9FHl$~+0Pp;QMfjH^g>HpyJ5l-f$+>fmM-p-H zA_X!Z;j38BX%fBdsG3YAEvLchM-CFY%zpE0SNGg`f!Wo_>08t8nBy|8TsMR67$5CH z1-In4V%sB^y(w0YT|Z{7E?iNZt11&CY>(@m&3DFsUxf2W=X|yIThPm~=ukOv9XmKG zW+UrvoQhO*j@61IVHXv@1kcOznp?E?MQ@hpil{3!Us;;rLoIhb`DP1n6WnGiZ}U1z zx@&Sm*4LV*Wo{o{r-_2Do}K(Gv#)5P5Kze@k4VNnx0ji(?s?A-dzh|3D)v@+q1ykw z?n@MEClj8xXO8M^vfEvTd)ZY1eaiD1Ro$<(MUtrupgIjgb0fO585UA4%DGu%8Dp9(NJ*t!5pJe zhxv}iFWRPSn2$2~?OBE9{!`PPw<~Q3`qSiZB=!0pQsPDLni^8)Tfs+qJ5^PR=fMR? zv)fj#3T>tNw?)>D!F$5xVo-{N{dhTpjFZ74LVb|~jD*AZtCfYD4`Z8RHOeKh>&V`P zxW^h_IKSIziaXjj{h~hEYfNA%DYBPZZzggKz0AU{Gns{xU-{X~XAe|f7j8Y3ZBiC7 zQ0X#$;9BZ@m2)%O^i#>sdJDzd5er7BzwMGPpYD00&)m`27_XGYwLlwNCLD78Qp%Xe zaWzJx-lS!<%d=-J;X~##lINDn=FfuoXgQU?J24oV0cdNYz}Leq#zj69Jr->X{pBV0 z%7$)7P`C4~yWFl-_0H7f#^9Mmq3<`p_O0{qlxz4aO0HOtxn&pG7Yh>V+Op|ei>H&B zJu(sg9|J|I%|IzPDIV*D zY+ZXr)4L^U>%CWReH{N}Ey8V}n%%9L(P$#pXg)bb>E>21qK%}>&El?%=B8=!GiwI! z8z8D);cF}&ZOORI*hyutIy2>qlYBmVMpE(U#$;=?yG_kPEh-SZ=(XXlyWqA#Sg zp|hdiquZmWqNAcurAwvPr_-mOqno1_r4yxZq+^%9e6101^d>)dviu8Mrc} zGK%<9k7aB_g-KoMcO=I`K4A=#W;~QJ4P_=>9Bz@3#0bqM9iU5=uJr$eGyE*$fs9_L z8|glMbI2CP@WTu;84LXSwEEXBU$$_Eu`?)S>_f##C8W**w@4mh@nA?{@{lq-W*{;l zZT}cbPr6LnM#n(6g_FS=`YH5j=rU;;sSCVQ`o-&^0>QJLfp?**q?z=cuOq)a#p9td z!IF8@E)yz88b_b~TH#9)?y*GZHtEp=df(4U1U!T$H0|D@IHZL1C?lyXJ!`00s3~a|z0&K{AVHjCfp*H!3evmRse!c^ zjt^HJwVQ`>kg}0#(-%wXhtv`{60Y#KQ-?N?=8;~|9Y~A%d))hmd;FAvdWE1J7)lhn zNeZAdlxqC!f&Go(n4E!-;W+~y1H}q;yH}`pCT|bGU_SHU0MBDSkdy7R1jWkd_jJ52b8t>LK^{coE6AKD7} z{>#FVZ4yyb9rLbg;LR*}w|@WqC&NOqV);p1YHz2!8M&SPclxLf6vtSzikHcLcvYLG z(kB?4#>mj7sbh!CDn=eKd8)6iJ3Xlxb8i;Xoaa+4zXRSz-Haf_MqGW_3c%JPhwpBD z@ta(1?ZsQ#XO9UUta`M^-sy z;P=Cb>`b4kok+@03;^4Z)G_r^6~Efvu<@=Oqe7p&o8{5AW`G-e+>Y4e-I!|M9TdS5 zyS5>0vP$BzxV#ureZz=|dFJi*C2`bkPJaH*r5U3bBCJJolxr(^_4HQxI9sr6c$FC(PbOIYB;|KZFH=$xL!s|ex7U%J- zX{P7NOPkR3haLJAY91i=Xedn^5cshcWCMc=clCen092TJm^)DQQZcPTG*_1(@2U~7BK)o^@0h4 zpsFhivg=t~P`J07FZ=ny`^7QwNha6-Z_oS!g+M{IPWtP0YcsxBmuDx_4|hl)`h`B? zVrq(EYJT-UPePPQu9~Ov6!I@r3MFPxdAltB1^S+zhLg8T4ZZb-Gv_g55>`jkPd+Hk zIs#np&<`*R_47UDw@znf67rjRt;Cl(0Gd|>2>DsZ-# zM}4&>P)Eo9spEc9cqH{`!^-4X)B6uaqvE$|H zN^+g`Qc^-EU^U$Mt#kjY4xZHrw|>Q-l_(JL6eK3U3{B|d8EpqV*8)*h%=`y5 z{DqbO1Bw5)kRa>hk)Gpio-+4#?5n*rrwKZ`L@#^)=g?T5{!h)6Db~!17R>xG^hsw2 z@cC=}7-QyFzLYCzmMf{l-oVEtM8^X^SCWSv`+|-J-mfMPivsgjAm}CIAoPVY+d+kM zBBRlmi#LCCecVS{68WS};bjX^2d^|0@G+doaX>`@$XyK8;29v@dmbQc{AKiib$?jJjjBTU|3KmYZ+0MS<57<>4qky+u0V$! z`zx1|JxPCifL?V)Zb0&!`zpgs(UgGR_dBV)$;#PmzPgrWeYm8*J=usag$EV-{gPN_`aP>mHUE!l-3hS8N5!Y4Rbp3p{Sa91zh;P~L{VKp1OsBzQ z-ywl4d9$JmLZN40h6~$?8cpp?E)@rk~Ztpuhw z7`ca!2$AQW5KpJc%a+NLFi=Cb<%IYc?P)NNd$CT?+TM&I$XYdv8%0a3{f-RG4FI-R zvOBbVmwWfQa`tN>^>-a8CN1vqMy4}Q+x_?BhUR?fM+uPpn;=xyzTony>|P^Ng8t6= z)x<^C?ZS>Q31JmLqojIOOIpG-nsOt__`fQS9sBD^Wx@nOJEA~gn69Nh(7+SKir)LC z*=)hOq{pt;ygZ`7*N>giWNwTG0A;vAc9?Z%v~f1!qyj!%f$R@b(8#$I1Z8yq<9MT? z{N6y%qrX|+HYh;T+yG6 zR5c;5A6bVSHtXEEAR^#2lT3(9axXct!OHQ1UBQtB+I}Eod%`L^oN4l$tThJ$k4BrE zYbN`r+uy9-$D>A>5+uCAQx_dd=4wqLCO5+q$_5gc`s=-Yr}gJ}i<%RNk!ru6x2l2g z;vuJ*Xs^60qe3H-b+rLKsr1Q-VvT)Gty2Oc&%7DsT%(z2GI785K|QseEV~waAETYa zqT@2uP!qT4q}x$PI&n6@Wj`q~6CFeEIuND`+)Ug{O=oCor!LvQp5KisrCzTMA>K4Oe)-8Km%jo(*nBB(RMzxxq$ybA6O;|R75Mo zWPjigRaarY%r!6CB+x(Z>kT*Rd@`ya_7^f~;E{}pP<)uK&woZiKk#3Kpok^}&|id5 z{0||V{!Iv@|MP^v{J%yBqW{|v!hekdG&~5<))zTEk|Pl+^g{@SUYpE1kckIqG1fFY z%qW|!Sl2?z!v^?xQX$Pbn`RbWYJE@uCZo^M`!fj?>YhC)MAnN22~bfK4UUTOpbZ_6 z)JhWCNDxM|JUnuMCv)|W(Rg`j?xFy6jiwB@Mss}`(wrpJ#1LAY%4@p<&2#Rb;u%1j zl?twF5X*22wCf{f@@HguT`$po534U!B^o+*&Fe-4Og7T`K!xr`H}ZvO1#Xf>uqWt0 z6#udnQ_${1|6lHd{y*-+#^3Hk_W!*5p!mP$K6w6b<39XHE*(v@$fg-ZTWvu{{aaIi zEH#tWKPyot1j;(@3+e=LL>VzB>IJVrEmt7N9ek^3I|99_{|G<=`D|pgb)roCS`r#j z3JRR)Wr8L>1%;xeCHgPFH7TzPs2*b;{6{-@M;~`Z#+aUSnLxwVQ;&}a#!Qpxi=mHs z2GA~R@=9`9h+-I}S|!@m~L6uKr{|g%fCt1UY^O&4o! zoB~ITvy9O|42w7Gip$GO3TO!U*?iQm^dV!25yVy2uGi1qYc(yzgxkV5)D0|47-Kfy79@SwHvl|Qcj%fNxV==Qc?n-5ONU{NaxYFyGuo-K8MX)s5XCa#_q3=|7 zjy!wE$MpVYJGPfrTx{>kB!@R|LAvbr({4_2I!3Y6`nspVRp24}F4%HbLhUa1mxcBx zA=|E|u^Yeypv)<6gX;&}+FCpRoV@@URMM!i&oTzE?IK8*FxlkFTT`o9tZ4=yF0>{+ zbpUnJ>F;}G4MwU#CR)R73?aI9ZH=X zvrXTBaMoIgeCj9!&l-cHLEo-R4@(hG;22`xZmeuiMPL%?&*e$+{_z z%&?BGXrY#s_vS3=YXY@?w*{~yb&C>AdU5Gj-9@X+m230^j0HV7IFl~P!&!@)$RS4@ zrTTkaOU$mq#lNMgIf;J*e9$i*{Z-F|EO$wFjJdM_Uppoc$4sEOnMc!UkR7KpVkg_B zl|+Hxg3%w@AZE94*HBP#;VUQWRxDEfo$%oJ&L$?uofkP?9VUVFXmN}j4`eq(-BoMt zELT7HYaHpYLM&o;0!E+}rTB-f;dF19IMcOjiB@fw{NeEzH0_L$ws8p7t=?QSRMI9-`o$~O%dID&?djHA z4WDS!jPA2{*`X3H`X=<`oooGzk*;QVBBNL?m3H{v_s!wFH(Qm=+zmE2tZ;6)()9T> zxVE=Uy^|O?v2Du(>QBn@1Aea|7@qyS#U*~GMFX}bZsH1A2$znr2d6}#v?wYSzbpt# z*;D+e2^pG|*eaqv<0l69y`?!`7c{C=%y?Fj^#iA3;5$o20$u7f`Ae!RrkRoqPc6>% zy*u!I{M7LGO^)o$OyNoa%ru#!$-~=y`J*wzY+e0qo%y3dQ1t-KoKxPMlMHot&72M1 zoE4`utgCU$f~_%CmwHxVvBznsp45pv;V)!q`8}!OVM=8(IoiIi?_W5xXYRzmap|QO z_W3GgpyC=%=Ukt@^Gd?y1Faok&d_|yP>OA5PhRhSMYV>*kBh8~nfL4IDqi)dfLZxe z+V!d?8Q6@*S%my_+Kid1nPh`GE@vAr`ev({dR7qi-l$^Elb>PWo7=8#A$u#{hZ$*4xA3(+r+RS~{`K-U3++N$ebi7aGZ}tF z)0hx_9BaJ>W}-@XZ`tWy{GpIr`1MlnDc3+bB6G9u%wbAc^%E43WxiE)jB&Df(VjDDHFn0IyTdj`&H0Ek%~M+wkc-Kz$6%;;Jhi-GOHG zW%*h}#^X^I$src8@9H#LqtsjK=z~~AMjt_TUyH1Rg>)zfcZlWQ(4JrNxH9n4azlJz z2F?;beg3Kd1{xmi_e|!p?<$=g*WDX<8ti#t@>cL%{-=>gk9NdkQo$z)iE&wDe)9Pr zPTpWTtNQCdt|iBTnd7Ct2{2d1(0xoAPcW2szrW{+2N}+s8J1~AYh1p6EGy}Y`%~Tb zOk@HmG%+cl{voVif3Ux#C-XRx_m^b$ry~<2#aUS;Dh$C|;=$a~2-sA4Eih+T+tgdy zG_>`&{+_m$yq5{WX?wZP+ImxOoUjHW=ylh0{#(BJ&+42T#U|vKGyPdHj`Z@AsI_fIIPj?q!%Gn5{SCi~)<*QRPTc|Mb5 zb?UA-defAqOQT~m%hp-p&G7SxeTgff^H>(h;+|8tMDQCdPNIhPxh4VWECD((i&4~M zj>d&*{)c*Vu@H0+=sdBF2>L#5y}@FES?((#H<(Yl0f}39FAv+Xc@IQfCWV;$HQtjW zy70hz_a1hH+>YX%kFtDvKo?FjNx~9NG8{u6P6E#%>CYi)$ssAsA%Vfsmp%w)u+_IgP}j?A{bl3oCQ*QSn*{BAo-5H))IC9d^+v43g20gAbtzea~|xERp(6Syh-wiaU-~D?;dXksjWtKu;pM`v*k%&R z(W@w z$!e;rM+HWcOs|_8b?zLz!cIwQAVVh}JrsSVM18mN!QxgWR_#OcxOp8eg+l_?|-JQU7DJf z;pBZWjg|rL^|}M+^|~{sX<7NgEq}9iH%UBhMxpu`wKJACXDmt@#OvS0<7L^vumY;` zzQh6@K?TDqjRE$UgNhr|NxYtE)VI{kg?0#&5jH4w%V8g+!NmKtT;ptt0QpZ=|Rxs|D$S+{y>Oy%FF8?MqVim?C5Mf`WZU8w+JA^!y#5_y|pH(Mmy{dca}P2U9UU%6dGdqx5Z zFOxrFoi*ye^%da47ksK8#ji}HYJ0=eXFp>weaU<@ea*Sjsw3nu^Ndefq8uAqwXV<` zJms=UzrUi)UeltSiqK zdl}pt_xT`3h_C%4R|SYdr4e zG!8zcWNh{~h`V3eWrU>!?3XXImdQUFSR!c2+>vqV99Q5&T^G5k1cDk0yAoa-fB|Hq zo%`D{*B1ix?~c*R=_)rS>IVBq37ZWLUJ2Zr^}W_!=-vE>-LC9=dPmD2B^pyECMfG7 zKREsVBUX)T5x%w~Zat7DGmGWYg^@zF5pB4ea@b?Kb zGVoKyXA>s{qNq4p^li>mC}y)qZzi?j$J53+-s`p3%koH=X;<@`!YA#?po(w0g;r-Q zD&x+gD2@FrlP-tSvgtkBpCs$5Le*l`i+fl4JbraB)2u%j6BhNr!3R?&i650dlcAI0 z%J9g_5t6|RrKLl?RzL>`lwp|AqvHXr>4~LNzX;+v5`2!P@TOiNZpRK)K1zD6!*wP)6@!o12DzD96(SskdoCQoyF_q-q^ZD3xz1j)NpY+7(R7P_ z-3b)3%D7L!8yu5YQ0$O%LtLdtHdG)2-Ng-S71aR=42Vxfua2=!^ejY z^8|W+&jOOqZJr0s64q$zR#W_P3^RC7Rv*M%**LU`yne_*v5U9pY|^)S9@{zCQqy!4 z3;2Vr8;IGur7poATI7sQbB{0)OhiMyq7uu{)gTCsJlP%A`Zcp!%IQL1Q*$|rW0qMvB z^PUH>$UMOZPuJke07Lmn)96vsGLn%&-z`3SlAhALNnaBgUnnGGb zZ%7{F1LX=53nFQECmo>wZa0mAFSy>#K>w&z`Lhpuvh5vVY1!xq_$M2b3FyPS zXq2Z#dD(b+JnA(c{qKy#e=-mM$}}{r!6uH%>32>P`Cfbe@2tTEYeNl!13Nsk6ybDh z;Pp#~_p_uQvyDRjNy_^>6|RK+K*Tub?$cx=b}KT$cOt!xrga?|wkB>-C-_4l=2Kfvm8pS$3^TMo z!V;bTrH?r#XlPCQdGxsWLb;&4e%!`6Hg!WM`s=l41U}IPsZ&={yMb!sBP)r!H5DwI zzPf5=C#;~S+ORYRpFO9&EREt5R`aW0n$i0dUOlG;Od2$PQ*P7pDY^4g@{m0yxyrL1 zJNxt4EUU2is(azYOVSsrFdsS|_L33!htF@=Vx74>8E$MEyb%`bVF3B;SL-85lrd*t z?Ffg7SG+=%NX6(-lB{$LNfuk!?gCPKK~p$ocq{nrIOsSdd-`&EC%OemvY}uF;$^I5 z;$?zAFpYywK^B8CIY+%Y*yVmtX1&dzdLDR> z7&fp#Oba3|BwuS#EEN38nR>coe_~04lp8+rcpFOb6<~KjR({M-YMA6v(KYg8ONO!wIaEGoyP6ng7D`FHB#-BAWF&>QXj;v={P^>Di=}k$NIX{o9)_vu~&DeB(lt;{+A@ypd~T(!5`ZC zyQWP(`!_^kI9*mHKb)Y~`L5t;238+I!YPt|jJ8=LS7I+qyKecXB^_3)|}1KNOU@yA|7S?{7xCgN-jqKS12>g{8hV(dkC7)r0k z9K5|(2%hMXC7=oH^j-8p#rivd-rzc(UOFeLX)-7)p=BhnH*@pbqCP_EV)~rY3$2ps zjQD!^Uih;3wCEr{38^4SBKmOn?z0Ez;5yuP&d@ic1$4fFQ-o!-E3EBup#`KhbO(}i zAs#ZMyn-9%%%mXF1p55f_at9^rlZF|Yiqz1%P(>C%pbDRIk2;GvB<}+i`|r)_1bJ6 z>o@1io^JHCX8NR&w}{^nvENhI(vM(kEsQ(-vG942WgHI(5D|yyXFl zl-fERw?#=(`ztR0^1&oA#L(N-J!bY)GJ6|$g{W>3$Kli-+h@4Ad)G|GFH$czFZb`v z(BAyMDJ>voZmHXBan?`5Tt_o<#~D|wuOW&%;59JWN633h?@#LZk5lYhq$(u_7bB`Y2Q!d%`!B-yB!~SsU9s)0x_)i zJ(v7#)4&R!(nQAeGWreuaM!;r-7njb_SWU)`%)U{5bO|;dmnR?A_EgGX4Ld6^jo#C zRXXO^3IUe{CIszH=rGE2Nvh9+n8zgT9HAul=to0xF)$H*jdWP_R#LBmJ`oHPX8?n+ z7|0oDu3k*BG@7w9;M`Nf$yzs)D{sun5A<9tNj{!UE&}>{M$9GP+KIQSIIih8*<$+# z7TsOTf2q)L{I&0-^mOy50uD?<1a>!WNmpuMSGgHig6Y}UZl%j~THjhGTf}yA{z}W1 zF#qXfg-_`<<&mSE)4JRt=h8%5L-u?TV=I$R31k)V%q$?nqOorZ+8TxLnc^n;*h7#t zBbkW`HyDaX)+j!BPs{RfXONFEV0|5kJ(u_Zmps_OO%1V zZL5hjtY>|Gp|#2fo1(N!^@;3)u#QCj(YS_Ys>|QWpPlZ2 z>p`d=`;VxNJjMNjP`|XJ;k3<8Qa7#pFZyH3?a<$9_#d^q6W8_pQ2y&LL;YVhXid0| z%_|v?uc~+!g<@ZiJr(QX?y3vw`Jw#D^T)*()Ib*e=PZ;<(@lTX?1xhi5+=>|!AWL) z+S5%4wkZganf5I^Bt)ce$$CE4jDxUa=#GhEdiX*cf{mV;Kh>S4<#77^;Pi9{yu;e}_f|(k-36 zjtqE8hz{*FC$*;Im$V6Uhh3nEgY^nRBp zm)VQ^n0^$S7y9QZQG8+?Q_l&^H_W_V8^(w5@Z$BF45P~Adapu%S&!VMqfkLYj?cLm zVl`Os1jkNcU(aR@cmZ>lGHX!*|NY%3IZ?_+M01$lI|qBQ%PoZeym;i}@OM{9)2rsz zw!GpPrvb60%f6wisC{kBCSB@P(I-U#n_nIP5(mm~5_mTRk&{;U_XNfBAC7lE5-ujqBhB#Qt=8y zk0TDFq564`a@#=h3!*f9vutgxri3q;n_u5pNDtWf*DU8fF=U~@j>rluS@he#*T}6f z06SBmt!?+6`>JmF>gfK_-Ei6Rv!#bZUDLboeMl==Jud*xk9s&eBF3Y4+Z;uf-C`@# zcnP8?7Gp^lnOwrcOsB zm>60U-K}~ij5bD-xTlLWlxTr&uzDUXirc1yuF_lY^Ou)PRniDGOZ=!9^m-e{DxwCX zjB$8WXhcF>c%n)g55;jRXB7jL=$(@f3Xf7mgpXFTUSL!+)8PpUIFO3o2K0P!hWn*g ze|L0#Bu*Kxde_-^zH%YaBhD#kGwJQ;sCQ9>jdUFay7+mEdJs$ZFV1%WaO6u}|@q1%YO1pjeBXE3dLebZS)u1H`$(3;AM=Ii#rO1rG z{4`dI_9#V2Ed6~jDOp`r0kcp=oHAsDlKx9{oZ72Sccm}WmA^7wY0v0zWxCRx>1H}_ z$mHqn^I+~(VD8D8yfKqEVailtx|gQan=-o8ZB*1?gU(lC@)k_qQh+^k#-5d$JsYOH z9h1`c==~}VOx}^vq2ZajOr7d6`T9)SfbpA_HB|d| zBSvQ(MrUI+oxzOXB$EQBEPZ@}3!}FgbFV2;{2tJIg+xpls`py2Np+&+QA$f=OZCmdV>Pc{}92A&*l=Jn{-9<<6}6+fIz1rN~uwF_4tKI_cv)h5MzpPPzm}t;X%T0OYW}5x5=JBJ{_e8>W zknDXhCxpEZ6^mYk&5)f^TA z8`WHWK4p(EORhGJV7Dn<+KQvJ?8lO}-Ptd?HNpJ?!pl|D3#4wykgh{5mU0^n%4xYR zkK9hPa}JtD0hiOXUVB1V2brnOg6#frD5=An?Ym=1xev>RyQYR#yI+N^*NLaioO$Ff zn%mSx+ctF-*rtZ1HKrTE@%o0A)KZzH)t7I6LqGI#c;&}#9S;sij3PD7WG+RsW2`bV zIuZUBQ~b`rk7h!oGKxKg`IYt_XsUsyz;-odeg}>SkBeui@G7aoAE{7H#Bh#eYg5uQ zYMf$_l3nSqnyhk3?M9_Fv3kW+b9~pf9XfyCwpDLNj(*P~SmlhncWoKiv1x~vT}vsb zspY)Y9Ha9-MCpC2*QgOkn;M3}K9A)P8V`gY!jRbL5pkv1hgY@IdRE5#tdz~vft~@? zf9JPR87cljSH}D-h006xySPd(vTsI|{);O5MHBrp(pb$uBgU`d&MN*HC7UTHpk7w$ z<)x}uHlrWuGh_7Waln93{cQ?eV%yP5y&W~w*S3uM(N?N{G-UN-1!48FQ!g)NKN@}8 zek`hojQObo{q2iRjfJ&?YMdHN*bY+ks|l-L&4ks*TD`oK{c8Gc`_)?P_>{8$WXw-g zv|f2}-VNm|3iHcdy}Z=#l?J;WWntHX5c*3T@=#8ceDl4SH=~N0#|Dh2m5TFTg^bti zU*1qHy7f3YIQ;*+J^Ce2xAo8LnE5*iEe83G-PyH5ntX6 zb(_{|bu?%7l=_86mp%h+>n-3ds-j+hso!1`Ry#IkwVnEGh}w=RtD5EQnABFyKNFUJ zQniP&o-{`W<8nfa_L%DWZk{ZQVuIPZ`09>Ur?K)w7o{95?^f3oXd7ItZU z?o8?>%#XlAwek}F^iW;kPcMFDVISEwX6!O!NA->JB#M{LkPS2+RW8mO6{`7$d@^Qy z;hexD4Lz& zmlyB7`Iqgzv1RNC`TCajH&xe2#V{qix72odasCNhs>xCf?9R6;5#&}IH*JAT+pNe=AtvXbRBZt}=sp4GJUD01hH*v%jR*EZ|8 zu>HcDay0t!U)hx7%5Im6CCj_9%Col`cxd_oMdPj-Pt=o@N?P<{YotArc-Ks2cC9T- zmj7x4hE++q#tj&Bc^!Ace6>--MuR?DUQRc^__F=L8(m83b=BN{U+s@@D_Op(ruUjC z`z=O$2Wf5dgeRq+D(jQI(NLC&Y(FM=Il3&#E7U#yZ0zHclBI z5*{@unou2?rHB5MudYI#I4C+IEF?6MV1D5L5?bM_UjT~b7A*OJpXqBkORtAAY+zXZ zdIRf+HLNwTc39nk_3PGDG^k&9V1qgeMZJcD8nSj@pp%~ri^$YWMwZC@qe84QMydF6 z$lAbIrD7P$8N@_Kqa&wG2ZcusR>sD}hDXH{Uw&yqUOChZs!rF}BQ!QTF0MNKl_@+- h@#Q?6ua5rGSHz>EbC`p*iggy@{{g0b_LvH>0{|V`G~@sP literal 0 HcmV?d00001 diff --git a/tests/testthat/test-survival-tune-grid.R b/tests/testthat/test-survival-tune-grid.R index 6fbddace..78284673 100644 --- a/tests/testthat/test-survival-tune-grid.R +++ b/tests/testthat/test-survival-tune-grid.R @@ -9,52 +9,76 @@ skip_if_not_installed("censored", minimum_version = "0.2.0.9000") skip_if_not_installed("tune", minimum_version = "1.1.1.9001") skip_if_not_installed("yardstick", minimum_version = "1.2.0.9001") -test_that("grid tuning survival models with static metric", { +test_that("grid tuning with static metric", { skip_if_not_installed("prodlim") skip_if_not_installed("coin") # required for partykit engine - stc_mtrc <- metric_set(concordance_survival) - - # standard setup start - set.seed(1) - sim_dat <- prodlim::SimSurv(500) %>% - mutate(event_time = Surv(time, event)) %>% - select(event_time, X1, X2) - - set.seed(2) - split <- initial_split(sim_dat) - sim_tr <- training(split) - sim_te <- testing(split) - sim_rs <- vfold_cv(sim_tr) - - time_points <- c(10, 1, 5, 15) + if (is_object_available(grid_static_res)) { + grid_static_res <- return_object(grid_static_res) + } else { + stc_mtrc <- metric_set(concordance_survival) + + # standard setup start + set.seed(1) + sim_dat <- prodlim::SimSurv(500) %>% + mutate(event_time = Surv(time, event)) %>% + select(event_time, X1, X2) + + set.seed(2) + split <- initial_split(sim_dat) + sim_tr <- training(split) + sim_te <- testing(split) + sim_rs <- vfold_cv(sim_tr) + + time_points <- c(10, 1, 5, 15) + + mod_spec <- + decision_tree(tree_depth = tune(), min_n = 4) %>% + set_engine("partykit") %>% + set_mode("censored regression") + + grid <- tibble(tree_depth = c(1, 2, 10)) + + gctrl <- control_grid(save_pred = TRUE) + # standard setup end + + set.seed(2193) + grid_static_res <- + mod_spec %>% + tune_grid( + event_time ~ X1 + X2, + resamples = sim_rs, + grid = grid, + metrics = stc_mtrc, + control = gctrl + ) + save_object(grid_static_res) + } + + expect_s3_class(grid_static_res, "tune_results") +}) - mod_spec <- - decision_tree(tree_depth = tune(), min_n = 4) %>% - set_engine("partykit") %>% - set_mode("censored regression") - grid <- tibble(tree_depth = c(1, 2, 10)) +test_that("grid tuning with static metric - check structure", { + skip_if_not_installed("prodlim") + skip_if_not_installed("coin") # required for partykit engine - gctrl <- control_grid(save_pred = TRUE) - # standard setup end - - set.seed(2193) - grid_static_res <- - mod_spec %>% - tune_grid( - event_time ~ X1 + X2, - resamples = sim_rs, - grid = grid, - metrics = stc_mtrc, - control = gctrl - ) + is_object_available(grid_static_res, fail = TRUE) + grid_static_res <- return_object(grid_static_res) expect_false(".eval_time" %in% names(grid_static_res$.metrics[[1]])) expect_equal( names(grid_static_res$.predictions[[1]]), c(".pred_time", ".row", "tree_depth", "event_time", ".config") ) +}) + +test_that("grid tuning with static metric - autoplot", { + skip_if_not_installed("prodlim") + skip_if_not_installed("coin") # required for partykit engine + + is_object_available(grid_static_res, fail = TRUE) + grid_static_res <- return_object(grid_static_res) expect_snapshot_plot( print(autoplot(grid_static_res)), @@ -62,6 +86,7 @@ test_that("grid tuning survival models with static metric", { ) }) + test_that("grid tuning survival models with integrated metric", { skip_if_not_installed("prodlim") skip_if_not_installed("coin") # required for partykit engine From 068d7792a035fdb1931ac2e73623fb54ce9853ae Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Tue, 14 Nov 2023 08:02:20 -0500 Subject: [PATCH 3/3] removed skips and lines that are no longer required --- tests/testthat/test-survival-tune-grid.R | 6 ------ 1 file changed, 6 deletions(-) diff --git a/tests/testthat/test-survival-tune-grid.R b/tests/testthat/test-survival-tune-grid.R index 78284673..1d98fd29 100644 --- a/tests/testthat/test-survival-tune-grid.R +++ b/tests/testthat/test-survival-tune-grid.R @@ -18,7 +18,6 @@ test_that("grid tuning with static metric", { } else { stc_mtrc <- metric_set(concordance_survival) - # standard setup start set.seed(1) sim_dat <- prodlim::SimSurv(500) %>% mutate(event_time = Surv(time, event)) %>% @@ -40,7 +39,6 @@ test_that("grid tuning with static metric", { grid <- tibble(tree_depth = c(1, 2, 10)) gctrl <- control_grid(save_pred = TRUE) - # standard setup end set.seed(2193) grid_static_res <- @@ -60,8 +58,6 @@ test_that("grid tuning with static metric", { test_that("grid tuning with static metric - check structure", { - skip_if_not_installed("prodlim") - skip_if_not_installed("coin") # required for partykit engine is_object_available(grid_static_res, fail = TRUE) grid_static_res <- return_object(grid_static_res) @@ -74,8 +70,6 @@ test_that("grid tuning with static metric - check structure", { }) test_that("grid tuning with static metric - autoplot", { - skip_if_not_installed("prodlim") - skip_if_not_installed("coin") # required for partykit engine is_object_available(grid_static_res, fail = TRUE) grid_static_res <- return_object(grid_static_res)