From dc25d4d8757cd7e491c7aab382024dea90ec2361 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 11:45:23 -0500 Subject: [PATCH 1/9] Test import_sdtm --- R/import_sdtm.R | 6 ++++++ tests/testthat/example-sdtm/dm.xpt | Bin 0 -> 79280 bytes tests/testthat/example-sdtm/suppdm.xpt | Bin 0 -> 124320 bytes tests/testthat/test-import_sdtm.R | 17 +++++++++++++++++ 4 files changed, 23 insertions(+) create mode 100644 tests/testthat/example-sdtm/dm.xpt create mode 100644 tests/testthat/example-sdtm/suppdm.xpt create mode 100644 tests/testthat/test-import_sdtm.R diff --git a/R/import_sdtm.R b/R/import_sdtm.R index 901d4aa..93cafca 100644 --- a/R/import_sdtm.R +++ b/R/import_sdtm.R @@ -22,6 +22,7 @@ import_sdtm <- function(path, extension_choice = c(".sas7bdat", ".xpt"), ignore_case = TRUE, + auto_supp = FALSE, ...) { stopifnot( is.character(path), @@ -54,6 +55,11 @@ import_sdtm <- function(path, ) ret <- append_no_duplicate_names(ret, tmp_ret, method=stop) } + + if (auto_supp) { + browser() + stop() + } ret } diff --git a/tests/testthat/example-sdtm/dm.xpt b/tests/testthat/example-sdtm/dm.xpt new file mode 100644 index 0000000000000000000000000000000000000000..a0b79cc2e0252cf80b8aab56763ba994ec611d83 GIT binary patch literal 79280 zcmd6QTaz8vb>5L=$Fi*0v@J_f$|{djl}c5rp!DtBpj}H#V7AIKdyK-{8w)7+&-(;H_P&7ga7O9`{8fBIyJ*&c<>32^#^t-Ll^POkDi@8 ze;?N;;_Liq_@zL$_dg837wFyB)k*kf^2%%Z&gu^z-MP3tzq}Q%<;rF`N5Z}8p0`M^oOfI!*}1}=XouNNzY#?X~5^h z&xC)=-hU8&FVMTMt3M9kOkP!AUc0#cwtW2J>c4lt=DrWV6h36{|0(=lpm$$K@5{;R z&mW!M5+OZ$j1Y8U;V}H%Qqg}g-zdn{{B<=lIOo3`;iVk z{9qv4`~MMsFVMTMqcZyT>Mu_p-Mmj4-kuX_#Q z{b*kIz18>dUHRDg)hF*hd-Ad5b9A}MrG=l#UPrFwi|~8dhm$v}e;K}+yi!KrUj5bS ztxJJ&`tI{jAAj)5x8)@KQut@={r?KT7wFyB)t`lLCa=7f@2$SC-$e|_?@MxN-Cxu9 z;gR+7Sm(ZBU##r5^+SU--T5HH7y=*AjT?>(F@c&9jTy^@CgIcQJatd+*K5qCCG}lsC3G z%A#EJsEV?=f%iqFXWMv|(@t9UB?}4b?>o0oA6?w}hc^)FlMi%H-?)46 z@Ra`a%||EqPA~61c$1%a_=}I^gK!@2UfFs0rpJ5h;uIHG-zcja)#k;=dLbjAtGX&EzmwF*%pmzYhQ!LvX znDk^%1R_x8DVK&1y{np{2J!j?dqI#FG>6bQo z8L{a#K(DvaFsDxBPC(LC|0`7QpIirY-=6ueU%dP5=`SBY`2eq1S5Hsw;PlgHmXmtC z0Gbz9{8+DJH3E7M(0fW6ih=N?>J4X5M3ptW zH`$kEeKT`s1l=4C+H+POFNQ2SoC!(SMOlXMgxh2Z>F!3kQTRE{K$A_-z2sy8NqfLN zUIMzbF~)-Y4ok(~)^$$>W8P#c{*h4_Rfi0cff+e3aj(Wg)he>)TFbEsYy&oM8+Ou1a7eVvlCTw~Oo8C(6#W2ba6`&q>eLN4BR@34B87z9xr-tNM!BT z$ROtuhe#EJvY_59cMj01DCyGFJ19okyhG6U5=S;O4fUky@q(l=f~bp^uX*ZS)lG>* zuO0PH^W#WUq90Fb2AXVEPI}47?F95p@9jy`<3&ls9~Cb?_d)LgI+lh+=5Wuf9pgqY z^NMGn6$EW;vFWaQUn^t{*T^W%L()(3@lRC(k{Wq26kc+X?Tzha=lZM^@RHNgBZm zZXuzmBZGr1h6fzCQb|uu;0=c?&qI5>sNP5@w|-#|u9+n=$XBAX&1)cdSwf1@X-YFm zBTXAlLo@ZB5Bd;C#w#xTG_)?Z0G%dQzDEmoQ1nNmjMEEbWS+C~ctO%kBPWKIbqUZ? z*oQS>96_05K*~H*@#Qp?w6Hl0v&&ZIFl}yUSrdvz4Km|K*X^?&>3?lxQJu{%B z>tj1IhzS=r(TPx_1dKyKi&MrK9GBH)XxPR=G&bCY#Vvp%e5bk@U-qi=0apon=%# zOKHWr4OzqLy-=L?Le^M;AxN54fr(CpdQ$_mji-@lDtx+UW@)hLoTiRU*c?w6Y0^$f ze;vltoSyJUS@mWQ(ET}@o|`g)-ibZ#PVW;0y+EUlr@|gDN*dmKDo*bp>0MhnF{MTk z%%*za#}k@`EV4P^=t=sG>)7&Ott`biumy+C2m zlcvWDpc%3zC5?v+p z=$(Msq*=Fqn4r_b;QeD%P5_!kO+QXI=mN$8EC^31w9uugdYk*oX{O#BWJ~2Fg-+0E z^W0G+Ehx%~5^z)Pk%m}zAne!9nh>#>kS4UK-ZhH-)y=H2ilEb;lgW&1+*JFe6)_8tO^YagSc>XFqcku5&iqF;-QYrYM?M_Qtu`%evFQ~0wy3@qHjN3q z`lYR383^Po(qii~*qd%;7s7D{dKF|8BF*eNYKvccSY5lMS0?C}!NMfK8F<`3I+iCIe=>c}E!iFJKi zC;GuNE&{CDr!n!ODWCm?I zRqvUgJ!yKp2%58tPDV!1Sh#{ipkhUnw6<&hY7x7oAq`8GD5Vu|#ZO0;4lQR+%6q^( zUH}agsC$p+-T;l%golF0d-LOLDjlLlN5&di-7O;2XA9KGJQenM5j14B^W${2-jz52 z5HT4kr@?3T(WjxYq`QPN{P1uZBrf%mx=vZ^f_ZMNpU*U@J~ zl})`sy}@W^l!( zjm^2NY#jt``fa_zhjt8(Npo7#fP`eadHL6_r1y~Yo&Y7~Y`cIZPWNc0-pI&?s-cU- zY0qvwUQ}=RqpdTv#BHf-%v#ozv{c5D>3L>k9U6+=O2o{G)X1`x9F%lAmvw;mo-b)! zF|v)FQvxPv*fb7cfzx9LR)8u>-J=<3NE$=S;^w-WoGdVx<=L&ri#ClMx$+%ZjR6Oa zUZycd(0hWLIjr7Ua&mgXe*W>l;f&0i#qf9vS|nZUof0r4-JlB?2e9b)gp#(AN<3?6 z!F!{IG#s*0^*$gY^VEB+QW|WU&S~uz5t?+=IkPg(+8;cm`kfLmGTg3OOw?)_@Jzm?-vG}ta)xGXfGCfyr|x=X|ISNps_tb7*ImKI?P}m77K$d zEi6%@ujo5`N;=*BVkT(MZatoY)*$P3_7il4ZG1vy3<_-O4bW}ujw+9GiE2ODbYwl7 z&f@fZn?6Xr;bpz?G(m3wdSkgavsOg~rH+ygXQ0UphuA?m6sMadDkq*aJzkKsmViGV z&AkbF+wf4Eh5%zmCe2mAm(nnoqaWnvHq6L6lk&MuA7yAMS6uF26fWpJw(;3ppn_kv zK*h-_kvXSoBMst>ijXFt>d0x+3-yM2$;lWmNSe8~x48=>Eqw@~+zY81d@krx&>77@ z(|hk^8=usjE$GM&vT3A?duQPaK?53&AV8Vn5TmulXmr%3@;D2HL5AwVIGxUL9H8EZ zfadI?w^~O)qc9kJwxuKhO{3Ktk<&7p?lsypOUzn&vDo89^@jKMTAv9T<7pfLU~pfk zoLI!hdNxZ=NHfqprFwTNCr#Edcq~aH2GxGXggH* zZt^0+yg2Pi)8nb66@|A68zfy}M;jahn$}>TQ5s=Nf4N;Y>v0>^@gC_3D8@aQc~#M`n59of-41_i}b?p;B9#+uO?PoMmn>Z;?_8{m5LY8N@9xvK7 z#N4(R6WKsZerfR9)l90ue zGgL#t(E$hT+;VTy%%*udIJEpa^oF7oGLeSX*yjWXWC`Iys#+zXT~NMVTBwGS&B{q{ zJe?*dGu7Mk&>k;%Z%TTia?(K5I20fvk%7h;7 z=F#&?V+4Ri9K*-IJpcMACHgX?3iX^gD;gX-|bcUXU~|&fDjNl3rsj zYi*-wCYlkIDSA$`I6VsbECGEi^~M!fP6?P=iV^~jF~Roes{JDw**a^fni;1(X?ncq zy>W51GbvBd==a8YDT=E&r%pUsRzvC z1xfRYH!n`~LI#@L1vCnv((f%JDqDBQ=1;AABkH9zN*cONwm7nGa+0a{JkVa& zqNx3l1%HJ$Nh=~?>}->^xE(x$z%!b(RB6Hn&}e;5odG5N@0XGEA&!h!T>7AE@+rPvRO++I6{?J zXT?HTNJ@(t*km@(giGLSa}aB zAZV=C!J+cy`=PT0U&~I2dP+(E9*X^APA*Cs+t=@3yzYgp8a*dCfCc$9+rt$VRK%uw zQkr%mFdd`NyMF||K<>?0JO<3;g^)!Qm7jZKB{722b<0IadWOf-3*_Ejs_F5fq;YZH z?iWyJq~1JKzQ{S+;APG&r>P@jRFDA&=6TvbO8PvF(^Hf3!@0L7O^+8rb0wM68wz%T zsahNY8dyTB1(It8ozp_Oh-@Y&o%V~(nVFIS8dTN&%ww%Ftu*_5QeiUEf>925q>RFxaZy#c!3H9P=S9GNuA$(cyHOACv}q4Pr- z*=DKaFnQTY3O8fGA`-) zphdm0aOJa6Nwa)iU{XFbHzR?wp(R(bshwxEP%a|-veU=c}sVael#IL%R(R|1Bl8$2%yN7pHhzK8gs-UwM~unLZByF^Qs z2h8IsXuUWuP77%4XjAtKUSp`$xie(-KCvyfODtURfO)(ar&-H#YGi0Wl7Z#GY+MhL z5yZ`Nyg3AVceX$$f(OjwrRwd~y#+MlbXY-~dha$j6Ys4qJ9GgfP7ghjVwYuP2NV$w z_1@n4X@W-22@cg-hGjiNjJLCl7CI5g=6Jf3k?qdX2MQetG#m~F93PK{EP`G)JjS%S zN5?&Z&;feLk?oeKhI%UO@m|%D5%dPh$);Zs=%HKScc7;YriuC63J9)Ew%K=M?Zz z^#(wjszo(lhnpO6CNxuTvIixduC+W0Xe7vx^xEn77SNFNmh!dYsmdH-NuhFR$%qXC zX#{Pj9A$MLufEF`m>#bLj4oi`rs2KIU0-ZHIT}Ik4&(o@O=lB$^SrkgmONezSrdgp zNE%gd9uZ5-!@^u8@U^tCg(k#5R1MuNG2meF&zsg63uh5Du6QD3RVBvLGHu6suVjK& z)H|cWR>Ce-qXUlAd(TWxra+I~kR)Vb4aetR$f|09uFX}Ul|<{JD3}LHXS9%elif1_ zdhct^WsR4M#(=$2378XY&USlLZ&dnm^bm{@UvB!%xjdXG2hb+|pxV|(xGE;Phr7n#bNlZfvbRuAf z*mSH#^S5aE0L(aT-SeXcM&Tj-z@D=#*xl$(EJ!T}Sp4y}^gjsTBjoCCJoOKt$eVI+?Gy}~(@dOIUK6*)-X#k@ajk-RI;0&b>rZttUq#Kbe-RxV-( zmc?nfeY5kNW;RVWCEcrgXB#WdleFidJzfM2jhq-yH|RvbA(BRfl2J5n6_i?K-k}+2 zvIn}0cG-gpX4>?j-Wykpy7%|I^ zfF4ufSFvdhi@gavj-cc@1)6fATomfwz->1or)SC16S#Yb|kzsj}El^%nT1)E!#%-q;Hm<)Ti=+GiUp9uTtTt2aU`7gagcP=JO( z^HBf9LW`co?e@4Sa-^wx!;wL~`(qTU_W~O>d9m2z#gK(K?L9h*pf@n;O*^zS_=t5j z#^%sjZ-h*1$SLE0e=z_-FZ6VVLnJM0LY;CEKv$fc4m+7ZhBnHA_m1*yY4JH6WHV%S zo+-c2rfO%}v?ooE7bOh`?zLYKG(Ola6e74TlHJ<3;Zc&|XWGfJTtU!YoO&;GayXVaaCG z8BID7U<4e9_wENJeLE=(9-!U_*)(eQ-t(sk8oOWMP|(m?tAL~WVAYhI7Be!|$ne9PhU%6d-2uk}3s)G64{~G}0`Hv(JW86qMK+}1x>1g-WpEJ`J*TO9GriSihiOfe z>V2(chhK$y%ecXP@E<`}Q19Tg@eOrpKoyeDoMw_HdtfeWzr=oIUe@LDqD^xn-wE}` zlg8^XMThVkYX;veMND4Y^)tYBgZJ6WrvhBo~?reN-Z@9Te-nm zO9rYQO(iXCdhg!QGHr;R3EFd39#28b6}$7(0No(>#-Sk#xt66Q%(@0>Vb6Ys!oiFz zZHS!-ddiVaN*cJ=ZLFC4nlV1Z+x8_pIuj z(@ee9dv}}X0D6H(M|sZ5MTP8LgoJ~` zWT1jGK#@qHc4+3v$Y$=HFI)lW?D^C4)^K>v%Hsu_#ucOe;!9V((SA|1?H2(wl6G@x z2mp2?NHfqpy(~AK_6vYc)6kic_JDc30Gj&h^m~hX@8HOG1`r)s7M+o_57EL@E!pb5 zRo(HvdIu_VmTrrCEYNT``|%nXL8AqjM=$=25ftQb?hVjsHFRdbw^!!%cu~^u!_M{q z0vdI1_Egbl>rId|Shq^LLsRd~j4T~g>K&q_(~N8;XwO-ByZ{yR%{A4Vp=@9RuPfJ+I;A{Y2U?5vFdI;EHeXdfr6p~WBcrSZLe^oR1w~m*s5e4ZX(5Y=2&Z*4 zIWgy!)7s=j9uk&6X&jP%sQ%-4P4423tLEhoTt|lO0m`sF005e#k#d=H%W3Mpr4ymQ zE(@U3wU#sEwCAimUT|d4Uo1v*D<>5mK7vD38M#atWxxNey}&5T3rij^f=1@FAMflJ(0IgSC69Q7r;oGJ!V!Eq&2n!J zWQH@c)TU=j+8b1Oya1Z@pUNLvRv1s?06?iOg;_1!0qY`!ve2bz{1eb}I<$Tol1^)6 z2RO2W;xsd-DbN^iK*NL6Qujp!0s1tWDBgS^b>YY98beDQYQM;{t?rGXrFwJ@LK0fcy$iHd zHJv>XmI3WKD~}f)8Ry*m8d;59s&EKsIQuY}!<@8BlQ;z;jGyeDE-+**Q0ynL`Ei;T z$>hWxaMWmh#vxc><5DDo{zmuJp;_)t_TW_Q+h32NW%=U78(P-b78gfPY-0r69o!SP zU-mvhNiR?W_UzWi%lJsHF3ltGNU>+|xGReKCKqF*H zZzw!HU4Wv(8_UvinmID2ZoS(=NiWoiaEMJ4g|j^X*jQYOwU%Mpj)Nx!jW|t5#&JhR zGtgwyd-sY6sicpWhN5!vxo6W2o>G9LC$=$y+zFtAS- z#Gz7!7qA&Dda5oBE;}q5M{FA^_Lpbr`so95@A*@;5>MSu1S$Ff^gun=ku+}&0($Qg zs4y-uwDhFu@uK(U#Z5>Wo4XXYxeFKfw2n+iUL9I=WZF`d4Lb-rYm+?2N_iwFKv9e@ zJCqbtpFYx6Wt3bj`Ak(_pO*yZ-NAIb!UEgwAHDZa)qfoFKp_v9$BUpj=QITx#r|t=i;KpZp&D74<=!)s6AzfjQ_%3< zytoO_d&H*wHAh*<^alIA%WS*7BY~ES^FcQ?a_`!bPn5o_2#6SOg~5y#O2A~Zh>&e> zMfFZQ5oUt+Nsx)2brVkN*N>k7nld>Tei^jX4vye3}Iq{_F@e)Ud zF5vMR89<{2m3mnq`1QjD?&X_kAF&H3q0?pPYZ)lx0&m9Fc)SIh+o#r`8dW$}?t&Ob!m1mND zgc?dtGnaR92`BlX@GQH0i5+_!|L>Md;A zbQZ1Y$kH0wSLD5Y^%fL(#N!v9dRJ@Y-fOjA7W)l8+%p{+B%0IArpX?3Wa&O9Gu7Lh zukv`org_EQcpBl!u&M6cbw@$xkNq)(AmBh zI^NorO%}3dg7y*+kEfu4g8Sz=Aq$|(JqFZ!N*W(WkyoR$pc2f8)LUBkD*miZ-8!O1zuY6C+LOt zIXP%N4KYsE)wiSL333BeHtp5HJYEu~-MK7+UL$0!RlPZ+wsJxn zyjmK(qLhmyV;Lxw6ZFyd?B~Fd-9=xHIx>K+px!v3-av;m)GXQNvN9USTV~T_OJ{$c zd#{i0z4eN#7e9AF!+Td*0i;{b&flx?i+SgalaqxUnWw@YFD56DwDbJwlJ2U+<}P7C ziQ8l@4O-HA??}V&SwWL6-aDP=SkRGqA#02mL5ufx)f>;}g&nh81XHDM=oxI9ak@(j zP3~l~Mway$5pmfS!cyWy#}@+asj$b3 zl7_=^9_A^a@j#(EJWvRN)#!`?N9aDuX!g7;VatG{>&O;ZVCoGYJzfNjvW~a=1#G%0 zkcNgLAe)=jXi;3V!%M$Lk~($uzqUmv|k8lj0gvw1J#3M z1idFPo1x0dI%|ENY15txdpwmi+|tDSG)9O;ffETti z9x#s=9T_jqnZP4xY|VuO0;Ke`?u~K+VqNSm3I$@)EM)OiymxNXn`{fsnUePG*5d_9 z6UD|ES_){iRLL*{0>u9ssGuTkjVz@RGzO$(vxv}XliVz!-X1WImrA;J+9U}Yn}*^L zQ-!eG!Y^(GOGp_F{mufKjtr8nx)XStr52-&#o|{PPxFe`6OwMA-i=MmBInTT3t4y@ zvQnC=x3DScY;_iGI-RwgwCUjmrk*rCo=RFPeZ`B9M{{pVS|%;~@u%yh!h4l8eB@Af z(PoLtiRY|5UQ};h+=L@T^IWm9n2d3RP3v&~A5m{M@wYU~y*V5k3R#ZLPnDZ3d!Bcs$;7A1ie5XnI}z;r=azUCnOEmjT)KNOPIB)(W2wk&T^W0 zZ?fsVdyZ_OmGbk`P|2Li-HQ{?k)ad{(Cyf{E&OW8;&3yesd{rK_d*JT`3%QqiGFX- zLwmfa-pI1NP1vB`B}!yC)TZ(A){?Ds(9)2px9t~$o4YI)r{_yrvq|T1aHW8TCtF)| z#(>gF2hb8L7G|{YkT9|b)6jHJgkyPc*xnRq>@iq|JqA;#VTEN*Gw+QwRJO10v{Wr3 zX-|bcUQ};*A+Oj^NpB$O4J8fZg;dSDIm-J?;`#%B9P{*W+$P9HNf6SOBykEfEx6>}$7XD*A9 z-l3&x$DB(gZP^zNvZpca-ZDx+Ay{yaQMVp578mHI~Nmm$U;fUgzI?=lWJLnfsDd|+b zXM*+y6&^2wMiSxmdlU2?oe2BrzJeob%YoEnMam6}qW2!Gk!`*fOO$ZMjc?O6s-ZZh z1RVK_pM$VS3MZ8G0_yEa)8i$QF1+pbAn6)uD2^73oH2M=MivK|LQ5pg-q6ktv5QFB z^UxkI0gX8Q&~s!MZeT8p$tSdeC1E{dtn1Ts8z01QjHmm`K}n}W%b6j|8%cRQ1uZCw zo$tsntAlBsYgJBUT4!LQlb{!vpY~MP;{{1WBGrT=t2fy4BW%qD_hphsjm*MWPNRC` zW|B?y?xmr>hcz5yMZ*9Zr4Y<;xHYmG%NcM03&)VE-WsuK=UrMzP7u6xsx}Q=l=K3H zK`$12JOzy_hNK&3H%U0MrbI(*n2Sb&X=5u^^8uRKXht(fMmCd^EWi`A`Hw@I+&y3( zFG`vtu~p+j6^d4l)Bim*x z@MfyFCryu+s5d6%$GtZ}Z(-D1$`Ve?>=$PMJxC*HV-Kv>*=A|zQ9ug{v_AiQ)TRL% zAb1ECT7$_PF=>!yk|tY*mg(?}>YdieW{$EvXXWuyo34CG*Kpl909ySXq2df#*C5S6 zlg-LWHlsz*uj>syBxHHOJYJ&S*h2Gjy^veycQ0-|ynFA>%c4BL4^_rRV!(kNVsVJ1 z8Iw)EXklpMbff{Jssz~#S)En2+pG)tSn7>9JpsCDHV9ePUW3{|lyrC&aYkz&Nr8~X z=Wyg*z}uzz$mV-**fhq4#f#sLN}3ZD*wh?{N*Z~#$sCJ6OwuVWhAhOf)NkvEdRy+Y zo|Bn2O%Ht#Xcjx1QPwV>wVc0xdTb;$9j74IcfD%pR|Hz(^lv@Tb%nZjXrH39SDD9zR04p~Q2MnQ4jF`n z8h?DHBTIL3KUNwF)7&{T98m8XOO$XZEY|z<3@Tzaozr5R=2MBW0dn3Dn`dM*L3?)V z@uE#5+o=4IrH{)p`65-fgfy<2ZkHExBcvob8JgDFWliprHa*-X=_Mc@FM{S|gtNH| yB;DXC1vnsI-k_L~;jAqITb2e|0L}iisMg_x>YaM;qdX)`QN+EA!nGat`u_nQ8@09o literal 0 HcmV?d00001 diff --git a/tests/testthat/example-sdtm/suppdm.xpt b/tests/testthat/example-sdtm/suppdm.xpt new file mode 100644 index 0000000000000000000000000000000000000000..342704ddbabe27108f926be5eca742b23198be13 GIT binary patch literal 124320 zcmchgTW?#}5k{Hxl1qc44@KJ~FQ+K_QlJ6Pg%{;bw&X^IZP}LMB9C+|2Wovu9XUY$ zedil#@7ZMJByh7vXu*&c&(hxCnmJbHhcTb$7mYpYJa5#5hmSo}E3v*gWm-zuG)Ke{z2I@|*6-iAq!mM2{|dwVvUeK33L${J$-<98N9`(1pJ$w7X!SS8_qr2UMv!|Pjv&Y@Ri)Wkj=iUCJM=#I5 zJ>OiMzj(g8IDcN2RQ~bm`3Gfr<@Mdi*~jIb&7=O7-^_mT`N`)u{%P~_`SbJtzB=np zUOoEv*_RhTK0#$kg?07(w`FK<-h zo^KvKJ=^bSf~AIKV?bfx38Yx zE6Xdd?>^4nEANcQ-QRiL^R0E*)%xxD#>pFRAKW}RvbE#U?c>vVe{g5s|9xfu@8|uZ z>uw(3xp(`tU*3H2%vMPkS_{2+(*5h~>_1((Kr-<{k$zI$@~;72LLbPZ*gerC$LyN0sfg>-K`mcv`OZ0t9`IDGQt{L9Uk z-+gb%ZK`ifIXXS{uG8709nqwtQ6DOD*7KVzaK%-EDsm1Cul zRT&hrDn;R|Qj`S8jKVuMtukgz6n@4;;b&~mDEzuIC}dRzg{(?Z_^K3zcT5!AvA*vU zX3Q!0j5#G?#_E10XmYQ;SKMT$B;;aaNyw#c^Mm{QeP1bHw`?e=V>Xrq$BdHTm{EAg zMms%&uaWzpkd6g~bW9Z9F;RHOL`iVW_V^MUs}$6+N+05-Z4>l$3)>B zTc>P~iNepACBPI3fcLCLUw*p_|7j1 zUzMWZjt%pSt&4^NI@VA?$DD#Y<`mp9r|^#HY{F$9BXdbPXEBJv=OPN9OPmu2_bi5> zkhLEa(lJr^+82d)Oq2x2_Db!ej#UckSf!wj8709nqa-+H6yC8_J@-mF78EjlQTX&l z;nNp|Pk)_pJV@64E%qYBL%Z#(tqbU50iIOm58E1LM zWu=f+85FWAMd7Pblmy3&!aKIE>4Qh%#-Nan1%-4>6y7mWc*jIZa4cmnDdou3m~!N5 zjO#AQstgKQl|dn^QWU-_Md7Pb6uc^@lzXZ)6wtAT0y^dt+%c!%jyZ*QY{)n(I*G#1 zm?->=>864B)q_(|$f^tqS(T#jRVfPZm?#O3)$=dl*2Oec3hG#;ppF?O!7-yGIA)Xt z$1;vuPgBNGYp1X?HrPGx*0{-q!kSzttjUGK<}z9?(Z{H6xlN(EhT&W~5+7!-|ahhQi0<6ue%hF{54@3Ro`<1*{jR;Pv7Z-Z7=mIyTu^(K)`CR4D9>6-vU4 zSuU(&J{F@S%vg$J{P8i(SWu`AQz(4;8VjGkD15!}cM0%Z@Vf*Q3O{25zGtDah{8K2 z3O{2@qg?J;khL!gU;Co)xroB&va%~w`CLTda}kBlMHD`lJ=;rS_r%p& z@acxL9pld>$uUuQ$3)>BTc&Ko1ch`g zD5PVe@asxZc*jJ+9UI~sa>4E7h5|a)P(a6=f;;9E+%c!{j*S_6;zLl#^hM#*7llt> z6h3|3-x5DQHt=@@wXF-M@VW4J1l3q{heJLW{+^I!EPO8fJt2K8_G!U{T#Ul^u_gZb z$}(ek9~*~^p6rx_v1IJMjyf-fo9qS=22h za9?Z;3b-%UP{6Hmr|^zx#(2j>;T_XA z&&4TtE>7WdiSJDSYkvv~So;kHtbM2Oj%mht$3$TrTj&Z^ypI(MKb8^S9@AKYLetnl!Wx_ zkzTaJR0`T*Dg|}SC<%@kCBZSH@Q%f||B#Lag>)<^q+_D+j)}rMCJOG@s5>6udr1ui zOy4PZ`cA>qcM6|A|EXu&P98kC<%_?+haZ!e0!`=@EIG| z_$TaaEKb24a|%0SE1loBZA-Q)3x%DrLcwQjnAcB0P@Uh#(om?*zfGY!f1%)x`HbO? zIfZp>ZB@yC`%j^;Ggc`4jPcj=Yb^Zr{Ds2LnAVl-@iC1hC{!QYrciyXP}n|JD122a zmjuUb>mtFiN@3> zp@3EC6uk30g?CK3BsgYQ+Fy2lG#8^JR6?qju|DvF{30nW)$ABxGNyp$AUtpFAAT&D17>&B&1)r#?kaE zh3qi=H%+Kp^4~O3C<%_G>{;k;!2DV)D5PUSA^Vspd><2qcT5z#kJ;vUaSY7GDR?eU z!Ehiykny9wZBSnEGT69qVVa9!ly4vLi%-k3_8y59Y){9dD+Lv4igmA zF&j&QV@64E%qR(t)$7Ml$0`MNtWr?NjFRA(Q4$<83h&sOzC(!jF;Vcb*jE=P5 zEciXUl#3ne&6qL#o?Skc1$}J1Qt;aEH5T5nWjzK9u3!3~fSundc;|NtpT1^{PhUM5 z-$(9)0&ZP26w)z`g?CI8-Z4=U9J4iYf@76}I#wyDV@64E%qR(t83lK280)cda4ptQ zK*t&i=$KP*$DD#Y<`mwsiN3Z++m=I6NXLRgIwlJ5m?*qsqVSF_ZJQroR}MiT(-(zL zUlcxlQTX&zj=&EoN8p{3Fk^NN$z{EeChPkvdB^Z?$@KLLem~es;cFkiA8Z{9Zt^&< zXA(h^or34$6ue%X!spUwtY1b^62_9Tmo)a3LYgcJZ?Y)7$)fP->v%H0Z8-)7+<$2( zq+=;(6MQVZV<~47#zj5D3m%7QD5zs~EU05f;rp0!NpQ?4d>@PZT#=3ig>)<^q+_D+ zj)}rMCJOIZ+#iN?EGT69qVVa9!ly3^p8hm9$M7wsh5~k&h5|a~6x=bV;Ep+kb*#6~ zB;t2G=nI9Nu|nZzEWV4A>d6{QP^hZhrchN`C~Q?03hx;Hy`rj@eyZ2QfVnsY&&4Tt zE>6K~e;V=YVJv;8uwxmm!-Qj0AKRu-eQcXT)k~qU^-?Hoy%Y-X*sAt1(y^eBjs=Bu zOcdTRQFzBh!5!=44u_y)4Fzko@79xhQTVZ}@axAkmY|UJ z5)`stMB(d26uw?W!5tgozN27IZYZE*4Fz<}DY#=!!5wo7@7MzW#E|u|Atl$CerE${{GEV?iMu6NPt76y7mWaL1+zKg(l%tf7GEI|WbQDR}x$Vbh;< zoZrqQvgi1=DO88qrcjO*3hP**u#Oc9?-+k|hsMHR-BBofF8tLUHkN)bqxKsLSo;kH ztbM28weJ+%F{j|QKg2iWQhVZNazg3htOwaL2|~MjvY^pkoaMbj&HZ zV@|;xa|-U*G?-)fj5!6LF{iLIwy^E7xT=%t{M!_&Dz_d$EG>H zFJ`sx6nw^%lmy4{>tTE>m4Z4}DX3#c zNpQ?4362?scWlJJn?sI?!q1o}{ESU0oj)jKRR)EuN>TW#6oq$86yC8V{wW((Wl+fU zMd8yIg->4;K7HMyA|l>R6?qju|DvF{30nW)$ABMO`D4eJm(s`l9gZi^8Wb zN<#Yh5qNc&MWv7(CMc+5HkJg(jFRA(QFzDVdw9tX6BN?1ppcG zI#wyDW0itBW|RcSjFRA(QFzDV+kQ#MfTbaJj5!6LF{kh|)@K}t z8G{0Ley8y1Yb<>FqVVa*x66UsmSa%BZOev2I;OGkj)}rMCJOHue@{p|);IF^ge(+3 z7yh1*HkPTc+c045Hx#h;8wyzaPQh#6DY#=!!E1lg-5T-z%7#KZ7GohD6NPt76y7mW z5*)K5BnggH3hG#;ppF?O!7-yGIA#>qv6WrfHMcD#*0F60<=8fba;#8T#|njYtWa>r zdj5W}HkO70I@VA?$DD#Y<`mp9r|^!gGWu8_6w6L78Tn79*!smOcrH%Cb8!lvOI$xj9fwgaK>>SmLjh~wDZFEvG2SszaL1;p zepVE8tf7F8H5AY>r{In`1$WFTtYd3^_6`4}aG|g>Rw(?8@!y%EvGCuSQYiS0*;ldB z$6;(N4Tb7s+Z3vg6$;zO3I(r9&xLnvw5y@mV||*jppcFQg>+05-Z4>l$3)>BTiDg< zykkKj9SaKSm?*qsqVSH1!aKG~nK4oL851R8#)eXrq{%Cz@Ft6rkc(09T!!c{)ZVMD zksAt_zEkk@or0(Dl!Wy0a~7U{rGV?oVNoflV@64E%qR(t83lK29O|`jU@lI Date: Sun, 16 Feb 2025 11:55:41 -0500 Subject: [PATCH 2/9] Added `auto_supp` argument to `import_sdtm()` --- NEWS.md | 3 +++ R/import_sdtm.R | 13 +++++++++++-- man/import_sdtm.Rd | 4 ++++ tests/testthat/test-import_sdtm.R | 15 +++++++++++++++ 4 files changed, 33 insertions(+), 2 deletions(-) create mode 100644 NEWS.md diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..58d65cb --- /dev/null +++ b/NEWS.md @@ -0,0 +1,3 @@ +# Rsdtm 0.0.9017 + +* Added `auto_supp` argument to `import_sdtm()` diff --git a/R/import_sdtm.R b/R/import_sdtm.R index 93cafca..46b4147 100644 --- a/R/import_sdtm.R +++ b/R/import_sdtm.R @@ -6,6 +6,8 @@ #' first extension in \code{extension_choice} with a usable file will be used, #' and a warning will be given for subsequent files. #' @param ignore_case Passed to \code{list.files} when loading a directory. +#' @param auto_supp Automatically combine --SUPP data with the main SDTM domain +#' and remove the --SUPP data from the returned list of data.frames. #' @param return_type When loading a single file, what type of output should be #' provided? #' @param ... Arguments passed to \code{rio::import} @@ -57,8 +59,15 @@ import_sdtm <- function(path, } if (auto_supp) { - browser() - stop() + supp_domains <- names(ret)[startsWith(names(ret), "SUPP")] + for (current_supp in supp_domains) { + current_domain <- gsub(x = current_supp, pattern = "^SUPP", replacement = "") + if (!(current_domain %in% names(ret))) { + stop("Domain ", current_domain, " was not found when trying to auto-combine --SUPP data with ", current_supp) + } + ret[[current_domain]] <- metatools::combine_supp(ret[[current_domain]], supp = ret[[current_supp]]) + ret[[current_supp]] <- NULL + } } ret } diff --git a/man/import_sdtm.Rd b/man/import_sdtm.Rd index eac4fd3..86bbd4e 100644 --- a/man/import_sdtm.Rd +++ b/man/import_sdtm.Rd @@ -10,6 +10,7 @@ import_sdtm( path, extension_choice = c(".sas7bdat", ".xpt"), ignore_case = TRUE, + auto_supp = FALSE, ... ) @@ -33,6 +34,9 @@ and a warning will be given for subsequent files.} \item{ignore_case}{Passed to \code{list.files} when loading a directory.} +\item{auto_supp}{Automatically combine --SUPP data with the main SDTM domain +and remove the --SUPP data from the returned list of data.frames.} + \item{...}{Arguments passed to \code{rio::import}} \item{ignore_filename}{A vector of filenames not to load (case sensitive, diff --git a/tests/testthat/test-import_sdtm.R b/tests/testthat/test-import_sdtm.R index 05719be..b49b8ad 100644 --- a/tests/testthat/test-import_sdtm.R +++ b/tests/testthat/test-import_sdtm.R @@ -15,3 +15,18 @@ test_that("import_sdtm", { regexp = "Detected domain DM from data." ) }) + +test_that("import_sdtm auto_supp automatically merges --SUPP domains", { + expect_message( + ld_sdtm <- import_sdtm(path = test_path("example-sdtm")), + regexp = "Detected domain SUPPDM from data." + ) + expect_named(ld_sdtm, c("DM", "SUPPDM")) + + expect_message( + ld_sdtm <- import_sdtm(path = test_path("example-sdtm"), auto_supp = TRUE), + regexp = "Detected domain SUPPDM from data." + ) + expect_named(ld_sdtm, "DM") +}) + From 2b55b87a9960a470ca652927e5a805545460cd5a Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 11:57:12 -0500 Subject: [PATCH 3/9] Fix check issue and export other `c_to_n` methods --- NAMESPACE | 5 +++++ R/c_to_n.R | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index d79ca56..8a0f8c3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,11 @@ # Generated by roxygen2: do not edit by hand S3method(c_to_n,character) +S3method(c_to_n,data.frame) +S3method(c_to_n,factor) +S3method(c_to_n,integer) +S3method(c_to_n,logical) +S3method(c_to_n,numeric) S3method(sdtm_dtc_to_datetime,data.frame) S3method(sdtm_dtc_to_datetime,list) S3method(sdtm_first_dose,data.frame) diff --git a/R/c_to_n.R b/R/c_to_n.R index 5f1afb7..258cb12 100644 --- a/R/c_to_n.R +++ b/R/c_to_n.R @@ -57,23 +57,27 @@ c_to_n.character <- function(x, ..., } #' @describeIn c_to_n For factors. +#' @export c_to_n.factor <- function(x, ...) { c_to_n.character(as.character(x), ...) } #' @describeIn c_to_n For numeric vectors. +#' @export c_to_n.numeric <- function(x, ...) { warning("`c_to_n` is generally not called on a numeric vector. Please verify code.") x } #' @describeIn c_to_n For integer vectors. +#' @export c_to_n.integer <- function(x, ...) { warning("`c_to_n` is generally not called on an integer vector. Please verify code.") x } #' @describeIn c_to_n For logical vectors (only handles all-NA case). +#' @export c_to_n.logical <- function(x, ...) { if (!all(is.na(x))) { warning("`c_to_n` does not set non-NA logical values to numeric.") @@ -84,6 +88,7 @@ c_to_n.logical <- function(x, ...) { #' @describeIn c_to_n For data.frames and similar, finds columns matching the #' regular expression pattern `"^..(ST|OR).*C$"`. data.frame method does not #' replace numeric columns that already exist. +#' @export c_to_n.data.frame <- function(x, ..., verbose=TRUE) { columns_named_c <- grep(pattern="^..(ST|OR).*C$", x=names(x), value=TRUE) columns_named_n <- grep(pattern="^..(ST|OR).*N$", x=names(x), value=TRUE) From 9f11a6bea040e53ac4a54cfc7264f4847ac5c23b Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 11:59:43 -0500 Subject: [PATCH 4/9] Include metatools --- DESCRIPTION | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 536f03c..a836ef6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -11,15 +11,16 @@ Description: Assist with management of clinical trial data in the SDTM and ADaM and verification of SDTM data. Depends: R (>= 3.5) Imports: - dplyr, - ggplot2, - labeling, - lubridate, - methods, - readr, - rio, - rlang, - tidyr + dplyr, + ggplot2, + labeling, + lubridate, + metatools, + methods, + readr, + rio, + rlang, + tidyr Suggests: covr, scales, From dc10c0f398f05a781bcd32e98da9c66e414146e4 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 12:03:24 -0500 Subject: [PATCH 5/9] Export strip_attributes() S3 methods --- NAMESPACE | 2 ++ R/merge_supp.R | 2 ++ 2 files changed, 4 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 8a0f8c3..05bc1c3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,8 @@ S3method(sdtm_first_dose,data.frame) S3method(sdtm_first_dose,list) S3method(sdtm_time_actual,data.frame) S3method(sdtm_time_actual,list) +S3method(strip_attributes,data.frame) +S3method(strip_attributes,default) export(c_to_n) export(dateany_to_date) export(detect_domain) diff --git a/R/merge_supp.R b/R/merge_supp.R index a2b27d1..6203394 100644 --- a/R/merge_supp.R +++ b/R/merge_supp.R @@ -167,6 +167,7 @@ strip_attributes <- function(x, specific=NULL, ...) { } #' @rdname strip_attributes +#' @export strip_attributes.data.frame <- function(x, specific=NULL, columns_only=TRUE, ...) { if (columns_only) { for (nm in seq_along(x)) { @@ -179,6 +180,7 @@ strip_attributes.data.frame <- function(x, specific=NULL, columns_only=TRUE, ... } #' @rdname strip_attributes +#' @export strip_attributes.default <- function(x, specific=NULL, ...) { if (is.null(specific)) { attributes(x) <- NULL From 4c870c6507afb732cbe0c6d4feecb9346735c974 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 12:09:02 -0500 Subject: [PATCH 6/9] Test import errors --- tests/testthat/test-import_sdtm.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/test-import_sdtm.R b/tests/testthat/test-import_sdtm.R index b49b8ad..6107919 100644 --- a/tests/testthat/test-import_sdtm.R +++ b/tests/testthat/test-import_sdtm.R @@ -16,6 +16,17 @@ test_that("import_sdtm", { ) }) +test_that("import_sdtm expected errors", { + expect_error( + import_sdtm(path = "foo"), + regexp = 'The following were not found as directories or files: "foo"' + ) + expect_error( + suppressMessages(import_sdtm(path = test_path("example-sdtm/suppdm.xpt"), auto_supp = TRUE)), + regexp = "Domain DM was not found when trying to auto-combine --SUPP data with SUPPDM" + ) +}) + test_that("import_sdtm auto_supp automatically merges --SUPP domains", { expect_message( ld_sdtm <- import_sdtm(path = test_path("example-sdtm")), From 94853f11f5dfcb2a0dde62d9ce9a77eb45555f06 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 12:16:39 -0500 Subject: [PATCH 7/9] Add `auto_dtc` to `import_sdtm()` --- NEWS.md | 2 +- R/date_conversion.R | 6 ++---- R/import_sdtm.R | 6 ++++++ man/import_sdtm.Rd | 3 +++ tests/testthat/test-date_conversion.R | 8 ++++++++ 5 files changed, 20 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 58d65cb..142a0cf 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,3 @@ # Rsdtm 0.0.9017 -* Added `auto_supp` argument to `import_sdtm()` +* Added `auto_supp` and `auto_dtc` arguments to `import_sdtm()` diff --git a/R/date_conversion.R b/R/date_conversion.R index 7ad2133..678c6d9 100644 --- a/R/date_conversion.R +++ b/R/date_conversion.R @@ -16,9 +16,7 @@ sdtm_dtc_to_datetime <- function(x, ...) { #' @rdname sdtm_dtc_to_datetime #' @export sdtm_dtc_to_datetime.list <- function(x, ...) { - lapply(X=x, - FUN=sdtm_dtc_to_datetime, - ...) + lapply(X=x, FUN=sdtm_dtc_to_datetime, ...) } #' @rdname sdtm_dtc_to_datetime @@ -29,7 +27,7 @@ sdtm_dtc_to_datetime.data.frame <- function(x, date_col_pattern="DTC$", truncate if (!lubridate::is.POSIXt(x[[current_name]])) { x[[current_name]] <- ymd_hms(x[[current_name]], truncated=truncated, ...) } else { - message("Column ", current_name, " is already a datetime object.") + message("Column ", current_name, " is already a datetime object.") # nocov } } x diff --git a/R/import_sdtm.R b/R/import_sdtm.R index 46b4147..b93a284 100644 --- a/R/import_sdtm.R +++ b/R/import_sdtm.R @@ -8,6 +8,7 @@ #' @param ignore_case Passed to \code{list.files} when loading a directory. #' @param auto_supp Automatically combine --SUPP data with the main SDTM domain #' and remove the --SUPP data from the returned list of data.frames. +#' @param auto_dtc Automatically convert --DTC columns to date/times? #' @param return_type When loading a single file, what type of output should be #' provided? #' @param ... Arguments passed to \code{rio::import} @@ -25,6 +26,7 @@ import_sdtm <- function(path, extension_choice = c(".sas7bdat", ".xpt"), ignore_case = TRUE, auto_supp = FALSE, + auto_dtc = FALSE, ...) { stopifnot( is.character(path), @@ -69,6 +71,10 @@ import_sdtm <- function(path, ret[[current_supp]] <- NULL } } + + if (auto_dtc) { + ret <- sdtm_dtc_to_datetime(ret, ...) + } ret } diff --git a/man/import_sdtm.Rd b/man/import_sdtm.Rd index 86bbd4e..2b8e35b 100644 --- a/man/import_sdtm.Rd +++ b/man/import_sdtm.Rd @@ -11,6 +11,7 @@ import_sdtm( extension_choice = c(".sas7bdat", ".xpt"), ignore_case = TRUE, auto_supp = FALSE, + auto_dtc = FALSE, ... ) @@ -37,6 +38,8 @@ and a warning will be given for subsequent files.} \item{auto_supp}{Automatically combine --SUPP data with the main SDTM domain and remove the --SUPP data from the returned list of data.frames.} +\item{auto_dtc}{Automatically convert --DTC columns to date/times?} + \item{...}{Arguments passed to \code{rio::import}} \item{ignore_filename}{A vector of filenames not to load (case sensitive, diff --git a/tests/testthat/test-date_conversion.R b/tests/testthat/test-date_conversion.R index ccb3a22..fbb7eee 100644 --- a/tests/testthat/test-date_conversion.R +++ b/tests/testthat/test-date_conversion.R @@ -1,3 +1,11 @@ +test_that("sdtm_dtc_to_datetime", { + expect_message( + ld_sdtm <- import_sdtm(path = test_path("example-sdtm"), auto_dtc = TRUE), + regexp = "Detected domain SUPPDM from data." + ) + expect_s3_class(ld_sdtm$DM$RFSTDTC, "POSIXt") +}) + test_that("generate_dtc works", { expect_equal( generate_dtc(datetime="2020-05-01T01:02:03"), From c4f283826129f6c1ad3db103266a72840a51ee3a Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 12:38:38 -0500 Subject: [PATCH 8/9] Improve testing of `sdtm_dtc_to_datetime() --- NAMESPACE | 3 ++ R/date_conversion.R | 51 ++++++++++++++++++++++----- inst/WORDLIST | 3 ++ man/sdtm_dtc_to_datetime.Rd | 20 ++++++++--- tests/testthat/test-date_conversion.R | 3 +- 5 files changed, 67 insertions(+), 13 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 05bc1c3..407eea1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,9 @@ S3method(c_to_n,factor) S3method(c_to_n,integer) S3method(c_to_n,logical) S3method(c_to_n,numeric) +S3method(sdtm_dtc_to_datetime,Date) +S3method(sdtm_dtc_to_datetime,POSIXt) +S3method(sdtm_dtc_to_datetime,character) S3method(sdtm_dtc_to_datetime,data.frame) S3method(sdtm_dtc_to_datetime,list) S3method(sdtm_first_dose,data.frame) diff --git a/R/date_conversion.R b/R/date_conversion.R index 678c6d9..3f9c6af 100644 --- a/R/date_conversion.R +++ b/R/date_conversion.R @@ -3,8 +3,11 @@ #' #' @param x The data to convert #' @param date_col_pattern A regex to search column names for dates to convert. -#' @param truncated Passed to \code{lubridate::ymd_hms} -#' @param ... Additional arguments passed to \code{lubridate::ymd_hms} +#' @param truncated Passed to `lubridate::ymd_hms()` or `lubridate::ymd()`; the +#' `truncated` argument is always considered relative to `ymd_hms` formatting, +#' so it is used as `truncated - 3` for dates. +#' @param ... Additional arguments passed to `lubridate::ymd_hms()` or +#' `lubridate::ymd()` #' @return The data with the date converted. Note that all dates will be #' returned as POSIXct objects, so partial dates will appear as the #' @family Date management and conversion @@ -21,14 +24,46 @@ sdtm_dtc_to_datetime.list <- function(x, ...) { #' @rdname sdtm_dtc_to_datetime #' @export -sdtm_dtc_to_datetime.data.frame <- function(x, date_col_pattern="DTC$", truncated=5, ...) { +sdtm_dtc_to_datetime.Date <- function(x, ...) { + x +} + +#' @rdname sdtm_dtc_to_datetime +#' @export +sdtm_dtc_to_datetime.POSIXt <- function(x, ...) { + x +} + +#' @rdname sdtm_dtc_to_datetime +#' @export +sdtm_dtc_to_datetime.character <- function(x, truncated=5, ...) { + # Treat empty strings as NA + x_current <- x + x_current[x_current %in% ""] <- NA_character_ + + # Detect columns that only contain dates and load them as dates rather than + # datetimes + is_date <- + grepl( + x = x_current, + pattern = paste0("^", pattern_ISO8601_calendar_date(), "$") + ) + if (all(is.na(x_current) | is_date)) { + # If it is a date + x <- lubridate::ymd(x_current, truncated=max(truncated - 3, 0), ...) + } else { + # Otherwise try to consider it a datetime + x <- lubridate::ymd_hms(x_current, truncated=truncated, ...) + } + x +} + +#' @rdname sdtm_dtc_to_datetime +#' @export +sdtm_dtc_to_datetime.data.frame <- function(x, date_col_pattern="DTC$", ...) { date_col_names <- grep(names(x), pattern=date_col_pattern, value=TRUE) for (current_name in date_col_names) { - if (!lubridate::is.POSIXt(x[[current_name]])) { - x[[current_name]] <- ymd_hms(x[[current_name]], truncated=truncated, ...) - } else { - message("Column ", current_name, " is already a datetime object.") # nocov - } + x[[current_name]] <- sdtm_dtc_to_datetime(x[[current_name]]) } x } diff --git a/inst/WORDLIST b/inst/WORDLIST index 885171f..1504941 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -25,7 +25,10 @@ datetime ddd difftime ggplots +hms https +lubridate trimws wikipedia +ymd yyyy diff --git a/man/sdtm_dtc_to_datetime.Rd b/man/sdtm_dtc_to_datetime.Rd index 21ccd4d..8437fa4 100644 --- a/man/sdtm_dtc_to_datetime.Rd +++ b/man/sdtm_dtc_to_datetime.Rd @@ -3,6 +3,9 @@ \name{sdtm_dtc_to_datetime} \alias{sdtm_dtc_to_datetime} \alias{sdtm_dtc_to_datetime.list} +\alias{sdtm_dtc_to_datetime.Date} +\alias{sdtm_dtc_to_datetime.POSIXt} +\alias{sdtm_dtc_to_datetime.character} \alias{sdtm_dtc_to_datetime.data.frame} \title{Convert the character representation of the date in an original SDTM dataset to a POSIXct object.} @@ -11,16 +14,25 @@ sdtm_dtc_to_datetime(x, ...) \method{sdtm_dtc_to_datetime}{list}(x, ...) -\method{sdtm_dtc_to_datetime}{data.frame}(x, date_col_pattern = "DTC$", truncated = 5, ...) +\method{sdtm_dtc_to_datetime}{Date}(x, ...) + +\method{sdtm_dtc_to_datetime}{POSIXt}(x, ...) + +\method{sdtm_dtc_to_datetime}{character}(x, truncated = 5, ...) + +\method{sdtm_dtc_to_datetime}{data.frame}(x, date_col_pattern = "DTC$", ...) } \arguments{ \item{x}{The data to convert} -\item{...}{Additional arguments passed to \code{lubridate::ymd_hms}} +\item{...}{Additional arguments passed to `lubridate::ymd_hms()` or +`lubridate::ymd()`} -\item{date_col_pattern}{A regex to search column names for dates to convert.} +\item{truncated}{Passed to `lubridate::ymd_hms()` or `lubridate::ymd()`; the +`truncated` argument is always considered relative to `ymd_hms` formatting, +so it is used as `truncated - 3` for dates.} -\item{truncated}{Passed to \code{lubridate::ymd_hms}} +\item{date_col_pattern}{A regex to search column names for dates to convert.} } \value{ The data with the date converted. Note that all dates will be diff --git a/tests/testthat/test-date_conversion.R b/tests/testthat/test-date_conversion.R index fbb7eee..56a5509 100644 --- a/tests/testthat/test-date_conversion.R +++ b/tests/testthat/test-date_conversion.R @@ -3,7 +3,8 @@ test_that("sdtm_dtc_to_datetime", { ld_sdtm <- import_sdtm(path = test_path("example-sdtm"), auto_dtc = TRUE), regexp = "Detected domain SUPPDM from data." ) - expect_s3_class(ld_sdtm$DM$RFSTDTC, "POSIXt") + expect_s3_class(ld_sdtm$DM$RFPENDTC, "POSIXt") + expect_s3_class(ld_sdtm$DM$RFSTDTC, "Date") }) test_that("generate_dtc works", { From 5131b4b1c08a681283b112ca6a8fd5fe3d571b11 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Feb 2025 12:49:08 -0500 Subject: [PATCH 9/9] Remove `merge_supp()` and related functions in favor of `metatools::combine_supp()` --- DESCRIPTION | 1 + NAMESPACE | 10 -- NEWS.md | 1 + R/merge_supp.R | 193 +--------------------------------- man/merge_supp.Rd | 28 +---- man/strip_attributes.Rd | 31 ------ man/supp_reformat.Rd | 26 ----- tests/testthat/test-defunct.R | 3 + 8 files changed, 12 insertions(+), 281 deletions(-) delete mode 100644 man/strip_attributes.Rd delete mode 100644 man/supp_reformat.Rd create mode 100644 tests/testthat/test-defunct.R diff --git a/DESCRIPTION b/DESCRIPTION index a836ef6..5461ecc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,6 +14,7 @@ Imports: dplyr, ggplot2, labeling, + lifecycle, lubridate, metatools, methods, diff --git a/NAMESPACE b/NAMESPACE index 407eea1..09ff9cb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,8 +15,6 @@ S3method(sdtm_first_dose,data.frame) S3method(sdtm_first_dose,list) S3method(sdtm_time_actual,data.frame) S3method(sdtm_time_actual,list) -S3method(strip_attributes,data.frame) -S3method(strip_attributes,default) export(c_to_n) export(dateany_to_date) export(detect_domain) @@ -52,22 +50,14 @@ export(sdtm_first_dose) export(sdtm_time_actual) export(simplify_sdtm_names) export(standardize_sdtm_id) -export(strip_attributes) -export(supp_reformat) -importFrom(dplyr,anti_join) importFrom(dplyr,case_when) importFrom(dplyr,group_by_at) importFrom(dplyr,is_grouped_df) -importFrom(dplyr,recode) importFrom(dplyr,rename_all) importFrom(dplyr,rename_at) importFrom(dplyr,summarize_at) importFrom(lubridate,format_ISO8601) importFrom(lubridate,is.POSIXt) importFrom(lubridate,ymd_hms) -importFrom(readr,type_convert) importFrom(rio,import) -importFrom(rlang,abort) -importFrom(rlang,inform) -importFrom(tidyr,spread) importFrom(tools,file_path_sans_ext) diff --git a/NEWS.md b/NEWS.md index 142a0cf..fd164db 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,4 @@ # Rsdtm 0.0.9017 * Added `auto_supp` and `auto_dtc` arguments to `import_sdtm()` +* Removed `merge_supp()` and related functions in favor of `metatools::combine_supp()` diff --git a/R/merge_supp.R b/R/merge_supp.R index 6203394..e59b402 100644 --- a/R/merge_supp.R +++ b/R/merge_supp.R @@ -1,194 +1,9 @@ #' Merge a supplementary dataset into a primary dataset #' -#' @param primary the data.frame of the primary dataset -#' @param supplementary the data.frame of the supplementary dataset -#' @param remove_attributes If \code{TRUE}, remove all attributes from all -#' columns (this will break many classes); if \code{FALSE}, remove no -#' attributes from any columns; if a character, remove those attributes from -#' the columns. -#' @inheritParams supp_reformat -#' @return \code{primary} merged with \code{supplementary} where new column -#' names come from the \code{QNAM} column in \code{supplementary} -#' @seealso \code{\link{supp_reformat}} -#' @export -#' @importFrom dplyr anti_join -#' @importFrom rlang abort inform -merge_supp <- function(primary, supplementary, remove_attributes = c("label"), auto_convert=FALSE) { - if (length(unique(supplementary$RDOMAIN)) != 1) { - stop("Only direct relationships with supplementary domains are currently supported.") - } - if (is.logical(remove_attributes) && remove_attributes) { - primary <- strip_attributes(primary, specific = NULL) - supplementary <- strip_attributes(supplementary, specific = NULL) - } else if (is.character(remove_attributes)) { - primary <- strip_attributes(primary, specific = remove_attributes) - supplementary <- strip_attributes(supplementary, specific = remove_attributes) - } - ret <- primary - supp_prep <- supp_reformat(supplementary, auto_convert=auto_convert) - for (current_supp_idx in seq_along(supp_prep)) { - current_supp <- supp_prep[[current_supp_idx]] - current_idvar <- names(supp_prep)[current_supp_idx] - if (current_idvar != "") { - # Check for a class mismatch between the original and the supp domain idvar - if (any(class(current_supp[[current_idvar]]) != class(ret[[current_idvar]]))) { - orig <- current_supp[[current_idvar]] - current_supp[[current_idvar]] <- - methods::as(current_supp[[current_idvar]], Class=class(ret[[current_idvar]])) - if (!all(is.na(orig) == is.na(current_supp[[current_idvar]]))) { - # Introduction of an NA is a problem - rlang::abort( - message=sprintf("NA introduced by coercion for supplemental merge in column %s", current_idvar), - class="Rsdtm_merge_supp_na_idvar" - ) - } else { - rlang::inform( - message= - sprintf( - "Supplemental merge column %s type converted to class: %s", - current_idvar, - class(ret[[current_idvar]])[1] - ), - class="Rsdtm_merge_supp_convert_idvar" - ) - } - } - } - current_join_vars <- setdiff(c("STUDYID", "DOMAIN", "USUBJID", current_idvar), "") - missed_rows <- dplyr::anti_join(current_supp, ret, by = current_join_vars) - if (nrow(missed_rows)) { - stop( - nrow(missed_rows), - " rows from the ", - current_idvar, - " IDVAR in the SUPP domain do not match rows in the primary ", - primary$DOMAIN[1], - " dataset." - ) - } - ret <- dplyr::left_join(ret, current_supp, by = current_join_vars) - } - ret -} - -#' Reformat a --SUPP SDTM domain into a list of data.frames ready for merging -#' into the primary domain. -#' -#' @param x a --SUPP SDTM domain object -#' @param auto_convert should the data be automatically converted using -#' `type_convert()`? -#' @return A list with length the same as \code{unique(x$IDVAR)} with -#' data.frames ready for merging into the primary dataset. -#' @seealso \code{\link{merge_supp}} -#' @export -supp_reformat <- function(x, auto_convert=FALSE) { - ret <- list() - for (current_idvar in unique(x$IDVAR)) { - ret <- append( - ret, - list( - supp_reformat_single( - x[x$IDVAR %in% current_idvar, ], - auto_convert=auto_convert - ) - ) - ) - } - names(ret) <- unique(x$IDVAR) - ret -} - -#' @importFrom dplyr rename_at recode -#' @importFrom tidyr spread -#' @importFrom readr type_convert -supp_reformat_single <- function(x, auto_convert=FALSE) { - idvar <- unique(x$IDVAR) - if (length(unique(x$RDOMAIN)) != 1) { - stop("RDOMAIN column in x must have a single value.") - } else if (length(idvar) != 1) { - stop("IDVAR column in x must have a single value.") - } else if (any(c("APID", "POOLID") %in% names(x))) { - stop("APID and POOLID are not yet supported.") - } - # Columns to drop - if (all(x$IDVAR %in% "" & x$IDVARVAL %in% "")) { - message( - "No IDVAR or IDVARVAL in SUPP", unique(x$RDOMAIN), - " data; assuming USUBJID is sufficient for merge." - ) - ret <- x[, setdiff(names(x), c("IDVAR", "IDVARVAL", "QLABEL", "QORIG", "QEVAL")), drop=FALSE] - ret <- - rename_at( - .tbl=ret, - .vars="RDOMAIN", - .funs=dplyr::recode, - RDOMAIN="DOMAIN" - ) - } else { - if (any(x$IDVAR %in% "")) { - stop("Some IDVAR values are missing (when some IDVAR or IDVARVAL are present) in SUPP", unique(x$RDOMAIN)) - } else if (any(x$IDVARVAL %in% "")) { - stop("Some IDVARVAL values are missing (when some IDVAR or IDVARVAL are present) in SUPP", unique(x$RDOMAIN)) - } - ret <- x[, setdiff(names(x), c("IDVAR", "QLABEL", "QORIG", "QEVAL")), drop=FALSE] - ret <- - rename_at( - .tbl=ret, - .vars=c("RDOMAIN", "IDVARVAL"), - .funs=recode, - RDOMAIN="DOMAIN", - IDVARVAL=idvar - ) - } - ret <- - tidyr::spread( - ret, - key="QNAM", - value="QVAL" - ) - if (auto_convert) { - ret <- type_convert(df=ret) - } - ret -} - -#' Remove attributes from an object +#' This function is defunct. Use `metatools::combine_supp()` instead. #' -#' @param x The object to remove attributes from -#' @param specific If \code{NULL}, all attributes are removed. If a character -#' vector, only the named attributes are removed. -#' @param columns_only Do not strip attributes from the data.frame; only strip -#' them from the columns of the data.frame. -#' @param ... Passed to other `strip_attributes()` methods. -#' @return \code{x} with fewer attributes. -#' @export -strip_attributes <- function(x, specific=NULL, ...) { - UseMethod("strip_attributes") -} - -#' @rdname strip_attributes -#' @export -strip_attributes.data.frame <- function(x, specific=NULL, columns_only=TRUE, ...) { - if (columns_only) { - for (nm in seq_along(x)) { - x[[nm]] <- strip_attributes(x[[nm]], specific=specific, columns_only=columns_only, ...) - } - x - } else { - strip_attributes.default(x, specific=specific, ...) - } -} - -#' @rdname strip_attributes +#' @param ... Ignored #' @export -strip_attributes.default <- function(x, specific=NULL, ...) { - if (is.null(specific)) { - attributes(x) <- NULL - x - } else { - for (current in specific) { - attr(x, current) <- NULL - } - x - } +merge_supp <- function(...) { + lifecycle::deprecate_stop(when = "0.0.9000", what = "merge_supp()", with = "metatools::combine_supp()") } diff --git a/man/merge_supp.Rd b/man/merge_supp.Rd index 12d058a..61e7867 100644 --- a/man/merge_supp.Rd +++ b/man/merge_supp.Rd @@ -4,33 +4,11 @@ \alias{merge_supp} \title{Merge a supplementary dataset into a primary dataset} \usage{ -merge_supp( - primary, - supplementary, - remove_attributes = c("label"), - auto_convert = FALSE -) +merge_supp(...) } \arguments{ -\item{primary}{the data.frame of the primary dataset} - -\item{supplementary}{the data.frame of the supplementary dataset} - -\item{remove_attributes}{If \code{TRUE}, remove all attributes from all -columns (this will break many classes); if \code{FALSE}, remove no -attributes from any columns; if a character, remove those attributes from -the columns.} - -\item{auto_convert}{should the data be automatically converted using -`type_convert()`?} -} -\value{ -\code{primary} merged with \code{supplementary} where new column - names come from the \code{QNAM} column in \code{supplementary} +\item{...}{Ignored} } \description{ -Merge a supplementary dataset into a primary dataset -} -\seealso{ -\code{\link{supp_reformat}} +This function is defunct. Use `metatools::combine_supp()` instead. } diff --git a/man/strip_attributes.Rd b/man/strip_attributes.Rd deleted file mode 100644 index 522824d..0000000 --- a/man/strip_attributes.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/merge_supp.R -\name{strip_attributes} -\alias{strip_attributes} -\alias{strip_attributes.data.frame} -\alias{strip_attributes.default} -\title{Remove attributes from an object} -\usage{ -strip_attributes(x, specific = NULL, ...) - -\method{strip_attributes}{data.frame}(x, specific = NULL, columns_only = TRUE, ...) - -\method{strip_attributes}{default}(x, specific = NULL, ...) -} -\arguments{ -\item{x}{The object to remove attributes from} - -\item{specific}{If \code{NULL}, all attributes are removed. If a character -vector, only the named attributes are removed.} - -\item{...}{Passed to other `strip_attributes()` methods.} - -\item{columns_only}{Do not strip attributes from the data.frame; only strip -them from the columns of the data.frame.} -} -\value{ -\code{x} with fewer attributes. -} -\description{ -Remove attributes from an object -} diff --git a/man/supp_reformat.Rd b/man/supp_reformat.Rd deleted file mode 100644 index 29f58f9..0000000 --- a/man/supp_reformat.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/merge_supp.R -\name{supp_reformat} -\alias{supp_reformat} -\title{Reformat a --SUPP SDTM domain into a list of data.frames ready for merging -into the primary domain.} -\usage{ -supp_reformat(x, auto_convert = FALSE) -} -\arguments{ -\item{x}{a --SUPP SDTM domain object} - -\item{auto_convert}{should the data be automatically converted using -`type_convert()`?} -} -\value{ -A list with length the same as \code{unique(x$IDVAR)} with - data.frames ready for merging into the primary dataset. -} -\description{ -Reformat a --SUPP SDTM domain into a list of data.frames ready for merging -into the primary domain. -} -\seealso{ -\code{\link{merge_supp}} -} diff --git a/tests/testthat/test-defunct.R b/tests/testthat/test-defunct.R new file mode 100644 index 0000000..4b970ba --- /dev/null +++ b/tests/testthat/test-defunct.R @@ -0,0 +1,3 @@ +test_that("Defunct function notifications", { + lifecycle::expect_defunct(merge_supp()) +})