unitizer/0000755000176200001440000000000014766411142012131 5ustar liggesusersunitizer/tests/0000755000176200001440000000000014766101401013265 5ustar liggesusersunitizer/tests/_helper/0000755000176200001440000000000014766101222014704 5ustar liggesusersunitizer/tests/_helper/unitizers/0000755000176200001440000000000014766101222016740 5ustar liggesusersunitizer/tests/_helper/unitizers/nav.R0000644000176200001440000000020414766101222017643 0ustar liggesusersz <- 24 unitizer_sect("A", { a <- 42 a + 1 a + 2 }) unitizer_sect("B", { b <- 25 bb <- 26 b + 1 bbb <- 27 b + 2 }) unitizer/tests/_helper/unitizers/trivial.unitizer/0000755000176200001440000000000014766411142022267 5ustar liggesusersunitizer/tests/_helper/unitizers/trivial.unitizer/data.rds0000644000176200001440000001106414766101222023707 0ustar liggesusersiUsal`bUBq̈HcI5r@NH$'{!UVԒZzj=i42[5u{ݯ5  /BqA(杲PFa*^q\[͊Lg,>$[JdJ]+#s>ߐy8ǎxA%d ϭ ,lQ" Se .I.>V1AYtJ 4*KE(PF695*M,EԼȋØqejȮa$e*H,RӂZN-7fqfa^#~qc NhzA4f6-TDKZZeяDobU7DWy < ,Q.Ej=~L1ef`FO~P2Qxs2sZbIl;Y~M%cT3lRSi ՛,'\V*A2hIHuUyrd73u|!jIȱ;{><0;TGxƺ\,s_y y-RqGtӝNulH0n&*2 G\.0m7:#A-^/ $Lq+rgEY!~FFݜ;EfVCGNJ`!3j4:[(p%ߎrçc;QƳmRы}GڮQeA!G "2̜ʵ_tly8FWdǘ[)Ѩ݉؝{4,Ni|gށ6^<࣫u#;&ʃo`kvc[lKk QAYoIA70Fc.1*}4edx=fG!x4LcL IiK&|0;~63d#QfBBBŒ?؇k<V&cH0r`b^H9E)KA9-qC6 m<?/Ƞ'1#^4!7\[׈F I(M [4" %.>Jw[̈́sslXbTj :KlHTn\4K+>WL=z af BJo{"DbSőR;b&|χ1b"*HlR@Q!Pjx\:>#Ϲ>䡄VU=m1me5͓m/ vCbڻ6{>Iݴ:ͮ5  L;JU"mBHxt[N|ȧdlw %UQP0TCJs[‚+.-ͦ ˦Ja)Zp4W-Cԙ@8=ǭ mU{%B< YOgEg}8[u2ccUmd}a锍,uFpEnD(vaņb6d\#3MRHEl$9 IAoۙaf{o%rYR@ CA},DF+IT0i~Qb|C%ʾAh-xHcکSrf n0-1a`Z+zXTDet H%zM)ԃ]$ܡ14r;Rv SO,BI5|#uFĉhDg QqlFBQDE3"X7lv<v!sXU rɉl;ӗ0O R$&5)hDhWfn8Z ˱5@Ӛ[эYi}-.ʦ-R%ε,qV>|:Yr5\UIX#L(UBՁ\mN̒=`Kꟽn]RYRzpBBC1MPʖKHCL7HbJ3G~oO#ܛj50;h(p c'nʜbpx*k&`:f +((UjX>bkʿ ^~bUSV$%/3h53P>2`Y"!]MUecr L]9$Չ\!bfP4 4^ ;2 "gxD5 AG{bz.^_HXpy""xO=*VpN eʨRqǸQ8je\_ŭ^f:3p}o/C`Og:>-9%6sx#6_Qä1k4b$3'x>5JZB6#pI]1zY4Mz!_ٲ~cYn;G S.nI w(s_ d"tHvfNWٶŋRdr:ObV g.:|#}<; ΀lObԫ<}q'c=UxaZ{,1'ԍtvދ@jI ==$*}l$hG 氮K$併SȸW ׃D1_y_Z͑$_dwpF{ T@NfR 7B_Epߊ1dF|'~<ހ:_oJiipFh֑Vfi$VlRi݌-D~j$ۉѽsm=>ȧ㸊v2xyà,\ܿ/K5f@mɿɺ4>vzi|,(d "GidRjH*5cyED?Ҏ >;# u^]m59qwO861=I᠇_3CEYAyc| w)庬ՈfUVT7TB }mOe0ZM- 3o|JǨRJ n"92unitizer/tests/_helper/unitizers/misc.R0000644000176200001440000000046714766101222020025 0ustar liggesusersunitizer_sect("Compare Returns False", compare=identical, { 1L runif(3) } ) unitizer_sect("I'm an empty section", details="this is just on of those tests that I had noted to myself to do") unitizer_sect("Another empty section", details="this is just on of those tests that I had noted to myself to do", {}) unitizer/tests/_helper/unitizers/sects.R0000644000176200001440000000040614766101222020204 0ustar liggesusers# Tests with sections with funs that produce output unitizer_sect("stdout", compare=unitizer:::comp_stdout, { 1 + 1 }) unitizer_sect("stderr", compare=unitizer:::comp_stderr, { 1 + 2 }) unitizer_sect("stdboth", compare=unitizer:::comp_stdboth, { 1 + 3 }) unitizer/tests/_helper/unitizers/trivial.R0000644000176200001440000000014014766101222020530 0ustar liggesusers# File used to build a trivial unitizer for tests TRUE x <- 1 + 1 x + 2 y <- x y * x y / x + 2 unitizer/tests/_helper/unitizers/fail-and-upgrade.unitizer/0000755000176200001440000000000014766101222023710 5ustar liggesusersunitizer/tests/_helper/unitizers/fail-and-upgrade.unitizer/data.rds0000644000176200001440000000344414766101222025340 0ustar liggesusersYo6wwA)lLHQHLʤiQ4ie%vl'}i2M"8I;`R+Ǐן~h*VU?q́hws u|7p \W c SF!ejإ_]"JUr\ٮn]%v1=٭&' >}d3A ^ۈbXHaτ,lːٯ͚#ۆ]}Fy,w*OWCag!vStσ2z`@PƢ5xKTL9 (xMIn40.0ZJ |cBU) H1ށ]=j\dl$Alm>w RRS3)\j-l 9hv2gx1 ̋p2) @t!I+!AVL 7i2n"jI5*g$aLE ݧ"J;zO6 dʹΕ]5LԬ7MTr"L$>K[ 3єQx*:>HAp?K\Ai0Y3|R't{**w˼(̏nLrF̻%w⧥VtAo" $mma4ETt.-Ÿrc O깋+* V.YJ\][1+S-ߴ{p'j:lhĒ,obF5B;آ!-:wX@ ~)h`!fa:1 (`f1X/Ԛ$ФT.1s  $(*0clY I, 8V:'} B*4'%п.M! %+Nkeáb1J[/~lF}IF]xW[hs9C/9, P`ЊfXKuC(x$S}5yoFڼثJ d/~+/ }ֽ*> 4SYwA޷JE)G!zL#Wg9:0 Kψcm>נ({rwM}%ۇ(D.w9@p(@ؤ=l`X&!+cVN}2!fkGf)2Gf9at%l<,*'ɩi#:A?3cgƅ ?G뀧uoŗ3,\OPVgB,|ˑ}creyq. k [H781L< .z E5>lp뫐&ˊN_Wg]0~4?#fT%p7λ=Dޠ !'xZQ='?(KFGx_N-'$ ؾQZFU5_KMg3 : uUԨvMOB+eB)<U]|ptI]E7χ@ De!YȮ&Sʔߌ7Pˈ1BUS*bMn̩̪S:l0.LTLfyHa9X\vhݨtݸ MZ&Cz _s>ա{ gkp/fYȣC ӂTp^i`f Q5H贒RgE7N `T>bm_AuThaP2(O@4bRG "ty\F;2?IbϘ%u0Ng]D}^mnMX\Xρ7FtnsD-÷kW0#/ ]FCn}7 3:gِR+~D@QRsla)QD/ 8eG8{uÙKy\Ы{(I:~foʬnwX25uzbI|vzLgNOONM;`)@+J MVgA:\UCF劳%%w#vk[4d(;릍do[UG*0S.oH/= Nh)N_^Ϫ|N(G| f'&qץݛsE4:ZfXeobEmnSjך%B{29}@ٖ5CD#;#)'d%{<vz~80uaYANr|L`[ypS-٠5c)j:B^DM>zxMSqyq]z}A|ӥkF}h9ΔgrEeU_A+R>rLϜ,Oγeo/=rrdvZim\عӠVqzc<@沑fjl榑0g9;+p1^G Ë_fʟy7/]};2~9ґ"jlvQFE1E.*,Mu⥁}_N 7nC25";g=HiyR\9&yy]a? ?L2u O mPY$O>UcTZfg0 gi 8 L^㐠?h%[6w(T&AI8*ɕ8YlRTY;?Jϻh;)}|}"d%x^П탴|I cS(M&g@0-OH}Lv>NvƧ ;-@+d=ПwV h?Oϙq h(g"_탴iiqP2%g/ZB>J&}@1OFBFzi#MxGϪ{VEƅp𨘜j!%:4;(ek pC,]`B8n JbQR:X@b$_1WݙwMgޟ`fmB.y/RGg])+\~vO0~BnPQgV{APgO >mz$o8ё?x"H9 %>}d&==!`!2~63I E$tduin9:;_5«j4SR;.!nK/Vnݩzd$G-Yf0u}swE J&+sjPojs?DQTq 3N+K%6-WS~fD ThoroĈhQb\^Ծ6uXPs5Rѷ-ݪ:p5czӧ9 $@Ĥ5Ep^މ]ww28 hNZ*J2H^aLDf <rhtC>U&c])\fp7%{l^5{yqrb ֭K3#pZa\1M=6)SܭيQ%]Bnq*bJՍwJ. f55#z6 ?.=/4xi|? Cx Nm!a>E|baۧxU1u=7 hO;i=)SdYaG jfRpqͅp[lɭϷpkC~"!"Ab5"B"29Fd[,A6xw4DNPp5Mh *pO >8fmǬtq}7cLn'?>\ġ}CnCI`k8;N1dh諃PG;4%ݧNn'dUwzYʃV06$`;;Z2BNz|7Xͅ$ tS ]=%`zn<EH=zƹeow)o~ C>qj'C>bYan3Dd;{?&"1s vb\NfL;]J$^f NBk2KZi*X(W%oc&?FLEU$~c,||Jh,Gݱ{7+E^GYdz]7rtp7duѮT1,ic%MfGr1ɏtGFEȍ<1_L[hsoXmη6Rwy@%"{y! <2wcTjY!!'& ^U:@nmMQm&G" 3ږfޏ90RdvsP$X+V }8㲼X0| ַU,i[ꀗ_OdJQcua=Hq,O[P2} _p!mY{-o8Pd;d^Cd5#(""6ũڭ_AaQ@2vU\v78)@{,Q'3R:UR?Հd3"\-U9ڣ7tKyd5 N̑wԬ(ȑ{ ~2ۀB˶H.BqwerV*}BF-*"(L:@Tֱ0 %#Y;B>iH2n' "ǾQZP-Nq%[[ɨZt{{@sX3-.%myݶ(Cn39߁îzx-?m:uh6>v(;߇y1k}G"fCM]DNJ!j!"RHNKPZ|pc7ʇ?_v~JNunitizer/tests/_helper/init.R0000644000176200001440000000250514766101222015774 0ustar liggesusers# Temporary dirs, etc., to cleanup on exit. See _helper/pkgs.R for their # use. START.DIR <- getwd() TMP.DIR <- tempfile() TMP.LIB <- file.path(TMP.DIR, 'utz-tmp-lib') if(!isTRUE(dir.create(TMP.DIR))) stop("Unable to create temp directory") if(!isTRUE(dir.create(TMP.LIB))) stop("Unable to create temp library directory") USE.PKGS <- FALSE # Global options options( useFancyQuotes=FALSE, unitizer.tmp.lib.loc=TMP.LIB, unitizer.state='recommended', diffobj.pager='off', unitizer.show.progress=FALSE, unitizer.color = FALSE, unitizer.transcript = FALSE, width = 80L, crayon.enabled = FALSE, diffobj.term.colors = 1, digits=3, warn=1, aammrtf.ref.objs=file.path("_helper/ref-objs") ) if(isTRUE(getOption("showErrorCalls"))) options(showErrorCalls=FALSE) library(unitizer) suppressWarnings(RNGversion("3.5.2")); # Cleanup on exit; no output here or Rdiff will include timing FIN.ENV <- new.env() reg.finalizer( FIN.ENV, function(e) { if(isTRUE(USE.PKGS)) { for(i in names(TMP.PKGS)) { try(detach(sprintf("package:%s", i)), silent=TRUE) try(unloadNamespace(i), silent=TRUE) } suppressWarnings(remove.packages(names(TMP.PKGS), lib=TMP.LIB)) } unlink(TMP.DIR, recursive=TRUE) }, onexit=TRUE ) # misc helper funs coi <- function(x) invisible(capture.output(x)) unitizer/tests/_helper/pkgs.R0000644000176200001440000000277514766101222016006 0ustar liggesusers# Setup helper packages used in some tests USE.PKGS <- TRUE writeLines("Install Packages") TMP.PKGS <- c( unitizerdummypkg1="unitizerdummypkg1", unitizerdummypkg2="unitizerdummypkg2", utzflm="flm0" ) UNITIZER.DIR <- system.file(package="unitizer") PKG.DIRS <- file.path(UNITIZER.DIR, "expkg", TMP.PKGS) if( any(which.inst <- names(TMP.PKGS) %in% rownames(installed.packages())) ) { stop( "Packages\n", paste0( deparse(names(TMP.PKGS)[which.inst], width.cutoff=500), collapse="" ), "\nalready installed; cannot proceed with tests" ) } # install.packages does not work within R CMD check, and it does not # appear to be by design? inst_pak <- function(pkg) { old.val <- Sys.getenv("R_TESTS", unset=NA) on.exit( if(is.na(old.val)) Sys.unsetenv("R_TESTS") else Sys.setenv(R_TESTS=old.val) ) Sys.setenv(R_TESTS="") pkg.inst <- try( install.packages(pkg, repos=NULL, type='src', lib=TMP.LIB, quiet=TRUE) ) if(inherits(pkg.inst, "try-error")) stop("install error") } inst_pak(PKG.DIRS) writeLines("Setup Demos") # Setup the demo files used by a number of tests. All references # should be relative to FLM (i.e. start with (setwd(FLM)). This # will avoid the temp file of the directory showing up in the files. FLM <- copy_fastlm_to_tmpdir() FLM.TEST.DIR <- file.path(FLM, "tests", "unitizer") FLM.TEST.FILE <- file.path(FLM.TEST.DIR, "fastlm1.R") FLM.TEST.STORE <- file.path(FLM.TEST.DIR, "fastlm1.unitizer") setwd(FLM) # For whole test file to avoid temp file display unitizer/tests/_helper/ref-objs/0000755000176200001440000000000014766101222016413 5ustar liggesusersunitizer/tests/_helper/ref-objs/load/0000755000176200001440000000000014766101222017332 5ustar liggesusersunitizer/tests/_helper/ref-objs/load/nth-value.unitizer/0000755000176200001440000000000014766101222023105 5ustar liggesusersunitizer/tests/_helper/ref-objs/load/nth-value.unitizer/data.rds0000644000176200001440000002420314766101222024531 0ustar liggesusers}kyKh=A@P""=7;˲VT*UgYSexdMY6B,mYşyGxer^Ű#~ГԄqaȮ^}!)zj+4L+R[ BHPfjPQ|} D 5ƒC]wj\(2|mA#jd!ѝD'9I ?Q%G9ޯz5ӭsv9V/:aU4aU}< _v\xz1{kJlMy_z^p cN~DkҜJ3'i.O$7O4x s'z d))AӽFOcGR}(SK5:ќє^jg^p[D҈d87xZ5P"7V_x25BBY贰ꛁT%xUE/>!a@/z{U5xjٞ˂> H^ NUIOb^8~F( },w}`=C2 3Nhx f ؒ0xԷ[wNNPVƓAi=ggjHO QԓjVBБmM7hMj7϶s_A"TAہF-Cֆ )غAoB- @qY'7Ta(6kzDbZ]FQ?v3\@Bzf[Xjh'7Z F*OtE9u4}bE+Z!(֣nQY6$x曡R )WSUIcu}El 'zT`Ta5%Jk ݉b/o>'מ)KJ4v;l@kYlDХ7A hdL#ޓ+O ^rg t*jlsZ@⃴qn+4}dct `$A+<`'+`|/O6Ľ"%$n\l߉XDc9jkh"dzRX4R.R!]HAZDP҂gkpq).Es* lA2 t>aJw cƾtRDv^R٥(Z _Y8NBJZ߄ͦ%]^D OR=찻q2`u9=lnx(ȒG*(FҍלG^:~v3|(k2H-P#<]G֖sa&0&L~7flf?Y +|}g$G2쯦'pP((ĴUk׮FUiI!ItSq&ڭ7#se+-_`}HDA"yVp~Kir T15H`x 8v7^%Jo=@ XpT򶇥7LH24AvsEE\)#0x@zA(,,FWPV_/2/U( -~"R RH2+ y5*)r>ֽCq+@"A5'4+g&=P.zst_AaaruT4ZZFz~ [^Mn5`F%ȃX` 5Z!#P!O{dv:C] -xPpST:#r}+uo5JO8HY#iop)7Ty1'U~mgw*P,uy\"TG @1xCJpGIߑ^cLJCoԯK ?V1נ i U8*}eT24q\Sq1 +IVRtXTDIE/IEXo\HEHp) :T[R2ymҔ0RSJq=OVV>͵qYsͧ! x8: \",.xh;7AJQH̑5mՖَ {A척-!nEaUId2ƾ~ftmNؽWX[y-)ħHCη4xBI4mAsw7TZw9ўPR; dT2SrT`د M히 [:Pa/VMvF.u{sǭ"kpA\цUSʖrm6Xr Ty;WwS&4؅r_=>m;^> X=#9n7{&OD=\&)w}M;wl'3T9THi.#b_UNh?U=ĪFT-w:?='hv| (WFWshT)4^=э:CXeFne)׹,M!ldsmK5QO=|Kz{g M!@[>gzϻ r}Ršӈ*~PfQN\7FJ;\W=|!ɑqUqI8H$R("q5Nױ'9c8Q-UTV+Tx>3x]f#t)K;ds:Յ%󝔮M3*[Egb{z~3=?(eZH6rFNX_f%R WNXvI#?j&$ϯ>J_Wv[onaGʩ&ޫwj0zߜb}`d#яT@~q:gVT3@:>.(/sПaVF|O_뷮ܪXX) NsȫȮGr+97µS+ Fp-7/Q5?ڃRn5tqNej3~5s_L/]sNAN[|NQrY|Y><2g03UO@g.(Sbrt1B=9RH";^(,}ԐQ/wtjP<F!ͮ4U3O>rbJ W>#VTe3hJ(Ы-Z2Ҧv~/GE6belNRyK33Ϙ@Ge)Xn_a]"?y-KG*を4$r ]E5dtSv.y=m(=^42jlFg`oy[- qK`z#t!0)$e-TDZ?-Na;52.*h[)KUINd6 ET/5UX+c*2iQf P_CXfkBIeUC~Vg(v/=bӚ_t~X(3~7Y0olU,}A n>S[Edl;fD-"m_3F=bn\`$7$i]C~uޏs,iT?4Tv-7bSej|tLd=“R'pPJ%v7I){J$#7-.Px+^ISHKm;~p;$'ǣz(1\tRϤf?:w⧩񏾲 :RO\|S"~EPh@-h :Ҵ*m7 URտ_>bGFs__y' ${t J/;WR yU7"/tƚ~e+[ =} 6/GlD^?GjdrET)L!]>7lV!gׇ;Y-Žԙ֨u@ڞ(7Sgj?=xRgtcqREy?^"={u]yY_:(B]],oA NAgCǣ!Ɲ*JlۀDe3:&F笼vZA>ޤ4jaYg~bT6q9%dLSq|М f׌70 9e9 TD쀘R4OBzAM8>'VuAvOuN&Rw<6 o[CۯZ {gmb$v }j_o'dKpEut×ZhK7$|n#vS& ϥsZ~tf 9z3:,ԡs`_)K+L։'2»r>I|MAEÒ" /굟 ܃ fxŗCp4 fq+ .nL &LGX ۉtF& /nc"S߾`M`=7IavթөE1Cl͘E3Z08nPe@&Ay QE=+^ KNH.nn[wo8[byz!hc4+L&70іơ9f=4MnbcМry,7# ܢ^0sU#VO`Ze+8.X}*^DZD m5tO$t%-IQ$!eT v-3#/ϨvtoC$;܍dCH*!u7t7Z@=K9{ ]&&^̮1b>ma\[Jҁq9LK@-Hk2J!MG1YLLK1)#,"OkDF"aFLN\+&&99>rra_IN2/,<#,9Lj[6rOhy`_ L@^VgYy2GVdOڈr)y7BR#CǽZ>m)?L!}_^~QBv(YR_6K'bžXM-?%bt"[w9at(XToY!-R5,Gefx-(7nbtec~lɽ 2QQEj:cjc YLBb( -&e&@&H)AS„Sm S$bUy"h_X4!}h 9R4&@9ZA?fY7&c`ҙ41 WaJ>J,a^YCA*kݱUBɳ0Bu݇ vk/Rcӏ){q~r5⢗(v:K*hR)a:PO"/Hq؛ԤUx;.q <)hјˇĭ5 `u]&X',i  .) ƠD"lNu=H3.`^a\;ήw-Ž78_IŪ* ةyAvJdFʦ1'Hp Rd,h6G,i'UJtٿmG;462nB= nG36 X(]k|nzL8DN ⽤8;Gf ;n@#Y8|e4\ rWQrJR(pA / ჿ/W]FobGXE܈ֶYDߣM~- x߳% 3\x@'oQX2%@!`~o(CEd͞#[lL)&י8GT_u7ձr3MTTcdJ^vE %;DϨ*OrQ0gѳQ°{]/Wb]){q׏q]'t:;'NXm٘I(eo YicI?)^xPa͆&j5rJ3 6a$]K'w?i*rgT-ex k_Ss؋o}βf$l+mTqYUV!-#TBl KPZ**?! s%}xony<˄R˧@p{i+}B))VY DjM7LZB^(wj,lH6.tH }ݓt]=jfRD^HDMζ5ε\Sy3/(ye ġ|e \^$w/pvc`=iF)Wp1vݕA|32}/)/ Pj afw{\eۘD7 X̠يgs{J{}ʥOr]XpSZ~Kϱ25we| -]2:/QbPL\Qɴ¯YM5ة|_Rթhܚғس7%V>~4F܌AcKǬ1wW]Z}\}|TJb+(}4_ҬJ+8gLoNӓs~X~c*M Wi*ШԱ]Cjk6#"SD~y"Th6 c1qMs~JJG(r%3{ʛv<,IkL}iv] L׎)>ot7͙҃fz#}>~O+KV]~?%~<6{@LH׷irSi-u3Z#Ĭ7LY+ZCfMYBY\mxQhF>~ʼIi` z!> ״&#fÉ:љ'VNO uC]6k\r>+CRBl&HW҅JaAb?<H!!Àfhbk憑țEf0b(s@:~3k(Q~-:b<`D(*{ /ܝu5zD@#3b>@/I/-s0'͆sT[5L/`kT+Ɠ]) |эEٮn+M!_P 9JծFD#ͣ} ]SLR;C" 79?4u}4.58lu9+ ,h:.4icy_R'r @"'S  l m9DiXKFn\|D([v?cҫe'F BJ,NYS̳Cϯ}`QT=)]1Edr4:4a^I(2{Qqk<(|Nl~KO{[ QWAX>lj&ge D$X ^&8|D&׎-htC^7va(k{i`Ya2 d4HuZ&E Uup^hN!}K"2ͮp;Zђ!h ׈z$O!%2~Ќg*rXI.dRYlWUO}ֱNMʙ@#HMa ҲشpR5ܮw#QkbHT'gi0g(TiSqm2Ow` AdVx$mǵ,]DLe t4zPML=bs0%o,՗|qbwu3.(V/iж "bIzHF6Mr1xSx/ 0+K[dc/B8Eئ\: iI~(·L2X>$IxOXwl`cylj B\ B$WTE^L aHȻ&:I=Qc#Ttt2E: 4}rd=fgB*̀FgO]$e [tjm4D*˜s7ej%)Tî5#+̶vk^pE+ө}r& gZԑBZ,Y];pB#ƽO ۲B%hHّ~ɝ"=Ul~ *jE* V MP!#UI5'챏02="Dm'j׌ڎoR3͛hDVj9$eCͳ {_pA$ Yt|KK+ lRVOc_ Wt8gZ% S60'z 7RO8bwZ5O[_^b80߁-A@YC2V/Y'SH|ߺ8w(/2C])^DMS'X564iRE~e>-(J-R6Pf[@Xp%>T3>~ܖiaټno@fZ6cf4 )8˲y3y?\>.Gb0xiHxjQIY4ߔȧcwl# QrƚX~z0 cU/W51k@jĦP{Ɩץ6Uyh |h~*P_o Ù/H<2Ե&xcW[)Sy1iSQ:8 >y? )ԡ@3 hU6t72@S՜D^Di?Jo"if/)IkF OTPX|5i?Αoˊ%Qerv{ Eʧ}wʳ[(OÜ@BR*@|XHn~Kx |}*NtvzT)[]L-ra/+F5ۧCt6~oT՚g;mzO1~g(2g1~ܑtieTR?ß풬83(}H D\p`rd`!1f`a!xLh ۈh<όx3W3x0{8TqEyqQg*ƚ@ (0:N,'onAjÎ8zBGzL҇\3p/WOw<;4UMW?$e$]LJV|JQ`π=]lw]{>So]yɻ-aM@;eL!뜶7k9XǑwMzA"zwػ>6ݱ-ObYAײنrM?_dgI q%JSOSu_'A6HQAToϭ2] avH6YmEHT7P $uVSy76iР̈́aD=Qm#/@++hk?0L%?}TУXC)!wc ؃3~ύ:uOAԝh~vmU)o P2H*Gǯv9<$+7KQ.C~; rf[6P'8#%2;\saࡋ|.t= \{$w(撷/D"e|biߕc{9F-RBn56%<<1bZgO/ QW}#'m3\Biqោ:5O|iG!Gmmn8 Iwzh.y/#dJX|aŃ{xkHSa a" oqNDYeOm[顚s>R=܊:!/ͨUѓiJC&+~X$ya3zUGCՊifJ1/>J~E&$l{|,@/O+RI61uѲߨ@c $YhTݺdۧ|d8d=eF2r ӫeDǔ*=S)/ɺۗkTD*єhBTeDa [` c)Z:8i;įΏPS3P~Snk2 R?OfeqD6 K8bf_Qq*10d {R}Oj(H;J@3Lٱ/nIpOĝz\y'%GZX%aBR ?J ¼W^$;2FzA+>p{d:k @ծKAJ 3[4R: 6Z#1XWh]ܱFsb-o]H{pe:-\/AGy~ok;q+i.aRC `#n$麶yRz, K?:NU.E!vR]\I]dLOOv!O;wqa{ {=05-iYt #.*2Xy~مAȤKBo Msc ;aQMyVXE١Xj 4ud^/d玛NRIXLu,IVmIw71< b12?nH3y!}KԶ/iUliDsSm$%/o$/ɩmo\[qM?J4:QoVrf 9)Z*$Qd ggO٨8K 1/^00nY iS9֝Qp!tUV"&{ql>uT?pP$BkX` D`˟TY~G'Dq; +[4*D?G2!@Z"3/Mc3w}eCFܨJ "[&Ӌw4QG2TcIC7ws OK4U i&&57{/H8B/&\D@ hIXǐҝ)T A B0ڌ6hx?*(NXǭ2E/ui_'O)oC~duLL`:+*Ri\Fgo]R^}8@[ȔouzDx2c]DRB#5sE)+IKɶcK{S/Τy\v?Z#BrL#T< )] 2?IWgae 0}=/2;NHwaJ|rdtUs;CF頞 *PcK:鯄u5!dޣ_T  cr0>(PGMcHITdKz1uzjgO8NeE Cit 5.OS];0ye=ؗXMljMseE깊|J1/8Eƈ"6P u wj9)K ) 04~HV'm3H2 &MraHJPfv1"ҽy~F V¡PwgOl ٥H|c{ЁrIt6IQ J[zDlmYn8vm;׳-6p\7b٥Ȭ#ӟ,'`%o";W+lPiw)Ҽobn&f]}d"pCs\C|G!'Jնo”ҌJ~,ӍiFn"y{?"P[ֳ'F:^"/;OqOƚQlxMԑC mX>Fr -(=_7LJNխ|unitizer/tests/_helper/ref-objs/load/old.unitizer/0000755000176200001440000000000014766101222021760 5ustar liggesusersunitizer/tests/_helper/ref-objs/load/old.unitizer/data.rds0000644000176200001440000000151314766101222023403 0ustar liggesusersWMo0un] Rဈ=@[ ! lđl%NqvbniAbTZmyy3~^ \9r=B#W9h{b!=ZVj{8L0caUs~ESYfCq a[IHc: y '9{վAڸ[*s!kroHэ#{zI&IPd156 ۨP?ꃑLs>90RdvsP$X+V }8㲼X0| ַU,i[ꀗ_OdJQcua=Hq,O[P2} _p!mY{-o8Pd;d^Cd5#(""6ũڭ_AaQ@2vU\v78)@{,Q'3R:UR?Հd3"\-U9ڣ7tKyd5 N̑wԬ(ȑ{ ~2ۀB˶H.BqwerV*}BF-*"(L:@Tֱ0 %#Y;B>iH2n' "ǾQZP-Nq%[[ɨZt{{@sX3-.%myݶ(Cn39߁îzx-?m:uh6>v(;߇y1k}G"fCM]DNJ!j!"RHNKPZ|pc7ʇ?_v~JNunitizer/tests/_helper/ref-objs/load/borked1.unitizer/0000755000176200001440000000000014766101222022531 5ustar liggesusersunitizer/tests/_helper/ref-objs/load/borked1.unitizer/data.rds0000644000176200001440000000011614766101222024152 0ustar liggesusersb```b`fdb`b1y'3@,@ l@5,L`u,`)@IH aunitizer/tests/_helper/ref-objs/load/internals.unitizer/0000755000176200001440000000000014766101222023201 5ustar liggesusersunitizer/tests/_helper/ref-objs/load/internals.unitizer/data.rds0000644000176200001440000001712014766101222024625 0ustar liggesusers=[qؽSeɖ%,iȲH2_z$ԉ>Rg۝݃V(Kb;*'J$qU8N*?]N/USȇ鸊yAݽYN=====3WaTJըNFe]1]*ƴ1Ϯ t|0 c@ziRF oCahbfxD,ٶ蠋A(Scɢ9[îG;42X zIz@/=wI_?a6ۢjv"S_}DzL(TA=pзBےeiq*{ycҽ0 eU'%SQDpH&GI3vőD;/a MxǾ6`N:J6'X(dS!)M 5䬶Lk_3WiȁDkv Aޤh@$nțԳfБ.apx;%`,:L,fx 3\NW٤H{.mӉ HD5s}bG;Zr ͿaQ?)6DZWVN+ɅL*km*bi=5:vӉB5hF4C) \YV@א۳^$R"jm\hlѺ7MqB6& 8}ưDfwNx{v\ODZBGG,6'Sy RcyA)!v^3Cb&m "'}tm`m$!+a3 1$G{cQ;"  {DI6#$mʵدvJwx"|$eC2uV6ݞgKi*]ya.0!ē+-'hTdziRZiZa2wͤF\2&$ӞIֈ"a0zsQ¶ }tW[("lӯD^ cS*MM-$#IrRDMe`"#v唸813QoX~_5A0=],[9LW/t&Vr_S)dH&H3p3J$do9ϘLu2Aq0N-qG"pD/Ϫ,@݇Kϫ0a'K[´yciłAV_ 8 i V%pM.v̨ baJئF$_B g_.XTp]31;M}Ջl ;_b5Hpȝ#k9Qq9$v O[זKPpB.)ܕ9?zqrʈYhLeEv@NTWv@TeEPC*l j'2;eZxX6o/;['٩YjJӘٌF=gY:o&颦!oZ5R!^h}ZR&"7{ǀڽz]yT\! ~:4׀է*G×@4a%G` HV=~OZؒxަ"͏9E<ڛ5MpEZG64;x}nLw+*?;&_4Gܩ*<ȟBPc A4^*v߾cޓi7bP jQb H^P@O+ɺG,Ao9K l",e4X—>2@SռB^Di?Jo!if/)IkF OTPX|5i?Αoˊ%Qcrv{ ʧ}wʳ[(OÜBBR*@|XHn~Kx |}*NtvzT)[L-ra/+F-ۧCt6~s`P՚g;zOSbj,Y|liw$']FTg$+?* Rȃ NJn~CQ#3x"D:ƔdBkFDyfSJ3B8Y%99qBl1Z:Լpʼ g'{qR+qZ„`t\H]FtG.V s05}׵{WM_y`+ `J֕G.vH ɼSɔr_-A_^{cG5}E̱wyCf=>f1@n.%';jj6zGM>~@T? LGO&BiܰC]ɴXSC2 B $Is*1tճxY-Գ]7j{Y4I]3Xt WeKW*cƿQ|xffwmeszkoZ.;(z3ZpO}Vu<PCVVs>ǖ{Cxo(s1^l!.]$oo޽dHkg+CE:[a۵yNLvʉsһ/CS4V5mo)3rֹ7:/_b@LxA9QP_i_v~Ion(3"{uEW#1;$tZCW tW+vxGv^; 7g&{}fߵbzṔ.m Nr}aǰ ;I2+hj>P#Sنl)h\ITcӔvhIc ~4iP<1sL'>aͩFVG*U05 d_!SIՔ(^3񍧅My4d3a9Q_}[4?:'0L? EIO#77֐GJ?=q?D̴sD~NISc/UOG󳀵Ko(J}DK#U}.xL˳@nT\.E oj I2(șmesfؖBlʀ亠 nUP #=$uh7o$C1}!|>EKկ#1=~a q"u/)9Ye[ckSs##vڡ%D}^}鼑50rҶ:Õ9!N S3,0.'~Hr<0 ›~V"Z_̀<@ xݟXX~c? ԨgHB[x?aFcSVz&2Tnop3R$o.R4Mkhd% `:>,c^83.]~4)| cቺ@߃^„sg|?DS? lLɯlx]{ "K;rQ=W $yfmcC geQs};y nH3(r)uchO!JCVq"E/4U{ݙdfVd_)UznR.K~'Rn_I,2%VIuE2-#S_pKPMII1@ >M:?B%f֯7dP∼8.p̾u7U<b`/7ZPJ@3Lٱ/nIpOĝz\y'%GX%aBR ?B ¼W^$;2FzA+3>p{d:k @VծKAN 3[4R: 6Z#1\Wh]ܵfsb-o]H{pie:-\9(AGy~ok;~+7i.aRC `#n$麶yRz, K?:NU&E!vR]\I]dLOOv!O;wqa{ {=05-iYtM#.*2Xy~مAȤKBo -sc ;aQMyVX١Xj 4uZd^?d[NRIXLu,IVmIw7bx b12?nH3y!}KԶ/iULL NHb K^'HI_S8\5췼;D~h[^ $W鬮 = 9ZȇJy$!"@oHQ!v0qg ^aܲ!N[g~[SH>Fu…, 6]~a­J kfLck4&kѪIbV35jFž+d 5{O#ۅ!İG'^-&:n(Yww nS4+n([?~IB7 Gd*[ ؿÔ1~'{*4x,Z_|"#0ӫv(=T34V>G[SR''gֶG.Nala:Q!栊BfY}7dz pKG =q~ / Hl 5h.98 Nhr_ 3 T/j]«E2W#) YKge"^3D⯴4ogwUqQ"p@NIݺt΋&O)oC~K(ULLA~Cp>*rm[ԭW?ZJukJG'\_g'vh8;!@$GS,+OY>=ؒ%Iԋh0)dy|ޠh躹ѪP!9|]9C3(3*L_ߋ̮ҽ']\Q9y"! T (1hEP]O55!dVW/*O1Sx+ipX`-"R=yB.1.9hw /dNeE ~u: +T@Lz7$ X=ؗXMlnMseE깊zr1/8EΈ"6P u bn;)6 ) _cP=ۊ $ؚ[7 ʑq*L$z"7QuWޝ'nd; o  u'q$Q"ήHO*ʝ,^9VW6T +Jms\Dűp!~D wS1-ǎ",L|}z6Y;t.p\?~d3屍{y̻Td3}Q%«ܘ8RtS#`{%vT4E2m9!fJ3mQ۾SjzJ3S5enL6rۋ\)O28܆U<7ҡQI.pey{7lB`;u+} ;Fco&gsk==J3 .gהunitizer/tests/_helper/ref-objs/exec/0000755000176200001440000000000014766101222017337 5ustar liggesusersunitizer/tests/_helper/ref-objs/exec/600.rds0000644000176200001440000000060714766101222020361 0ustar liggesusersSM ŏčf=eӖ(+Bq.b[47P3{? B(FG(v0EAl歍ZS 2:XM~츄| kdN&2`+~0ѹCqT&-AoL8('JMW=ף[iA%ɵT/.U=Î(Vrr| zs K@Ջ7D Q!ےr:mAܵE gnJJ!/7T7Da]ܼ덛79tfKY{սXӄ⫁d=է$` 5OPxHq9d=v0ZVxˌ,`{/@͘JA&n猪h-/iK0?`unitizer/tests/_helper/ref-objs/exec/900.rds0000644000176200001440000000201414766101222020356 0ustar liggesusersWo6VKStHao0` %]0?ݰ`{3hʢFRIat)E%GfDH9uGNs7<(;rwq{<3IVaF Khyq{.Ø ).6{Ic%iJTf$ӭraG;խdQ6~0QQqGN:4n4nD@RVnH4̥ ibH(^tbhEϬ^4hwwVKMfiait!{@벘II+￰kJIkMk8#vh;ni~e jp<(0) %ՕjH+*Mi еA[@z]> C5w0_eI˖BK;}A+G^eE)NL^Aha >5kgjqL{ݘc|Od]ϩ" *1h|^1aZw|noLp j\ 4h]?junitizer/tests/_helper/ref-objs/exec/700.rds0000644000176200001440000000035414766101222020361 0ustar liggesusers}PI0 t["$' iR%ASRh90S!I"7]1bH J6r9B+Y*?T^z$˫'Y!- oG< Sf葥Kr <  E+>kVN>ၘk'M-g@n용-&yAufE::t sc=$_|P{x{z&Z unitizer/tests/_helper/ref-objs/exec/500.rds0000644000176200001440000000060714766101222020360 0ustar liggesusersSM ŏčf=eӖ(+Bq.b[47P3{? B(FG(v0EAl歍ZS 2:XM~츄| kdN&2`+~0ѹCqT&-AoL8('JMW=ף[iA%ɵT/.U=Î(Vrr| zs K@Ջ7D Q!ےr:mAܵE gnJJ!/7T7Da]ܼ덛79tfKY{սXӄ⫁d=է$` 5OPxHq9d=v0ZVxˌ,`{/@͘JA&n猪h-/iK0?`unitizer/tests/_helper/ref-objs/exec/300.rds0000644000176200001440000000056514766101222020361 0ustar liggesusersSn %!iT:E;/_Ln;65"ogHHSTEټea[3 !=B Z6sP+Nc1TwY~};",5%j\I' Rm5S2R}MZ Mi=Qݒ^@q{ ˒Q3xY mɆ^3XYB1a܏ .,l^{RJ5Wߵ|HQOS}!pTsv-OIG΢ [L=Ҷ2X韈D}'2a{YɽjCpGJpmIunitizer/tests/_helper/ref-objs/exec/200.rds0000644000176200001440000000052514766101222020354 0ustar liggesusersRN uLw}^JFF: դ |;B ȉe|Rh NSȩ9Yֻmeozr.ՙc2EcSX5 DŽUx?f'U\6,KZ671vE(I0Eӟ+G~'RRULTA71*Bry6[r IaŚ3)q5@Ѵw.bJ:Sr"\_ lupd_m,FJ^DYln/LGu 67RVë6ʾ1WpίAunitizer/tests/_helper/ref-objs/exec/800.rds0000644000176200001440000000050514766101222020360 0ustar liggesusersQn04(R"Co~R{+Fk)䀊0zgg&$I"'Ȃd߿(y"d6uт)lZ˕43U,*J̀7d0VfZl 0Ǜx5i{}ufT.wwa\N7?_ sruᆗ"Kc1(v^!V//%unitizer/tests/_helper/ref-objs/exec/400.rds0000644000176200001440000000056514766101222020362 0ustar liggesusersSn %!iT:E;/_Ln;65"ogHHSTEټea[3 !=B Z6sP+Nc1TwY~};",5%j\I' Rm5S2R}MZ Mi=Qݒ^@q{ ˒Q3xY mɆ^3XYB1a܏ .,l^{RJ5Wߵ|HQOS}!pTsv-OIG΢ [L=Ҷ2X韈D}'2a{YɽjCpGJpmIunitizer/tests/_helper/ref-objs/translate/0000755000176200001440000000000014766101222020410 5ustar liggesusersunitizer/tests/_helper/ref-objs/translate/testthat2/0000755000176200001440000000000014766101222022332 5ustar liggesusersunitizer/tests/_helper/ref-objs/translate/testthat2/test-translate-min.R0000644000176200001440000000012414766101222026205 0ustar liggesusers# Minimal translation test_that("simple tests", { expect_equal(fun0(a), 1:10) }) unitizer/tests/_helper/ref-objs/translate/testthat/0000755000176200001440000000000014766101222022250 5ustar liggesusersunitizer/tests/_helper/ref-objs/translate/testthat/test-translate1.R0000644000176200001440000000024414766101222025426 0ustar liggesusers# for translate unitizer tests expect_equal(fun0(a), 1:10) # blah blah expect_true(fun1(a)) # a test for errors expect_error(stop("hello")) random_function() unitizer/tests/_helper/ref-objs/translate/testthat/test-translate2.R0000644000176200001440000000111114766101222025421 0ustar liggesusers# for translate unitizer tests set.seed(1) context("testthat to unitizer") # random non-sectioned expect_equal(rev(10:1), 1:10) # blah blah test_that("simple tests", { expect_equal(fun0(a), 1:10) # first internal expect_equal( fun1(a, b, c, d, e, f), # internal comment runif(20) ) # "external" comment expect_true(fun1(a)) }) # a test for errors test_that("errors", { # Making up sections expect_error(stop("hello")) expect_warning(warning("yoyo")) }) # Cause error test_that("Nested test_that", { test_that("Inner test_that", TRUE) } ) unitizer/tests/_helper/ref-objs/translate/testthat/helper-translate.R0000644000176200001440000000013214766101222025641 0ustar liggesusers# helper functions for translate tests fun0 <- function(...) 42 fun1 <- function(...) 24 unitizer/tests/_helper/ref-objs/refobjs/0000755000176200001440000000000014766101222020045 5ustar liggesusersunitizer/tests/_helper/ref-objs/refobjs/translate_res4.rds0000644000176200001440000000024014766101222023505 0ustar liggesusersM1 0#|dBfuwp7 %$*f}$BH x3@s9l=sI:QM: 0^6'M›BaVc=>O57M+{\}{'ٵ2P@`-;@*< Zunitizer/tests/_helper/ref-objs/refobjs/browse_aschar2.rds0000644000176200001440000000056314766101222023467 0ustar liggesusersO0+"'ł[PYG/EФ[IW~]-tMuK{ouP 99v.B>z#yi4)) 3y7>0Be@ORV!/,yRRb!-z!F%#/Cr؝)5R=ZI2 = JvRfcu=hUI϶Pkt-%9h)OCՙ-%Q f j$WOV= =Y{RNH."7zNcɋl4؎8( %;/$02,K 4 o^E<Ҝ P_^ unitizer/tests/_helper/ref-objs/refobjs/misc_cndlistshow1.rds0000644000176200001440000000023014766101222024207 0ustar liggesusers] @ DcWz*~k/Aoei7f]7Ю0L;"*ȘFO*u7*A:=OG6z]3v'X0ؗklfr8sk$ A\6~xLgGm|߈unitizer/tests/_helper/ref-objs/refobjs/unitize_res1.rds0000644000176200001440000000137214766101222023203 0ustar liggesusersݖo0Ӵ]UHHV ǁ& Ħ9S$'lgkw@+ω_z]A$~M˲lZ- z+^ͪACY_ZY{|"`QeOFwc&IP2Zj;Ǟ$×: QgW':F9|p]])bk/O85٪8EWm mTXQcf-DɚsCW885) PH X_n{o(SSq%8O57M+{\}{'ٵ2P@`-;@*< Zunitizer/tests/_helper/ref-objs/refobjs/browse_aschar3.rds0000644000176200001440000000061314766101222023464 0ustar liggesusersO0+pѬ,̣Ƌ1zx*&Jn7D1iӗf&B#TsaiYt aUK;Tt57J^Ps9THQ x.#{?4eFɽ4#s/@}_GSD.j`H\ʱ^w4!.UoPg]aT+Isߧ4ͷ#l1,橶^!P1YE3Ph* @{a/DTS>Ojunitizer/tests/_helper/ref-objs/refobjs/browse_df1.rds0000644000176200001440000000100514766101222022606 0ustar liggesusersTo0W5@54M7+/TM`Ҙ6^& v[2eտdZjo(K,T\02X fF*wj<h2xeտas/vK.qlUQ! TBmǛR{f-9nu{d5AWxu.ۏ4ounitizer/tests/_helper/ref-objs/refobjs/translate_res3.rds0000644000176200001440000000110114766101222023501 0ustar liggesusersTk@iAڣ`9GA;&T0="}QPDܜힻm&xA.offv;:;;z oǹ}g'>,%( U)U 5"Ϛk 4! NȂX_(q fV4#D!H[bp wаZ㡮sW3*R1gddx~;=$qN"S"^*ZR^M0N%f; y&V?V\p<3-3[ *;M&dC2M&w;R<*WmQ 6eWO'z/ e1ǐƐŀ1,L4M/v,6]k6ZҌ+JCn-뻾Qt? XW+0:lhg#Gu~H&7X-d(~vź/JJ5X"j?0sot).[~[0AQC^~x|kj?=oxJV덖-O1Z9wwǾ}8K7O'ٻes}}q.܍n3( ?'UQunitizer/tests/_helper/ref-objs/refobjs/browse_ascharnarrow.rds0000644000176200001440000000052714766101222024636 0ustar liggesusersMO0+p~'KfM=VBn%]yް46m&<jv f.̺DtnWR͵`#LNn OU;7Tg=\b4)6Bl7fU|YblJ ^#DieL˥l\HvaM},Qx!ZKFC" 44<_ S%rb'Dy/pOx2 <.(㤍L`ŭ})$hKgRGW[1ᆺAn unitizer/tests/_helper/ref-objs/refobjs/parse-eq.rds0000644000176200001440000000013414766101222022272 0ustar liggesusersb```b`a`e`b2 A,HlF" `1N ͡DZJ!r ,!Dqk%unitizer/tests/_helper/ref-objs/refobjs/browse_itemord.rds0000644000176200001440000000055414766101222023607 0ustar liggesusersRQO0 %Co8\ؔD|-%%mO7^gﾻvwq\q=zzAD;M, "P*Р!1X0Yo_* +[" DKֹS`TX.UD֨$ņZA=: +=|B(/)("SH&(wY8Ջ޳<C*1s |Kq3P.}+AoQ=]F5ڟq6tc:zfVtX35GٖqFG*7" $aW]l֕vMqҌiZ?O_4cunitizer/tests/_helper/ref-objs/refobjs/browse_aschar1.rds0000644000176200001440000000055114766101222023463 0ustar liggesusersOO0'x~]8u qM=VBn%]w[ 8C6kjTjĩT99u3p7I0oРR5 /3duhkk%|`JA!+,xBZzR&oH 3j3FJ=١!2& @ %c aFG{]2<ZcK)y;*unitizer/tests/_helper/ref-objs/item/700.rds0000644000176200001440000000027514766101222020375 0ustar liggesusersb```b`ffd`b2HK$'e&+d)䥖+(Y%@hG*(%*)RNiP:#뤒:7[2%TH.KC3C|la.Zq.܅ quunitizer/tests/_helper/ref-objs/item/200.rds0000644000176200001440000000030514766101222020362 0ustar liggesusers-= @ DQ=l:9Hx`nB繳yjEYlkW ))IvreE~.+/?dD$p|unitizer/tests/_helper/ref-objs/item/400.rds0000644000176200001440000000012714766101222020366 0ustar liggesusersb```b`ffd`b2|N YY\PY` 3Sp-*/RH ,{Tunitizer/tests/_helper/ref-objs/capture/0000755000176200001440000000000014766101222020056 5ustar liggesusersunitizer/tests/_helper/ref-objs/capture/100.rds0000644000176200001440000000041514766101222021070 0ustar liggesusers}N0 vci'=7 !nmѲJ!x KFFr8㟼B%f's[rϒe${=[s/щm mxP`3ېƏ /vlZ9)Ⱥxv_z)0A!2OF@s>FU Un$<Ʋ} R%@co>Vb*k,@ytP2vP^U:.wXYG<0%a,Vd[jZן[>ABunitizer/tests/_helper/ref-objs/capture/200.rds0000644000176200001440000000037514766101222021076 0ustar liggesusers}QN0 u/ 4O7F[,w|%"̃\Mded;@v OAWG>=Rφ\؀xxutivxѡG: e68GK-OיZenr#KsXe/GZX+A&&w/-y"GdD4{a,:4p?pʕ(H4unitizer/tests/t-state.Rout.save0000644000176200001440000003702514766101222016466 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > options(unitizer.color = FALSE, width = 80L) > > # - "Random Seed" -------------------------------------------------------------- > > old.seed <- if (!exists(".Random.seed")) NULL else .Random.seed > seed.dat <- getOption("unitizer.seed") > > suppressWarnings( + untz.glob <- + unitizer:::unitizerGlobal$new(enable.which = setNames(2L, "random.seed")) + ) > do.call(set.seed, seed.dat) > new.seed <- .Random.seed > state <- untz.glob$state() > invisible(runif(10)) # see if we can reset state after this > untz.glob$reset(state) An object of class "unitizerGlobalIndices" Slot "search.path": [1] 0 Slot "options": [1] 0 Slot "working.directory": [1] 0 Slot "random.seed": [1] 2 Slot "namespaces": [1] 0 > identical(.Random.seed, new.seed) [1] TRUE > untz.glob$resetFull() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 1 > > if (is.null(old.seed)) { + !isTRUE(exists(".Random.seed")) + } else identical(old.seed, .Random.seed) [1] TRUE > > # - "State Show" --------------------------------------------------------------- > > show(unitizer:::unitizerStatePristine()) Settings Values 1 par.env 2 search.path 2 3 options 2 4 working.directory 2 5 random.seed 2 6 namespaces 2 ----- 0: off 1: track starting with initial state 2: track starting with clean state : use special unitizer environment as 'par.env' See `?unitizerState` for more details. > > # - "all.equal.unitizerDummy" -------------------------------------------------- > > dummy <- new("unitizerDummy") > blah <- "hello" > ref.txt <- "`.REF` value was not recorded, but `.NEW` value was; they are likely different" > identical(all.equal(dummy, blah), ref.txt) [1] TRUE > all.equal(dummy, dummy) [1] TRUE > identical( + all.equal(blah, dummy), + "`.NEW` value was not recorded, but `.REF` value was; they are likely different" + ) [1] TRUE > # testing S4 / S3 methods, first works, second doesn't since we can't > # have an S3 generic with dispatch on 2nd arg > > identical( + evalq(all.equal(new("unitizerDummy"), "hello"), getNamespace("stats")), + ref.txt + ) [1] TRUE > evalq(all.equal("hello", new("unitizerDummy")), getNamespace("stats")) [1] "Modes: character, S4" [2] "Attributes: < target is NULL, current is list >" [3] "target is character, current is unitizerDummy" > > # - "All Equal States" --------------------------------------------------------- > > # Doesn't seem like we're comparing these to anything? Maybe should look into > # doing so? > > state.A <- new("unitizerGlobalState", search.path = letters[1:3], + options = list(a = 5:7, b = new("unitizerDummy"), c = "hello"), + working.directory = "a/b/c") > state.B <- new("unitizerGlobalState", search.path = letters[1:3], + options = list(a = 5:7, b = new("unitizerDummy"), d = "goodbye", + c = new("unitizerDummy")), working.directory = new("unitizerDummy"), + random.seed = 1:3) > state.C <- new("unitizerGlobalState", search.path = letters, + options = list(a = list(5, 6, 7), c = LETTERS), working.directory = new("unitizerDummy"), + random.seed = 1:3) > # just compare to A > state.D <- new("unitizerGlobalState", search.path = letters[1:3], + options = list(a = list(1, 2, 3), b = new("unitizerDummy"), + c = "hello"), working.directory = "a/b/c") > state.E <- new("unitizerGlobalState", options = setNames(as.list(1:20), + head(letters, 20))) > state.F <- new("unitizerGlobalState", options = setNames(as.list(1:20), + tail(letters, 20))) > # This one is supposed to return something non-character or TRUE when used > # with the provided all.equal > state.G <- new("unitizerGlobalState", options = list(a = structure(TRUE, + class = "unitizer_glob_state_test"), b = 0)) > state.H <- new("unitizerGlobalState", options = list(a = structure(FALSE, + class = "unitizer_glob_state_test"), b = 2)) > > # - "as.state" ----------------------------------------------------------------- > > identical( + unitizer:::as.state("recommended"), + unitizer:::as.state(unitizer:::unitizerStateSuggested()) + ) [1] TRUE > identical( + unitizer:::as.state("suggested"), + unitizer:::as.state(unitizer:::unitizerStateSuggested()) + ) [1] TRUE > identical( + unitizer:::as.state("pristine"), + unitizer:::as.state(unitizer:::unitizerStatePristine()) + ) [1] TRUE > > # unitizerStateProcessed should produce the default object (which currently > # is "off") > > all.equal( + unitizer:::as.state(.GlobalEnv), + unitizer:::as.state(unitizer:::unitizerStateSuggested(par.env = .GlobalEnv)) + ) [1] TRUE > all.equal( + unitizer:::as.state(in_pkg("stats")), + unitizer:::as.state( + unitizer:::unitizerStateSuggested(par.env = getNamespace("stats")) + ) ) [1] TRUE > > stats.lib <- file.path(system.file(package = "stats"), "R") > all.equal( + unitizer:::as.state(in_pkg(), test.files = stats.lib), + unitizer:::as.state( + unitizer:::unitizerStateSuggested(par.env = getNamespace("stats")) + ) ) [1] TRUE > try(unitizer:::as.state(200)) Error in as.state_raw(x) : Argument `x` must be character(1L) %in% c("pristine", "recommended", "suggested" , "basic", "off", "safe"), NULL, an environment, or must inherit from S4 classes `unitizerStateRaw`, `unitizerStateProcessed` or `unitizerInPkg` in order to be interpreted as a unitizer state object. > state <- unitizer:::unitizerStateOff() > # bypass validity method > state@options <- 2L > try(validObject(state)) Error in validObject(state) : invalid class "unitizerStateOff" object: Argument `state` is an invalid state: 'options' is set to 2, but 'search.path' and 'namespaces' are not > # state raw conversions > identical( + unitizer:::as.state(unitizer:::unitizerStateRaw()), + unitizer:::unitizerStateProcessed() + ) [1] TRUE > identical( + unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = "stats")), + unitizer:::unitizerStateProcessed(par.env = getNamespace("stats")) + ) [1] TRUE > state@options <- 0L > state.proc <- unitizer:::as.unitizerStateProcessed(state) > state.raw <- unitizer:::as.unitizerStateRaw(state.proc) > is(state.raw, "unitizerStateRaw") [1] TRUE > all.equal( + lapply(slotNames(state), slot, object = state.proc), + lapply(slotNames(state.raw), slot, object = state.raw) + ) [1] TRUE > try(unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = in_pkg()))) Error in in_pkg_to_env(x.raw@par.env, test.files) : Unable to detect package to use namespace of as parent environment; see `? unitizerState` for how to specify a package namespace explicitly as a parent environment. Error in unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = in_pkg())) : Unable to convert `par.env` value to a namespace environment > > identical( + unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = in_pkg("stats"))), + unitizer:::unitizerStateProcessed(par.env = getNamespace("stats")) + ) [1] TRUE > try( + unitizer:::as.state( + unitizer:::unitizerStateRaw(par.env = in_pkg("asdfalkdfasd")) + ) ) Error in loadNamespace(name) : there is no package called 'asdfalkdfasd' Error in in_pkg_to_env(x.raw@par.env, test.files) : Unable to load "asdfalkdfasd" namespace to use as parent environment; see `?unitizerState` for instructions on how to specify a package namespace as a parent environment for tests. Error in unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = in_pkg("asdfalkdfasd"))) : Unable to convert `par.env` value to a namespace environment > try( + unitizer:::as.state( + unitizer:::unitizerStateRaw(par.env = in_pkg("")), test.files = getwd() + ) ) Error in in_pkg("") : Argument `package` may not be an empty string > # impossible states > state.obj <- unitizer:::unitizerStateRaw() > state.obj@options <- 2L > try(unitizer:::as.state(state.obj)) Error in unitizer:::as.state(state.obj) : Options state tracking (2) must be less than namespace state tracking (0). > state.obj@namespaces <- 2L > state.obj@search.path <- 1L > try(unitizer:::as.state(state.obj)) Error in unitizer:::as.state(state.obj) : Namespace state tracking (2) must be less than or equal to search path state tracking (1). > > # - "as.state_raw" ------------------------------------------------------------- > > old.opt.loc <- options(unitizer.state = .GlobalEnv) > try(unitizer:::as.state_raw(.GlobalEnv)) Error in unitizer:::as.state_raw(.GlobalEnv) : Value for `getOption('unitizer.state')` is incompatible with using an environment or an 'unitizerInPkg' object as the value for the `state` argument because it also is an environment or a 'unitizerInPkg' object; you must change the option or the `state` argument to be compatible. > options(unitizer.state = 42L) > try(unitizer:::as.state_raw(.GlobalEnv)) Error in unitizer:::as.state_raw(.GlobalEnv) : `getOption('unitizer.state')` must be character(1L) %in% c("pristine", "recom- mended", "suggested", "basic", "off", "safe"), NULL, an environment, or must inherit from S4 classes `unitizerStateRaw`, `unitizerStateProcessed` or ` unitizerInPkg` in order to be interpreted as a unitizer state object. > state.raw <- unitizer:::as.unitizerStateRaw(unitizer:::unitizerStateOff()) > state.proc <- unitizer:::as.unitizerStateProcessed(state.raw) > my.env <- new.env() > options(unitizer.state = state.raw) > state.raw@par.env <- my.env > all.equal(unitizer:::as.state_raw(my.env), state.raw) [1] TRUE > options(unitizer.state = state.proc) > my.env <- new.env() > state.proc@par.env <- my.env > all.equal( + unitizer:::as.state_raw(my.env), + unitizer:::as.unitizerStateRaw(state.proc) + ) [1] TRUE > options(old.opt.loc) > > # - "state" -------------------------------------------------------------------- > > # all these assume we set the options to be in recommended mode > > all.equal(state("stats"), unitizer:::unitizerStateSuggested(par.env = "stats")) [1] TRUE > > all.equal( + state(in_pkg("stats")), + unitizer:::unitizerStateSuggested(par.env = in_pkg("stats")) + ) [1] TRUE > all.equal( + state(in_pkg()), unitizer:::unitizerStateSuggested(par.env = in_pkg()) + ) [1] TRUE > all.equal( + state(search.path = 1), unitizer:::unitizerStateSuggested(search.path = 1L) + ) [1] TRUE > s1 <- unitizer:::unitizerStateSuggested(par.env = .GlobalEnv) > for (i in setdiff(slotNames(s1), "par.env")) slot(s1, i) <- 0L > s2 <- unitizer:::unitizerStateOff() > all.equal(s1, s2) [1] TRUE > # invalid state > try(state(search.path = 3)) Error in state(search.path = 3) : Argument `search.path` must be integer(1L) in 0:2 > try(state(options = 2, namespaces = 1)) Error in state(options = 2, namespaces = 1) : Unable to create valid `unitizerStateRaw` object: Argument `state` is an invalid state: 'options' is set to 2, but 'search.path' and 'namespaces' are not > try(state(namespaces = 2, search.path = 1)) Error in state(namespaces = 2, search.path = 1) : Unable to create valid `unitizerStateRaw` object: Argument `state` is an invalid state: 'namespaces' is set to 2, but 'search.path' is not > state.inv <- unitizer:::unitizerStateProcessed() > state.inv@options <- 2L > try(unitizer:::as.state(state.inv)) Error in unitizer:::as.state(state.inv) : Options state tracking (2) must be less than namespace state tracking (0). > state.inv@namespaces <- 2L > try(unitizer:::as.state(state.inv)) Error in unitizer:::as.state(state.inv) : Namespace state tracking (2) must be less than or equal to search path state tracking (0). > # captured > any(grepl("", capture.output(show(state(in_pkg()))))) [1] TRUE > any(grepl("", capture.output(show(state(in_pkg("stats")))))) [1] TRUE > any(grepl("namespace:stats", capture.output(show(state(asNamespace("stats")))))) [1] TRUE > > # - "in_pkg" ------------------------------------------------------------------- > > try(in_pkg("")) Error in in_pkg("") : Argument `package` may not be an empty string > identical(as.character(in_pkg()), "") [1] TRUE > identical(as.character(in_pkg("stats")), "") [1] TRUE > identical(capture.output(show(in_pkg())), "") [1] TRUE > try(unitizer:::in_pkg_to_env(in_pkg(), "/")) Error in unitizer:::in_pkg_to_env(in_pkg(), "/") : Unable to detect package to use namespace of as parent environment; see `? unitizerState` for how to specify a package namespace explicitly as a parent environment. > > # - "merge states" ------------------------------------------------------------- > > trk.new <- new("unitizerGlobalTrackingStore", search.path = list(1, + 2, 3), options = list("a", "b")) > trk.ref <- new("unitizerGlobalTrackingStore", search.path = list(4, + 5, 6), options = list("c", "d")) > items <- new("unitizerItems") > items <- items + new("unitizerItem", call = quote(1 + 1), glob.indices = new("unitizerGlobalIndices", + search.path = 1L, options = 2L)) > items <- items + new("unitizerItem", call = quote(2 + 1), glob.indices = new("unitizerGlobalIndices", + search.path = 2L, options = 1L)) > items <- items + new("unitizerItem", call = quote(1 * 1), reference = TRUE, + glob.indices = new("unitizerGlobalIndices", search.path = 1L, + options = 1L)) > items <- items + new("unitizerItem", call = quote(2 * 1), reference = TRUE, + glob.indices = new("unitizerGlobalIndices", search.path = 3L, + options = 2L)) > res <- unitizer:::mergeStates(items, trk.new, trk.ref) > > sapply(res$items, function(x) as.integer(slot(x, "glob.indices"))) [,1] [,2] [,3] [,4] search.path 1 2 4 5 options 2 1 3 4 working.directory 0 0 0 0 random.seed 0 0 0 0 namespaces 0 0 0 0 > s.n.to.check <- c("search.path", "options", "working.directory", + "random.seed", "namespaces") > sapply(s.n.to.check, slot, object = res$states) $search.path $search.path[[1]] [1] 1 $search.path[[2]] [1] 2 $search.path[[3]] [1] 3 $search.path[[4]] [1] 4 $search.path[[5]] [1] 6 $options $options[[1]] [1] "a" $options[[2]] [1] "b" $options[[3]] [1] "c" $options[[4]] [1] "d" $working.directory list() $random.seed list() $namespaces list() > # No reference items > items.no.ref <- items[1:2] > identical( + unitizer:::mergeStates(items.no.ref, trk.new, trk.ref), + list(items = items.no.ref, states = trk.new) + ) [1] TRUE > # No new items; note that we only remap the used states to the new state > # which is why we need all the .mod objects > > items.no.new <- items[3:4] > items.no.new.mod <- items.no.new > items.no.new.mod[[2L]]@glob.indices@search.path <- 2L > trk.ref.mod <- trk.ref > trk.ref.mod@search.path[[2L]] <- NULL > > identical( + unitizer:::mergeStates( + items.no.new, new("unitizerGlobalTrackingStore"),trk.ref + ), + list(items = items.no.new.mod, states = trk.ref.mod) + ) [1] TRUE > > > proc.time() user system elapsed 0.882 0.161 1.669 unitizer/tests/t-prompt.R0000644000176200001440000000740414766101222015200 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "read_line works" ---------------------------------------------------------- # read through prompt vals unitizer:::read_line_set_vals(letters[1:3]) u.ns <- asNamespace("unitizer") unitizer:::read_line() identical(u.ns$.global$prompt.vals, letters[2:3]) unitizer:::read_line() u.ns$.global$prompt.vals unitizer:::read_line() u.ns$.global$prompt.vals try(unitizer:::read_line()) # - "simple prompts" ----------------------------------------------------------- unitizer:::read_line_set_vals(c("y", "Y", "n", "N")) try(unitizer:::simple_prompt(1:5)) try(unitizer:::simple_prompt("hello", attempts = 1:5)) try(unitizer:::simple_prompt("hello", values = NA_character_)) try(unitizer:::simple_prompt("hello", case.sensitive = 1)) unitizer:::simple_prompt("hello") unitizer:::simple_prompt("hello")# unitizer:::simple_prompt("hello") unitizer:::read_line_set_vals(c("y", "y", "n")) try(unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE)) try(unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE), silent = TRUE) try(unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE)) # - "faux prompt" -------------------------------------------------------------- unitizer:::read_line_set_vals(c("1 +", "1")) unitizer:::faux_prompt(prompt = "> ", continue = "+ ")[[1L]] unitizer:::read_line_set_vals(c("(})")) try(unitizer:::faux_prompt(prompt = "> ", continue = "+ ")) ## Test the new readLines based read_line ## This test will not work in interactive mode, requiring input unitizer:::read_line_set_vals(c("1 +", "1")) unitizer:::faux_prompt() ## This one embeds a CTRL+C to test interrupt, but we can't test this without ## read_line_setvals unitizer:::read_line_set_vals(c("1 +", "\x03", "2 + ", "1")) unitizer:::faux_prompt() unitizer:::read_line_set_vals(c("\x03", "2 + ", "1")) unitizer:::faux_prompt() ## Test that changing language doesn't affect partial parsing lang <- Sys.getenv("LANGUAGE", unset=NA) Sys.setenv("LANGUAGE"="fr") unitizer:::read_line_set_vals(c("1 +", "1")) unitizer:::faux_prompt(prompt = "> ", continue = "+ ") if(is.na(lang)) Sys.unsetenv("LANGUAGE") else Sys.setenv("LANGUAGE"=lang) # - "unitizer prompt" ---------------------------------------------------------- # Some of this needs to be done outside of testthat due to sinking suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) unitizer:::read_line_set_vals(c("1 +", "1", "H", "Y")) unitizer:::unitizer_prompt( "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob ) unitizer:::read_line_set_vals(c("1 +", "1", "H", "Q")) unitizer:::unitizer_prompt("hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), help = "This is all the help you get", global = glob) unitizer:::read_line_set_vals(c("hell())", "Q")) txt3 <- unitizer:::capture_output(unitizer:::unitizer_prompt("hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob)) txt3$message # and multiline stuff (#242) unitizer:::read_line_set_vals(c("{\n 1 + 1\n 2 + 1\n}", "N")) unitizer:::unitizer_prompt( "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob ) try( unitizer:::unitizer_prompt( "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), browse.env = "not an env", global = glob ) ) unitizer:::read_line_set_vals(character()) try( unitizer:::unitizer_prompt( "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob ) ) unitizer:::read_line_set_vals("1L") try( unitizer:::unitizer_prompt( "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), exit.condition = unitizer:::exit_fun, valid.vals = 2:3, global = glob ) ) unitizer:::read_line_set_vals("2L") unitizer:::unitizer_prompt("hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), exit.condition = unitizer:::exit_fun, valid.vals = 2:3, global = glob) unitizer/tests/t-get.Rout.save0000644000176200001440000003652714766101222016133 0ustar liggesusers R Under development (unstable) (2023-03-16 r83985) -- "Unsuffered Consequences" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: aarch64-apple-darwin20 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "mock.R")) > > toy.path <- file.path("_helper", "unitizers", "misc.unitizer") > toy.stor <- readRDS(file.path(toy.path, "data.rds")) > > # - "Error Cases" -------------------------------------------------------------- > > try(get_unitizer(1)) Error in get_unitizer.default(1) : No method defined for object of class "numeric"; make sure that the specified `store.id` is a reference to a valid unitizer store and had defined `get_unitizer` and `set_unitizer` methods. > try(get_unitizer(letters)) Error in get_unitizer.character(letters) : Argument `store.id` must be a 1 length character vector > try(get_unitizer("_helper")) Error in get_unitizer.character("_helper") : Argument `store.id` does not appear to refer to a unitizer directory > try(get_unitizer("t-get.R")) Error in get_unitizer.character("t-get.R") : Argument `store.id` does not appear to refer to a unitizer directory > try(set_unitizer(1)) Error in set_unitizer.default(1) : No method defined for object of class "numeric"; make sure that the specified `store.id` is a reference to a valid unitizer store and had defined `get_unitizer` and `set_unitizer` methods. > try(set_unitizer(letters)) Error in set_unitizer.character(letters) : Argument `store.id` must be a 1 length character vector > # 4.3 changed reporting of missing argument errors > tryCatch(set_unitizer("a"), error=function(e) conditionMessage(e)) [1] "argument \"unitizer\" is missing, with no default" > try(set_unitizer("a", "blergh")) Error in set_unitizer.character("a", "blergh") : Argument `unitizer` must be a unitizer > !file.exists("a") # TRUE [1] TRUE > try(suppressWarnings(set_unitizer("tests/# ;!./# \\/", toy.stor))) Error in set_unitizer.character("tests/# ;!./# \\/", toy.stor) : Could not create `store.id`; make sure it is a valid file name; see warning for details > > # - "Get works as expected" ---------------------------------------------------- > > tmp.dir <- tempfile() > dir.create(tmp.dir) > tmp.sub.dir <- paste0(tmp.dir, "/get.test.dir") > tmp.fake.utz <- paste0(tmp.dir, "/fake.unitizer") > > # expect_false(get_unitizer("asldkfjskfa")) > get_unitizer("asldkfjskfa") # FALSE [1] FALSE > all.equal(get_unitizer(toy.path), toy.stor) [1] TRUE > is(toy.stor, "unitizer") [1] TRUE > dir.create(tmp.fake.utz) > fake.utz <- file.path(tmp.fake.utz, "data.rds") > cat("# this is not an RDS\n", file = fake.utz) > # expect_error(capture.output(get_unitizer(tmp.fake.utz), type = "message"), > # "Failed loading unitizer") > try(capture.output(get_unitizer(tmp.fake.utz), type = "message")) Error in get_unitizer.character(tmp.fake.utz) : Failed loading unitizer; see prior error messages for details > > tmp.sub.dir <- paste0(tmp.dir, "/get.test.dir") > tmp.sub.dir2 <- paste0(tmp.dir, "/get.test.dir2") > tmp.sub.dir3 <- paste0(tmp.dir, "/load.dirs") > > # - "Set works as expected" ---------------------------------------------------- > > dir.create(tmp.sub.dir) > set_unitizer(tmp.sub.dir, toy.stor) [1] TRUE > all.equal(readRDS(paste0(tmp.sub.dir, "/data.rds")), toy.stor) [1] TRUE > just.a.file <- tempfile() > on.exit(unlink(just.a.file)) > cat("just a file\n", file = just.a.file) > err <- capture.output(try(set_unitizer(just.a.file, toy.stor)), type='message') > any(grepl('not a directory', err)) [1] TRUE > > # - "load/store_unitizer" ------------------------------------------------------ > > # Several different stores in different states (i.e. requiring upgrade, > # not unitizers, etc.) > dir.create(tmp.sub.dir3) > make.path <- lapply(file.path(tmp.sub.dir3, dir("_helper/ref-objs/load/")), + dir.create) > if (!all(unlist(make.path))) stop("Failed making paths") > file.copy(list.files("_helper/ref-objs/load", full.names = TRUE), tmp.sub.dir3, + recursive = TRUE) [1] TRUE TRUE TRUE TRUE TRUE TRUE > par.frame <- new.env() > store.ids <- as.list(list.files(tmp.sub.dir3, full.names = TRUE)) > > # must be upgraded, but cannot > load.try <- unitizer:::capture_output( + try( + unitizer:::load_unitizers(store.ids, rep(NA_character_, + length(store.ids)), par.frame = par.frame, interactive.mode = FALSE, + mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE + ) ) ) > any(grepl('could not be loaded', load.try$message)) [1] TRUE > any(grepl('could not be upgraded', load.try$message)) [1] TRUE > any(grepl('Cannot proceed', load.try$message)) [1] TRUE > > # handle failure in store_unitizer, we just try this on one of the store ids > > out <- unitizer:::capture_output( + unitizer:::load_unitizers( + store.ids[4], rep(NA_character_, length(store.ids))[4], + par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", + force.upgrade = TRUE, show.progress=0L, transcript=FALSE + ) + ) > any(grepl('Upgraded test file does not match original', out$message)) [1] TRUE > > # try weird store ids > out <- unitizer:::capture_output( + invalid.store <- try( + unitizer:::load_unitizers( + list(structure("hello", class = "unitizer_error_store")), + NA_character_, par.frame = par.frame, + interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, + show.progress=0L, transcript=FALSE + ) ) + ) > inherits(invalid.store, "try-error") [1] TRUE > any(grepl("returned something other than", out$message)) [1] TRUE > > # Load mix of loadable and not loadable objects > glob <- suppressWarnings(unitizer:::unitizerGlobal$new()) > # with warning: "does not exist|test file does not") > out <- unitizer:::capture_output( + untzs <- try( + unitizer:::load_unitizers( + store.ids, rep(NA_character_, length(store.ids)), par.frame = par.frame, + interactive.mode = FALSE, mode = "unitize", force.upgrade = TRUE, + global = glob, show.progress=0L, transcript=FALSE + ) ) ) > inherits(untzs, "try-error") [1] TRUE > any(grepl('could not be loaded', out$message)) [1] TRUE > any(grepl('could not be upgraded', out$message)) [1] TRUE > any(grepl('Cannot proceed', out$message)) [1] TRUE > > # Test failure of storage of a loaded and upgraded unitizers > > untzs <- unitizer:::load_unitizers( + store.ids[4], NA_character_, par.frame = par.frame, + interactive.mode = FALSE, mode = "unitize", force.upgrade = TRUE, + global = glob, show.progress=0L, transcript=FALSE + ) Warning in addSlot(object, "cons", NULL) : Slot `cons` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "jump.to.test", 0L) : Slot `jump.to.test` does not exist in current version of `unitizer` so not added to object. Warning in unitizer:::load_unitizers(store.ids[4], NA_character_, par.frame = par.frame, : Upgraded test file does not match original test file ('internals.R' vs 'NA'). > mock(unitizer:::set_unitizer, quote(stop("set fail"))) > try(unitizer:::store_unitizer(untzs[[1]])) Error in set_unitizer(unitizer@id, unitizer) : set fail Error in unitizer:::store_unitizer(untzs[[1]]) : Error attempting to save unitizer, see previous messages. > unmock(unitizer:::set_unitizer) > > # Try reloading already loaded unitisers > reload <- unitizer:::as.list(untzs) > # this creates a global object, hence warning > untzs1a <- unitizer:::load_unitizers( + reload, rep(NA_character_, length(reload)), par.frame = par.frame, + interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, + show.progress=0L, transcript=FALSE + ) Warning in .Object$initialize(...) : Instantiated global object without global namespace registry; you should only see this warning you are using `repair_environments`. > all(vapply(unitizer:::as.list(untzs1a), is, logical(1L), "unitizer")) [1] TRUE > > # misc tests > # warning Instantiated global object without > > untzs2 <- unitizer:::load_unitizers( + list(tmp.sub.dir2), NA_character_, par.frame, interactive.mode = FALSE, + mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE + ) Warning in .Object$initialize(...) : Instantiated global object without global namespace registry; you should only see this warning you are using `repair_environments`. > is(untzs2[[1L]], "unitizer") [1] TRUE > identical(parent.env(untzs2[[1L]]@zero.env), par.frame) [1] TRUE > > # something that won't get reset on load so we can check our re-load > untzs2[[1L]]@eval.time <- 33 > unitizer:::store_unitizer(untzs2[[1L]]) | unitizer updated. > > # warning Instantiated global object without > untzs2.1 <- unitizer:::load_unitizers( + list(tmp.sub.dir2), NA_character_, par.frame, interactive.mode = FALSE, + mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE + ) Warning in .Object$initialize(...) : Instantiated global object without global namespace registry; you should only see this warning you are using `repair_environments`. > untzs2.1[[1L]]@eval.time # 33 [1] 33 > unlink(c(tmp.sub.dir2, tmp.sub.dir3, tmp.sub.dir), recursive = TRUE) > > # - "is_package" --------------------------------------------------------------- > > unitizer:::is_package_dir(system.file(package = "stats")) [1] TRUE > unitizer:::is_package_dir(system.file(package = "methods")) [1] TRUE > > ## Seems like some change now tests no longer installed by default with > ## packages, at least in the unix distros, so can't easily test with > ## has.tests==TRUE > > unitizer:::pretty_path(file.path(system.file(package = "stats"), + "DESCRIPTION")) [1] "package:stats/DESCRIPTION" > old.wd <- getwd() > setwd(system.file(package = "stats")) > unitizer:::pretty_path(file.path(system.file(package = "stats"), "DESCRIPTION")) [1] "DESCRIPTION" > unitizer:::pretty_path(file.path(system.file(package = "stats"))) [1] "." > setwd(old.wd) > > # just picked some folder we know will not work (No Desc) > unitizer:::is_package_dir(file.path(system.file(package = "stats"), "R")) [1] "No DESCRIPTION file" > unitizer:::is_package_dir("ASDFASDF") [1] "not an existing directory" > unitizer:::is_package_dir(file.path(system.file(package = "unitizer"), + "expkg", "baddescription1")) [1] "DESCRIPTION file did not have a package name entry" > # *get_*package_dir > pkg.f <- file.path(system.file(package = "unitizer"), "tests", + "interactive", "run.R") > length(unitizer:::get_package_dir(pkg.f)) == 1L [1] TRUE > length(unitizer:::get_package_dir(dirname(pkg.f))) == 1L [1] TRUE > f <- tempfile() > cat("helloworld", file = f) > length(unitizer:::get_package_dir(f)) == 0L [1] TRUE > unlink(f) > > # some more tests moved to t-demo.R to avoid reloading pkgs > > # - "is_unitizer_dir" ---------------------------------------------------------- > > base.dir <- file.path(system.file(package = "unitizer"), "expkg", "infer") > unitizer:::is_unitizer_dir(base.dir) # FALSE [1] FALSE > unitizer:::is_unitizer_dir( + file.path(base.dir, "tests", "unitizer", "infer.unitizer") + ) [1] TRUE > # - "infer_unitizer_location" -------------------------------------------------- > > infer <- function(...) infer_unitizer_location(..., interactive.mode = FALSE) > base.dir <- file.path(system.file(package = "unitizer"), "expkg", "infer") > > # Verify package is still in state we built tests on; need to sort b/c > # different platforms have different lexical sorts > identical( + sort(c("aaa.R", "aaa.unitizer", "abc.R", "abc.unitizer", "inf.R", + "inf.unitizer", "infer.R", "infer.unitizer", "zzz.R", "zzz.unitizer")), + list.files(file.path(base.dir, "tests", "unitizer")) + ) [1] TRUE > # Package dir > unitizer:::capture_output(inf <- infer(base.dir)) > basename(inf) [1] "infer.R" > unitizer:::capture_output(inf <- infer(base.dir, type = "d")) > basename(inf) [1] "unitizer" > unitizer:::capture_output(inf <- infer(base.dir, type = "u")) > basename(inf) [1] "infer.unitizer" > > inf.dir <- infer(file.path(base.dir, "*")) # warn Warning in infer_unitizer_location.character(..., interactive.mode = FALSE) : 5 possible targets; too many to unambiguously infer desired file > identical(file.path(base.dir, "*"), inf.dir) [1] TRUE > > unitizer:::capture_output(inf <- infer(file.path(base.dir, "z"))) > basename(inf) [1] "zzz.R" > unitizer:::capture_output(inf <- infer(file.path(base.dir, "z"), type = "u")) > basename(inf) [1] "zzz.unitizer" > > # Normal dir > base.dir2 <- file.path(base.dir, "tests", "unitizer") > # note don't need * to generate warning > out <- unitizer:::capture_output(inf.dir2 <- infer(base.dir2)) # warn > any(grepl("5 possible targets", out$message)) [1] TRUE > identical(base.dir2, inf.dir2) [1] TRUE > out <- unitizer:::capture_output(infer(file.path(base.dir2, "a"))) > any(grepl("2 possible targets", out$message)) [1] TRUE > out <- unitizer:::capture_output(infer(file.path(base.dir2, "a"), type = "u")) > any(grepl("2 possible targets", out$message)) [1] TRUE > out <- + unitizer:::capture_output(fname <- basename(infer(file.path(base.dir2, "z")))) > fname [1] "zzz.R" > any(grepl('Inferred test file location:', out)) [1] TRUE > out <- unitizer:::capture_output( + fname <- basename(infer(file.path(base.dir2, "z"), type="u")) + ) > fname [1] "zzz.unitizer" > any(grepl('Inferred unitizer location:', out)) [1] TRUE > > # Random file without setting working dir first, in order for this to work > # non-interactivel we need it to work with the R CMD check dir structure, > # and possibly with the covr dir structure > if (interactive()) infer("tests2") > > # Interactive mode > unitizer:::read_line_set_vals(c("26", "Q")) > # warn/output > select <- unitizer:::infer_unitizer_location( + file.path(base.dir, "*"), type = "f", interactive.mode = TRUE + ) Possible matching files from "tests/unitizer": 1: aaa.R 2: abc.R 3: inf.R 4: infer.R 5: zzz.R unitizer> 26 | Type a number in `1:5` at the prompt [1] 26 unitizer> Q No file selected Warning in infer_unitizer_location.character(file.path(base.dir, "*"), type = "f", : Invalid user selection > identical(select, file.path(base.dir, "*")) [1] TRUE > > unitizer:::read_line_set_vals(c("5")) > # output > sel.loc <- unitizer:::infer_unitizer_location(file.path(base.dir, + "*"), type = "f", interactive.mode = TRUE) Possible matching files from "tests/unitizer": 1: aaa.R 2: abc.R 3: inf.R 4: infer.R 5: zzz.R unitizer> 5 Selected file: zzz.R > basename(sel.loc) [1] "zzz.R" > unitizer:::read_line_set_vals(NULL) > > # Non standard inferences > # warn > out <- unitizer:::capture_output( + unitizer:::infer_unitizer_location(NULL, interactive = FALSE) + ) > any(grepl("too many to unambiguously", out$message)) [1] TRUE > > fake.class <- structure(list(), class = "thisclassdoesn'texist") > identical(infer(fake.class), fake.class) [1] TRUE > > # no match since file can't exist (warn) > f <- tempfile() > out <- capture.output( + invisible(unitizer:::infer_unitizer_location(f)), type='message' + ) > any(grepl("No possible matching files", out)) [1] TRUE > > > unlink(tmp.dir, recursive = TRUE) > > unitizer/tests/t-parse.R0000644000176200001440000002374714766101222015001 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") txt <- "# This is an early comment\n\n hello <- 25\n\n # multi\n # line\n # comment\n\n matrix(1:9, 3) # and another!\n\n unitizer_sect(\"here is a section\", {\n # test that were not crazy\n\n 1 + 1 == 2 # TRUE hopefully\n\n # Still not crazy\n\n 2 * 2 == 2 ^ 2\n # Tada\n } )\n sample(1:10)\n\n # and this comment belongs to whom?\n\n runif(20)\n print(\"woo\") # and I?\n " all <- unitizer:::parse_dat_get(text = txt) prs <- all$expr dat <- all$dat dat$parent <- pmax(0L, dat$parent) # With R4.0 some of the ids started changing normalize_id <- function(dat) { idu <- sort(unique(dat[["id"]])) id <- with(dat, match(id, idu)) parent <- with(dat, ifelse(parent == 0L, 0L, match(parent, idu))) dat[["id"]] <- id dat[["parent"]] <- parent dat } dat <- normalize_id(dat) dat.split <- dat.split.2 <- par.ids.3 <- NULL if.text <- "if # IFFY\n(x > 3 # ifcond\n){ hello\n #whome to attach?\n} else #final\ngoodbye" # - "Top Level Parents Identified Correctly" ----------------------------------- # "Identified top level parents?" par.ids <- with(dat, unitizer:::top_level_parse_parents(id, parent)) par.ids dat.split <- split(dat, par.ids) # "Identified sub-level top level parents correctly" par.ids.2 <- with(dat.split$`64`, unitizer:::top_level_parse_parents(id, parent, 64L)) par.ids.2 dat.split.2 <- split(dat.split$`64`, par.ids.2) # "Parent relationships in `unitizer_sect` piece." par.ids.3 <- with(dat.split.2$`62`, unitizer:::top_level_parse_parents(id, parent, 62L)) par.ids.3 # - "Comments Are Assigned" ---------------------------------------------------- # "Did we assign comments correctly to topmost level?" lapply(unitizer:::comments_assign(prs, dat.split$`0`), attr, "comment") # "No comments here so no changes should occur" all.equal(unitizer:::comments_assign(prs[[3]], dat.split.2$`64`), prs[[3]]) # "Comments in `unitizer_sect` body assigned correctly" lapply(unitizer:::comments_assign(prs[[3]][[3]], split(dat.split.2$`62`, par.ids.3)$`62`), attr, "comment") # - "Ancestry Descend" --------------------------------------------------------- x <- unitizer:::parse_dat_get(text = "1 + 1; fun(x, fun(y + z))")$dat x <- normalize_id(x) unitizer:::ancestry_descend(x$id, x$parent, 0) # - "Clean up Parse Data" ------------------------------------------------------ dat <- unitizer:::parse_dat_get(text = "{function(x) NULL;; #comment\n}")$dat # set negative ids to be top level parents dat <- transform(dat, parent = ifelse(parent < 0, 0L, parent)) dat <- normalize_id(dat) # "Ancestry Descend" dat.anc <- unitizer:::ancestry_descend(dat$id, dat$parent, 0L) dat.anc # "Excise `exprlist`" unitizer:::prsdat_fix_exprlist(dat, dat.anc)$token dat.1 <- unitizer:::parse_dat_get(text = "{1 ; ; ;2;}")$dat # set negative ids to be top level parents dat.1 <- transform(dat.1, parent = ifelse(parent < 0, 0L, parent)) dat.1 <- normalize_id(dat.1) # "Another `exprlist` test" unname( as.list( unitizer:::prsdat_fix_exprlist( dat.1, unitizer:::ancestry_descend(dat.1$id, dat.1$parent, 0L) )[c("parent", "token")] ) ) dat.2 <- unitizer:::parse_dat_get(text = "{NULL; yowza; #comment\nhello\n}")$dat # set negative ids to be top level parents dat.2 <- transform(dat.2, parent = ifelse(parent < 0, 0L, parent)) dat.2 <- normalize_id(dat.2) # "Yet another `exprlist`" unname( as.list( unitizer:::prsdat_fix_exprlist( dat.2, unitizer:::ancestry_descend(dat.2$id, dat.2$parent, 0L) )[c("parent", "token")] ) ) dat.2a <- normalize_id( unitizer:::parse_dat_get(text = "for(i in x) {if(x) break else next}")$dat ) # "`for` cleanup" as.list(unitizer:::prsdat_fix_for(dat.2a[-1L, ])) dat.3 <- normalize_id(unitizer:::parse_dat_get(text = if.text)$dat) # "`if` cleanup" unname(as.list(unitizer:::prsdat_fix_if(dat.3[-1, ])[c("id", "token")])) # - "Full Parse Works Properly" ------------------------------------------------ # "Full Comment Parse" unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt)) # "EQ_SUB and SYMBOL_SUB test" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "structure(1:3, # the data\nclass # the label\n=#the equal sign\n'hello' # the class\n)" ) ) # "Function with `exprlist`" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "function(x #first arg\n, y=25 #second arg with default\n) {x + y; # first comment\n; yo #second comment\n x / y; #lastcomment \n;}" ) ) # "`for` loop" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "for(i #in counter\nin 1:10#incounter again\n) {x + y; # first comment\n; next; yo #second comment\n x / y; break; #lastcomment \n;}" ) ) # "`if` statement" unitizer:::comm_extract(unitizer:::parse_with_comments(text = if.text)) # "formula" unitizer:::comm_extract( unitizer:::parse_with_comments( text = ". + x # hello\n#yowza\n~#bust a move\ny" ) ) # "`repeat`" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "repeat #first\n{runif(10); #comm\nbreak;}" ) ) # "S4 slot" unitizer:::comm_extract( unitizer:::parse_with_comments(text = "test@#comment\nhello <- 3") ) # "`while`" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "while(x > 5 # a comment\n) { hello; goodbye } #yay" ) ) txt2 <- "library(functools)\n fun <- function(a=1, bravo, card=25, ..., xar=list(\"aurochs\", 1), z) {}\n\n # Need to add tests:\n # - with complex objects? (did I mean in the definition? Or the call??)\n (NULL)\n # These should be identical to match.call()\n\n body(fun) <- parse(text=\"{print(match_call()); print(match.call())}\")\n\n calls <- c(\n 'fun(54, \"hello\", \"wowo\", \"blergh\", 8, 9)',\n 'fun(54, \"hello\", \"wowo\", \"blergh\", a=8, z=9)',\n 'fun(54, \"hello\", z=\"wowo\", \"blergh\", 8, 9)',\n 'fun(54, \"hello\", z=\"wowo\", x=\"blergh\", 8, 9)',\n 'fun(54, c=\"hello\", z=\"wowo\", xar=3, 8, 9)'\n )\n invisible(lapply(calls, function(x){cat(\"-- New Call --\", x, sep=\"\n\"); eval(parse(text=x))}))\n " test.comp <- unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt2)) # "A more complex test" lapply(test.comp[4:5], `[[`, 1) # "Added SYMBOL_PACKAGE token" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "# a comment before\nunitizer:::browse() #a comment after" ) ) # "Added SYMBOL_PACKAGE token v2" unitizer:::comm_extract( unitizer:::parse_with_comments( text = "# a comment before\nunitizer::browse() #a comment after" ) ) # LBB used to break stuff txt3 <- "# This is an early comment\n hello <- 25\n # multi\n hello[[1]] # and another!" # "LBB test" unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt3)) # - "Weird missing comment on `res` works" ------------------------------------- txt3 <- "# Calls to `library` and assignments are not normally considered tests, so\n# you will not be prompted to review them\n\nlibrary(utzflm)\nx <- 1:100\ny <- x ^ 2\nres <- fastlm(x, y)\n\nres # first reviewable expression\nget_slope(res)\nget_rsq(res)\n\nfastlm(x, head(y)) # This should cause an error; press Y to add to store" expr <- unitizer:::parse_with_comments(text = txt3) my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) capture.output(my.unitizer <- my.unitizer + expr) lapply(unitizer:::as.list(my.unitizer@items.new), slot, "comment") # - "exprlist excission with negative par ids" --------------------------------- txt <- "# For random tests\n\nunitizer_sect(\"blah\", {\n identity(1);\n})\n" prs.dat <- unitizer:::parse_dat_get(text = txt)$dat # set negative ids to be top level parents prs.dat <- transform(prs.dat, parent = ifelse(parent < 0, 0L, parent)) prs.dat <- normalize_id(prs.dat) ancestry <- with(prs.dat, unitizer:::ancestry_descend(id, parent, 0L)) x <- unitizer:::prsdat_fix_exprlist(prs.dat, ancestry) unname(as.matrix(x[, 5:6])) # - "empty symbols handled okay" ----------------------------------------------- # the empty second argument to `[` caused problems before txt <- "mtcars[1:10,]\n" # shouldn't cause error unitizer:::parse_with_comments(text = txt) # - "uncommenting works" ------------------------------------------------------- unitizer:::uncomment(expr[[1]]) # "don't blow away function arg names" unitizer:::uncomment(quote(function(a, b) NULL)) # # Recover comments and uncomment txt <- ".alike( # FALSE, match.call disabled\n quote(fun(b=fun2(x, y), 1, 3)), # first sub.call\n quote(fun(NULL, fun2(a, b), 1)), # second sub.call\n alike_settings(lang.mode=1))" exp <- unitizer:::parse_with_comments(text = txt) candc <- unitizer:::comm_and_call_extract(exp) candc$call[[1L]] candc$comments # - "failing parses produce proper errors" ------------------------------------- txt <- "this is a + syntax error that cannot be parsed" try(capture.output(unitizer:::parse_tests(text = txt), type = "message")) f <- tempfile() on.exit(unlink(f)) cat(txt, "\n", sep = "", file = f) try(capture.output(unitizer:::parse_tests(f), type = "message")) # try in normal mode (just fall back to normal parse) try(unitizer:::parse_tests(text = txt, comments = FALSE)) any( grepl( "unexpected symbol", capture.output(try(unitizer:::parse_tests(f, comments = FALSE)), type='message'), ) ) # - "NULL, constants, and new tokens" ------------------------------------------ # These were added with 3.6.3? Previously, it seems that the equal assign did # not generate a master expression to wrap all the pieces, which means these # tests just don't work because all the eq_assign at the top level end up with # the same parent and the parser gets confused. txt <- c("a = 2", "# ho how", "b = 3", "", "b + a # oh here", "", "b + # oh there", "a # bear", "", "NULL") if(getRversion() >= "3.6.3") { identical( unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt)), rds('parse-eq') ) } else TRUE with.const <- unitizer:::parse_with_comments(text = "3 # comment on const") unitizer:::symb_mark_rem(with.const[[1]]) unitizer/tests/t-exec.Rout.save0000644000176200001440000002553414766101222016274 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("exec") > > suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) > > # - "Invisible Expression" ----------------------------------------------------- > > e <- new.env() > exp <- quote(x <- 1:30) > all.equal(1:30, unitizer:::eval_user_exp(exp, e, global = glob)$value) [1] TRUE > > # `eval_user_exp` must be evaluated outside of test_that; also note that by > # design this will output stuff to stderr and stdout > out.err <- capture.output(type = "message", out.std <- capture.output({ + test.obj.s3 <- structure("hello", class = "test_obj") + setClass("testObj", list(a = "character")) + test.obj.s4 <- new("testObj", a = "goodday") + print.test_obj <- function(x, ...) stop("Error in Print") + setMethod("show", "testObj", function(object) stop("Error in Show")) + fun_signal <- function() signalCondition(simpleError("Error in Function", + sys.call())) + fun_error <- function() stop("Error in function 2") + fun_error_cond <- function() stop(simpleError("Error in function 2", + sys.call())) + fun_error_cond_call <- function() fun_error_cond() + fun_s3 <- function() test.obj.s3 + fun_s4 <- function() test.obj.s4 + fun_msg <- function() message("This is a Message") + fun_warn <- function() warning("This is a warning", immediate. = TRUE) + eval.env <- sys.frame(sys.nframe()) + ex0 <- unitizer:::eval_user_exp(quote(stop()), eval.env, + global = glob) + unitizer:::set_trace(ex0$trace) + trace0 <- unitizer:::unitizer_traceback() + ex1 <- unitizer:::eval_user_exp(quote(fun_signal()), eval.env, + global = glob) + unitizer:::set_trace(ex1$trace) + trace1 <- unitizer:::unitizer_traceback() + ex2 <- unitizer:::eval_user_exp(quote(fun_error()), eval.env, + global = glob) + unitizer:::set_trace(ex2$trace) + trace2 <- unitizer:::unitizer_traceback() + ex2a <- unitizer:::eval_user_exp(expression(fun_error()), + eval.env, global = glob) + unitizer:::set_trace(ex2a$trace) + trace2a <- unitizer:::unitizer_traceback() + ex6 <- unitizer:::eval_user_exp(quote(fun_error_cond()), + eval.env, global = glob) + unitizer:::set_trace(ex6$trace) + trace6 <- unitizer:::unitizer_traceback() + ex7 <- unitizer:::eval_user_exp(quote(fun_error_cond_call()), + eval.env, global = glob) + unitizer:::set_trace(ex7$trace) + trace7 <- unitizer:::unitizer_traceback() + ex3 <- unitizer:::eval_user_exp(quote(fun_s3()), eval.env, + global = glob) + unitizer:::set_trace(ex3$trace) + trace3 <- unitizer:::unitizer_traceback() + ex3a <- unitizer:::eval_user_exp(expression(fun_s3()), eval.env, + global = glob) + unitizer:::set_trace(ex3a$trace) + trace3a <- unitizer:::unitizer_traceback() + ex4 <- unitizer:::eval_user_exp(quote(fun_s4()), eval.env, + global = glob) + ex4a <- unitizer:::eval_user_exp(expression(fun_s4()), eval.env, + global = glob) + unitizer:::set_trace(ex4a$trace) + trace4a <- unitizer:::unitizer_traceback() + ex5 <- unitizer:::eval_user_exp(quote(sum(1:20)), eval.env, + global = glob) + ex9 <- unitizer:::eval_user_exp(quote(fun_warn()), eval.env, + global = glob) + ex10 <- unitizer:::eval_user_exp(quote(fun_msg()), eval.env, + global = glob) + ex11 <- unitizer:::eval_user_exp(quote((function() quote(stop("shouldn't error")))()), + eval.env, global = glob) + })) > # NOTE: deparsed test values generated with unitizer:::deparse_mixed > > # - "User Expression Evaluation" ----------------------------------------------- > > # a condition error, signaled, not stop (hence no aborted, etc.) > identical(ex1, rds(100)) [1] TRUE > # a stop > identical(ex2, rds(200)) [1] TRUE > # ex3 and ex3a are a total PITA because the calls need to be manually copied > # b/c they don't deparse properly even with control="all", the trace and > # call component loose the `structure` part in the quoted portions... > # a stop in print; > identical(ex3, rds(300)) [1] TRUE > identical(ex3a, rds(400)) [1] TRUE > # S4 objects; these originally caused problems since they don't deparse > identical(ex4, rds(500)) [1] TRUE > identical(ex4a, rds(600)) [1] TRUE > # a normal expression > identical(ex5, rds(700)) [1] TRUE > identical(ex9, rds(800)) [1] TRUE > all.equal(ex10, rds(900)) # not sure why identical doesn't work here [1] TRUE > # expect_false(ex11$aborted) > ex11$aborted # FALSE [1] FALSE > > # - "Trace Setting" ------------------------------------------------------------ > > identical(trace0, trace1) [1] TRUE > # expect_identical(trace2, list("stop(\"Error in function 2\")", > # "fun_error()")) > trace2 [[1]] [1] "stop(\"Error in function 2\")" [[2]] [1] "fun_error()" > trace6 [[1]] [1] "stop(simpleError(\"Error in function 2\", sys.call()))" [[2]] [1] "fun_error_cond()" > trace7 [[1]] [1] "stop(simpleError(\"Error in function 2\", sys.call()))" [[2]] [1] "fun_error_cond()" [[3]] [1] "fun_error_cond_call()" > trace3a [[1]] [1] "stop(\"Error in Print\")" [[2]] [1] "print.test_obj(\"hello\")" [[3]] [1] "print(\"hello\")" > > # needed to tweak this one so it would pass in R-devel 3.4.1 > # expect_true(all(mapply(function(x, y) grepl(y, x), trace4a, list("stop\\(\"Error in Show\"\\)", > # "show\\(.*\"testObj\".*\\)", "show\\(.*\"testObj\".*\\)")))) > all( + mapply( + function(x, y) grepl(y, x), + trace4a, + list( + "stop\\(\"Error in Show\"\\)", + "show\\(.*\"testObj\".*\\)", "show\\(.*\"testObj\".*\\)") + ) ) [1] TRUE > # - "Clean Top Level Message" -------------------------------------------------- > > old.width <- options(width = 80L) > a <- unitizer:::eval_with_capture( + expression(stop("short stop message")), global = glob + ) > b <- unitizer:::eval_with_capture( + expression(stop("short stop .* with regex message")), global = glob + ) > c <- unitizer:::eval_with_capture( + expression(stop("this is a long error message that is supposed to cause R to add a new line after the error: part")), + global = glob + ) > d <- unitizer:::eval_with_capture( + expression(warning("short warning message")), global = glob + ) > e <- unitizer:::eval_with_capture( + expression(warning("short warning message .* with regex")), global = glob + ) > f <- unitizer:::eval_with_capture( + expression( + warning("this is a long error message that is supposed to cause R to add a new line after the error: part") + ), + global = glob + ) > g <- unitizer:::eval_with_capture( + quote(stop("short stop message")), global = glob + ) > h <- unitizer:::eval_with_capture( + quote(stop("short stop .* with regex message")), global = glob + ) > i <- unitizer:::eval_with_capture( + quote(stop("this is a long error message that is supposed to cause R to add a new line after the error: part")), + global = glob + ) > j <- unitizer:::eval_with_capture( + quote(warning("short warning message")), global = glob + ) > k <- unitizer:::eval_with_capture( + quote(warning("short warning message .* with regex")), global = glob + ) > l <- unitizer:::eval_with_capture( + quote(warning("this is a long error message that is supposed to cause R to add a new line after the error: part")), + global = glob + ) > m <- unitizer:::eval_with_capture(expression("a"/3), global = glob) > exp.q <- quote({ + fun <- function() warning("error in fun") + message("boo hay \n there \n") + warning("this is a fairly long warning wladsfasdfasd that might wrap if we keep typing humpty dumpty sat on a wall and had a big fall") + warning("ashorter warning blah") + message("boo hay \n there \n") + warning() + fun() + suppressWarnings(warning("quiet warn")) + message("boo hay \n there \n") + error(3) + }) > x <- unitizer:::eval_with_capture(exp.q, global = glob) > exp.exp <- expression({ + fun <- function() warning("error in fun") + message("boo hay \n there \n") + warning("this is a fairly long warning wladsfasdfasd that might wrap if we keep typing humpty dumpty sat on a wall and had a big fall") + warning("ashorter warning blah") + message("boo hay \n there \n") + warning() + fun() + suppressWarnings(warning("quiet warn")) + message("boo hay \n there \n") + error(3) + }) > y <- unitizer:::eval_with_capture(exp.exp, global = glob) > options(old.width) > > a$message [1] "Error: short stop message\n" > b$message [1] "Error: short stop .* with regex message\n" > c$message [1] "Error: \n this is a long error message that is supposed to cause R to add a new line after the error: part\n" > d$message [1] "Warning: short warning message\n" > e$message [1] "Warning: short warning message .* with regex\n" > f$message [1] "Warning:\n this is a long error message that is supposed to cause R to add a new line after the error: part\n" > g$message [1] "Error: short stop message\n" > h$message [1] "Error: short stop .* with regex message\n" > i$message [1] "Error: \n this is a long error message that is supposed to cause R to add a new line after the error: part\n" > j$message [1] "Warning: short warning message\n" > k$message [1] "Warning: short warning message .* with regex\n" > l$message [1] "Warning:\n this is a long error message that is supposed to cause R to add a new line after the error: part\n" > m$message [1] "Error in \"a\"/3 : non-numeric argument to binary operator\n" > > # `sub` needed due to inconsistencies in R 3.4 and 3.3 for top level error > # messages > writeLines(sub("\\bError.*: ", "", x$message)) boo hay there Warning: this is a fairly long warning wladsfasdfasd that might wrap if we keep typing humpty dumpty sat on a wall and had a big fall Warning: ashorter warning blah boo hay there Warning: Warning in fun() : error in fun boo hay there could not find function "error" > writeLines(sub("\\bError.*: ", "", y$message)) boo hay there Warning: this is a fairly long warning wladsfasdfasd that might wrap if we keep typing humpty dumpty sat on a wall and had a big fall Warning: ashorter warning blah boo hay there Warning: Warning in fun() : error in fun boo hay there could not find function "error" > > > proc.time() user system elapsed 0.847 0.127 0.973 unitizer/tests/t-ischecks.Rout.save0000644000176200001440000000410614766101222017134 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > # - "int.pos" ------------------------------------------------------------------ > > unitizer:::is.int.pos.1L(c(1, 2, 3)) # FALSE [1] FALSE > unitizer:::is.int.pos.1L(1) [1] TRUE > unitizer:::is.int.pos.1L(1) [1] TRUE > unitizer:::is.int.pos.1L(-1) # FALSE [1] FALSE > unitizer:::is.int.pos.1L(NA_integer_) # FALSE [1] FALSE > unitizer:::is.int.pos.2L(1:2) [1] TRUE > unitizer:::is.int.pos.2L(c(1, 2)) [1] TRUE > > # - "is.valid_two_arg" --------------------------------------------------------- > > f1 <- function(x, y) NULL > f2 <- function(...) NULL > f3 <- function(x, ...) NULL > f4 <- function(x, y, z) NULL > f5 <- function(x, y, z = 3) NULL > f6 <- function(x) NULL > unitizer:::is.two_arg_fun(f1) [1] TRUE > unitizer:::is.two_arg_fun(f2) [1] TRUE > unitizer:::is.two_arg_fun(f3) [1] TRUE > unitizer:::is.two_arg_fun(f4) [1] "cannot have any non-optional arguments other than first two" > unitizer:::is.two_arg_fun(f5) [1] TRUE > unitizer:::is.two_arg_fun(f6) [1] "does not have at least two arguments" > unitizer:::is.two_arg_fun(1) [1] "is not a function" > > # - "is.valid_capt_setting" ---------------------------------------------------- > > capt.test <- unitizer:::is.valid_capt_setting(c(T, T)) | value must be logical(2L) containing TRUE | / FALSE and with names `c("output", "message") > capt.test [1] FALSE > > proc.time() user system elapsed 0.650 0.088 0.724 unitizer/tests/t-section.R0000644000176200001440000000702114766101222015316 0ustar liggesuserssource(file.path("_helper", "init.R")) expr.1 <- expression(1 + 1, b <- 5, matrix(integer(), nrow = b, ncol = b)) expr.2 <- { 1 + 1 b <- 5 matrix(integer(), nrow = b, ncol = b) } expr.3 <- quote(expression(1 + 1, b <- 5, matrix(integer(), nrow = b, ncol = b))) expr.4 <- quote({ 1 + 1 b <- 5 matrix(integer(), nrow = b, ncol = b) }) # - "simple tests" ------------------------------------------------------------- try(unitizer_sect(1:3)) try(unitizer_sect(letters)) try(unitizer_sect("mytest", expr.1, 1:3)) # note the following two produce error messages, but it's not actually an error, # it's just that there are multiple errors and `expect_error` only suppresses # the last one, not the preceding ones. try(unitizer_sect("mytest", expr.1, letters, letters)) try(unitizer_sect("mytest", expr.1, letters, identity)) try(unitizer_sect("mytest", expr.2)) try(unitizer_sect("mytest", matrix(1:9, nrow = 3))) is(sect.1 <- unitizer_sect("mytest", expr.1), "unitizerSectionExpression") identical(unitizer:::as.expression(sect.1), expr.1) is(sect.2 <- unitizer_sect("mytest", { 1 + 1 b <- 5 matrix(integer(), nrow = b, ncol = b) }), "unitizerSectionExpression") identical(sect.1, sect.2) is(sect.3 <- unitizer_sect("mytest", expr.3), "unitizerSectionExpression") identical(sect.1, sect.3) is(sect.4 <- unitizer_sect("mytest", expr.4), "unitizerSectionExpression") identical(sect.1, sect.4) is(sect.5 <- unitizer_sect("mytest", expression(1 + 1, b <- 5, matrix(integer(), nrow = b, ncol = b))), "unitizerSectionExpression") identical(sect.1, sect.5) is(sect.1 <- unitizer_sect("mytest", expr.1, compare = identical), "unitizerSectionExpression") unitizer_sect("hello") # warn # - "Custom Comparison Functions" ---------------------------------------------- # Run expressions with different comparison functions set.seed(1) expr.1 <- expression(50 + runif(1)/10^10, message("Hello There", runif(1)), cat("Hello there", runif(1)), stop("Yo", runif(1))) expr.2 <- expression(50 + runif(1)/10^10, message("Hello There", runif(1)), cat("Hello there", runif(1)), stop("Yo", runif(1))) expr.3 <- expression(unitizer_sect("change comp funs", compare = identical, { 50 + runif(1)/10^10 message("Hello There", runif(1)) cat("Hello there", runif(1)) stop("Yo", runif(1)) })) expr.4 <- expression( unitizer_sect( "change comp funs", compare = testFuns( value = identical, output = all.equal, message = all.equal, conditions = function(x, y) TRUE), { 50 + runif(1)/10^10 message("Hello There", runif(1)) cat("Hello there", runif(1)) stop("Yo", runif(1)) })) my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) coi(my.unitizer <- my.unitizer + expr.1) my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env()) # make previous items into reference items coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new) # now add back items to compare coi(my.unitizer2 <- my.unitizer2 + expr.2) my.unitizer3 <- new("unitizer", id = 3, zero.env = new.env()) # make previous items into reference items coi(my.unitizer3 <- my.unitizer3 + my.unitizer@items.new) # now add back items to compare coi(my.unitizer3 <- my.unitizer3 + expr.3) my.unitizer4 <- new("unitizer", id = 4, zero.env = new.env()) # make previous items into reference items coi(my.unitizer4 <- my.unitizer4 + my.unitizer@items.new) # now add back items to compare coi(my.unitizer4 <- my.unitizer4 + expr.4) my.unitizer2@tests.result my.unitizer3@tests.result my.unitizer4@tests.result unitizer/tests/t-handledruns.R0000644000176200001440000000121314766101222016156 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "Ensure we get warning if we try to run in handlers" ----------------------- try(unitize("_helper/unitizers/trivial.R")) tryCatch(unitize("_helper/unitizers/trivial.R")) withRestarts(unitize("_helper/unitizers/trivial.R")) # need to figure out why running this without `try` in covr causes cover to # fail with # Error in aggregate.data.frame(mf[1L], mf[-1L], FUN = FUN, ...) : # no rows to aggregate # - "Ensure we get error if we try to do something stupid..." ------------------ try( withRestarts( unitize("_helper/unitizers/trivial.R"), unitizerInteractiveFail = function() NULL ) ) unitizer/tests/t-ischecks.R0000644000176200001440000000173114766101222015450 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "int.pos" ------------------------------------------------------------------ unitizer:::is.int.pos.1L(c(1, 2, 3)) # FALSE unitizer:::is.int.pos.1L(1) unitizer:::is.int.pos.1L(1) unitizer:::is.int.pos.1L(-1) # FALSE unitizer:::is.int.pos.1L(NA_integer_) # FALSE unitizer:::is.int.pos.2L(1:2) unitizer:::is.int.pos.2L(c(1, 2)) # - "is.valid_two_arg" --------------------------------------------------------- f1 <- function(x, y) NULL f2 <- function(...) NULL f3 <- function(x, ...) NULL f4 <- function(x, y, z) NULL f5 <- function(x, y, z = 3) NULL f6 <- function(x) NULL unitizer:::is.two_arg_fun(f1) unitizer:::is.two_arg_fun(f2) unitizer:::is.two_arg_fun(f3) unitizer:::is.two_arg_fun(f4) unitizer:::is.two_arg_fun(f5) unitizer:::is.two_arg_fun(f6) unitizer:::is.two_arg_fun(1) # - "is.valid_capt_setting" ---------------------------------------------------- capt.test <- unitizer:::is.valid_capt_setting(c(T, T)) capt.test unitizer/tests/t-utz2.Rout.save0000644000176200001440000012170014766101222016244 0ustar liggesusers R Under development (unstable) (2023-03-16 r83985) -- "Unsuffered Consequences" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: aarch64-apple-darwin20 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Overflow tests from testthat.unitize.R > > source(file.path("_helper", "init.R")) > source(file.path("_helper", "pkgs.R")) Install Packages Setup Demos > > library(unitizer) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "unreviewed variations" ---------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Test unreviewed > # Accept one and go to unreviewed > # Accept one more and browse and go to unreviewed > # Accept two remaining and confirm no unreviewed > # No unreviewed tests > unitizer:::read_line_set_vals( + c("Y", "Q", "U", "Y", "B", "U", "Y", "Y", "U", "B", "U", "Q") + ) > out <- unitizer:::capture_output(unitize(FLM.TEST.FILE, interactive.mode = TRUE)) > unitizer:::clean_eval_exp(out) - Output ----------------------------------------------------------------------- +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail New - - 4 ........................... - - 4 - New -------------------------------------------------------------------------- | The 4 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? # Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # The `unitizer>` prompt is like the standard R prompt. You may # enter expressions such as `lm(y ~ x, dat)$coefficients`, or # `str(res)`. # # Once you are done reviewing, you need to tell `unitizer` you # accept the test by typing 'Y' at the prompt. Enter 'H' for help. > res intercept slope rsq -1717.000 101.000 0.939 attr(,"class") [1] "fastlm" unitizer> Y # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> Q = Finalize Unitizer ============================================================ | You have 3 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [U]nreviewed, [R]erun)? unitizer> U # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> Y > get_rsq(res) [1] 0.939 unitizer> B *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . . New:Y 5. get_slope(res) . . . . . . . . . . . . . . . . New:Y 6. get_rsq(res) . . . . . . . . . . . . . . . . . New:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . New:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> U - New -------------------------------------------------------------------------- | The 4 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? > get_rsq(res) [1] 0.939 unitizer> Y # This last test is expected to cause an error; press 'Y' to # accept it so future checks can confirm the same error persists > fastlm(1:100, 1:10) unitizer> Y = Finalize Unitizer ============================================================ | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> U | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? unitizer> B *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . . New:Y 5. get_slope(res) . . . . . . . . . . . . . . . . New:Y 6. get_rsq(res) . . . . . . . . . . . . . . . . . New:Y 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . New:Y | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> U = Finalize Unitizer ============================================================ | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Q | unitizer unchanged. - Message ---------------------------------------------------------------------- | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Adding 1 out of 4 new tests Error in fastlm(1:100, 1:10) : Arguments `x` and `y` must be the same length. | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Adding 4 out of 4 new tests Error in : object 'U' not found | No unreviewed tests. | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Adding 4 out of 4 new tests | Changes discarded. > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Re-eval" ------------------------------------------------------------------ > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Test re-eval > # Re-eval and jump back to file 1 > # Quit from file 1 and back to main menu > # Accept one test in file 2 and quit > # Go to file 3, accept one, and Re-eval all > > unitizer:::read_line_set_vals( + c("1", "Y", "R", "Y", "Q", "2", "Y", "Y", "3", "Y", "RR", "Y", "Q", "Q") + ) > untz1 <- unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R - - 4 | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | - - 8 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail New - - 4 ........................... - - 4 - New -------------------------------------------------------------------------- | The 4 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? # Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # The `unitizer>` prompt is like the standard R prompt. You may # enter expressions such as `lm(y ~ x, dat)$coefficients`, or # `str(res)`. # # Once you are done reviewing, you need to tell `unitizer` you # accept the test by typing 'Y' at the prompt. Enter 'H' for help. > res intercept slope rsq -1717.000 101.000 0.939 attr(,"class") [1] "fastlm" unitizer> Y # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 3 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Adding 1 out of 4 new tests | Update unitizer and re-run unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [U] | nreviewed, [R]erun)? unitizer> Y | unitizer updated. +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail New 1 - 3 ........................... 1 - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? | Jumping to test #5 because that was the test under review when test re-run was | requested. # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R 1 - 3 | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | 1 - 7 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 2 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm2.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? # For internal tests only; not for demo > x <- 1:10 > y <- 1:10^3 > res <- summary(lm(y ~ x, data.frame(x = x, y = y))) > intercept <- res$coefficients[1, 1] > slope <- res$coefficients[2, 1] > rsq <- res$r.squared > structure(c(intercept = intercept, slope = slope, rsq = rsq), + class = "fastlm") intercept slope rsq 4.95e+02 1.00e+00 9.90e-05 attr(,"class") [1] "fastlm" unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm2.unitizer' by: | - Adding 1 out of 1 new tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Y | unitizer updated. | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R 1 - 3 | $2. fastlm2.R ? ? ? | *3. unitizer.fastlm.R - - 3 | ..................................... | ? ? ? | Legend: | * `unitizer` requires review | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> 3 +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New - - 3 ........................... - - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 105 unitizer> Y > get_rsq(res) [1] 0.862 unitizer> RR | Toggling re-run mode ON for all loaded unitizers = Finalize Unitizer ============================================================ | You have 2 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You will IRREVERSIBLY modify 'unitizer/unitizer.fastlm.unitizer' by: | - Adding 1 out of 3 new tests | Update unitizer and re-run all loaded unitizers ([Y]es, [N]o, [P]rev, [B] | rowse, [U]nreviewed, [R]erun)? unitizer> Y | unitizer updated. | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R 1 - 3 | 2. fastlm2.R 1 - - | *3. unitizer.fastlm.R 1 - 2 | ..................................... | 3 - 5 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > print(untz1) Summary of tests (accept/total): id test.file New Passed Totals 1 fastlm1.R 0/3 1/1 1/4 $ 2 fastlm2.R 0/0 1/1 1/1 $ 3 unitizer.fastlm.R 0/2 1/1 1/3 $ ----------------------------------------------------- 0 Totals 0/5 3/3 3/8 $ unitizer was saved in prior evaluation Test files in common directory 'tests/unitizer' > # remove temp file names and display > invisible(lapply(untz1, function(x) {print(x); cat('\n')})) Test File: tests/unitizer/fastlm1.R Store ID: tests/unitizer/fastlm1.unitizer id call ignored status user reviewed 1 4 library(utzflm, lib.loc = g... * Passed Y FALSE 2 5 dat <- data.frame(x = 1:100... * Passed Y FALSE 3 6 res <- fastlm(dat$x, dat$y) * Passed Y FALSE 4 7 res Passed Y FALSE 5 1 get_slope(res) New N FALSE 6 2 get_rsq(res) New N FALSE 7 3 fastlm(1:100, 1:10) New N FALSE You chose NOT to save these changes to the unitizer store Test File: tests/unitizer/fastlm2.R Store ID: tests/unitizer/fastlm2.unitizer id call ignored status user reviewed 1 1 x <- 1:10 * Passed Y FALSE 2 2 y <- 1:10^3 * Passed Y FALSE 3 3 res <- summary(lm(y ~ x, da... * Passed Y FALSE 4 4 intercept <- res$coefficien... * Passed Y FALSE 5 5 slope <- res$coefficients[2... * Passed Y FALSE 6 6 rsq <- res$r.squared * Passed Y FALSE 7 7 structure(c(intercept = int... Passed Y FALSE You chose NOT to save these changes to the unitizer store Test File: tests/unitizer/unitizer.fastlm.R Store ID: tests/unitizer/unitizer.fastlm.unitizer id call ignored status user reviewed 1 3 library(utzflm, lib.loc = g... * Passed Y FALSE 2 4 x <- 1:10 * Passed Y FALSE 3 5 y <- x^3 * Passed Y FALSE 4 6 res <- fastlm(x, y) * Passed Y FALSE 5 7 get_slope(res) Passed Y FALSE 6 1 get_rsq(res) New N FALSE 7 2 get_intercept(res) New N FALSE You chose NOT to save these changes to the unitizer store > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Section Extra" ------------------------------------------------------------ > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Make sure that deleted items from a section are still marked from that > # section upgrade to version two to use the files that are set up for that > # there; notice update_fastlm_*extra* > # Re-set by dropping unitizers > > unlink(list.dirs(FLM.TEST.DIR, recursive = FALSE), recursive = TRUE) > unitizer:::update_fastlm_extra(FLM) > inst_pak(FLM) > test.file.1 <- file.path(FLM.TEST.DIR, "unitizer.fastlm.R") > test.file.2 <- file.path(FLM.TEST.DIR, "unitizer.fastlm2.R") > test.store <- file.path(FLM.TEST.DIR, "store2.unitizer") > # First auto accept all initial tests, and then re-run with second version to > # make sure deleted tests are where we think they should be > out.1 <- + unitizer:::capture_output(unitize(test.file.1, test.store, auto.accept = "new")) > unitizer:::read_line_set_vals(c("B", "Q")) > out.2 <- unitizer:::capture_output( + untz.2 <- unitize(test.file.2, test.store, interactive.mode = TRUE) + ) > attributes(untz.2) <- NULL > untz.2 [[1]] [1] 1 2 3 4 5 6 7 [[2]] [1] "library(utzflm, lib.loc = getOption(\"unitizer.tmp.lib.loc\"))" [2] "x <- 1:10" [3] "y <- x^2" [4] "res <- fastlm(x, y)" [5] "get_slope(res)" [6] "get_rsq(res)" [7] "2 * get_slope(res) + get_intercept(res)" [[3]] [1] "Basic Tests" "Basic Tests" "Basic Tests" "Basic Tests" [5] "Basic Tests" "Advanced Tests" "Advanced Tests" [[4]] [1] TRUE TRUE TRUE TRUE FALSE FALSE FALSE [[5]] [1] Failed Failed Failed Failed Failed Failed Removed Levels: New Passed Failed Removed Corrupted [[6]] [1] N N N N N N N Levels: Y N [[7]] [1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "warning when comp funs produce output" ------------------------------------ > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Sections with comp funs that output to stdout/stderr > temp.loc <- tempfile() > dir.create(temp.loc) > file.copy(file.path(START.DIR, "_helper", "unitizers", "sects.R"), temp.loc) [1] TRUE > f.sec <- file.path(temp.loc, "sects.R") > odir <- setwd(temp.loc) > out <- unitizer:::capture_output( + unitize(f.sec, auto.accept = "new", interactive.mode = FALSE + ) ) > > unitize(f.sec, interactive.mode = FALSE) Warning in close_and_clear(e1@global$cons) : Test comparison functions appear to have produced output, which should not happen (see `?unitizer_sect` for more details). If you did not provide custom testing functions, contact maintainer. First 50 lines follow: I'm outputting to stdout I'm outputting to stderr I'm outputting to both 1 I'm outputting to both 2 Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | 3/3 tests passed; nothing to review. > setwd(odir) > unlink(temp.loc, recursive = TRUE) > > # - "Corner Case Files" -------------------------------------------------------- > > # Corner case files > # empty > temp.empty <- paste0(tempfile(), "-empty.R") > cat("\n", file = temp.empty) > empty.capt <- unitizer:::capture_output(unitize(temp.empty, force = TRUE)) > # File, but does not end in .R > temp.bad <- paste0(tempfile()) > > cat("\n", file = temp.bad) > badname.capt <- unitizer:::capture_output(try(unitize(temp.bad))) > any(grepl("`get_unitizer` error", out$message)) [1] FALSE > > any(grepl("Empty unitizer", empty.capt$output)) [1] TRUE > any(grepl("No valid unitizers available", badname.capt$message)) [1] FALSE > unlink(c(temp.empty, temp.bad)) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Re-eval change" ----------------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # re-eval reeval with a modified file > temp.reeval.base <- paste0(tempfile(), "-reeval") > temp.reeval <- paste0(temp.reeval.base, ".R") > temp.reeval.utz <- paste0(temp.reeval.base, ".unitizer") > cat("1 + 1\n2 + 2\n", file = temp.reeval) > # force re-review > unitizer:::read_line_set_vals(c("Y", "P", "Y", "cat(\"1 + 1\n2 + 3\n\", file=temp.reeval)", + "R", "Y", "Q")) > # state = environment() so we can access variables from this local > reeval.capt <- unitizer:::capture_output(unitize(temp.reeval, + state = environment(), interactive.mode = TRUE)) > unlink(c(temp.reeval, temp.reeval.utz), recursive = TRUE) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Condition fail" ----------------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Fail test with conditions > temp.cond.base <- paste0(tempfile(), "-cond") > temp.cond <- paste0(tempfile(), ".R") > temp.cond.utz <- paste0(tempfile(), ".unitizer") > cond.message <- "hello world" > cat("warning(cond.message)", file = temp.cond) > unitizer:::read_line_set_vals(c("Y", "Y")) > # state = environment() so we can access variables from this local > unitizer:::capture_output( + unitize(temp.cond, state = environment(), interactive.mode = TRUE) + ) > cond.message <- "goodbye world" > unitizer:::read_line_set_vals("Q") > cond.capt <- + unitizer:::capture_output( + unitize(temp.cond, state = environment(), interactive.mode = TRUE) + ) > sum(grepl("Conditions mismatch", cond.capt$output)) == 1L [1] TRUE > unlink(c(temp.cond, temp.cond.utz), recursive = TRUE) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Force" -------------------------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # > # Toggle force update, in order for this to work we need to create a situation > # where in a `unitize_dir`, one file passes, the other doesn't, and we review > # the file that passes. Otherwise the only other way to do it is to set force > # from the beginning, but that ruins the toggle effect. One possible issue > # here is that we don't have a great way to check the file actually changed. > > temp.forceup.base.dir <- tempfile() > dir.create(temp.forceup.base.dir) > temp.forceup.1 <- file.path(temp.forceup.base.dir, "force1.R") > temp.forceup.2 <- file.path(temp.forceup.base.dir, "force2.R") > cat("force.var\n", file = temp.forceup.1) > cat("4 + 1\n", file = temp.forceup.2) > force.var <- 1 > unitizer:::capture_output({ + unitize(temp.forceup.1, auto.accept = "new", state = environment()) + unitize(temp.forceup.2, auto.accept = "new", state = environment()) + }) > force.var <- 2 > unitizer:::read_line_set_vals(c("2", "1", "Y", "O", "Q", "Q")) > force.capt <- unitizer:::capture_output(unitize_dir(temp.forceup.base.dir, + state = environment(), interactive.mode = TRUE)) > unlink(temp.forceup.base.dir, recursive = TRUE) > sum(grepl("Toggling force update mode ON", force.capt$message)) == + 1L [1] TRUE > sum(grepl("You are about to .* with re-evaluated", force.capt$message)) == + 1L [1] TRUE > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Compare Funs" ------------------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Bad comparison functions > temp.bad.comp <- paste0(tempfile(), ".R") > cat("\n unitizer_sect(\n 'bad comp', {1 + 1; 2 + 2},\n compare=function(x, y) list('failed', 'comparison')\n )\n", + file = temp.bad.comp) > unitizer:::capture_output(unitize(temp.bad.comp, auto.accept = "new")) > unitizer:::read_line_set_vals(c("Q")) > bad.comp.capt <- unitizer:::capture_output(unitize(temp.bad.comp, + interactive.mode = TRUE)) > unlink(temp.bad.comp) > > sum(grepl("Unable to compare value", bad.comp.capt$message)) == 1L [1] TRUE > sum(grepl("Corrupted", bad.comp.capt$output)) >= 1L [1] TRUE > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "bad map" ------------------------------------------------------------------ > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Bad store mapping functions > > try(unitize_dir(FLM.TEST.DIR, store.ids = function(x) stop("Bad store map fun"))) Error in FUN(X[[i]], ...) : Bad store map fun Error in unitize_dir(FLM.TEST.DIR, store.ids = function(x) stop("Bad store map fun")) : Argument `store.ids` is a function, but caused an error when attempting to use it to convert test file names to `unitizer` ids. > > unitizer:::read_line_set_vals(NULL) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Multiple Bookmarks" ------------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Issue 245: In review-all mode should not move to next unitizer until the > # review bookmark is cleared. > > temp.dir <- tempfile() > dir.create(temp.dir) > writeLines("'hello'\n'world'", file.path(temp.dir, "a.R")) > writeLines("2 + 1\n3 + 2", file.path(temp.dir, "b.R")) > writeLines("pi\n2 * pi\nsqrt(pi)", file.path(temp.dir, "c.R")) > unitizer:::read_line_set_vals( + c("A","N","N","Y","Y","R","Y","Q","Y","R","Y","Y","Y","Y","Q") + ) > unitize_dir(temp.dir, interactive.mode=TRUE) | Summary of files in common directory '.': | | Pass Fail New | *1. a.R - - 2 | *2. b.R - - 2 | *3. c.R - - 3 | ....................... | - - 7 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: a.R | +------------------------------------------------------------------------------+ Pass Fail New - - 2 ........................... - - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > "hello" [1] "hello" unitizer> N > "world" [1] "world" unitizer> N = Finalize Unitizer ============================================================ | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Exit unitizer ([Y]es, [P]rev, [B]rowse, [R]erun, f[O]rce, [QQ]uit All)? unitizer> Y | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: b.R | +------------------------------------------------------------------------------+ Pass Fail New - - 2 ........................... - - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > 2 + 1 [1] 3 unitizer> Y > 3 + 2 [1] 5 unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 1 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You will IRREVERSIBLY modify 'b.unitizer' by: | - Adding 1 out of 2 new tests | Update unitizer and re-run unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [U] | nreviewed, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. +------------------------------------------------------------------------------+ | unitizer for: b.R | +------------------------------------------------------------------------------+ Pass Fail New 1 - 1 ........................... 1 - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [QQ]uit All, [Q]uit, [H]elp)? | Jumping to test #2 because that was the test under review when test re-run was | requested. > 3 + 2 [1] 5 unitizer> Q | No changes recorded. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: c.R | +------------------------------------------------------------------------------+ Pass Fail New - - 3 ........................... - - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > pi [1] 3.14 unitizer> Y > 2 * pi [1] 6.28 unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 2 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You will IRREVERSIBLY modify 'c.unitizer' by: | - Adding 1 out of 3 new tests | Update unitizer and re-run unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [U] | nreviewed, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. +------------------------------------------------------------------------------+ | unitizer for: c.R | +------------------------------------------------------------------------------+ Pass Fail New 1 - 2 ........................... 1 - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? | Jumping to test #2 because that was the test under review when test re-run was | requested. > 2 * pi [1] 6.28 unitizer> Y > sqrt(pi) [1] 1.77 unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'c.unitizer' by: | - Adding 2 out of 2 new tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Y | unitizer updated. | Summary of files in common directory '.': | | Pass Fail New | *1. a.R - - 2 | *2. b.R 1 - 1 | $3. c.R ? ? ? | ....................... | ? ? ? | Legend: | * `unitizer` requires review | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> Q > > # Make sure re-eval all clears all bookmarks > unlink( + list.files(temp.dir, full.names=TRUE, pattern="\\.unitizer$"), + recursive=TRUE + ) > unitizer:::read_line_set_vals(c("A","Q","Y","RR","Y","Q")) > unitize_dir(temp.dir, interactive.mode=TRUE) | Summary of files in common directory '.': | | Pass Fail New | *1. a.R - - 2 | *2. b.R - - 2 | *3. c.R - - 3 | ....................... | - - 7 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: a.R | +------------------------------------------------------------------------------+ Pass Fail New - - 2 ........................... - - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > "hello" [1] "hello" unitizer> Q | No changes recorded. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: b.R | +------------------------------------------------------------------------------+ Pass Fail New - - 2 ........................... - - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > 2 + 1 [1] 3 unitizer> Y > 3 + 2 [1] 5 unitizer> RR | Toggling re-run mode ON for all loaded unitizers = Finalize Unitizer ============================================================ | You have 1 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You will IRREVERSIBLY modify 'b.unitizer' by: | - Adding 1 out of 2 new tests | Update unitizer and re-run all loaded unitizers ([Y]es, [N]o, [P]rev, [B] | rowse, [U]nreviewed, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. | Summary of files in common directory '.': | | Pass Fail New | *1. a.R - - 2 | *2. b.R 1 - 1 | *3. c.R - - 3 | ....................... | 1 - 6 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > > unitizer:::read_line_set_vals(NULL) > unlink(temp.dir, recursive=TRUE) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Non-Standard Conditions" -------------------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Issue 272: some conditions don't produce any output, but for `unitizer` we > # consider normally non-test expressions that produce conditions as tests. So > # we need a mechanism for clarifying what happened. > > temp.dir <- tempfile() > temp.file <- file.path(temp.dir, 'a.R') > dir.create(temp.dir) > > unitizer:::read_line_set_vals("Q") > writeLines( + c( + "cond <- simpleCondition('hello')", + "class(cond) <- c('svgchop_unsupported', 'svgchop', class(cond))", + "invisible(signalCondition(cond))" + ), + temp.file + ) > unitize(temp.file, interactive.mode=TRUE) +------------------------------------------------------------------------------+ | unitizer for: a.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? > cond <- simpleCondition("hello") > class(cond) <- c("svgchop_unsupported", "svgchop", class(cond)) > invisible(signalCondition(cond)) | Test silently signalled conditions (use e.g. .NEW$conditions[[1]] to inspect): Condition list with 1 condition: 1. svgchop_unsupported: hello unitizer> Q | No changes recorded. | unitizer unchanged. > > unitizer:::read_line_set_vals(NULL) > unlink(temp.dir, recursive=TRUE) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Output Transcript in non-Interactive" ------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Issue 286: don't capture output in non-interactive. > # We need `try` because we're testing what happens when the unitizer fails. > > temp.dir <- tempfile() > temp.file <- file.path(temp.dir, 'a.R') > dir.create(temp.dir) > writeLines('warning("boom")', temp.file) # can't use error b/c try below > old.opt <- options(unitizer.transcript=NULL, unitizer.show.progress=TRUE) > try(unitize(temp.file)) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Preloads... Loading unitizer data... Parsing tests... Parsing a.R Evaluating tests... warning("boom") Warning in withVisible(warning("boom")) : boom Prepping Unitizers... Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. +------------------------------------------------------------------------------+ | unitizer for: a.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? > warning("boom") | Test signalled conditions (use e.g. .NEW$conditions[[1]] to inspect): Condition list with 1 condition: 1. Warning: boom | User input required to proceed, but we are in non-interactive mode. | unitizer unchanged. | * New: warning("boom") | in 'a.R' | Newly evaluated tests do not match unitizer (New: 1); see above for more info, | or run in interactive mode. | Running in transcript mode: only stderr text that is also part of a signalled | condition is in the test review section (scroll up to the evaluation section | for the rest). See `transcript` parameter in `?unitize`. Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : Cannot proceed in non-interactive mode. > options(old.opt) > unlink(temp.dir, recursive=TRUE) > > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > # - "Display All Tests in non-Interactive" ------------------------------------- > # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ > > # Issue 293: don't stop after first failing test > # We need `try` because we're testing what happens when the unitizer fails. > > temp.dir <- tempfile() > temp.file.a <- file.path(temp.dir, 'a.R') > temp.file.b <- file.path(temp.dir, 'b.R') > dir.create(temp.dir) > writeLines(c("1 + 1", "warning('hello')"), temp.file.a) > writeLines(c("2 + 1", "warning('goodbye')"), temp.file.b) > try(unitize_dir(temp.dir, transcript=FALSE)) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | Summary of files in common directory '.': | | Pass Fail New | *1. a.R - - 2 | *2. b.R - - 2 | ....................... | - - 4 | Legend: | * `unitizer` requires review +------------------------------------------------------------------------------+ | unitizer for: a.R | +------------------------------------------------------------------------------+ Pass Fail New - - 2 ........................... - - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > 1 + 1 [1] 2 > warning("hello") Warning: hello | User input required to proceed, but we are in non-interactive mode. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: b.R | +------------------------------------------------------------------------------+ Pass Fail New - - 2 ........................... - - 2 - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > 2 + 1 [1] 3 > warning("goodbye") Warning: goodbye | User input required to proceed, but we are in non-interactive mode. | unitizer unchanged. | * New: 1 + 1 | * New: warning("hello") | in 'a.R' | * New: 2 + 1 | * New: warning("goodbye") | in 'b.R' | Newly evaluated tests do not match unitizer (New: 4); see above for more info, | or run in interactive mode. Error in unitize_core(test.files = test.files, store.ids = store.ids, : Cannot proceed in non-interactive mode. > options(old.opt) > unlink(temp.dir, recursive=TRUE) > > unitizer/tests/t-utz1.Rout.save0000644000176200001440000027501414766101222016253 0ustar liggesusers R Under development (unstable) (2023-03-16 r83985) -- "Unsuffered Consequences" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: aarch64-apple-darwin20 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # - "No Attach Test" ----------------------------------------------------------- > > f <- paste0(tempfile(), ".R") > writeLines("1 + 1", f) > try(unitizer::unitize(f)) Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : `unitizer` package must be attached to the search path, e.g. with `library(unitizer)` > unlink(f) > > # - "Usual Setup" -------------------------------------------------------------- > > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") > source(file.path("_helper", "pkgs.R")) Install Packages Setup Demos > > # - "custom history file" ------------------------------------------------------ > > # Random history file > unitizer:::read_line_set_vals(c("1 + 1", "Y", "Y", "Y", "Y", "N")) > hist.file <- tempfile() > invisible( + unitizer:::capture_output( + unitize(FLM.TEST.FILE, interactive.mode = TRUE, history = hist.file) + ) ) > hist.dat <- readLines(hist.file) > unlink(hist.file) > > # History only works in interactive mode > if (interactive()) { + identical(hist.dat, c("## (original history will be restored on exit)", + "library(utzflm, lib.loc = getOption(\"unitizer.tmp.lib.loc\"))", + "dat <- data.frame(x = 1:100, y = (1:100)^2)", "res <- fastlm(dat$x, dat$y)", + "res", "1 + 1", "get_slope(res)", "get_rsq(res)", "fastlm(1:100, 1:10)")) + } else { + identical(hist.dat, character()) + } [1] TRUE > # - "bad history" -------------------------------------------------------------- > > bad.hist <- try(unitize(FLM.TEST.FILE, history = list()), silent = TRUE) > inherits(bad.hist, "try-error") [1] TRUE > conditionMessage(attr(bad.hist, "condition")) [1] "Argument `history` must be the name of a file that can be opened in \"at\" mode, or \"\", or NULL" > > # - "bad seed" ----------------------------------------------------------------- > > # gsub needed b/c of inconsistent error calls in 3.3.2 and 3.4 > old.opt <- options(unitizer.seed = "bad.seed") > txtopt1 <- unitizer:::capture_output(try(unitize(FLM.TEST.FILE))) > options(unitizer.seed = list("bad.seed")) > txtopt2 <- unitizer:::capture_output(try(unitize(FLM.TEST.FILE))) > # set.seed gained an argument c.a. R3.6 that caused error mismatch > txtopt2$message[grepl("\\(function \\(seed", txtopt2$message, + ignore.case = TRUE)] <- "" > options(old.opt) > > > unitizer:::clean_eval_exp(txtopt1) - Output ----------------------------------------------------------------------- - Message ---------------------------------------------------------------------- Error in do.call(set.seed, seed.dat) : second argument must be a list Error in as.state(state, test.files) : Internal Error: failed processing raw state object, contact maintainer. (Unable to set random seed; make sure `getOption('unitizer.seed')` is a list of possible arguments to `set.seed`, or set `seed` slot to be less than 2L.) Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : Argument `state` could not be evaluated. > # supplied seed not valid int > # unexpectedly exited; not clear why all stderr is not being captured by > # capture_output... > txtopt2 - Output ----------------------------------------------------------------------- - Message ---------------------------------------------------------------------- NAs introduced by coercion supplied seed is not a valid integer Error in as.state(state, test.files) : Internal Error: failed processing raw state object, contact maintainer. (Unable to set random seed; make sure `getOption('unitizer.seed')` is a list of possible arguments to `set.seed`, or set `seed` slot to be less than 2L.) Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : Argument `state` could not be evaluated. > > # - "create dir" --------------------------------------------------------------- > > # Unitizers in different directories that don't exist; also test using a > # function to generate those directories > get_store_id <- function(x) { + file <- basename(x) + dir <- dirname(dirname(x)) + file.path(dir, "unitizer2", sub("(.*)\\.R", "\\1.unitizer", + file)) + } > unitizer:::read_line_set_vals(c("N")) > txt1 <- unitizer:::capture_output( + untz1 <- try(unitize_dir(FLM.TEST.DIR, get_store_id, interactive.mode = TRUE)) + ) > unitizer:::read_line_set_vals(c("Y", "Q")) > txt2 <- unitizer:::capture_output(untz2 <- unitize_dir(FLM.TEST.DIR, + get_store_id, interactive.mode = TRUE)) > > inherits(untz1, "try-error") [1] TRUE > inherits(untz2, "unitizer_results") [1] TRUE > > # Some of the text must be ablated > rem_txt <- function(x) { + crd <- grep("Create directory\\?", x) + if (!length(crd)) + stop("Logic Error: this must be a create directory test") + x[-(2L:(crd[[1L]] - 1L))] + } > txt1$output <- rem_txt(txt1$output) > txt2$output <- rem_txt(txt2$output) > > # must create the following directory > # cannot proceed w/o creating directories > > txt1 - Output ----------------------------------------------------------------------- | Create directory? unitizer> N - Message ---------------------------------------------------------------------- Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Error in unitize_core(test.files = test.files, store.ids = store.ids, : Cannot proceed without creating directories. > txt2 - Output ----------------------------------------------------------------------- | Create directory? unitizer> Y | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R - - 4 | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | - - 8 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q - Message ---------------------------------------------------------------------- > > # - print / dir ---------------------------------------------------------------- > > # quit from all at once > unitizer:::read_line_set_vals(c("A", "QQ", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R - - 4 | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | - - 8 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail New - - 4 ........................... - - 4 - New -------------------------------------------------------------------------- | The 4 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # The `unitizer>` prompt is like the standard R prompt. You may # enter expressions such as `lm(y ~ x, dat)$coefficients`, or # `str(res)`. # # Once you are done reviewing, you need to tell `unitizer` you # accept the test by typing 'Y' at the prompt. Enter 'H' for help. > res intercept slope rsq -1717.000 101.000 0.939 attr(,"class") [1] "fastlm" unitizer> QQ | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R - - 4 | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | - - 8 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > > # Now test `unitize_dir`; we are testing all different combination of whether > # a unitizer is accepted and updated > # Review all > # Accept all > # Quit > # Quit > # Re-evalute > # Review remaining > # Accept all > # Quit from review > # Quit completely > > unitizer:::read_line_set_vals(c("A", "Y", "Y", "Y", "Y", "Y", + "Q", "Q", "R", "A", "Y", "Y", "Q", "Q")) > untz3a <- unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail New | *1. fastlm1.R - - 4 | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | - - 8 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail New - - 4 ........................... - - 4 - New -------------------------------------------------------------------------- | The 4 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # The `unitizer>` prompt is like the standard R prompt. You may # enter expressions such as `lm(y ~ x, dat)$coefficients`, or # `str(res)`. # # Once you are done reviewing, you need to tell `unitizer` you # accept the test by typing 'Y' at the prompt. Enter 'H' for help. > res intercept slope rsq -1717.000 101.000 0.939 attr(,"class") [1] "fastlm" unitizer> Y # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> Y > get_rsq(res) [1] 0.939 unitizer> Y # This last test is expected to cause an error; press 'Y' to # accept it so future checks can confirm the same error persists > fastlm(1:100, 1:10) Error in fastlm(1:100, 1:10) : Arguments `x` and `y` must be the same length. unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Adding 4 out of 4 new tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm2.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # For internal tests only; not for demo > x <- 1:10 > y <- 1:10^3 > res <- summary(lm(y ~ x, data.frame(x = x, y = y))) > intercept <- res$coefficients[1, 1] > slope <- res$coefficients[2, 1] > rsq <- res$r.squared > structure(c(intercept = intercept, slope = slope, rsq = rsq), + class = "fastlm") intercept slope rsq 4.95e+02 1.00e+00 9.90e-05 attr(,"class") [1] "fastlm" unitizer> Q | No changes recorded. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New - - 3 ........................... - - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 105 unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail New | $1. fastlm1.R ? ? ? | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | ? ? ? | Legend: | * `unitizer` requires review | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> R | Summary of files in common directory 'unitizer': | | Pass Fail New | 1. fastlm1.R 4 - - | *2. fastlm2.R - - 1 | *3. unitizer.fastlm.R - - 3 | ..................................... | 4 - 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm2.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # For internal tests only; not for demo > x <- 1:10 > y <- 1:10^3 > res <- summary(lm(y ~ x, data.frame(x = x, y = y))) > intercept <- res$coefficients[1, 1] > slope <- res$coefficients[2, 1] > rsq <- res$r.squared > structure(c(intercept = intercept, slope = slope, rsq = rsq), + class = "fastlm") intercept slope rsq 4.95e+02 1.00e+00 9.90e-05 attr(,"class") [1] "fastlm" unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm2.unitizer' by: | - Adding 1 out of 1 new tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New - - 3 ........................... - - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 105 unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail New | 1. fastlm1.R 4 - - | $2. fastlm2.R ? ? ? | *3. unitizer.fastlm.R - - 3 | ..................................... | ? ? ? | Legend: | * `unitizer` requires review | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> Q > untz3a.get.all <- vapply(get_unitizer(untz3a), class, character(1L)) > identical(untz3a.get.all, c("unitizer", "unitizer", "logical")) [1] TRUE > print(untz3a) Summary of tests (accept/total): id test.file New Passed Totals 1 fastlm1.R 0/0 4/4 4/4 $ 2 fastlm2.R 1/1 0/0 1/1 3 unitizer.fastlm.R 0/3 0/0 0/3 * ----------------------------------------------------- 0 Totals 1/4 4/4 5/8 * unitizer was not saved $ unitizer was saved in prior evaluation Test files in common directory 'tests/unitizer' > untz3a.first <- untz3a[[1L]] > print(untz3a.first) Test File: tests/unitizer/fastlm1.R Store ID: tests/unitizer/fastlm1.unitizer id call ignored status user reviewed 1 1 library(utzflm, lib.loc = g... * Passed Y FALSE 2 2 dat <- data.frame(x = 1:100... * Passed Y FALSE 3 3 res <- fastlm(dat$x, dat$y) * Passed Y FALSE 4 4 res Passed Y FALSE 5 5 get_slope(res) Passed Y FALSE 6 6 get_rsq(res) Passed Y FALSE 7 7 fastlm(1:100, 1:10) Passed Y FALSE You chose NOT to save these changes to the unitizer store > > identical(class(untz3a), "unitizer_results") [1] TRUE > identical( + lapply(untz3a, class), + replicate(3L, c("unitizer_result", "data.frame"), simplify = FALSE) + ) [1] TRUE > > untz3a.cpy <- untz3a > # need to drop temp file attributes for tests > for (i in seq_along(untz3a.cpy)) { + attr(untz3a.cpy[[i]], "test.file") <- basename(attr(untz3a.cpy[[i]], + "test.file")) + attr(untz3a.cpy[[i]], "store.id") <- basename(attr(untz3a.cpy[[i]], + "store.id")) + } > all.equal(untz3a.cpy, rds("unitize_res1")) [1] TRUE > > # dummy class for errors > untz3a.first.bad <- untz3a.first > setClass("uhtsdfoqiuerhzb", slots=c(a='integer')) > attr(untz3a.first.bad, "store.id") <- new("uhtsdfoqiuerhzb") > print(untz3a.first.bad) Test File: tests/unitizer/fastlm1.R Store ID: id call ignored status user reviewed 1 1 library(utzflm, lib.loc = g... * Passed Y FALSE 2 2 dat <- data.frame(x = 1:100... * Passed Y FALSE 3 3 res <- fastlm(dat$x, dat$y) * Passed Y FALSE 4 4 res Passed Y FALSE 5 5 get_slope(res) Passed Y FALSE 6 6 get_rsq(res) Passed Y FALSE 7 7 fastlm(1:100, 1:10) Passed Y FALSE You chose NOT to save these changes to the unitizer store > > # this is a bit contrived as it isn't possible to directly create an empty > # unitize dir result > untz3a.empty <- untz3a[0] > class(untz3a.empty) <- class(untz3a) > print(untz3a.empty) | No unitizers > > # Now accept the last remaining tests > # unlink(list.files(test.dir, pattern="\\.unitizer$", full.names=TRUE), > # recursive=TRUE) > # Invalid input > # Review third unitizer > # Accept all > # Re-eval and exit (again, not clear this is right thing to do) > unitizer:::read_line_set_vals(c("3000", "3", "Y", "Y", "Y", "Y", + "R")) > untz3b <- unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail New | 1. fastlm1.R 4 - - | 2. fastlm2.R 1 - - | *3. unitizer.fastlm.R - - 3 | ..................................... | 5 - 3 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 3000 | Type a number in `1:3` at the prompt [1] 3000 unitizer> 3 +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New - - 3 ........................... - - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 105 unitizer> Y > get_rsq(res) [1] 0.862 unitizer> Y > get_intercept(res) [1] -277 unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/unitizer.fastlm.unitizer' by: | - Adding 3 out of 3 new tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Y | unitizer updated. | Summary of files in common directory 'unitizer': | | Pass Fail | 1. fastlm1.R 4 - | 2. fastlm2.R 1 - | $3. unitizer.fastlm.R ? ? | ................................ | ? ? | Legend: | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> R | Summary of files in common directory 'unitizer': | | Pass Fail | 1. fastlm1.R 4 - | 2. fastlm2.R 1 - | 3. unitizer.fastlm.R 3 - | ................................ | 8 - | 8/8 tests passed; nothing to review. > print(untz3b) Summary of tests (accept/total): id test.file Passed 1 fastlm1.R 4/4 * 2 fastlm2.R 1/1 * 3 unitizer.fastlm.R 3/3 $ --------------------------------- 0 Totals 8/8 * unitizer was not saved $ unitizer was saved in prior evaluation Test files in common directory 'tests/unitizer' > identical( + vapply(get_unitizer(untz3b), class, character(1L)), rep("unitizer", 3L) + ) [1] TRUE > # - "namespace conflict" ------------------------------------------------------- > > # Namespace conflicts; unfortunately if either `covr` or `data.table` are > # loaded this may not work quite right. Also as of `covr` 2.2.2 it seems that > # the R session `covr` launches now seems to load the covr namespace. The > # logic here ensures covr namespace is always loaded for this tests, if > # possible. So we omit the line were what namespaces could not be unloaded are > # mentioned. > > unitizer:::read_line_set_vals("Y") > ns.conf1 <- unitizer:::capture_output( + unitize_dir(FLM.TEST.DIR, state = "pristine", interactive.mode = TRUE) + ) > ns.conf1$message <- ns.conf1$message[-3] > ns.conf1 - Output ----------------------------------------------------------------------- | Summary of files in common directory 'unitizer': | | Pass Fail | 1. fastlm1.R 4 - | 2. fastlm2.R 1 - | 3. unitizer.fastlm.R 3 - | ................................ | 8 - | Do you wish to proceed despite compromised state tracking | ([Y]es, [N]o)? unitizer> Y - Message ---------------------------------------------------------------------- | `unitizer` was unable to run with `options` state tracking enabled starting | with the first test file because the following namespaces could not be | You may proceed normally but be aware that option state was not managed | starting with the file in question, and option state will not be managed | during review, or restored to original values after `unitizer` completes | evaluation. You may quit `unitizer` now to avoid any changes. See `?unitiz- | erState` for more details. | 8/8 tests passed; nothing to review. > > unitizer:::read_line_set_vals("N") > ns.conf2 <- unitizer:::capture_output( + unitize_dir(FLM.TEST.DIR, state = "pristine", interactive.mode = TRUE) + ) > ns.conf2$message <- ns.conf2$message[-3] > ns.conf2 - Output ----------------------------------------------------------------------- | Summary of files in common directory 'unitizer': | | Pass Fail | 1. fastlm1.R 4 - | 2. fastlm2.R 1 - | 3. unitizer.fastlm.R 3 - | ................................ | 8 - | Do you wish to proceed despite compromised state tracking | ([Y]es, [N]o)? unitizer> N - Message ---------------------------------------------------------------------- | `unitizer` was unable to run with `options` state tracking enabled starting | with the first test file because the following namespaces could not be | You may proceed normally but be aware that option state was not managed | starting with the file in question, and option state will not be managed | during review, or restored to original values after `unitizer` completes | evaluation. You may quit `unitizer` now to avoid any changes. See `?unitiz- | erState` for more details. > > # Non-interactive; also testing what happens when we run a test with errors > # inside a try block > > try(unitize_dir(FLM.TEST.DIR, state = "pristine", interactive.mode = FALSE)) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. | Unexpectedly exited evaluation attempt when executing test expression: | > fastlm(1:100, 1:10) | Make sure you are not calling `unitize` inside a `tryCatch`/`try` block, | invoking a restart defined outside `unitize`, evaluating an expression that | calls `quit()`/`q()`, or quitting from a `browser()`/`debug()`/`trace()`. If | none of these apply yet you are seeing this message please contact package | maintainer. Error in fastlm(1:100, 1:10) : Arguments `x` and `y` must be the same length. > ns.conf3 <- unitizer:::capture_output( + try( + unitize( + file.path(FLM.TEST.DIR, "fastlm2.R"), state = "pristine", + interactive.mode = FALSE + ) ) ) > ns.conf3$message <- ns.conf3$message[-grep('unloaded', ns.conf3$message)] > ns.conf3 - Output ----------------------------------------------------------------------- - Message ---------------------------------------------------------------------- Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | `unitizer` was unable to run with `options` state tracking enabled starting | with the first test file because the following namespaces could not be Error in unitize_browse(unitizers = unitizers[valid], mode = mode, interactive.mode = interactive.mode, : Unable to proceed in non-interactive mode; set options state tracking to a value less than or equal to search path state tracking or see vignette for other workarounds. > > # - "Removing Tests" ----------------------------------------------------------- > > # Removing tests; del2 has the same tests as del1, but with some removed > extra.dir <- file.path(FLM.TEST.DIR, "..", "extra") > unitize(file.path(extra.dir, "del1.R"), auto.accept = "new", interactive.mode = FALSE) Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. +------------------------------------------------------------------------------+ | unitizer for: extra/del1.R | +------------------------------------------------------------------------------+ Pass Fail New basic tests - - 3 more tests - - 3 ............................ - - 6 | Auto-accepting changes... | unitizer updated. > unitizer:::read_line_set_vals(c("Y", "YY", "Y", "Y")) > unitize( + file.path(extra.dir, "del2.R"), + store.id = file.path(extra.dir, "del1.unitizer"), + interactive.mode = TRUE + ) +------------------------------------------------------------------------------+ | unitizer for: extra/del2.R | +------------------------------------------------------------------------------+ Pass Fail Del basic tests 2 - 1 - - 3 ............................ 2 - 4 = basic tests ================================================================== - Removed ---------------------------------------------------------------------- | The following test exists in the unitizer store but not in the new test | script. Remove test from store ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, | [Q]uit, [H]elp)? > "hello" [1] "hello" unitizer> Y = Other Removed Items ========================================================== - Removed ---------------------------------------------------------------------- | The 3 tests in this section exist in the unitizer store but not in the new | test script. Remove tests from store ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, | [Q]uit, [H]elp)? > 3 [1] 3 unitizer> YY 1. 3 . . . . Removed:- 2. 645 . . . . Removed:- 3. 9/0 . . . . Removed:- Choose 'Y' for the 3 tests shown above ([Y]es, [N]o)? unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'extra/del1.unitizer' by: | - Removing 4 out of 4 removed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Y | unitizer updated. > # - "navigate" ----------------------------------------------------------------- > > # Update `fastlm` to cause unitizers to fail, and go through the errors > update_fastlm(FLM, version = "0.1.1") > inst_pak(FLM) > # Try navigating through the unitizer > unitizer:::read_line_set_vals(c("P", "B", "3", "N", "U", "N", + "N", "B", "U", "Q")) > untz7a <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> P | At first reviewable item; nothing to step back to > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> B *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . . Failed:- 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:- 6. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> 3 | You selected a test that is not normally reviewed in this mode; | as such, upon test completion, you will be brought back to this menu | instead of being taken to the next reviewable test. - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > res <- fastlm(dat$x, dat$y) unitizer> N *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:N 4. res . . . . . . . . . . . . . . . . . . . . Failed:- 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:- 6. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> U - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> N # This one is also incorrect; reject with 'N' > get_slope(res) [1] 7.01e+11 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 101 > [1] 7.01e+11 | State mismatch; see `.DIFF$state` for details. unitizer> N = Finalize Unitizer ============================================================ | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Exit unitizer ([Y]es, [P]rev, [B]rowse, [R]erun, f[O]rce)? unitizer> B *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:N 4. res . . . . . . . . . . . . . . . . . . . . Failed:N 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:N 6. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> U | No unreviewed tests. = Finalize Unitizer ============================================================ | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Exit unitizer ([Y]es, [P]rev, [B]rowse, [R]erun, f[O]rce)? unitizer> Q | Changes discarded. | unitizer unchanged. > attr(untz7a, "test.file") <- basename(attr(untz7a, "test.file")) > attr(untz7a, "store.id") <- basename(attr(untz7a, "store.id")) > path <- attr(untz7a, "test.file") > path [1] "fastlm1.R" > (path.norm <- unitizer:::normalize_path(path, mustWork=FALSE, exists=TRUE)) [1] "fastlm1.R" > (rel.path <- unitizer:::relativize_path(path.norm, wd=NULL, only.if.shorter=TRUE, exists=TRUE)) [1] "fastlm1.R" > (pkg.dir <- unitizer:::get_package_dir(path.norm, exists=TRUE)) [1] "." > untz7a Test File: fastlm1.R Store ID: fastlm1.unitizer id call ignored status user reviewed 1 1 library(utzflm, lib.loc = g... * Failed N FALSE 2 2 dat <- data.frame(x = 1:100... * Failed N FALSE 3 3 res <- fastlm(dat$x, dat$y) * Failed N TRUE 4 4 res Failed N TRUE 5 5 get_slope(res) Failed N TRUE 6 6 get_rsq(res) Passed Y FALSE 7 7 fastlm(1:100, 1:10) Passed Y FALSE You chose NOT to save these changes to the unitizer store > > # - "review dir" --------------------------------------------------------------- > > # list help, review first item, but do nothing > unitizer:::read_line_set_vals(c("H", "1", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> H | Available options: | - 1:3: unitizer number to review | - A: Review all `unitzers` that require review (*) | - AA: Review all tests | - RR: Re-run all tests | - Q: quit | | Pick a unitizer or an option ([A]ll, [Q]uit, [H]elp)? unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # incorrect selection > unitizer:::read_line_set_vals(c("H", "4", "1", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> H | Available options: | - 1:3: unitizer number to review | - A: Review all `unitzers` that require review (*) | - AA: Review all tests | - RR: Re-run all tests | - Q: quit | | Pick a unitizer or an option ([A]ll, [Q]uit, [H]elp)? unitizer> 4 | Type a number in `1:3` at the prompt [1] 4 unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # simulate slow unitizer review > old.opt <- options(unitizer.prompt.b4.quit.time = 0) > unitizer:::read_line_set_vals(c("H", "1", "Q", "Q", "Q", "Y")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> H | Available options: | - 1:3: unitizer number to review | - A: Review all `unitzers` that require review (*) | - AA: Review all tests | - RR: Re-run all tests | - Q: quit | | Pick a unitizer or an option ([A]ll, [Q]uit, [H]elp)? unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q = Finalize Unitizer ============================================================ | You have 2 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Exit unitizer ([Y]es, [P]rev, [B]rowse, [U]nreviewed, [R]erun, f[O]rce)? unitizer> Q | Changes discarded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q | Are you sure you want to quit? unitizer> Y > options(old.opt) > # Failures in non-interactive mode (note, can't run on the actual "fastlm.R" > # file b/c we need to do this under a `try`): > try( + unitize_dir(FLM.TEST.DIR, pattern = "unitize|fastlm2", interactive.mode = FALSE) + ) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | Summary of files in common directory 'unitizer': | | Pass Fail | 1. fastlm2.R 1 - | *2. unitizer.fastlm.R 1 2 | ................................ | 2 2 | Legend: | * `unitizer` requires review +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail 1 2 ...................... 1 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 717379 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 105 > [1] 717379 | State mismatch; see `.DIFF$state` for details. > get_intercept(res) [1] -3945281 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] -277 > [1] -3945281 | State mismatch; see `.DIFF$state` for details. | User input required to proceed, but we are in non-interactive mode. | unitizer unchanged. | * Fail: get_slope(res) | * Fail: get_intercept(res) | in 'unitizer/unitizer.fastlm.R' | Newly evaluated tests do not match unitizer (Pass: 2, Fail: 2); see above for | more info, or run in interactive mode. Error in unitize_core(test.files = test.files, store.ids = store.ids, : Cannot proceed in non-interactive mode. > # review all that need review, but don't do anything > unitizer:::read_line_set_vals(c("A", "Q", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail 1 2 ...................... 1 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 717379 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 105 > [1] 717379 | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # review all, but don't do anything > unitizer:::read_line_set_vals(c("AA", "Q", "Q", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> AA +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm2.R | +------------------------------------------------------------------------------+ Pass Fail 1 - ...................... 1 - *1. x <- 1:10 . . . . . . . . . . . . . . . . . . . -:- *2. y <- 1:10^3 . . . . . . . . . . . . . . . . . . -:- *3. res <- summary(lm(y ~ x, data.frame(x = x, y = y))) . . . . . -:- *4. intercept <- res$coefficients[1, 1] . . . . . . . . . . -:- *5. slope <- res$coefficients[2, 1] . . . . . . . . . . . -:- *6. rsq <- res$r.squared . . . . . . . . . . . . . . . -:- 7. structure(c(intercept = intercept, slope = slope, rsq = rsq),... Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> Q | No changes recorded. | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail 1 2 ...................... 1 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 717379 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 105 > [1] 717379 | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # review one, and Re-eval despite no change > unitizer:::read_line_set_vals(c("1", "R", "Y", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 2 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Re-run unitizer ([Y]es, [P]rev, [B]rowse, [U]nreviewed, [R]erun, f[O]rce)? unitizer> Y | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? | Jumping to test #4 because that was the test under review when test re-run was | requested. > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > unitizer:::read_line_set_vals(c("1", "RR", "Y", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> RR | Toggling re-run mode ON for all loaded unitizers = Finalize Unitizer ============================================================ | You have 2 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Re-run all loaded unitizers ([Y]es, [P]rev, [B]rowse, [U]nreviewed, [R]erun, | f[O]rce)? unitizer> Y | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # Test force eval > # first run, force update and accept > # second run, R from dir summary doesn't set bookmarks > unitizer:::read_line_set_vals(c("1", "O", "Q", "Y", "R", "1", + "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> O | Toggling force update mode ON unitizer> Q = Finalize Unitizer ============================================================ | You have 2 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | Running in `force.update` mode so `unitizer` will be re-saved even though | there are no changes to record (see `?unitize` for details). | You are about to update 'unitizer/fastlm1.unitizer' with re-evaluated but | otherwise unchanged tests. | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [U]nreviewed, [R]erun, | f[O]rce)? unitizer> Y | unitizer updated. | Summary of files in common directory 'unitizer': | | Pass Fail | $1. fastlm1.R ? ? | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | ? ? | Legend: | * `unitizer` requires review | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> R | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # Variations on YY, YYY, and YYY > unitizer:::read_line_set_vals(c("1", "YY", "Y", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> YY 4. res . . . . . Failed:- 5. get_slope(res) . Failed:- Choose 'Y' for the 2 tests shown above ([Y]es, [N]o)? unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Q | Changes discarded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > unitizer:::read_line_set_vals(c("1", "YYY", "Y", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> YYY 4. res . . . . . Failed:- 5. get_slope(res) . Failed:- Choose 'Y' for the 2 tests shown above ([Y]es, [N]o)? unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Q | Changes discarded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > unitizer:::read_line_set_vals(c("1", "YYYY", "Y", "Q", "Q")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 1 +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> YYYY 4. res . . . . . Failed:- 5. get_slope(res) . Failed:- Choose 'Y' for the 2 tests shown above ([Y]es, [N]o)? unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Q | Changes discarded. | unitizer unchanged. | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q > # review all, accepting all changes, and reevaluting everything; note that this > # means we're accepting tests that are not correct > unitizer:::read_line_set_vals(c("A", "Y", "Y", "Y", "Y", "Y", "Y", "RR")) > unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | *3. unitizer.fastlm.R 1 2 | ................................ | 4 4 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> A +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Y # This one is also incorrect; reject with 'N' > get_slope(res) [1] 7.01e+11 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 101 > [1] 7.01e+11 | State mismatch; see `.DIFF$state` for details. unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail 1 2 ...................... 1 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [QQ]uit All, [Q]uit, [H]elp)? # Extra test file for internal tests; not for DEMO > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 717379 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 105 > [1] 717379 | State mismatch; see `.DIFF$state` for details. unitizer> Y > get_intercept(res) [1] -3945281 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] -277 > [1] -3945281 | State mismatch; see `.DIFF$state` for details. unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/unitizer.fastlm.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [QQ]uit All)? unitizer> Y | unitizer updated. | Summary of files in common directory 'unitizer': | | Pass Fail | $1. fastlm1.R ? ? | 2. fastlm2.R 1 - | $3. unitizer.fastlm.R ? ? | ................................ | ? ? | Legend: | $ `unitizer` has been modified and needs to be re-run to recompute summary | Type number of unitizer to review, 'A' to review all that require review, 'R' | to re-run all updated unitizer> RR | Summary of files in common directory 'unitizer': | | Pass Fail | 1. fastlm1.R 4 - | 2. fastlm2.R 1 - | 3. unitizer.fastlm.R 3 - | ................................ | 8 - | 8/8 tests passed; nothing to review. > > # - "multi-sect" --------------------------------------------------------------- > > # Upgrade again, and try with deleted tests and other things > update_fastlm(FLM, version = "0.1.2") > inst_pak(FLM) > unitizer:::read_line_set_vals(c("3", "ref(res)", "Y", "Y", "B", + "1", "B", "U", "Y", "RR", "Y", "Q")) > txt20 <- unitizer:::capture_output(unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE)) > txt20$output <- gsub("^<\\w+: .*?>", "", txt20$output) > txt20 - Output ----------------------------------------------------------------------- | Summary of files in common directory 'unitizer': | | Pass Fail New Del | *1. fastlm1.R 2 2 - - | 2. fastlm2.R 1 - - - | *3. unitizer.fastlm.R 1 1 1 1 | .......................................... | 4 3 1 1 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> 3 +------------------------------------------------------------------------------+ | unitizer for: unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New Del - - - 1 Basic Tests - 1 - - Advanced Tests 1 - 1 - .................................... 1 1 1 1 = =================================================================== - Removed ---------------------------------------------------------------------- | The following test exists in the unitizer store but not in the new test | script. Remove test from store ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, | [Q]uit, [H]elp)? > get_intercept(res) [1] -3945281 unitizer> ref(res) unitizer> Y = Basic Tests ================================================================== - Failed ----------------------------------------------------------------------- | The following test failed because the new evaluation does not match the | reference value from the store. Overwrite with new result ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > x <- 1:10 > y <- x^3 > res <- fastlm(x, y) > get_slope(res) [1] 105 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 717379 > [1] 105 | State mismatch; see `.DIFF$state` for details. unitizer> Y = Advanced Tests =============================================================== - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? > 2 * get_slope(res) + get_intercept(res) [1] -66.4 unitizer> B = =================================================================== 8. get_intercept(res) . . . . . . . . . . . . . . . Removed:Y = Basic Tests ================================================================== *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. x <- 1:10 . . . . . . . . . . . . . . . . . . -:- *3. y <- x^3 . . . . . . . . . . . . . . . . . . -:- *4. res <- fastlm(x, y) . . . . . . . . . . . . . . -:- 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:Y = Advanced Tests =============================================================== 6. 2 * get_slope(res) + get_intercept(res) . . . . . . . . New:- 7. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> 1 = Basic Tests ================================================================== - Failed ----------------------------------------------------------------------- | The following test failed because the new evaluation does not match the | reference value from the store. Overwrite with new result ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) unitizer> B = =================================================================== 8. get_intercept(res) . . . . . . . . . . . . . . . Removed:Y = Basic Tests ================================================================== *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. x <- 1:10 . . . . . . . . . . . . . . . . . . -:- *3. y <- x^3 . . . . . . . . . . . . . . . . . . -:- *4. res <- fastlm(x, y) . . . . . . . . . . . . . . -:- 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:Y = Advanced Tests =============================================================== 6. 2 * get_slope(res) + get_intercept(res) . . . . . . . . New:- 7. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> U = Advanced Tests =============================================================== - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? > 2 * get_slope(res) + get_intercept(res) [1] -66.4 unitizer> Y = Finalize Unitizer ============================================================ | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> RR | Update unitizer and re-run all loaded unitizers ([Y]es, [N]o, [P]rev, [B] | rowse, [R]erun)? unitizer> Y | Summary of files in common directory 'unitizer': | | Pass Fail | *1. fastlm1.R 2 2 | 2. fastlm2.R 1 - | 3. unitizer.fastlm.R 3 - | ................................ | 6 2 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q - Message ---------------------------------------------------------------------- `ref` is only active when there is an active secondary environment | You selected a test that is not normally reviewed in this mode; | as such, upon test completion, you will be brought back to this menu | instead of being taken to the next reviewable test. | You will IRREVERSIBLY modify 'unitizer/unitizer.fastlm.unitizer' by: | - Replacing 1 out of 1 failed tests | - Adding 1 out of 1 new tests | - Removing 1 out of 1 removed tests | Toggling re-run mode ON for all loaded unitizers | You will IRREVERSIBLY modify 'unitizer/unitizer.fastlm.unitizer' by: | - Replacing 1 out of 1 failed tests | - Adding 1 out of 1 new tests | - Removing 1 out of 1 removed tests | unitizer updated. > > # - "Load Fail" ---------------------------------------------------------------- > > # Purposefully mess up one of the unitizers to see if the load fail stuff works > saveRDS(list(1, 2, 3), file.path(FLM.TEST.DIR, "fastlm1.unitizer", + "data.rds")) > try(unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE)) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. | | The following unitizer could not be loaded: | - unitizer/fastlm1.unitizer: `get_unitizer` error: Retrieved object is not a | unitizer store Error in load_unitizers(store.ids[active], test.files[active], par.frame = util.frame, : Cannot proceed with invalid or out of date unitizers. You must either fix or remove them. > unitizer:::read_line_set_vals(NULL) > > proc.time() user system elapsed 6.143 0.846 7.732 unitizer/tests/t-change.Rout.save0000644000176200001440000000342114766101222016564 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "Construction works" ------------------------------------------------------- > > # invalid slot > try(new("unitizerChanges", removed = 1:3)) Error in validObject(.Object) : invalid class "unitizerChanges" object: slot `@`removed must be of length 2 > # invalid/ got character > try(new("unitizerChanges", failed = letters[1:2])) Error in validObject(.Object) : invalid class "unitizerChanges" object: invalid object for slot "failed" in class "unitizerChanges": got class "character", should be or extend class "integer" > > # - "Output as expected" ------------------------------------------------------- > > my.changes <- new("unitizerChanges", failed = c(1L, 10L), new = c(1L, + 5L), removed = c(2L, 4L), corrupted = c(3L, 8L)) > show(my.changes) - Replacing 1 out of 10 failed tests - Adding 1 out of 5 new tests - Removing 2 out of 4 removed tests - Replacing 3 out of 8 tests with errors > > # - "Length Works" ------------------------------------------------------------- > > length(my.changes) # 7 [1] 7 > > proc.time() user system elapsed 0.775 0.120 0.991 unitizer/tests/t-rename.Rout.save0000644000176200001440000000434214766101222016611 0ustar liggesusers R version 4.0.5 Patched (2021-05-28 r80517) -- "Shake and Throw" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "Rename Works" ------------------------------------------------------------- > > x <- readRDS("_helper/unitizers/trivial.unitizer/data.rds") > x.edit <- editCalls(x, quote(x), quote(y), interactive.only = FALSE) Warning in .local(x, lang.old, lang.new, ...) : This is an experimental function; make sure you backup any unitizers before you edit them > x.edit@items.ref.calls.deparse [1] "TRUE" "y <- 1 + 1" "y + 2" "y <- y" "y * y" [6] "y/y + 2" > !identical(x@items.ref.calls.deparse, x.edit@items.ref.calls.deparse) [1] TRUE > identical( + x.edit@items.ref.calls.deparse, + gsub("\\bx\\b", "y", x@items.ref.calls.deparse) + ) [1] TRUE > > # warn > unitizer:::read_line_set_vals("Y") > x.edit2 <- editCalls(x, quote(x), quote(y), interactive.mode = TRUE) Warning in .local(x, lang.old, lang.new, ...) : This is an experimental function; make sure you backup any unitizers before you edit them | Do you wish to proceed ([Y]es/[N]o)? unitizer> Y > # message > unitizer:::read_line_set_vals("N") > x.edit3 <- editCalls(x, quote(x), quote(y), interactive.mode = TRUE) Warning in .local(x, lang.old, lang.new, ...) : This is an experimental function; make sure you backup any unitizers before you edit them | Do you wish to proceed ([Y]es/[N]o)? unitizer> N Exiting without edits > identical(x.edit3, x) [1] TRUE > > unitizer:::read_line_set_vals(NULL) > x.edit@items.ref.calls.deparse [1] "TRUE" "y <- 1 + 1" "y + 2" "y <- y" "y * y" [6] "y/y + 2" > > proc.time() user system elapsed 0.736 0.101 0.845 unitizer/tests/t-exec.R0000644000176200001440000001740614766101222014606 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("exec") suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) # - "Invisible Expression" ----------------------------------------------------- e <- new.env() exp <- quote(x <- 1:30) all.equal(1:30, unitizer:::eval_user_exp(exp, e, global = glob)$value) # `eval_user_exp` must be evaluated outside of test_that; also note that by # design this will output stuff to stderr and stdout out.err <- capture.output(type = "message", out.std <- capture.output({ test.obj.s3 <- structure("hello", class = "test_obj") setClass("testObj", list(a = "character")) test.obj.s4 <- new("testObj", a = "goodday") print.test_obj <- function(x, ...) stop("Error in Print") setMethod("show", "testObj", function(object) stop("Error in Show")) fun_signal <- function() signalCondition(simpleError("Error in Function", sys.call())) fun_error <- function() stop("Error in function 2") fun_error_cond <- function() stop(simpleError("Error in function 2", sys.call())) fun_error_cond_call <- function() fun_error_cond() fun_s3 <- function() test.obj.s3 fun_s4 <- function() test.obj.s4 fun_msg <- function() message("This is a Message") fun_warn <- function() warning("This is a warning", immediate. = TRUE) eval.env <- sys.frame(sys.nframe()) ex0 <- unitizer:::eval_user_exp(quote(stop()), eval.env, global = glob) unitizer:::set_trace(ex0$trace) trace0 <- unitizer:::unitizer_traceback() ex1 <- unitizer:::eval_user_exp(quote(fun_signal()), eval.env, global = glob) unitizer:::set_trace(ex1$trace) trace1 <- unitizer:::unitizer_traceback() ex2 <- unitizer:::eval_user_exp(quote(fun_error()), eval.env, global = glob) unitizer:::set_trace(ex2$trace) trace2 <- unitizer:::unitizer_traceback() ex2a <- unitizer:::eval_user_exp(expression(fun_error()), eval.env, global = glob) unitizer:::set_trace(ex2a$trace) trace2a <- unitizer:::unitizer_traceback() ex6 <- unitizer:::eval_user_exp(quote(fun_error_cond()), eval.env, global = glob) unitizer:::set_trace(ex6$trace) trace6 <- unitizer:::unitizer_traceback() ex7 <- unitizer:::eval_user_exp(quote(fun_error_cond_call()), eval.env, global = glob) unitizer:::set_trace(ex7$trace) trace7 <- unitizer:::unitizer_traceback() ex3 <- unitizer:::eval_user_exp(quote(fun_s3()), eval.env, global = glob) unitizer:::set_trace(ex3$trace) trace3 <- unitizer:::unitizer_traceback() ex3a <- unitizer:::eval_user_exp(expression(fun_s3()), eval.env, global = glob) unitizer:::set_trace(ex3a$trace) trace3a <- unitizer:::unitizer_traceback() ex4 <- unitizer:::eval_user_exp(quote(fun_s4()), eval.env, global = glob) ex4a <- unitizer:::eval_user_exp(expression(fun_s4()), eval.env, global = glob) unitizer:::set_trace(ex4a$trace) trace4a <- unitizer:::unitizer_traceback() ex5 <- unitizer:::eval_user_exp(quote(sum(1:20)), eval.env, global = glob) ex9 <- unitizer:::eval_user_exp(quote(fun_warn()), eval.env, global = glob) ex10 <- unitizer:::eval_user_exp(quote(fun_msg()), eval.env, global = glob) ex11 <- unitizer:::eval_user_exp(quote((function() quote(stop("shouldn't error")))()), eval.env, global = glob) })) # NOTE: deparsed test values generated with unitizer:::deparse_mixed # - "User Expression Evaluation" ----------------------------------------------- # a condition error, signaled, not stop (hence no aborted, etc.) identical(ex1, rds(100)) # a stop identical(ex2, rds(200)) # ex3 and ex3a are a total PITA because the calls need to be manually copied # b/c they don't deparse properly even with control="all", the trace and # call component loose the `structure` part in the quoted portions... # a stop in print; identical(ex3, rds(300)) identical(ex3a, rds(400)) # S4 objects; these originally caused problems since they don't deparse identical(ex4, rds(500)) identical(ex4a, rds(600)) # a normal expression identical(ex5, rds(700)) identical(ex9, rds(800)) all.equal(ex10, rds(900)) # not sure why identical doesn't work here # expect_false(ex11$aborted) ex11$aborted # FALSE # - "Trace Setting" ------------------------------------------------------------ identical(trace0, trace1) # expect_identical(trace2, list("stop(\"Error in function 2\")", # "fun_error()")) trace2 trace6 trace7 trace3a # needed to tweak this one so it would pass in R-devel 3.4.1 # expect_true(all(mapply(function(x, y) grepl(y, x), trace4a, list("stop\\(\"Error in Show\"\\)", # "show\\(.*\"testObj\".*\\)", "show\\(.*\"testObj\".*\\)")))) all( mapply( function(x, y) grepl(y, x), trace4a, list( "stop\\(\"Error in Show\"\\)", "show\\(.*\"testObj\".*\\)", "show\\(.*\"testObj\".*\\)") ) ) # - "Clean Top Level Message" -------------------------------------------------- old.width <- options(width = 80L) a <- unitizer:::eval_with_capture( expression(stop("short stop message")), global = glob ) b <- unitizer:::eval_with_capture( expression(stop("short stop .* with regex message")), global = glob ) c <- unitizer:::eval_with_capture( expression(stop("this is a long error message that is supposed to cause R to add a new line after the error: part")), global = glob ) d <- unitizer:::eval_with_capture( expression(warning("short warning message")), global = glob ) e <- unitizer:::eval_with_capture( expression(warning("short warning message .* with regex")), global = glob ) f <- unitizer:::eval_with_capture( expression( warning("this is a long error message that is supposed to cause R to add a new line after the error: part") ), global = glob ) g <- unitizer:::eval_with_capture( quote(stop("short stop message")), global = glob ) h <- unitizer:::eval_with_capture( quote(stop("short stop .* with regex message")), global = glob ) i <- unitizer:::eval_with_capture( quote(stop("this is a long error message that is supposed to cause R to add a new line after the error: part")), global = glob ) j <- unitizer:::eval_with_capture( quote(warning("short warning message")), global = glob ) k <- unitizer:::eval_with_capture( quote(warning("short warning message .* with regex")), global = glob ) l <- unitizer:::eval_with_capture( quote(warning("this is a long error message that is supposed to cause R to add a new line after the error: part")), global = glob ) m <- unitizer:::eval_with_capture(expression("a"/3), global = glob) exp.q <- quote({ fun <- function() warning("error in fun") message("boo hay \n there \n") warning("this is a fairly long warning wladsfasdfasd that might wrap if we keep typing humpty dumpty sat on a wall and had a big fall") warning("ashorter warning blah") message("boo hay \n there \n") warning() fun() suppressWarnings(warning("quiet warn")) message("boo hay \n there \n") error(3) }) x <- unitizer:::eval_with_capture(exp.q, global = glob) exp.exp <- expression({ fun <- function() warning("error in fun") message("boo hay \n there \n") warning("this is a fairly long warning wladsfasdfasd that might wrap if we keep typing humpty dumpty sat on a wall and had a big fall") warning("ashorter warning blah") message("boo hay \n there \n") warning() fun() suppressWarnings(warning("quiet warn")) message("boo hay \n there \n") error(3) }) y <- unitizer:::eval_with_capture(exp.exp, global = glob) options(old.width) a$message b$message c$message d$message e$message f$message g$message h$message i$message j$message k$message l$message m$message # `sub` needed due to inconsistencies in R 3.4 and 3.3 for top level error # messages writeLines(sub("\\bError.*: ", "", x$message)) writeLines(sub("\\bError.*: ", "", y$message)) unitizer/tests/t-shim.R0000644000176200001440000001452714766101222014623 0ustar liggesuserssource(file.path("aammrtf", "mock.R")) source(file.path("_helper", "init.R")) source(file.path("_helper", "pkgs.R")) old.state <- tracingState(TRUE) # - "trace_at_end" ------------------------------------------------------------- if (is(unitizer:::trace_test_fun, "functionWithTrace")) untrace("trace_test_fun", where = asNamespace("unitizer")) unitizer:::trace_at_end("trace_test_fun", quote(if (!inherits(.res, "try-error")) cat(sprintf("x: %d\n", .res$value))), print = FALSE, where = asNamespace("unitizer")) coi(unitizer:::trace_test_fun()) tracingState(FALSE) identical(capture.output(unitizer:::trace_test_fun()), character()) tracingState(TRUE) err <- try(unitizer:::trace_test_fun(stop("hello")), silent = TRUE) cond <- attr(err, "condition") conditionMessage(cond) conditionCall(cond) # return/missing etc. corner cases f <- function(x, y, z = 5) { if (missing(x)) { return(TRUE) } else if (z > 5) { stop("OMG, z > 5") } else if (identical(substitute(y), "hey")) { "substitute!" } else FALSE } unitizer:::trace_at_end("f", quote(cat("hello\n")), FALSE, environment()) res <- f() res res2 <- f(1) res2 # FALSE err <- try(f(1, z = 6), silent = TRUE) is(err, "try-error") attr(err, "condition") res3 <- f(1, y = "hey") res3 # - "Parent Env Stays on Top" -------------------------------------------------- try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) unitizer.dummy.list <- list(z = 23, x = 1, y = "hello") my.env <- new.env() state.set <- c(search.path = 2L) # make sure to unset this at end untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, enable.which = state.set, set.global = TRUE) untz.glob$shimFuns() sp <- search() curr2 <- sp[[2L]] identical(environmentName(parent.env(my.env)), curr2) library("unitizerdummypkg1", lib.loc = TMP.LIB) identical(environmentName(parent.env(my.env)), "package:unitizerdummypkg1") attach(unitizer.dummy.list) identical(environmentName(parent.env(my.env)), "unitizer.dummy.list") detach("unitizer.dummy.list") identical(environmentName(parent.env(my.env)), "package:unitizerdummypkg1") detach("package:unitizerdummypkg1", unload = TRUE) identical(environmentName(parent.env(my.env)), curr2) untz.glob$checkShims() # - "Parent env tracking with search path manip" ------------------------------- untz.glob$state() keep.more <- c(getOption("unitizer.search.path.keep.base")) unitizer:::search_path_trim(keep.more, global = untz.glob) untz.glob$state() identical(environmentName(parent.env(my.env)), search()[[2L]]) untz.glob$resetFull() identical(environmentName(parent.env(my.env)), curr2) # - "Disable Unshims, etc." ---------------------------------------------------- untz.glob$unshimFuns() !any(vapply(list(library, detach, attach), inherits, logical(1L), "functionWithTrace")) untz.glob$release() # - "Checks, errors, etc." ----------------------------------------------------- # make sure to unset this at end untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, enable.which = state.set, set.global = TRUE) tracingState(FALSE) untz.glob$shimFuns() # warning parent.env(my.env) tracingState(TRUE) untz.glob$release() untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, set.global = TRUE) trace("library", quote(cat("I am traced\n")), where = .BaseNamespaceEnv) lib.trace <- library untz.glob$shimFuns() # warning parent.env(my.env) inherits(attach, "functionWithTrace") # FALSE inherits(detach, "functionWithTrace") # FALSE inherits(library, "functionWithTrace") identical(lib.trace, library) untrace("library", where = .BaseNamespaceEnv) untz.glob$release() untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, set.global = TRUE) untz.glob$shimFuns() trace("attach", quote(cat("I am traced\n")), where = .BaseNamespaceEnv) attach.trace <- attach untz.glob$checkShims() # warning parent.env(my.env) inherits(detach, "functionWithTrace") # FALSE inherits(library, "functionWithTrace") # FALSE inherits(attach, "functionWithTrace") identical(attach.trace, attach) untrace("attach", where = .BaseNamespaceEnv) untz.glob$release() untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, set.global = TRUE) untz.glob$shimFuns() tracingState(FALSE) untz.glob$checkShims() # warning parent.env(my.env) tracingState(TRUE) inherits(detach, "functionWithTrace") # FALSE inherits(library, "functionWithTrace") # FALSE inherits(attach, "functionWithTrace") # FALSE # try tracing some stuff that shouldn't be untz.glob$shimFuns("baljevzxhjLsdc") # Warning # test unexpected message or behavior from `trace_at_end` try(untz.glob$shimFun("sum")) mock(unitizer:::trace_at_end, quote(stop("trace_at_end fail"))) any( grepl( "trace_at_end fail", capture.output( trace.fail <- untz.glob$shimFun("library"), type = "message" ), fixed = TRUE ) ) unmock(unitizer:::trace_at_end) trace.fail # FALSE mock(unitizer:::trace_at_end, quote(message("random message"))) untz.glob$shimFun("library") unmock(unitizer:::trace_at_end) mock(unitizer:::trace_at_end, quote(TRUE)) dont.trace <- untz.glob$shimFun("library") # Warning "not traced" unmock(unitizer:::trace_at_end) dont.trace # FALSE untz.glob$release() # untrace condition untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, set.global = TRUE) untz.glob$shimFuns() mock( unitizer:::untrace_utz, quote({ message("untrace dummy") base::untrace(what = what, signature = signature, where = where) }) ) untz.glob$unshimFuns() # message untrace dummy unmock(unitizer:::untrace_utz) untz.glob$release() try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) # - "find_returns" ------------------------------------------------------------- fun <- function() { if (TRUE) return(1) else { { 2 + 2 identity(c(1, 2, return(3), { list(1, 2, 5) return(return(4)) })) return(5) } return(6) } if (TRUE) return(7) else return(8) return(9) return(10) } ret.loc <- unitizer:::find_returns(fun) ret.loc # Validate visually that this worked all(vapply(unitizer:::get_returns(fun, ret.loc), function(x) x[[1L]] == quote(return), logical(1L))) unitizer/tests/t-capture.Rout.save0000644000176200001440000002307714766101222017013 0ustar liggesusers R Under development (unstable) (2022-02-01 r81609) -- "Unsuffered Consequences" Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("capture") > > # # Messing around trying to understand seek... > # f <- tempfile() > # con <- file(f, "w+b") > # writeChar(paste(letters, LETTERS, collapse=" "), con) > # readChar(con, 20) > # pos <- seek(con, origin="current") > # seek(con, pos, rw="write") > # writeChar("xxxxxxxxx", con) > # readChar(con, 3) > # pos <- seek(con, origin="current") > # seek(con, pos, rw="write") > # writeChar("yyyyy", con) > # close(con) > # readLines(f) > # unlink(f) > > # - "get_capture" -------------------------------------------------------------- > > old.max <- options(unitizer.max.capture.chars = 100L) > cons <- new("unitizerCaptCons") > base.char <- paste(rep(letters, 10), collapse = " ") > writeChar(base.char, cons@out.c) > > # Error "Argument `chrs.max`" > try(unitizer:::get_text_capture(cons, "output", TRUE, chrs.max = "howdy")) Error in unitizer:::get_text_capture(cons, "output", TRUE, chrs.max = "howdy") : Argument `chrs.max` must be integer(1L) and greater than 100L; using 200000L for nowTRUE > # Warn max capt > cpt0 <- unitizer:::get_text_capture(cons, "output", TRUE) Warning in get_text(slot(cons, if (type == "message") "err.c" else "out.c")) : Reached maximum text capture characters 100; see `getOption("unitizer.max.capture.chars")` > nchar(cpt0) [1] 100 > base.char.2 <- paste(rev(rep(letters, 10)), collapse = " ") > writeChar(base.char.2, cons@err.c) > sink(cons@err.c, type = "message") > > cpt0.err <- unitizer:::get_text_capture(cons, "message", FALSE) Warning in get_text(slot(cons, if (type == "message") "err.c" else "out.c")) : Reached maximum text capture characters 100; see `getOption("unitizer.max.capture.chars")` > sink(type = "message") > all.equal(cpt0.err, substr(base.char.2, 1, 100)) [1] TRUE > > ## for some reason this test stopped working; not sure why, need to look into > ## it; seemingly it messes up the pointer for the next read > # writeChar("xxxxxx", cons@out.c) > # cpt2 <- unitizer:::get_text_capture(cons, "output", TRUE) > # expect_equal("xxxxxx", cpt2) > writeChar(paste0(rep("yyyyyyy", 20L), collapse = ""), cons@out.c) > # warn max capt > cpt1 <- unitizer:::get_text_capture(cons, "output", TRUE) Warning in get_text(slot(cons, if (type == "message") "err.c" else "out.c")) : Reached maximum text capture characters 100; see `getOption("unitizer.max.capture.chars")` > all.equal(cpt1, paste0(rep("y", 100), collapse = "")) [1] TRUE > unitizer:::close_and_clear(cons) > options(old.max) > > # - "get_text" ----------------------------------------------------------------- > > old.max <- options(unitizer.max.capture.chars = 100L) > f <- tempfile() > con <- file(f, "w+b") > base.char <- paste(letters, collapse = " ") > sink(con, type = "message") > cat(base.char, file = stderr()) > # this needs to temporarily switch the sink to be able to issue the warning > # Warn: "Reached maximum" > unitizer:::get_text(con, 10) Warning in unitizer:::get_text(con, 10) : Reached maximum text capture characters 10; see `getOption("unitizer.max.capture.chars")` [1] "a b c d e " > # should still be to writing to our file, 10 chars in > cat("boogiewoogy", file = stderr()) > sink(type = "message") > suppressWarnings(readLines(f)) # incomplete final line... [1] "a b c d e boogiewoogy l m n o p q r s t u v w x y z" > > options(old.max) > unlink(f) > > # - "connection capture works" ------------------------------------------------- > > out.num <- as.integer(stdout()) > err.num <- as.integer(stderr()) > err.con <- getConnection(sink.number(type = "message")) > cons <- new("unitizerCaptCons") > cons <- unitizer:::set_capture(cons) > cat("hello there\n") > cat("goodbye there\n", file = stderr()) > capt <- unitizer:::get_capture(cons) > cons <- unitizer:::unsink_cons(cons) > capt $output [1] "hello there\n" $message [1] "goodbye there\n" > # expect_identical(as.integer(stdout()), out.num) > identical(as.integer(stdout()), out.num) [1] TRUE > identical(as.integer(stderr()), err.num) [1] TRUE > unitizer:::close_and_clear(cons) > > # Now, here we add an extra stdout sink. In both cases unsink_cons will not > # touch the sinks since we're not in an expected state, leaving > # close_and_clear to cleanup > err.con <- getConnection(sink.number(type = "message")) > cons <- new("unitizerCaptCons") > cons <- unitizer:::set_capture(cons) > cat("there hello\n") > # message does not work with testthat > cat("there goodbye\n", file = stderr()) > f1 <- tempfile() > f2 <- tempfile() > c2 <- file(f2, "w") > sink(f1) > sink(c2, type = "message") > cat("12 there hello\n") > # message does not work with testthat > cat("12 there goodbye\n", file = stderr()) > capt <- unitizer:::get_capture(cons) > cons <- unitizer:::unsink_cons(cons) > unitizer:::close_and_clear(cons) > attr(cons@out.c, "waive") [1] TRUE > attr(cons@err.c, "waive") [1] TRUE > capt $output [1] "there hello\n" $message [1] "there goodbye\n" > readLines(f1) [1] "12 there hello" > readLines(f2) [1] "12 there goodbye" > close(c2) > unlink(c(f1, f2)) > > # Same, but this time close the sinks properly, so the connections should not > # be waived > err.con <- getConnection(sink.number(type = "message")) > cons <- new("unitizerCaptCons") > cons <- unitizer:::set_capture(cons) > cat("there hello\n") > # message does not work with testthat > cat("there goodbye\n", file = stderr()) > f1 <- tempfile() > f2 <- tempfile() > c2 <- file(f2, "w") > sink(f1) > sink(c2, type = "message") > cat("12 there hello\n") > # message does not work with testthat > cat("12 there goodbye\n", file = stderr()) > sink() > sink(cons@err.c, type = "message") > capt <- unitizer:::get_capture(cons) > cons <- unitizer:::unsink_cons(cons) > attr(cons@out.c, "waive") # NULL NULL > attr(cons@err.c, "waive") # NULL NULL > capt $output [1] "there hello\n" $message [1] "there goodbye\n" > unitizer:::close_and_clear(cons) > readLines(f1) [1] "12 there hello" > readLines(f2) [1] "12 there goodbye" > close(c2) > unlink(c(f1, f2)) > # Try to mess up sink counter by replacing the real sink with a fake sink > # should lead to a waived connection > cons <- new("unitizerCaptCons") > cons <- unitizer:::set_capture(cons) > f1 <- tempfile() > sink() > sink(f1) > capt <- unitizer:::get_capture(cons) > cons <- unitizer:::unsink_cons(cons) > attr(cons@out.c, "waive") > attr(cons@err.c, "waive") > capt > # Try to fix so that we don't get a full stack release error > sink() > sink(cons@out.c) > unitizer:::close_and_clear(cons) > unlink(f1) > # helper function > f1 <- tempfile() > f2 <- tempfile() > c1 <- file(f1, "w+b") > c2 <- file(f2, "w+b") > sink(c2) > unitizer:::is_stdout_sink(f1) > sink() > sink(c1) > unitizer:::is_stdout_sink(f1) > sink() > close(c1) > close(c2) > unlink(c(f1, f2)) > > # - "connection breaking tests" ------------------------------------------------ > > # # These tests cannot be run as they blow away the entire sink stack which can > # # mess up any testing done under capture > # > # test_that("connection breaking tests", { > # # Test the more pernicious error where we substitute the stdout sink > # > # cons <- new("unitizerCaptCons") > # cons <- unitizer:::set_capture(cons) > # cat("woohoo\n") > # cat("yohooo\n", file=stderr()) > # f1 <- tempfile() > # sink() > # sink(f1) > # capt <- unitizer:::get_capture(cons) > # cons <- unitizer:::unsink_cons(cons) > # sink() > # unlink(f1) > # expect_true(attr(cons@out.c, "waive")) > # expect_null(attr(cons@err.c, "waive")) > # expect_identical( > # capt, list(output = "woohoo\n", message = "yohooo\n") > # ) > # expect_identical( > # unitizer:::close_and_clear(cons), > # structure(c(FALSE, TRUE), .Names = c("output", "message")) > # ) > # }) > > # - "close_and_clear" ---------------------------------------------------------- > > # need some careful handling to make sure we don't mess up the testthat's > # sinking (legacy behavior) > cons <- new("unitizerCaptCons") > err.con <- cons@stderr.con > on.exit(sink(err.con, type = "message")) > # intended to cause an error > cons@stderr.con <- list() > # msg: "Unable to restore original " > cons.txt <- capture.output(status <- unitizer:::close_and_clear(cons), + type = "message") | Unable to restore original message sink, setting back to normal stderr > any(grepl("connection", cons.txt)) [1] TRUE > sink(err.con, type = "message") > status["message"] message FALSE > > # - "eval with capt" ----------------------------------------------------------- > > suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) > all.equal( + (capt <- unitizer:::eval_with_capture(quote(1 + 1), global = glob))[1:8], + rds(100) + ) [1] TRUE > is(capt[[9]], "unitizerCaptCons") [1] TRUE > all.equal( + ( + capt <- unitizer:::eval_with_capture( + cat("wow\n", file = stderr()), global = glob) + )[1:8], + rds(200) + ) [1] TRUE > is(capt[[9]], "unitizerCaptCons") [1] TRUE > > proc.time() user system elapsed 0.533 0.071 0.599 unitizer/tests/t-list.Rout.save0000644000176200001440000001557114766101222016323 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > lst <- new("unitizerList") > > # - "unitizerList basic tests" ------------------------------------------------- > > length(lst) == 0L [1] TRUE > is(lst <- unitizer:::append(lst, 5), "unitizerList") [1] TRUE > length(lst) == 1L [1] TRUE > is( + lst <- unitizer:::append( + lst, list("booyah", list(1:3), matrix(1:9, nrow = 3)) + ), "unitizerList" + ) [1] TRUE > length(lst) == 4L [1] TRUE > is(lst[3L], "unitizerList") [1] TRUE > is(lst[[3L]], "list") [1] TRUE > lst <- unitizer:::append(lst, list(data.frame(a = letters[1:3])), 2L) > is(lst[[3L]], "data.frame") [1] TRUE > length(lst[1:4]) == 4L [1] TRUE > lst[[4L]] <- "boo" > is(lst[[4L]], "character") [1] TRUE > lst[4L:5L] <- letters[1:2] > > c(lst[[4L]], lst[[5L]]) [1] "a" "b" > lst[[4L]] [1] "a" > > is(unitizer:::as.list(lst), "list") [1] TRUE > length(unitizer:::as.list(lst)) == 5L [1] TRUE > is(unitizer:::as.expression(lst), "expression") [1] TRUE > > try(unitizer:::getItem(lst)) # error Error in .local(x, ...) : Internal pointer for `x` not initialized; initialize with `nextItem` > lst <- unitizer:::nextItem(lst) > unitizer:::getItem(lst) [1] 5 > lst <- unitizer:::nextItem(lst) > unitizer:::getItem(lst) [1] "booyah" > lst <- unitizer:::prevItem(lst) > unitizer:::getItem(lst) [1] 5 > lst <<- lst # leftover from testthat testing? > > # - "unitizerList pointer seeking" --------------------------------------------- > > for (i in 1:10) lst <- unitizer:::nextItem(lst) > try(unitizer:::getItem(lst)) Error in .local(x, ...) : Internal pointer for `x` is corrupted > unitizer:::done(lst) [1] TRUE > is(lst <- unitizer:::reset(lst, "back"), "unitizerList") [1] TRUE > try(unitizer:::reset(lst, letters)) Error in .local(x, ...) : Argument `position` must be `NULL`, or "front" or "back" > try(unitizer:::reset(lst, NA_character_)) Error in .local(x, ...) : Argument `position` must be `NULL`, or "front" or "back" > try(unitizer:::getItem(lst)) Error in .local(x, ...) : Internal pointer for `x` not initialized; initialize with `prevItem` > lst <- unitizer:::prevItem(lst) > unitizer:::getItem(lst) == "b" [1] TRUE > while (!unitizer:::done(lst)) { + item <- unitizer:::getItem(lst) + lst <- unitizer:::prevItem(lst) + } > item == 5L [1] TRUE > try(unitizer:::getItem(lst)) Error in .local(x, ...) : Internal pointer for `x` outside of range for `x`; test for this condition with `done`, or reset with `reset` > withCallingHandlers( + lst[[4]] <- "new value", + warning = function() stop("A Warning!") + ) > > for (i in 1:5) lst <- unitizer:::nextItem(lst) > lst@.pointer [1] 5 > > # - "unitizerList value replacement and pointer adjustments" ------------------- > > lst[[4]] <- NULL > lst@.pointer [1] 4 > unitizer:::reset(lst, "back") An object of class "unitizerList" Slot ".items": [[1]] [1] 5 [[2]] [1] "booyah" [[3]] a 1 a 2 b 3 c [[4]] [1] "b" Slot ".pointer": [1] 5 Slot ".seek.fwd": [1] FALSE > lst.len <- length(lst) > identical(lst@.pointer, lst.len) [1] TRUE > lst[2:3] <- letters[1:2] > identical(lst@.pointer, lst.len) [1] TRUE > lst[2:3] <- list(NULL, NULL) > identical(lst@.pointer, lst.len) [1] TRUE > lst[2:3] <- NULL > identical(lst@.pointer, lst.len - 2L) [1] TRUE > > lst <- unitizer:::reset(lst, "front") > for (i in 1:2) lst <- unitizer:::nextItem(lst) > curr.point <- lst@.pointer > lst[[3]] <- NULL > identical(curr.point, lst@.pointer) [1] TRUE > lst <- unitizer:::append(lst, list(5, 6, "blaskdjf"), 1L) > identical(curr.point + 3L, lst@.pointer) [1] TRUE > lst <- unitizer:::append(lst, list(matrix(1:9, nrow = 3)), 5L) > identical(curr.point + 3L, lst@.pointer) [1] TRUE > > # - "Append Factors Works" ----------------------------------------------------- > > vec <- factor(letters[1:3], levels = letters) > vec2 <- factor(letters[10:15], levels = letters) > > all.equal(structure(c(1L, 2L, 3L, 10L, 11L, 12L, 13L, 14L, + 15L), .Label = c("a", "b", "c", "d", "e", "f", "g", "h", + "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", + "u", "v", "w", "x", "y", "z"), class = "factor"), append(vec, + vec2)) [1] TRUE > all.equal(structure(c(1L, 2L, 10L, 11L, 12L, 13L, 14L, 15L, + 3L), .Label = c("a", "b", "c", "d", "e", "f", "g", "h", "i", + "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", + "v", "w", "x", "y", "z"), class = "factor"), append(vec, + vec2, 2)) [1] TRUE > > all.equal(structure(c(10L, 11L, 12L, 13L, 1L, 2L, 3L, 14L, + 15L), .Label = c("a", "b", "c", "d", "e", "f", "g", "h", + "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", + "u", "v", "w", "x", "y", "z"), class = "factor"), append(vec2, + vec, 4)) [1] TRUE > try(append(vec2, vec, 20)) Error in append(vec2, vec, 20) : Argument after must be integer like between 0 and length(x) > try(append(vec2, vec, -5)) Error in append(vec2, vec, -5) : Argument after must be integer like between 0 and length(x) > > # - "List coersion works even inside apply functions" -------------------------- > > ulist <- new("unitizerList", .items = list("a", 1, 2, "b")) > identical(lapply(ulist, identity), ulist@.items) [1] TRUE > > # - "Errors" ------------------------------------------------------------------- > > setClass("uhtsdfoqiuerhzb", slots = c(a = "integer")) > dummy <- new("uhtsdfoqiuerhzb", a = 1L) > lst2 <- new("unitizerList", .items = list(1, 2, 3)) > try(append(lst2, 5, after = -1)) Error in append(lst2, 5, after = -1) : Argument `after` must be a length 1 numeric greater than zero > try(append(lst2, dummy)) Error in as.list.default(values) : no method for coercing this S4 class to a vector Error in append(lst2, dummy) : Unable to coerce argument `values` to appropriate type; see previous errors for details. > > lst3 <- new("unitizerList", .items = expression(1, 2, 3)) > try(append(lst3, dummy)) Error in as.expression.default(values) : no method for coercing this S4 class to a vector Error in append(lst3, dummy) : Unable to coerce argument `values` to appropriate type; see previous errors for details. > > # - "Set Names" ---------------------------------------------------------------- > > nlst <- new("unitizerList", .items = list(a = "a", b = "b")) > names(nlst) <- toupper(names(nlst)) > as.list(nlst) $A [1] "a" $B [1] "b" > > > proc.time() user system elapsed 0.747 0.099 0.838 unitizer/tests/t-browser.R0000644000176200001440000001555514766101222015350 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") options(unitizer.color = FALSE) zero.env <- parent.env(.GlobalEnv) obj.item <- new("unitizerItem", call = quote(1 + 1), env = new.env()) obj.item@data@value <- list(2) obj.item@data@output <- c("two", "dos", "due") obj.item@data@conditions <- new("conditionList", .items = list(simpleError("hello"), simpleWarning("What a warning"))) obj.item@data@message <- vapply(unitizer:::as.list(obj.item@data@conditions), conditionMessage, character(1L)) obj.item@data@aborted <- TRUE # - "unitizerItem accessor functions work" ------------------------------------- obj.item$value obj.item$output obj.item$conditions # Create a bunch of expressions for testing exps1 <- expression( library(stats), unitizer_sect("Section 1", { 1 + 1 runif(20) stop("woohoo") "I'll be removed" "I too will be removed" }), unitizer_sect("Section 2", { "I three will be removed" sample(20) })) exps2 <- expression( library(stats), unitizer_sect("Section 1", { 1 + 1 runif(20) stop("woohoo") var <- 200 matrix(1:9, 3) }), unitizer_sect("Section 2", { 1 + 20 var1 <- list(1, 2, 3) sample(20) matrix(1:9, ncol = 3) lm(x ~ y, data.frame(x = 1:10, y = c(5, 3, 3, 2, 1, 8, 2, 1, 4, 1.5))) })) my.unitizer <- new("unitizer", id = 1, zero.env = zero.env) coi(my.unitizer <- my.unitizer + exps1) my.unitizer2 <- new("unitizer", id = 2, zero.env = zero.env) # make previous items into reference items my.unitizer2 <- my.unitizer2 + my.unitizer@items.new # now add back items to compare coi(my.unitizer2 <- my.unitizer2 + exps2) unitizer.prepped <- unitizer:::browsePrep(my.unitizer2, mode = "unitize") # NOTE: for some reason, changes in between revisions d9619db and a46e941 # should have caused the tests to fail, but didn't. We did not notice # failures until we ran tests quite a bit later at ca9f540364. Not sure why # this happened. The failures were due to the order of tests changing because # we moved ignored tests to be in the same sub-section as the subsequent non- # ignored tests # - "Can convert to data.frame" ------------------------------------------------ all.equal(unitizer:::as.data.frame(unitizer.prepped), rds("browse_df1")) # - "unitizerBrowse correctly processes unitizer for display" ------------------ # force all tests to be reviewed so they will be shown unitizer.prepped@mapping@reviewed <- rep(TRUE, length(unitizer.prepped@mapping@reviewed)) unitizer.prepped@mapping@review.val <- rep("Y", length(unitizer.prepped@mapping@reviewed)) all.equal(as.character(unitizer.prepped, 60), rds("browse_aschar1")) # Alternating tests unitizer.prepped@mapping@reviewed <- as.logical(seq(length(unitizer.prepped@mapping@reviewed))%%2) all.equal(as.character(unitizer.prepped, 60), rds("browse_aschar2")) # Errors / warnings try(as.character(unitizer.prepped, -1)) # positive prep.narrow <- as.character(unitizer.prepped, 5) # too small all.equal(prep.narrow, rds("browse_ascharnarrow")) # Colors work (should be last in this section) since the reference @global unitizer.prepped@global$unitizer.opts[["unitizer.color"]] <- TRUE old.opt <- options(crayon.enabled = TRUE) prep.color <- as.character(unitizer.prepped, 60) all.equal(prep.color, rds("browse_aschar3")) unitizer.prepped@global$unitizer.opts[["unitizer.color"]] <- FALSE options(old.opt) # - "processInput generates Correct Item Structure" ---------------------------- # Here we just test that the calls of each item are what we expect, making # sure that different behavior for Y or N depending on sub-section type is # observed correctly (e.g. a Y for new test means keep it, where as for # removed test means don't keep it) # For debugging: # cbind(substr(unitizer:::deparseCalls(unitizer.prepped), 1, 15), as.character(unitizer.prepped@mapping@review.type), unitizer.prepped@mapping@review.val, unitizer.prepped@mapping@reviewed) # cat(deparse(width=500, # lapply( # unitizer:::as.list(unitizer:::processInput(unitizer.prepped)), # function(x) call("quote", slot(x, "call"))) # ) ) unitizer.prepped@mapping@reviewed <- rep(TRUE, length(unitizer.prepped@mapping@reviewed)) unitizer.prepped@mapping@review.val <- rep("Y", length(unitizer.prepped@mapping@reviewed)) # Assume user accepted all tests lapply( unitizer:::as.list(unitizer:::processInput(unitizer.prepped)), slot, "call" ) # Assume user accepted all but 1, 4, 6 and 11, note it isn't completely # obvious what should be kept since an N for anything but a new and passed # test will result in some object remaining in the list (typically the # reference copy thereof) unitizer.prepped@mapping@review.val[] <- "N" unitizer.prepped@mapping@review.val[c(2, 6, 8, 12)] <- "Y" lapply( unitizer:::as.list(unitizer:::processInput(unitizer.prepped)), slot, "call" ) # - "unitizerBrowse subsetting works" ------------------------------------------ # note single bracket subsetting for `unitizerBrowse` overrides the `unitizerList` # subsetting unitizer:::deparseCalls(unitizer:::extractItems(unitizer.prepped[c(4, 8, 10)])) unitizer:::deparseCalls(unitizer:::extractItems(unitizer.prepped[c(2, 3, 11)])) # - "Reference section mapping works" ------------------------------------------ # Copy over just two sections my.unitizer3 <- new("unitizer", id = 3, zero.env = zero.env) + my.unitizer2@items.new[-(2:6)] # Exclude section two tests # sections should copy over my.unitizer3 <- unitizer:::refSections(my.unitizer3, my.unitizer2) # just copy over 1st and 3rd sections identical(my.unitizer3@sections.ref, my.unitizer2@sections[-2]) my.unitizer3@section.ref.map # Make sure "removed" sections are NA when kept unitizer.prepped@mapping@reviewed <- rep(TRUE, length(unitizer.prepped@mapping@reviewed)) # don't delete removed unitizer.prepped@mapping@review.val <- ifelse(unitizer.prepped@mapping@review.type %in% c("Removed"), "N", "Y") items.processed <- unitizer:::processInput(unitizer.prepped) vapply(unitizer:::as.list(items.processed), slot, 1L, "section.id") # Now try to re-establish sections with removed tests my.unitizer4 <- new("unitizer", id = 4, zero.env = zero.env) + items.processed # sections should copy over my.unitizer4 <- unitizer:::refSections(my.unitizer4, my.unitizer2) is(my.unitizer4@sections.ref[[4L]], "unitizerSectionNA") my.unitizer4@section.ref.map # - "Item Extraction" ---------------------------------------------------------- items <- unitizer:::extractItems(unitizer.prepped) item.calls <- vapply( unitizer:::as.list(items), function(x) paste0(deparse(x@call, width.cutoff = 500), collapse = ""), character(1L) ) item.types <- vapply(unitizer:::as.list(items), slot, FALSE, "reference") item.ids <- vapply(unitizer:::as.list(items), slot, 1L, "id") item.df <- data.frame(item.calls, item.types, item.ids, stringsAsFactors = FALSE) all.equal(item.df[order(item.types, item.ids),], rds("browse_itemord")) unitizer/tests/t-browser.Rout.save0000644000176200001440000002164614766101222017033 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") > > options(unitizer.color = FALSE) > zero.env <- parent.env(.GlobalEnv) > obj.item <- new("unitizerItem", call = quote(1 + 1), env = new.env()) > obj.item@data@value <- list(2) > obj.item@data@output <- c("two", "dos", "due") > obj.item@data@conditions <- new("conditionList", .items = list(simpleError("hello"), + simpleWarning("What a warning"))) > obj.item@data@message <- vapply(unitizer:::as.list(obj.item@data@conditions), + conditionMessage, character(1L)) > obj.item@data@aborted <- TRUE > > # - "unitizerItem accessor functions work" ------------------------------------- > > obj.item$value [1] 2 > obj.item$output [1] "two" "dos" "due" > obj.item$conditions Condition list with 2 conditions: 1. Error: hello 2. Warning: What a warning > > # Create a bunch of expressions for testing > > exps1 <- expression( + library(stats), + unitizer_sect("Section 1", { + 1 + 1 + runif(20) + stop("woohoo") + "I'll be removed" + "I too will be removed" + }), + unitizer_sect("Section 2", { + "I three will be removed" + sample(20) + })) > exps2 <- expression( + library(stats), + unitizer_sect("Section 1", { + 1 + 1 + runif(20) + stop("woohoo") + var <- 200 + matrix(1:9, 3) + }), + unitizer_sect("Section 2", { + 1 + 20 + var1 <- list(1, 2, 3) + sample(20) + matrix(1:9, ncol = 3) + lm(x ~ y, data.frame(x = 1:10, y = c(5, 3, 3, 2, 1, 8, 2, + 1, 4, 1.5))) + })) > my.unitizer <- new("unitizer", id = 1, zero.env = zero.env) > coi(my.unitizer <- my.unitizer + exps1) > my.unitizer2 <- new("unitizer", id = 2, zero.env = zero.env) > # make previous items into reference items > my.unitizer2 <- my.unitizer2 + my.unitizer@items.new > # now add back items to compare > coi(my.unitizer2 <- my.unitizer2 + exps2) > unitizer.prepped <- unitizer:::browsePrep(my.unitizer2, mode = "unitize") > > # NOTE: for some reason, changes in between revisions d9619db and a46e941 > # should have caused the tests to fail, but didn't. We did not notice > # failures until we ran tests quite a bit later at ca9f540364. Not sure why > # this happened. The failures were due to the order of tests changing because > # we moved ignored tests to be in the same sub-section as the subsequent non- > # ignored tests > > # - "Can convert to data.frame" ------------------------------------------------ > > all.equal(unitizer:::as.data.frame(unitizer.prepped), rds("browse_df1")) [1] TRUE > > # - "unitizerBrowse correctly processes unitizer for display" ------------------ > > # force all tests to be reviewed so they will be shown > unitizer.prepped@mapping@reviewed <- + rep(TRUE, length(unitizer.prepped@mapping@reviewed)) > unitizer.prepped@mapping@review.val <- + rep("Y", length(unitizer.prepped@mapping@reviewed)) > all.equal(as.character(unitizer.prepped, 60), rds("browse_aschar1")) [1] TRUE > > # Alternating tests > unitizer.prepped@mapping@reviewed <- + as.logical(seq(length(unitizer.prepped@mapping@reviewed))%%2) > all.equal(as.character(unitizer.prepped, 60), rds("browse_aschar2")) [1] TRUE > > # Errors / warnings > try(as.character(unitizer.prepped, -1)) # positive Error in .local(x, ...) : Argument `width` must be a positive scalar numeric. > prep.narrow <- as.character(unitizer.prepped, 5) # too small Warning in .local(x, ...) : Selected display width too small, will be ignored > > all.equal(prep.narrow, rds("browse_ascharnarrow")) [1] TRUE > > # Colors work (should be last in this section) since the reference @global > > unitizer.prepped@global$unitizer.opts[["unitizer.color"]] <- TRUE > old.opt <- options(crayon.enabled = TRUE) > prep.color <- as.character(unitizer.prepped, 60) > all.equal(prep.color, rds("browse_aschar3")) [1] TRUE > unitizer.prepped@global$unitizer.opts[["unitizer.color"]] <- FALSE > options(old.opt) > > # - "processInput generates Correct Item Structure" ---------------------------- > > # Here we just test that the calls of each item are what we expect, making > # sure that different behavior for Y or N depending on sub-section type is > # observed correctly (e.g. a Y for new test means keep it, where as for > # removed test means don't keep it) > # For debugging: > # cbind(substr(unitizer:::deparseCalls(unitizer.prepped), 1, 15), as.character(unitizer.prepped@mapping@review.type), unitizer.prepped@mapping@review.val, unitizer.prepped@mapping@reviewed) > # cat(deparse(width=500, > # lapply( > # unitizer:::as.list(unitizer:::processInput(unitizer.prepped)), > # function(x) call("quote", slot(x, "call"))) > # ) ) > unitizer.prepped@mapping@reviewed <- + rep(TRUE, length(unitizer.prepped@mapping@reviewed)) > unitizer.prepped@mapping@review.val <- + rep("Y", length(unitizer.prepped@mapping@reviewed)) > > # Assume user accepted all tests > > lapply( + unitizer:::as.list(unitizer:::processInput(unitizer.prepped)), slot, "call" + ) [[1]] library(stats) [[2]] runif(20) [[3]] var <- 200 [[4]] matrix(1:9, 3) [[5]] 1 + 1 [[6]] stop("woohoo") [[7]] var1 <- list(1, 2, 3) [[8]] sample(20) [[9]] 1 + 20 [[10]] matrix(1:9, ncol = 3) [[11]] lm(x ~ y, data.frame(x = 1:10, y = c(5, 3, 3, 2, 1, 8, 2, 1, 4, 1.5))) > # Assume user accepted all but 1, 4, 6 and 11, note it isn't completely > # obvious what should be kept since an N for anything but a new and passed > # test will result in some object remaining in the list (typically the > # reference copy thereof) > unitizer.prepped@mapping@review.val[] <- "N" > unitizer.prepped@mapping@review.val[c(2, 6, 8, 12)] <- "Y" > lapply( + unitizer:::as.list(unitizer:::processInput(unitizer.prepped)), slot, "call" + ) [[1]] runif(20) [[2]] stop("woohoo") [[3]] [1] "I'll be removed" [[4]] sample(20) [[5]] matrix(1:9, ncol = 3) [[6]] [1] "I three will be removed" > # - "unitizerBrowse subsetting works" ------------------------------------------ > > # note single bracket subsetting for `unitizerBrowse` overrides the `unitizerList` > # subsetting > unitizer:::deparseCalls(unitizer:::extractItems(unitizer.prepped[c(4, 8, 10)])) [1] "matrix(1:9, 3)" "\"I too will be removed\"" [3] "sample(20)" > unitizer:::deparseCalls(unitizer:::extractItems(unitizer.prepped[c(2, 3, 11)])) [1] "runif(20)" "var <- 200" "1 + 20" > > # - "Reference section mapping works" ------------------------------------------ > > # Copy over just two sections > my.unitizer3 <- new("unitizer", id = 3, zero.env = zero.env) + + my.unitizer2@items.new[-(2:6)] > # Exclude section two tests > # sections should copy over > my.unitizer3 <- unitizer:::refSections(my.unitizer3, my.unitizer2) > # just copy over 1st and 3rd sections > identical(my.unitizer3@sections.ref, my.unitizer2@sections[-2]) [1] TRUE > my.unitizer3@section.ref.map [1] 1 2 2 2 2 2 > > # Make sure "removed" sections are NA when kept > unitizer.prepped@mapping@reviewed <- + rep(TRUE, length(unitizer.prepped@mapping@reviewed)) > # don't delete removed > unitizer.prepped@mapping@review.val <- + ifelse(unitizer.prepped@mapping@review.type %in% c("Removed"), "N", "Y") > items.processed <- unitizer:::processInput(unitizer.prepped) > vapply(unitizer:::as.list(items.processed), slot, 1L, "section.id") [1] 1 2 2 2 2 2 NA NA 3 3 3 3 3 NA > > # Now try to re-establish sections with removed tests > my.unitizer4 <- + new("unitizer", id = 4, zero.env = zero.env) + items.processed > # sections should copy over > my.unitizer4 <- unitizer:::refSections(my.unitizer4, my.unitizer2) > is(my.unitizer4@sections.ref[[4L]], "unitizerSectionNA") [1] TRUE > my.unitizer4@section.ref.map [1] 1 2 2 2 2 2 4 4 3 3 3 3 3 4 > > # - "Item Extraction" ---------------------------------------------------------- > > items <- unitizer:::extractItems(unitizer.prepped) > item.calls <- vapply( + unitizer:::as.list(items), + function(x) + paste0(deparse(x@call, width.cutoff = 500), collapse = ""), character(1L) + ) > item.types <- vapply(unitizer:::as.list(items), slot, FALSE, "reference") > item.ids <- vapply(unitizer:::as.list(items), slot, 1L, "id") > item.df <- data.frame(item.calls, item.types, item.ids, stringsAsFactors = FALSE) > > all.equal(item.df[order(item.types, item.ids),], rds("browse_itemord")) [1] TRUE > > proc.time() user system elapsed 1.332 0.147 1.672 unitizer/tests/not-cran.R0000644000176200001440000000444314766101222015137 0ustar liggesusersif(!nzchar(Sys.getenv('NOT_CRAN'))) q() source(file.path("_helper", "init.R")) # - "test file / store manip" ------------------------------------------------ as.character.custstore <- function(x, ...) x stopifnot( all.equal(unitizer:::as.store_id_chr(file.path(getwd(), "hello")), "hello"), grepl( "Unable to convert store id to character", try(unitizer:::as.store_id_chr(structure("hello", class = "untz_stochrerr"))), ), all.equal( unitizer:::best_store_name( structure(list("hello", class = "custstore")), "hello" ), "unitizer for test file 'hello'" ), all.equal( unitizer:::best_store_name( structure(list("hello", class = "custstore")), NA_character_ ), "" ), all.equal( unitizer:::best_file_name( structure(list("hello", class = "custstore")), NA_character_ ), "" ) ) # - read only ------------------------------------------------------------------ # try to write to read only # seems to be case that root can always write so defeats this test if (identical(.Platform$OS.type, "unix")) { toy.path <- file.path("_helper", "unitizers", "misc.unitizer") toy.stor <- readRDS(file.path(toy.path, "data.rds")) ro.dir <- tempfile() on.exit(unlink(ro.dir)) dir.create(ro.dir, mode = "0500") if (!identical(try(system("whoami", intern = TRUE), silent = TRUE), "root")) { err <- try( capture.output(set_unitizer(ro.dir, toy.stor), type = "message"), ) stopifnot( grepl("Failed setting unitizer", conditionMessage(attr(err, 'condition'))) ) } } # - "as.state" ----------------------------------------------------------------- # This fails on winbuilder machines? Not entirely clear why it would given that # the only obvious difference in the dir structure is that the test dirs are # tests_x64, etc., instead of just tests, but the code doesn't care about that. # A bit of a red herring is that the winbuilder artifact dir is not actually # the directory the tests are run in (we know because we ran a pwd() in one of # our tests). in.pkg.state <- unitizer:::as.state( unitizer:::unitizerStateRaw(par.env = in_pkg()), test.files = getwd() ) stopifnot( identical( in.pkg.state, unitizer:::unitizerStateProcessed(par.env = getNamespace("unitizer")) ) ) unitizer/tests/t-nav.Rout.save0000644000176200001440000001571314766101222016132 0ustar liggesusers R version 4.0.5 Patched (2021-05-28 r80517) -- "Shake and Throw" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > nav <- file.path("_helper", "unitizers", "nav.R") > > # Simple navigation tests that don't require complex unitizers > > # - "Re-run bookmark" -----=---------------------------------------------------- > > # Relates to #278. Tests both Review and Browse > > unitizer:::read_line_set_vals( + c("R", "Y", "B", "7", "R", "Y", "B", "9", "R", "Y", "Q") + ) > unitize(nav, interactive.mode=TRUE) +------------------------------------------------------------------------------+ | unitizer for: _helper/unitizers/nav.R | +------------------------------------------------------------------------------+ Pass Fail New A - - 2 B - - 2 .................. - - 4 = A ============================================================================ - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? > a <- 42 > a + 1 [1] 43 unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 4 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Re-run unitizer ([Y]es, [P]rev, [B]rowse, [U]nreviewed, [R]erun, f[O]rce)? unitizer> Y | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: _helper/unitizers/nav.R | +------------------------------------------------------------------------------+ Pass Fail New A - - 2 B - - 2 .................. - - 4 = A ============================================================================ - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? | Jumping to test #3 because that was the test under review when test re-run was | requested. > a <- 42 > a + 1 [1] 43 unitizer> B = ============== *1. z <- 24 . . -:- = A ======================= *2. a <- 42 . . -:- 3. a + 1 . . . New:- 4. a + 2 . . . New:- = B ======================= *5. b <- 25 . . -:- *6. bb <- 26 . . -:- 7. b + 1 . . . New:- *8. bbb <- 27 . . -:- 9. b + 2 . . . New:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> 7 = B ============================================================================ - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? > b <- 25 > bb <- 26 > b + 1 [1] 26 unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 4 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Re-run unitizer ([Y]es, [P]rev, [B]rowse, [U]nreviewed, [R]erun, f[O]rce)? unitizer> Y | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: _helper/unitizers/nav.R | +------------------------------------------------------------------------------+ Pass Fail New A - - 2 B - - 2 .................. - - 4 = B ============================================================================ - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? | Jumping to test #7 because that was the test under review when test re-run was | requested. > b <- 25 > bb <- 26 > b + 1 [1] 26 unitizer> B = ============== *1. z <- 24 . . -:- = A ======================= *2. a <- 42 . . -:- 3. a + 1 . . . New:- 4. a + 2 . . . New:- = B ======================= *5. b <- 25 . . -:- *6. bb <- 26 . . -:- 7. b + 1 . . . New:- *8. bbb <- 27 . . -:- 9. b + 2 . . . New:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> 9 = B ============================================================================ - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? > bbb <- 27 > b + 2 [1] 27 unitizer> R | Toggling re-run mode ON for this unitizer = Finalize Unitizer ============================================================ | You have 4 unreviewed tests; press `B` to browse tests, `U` to go to first | unreviewed test. | You made no changes to the unitizer so there is no need to update it. While | unnecessary, you can force an update by typing O at the prompt. | Re-run unitizer ([Y]es, [P]rev, [B]rowse, [U]nreviewed, [R]erun, f[O]rce)? unitizer> Y | unitizer unchanged. +------------------------------------------------------------------------------+ | unitizer for: _helper/unitizers/nav.R | +------------------------------------------------------------------------------+ Pass Fail New A - - 2 B - - 2 .................. - - 4 = B ============================================================================ - New -------------------------------------------------------------------------- | The 2 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? | Jumping to test #9 because that was the test under review when test re-run was | requested. > bbb <- 27 > b + 2 [1] 27 unitizer> Q | No changes recorded. | unitizer unchanged. > > > proc.time() user system elapsed 2.198 0.152 3.311 unitizer/tests/t-error.R0000644000176200001440000000121114766101222014776 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "Test Error Diffs" --------------------------------------------------------- diffs <- new( "unitizerItemTestsErrorsDiffs", value = new("unitizerItemTestsErrorsDiff", txt = "value", err = TRUE, diff = diffobj::diffChr(1, 2)) ) diffs$value@diff@target diffs$value@diff@current try(diffs$values) try(diffs[[NA]]) err <- new( "unitizerItemTestsErrors", value = new( "unitizerItemTestError", compare.err = TRUE, value = c("compare", "error") ) ) # - "Show Test Error" ---------------------------------------------------------- is(unitizer:::as.Diffs(err)@value, "unitizerItemTestsErrorsDiff") unitizer/tests/t-utz2.R0000644000176200001440000002675214766101222014572 0ustar liggesusers# Overflow tests from testthat.unitize.R source(file.path("_helper", "init.R")) source(file.path("_helper", "pkgs.R")) library(unitizer) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "unreviewed variations" ---------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Test unreviewed # Accept one and go to unreviewed # Accept one more and browse and go to unreviewed # Accept two remaining and confirm no unreviewed # No unreviewed tests unitizer:::read_line_set_vals( c("Y", "Q", "U", "Y", "B", "U", "Y", "Y", "U", "B", "U", "Q") ) out <- unitizer:::capture_output(unitize(FLM.TEST.FILE, interactive.mode = TRUE)) unitizer:::clean_eval_exp(out) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Re-eval" ------------------------------------------------------------------ # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Test re-eval # Re-eval and jump back to file 1 # Quit from file 1 and back to main menu # Accept one test in file 2 and quit # Go to file 3, accept one, and Re-eval all unitizer:::read_line_set_vals( c("1", "Y", "R", "Y", "Q", "2", "Y", "Y", "3", "Y", "RR", "Y", "Q", "Q") ) untz1 <- unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) print(untz1) # remove temp file names and display invisible(lapply(untz1, function(x) {print(x); cat('\n')})) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Section Extra" ------------------------------------------------------------ # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Make sure that deleted items from a section are still marked from that # section upgrade to version two to use the files that are set up for that # there; notice update_fastlm_*extra* # Re-set by dropping unitizers unlink(list.dirs(FLM.TEST.DIR, recursive = FALSE), recursive = TRUE) unitizer:::update_fastlm_extra(FLM) inst_pak(FLM) test.file.1 <- file.path(FLM.TEST.DIR, "unitizer.fastlm.R") test.file.2 <- file.path(FLM.TEST.DIR, "unitizer.fastlm2.R") test.store <- file.path(FLM.TEST.DIR, "store2.unitizer") # First auto accept all initial tests, and then re-run with second version to # make sure deleted tests are where we think they should be out.1 <- unitizer:::capture_output(unitize(test.file.1, test.store, auto.accept = "new")) unitizer:::read_line_set_vals(c("B", "Q")) out.2 <- unitizer:::capture_output( untz.2 <- unitize(test.file.2, test.store, interactive.mode = TRUE) ) attributes(untz.2) <- NULL untz.2 # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "warning when comp funs produce output" ------------------------------------ # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Sections with comp funs that output to stdout/stderr temp.loc <- tempfile() dir.create(temp.loc) file.copy(file.path(START.DIR, "_helper", "unitizers", "sects.R"), temp.loc) f.sec <- file.path(temp.loc, "sects.R") odir <- setwd(temp.loc) out <- unitizer:::capture_output( unitize(f.sec, auto.accept = "new", interactive.mode = FALSE ) ) unitize(f.sec, interactive.mode = FALSE) setwd(odir) unlink(temp.loc, recursive = TRUE) # - "Corner Case Files" -------------------------------------------------------- # Corner case files # empty temp.empty <- paste0(tempfile(), "-empty.R") cat("\n", file = temp.empty) empty.capt <- unitizer:::capture_output(unitize(temp.empty, force = TRUE)) # File, but does not end in .R temp.bad <- paste0(tempfile()) cat("\n", file = temp.bad) badname.capt <- unitizer:::capture_output(try(unitize(temp.bad))) any(grepl("`get_unitizer` error", out$message)) any(grepl("Empty unitizer", empty.capt$output)) any(grepl("No valid unitizers available", badname.capt$message)) unlink(c(temp.empty, temp.bad)) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Re-eval change" ----------------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # re-eval reeval with a modified file temp.reeval.base <- paste0(tempfile(), "-reeval") temp.reeval <- paste0(temp.reeval.base, ".R") temp.reeval.utz <- paste0(temp.reeval.base, ".unitizer") cat("1 + 1\n2 + 2\n", file = temp.reeval) # force re-review unitizer:::read_line_set_vals(c("Y", "P", "Y", "cat(\"1 + 1\n2 + 3\n\", file=temp.reeval)", "R", "Y", "Q")) # state = environment() so we can access variables from this local reeval.capt <- unitizer:::capture_output(unitize(temp.reeval, state = environment(), interactive.mode = TRUE)) unlink(c(temp.reeval, temp.reeval.utz), recursive = TRUE) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Condition fail" ----------------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Fail test with conditions temp.cond.base <- paste0(tempfile(), "-cond") temp.cond <- paste0(tempfile(), ".R") temp.cond.utz <- paste0(tempfile(), ".unitizer") cond.message <- "hello world" cat("warning(cond.message)", file = temp.cond) unitizer:::read_line_set_vals(c("Y", "Y")) # state = environment() so we can access variables from this local unitizer:::capture_output( unitize(temp.cond, state = environment(), interactive.mode = TRUE) ) cond.message <- "goodbye world" unitizer:::read_line_set_vals("Q") cond.capt <- unitizer:::capture_output( unitize(temp.cond, state = environment(), interactive.mode = TRUE) ) sum(grepl("Conditions mismatch", cond.capt$output)) == 1L unlink(c(temp.cond, temp.cond.utz), recursive = TRUE) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Force" -------------------------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # # Toggle force update, in order for this to work we need to create a situation # where in a `unitize_dir`, one file passes, the other doesn't, and we review # the file that passes. Otherwise the only other way to do it is to set force # from the beginning, but that ruins the toggle effect. One possible issue # here is that we don't have a great way to check the file actually changed. temp.forceup.base.dir <- tempfile() dir.create(temp.forceup.base.dir) temp.forceup.1 <- file.path(temp.forceup.base.dir, "force1.R") temp.forceup.2 <- file.path(temp.forceup.base.dir, "force2.R") cat("force.var\n", file = temp.forceup.1) cat("4 + 1\n", file = temp.forceup.2) force.var <- 1 unitizer:::capture_output({ unitize(temp.forceup.1, auto.accept = "new", state = environment()) unitize(temp.forceup.2, auto.accept = "new", state = environment()) }) force.var <- 2 unitizer:::read_line_set_vals(c("2", "1", "Y", "O", "Q", "Q")) force.capt <- unitizer:::capture_output(unitize_dir(temp.forceup.base.dir, state = environment(), interactive.mode = TRUE)) unlink(temp.forceup.base.dir, recursive = TRUE) sum(grepl("Toggling force update mode ON", force.capt$message)) == 1L sum(grepl("You are about to .* with re-evaluated", force.capt$message)) == 1L # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Compare Funs" ------------------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Bad comparison functions temp.bad.comp <- paste0(tempfile(), ".R") cat("\n unitizer_sect(\n 'bad comp', {1 + 1; 2 + 2},\n compare=function(x, y) list('failed', 'comparison')\n )\n", file = temp.bad.comp) unitizer:::capture_output(unitize(temp.bad.comp, auto.accept = "new")) unitizer:::read_line_set_vals(c("Q")) bad.comp.capt <- unitizer:::capture_output(unitize(temp.bad.comp, interactive.mode = TRUE)) unlink(temp.bad.comp) sum(grepl("Unable to compare value", bad.comp.capt$message)) == 1L sum(grepl("Corrupted", bad.comp.capt$output)) >= 1L # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "bad map" ------------------------------------------------------------------ # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Bad store mapping functions try(unitize_dir(FLM.TEST.DIR, store.ids = function(x) stop("Bad store map fun"))) unitizer:::read_line_set_vals(NULL) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Multiple Bookmarks" ------------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Issue 245: In review-all mode should not move to next unitizer until the # review bookmark is cleared. temp.dir <- tempfile() dir.create(temp.dir) writeLines("'hello'\n'world'", file.path(temp.dir, "a.R")) writeLines("2 + 1\n3 + 2", file.path(temp.dir, "b.R")) writeLines("pi\n2 * pi\nsqrt(pi)", file.path(temp.dir, "c.R")) unitizer:::read_line_set_vals( c("A","N","N","Y","Y","R","Y","Q","Y","R","Y","Y","Y","Y","Q") ) unitize_dir(temp.dir, interactive.mode=TRUE) # Make sure re-eval all clears all bookmarks unlink( list.files(temp.dir, full.names=TRUE, pattern="\\.unitizer$"), recursive=TRUE ) unitizer:::read_line_set_vals(c("A","Q","Y","RR","Y","Q")) unitize_dir(temp.dir, interactive.mode=TRUE) unitizer:::read_line_set_vals(NULL) unlink(temp.dir, recursive=TRUE) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Non-Standard Conditions" -------------------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Issue 272: some conditions don't produce any output, but for `unitizer` we # consider normally non-test expressions that produce conditions as tests. So # we need a mechanism for clarifying what happened. temp.dir <- tempfile() temp.file <- file.path(temp.dir, 'a.R') dir.create(temp.dir) unitizer:::read_line_set_vals("Q") writeLines( c( "cond <- simpleCondition('hello')", "class(cond) <- c('svgchop_unsupported', 'svgchop', class(cond))", "invisible(signalCondition(cond))" ), temp.file ) unitize(temp.file, interactive.mode=TRUE) unitizer:::read_line_set_vals(NULL) unlink(temp.dir, recursive=TRUE) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Output Transcript in non-Interactive" ------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Issue 286: don't capture output in non-interactive. # We need `try` because we're testing what happens when the unitizer fails. temp.dir <- tempfile() temp.file <- file.path(temp.dir, 'a.R') dir.create(temp.dir) writeLines('warning("boom")', temp.file) # can't use error b/c try below old.opt <- options(unitizer.transcript=NULL, unitizer.show.progress=TRUE) try(unitize(temp.file)) options(old.opt) unlink(temp.dir, recursive=TRUE) # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # - "Display All Tests in non-Interactive" ------------------------------------- # /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ # Issue 293: don't stop after first failing test # We need `try` because we're testing what happens when the unitizer fails. temp.dir <- tempfile() temp.file.a <- file.path(temp.dir, 'a.R') temp.file.b <- file.path(temp.dir, 'b.R') dir.create(temp.dir) writeLines(c("1 + 1", "warning('hello')"), temp.file.a) writeLines(c("2 + 1", "warning('goodbye')"), temp.file.b) try(unitize_dir(temp.dir, transcript=FALSE)) options(old.opt) unlink(temp.dir, recursive=TRUE) unitizer/tests/t-translate.Rout.save0000644000176200001440000001271514766101222017342 0ustar liggesusers R Under development (unstable) (2022-01-01 r81419) -- "Unsuffered Consequences" Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") > > test.file.dir <- file.path("_helper", "ref-objs", "translate") > test.file <- file.path(test.file.dir, "testthat", "test-translate2.R") > test.file.min <- file.path(test.file.dir, "testthat2", "test-translate-min.R") > target.dir.base <- file.path(TMP.DIR, basename(tempfile())) > target.dir <- file.path(target.dir.base, "helper", "translate", "unitizer") > > # - "Prompt to create dir" ----------------------------------------------------- > > try( + testthat_translate_file( + test.file, target.dir, prompt = "always", interactive.mode = FALSE + ) ) Error in testthat_transcribe_file(file.name, target.dir, keep.testthat.call, : Unable to proceed without creating target directory > # translations have to be outside of `testthat`; second translation should fail > # except we allow manual input > > # - "translate a file" --------------------------------------------------------- > > unitizer:::capture_output({ + unitizer:::read_line_set_vals(c("Y")) + res1 <- testthat_translate_file(test.file, target.dir, prompt = "always", + interactive.mode = TRUE) + res1.txt <- readLines(res1) + unitizer:::read_line_set_vals(c("Y")) + res2 <- testthat_translate_file(test.file, target.dir, prompt = "overwrite", + interactive.mode = TRUE) + res2.txt <- readLines(res2) + unitizer:::read_line_set_vals(NULL) + }) > dummy <- new("unitizerDummy") > > all.equal(res1.txt, rds("translate_res1")) [1] TRUE > all.equal(res1.txt, res2.txt) [1] TRUE > > # Can't do this twice in a row without prompting in non-interactive mode > # note test above does work because we use interactive mode to accept prompt > > any( + grepl( + "already exists", + capture.output( + try( + testthat_translate_file( + test.file, target.dir, prompt = "always", interactive.mode = FALSE + ) ), + type='message' + ) ) ) [1] TRUE > untz <- get_unitizer(file.path(target.dir, "translate2.unitizer")) > all.equal(untz@items.ref.calls.deparse, rds("translate_res2")) [1] TRUE > > lapply(unitizer:::as.list(untz@items.ref), function(x) x@data@value[[1L]]) [[1]] [[2]] [1] 1 2 3 4 5 6 7 8 9 10 [[3]] NULL [[4]] NULL [[5]] NULL [[6]] NULL [[7]] [1] "yoyo" [[8]] NULL > unlink(target.dir, recursive = TRUE) > > target.dir.base <- file.path(TMP.DIR, basename(tempfile())) > target.dir <- file.path(target.dir.base, "_helper", "translate", "unitizer") > > test.dir <- file.path("_helper", "ref-objs", "translate", "testthat") > > # - "translate a dir" ---------------------------------------------------------- > > unitizer:::capture_output(res2 <- testthat_translate_dir(test.dir, target.dir)) > all.equal(lapply(res2, readLines), rds("translate_res3")) [1] TRUE > untz <- get_unitizer(file.path(target.dir, "translate2.unitizer")) > all.equal(untz@items.ref.calls.deparse, rds("translate_res4")) [1] TRUE > > # Note not the same as when we did just the single file because the helper > # file is loaded so `fun0` and `fun1` are actually defined > lapply(unitizer:::as.list(untz@items.ref), function(x) x@data@value[[1L]]) [[1]] [[2]] [1] 1 2 3 4 5 6 7 8 9 10 [[3]] [1] 42 [[4]] [1] 24 [[5]] [1] 24 [[6]] NULL [[7]] [1] "yoyo" [[8]] NULL > > # Can't do it again since there are files there > any( + grepl( + "safety feature to ensure files are not accidentally overwritten", + capture.output( + try(testthat_translate_dir(test.dir, target.dir)), type='message' + ) ) ) [1] TRUE > > # - minimal -------------------------------------------------------------------- > > # to test parameters > > writeLines( + readLines( + testthat_translate_file( + test.file.min, target.dir, prompt = "never", interactive.mode = TRUE, + unitize = FALSE + ) ) ) # Minimal translation # test_that("simple tests", { # expect_equal(fun0(a), 1:10) # }) unitizer_sect("simple tests", { # expect_equal(fun0(a), 1:10) fun0(a) }) > writeLines( + readLines( + testthat_translate_file( + test.file.min, target.dir, prompt = "never", interactive.mode = TRUE, + use.sects = FALSE, unitize = FALSE + ) ) ) # Minimal translation # test_that("simple tests", { # expect_equal(fun0(a), 1:10) # }) # - "simple tests" ------------------------------------------------------------- # expect_equal(fun0(a), 1:10) fun0(a) > writeLines( + readLines( + testthat_translate_file( + test.file.min, target.dir, prompt = "never", interactive.mode = TRUE, + use.sects = FALSE, keep.testthat.call = FALSE, unitize = FALSE + ) ) ) # Minimal translation # - "simple tests" ------------------------------------------------------------- fun0(a) > > > unitizer/tests/t-section.Rout.save0000644000176200001440000001426314766101222017011 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > expr.1 <- expression(1 + 1, b <- 5, matrix(integer(), nrow = b, + ncol = b)) > expr.2 <- { + 1 + 1 + b <- 5 + matrix(integer(), nrow = b, ncol = b) + } > expr.3 <- quote(expression(1 + 1, b <- 5, matrix(integer(), nrow = b, + ncol = b))) > expr.4 <- quote({ + 1 + 1 + b <- 5 + matrix(integer(), nrow = b, ncol = b) + }) > # - "simple tests" ------------------------------------------------------------- > > try(unitizer_sect(1:3)) Error in unitizer_sect(1:3) : Argument `title` must be a 1 length character vector. > try(unitizer_sect(letters)) Error in unitizer_sect(letters) : Argument `title` must be a 1 length character vector. > try(unitizer_sect("mytest", expr.1, 1:3)) Error in unitizer_sect("mytest", expr.1, 1:3) : Argument `details` must be character > # note the following two produce error messages, but it's not actually an error, > # it's just that there are multiple errors and `expect_error` only suppresses > # the last one, not the preceding ones. > try(unitizer_sect("mytest", expr.1, letters, letters)) Error in unitizer_sect("mytest", expr.1, letters, letters) : Argument `compare` must be "testFuns" or a function > try(unitizer_sect("mytest", expr.1, letters, identity)) Error in unitizer_sect("mytest", expr.1, letters, identity) : Argument `compare`, if a function, must accept two arguments and require no more than two (does not have at least two arguments) > try(unitizer_sect("mytest", expr.2)) Error in unitizer_sect("mytest", expr.2) : Argument `expr` must be an expression, or an unevaluated call that evaluates to an expression or `{`. > try(unitizer_sect("mytest", matrix(1:9, nrow = 3))) Error in unitizer_sect("mytest", matrix(1:9, nrow = 3)) : Argument `expr` must be an expression, or an unevaluated call that evaluates to an expression or `{`. > is(sect.1 <- unitizer_sect("mytest", expr.1), "unitizerSectionExpression") [1] TRUE > identical(unitizer:::as.expression(sect.1), expr.1) [1] TRUE > > is(sect.2 <- unitizer_sect("mytest", { + 1 + 1 + b <- 5 + matrix(integer(), nrow = b, ncol = b) + }), "unitizerSectionExpression") [1] TRUE > identical(sect.1, sect.2) [1] TRUE > is(sect.3 <- unitizer_sect("mytest", expr.3), "unitizerSectionExpression") [1] TRUE > identical(sect.1, sect.3) [1] TRUE > is(sect.4 <- unitizer_sect("mytest", expr.4), "unitizerSectionExpression") [1] TRUE > identical(sect.1, sect.4) [1] TRUE > is(sect.5 <- unitizer_sect("mytest", expression(1 + 1, + b <- 5, matrix(integer(), nrow = b, ncol = b))), "unitizerSectionExpression") [1] TRUE > identical(sect.1, sect.5) [1] TRUE > is(sect.1 <- unitizer_sect("mytest", expr.1, compare = identical), + "unitizerSectionExpression") [1] TRUE > unitizer_sect("hello") # warn Warning in unitizer_sect("hello") : `unitizer_sect` "hello" is empty. NULL > > # - "Custom Comparison Functions" ---------------------------------------------- > > # Run expressions with different comparison functions > set.seed(1) > expr.1 <- expression(50 + runif(1)/10^10, message("Hello There", + runif(1)), cat("Hello there", runif(1)), stop("Yo", runif(1))) > expr.2 <- expression(50 + runif(1)/10^10, message("Hello There", + runif(1)), cat("Hello there", runif(1)), stop("Yo", runif(1))) > expr.3 <- expression(unitizer_sect("change comp funs", compare = identical, + { + 50 + runif(1)/10^10 + message("Hello There", runif(1)) + cat("Hello there", runif(1)) + stop("Yo", runif(1)) + })) > expr.4 <- expression( + unitizer_sect( + "change comp funs", + compare = testFuns( + value = identical, output = all.equal, message = all.equal, + conditions = function(x, y) TRUE), + { + 50 + runif(1)/10^10 + message("Hello There", runif(1)) + cat("Hello there", runif(1)) + stop("Yo", runif(1)) + })) > my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) > coi(my.unitizer <- my.unitizer + expr.1) > my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env()) > # make previous items into reference items > coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new) > # now add back items to compare > coi(my.unitizer2 <- my.unitizer2 + expr.2) > my.unitizer3 <- new("unitizer", id = 3, zero.env = new.env()) > # make previous items into reference items > coi(my.unitizer3 <- my.unitizer3 + my.unitizer@items.new) > # now add back items to compare > coi(my.unitizer3 <- my.unitizer3 + expr.3) > my.unitizer4 <- new("unitizer", id = 4, zero.env = new.env()) > # make previous items into reference items > coi(my.unitizer4 <- my.unitizer4 + my.unitizer@items.new) > # now add back items to compare > coi(my.unitizer4 <- my.unitizer4 + expr.4) > > my.unitizer2@tests.result value conditions output message aborted [1,] TRUE TRUE TRUE TRUE TRUE [2,] TRUE FALSE TRUE TRUE TRUE [3,] TRUE TRUE TRUE TRUE TRUE [4,] TRUE FALSE TRUE TRUE TRUE > my.unitizer3@tests.result value conditions output message aborted [1,] FALSE TRUE TRUE TRUE TRUE [2,] TRUE FALSE TRUE TRUE TRUE [3,] TRUE TRUE TRUE TRUE TRUE [4,] TRUE FALSE TRUE TRUE TRUE > my.unitizer4@tests.result value conditions output message aborted [1,] FALSE TRUE TRUE TRUE TRUE [2,] TRUE TRUE TRUE FALSE TRUE [3,] TRUE TRUE FALSE TRUE TRUE [4,] TRUE TRUE TRUE FALSE TRUE > > > proc.time() user system elapsed 1.006 0.156 1.467 unitizer/tests/t-item.R0000644000176200001440000003671114766101222014620 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("item") options(unitizer.color = FALSE) # These tests are intended to cover all the functions/classes/methods in: # - item.R # - item.sub.R # - test_eval.R # indirectly # - heal.R # - unitizer.R # Basically everything that can be tested non-interactively # Helper funs callDep <- function(x) paste0(deparse(x@call, width.cutoff = 500), collapse = "") lsObjs <- function(x) paste0(x@ls$names, x@ls$status, collapse = ", ") lsStat <- function(x) x@ls$status lsInv <- function(x) isTRUE(attr(x@ls, "invalid")) # Get started new.exps <- expression( 1 + 1, a <- 54, # keep b <- 38, # keep a + b, e <- 5 * a, # keep a ^ 2, # Keep f <- e * a, matrix(rep(f, 20)) # keep ) ref.exps <- expression( 1 + 1, a <- 54, b <- 38, a + b, e <- 5 * a, e ^ 3 ) Sys.sleep(0.2) my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer <- my.unitizer + ref.exps) my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env()) # now convert them to reference items coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new) # now test against new.exps coi(my.unitizer2 <- my.unitizer2 + new.exps) # - "item funs" ---------------------------------------------------------------- item <- my.unitizer@items.new[[1L]] unitizer:::itemType(item) try(unitizer:::itemType(item) <- "asdfasd") unitizer:::itemType(item) <- "reference" unitizer:::itemType(item) try(unitizer:::itemsType(my.unitizer@items.new) <- as.character(1:1000)) try(item$booboo) # - "unitizer creation worked as expected" ------------------------------------- validObject(my.unitizer, complete = TRUE) all.equal(capture.output(show(my.unitizer@items.new[[1L]])), rds(100)) identical(length(my.unitizer2), length(new.exps)) identical(length(my.unitizer2@items.new), length(new.exps)) identical(length(my.unitizer2@items.ref), length(ref.exps)) all.equal( as.expression( lapply(unitizer:::as.list(my.unitizer2@items.new), slot, "call") ), new.exps ) all.equal( as.expression( lapply(unitizer:::as.list(my.unitizer2@items.ref), slot, "call") ), ref.exps ) vals <- lapply( unitizer:::as.list(my.unitizer2@items.new), function(x) x@data@value[[1L]] ) vals.ign <- unitizer:::ignored(my.unitizer2@items.new) all.equal(vals[!vals.ign], lapply(new.exps, eval)[!vals.ign]) all(vapply(vals[vals.ign], is, logical(1L), "unitizerDummy")) vals <- lapply( unitizer:::as.list(my.unitizer2@items.ref), function(x) x@data@value[[1L]] ) vals.ign <- unitizer:::ignored(my.unitizer2@items.ref) all.equal(vals[!vals.ign], lapply(ref.exps, eval)[!vals.ign]) all(vapply(vals[vals.ign], is, logical(1L), "unitizerDummy")) my.unitizer2@items.new.map my.unitizer2@items.ref.map my.unitizer2@tests.fail my.unitizer2@tests.status my.unitizer2@section.map unitizer:::ignored(my.unitizer2@items.new) unitizer:::ignored(my.unitizer2@items.ref) # - "Size Measurement works" --------------------------------------------------- # Used to produce warnings because the same base.env was used for every # unitizer because it was created on package load as part of the S4 class # definition instead of in "initialize", so any time we instantiated more # than one object they all shared the same environment, causing issues with # saveRDS x <- unitizer:::sizeUntz(my.unitizer2) is.matrix(x) && is.numeric(x) colnames(x) # - "Environment healing works" ------------------------------------------------ items.mixed <- my.unitizer2@items.new[4:5] + my.unitizer2@items.ref[[1]] + my.unitizer2@items.new[c(2, 6, 8)] items.sorted <- unitizer:::healEnvs(items.mixed, my.unitizer2) env.anc <- lapply(unitizer:::as.list(items.sorted), function(x) rev(unitizer:::env_ancestry(x@env, my.unitizer2@base.env))) max.len <- max(vapply(env.anc, length, 1L)) env.anc.2 <- lapply(env.anc, function(x) { length(x) <- max.len x }) env.anc.df <- as.data.frame(env.anc.2, stringsAsFactors = FALSE) # Here only the first item is reference, all others length(unique(unlist(env.anc.df[2, ]))) all( apply( env.anc.df[-(1:2), -1], 1, function(x) length(unique(Filter(Negate(is.na), x))) ) == 1L ) # First item is reference, all others are new unitizer:::itemsType(items.sorted) # Expected order of ids vapply(unitizer:::as.list(items.sorted), function(x) x@id, integer(1L)) lapply(unitizer:::as.list(items.sorted), function(x) x@ls$names) unique(unlist(lapply(unitizer:::as.list(items.sorted), function(x) x@ls$status))) # Tests with conditions # - "Items with conditions" ---------------------------------------------------- my_fun <- function() { warning("hello") 25 } ref.exps1a <- expression(stop("boom"), my_fun()) my.unitizer1a <- new("unitizer", id = 100, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer1a <- my.unitizer1a + ref.exps1a) all.equal(capture.output(show(my.unitizer1a@items.new[[1L]])), rds(200)) all.equal(capture.output(show(my.unitizer1a@items.new[[2L]])), rds(300)) all.equal( capture.output(show(my.unitizer1a@items.new[[1L]]@data@conditions)), rds(400) ) # - "Environment healing works 2" ---------------------------------------------- # Stars highlight items we are selecting, but keep in mind that unitizer only # cares about non ignored tests, and that the selection status of ignored test # has nothing to do with what we end up with wrt to ignored tests new.exps2 <- expression( 1 + 1, # 1 * a <- 54, # 2 b <- runif(5), # 3 howdy <- "yowser", # 4 * a + b, # 5 * e <- 5 * a, # 6 a ^ 2, # 7 f <- e * a, # 8 matrix(rep(f, 20)) # 9 * ) ref.exps2 <- expression( 1 + 1, # 1 a <- 54, # 2 b <- runif(5), # 3 * 25 + 3, # 4 q <- b ^ 2 / a, # 5 * a + b, # 6 z <- w <- list(1, 2, 3), # 7 Reduce(`+`, z), # 8 * Doesn't exist, should connect back to `a + b` e <- 5 * a, # 9 e ^ 3, # 10 * e * a # 11 * ) # Note that healEnvs modifies objects that contain environments, and as such # you won't get the same result if you run this function twice, so don't be # surprised if tests fail in those circumstances my.unitizer3 <- new("unitizer", id = 1, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer3 <- my.unitizer3 + ref.exps2) my.unitizer4 <- new("unitizer", id = 2, zero.env = new.env()) # now convert them to reference items coi(my.unitizer4 <- my.unitizer4 + my.unitizer3@items.new) # now test against new.exps coi(my.unitizer4 <- my.unitizer4 + new.exps2) coi( items.mixed2 <- my.unitizer4@items.ref[c(8, 10, 3, 5, 11)] + my.unitizer4@items.new[c(1, 4, 5, 9)] ) items.sorted2 <- unitizer:::healEnvs(items.mixed2, my.unitizer4) env.anc <- lapply(unitizer:::as.list(items.sorted2), function(x) rev(unitizer:::env_ancestry(x@env, my.unitizer4@base.env))) max.len <- max(vapply(env.anc, length, 1L)) env.anc.2 <- lapply(env.anc, function(x) { length(x) <- max.len x }) # oldest ancestor the same env.anc.df <- as.data.frame(env.anc.2, stringsAsFactors = FALSE) length(unique(unname(unlist(env.anc.df[1, ])))) # 1 # "base.env should be unitizer env") identical( env.anc.df[1, 1], unitizer:::env_name(my.unitizer4@base.env) ) # "all tests should also have another sub base.env") length(unique(unlist(env.anc.df[2, ]))) == 1L # "and it should be the items.ref here") identical( env.anc.df[2, 1], unitizer:::env_name(my.unitizer4@items.ref@base.env) ) items <- items.sorted2 items.lst <- unitizer:::as.list(items) # "new items should all have normal status", heal.info <- cbind( type = unitizer:::itemsType(items), ignored = unitizer:::ignored(items), id = vapply(items.lst, slot, 1L, "id"), call = vapply(items.lst, callDep, ""), ls = vapply(items.lst, lsObjs, ""), ls.invalid = vapply(items.lst, lsInv, TRUE) ) # "" unique(unlist(lapply(items.lst[unitizer:::itemsType(items) == "new"], lsStat))) # "Reference tests should have no ls data", unique(vapply(items.lst[unitizer:::ignored(items)], lsObjs, "")) all(vapply(items.lst[unitizer:::ignored(items)], lsInv, logical(1L))) # - "ls works" ----------------------------------------------------------------- my.unitizer5 <- new("unitizer", id = 2, zero.env = new.env()) # now add back our composite elements as references coi(my.unitizer5 <- my.unitizer5 + items.sorted2) # and new items coi(my.unitizer5 <- my.unitizer5 + new.exps2) # This is an ignored test, so there will be some problems env.val <- new.env(parent = my.unitizer5@items.new[[3]]@env) env.eval <- new.env(parent = env.val) assign(".NEW", my.unitizer5@items.new[[3]], env.val) assign(".new", my.unitizer5@items.new[[3]]@data@value[[1L]], env.val) assign(".REF", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[3]]]], env.val) assign(".ref", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[3]]]]@data@value[[1L]], env.val) ls.res <- evalq(unitizer:::unitizer_ls(), env.eval) # warn # Reference tests won't show up since they were nuked by `healEnvs` all.equal(ls.res, rds(500)) # These are normal tests so should work env.val <- new.env(parent = my.unitizer5@items.new[[9]]@env) env.eval <- new.env(parent = env.val) assign(".NEW", my.unitizer5@items.new[[9]], env.val) assign(".new", my.unitizer5@items.new[[9]]@data@value[[1L]], env.val) assign(".REF", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[9]]]], env.val) assign(".ref", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[9]]]]@data@value[[1L]], env.val) all.equal(evalq(unitizer:::unitizer_ls(), env.eval), rds(600)) all.equal(capture.output(print(evalq(unitizer:::unitizer_ls(), env.eval))), rds(700)) # - "Environment Healing Works #3" --------------------------------------------- # # Main difference to previous versions is that we're testing that moving the # order of tests around between ref and new still works # # Test that reference tests moving around doesn't cause major issues new.exps6 <- expression( 1 + 1, # 1 * a <- 54, # 2 b <- runif(5), # 3 howdy <- "yowser", # 4 a + b, # 5 e <- 5 * a, # 6 a ^ 2, # 7 * f <- 25, # 8 * matrix(rep(f, 20)) # 9 ) ref.exps6 <- expression( 1 + 1, # 1 a <- 54, # 2 f <- 25, # 3 matrix(rep(f, 20)), # 4 * b <- runif(5), # 5 boomboom <- "boo", # 6 a + b, # 7 * a + b + f, # 8 e <- 5 * a, # 9 a ^ 2 # 10 ) my.unitizer10 <- new("unitizer", id = 1, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer10 <- my.unitizer10 + ref.exps6) my.unitizer11 <- new("unitizer", id = 2, zero.env = new.env()) # now convert them to reference items coi(my.unitizer11 <- my.unitizer11 + my.unitizer10@items.new) # now test against new.exps coi(my.unitizer11 <- my.unitizer11 + new.exps6) items.mixed3 <- my.unitizer11@items.ref[c(4, 7)] + my.unitizer11@items.new[c(1, 7, 8)] items.sorted3 <- unitizer:::healEnvs(items.mixed3, my.unitizer11) # Both reference tests get appended to item #1, which means among other things # that for the second refernce test, the `a` object is absent (but `b` is # present because it gets sucked in by virtue of being an ignored test just # ahead of it) items <- items.sorted3 items.lst <- unitizer:::as.list(items) cbind( type = unitizer:::itemsType(items), ignored = unitizer:::ignored(items), id = vapply(items.lst, slot, 1L, "id"), call = vapply(items.lst, callDep, ""), ls = vapply(items.lst, lsObjs, ""), ls.invalid = vapply(items.lst, lsInv, TRUE) ) # - "No circular environment references" --------------------------------------- # This is to test for issue #2, which resulted in a self referential environment # in the stored items. The following code used to fail: new.exps3 <- expression(1 + 1, a <- 54, b <- 5, 2 + 2, runif(1)) ref.exps3 <- expression(1 + 1, a <- 54, 2 + 2, runif(1)) my.unitizer6 <- new("unitizer", id = 1, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer6 <- my.unitizer6 + ref.exps3) my.unitizer7 <- new("unitizer", id = 2, zero.env = new.env()) # now convert them to reference items coi(my.unitizer7 <- my.unitizer7 + my.unitizer6@items.new) # now test against new.exps coi(my.unitizer7 <- my.unitizer7 + new.exps3) # Note this doesn't test that there are no circular references, only that what # used to fail no longer fails. cbind(my.unitizer7@tests.new, my.unitizer7@tests.result) # - "testFuns" ----------------------------------------------------------------- # Error objects # these two should just work fine is(new("testFuns", output = all.equal, value = function(x, y) TRUE), "testFuns") is(new("testFuns"), "testFuns") try(new("testFuns", output = all.equal, value = function(x, y, z) TRUE)) # this should work too now, since technically has two args is( new("testFuns", output = all.equal, value = function(x, y = 1, z = 1) TRUE), "testFuns" ) try(new("testFuns", cabbage = all.equal)) # - "Misc" --------------------------------------------------------------------- new.exps4 <- expression(a <- function() b(), b <- function() TRUE, a()) my.unitizer8 <- new("unitizer", id = 3, zero.env = new.env()) new.exps5 <- expression(a <- function() b(), NULL, b <- function() TRUE, a()) my.unitizer9 <- new("unitizer", id = 4, zero.env = new.env()) coi(x <- my.unitizer9 + new.exps5) local({ fun <- function() quote(stop("This error should not be thrown")) is( new( "unitizerItem", value = fun(), call = quote(fun()), env = sys.frame(sys.parent() + 1L) ), "unitizerItem" ) }) # Nested environment hand waving can break down under certain circumstances # this first one should work because there are no tests until after all # the pieces necessary to run `a()` are defined: coi(res <- my.unitizer8 + new.exps4) is(res, "unitizer") # this should break because the NULL forces `b` to be stored in a different # environment to `a`; note: funky error message matching because in # at least some versions of rdevel reported fun name seems to change # (possibly related to level 3 bytecode) # could not find fun x@items.new[[4]]@data@message[[1]] # - "Comparison Function Errors" ----------------------------------------------- exps <- expression(fun <- function(x, y) warning("not gonna work"), unitizer_sect(compare = fun, expr = { 1 + 1 })) my.unitizer <- new("unitizer", id = 25, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer <- my.unitizer + exps) coi(my.unitizer2 <- new("unitizer", id = 26, zero.env = new.env()) + my.unitizer@items.new) # warn: not gonna work coi(my.unitizer2 <- my.unitizer2 + exps) as.character(my.unitizer2@tests.status) my.unitizer2@tests.errorDetails[[2]]@value@value # - "Language Objects Tested Properly" ----------------------------------------- exps <- expression(quote(x), quote(x + y), quote(identity(x)), expression(1 + y), quote(expression(1 + y))) my.unitizer <- new("unitizer", id = 27, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer <- my.unitizer + exps) coi(my.unitizer2 <- new("unitizer", id = 28, zero.env = new.env()) + my.unitizer@items.new) coi(my.unitizer2 <- my.unitizer2 + exps) # This used to error b/c expressions returning unevaluated calls/symbols were # not compared as such (they were evaluated) as.character(my.unitizer2@tests.status) # - "Test Fun Captured Properly" ----------------------------------------------- new("unitizerItemTestFun", fun = identical)@fun.name unitizer/tests/t-upgrade.Rout.save0000644000176200001440000003307314766101222016774 0ustar liggesusers R Under development (unstable) (2022-02-01 r81609) -- "Unsuffered Consequences" Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > blat_vers <- function(x) sub("'\\d+(?:\\.\\d+)*'", "''", x) > > # - "Upgrade works" ------------------------------------------------------------ > > # this is also now tested as part of load > unitizer <- + get_unitizer(file.path("_helper", "unitizers", "trivial.unitizer.0.4.2")) > try(validObject(unitizer, complete = TRUE)) Error in validObject(object[[x]], complete = TRUE) : invalid class "unitizerItem" object: 1: slots in class definition but not in object: "call.dep", "section.id", "section.name", "glob.indices", "state" invalid class "unitizerItem" object: 2: In slot "data" of class "unitizerItemData": invalid object for slot "value" in class "unitizerItemData": got class "logical", should be or extend class "list" > as.character(unitizer@version) [1] "0.4.2" > unitizer.up <- unitizer:::upgrade_internal(unitizer) # warning Warning in addSlot(object, "cons", NULL) : Slot `cons` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "jump.to.test", 0L) : Slot `jump.to.test` does not exist in current version of `unitizer` so not added to object. > validObject(unitizer.up) [1] TRUE > identical(unitizer.up@version, as.character(packageVersion("unitizer"))) [1] TRUE > > # - Upgrade Warnings in Unitize ------------------------------------------------ > > tdir <- tempfile() > dir.create(tdir) > dir.create(file.path(tdir, "trivial.unitizer")) > file.copy(file.path("_helper", "unitizers", "trivial.R"), tdir) [1] TRUE > file.copy( + file.path("_helper", "unitizers", "trivial.unitizer.0.4.2", "data.rds"), + file.path(tdir, "trivial.unitizer") + ) [1] TRUE > odir <- setwd(tdir) > unitizer:::read_line_set_vals('N') > out <- unitizer:::capture_output( + try(unitize(file.path(tdir, "trivial.R"), interactive.mode=TRUE)) + ) > out[] <- lapply(out, blat_vers) > out - Output ----------------------------------------------------------------------- | | The following unitizer will be upgraded to version '': | | - trivial.unitizer (at '') unitizer> N - Message ---------------------------------------------------------------------- Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in addSlot(object, "cons", NULL) : Slot `cons` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "jump.to.test", 0L) : Slot `jump.to.test` does not exist in current version of `unitizer` so not added to object. Warning in load_unitizers(store.ids[active], test.files[active], par.frame = util.frame, : Upgraded test file does not match original test file ('NA' vs 'trivial.R'). | unitizer upgrades are IRREVERSIBLE and not backwards compatible. | Proceed? Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : Cannot proceed without upgrading unitizers. > > unitizer:::read_line_set_vals(c('Y','Q')) > out <- unitizer:::capture_output( + unitize(file.path(tdir, "trivial.R"), interactive.mode=TRUE) + ) > out[] <- lapply(out, blat_vers) > out - Output ----------------------------------------------------------------------- | | The following unitizer will be upgraded to version '': | | - trivial.unitizer (at '') unitizer> Y +------------------------------------------------------------------------------+ | unitizer for: trivial.R | +------------------------------------------------------------------------------+ Pass Fail New 1 - 3 ........................... 1 - 3 - New -------------------------------------------------------------------------- | The 3 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? > x <- 1 + 1 > x + 2 [1] 4 unitizer> Q | unitizer unchanged. - Message ---------------------------------------------------------------------- Warning in addSlot(object, "cons", NULL) : Slot `cons` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "jump.to.test", 0L) : Slot `jump.to.test` does not exist in current version of `unitizer` so not added to object. Warning in load_unitizers(store.ids[active], test.files[active], par.frame = util.frame, : Upgraded test file does not match original test file ('NA' vs 'trivial.R'). | unitizer upgrades are IRREVERSIBLE and not backwards compatible. | Proceed? | No changes recorded. > unitizer:::read_line_set_vals(NULL) > setwd(odir) > unlink(tdir, recursive=TRUE) > > # - Upgrade Multiple Unitizers Unitize ----------------------------------------- > > tdir <- tempfile() > dir.create(tdir) > dir.create(file.path(tdir, "trivial1.unitizer")) > dir.create(file.path(tdir, "trivial2.unitizer")) > file.copy( + file.path("_helper", "unitizers", "trivial.R"), + file.path(tdir, c("trivial1.R", "trivial2.R")) + ) [1] TRUE TRUE > file.copy( + file.path("_helper", "unitizers", "trivial.unitizer.0.4.2", "data.rds"), + file.path(tdir, "trivial1.unitizer") + ) [1] TRUE > file.copy( + file.path("_helper", "unitizers", "trivial.unitizer.0.4.2", "data.rds"), + file.path(tdir, "trivial2.unitizer") + ) [1] TRUE > odir <- setwd(tdir) > unitizer:::read_line_set_vals(c('Y','Q')) > out <- unitizer:::capture_output( + unitize_dir(tdir, interactive.mode=TRUE) + ) > out[] <- lapply(out, blat_vers) > out - Output ----------------------------------------------------------------------- | | The following unitizers will be upgraded to version '': | | - trivial1.unitizer (at '') | - trivial2.unitizer (at '') unitizer> Y | Summary of files in common directory '.': | | Pass Fail New | *1. trivial1.R 1 - 3 | *2. trivial2.R 1 - 3 | .............................. | 2 - 6 | Legend: | * `unitizer` requires review | Type number of unitizer to review, 'A' to review all that require review unitizer> Q - Message ---------------------------------------------------------------------- Warning in addSlot(object, "cons", NULL) : Slot `cons` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "jump.to.test", 0L) : Slot `jump.to.test` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "cons", NULL) : Slot `cons` does not exist in current version of `unitizer` so not added to object. Warning in addSlot(object, "jump.to.test", 0L) : Slot `jump.to.test` does not exist in current version of `unitizer` so not added to object. Warning in load_unitizers(store.ids[active], test.files[active], par.frame = util.frame, : Upgraded test file does not match original test file ('NA' vs 'trivial1.R'). Warning in load_unitizers(store.ids[active], test.files[active], par.frame = util.frame, : Upgraded test file does not match original test file ('NA' vs 'trivial2.R'). | unitizer upgrades are IRREVERSIBLE and not backwards compatible. | Proceed? > unitizer:::read_line_set_vals(NULL) > setwd(odir) > unlink(tdir, recursive=TRUE) > > # - "Rename" ------------------------------------------------------------------- > > setClass("untzUpgrTest", slots = c(a = "character")) > x <- new("untzUpgrTest", a = letters) > validObject(x) [1] TRUE > setClass("untzUpgrTest", slots = c(b = "character")) > try(validObject(x)) Error in validObject(x) : invalid class "untzUpgrTest" object: slots in class definition but not in object: "b" > try(capture.output(unitizer:::renameSlot(x, "c", "b"), type = "message")) Error in unitizer:::renameSlot(x, "c", "b") : Old slot `c` doesn't exist in object > x.rename <- unitizer:::renameSlot(x, "a", "b") > validObject(x.rename) [1] TRUE > > # - "Later but valid version" -------------------------------------------------- > > test.file <- file.path(TMP.DIR, "tests.R") > cat("1 + 1", file = test.file) > unitizer:::capture_output(unitize(test.file, auto.accept = "new")) > version <- unlist(strsplit(as.character(packageVersion("unitizer")), + ".", fixed = TRUE)) > version[1] <- as.character(as.numeric(version[1]) + 1) > version.new <- paste0(version, collapse = ".") > unitizer.rds <- readRDS(file.path(TMP.DIR, "tests.unitizer", "data.rds")) > unitizer.rds@version <- version.new > # this should work > !nchar(unitizer:::unitizer_valid(unitizer.rds)) [1] TRUE > # now lets cause an error > unitizer.rds@eval.time <- runif(5) > grepl("NB: ", unitizer:::unitizer_valid(unitizer.rds)) [1] TRUE > > # - "Failing Test w/ Upgrade" -------------------------------------------------- > > # Unitizer will fail, but also requires an upgrade. This ensures the failure is > # shown despite the need for an upgrade. > tdir <- tempfile() > dir.create(tdir) > dir.create(file.path(tdir, "fail-and-upgrade.unitizer")) > file.copy(file.path("_helper", "unitizers", "fail-and-upgrade.R"), tdir) [1] TRUE > file.copy( + file.path("_helper", "unitizers", "fail-and-upgrade.unitizer", "data.rds"), + file.path(tdir, "fail-and-upgrade.unitizer") + ) [1] TRUE > odir <- setwd(tdir) > try(unitize(file.path("fail-and-upgrade.R"))) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. +------------------------------------------------------------------------------+ | unitizer for: fail-and-upgrade.R | +------------------------------------------------------------------------------+ Pass Fail - 1 ...................... - 1 - Failed ----------------------------------------------------------------------- | The following test failed because the new evaluation does not match the | reference value from the store. Overwrite with new result ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? # fails with newer versions of unitizer so we can make sure upgrade shows error # and doesn't just gag at the upgrade prompt > packageVersion("unitizer") < "1.4.15" [1] FALSE | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] TRUE > [1] FALSE | State mismatch; see `.DIFF$state` for details. | User input required to proceed, but we are in non-interactive mode. | unitizer unchanged. | * Fail: packageVersion("unitizer") < "1.4.15" | in 'fail-and-upgrade.R' | Newly evaluated tests do not match unitizer (Fail: 1); see above for more | info, or run in interactive mode. Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : Cannot proceed in non-interactive mode. > > # Confirm upgrade needed > capture.output(unitizer:::read_line_set_vals(c('Y', 'Q'))) character(0) > out <- unitizer:::capture_output( + unitize(file.path("fail-and-upgrade.R"), interactive.mode=TRUE) + ) > out[] <- lapply(out, blat_vers) > out - Output ----------------------------------------------------------------------- | | The following unitizer will be upgraded to version '': | | - fail-and-upgrade.unitizer (at '') unitizer> Y +------------------------------------------------------------------------------+ | unitizer for: fail-and-upgrade.R | +------------------------------------------------------------------------------+ Pass Fail - 1 ...................... - 1 - Failed ----------------------------------------------------------------------- | The following test failed because the new evaluation does not match the | reference value from the store. Overwrite with new result ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? # fails with newer versions of unitizer so we can make sure upgrade shows error # and doesn't just gag at the upgrade prompt > packageVersion("unitizer") < "1.4.15" [1] FALSE | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] TRUE > [1] FALSE | State mismatch; see `.DIFF$state` for details. unitizer> Q | unitizer unchanged. - Message ---------------------------------------------------------------------- | unitizer upgrades are IRREVERSIBLE and not backwards compatible. | Proceed? | No changes recorded. > > unitizer:::read_line_set_vals(NULL) > setwd(odir) > unlink(tdir, recursive=TRUE) > > > proc.time() user system elapsed 2.109 0.142 2.278 unitizer/tests/t-text.Rout.save0000644000176200001440000003445014766101222016331 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "cap_first" ---------------------------------------------------------------- > > set.seed(1, "Mersenne-Twister") > words <- replicate(2, paste0(sample(letters, 5), collapse = "")) > WORDS <- toupper(words) > > unitizer:::cap_first(c("", letters[1:2], letters[25:26], words, WORDS)) [1] "" "A" "B" "Y" "Z" "Gjnue" "Xzpob" "GJNUE" "XZPOB" > > unitizer:::decap_first(c("", letters[1:2], letters[25:26], words, WORDS)) [1] "" "a" "b" "y" "z" "gjnue" "xzpob" "gJNUE" "xZPOB" > > # - "header" ------------------------------------------------------------------- > > try(unitizer:::header("hello world", letters)) Error in unitizer:::header("hello world", letters) : Argument `level` must be 1 length integer-like and in 1:3 > try(unitizer:::header(letters, 1)) Error in unitizer:::header(letters, 1) : Argument `x` must be a one length character vector > > # - "word_wrap" ---------------------------------------------------------------- > > lorem1 <- "Today, with Kiernan on the stand offering confirmation, Howard walked the jury through the enormous amount of data pulled from Ulbricht's computer. Defense lawyers haven't had a chance yet to respond to this evidence—that will likely come tomorrow. The mountain they have to climb looks higher than ever, though. Last week, Ulbricht's lawyer outlined a defense in which Ulbricht walked away from the marketplace he created and was \"lured back.\" But what will explain the dozens of folders of data on this laptop, with data from the upper echelons of Silk Road management—mixed with the most intimate details of Ulbricht's personal life?" > lorem2 <- "/Volumes/FIXED/folder1/folder2/folder.2345/folderabac/file.text.batch" > lorem3 <- "\"untz.state.test\", \"add.smooth\", \"bitmapType\", \"browser\", \"browserNLdisabled\", \"CBoundsCheck\", \"check.bounds\", \"citation.bibtex.max\", \"continue\", \"contrasts\"" > range(nchar(head(unitizer:::word_wrap(lorem1, 25L), -1L))) [1] 18 25 > t.rn <- range(nchar(head(unitizer:::word_wrap(lorem1, 25L, 3L), + -1L))) > # for some reason can't get test to produce same thing in windows when > # running all tests vs. single one at the prompt; the > 20 is a cop-out that > # should catch both the expected case (23) and what actually happens when > # you run the tests on windows > # expect_true(min(t.rn) > 20 && max(t.rn) <= 25) > min(t.rn) > 20 && max(t.rn) <= 25 [1] TRUE > > unitizer:::word_wrap(substr(lorem1, 1, 147), 45L, 3L) [1] "Today, with Kiernan on the stand offering co-" [2] "nfirmation, Howard walked the jury through " [3] "the enormous amount of data pulled from Ulb-" [4] "richt's computer." > unitizer:::word_wrap(substr(lorem1, 1, 147), 45L, 3L, FALSE) [1] "Today, with Kiernan on the stand offering con" [2] "firmation, Howard walked the jury through the" [3] "enormous amount of data pulled from Ulbricht'" [4] "s computer." > unitizer:::word_wrap(lorem2, 15L, 3L) [1] "/Volumes/FIXED/" "folder1/fol-" "der2/folder.23-" "45/folderabac/" [5] "file.text.batch" > unitizer:::word_wrap(lorem2, 15L, 8L) [1] "/Volumes/FIXED/" "folder1/" "folder2/folder." "2345/fol-" [5] "derabac/file." "text.batch" > > unitizer:::word_wrap(lorem3, 76L, 8L) [1] "\"untz.state.test\", \"add.smooth\", \"bitmapType\", \"browser\", \"browserNLdisab-" [2] "led\", \"CBoundsCheck\", \"check.bounds\", \"citation.bibtex.max\", \"continue\", " [3] "\"contrasts\"" > unitizer:::word_wrap("hello sunset \nthere moonrise", width = 12L) [1] "hello sunset" "there " "moonrise" > > x1 <- c("this is supposed to be a particularly long string\nthat allows us to test the behavior of bullets once we start seeing\nsome wrapping kicking in which was a problem once upon a time") > > unitizer:::word_wrap(x1, unlist = FALSE, width = 80L) [[1]] [1] "this is supposed to be a particularly long string" [2] "that allows us to test the behavior of bullets once we start seeing" [3] "some wrapping kicking in which was a problem once upon a time" > com <- "# this is supposed to be a relatively long comment that will get re-flowed" > old.opt <- options(crayon.enabled = FALSE) > unitizer:::word_comment(com, width = 30L) [1] "# this is supposed to be a " "#relatively long comment that " [3] "#will get re-flowed" > unitizer:::word_wrap(c("\nhello\nthere", "\nhow")) [1] "" "hello" "there" "" "how" > # too narrow > no.wrap <- "hello I won't be wrapped" > unitizer:::word_wrap(no.wrap, width = 3) # warning Warning in unitizer:::word_wrap(no.wrap, width = 3) : Display width too narrow to properly wrap text; setting to 80L [1] "hello I won't be wrapped" > options(old.opt) > > # - "bullets" ------------------------------------------------------------------ > > x <- c("there was once a time when the fantastic unicorns could fly", + "bugs bunny ate carrots and drank milk while hunting ducks") > xx <- unitizer:::UL(x) > > as.character(xx, width = 30L) [1] "- there was once a time when " " the fantastic unicorns could" [3] " fly" "- bugs bunny ate carrots and " [5] " drank milk while hunting " " ducks" > print(xx, width = 80L) - there was once a time when the fantastic unicorns could fly - bugs bunny ate carrots and drank milk while hunting ducks > yy <- unitizer:::OL(x) > as.character(yy, width = 30L) [1] "1. there was once a time when " " the fantastic unicorns " [3] " could fly" "2. bugs bunny ate carrots and " [5] " drank milk while hunting " " ducks" > # hopefully always C locale collation in tests? > sort(as.character(unitizer:::OL(rep(letters, 2), style = "LETTERS"))) [1] " A. a" " B. b" " C. c" " D. d" " E. e" " F. f" " G. g" " H. h" " I. i" [10] " J. j" " K. k" " L. l" " M. m" " N. n" " O. o" " P. p" " Q. q" " R. r" [19] " S. s" " T. t" " U. u" " V. v" " W. w" " X. x" " Y. y" " Z. z" "AA. a" [28] "AB. b" "AC. c" "AD. d" "AE. e" "AF. f" "AG. g" "AH. h" "AI. i" "AJ. j" [37] "AK. k" "AL. l" "AM. m" "AN. n" "AO. o" "AP. p" "AQ. q" "AR. r" "AS. s" [46] "AT. t" "AU. u" "AV. v" "AW. w" "AX. x" "AY. y" "AZ. z" > xl <- as.list(x) > y <- unitizer:::UL(c(xl, list(unitizer:::OL(c(xl, list(unitizer:::UL(x))))), + "yowza it is raining toads today!")) > as.character(y, width = 30) [1] "- there was once a time when " " the fantastic unicorns could" [3] " fly" "- bugs bunny ate carrots and " [5] " drank milk while hunting " " ducks" [7] " 1. there was once a time " " when the fantastic " [9] " unicorns could fly" " 2. bugs bunny ate carrots " [11] " and drank milk while " " hunting ducks" [13] " - there was once a time " " when the fantastic " [15] " unicorns could fly" " - bugs bunny ate carrots " [17] " and drank milk while " " hunting ducks" [19] "- yowza it is raining toads " " today!" > try(unitizer:::as.character.bullet(hello, 1:10)) Error in unitizer:::as.character.bullet(hello, 1:10) : Argument `width` must be a one length positive numeric. > # Extra args to word_wrap > try(as.character(unitizer:::OL(c("hello", "there")), unlist = TRUE)) Error in as.character.bullet(unitizer:::OL(c("hello", "there")), unlist = TRUE) : You may not specify `unlist` as part of `...` as that argument is used internally > as.character(unitizer:::OL("asdfasdfqwerjhdfkasdfasdfasd"), width = 20L) [1] "1. asdfasdfqwerjhdf-" " kasdfasdfasd" > as.character(unitizer:::OL("asdfasdfqwerjhdfkasdfasdfasd"), width = 20L, + hyphens = FALSE) [1] "1. asdfasdfqwerjhdfk" " asdfasdfasd" > > # - "substr_const" ------------------------------------------------------------- > > unitizer:::substr_cons(c("ab", "abcde", "abce"), 4L) [1] "ab " "abcd" "abc " > unitizer:::substr_cons(c("ab", "abcde", "abce"), 4L, justify = "right") [1] " ab" "abcd" " abc" > unitizer:::substr_cons(c("NEW", "PASS", "FAIL", "DELETED", "Error"), 4L) [1] "NEW " "PASS" "FAIL" "DEL " "Err " > > # - "str_reduce_unique" -------------------------------------------------------- > > str1 <- c("abcdef", "abcdefgh", "abcql") > res1 <- c("def", "defgh", "ql") > unitizer:::str_reduce_unique(str1) [1] "def" "defgh" "ql" > unitizer:::str_reduce_unique(str1, from = "right") [1] "abcdef" "abcdefgh" "abcql" > str2 <- vapply(strsplit(str1, ""), function(x) paste0(rev(x), + collapse = ""), "") > res2 <- vapply(strsplit(res1, ""), function(x) paste0(rev(x), + collapse = ""), "") > all.equal(unitizer:::str_reduce_unique(str2, from = "right"), res2) [1] TRUE > unitizer:::str_reduce_unique("aaa") [1] "" > identical(unitizer:::str_reduce_unique(rep("aaa", 5L)), rep("", 5L)) [1] TRUE > > # - "strtrunc" ----------------------------------------------------------------- > > str1 <- c(paste0(letters, collapse = ""), paste0(LETTERS, collapse = "")) > unitizer:::strtrunc(str1, 10L) [1] "abcdefg..." "ABCDEFG..." > unitizer:::strtrunc(str1, 10L, from = "left") [1] "...tuvwxyz" "...TUVWXYZ" > unitizer:::strtrunc(c("abc", "cab"), 3L) [1] "abc" "cab" > try(unitizer:::strtrunc(c("abc", "cab"), 2L)) Error in unitizer:::strtrunc(c("abc", "cab"), 2L) : `nchar.max` too small, make bigger or make `ctd` shorter. > > # - "oneline" ------------------------------------------------------------------ > > dep <- c("res <- data %>% group_by(ID) %>% summarise(date2 = nth(date, ", + " 2), time2 = nth(time, 2), first_date = first(date), last_date = last(date), ", + " first_time = first(time), last_time = last(time))") > unitizer:::one_line(dep) [1] "res <- data %>% group_by(ID) %>% summarise(date2 = nth(date, 2), time2 = nth(time, 2), first_date = first(date), last_date = last(date), first_time = first(time), last_time = last(time))" > unitizer:::one_line(dep, 50) [1] "res <- data %>% group_by(ID) %>% summarise(date..." > > # - "let_comb_fun" ------------------------------------------------------------- > > (unitizer:::make_let_combn_fun(letters))(12) [1] "a." "b." "c." "d." "e." "f." "g." "h." "i." "j." "k." "l." > > # - "cc" ----------------------------------------------------------------------- > > unitizer:::cc("a", "b") [1] "ab" > unitizer:::cc(c("a", "b"), "c") [1] "abc" > unitizer:::cc(c("a", "b"), "c", c = " ") [1] "a b c" > > # - "screen_out" --------------------------------------------------------------- > > string <- "once upon a time in a fairy land very far away lived a green dragon" > unitizer:::screen_out(string, max.len = c(3L, 2L), width = 13L) once upon a time in a ... truncated 4 lines > > # - "text_wrap" ---------------------------------------------------------------- > > try(unitizer:::text_wrap(list(1, 2, 3), 5)) Error in unitizer:::text_wrap(list(1, 2, 3), 5) : Arguments `x` and `width` must be character and integer like (all values >= 1) respectively > try(unitizer:::text_wrap(letters, 1:3)) Error in unitizer:::text_wrap(letters, 1:3) : Argument `x` must be a multiple in length of argument `width` > > # - "capture_output" ----------------------------------------------------------- > > capt <- unitizer:::capture_output({ + cat("hello") + cat("goodbye", file = stderr()) + }) > capt - Output ----------------------------------------------------------------------- hello - Message ---------------------------------------------------------------------- goodbye > sum(grepl("Output|Message", capture.output(print(capt)))) [1] 2 > > # - "meta_word_cat" ------------------------------------------------------------ > > unitizer:::meta_word_cat("hello") | hello > capture.output(unitizer:::meta_word_cat("hello", trail.nl = FALSE)) [1] "| hello" > # Newline issues > unitizer:::meta_word_cat("hello\n", sep = "") | hello > unitizer:::meta_word_cat("hello", "there") | hello | there > unitizer:::meta_word_cat("hello", "there", sep = " ") | hello there > > # - "meta_word_msg" ------------------------------------------------------------ > > unitizer:::meta_word_msg("hello") | hello > txt <- "hello there how are you this wraps" > unitizer:::meta_word_msg(txt, width = 20) | hello there how | are you this wraps > # legacy fun > unitizer:::word_msg("hello") hello > > # - "desc" --------------------------------------------------------------------- > > obj1 <- list(a = iris, b = lm(dist ~ speed, cars), 1:10, matrix(letters, + 2)) > desc(obj1, 80) [1] "list(a=data.frame[150,5], b=lm[12], int[10], chr mat[2,13])" > desc(obj1, 40) [1] "list[4]" > desc(iris, 80) [1] "data.frame[150,5]" > desc(iris, 200) [1] "data.frame(Sepal.Length=num[150], Sepal.Width=num[150], Petal.Length=num[150], Petal.Width=num[150], Species=fct[150])" > desc(list(NULL, 1L)) [1] "list(NULL, int[1])" > desc(NULL) [1] "NULL" > unitizer:::desc(NULL) [1] "NULL" > unitizer:::desc(lm(y ~ x, data.frame(y = 1:10, x = runif(10)))) [1] "lm[12]" > unitizer:::desc(new("unitizerItem", call = quote(1 + 1), env = new.env())) [1] "unitizerItem" > unitizer:::desc(array(1:27, dim = rep(3, 3))) [1] "array[3,3,3]" > unitizer:::desc(data.frame(a = letters[1:10], b = 1:10, stringsAsFactors = TRUE)) [1] "data.frame(a=fct[10], b=int[10])" > > # - "char_to_eng" -------------------------------------------------------------- > > unitizer:::char_to_eng(character(), "", "") [1] "" > unitizer:::char_to_eng(letters[1:4], "", "") [1] "a, b, c, and d" > unitizer:::char_to_eng(letters[1:2], "", "") [1] "a, and b" > unitizer:::char_to_eng(letters[1], "", "") [1] "a" > unitizer:::char_to_eng(letters[1]) [1] "a was" > unitizer:::char_to_eng(letters[1:2]) [1] "a, and b were" > > > proc.time() user system elapsed 1.12 0.16 2.27 unitizer/tests/t-misc.Rout.save0000644000176200001440000006435614766101222016310 0ustar liggesusers R Under development (unstable) (2022-01-01 r81419) -- "Unsuffered Consequences" Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") > > # - "Text wrapping" ------------------------------------------------------------ > > var <- "humpty dumpty sat on a truck and had a big dump" > # expect_true(all(nchar(unlist(unitizer:::text_wrap(var, 10))) <= > writeLines(unlist(unitizer:::text_wrap(var, 10))) humpty dum pty sat on a truck a nd had a b ig dump > all(nchar(unlist(unitizer:::text_wrap(var, 10))) <= 10) [1] TRUE > > var2 <- rep(var, 4) > # expect_true(all(nchar(wrp <- unlist(unitizer:::text_wrap(var2, > # c(20, 15)))) <= 20) && length(wrp) == 14) > writeLines(unlist(unitizer:::text_wrap(var2, c(20, 15)))) humpty dumpty sat on a truck and had a b ig dump humpty dumpty s at on a truck a nd had a big du mp humpty dumpty sat on a truck and had a b ig dump humpty dumpty s at on a truck a nd had a big du mp > all(nchar(wrp <- unlist(unitizer:::text_wrap(var2, c(20, 15)))) <= + 20) && length(wrp) == 14 [1] TRUE > > # - "Headers" ------------------------------------------------------------------ > > # these basically require visual inspection > > unitizer:::H1("hello world") +------------------------------------------------------------------------------+ | hello world | +------------------------------------------------------------------------------+ > unitizer:::H2("hello world") = hello world ================================================================== > unitizer:::H3("hello world") - hello world ------------------------------------------------------------------ > > # cause an error > try(print(unitizer:::H1(rep_len("hello world", 10)))) Error in header(x, 1L) : Argument `x` must be a one length character vector > > h.w.long <- paste0(rep_len("hello world", 10), collapse = " ") > unitizer:::H1(h.w.long) +------------------------------------------------------------------------------+ | hello world hello world hello world hello world hello world hello world | | hello world hello world hello world hello world | +------------------------------------------------------------------------------+ > unitizer:::H2(h.w.long) = hello world hello world hello world hello world hello world hello world h... = > print(unitizer:::H2("No margin"), margin = "none") # no extra line below = No margin ==================================================================== > > # - "Valid Names convert names to valid" --------------------------------------- > > # expect_equal(unitizer:::valid_names("hello"), "hello") > unitizer:::valid_names("hello") [1] "hello" > # expect_equal(unitizer:::valid_names(".hello"), ".hello") > unitizer:::valid_names(".hello") [1] ".hello" > # expect_equal(unitizer:::valid_names("1hello"), "`1hello`") > unitizer:::valid_names("1hello") [1] "`1hello`" > # expect_equal(unitizer:::valid_names("hello kitty"), "`hello kitty`") > unitizer:::valid_names("hello kitty") [1] "`hello kitty`" > # expect_equal(unitizer:::valid_names("h3llo"), "`h3llo`") > unitizer:::valid_names("h3llo") [1] "`h3llo`" > # expect_equal(unitizer:::valid_names("h_llo"), "h_llo") > unitizer:::valid_names("h_llo") [1] "h_llo" > # expect_equal(unitizer:::valid_names("$hot"), "`$hot`") > unitizer:::valid_names("$hot") [1] "`$hot`" > # expect_equal(unitizer:::valid_names("HELLO"), "HELLO") > unitizer:::valid_names("HELLO") [1] "HELLO" > > # - "strtrunc" ----------------------------------------------------------------- > > # expect_equal(unitizer:::strtrunc("hollywood is for starlets", > # 5), "ho...") > unitizer:::strtrunc("hollywood is for starlets", 5) [1] "ho..." > # expect_error(unitizer:::strtrunc(5, "hollywood is for starlets")) > try(unitizer:::strtrunc(5, "hollywood is for starlets")) Error in unitizer:::strtrunc(5, "hollywood is for starlets") : Argument `x` must be character > > # - "environment name tools" --------------------------------------------------- > > env1 <- new.env(parent = globalenv()) > env2 <- new.env(parent = env1) > env3 <- new.env(parent = env2) > env4 <- new.env(parent = env3) > # expect_true(is.character(ename <- unitizer:::env_name(env3)) && > # identical(length(ename), 1L)) > is.character(ename <- unitizer:::env_name(env3)) && identical(length(ename), 1L) [1] TRUE > # expect_true(is.character(envanc <- unitizer:::env_ancestry(env4)) && > # identical(length(envanc), 5L) && identical(envanc[[5L]], > # "R_GlobalEnv")) > is.character(envanc <- unitizer:::env_ancestry(env4)) && + identical(length(envanc), 5L) && identical(envanc[[5L]], "R_GlobalEnv") [1] TRUE > > # - "deparse peek" ------------------------------------------------------------- > > expr1 <- quote(1 + 1 + 3) > expr2 <- quote(for (i in 1:100) { + loop.val <- sample(1:1000, 200, replace = TRUE) + loop.val <- loop.val * 200/3000 * mean(runif(20000)) + }) > # expect_equal("1 + 1 + 3", unitizer:::deparse_peek(expr1, 20L)) > unitizer:::deparse_peek(expr1, 20L) [1] "1 + 1 + 3" > > # expect_error(unitizer:::deparse_peek(expr1, 3L)) > try(unitizer:::deparse_peek(expr1, 3L)) Error in unitizer:::deparse_peek(expr1, 3L) : Argument `len` must be an integer greater than four > # expect_equal("1 ...", unitizer:::deparse_peek(expr1, 5L)) > unitizer:::deparse_peek(expr1, 5L) [1] "1 ..." > > # expect_equal("for (i in 1:100) { loop.val <- sam...", unitizer:::deparse_peek(expr2, > # 40L)) > unitizer:::deparse_peek(expr2, 40L) [1] "for (i in 1:100) { loop.val <- sam..." > > # - "deparse fun" -------------------------------------------------------------- > > # expect_identical(unitizer:::deparse_fun(quote(fun)), "fun") > unitizer:::deparse_fun(quote(fun)) [1] "fun" > # expect_identical(unitizer:::deparse_fun(quote(function(x) NULL)), > # NA_character_) > unitizer:::deparse_fun(quote(function(x) NULL)) [1] NA > # expect_identical(unitizer:::deparse_fun("hello"), character(0L)) > unitizer:::deparse_fun("hello") character(0) > > # - "deparse_prompt" ----------------------------------------------------------- > > suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) > item <- unitizer:::exec(quote(if (TRUE) { + 25 + } else { + 42 + }), new.env(), glob) > unitizer:::deparse_prompt(item) [1] "> if (TRUE) {" "+ 25" "+ } else {" "+ 42" [5] "+ }" > > # - "deparse_mixed" ------------------------------------------------------------ > > b <- setNames(1:3, letters[1:3]) > x <- quote(1 + b) > x[[3]] <- b > # expect_equal(unitizer:::deparse_mixed(x), "quote(1 + 1:3)") > unitizer:::deparse_mixed(x) [1] "quote(1 + 1:3)" > y <- quote(1 + 3 + b) > y[[3]] <- b > # expect_equal(unitizer:::deparse_mixed(y), "quote(1 + 3 + 1:3)") > unitizer:::deparse_mixed(y) [1] "quote(1 + 3 + 1:3)" > > # - "(Un)ordered Lists" -------------------------------------------------------- > > vec <- c("hello htere how are you blah blah blah blah blah", + "this is helpful you know", "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", + letters[1:10]) > > # expect_equal(as.character(unitizer:::OL(vec), width = 100L), > # c(" 1. hello htere how are you blah blah blah blah blah", > # " 2. this is helpful you know", " 3. Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut ", > # " labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco ", > # " laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in ", > # " voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat ", > # " non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", > # " 4. a", " 5. b", " 6. c", " 7. d", " 8. e", " 9. f", > # "10. g", "11. h", "12. i", "13. j")) > writeLines(as.character(unitizer:::OL(vec), width = 100L)) 1. hello htere how are you blah blah blah blah blah 2. this is helpful you know 3. Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. 4. a 5. b 6. c 7. d 8. e 9. f 10. g 11. h 12. i 13. j > > # expect_equal(as.character(unitizer:::UL(vec), width = 20L), c("- hello htere how ", > # " are you blah blah ", " blah blah blah", "- this is helpful ", > # " you know", "- Lorem ipsum dolor ", " sit amet, consec-", > # " tetur adipisicing ", " elit, sed do ", " eiusmod tempor ", > # " incididunt ut ", " labore et dolore ", " magna aliqua. Ut ", > # " enim ad minim ", " veniam, quis ", " nostrud exer-", > # " citation ullamco ", " laboris nisi ut ", " aliquip ex ea ", > # " commodo consequat.", " Duis aute irure ", " dolor in reprehen-", > # " derit in voluptate", " velit esse cillum ", " dolore eu fugiat ", > # " nulla pariatur. ", " Excepteur sint ", " occaecat cupidatat", > # " non proident, sunt", " in culpa qui ", " officia deserunt ", > # " mollit anim id est", " laborum.", "- a", "- b", "- c", > # "- d", "- e", "- f", "- g", "- h", "- i", "- j")) > > writeLines(as.character(unitizer:::UL(vec), width = 20L)) - hello htere how are you blah blah blah blah blah - this is helpful you know - Lorem ipsum dolor sit amet, consec- tetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exer- citation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehen- derit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. - a - b - c - d - e - f - g - h - i - j > > # test_that("Messing with traceback", { > # warning("Missing traceback tests") > # # Main problem with this is that there may not be a good way to cause a trace > # # back to register while not also stopping execution of this file, so not > # # sure if this can be tested > # } ) > > # - "Compare Conditions" ------------------------------------------------------- > > lst1 <- new("conditionList", .items = list(simpleWarning("warning", + quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), + simpleWarning("warning3", quote(yo3 + yo)), simpleError("error1", + quote(make_an_error())))) > lst2 <- new("conditionList", .items = list(simpleWarning("warning", + quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), + simpleError("error1", quote(make_an_error())))) > > all.equal(lst1, lst1) [1] TRUE > # expect_equal("Condition count mismatch; expected 4 (got 3)", > # all.equal(lst1, lst2)) > all.equal(lst1, lst2)# [1] "Condition count mismatch; expected 4 (got 3)" > # expect_equal("There is one condition mismatch at index [[3]]", > # all.equal(lst2, lst1[1L:3L])) > all.equal(lst2, lst1[1L:3L]) [1] "There is one condition mismatch at index [[3]]" > # expect_equal("There are 2 condition mismatches, first one at index [[1]]", > # all.equal(lst2, lst1[2L:4L])) > all.equal(lst2, lst1[2L:4L]) [1] "There are 2 condition mismatches, first one at index [[1]]" > attr(lst1[[3L]], "unitizer.printed") <- TRUE > # expect_equal("There is one condition mismatch at index [[3]]", > # all.equal(lst2, lst1[1L:3L])) > all.equal(lst2, lst1[1L:3L]) [1] "There is one condition mismatch at index [[3]]" > # expect_equal(c("Condition type mismatch, `target` is 'Error', but `current` is 'Warning'", > # "Condition mismatch may involve print/show methods; carefully review conditions with `.NEW$conditions` and `.REF$conditions` as just typing `.ref` or `.new` at the prompt will invoke print/show methods, which themselves may be the cause of the mismatch"), > # all.equal(lst2[[3]], lst1[[3]])) > all.equal(lst2[[3]], lst1[[3]]) [1] "Condition type mismatch, `target` is 'Error', but `current` is 'Warning'" [2] "Condition mismatch may involve print/show methods; carefully review conditions with `.NEW$conditions` and `.REF$conditions` as just typing `.ref` or `.new` at the prompt will invoke print/show methods, which themselves may be the cause of the mismatch" > > attr(lst1[[3L]], "unitizer.printed") <- NULL > lst1[[2L]] <- simpleWarning("warning2", quote(yo2 + yoyo)) > # This used to produce "one condition mismatch at index [[2]]", but with the > # relation of condition call comparison, no longer fails. Arguably this one > # should still fail as none of the parameters are named. > all.equal(lst2, lst1[c(1L:2L, 4L)]) [1] TRUE > > # single condition display with a more complex condition > large.cond <- simpleWarning(paste0(collapse = "\n", c("This is a complicated warning:", + as.character(unitizer:::UL(c("one warning", "two warning", + "three warning"))))), quote(make_a_warning())) > lst3 <- new("conditionList", .items = list(large.cond)) > show1 <- capture.output(show(lst3)) > all.equal(show1, rds("misc_cndlistshow1")) [1] TRUE > > attr(lst3[[1L]], "unitizer.printed") <- TRUE > lst3[[2L]] <- simpleWarning("warning2", quote(yo2 + yoyo)) > lst3 Condition list with 2 conditions: 1. [print] Warning in make_a_warning() : This is a complicated warning: - one warning - two warning - three warning 2. Warning in yo2 + yoyo : warning2 [print] means condition was issued by a print or show method for an auto-printed result. > > # empty condition > lst3[0] Empty condition list > > # Conditions with mismatched calls (due to instability in call generation for C > # errors issue285) > lst4a <- new("conditionList", + .items = list( + simpleWarning("A", quote(fun(a=b, c=d))), + simpleWarning("B", quote(fun(a=b, c=d))), + simpleWarning("C", quote(fun(a=b, c=d))), + simpleWarning("D", quote(fun(a, c=d))), + simpleWarning("E", quote(fun())), + simpleWarning("F"), + simpleWarning("G", quote(fun(a=b, c=d))), + simpleWarning("H", quote(fun(a=b, c=d))), + simpleWarning("I", quote(foo(a=b, c=d))) + )) > lst4b <- new("conditionList", + .items = list( + simpleWarning("A", quote(fun(a=b, c=d))), + simpleWarning("B", quote(fun(a=B, c=d))), + simpleWarning("C", quote(fun(b, c=d))), + simpleWarning("D", quote(fun(a=b, c=d))), + simpleWarning("E", quote(fun(a=b, c=d))), + simpleWarning("F", quote(fun(a=b, c=d))), + simpleWarning("G"), + simpleWarning("H", quote(fun())), + simpleWarning("I", quote(bar(a=b, c=d))) + )) > all.equal(lst4a, lst4b) [1] "There are 2 condition mismatches, first one at index [[2]]" > all.equal(lst4a[c(2, 9)], lst4b[c(2, 9)]) [1] "There are 2 condition mismatches, first one at index [[1]]" > > # - "Compare Functions With Traces" -------------------------------------------- > > fun.a <- base::library > identical(fun.a, base::library) [1] TRUE > trace(library, where = .BaseNamespaceEnv) Tracing function "library" in package "namespace:base" [1] "library" > identical(fun.a, base::library) # FALSE [1] FALSE > unitizer:::identical_fun(fun.a, base::library) [1] TRUE > unitizer:::identical_fun(base::library, fun.a) # FALSE [1] FALSE > untrace(library, where = .BaseNamespaceEnv) Untracing function "library" in package "namespace:base" > # expect_error(unitizer:::identical_fun(1, base::library)) > try(unitizer:::identical_fun(1, base::library)) Error in unitizer:::identical_fun(1, base::library) : Arguments `x` and `y` must both be functions. > # expect_error(unitizer:::identical_fun(base::library, 1)) > try(unitizer:::identical_fun(base::library, 1)) Error in unitizer:::identical_fun(base::library, 1) : Arguments `x` and `y` must both be functions. > unitizer:::identical_fun(base::print, base::print) [1] TRUE > # make sure all.equal dispatches properly out of namespace > > # expect_equal(evalq(all.equal(new("conditionList", .items = list(simpleWarning("warning", > # quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), > # simpleWarning("warning3", quote(yo3 + yo)), simpleError("error1", > # quote(make_an_error())))), new("conditionList", .items = list(simpleWarning("warning", > # quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), > # simpleError("error1", quote(make_an_error()))))), envir = getNamespace("stats")), > # "Condition count mismatch; expected 4 (got 3)") > evalq(all.equal(new("conditionList", .items = list(simpleWarning("warning", + quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), + simpleWarning("warning3", quote(yo3 + yo)), simpleError("error1", + quote(make_an_error())))), new("conditionList", .items = list(simpleWarning("warning", + quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), + simpleError("error1", quote(make_an_error()))))), envir = getNamespace("stats")) [1] "Condition count mismatch; expected 4 (got 3)" > > # - "word_cat" ----------------------------------------------------------------- > > str <- "Humpty dumpty sat on a wall and took a big fall. All the kings horses and men couldn't put humpty dumpty together again" > # expect_equal(capture.output(unitizer:::word_cat(str, width = 20L)), > # c("Humpty dumpty sat on", "a wall and took a ", "big fall. All the ", > # "kings horses and men", "couldn't put humpty ", "dumpty together ", > # "again")) > unitizer:::word_cat(str, width = 20L) Humpty dumpty sat on a wall and took a big fall. All the kings horses and men couldn't put humpty dumpty together again > # expect_error(unitizer:::word_cat(stop("boom"), width = 20L, sep = " "), > # "boom") > try(unitizer:::word_cat(stop("boom"), width = 20L, sep = " ")) Error in word_wrap_split(..., width = width, tolerance = tolerance, sep = sep) : boom > str2 <- rep("goodbye goodbye") > str1 <- rep("hello hello hello", 2) > # expect_equal(c("hello hello ", "hello hello ", "hello hello ", > # "goodbye ", "goodbye"), capture.output()) > unitizer:::word_cat(str1, str2, width = 14L) hello hello hello hello hello hello goodbye goodbye > > # Make sure default works > old.width <- options(width = 20L) > # expect_equal(capture.output(unitizer:::word_cat(str)), c("Humpty dumpty sat on", > # "a wall and took a ", "big fall. All the ", "kings horses and men", > # "couldn't put humpty ", "dumpty together ", "again")) > unitizer:::word_cat(str) Humpty dumpty sat on a wall and took a big fall. All the kings horses and men couldn't put humpty dumpty together again > options(old.width) > > # - "relativize_path" ---------------------------------------------------------- > > base <- file.path(system.file(package = "unitizer"), "expkg") > wd <- file.path(base, "infer") > p1 <- file.path(wd, "R") > p2 <- file.path(base, "unitizerdummypkg1") > # expect_equal(unitizer:::relativize_path(p1, wd), "R") > unitizer:::relativize_path(p1, wd) [1] "R" > # expect_equal(unitizer:::relativize_path(p2, wd), "../unitizerdummypkg1") > unitizer:::relativize_path(p2, wd) [1] "../unitizerdummypkg1" > # expect_equal(unitizer:::relativize_path(c(p1, p2), wd), c("R", > # "../unitizerdummypkg1")) > unitizer:::relativize_path(c(p1, p2), wd) [1] "R" "../unitizerdummypkg1" > # expect_equal(unitizer:::relativize_path(c(p1, p2), wd), c("R", > # "../unitizerdummypkg1")) > unitizer:::relativize_path(c(p1, p2), wd) [1] "R" "../unitizerdummypkg1" > # expect_equal(unitizer:::relativize_path(c(p1, p2, file.path("notarealpath", > # "foo")), wd), c("R", "../unitizerdummypkg1", file.path("notarealpath", > # "foo"))) > unitizer:::relativize_path( + c(p1, p2, file.path("notarealpath", "foo")), wd + ) [1] "R" "../unitizerdummypkg1" "notarealpath/foo" > # expect_equal(unitizer:::relativize_path("/a/b/c/d/e/x.txt"), > # "/a/b/c/d/e/x.txt") > unitizer:::relativize_path("/a/b/c/d/e/x.txt", exists = TRUE) [1] "/a/b/c/d/e/x.txt" > # ## This was too difficult to get to behave consistently across windows and > # ## other platforms (see docs) > # wd <- sub("^[a-zA-Z]:", "", getwd()) > # all.equal( > # unitizer:::relativize_path( > # "/a/b/c/d/e/x.txt", only.if.shorter = FALSE, exists = TRUE > # ), > # do.call( > # file.path, > # c( > # as.list( > # rep( > # "..", > # length(unlist(strsplit(wd, .Platform$file.sep, fixed = TRUE))) - > # 1L > # ) ), > # list("a/b/c/d/e/x.txt") > # ) ) ) > > # - "path_clean" --------------------------------------------------------------- > > try(unitizer:::path_clean(list())) Error in unitizer:::path_clean(list()) : Argument `path` must be character > unitizer:::path_clean(file.path("a", "", "b", "c")) [1] "a/b/c" > > # - "unitizer:::merge_lists" --------------------------------------------------- > > unitizer:::merge_lists(list(a = 1, b = 2), list(c = 3)) $a [1] 1 $b [1] 2 $c [1] 3 > unitizer:::merge_lists(list(a = 1, b = 2, c = 3), list(d = 5, c = 5)) $a [1] 1 $b [1] 2 $c [1] 5 $d [1] 5 > unitizer:::merge_lists(list(a = 1, b = 2, c = 3), list(a = NULL, d = 5, c = 5)) $a NULL $b [1] 2 $c [1] 5 $d [1] 5 > > # - "filename to storeid" ------------------------------------------------------ > > filename_to_storeid("tests.R") [1] "tests.unitizer" > filename_to_storeid("tests.rock") Warning in filename_to_storeid("tests.rock") : Unable to translate file name 'tests.rock' to `store.id` because it does not match regex '\.[rR]$', please provide explicit `store.id` or rename to end in '.R'. Returning in NULL for `store.id`. NULL > > # - "pretty_path" -------------------------------------------------------------- > # not supposed to exist > res <- unitizer:::pretty_path("xadfasdfxcfasdfasd") # warn > > if(FALSE) { + # "fails CRAN" + # expect_identical(res, "xadfasdfxcfasdfasd") + res + unitizer:::pretty_path(normalizePath(".")) + unitizer:::pretty_path(file.path(system.file(package = "stats"), + "DESCRIPTION")) + } > # - "quit" --------------------------------------------------------------------- > > # for some reason cover tests run via travis can't handle the with_mock, > # so we just use truly-quit=FALSE; UPDATE (mabye du to compiler?) > # with_mock( > # quit=function(...) stop("quit!\n"), { > # unitizer:::read_line_set_vals("y") > # expect_error(capture.output(unitizer:::unitizer_quit()), "quit!") > # unitizer:::read_line_set_vals("n") > # capture.output(uq2 <- unitizer:::unitizer_quit()) > # expect_equal(uq2, NULL) > # unitizer:::read_line_set_vals(c("q", "q", "q", "q", "q", "q")) > # expect_error(capture.output(unitizer:::unitizer_quit()), "quit!") > # } > # ) > unitizer:::read_line_set_vals("y") > capture.output(q.res.1 <- unitizer:::unitizer_quit(truly.quit = FALSE)) | You are attempting to quit R from within `unitizer`. If you do so | you will lose any unsaved `unitizers`. Use `Q` to quit `unitizer` | gracefully. Are you sure you want to exit R? [1] "Quit R? [y/n]: y" > q.res.1 [1] TRUE > unitizer:::read_line_set_vals("n") > capture.output(q.res.2 <- unitizer:::unitizer_quit(truly.quit = FALSE)) | You are attempting to quit R from within `unitizer`. If you do so | you will lose any unsaved `unitizers`. Use `Q` to quit `unitizer` | gracefully. Are you sure you want to exit R? [1] "Quit R? [y/n]: n" > q.res.2 # FALSE [1] FALSE > unitizer:::read_line_set_vals(c("q", "q", "q", "q", "q", "q")) > capture.output(q.res.3 <- unitizer:::unitizer_quit(truly.quit = FALSE)) | You are attempting to quit R from within `unitizer`. If you do so | you will lose any unsaved `unitizers`. Use `Q` to quit `unitizer` | gracefully. Are you sure you want to exit R? | Sorry, could not understand you, quitting then. [1] "Quit R? [y/n]: q" "Quit R? [y/n]: q" "Quit R? [y/n]: q" "Quit R? [y/n]: q" [5] "Quit R? [y/n]: q" "Quit R? [y/n]: q" > q.res.3 [1] TRUE > unitizer:::read_line_set_vals(NULL) > > # - "mock_item" ---------------------------------------------------------------- > > is(mock_item(), "unitizerItem") [1] TRUE > > # - "diff conditionList" ------------------------------------------------------- > > cond1 <- new("conditionList", .items = list(simpleWarning("hello", + call = quote(fun())), simpleWarning("goodbye", call = quote(fun())))) > is(diffobj::diffObj(cond1, cond1), "Diff") [1] TRUE > > # - "Condition object structure" ----------------------------------------------- > > # We're assuming a particular structure for the condition object in > # `faux_prompt` and `unitizer_prompt` so we put in a test here to make sure it > # doesn't change > cond <- simpleError("hello") > is.list(cond) [1] TRUE > identical(names(cond), c("message", "call")) [1] TRUE > identical(class(cond), c("simpleError", "error", "condition")) [1] TRUE > > # - "options" ------------------------------------------------------------------ > > # not great tests... > > old.opts <- options() > new.opts <- unitizer:::options_zero() > > all(names(new.opts) %in% names(old.opts)) [1] TRUE > length(new.opts) <= length(old.opts) [1] TRUE > options(old.opts) > > unitizer/tests/t-repairenvs.Rout.save0000644000176200001440000001275214766101401017523 0ustar liggesusers R version 4.3.2 (2023-10-31) -- "Eye Holes" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin20 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > exps <- expression(1 + 1, a <- 54, b <- 38, a + b, e <- 5 * a, + a^2, f <- e * a, matrix(rep(f, 20))) > my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer <- my.unitizer + exps) > my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env()) > # now convert them to reference items > coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new) > # - "messed up env ancestry repair works" -------------------------------------- > > # # Purposefully mess up the environments > # # UPDATE: these tests don't work since parent.env<- added checks for circular > # # environment chains in r86545. We could probably restore functionality by > # # using a different parent env but would have to figure out what the intended > # # logic was. > # parent.env(my.unitizer2@items.ref[[2]]@env) <- baseenv() > # x <- unitizer:::healEnvs(my.unitizer2@items.ref, my.unitizer2) > # old.opt <- options(unitizer.max.env.depth = 20) > # res <- unitizer:::healEnvs(my.unitizer2@items.ref, my.unitizer2) > # is(res, "unitizerItems") > # ref.anc <- unitizer:::env_ancestry(x@base.env) > # itm.anc <- unitizer:::env_ancestry(x[[1L]]@env) > # # Items should belong to base env for reference > # identical(rev(ref.anc), head(rev(itm.anc), length(ref.anc))) > # options(old.opt) > > # - "re-assigning to ignored environments handled properly" -------------------- > > # now `a + b` could try to re-assign to `a <- 54`, but that is same env as > # `a + b` b/c it is ignored > items.picked <- my.unitizer@items.new[-3L] > # expect_error(items.heal <- unitizer:::healEnvs(items.picked, > # my.unitizer), NA) > # no error > items.heal <- unitizer:::healEnvs(items.picked, my.unitizer) > > # - "full repair process works" ------------------------------------------------ > > # copy files and then try messing up environment for the object > file_test("-d", file.path("_helper")) [1] TRUE > store <- file.path("_helper", "unitizers", "trivial.unitizer") > store.new <- file.path(TMP.DIR, store) > dir.create(store.new, recursive = TRUE) > cpy.files <- c( + list.files(store, full.names = TRUE), + file.path("helper", "unitizers", "trivial.R") + ) > file.copy(cpy.files, file.path(TMP.DIR, cpy.files), overwrite = TRUE) [1] TRUE FALSE > > untz <- unitizer:::load_unitizers( + list(store.new), NA_character_, + par.frame = .GlobalEnv, interactive.mode = TRUE, mode = "unitize", + show.progress=0L, transcript=FALSE + ) Warning in unitizer:::load_unitizers(list(store.new), NA_character_, par.frame = .GlobalEnv, : Upgraded test file does not match original test file ('trivial.R' vs 'NA'). Warning in .Object$initialize(...) : Instantiated global object without global namespace registry; you should only see this warning you are using `repair_environments`. > # Break env chain, store, and reload > untz[[1L]]@items.ref.calls.deparse[[5L]] [1] "y * x" > parent.env(untz[[1L]]@items.ref[[5L]]@env) <- baseenv() > # warning > unitizer:::store_unitizer(untz[[1L]]) | unitizer updated. > untz.rep <- repair_environments(store.new) Warning in .Object$initialize(...) : Instantiated global object without global namespace registry; you should only see this warning you are using `repair_environments`. Warning in repairEnvs(x@items.ref) : Detected corrupted environment history; we will attempt to repair, but keep in mind that even when repaired the test environments may be missleading. For example, the objects other than `.new` or `.ref` when reviewing tests at the `unitzer` prompt may not be those you expect or those reported by `ls`. To fully restore environments re-unitize with `unitize(..., force.update=TRUE)`. If errors persist after an attempt to repair, please contact maintainer. | unitizer updated. > # this should not give warnings > unitizer:::healEnvs(untz.rep@items.ref, untz.rep) An object of class "unitizerItems" Slot "base.env": Slot ".items": [[1]] ~~~ Reference Test ~~~ TRUE * value: logi[1] * output: 9 chars Access components with `$`, e.g. `.REF$value`; see `help("$", "unitizer")` [[2]] ~~~ Reference Test ~~~ x <- 1 + 1 * value: unitizerDummy Access components with `$`, e.g. `.REF$value`; see `help("$", "unitizer")` [[3]] ~~~ Reference Test ~~~ x + 2 * value: num[1] * output: 6 chars Access components with `$`, e.g. `.REF$value`; see `help("$", "unitizer")` [[4]] ~~~ Reference Test ~~~ y <- x * value: unitizerDummy Access components with `$`, e.g. `.REF$value`; see `help("$", "unitizer")` [[5]] ~~~ Reference Test ~~~ y * x * value: num[1] * output: 6 chars Access components with `$`, e.g. `.REF$value`; see `help("$", "unitizer")` [[6]] ~~~ Reference Test ~~~ y/x + 2 * value: num[1] * output: 6 chars Access components with `$`, e.g. `.REF$value`; see `help("$", "unitizer")` Slot ".pointer": [1] 0 Slot ".seek.fwd": [1] TRUE > > unitizer/tests/t-capture.R0000644000176200001440000001575314766101222015330 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("capture") # # Messing around trying to understand seek... # f <- tempfile() # con <- file(f, "w+b") # writeChar(paste(letters, LETTERS, collapse=" "), con) # readChar(con, 20) # pos <- seek(con, origin="current") # seek(con, pos, rw="write") # writeChar("xxxxxxxxx", con) # readChar(con, 3) # pos <- seek(con, origin="current") # seek(con, pos, rw="write") # writeChar("yyyyy", con) # close(con) # readLines(f) # unlink(f) # - "get_capture" -------------------------------------------------------------- old.max <- options(unitizer.max.capture.chars = 100L) cons <- new("unitizerCaptCons") base.char <- paste(rep(letters, 10), collapse = " ") writeChar(base.char, cons@out.c) # Error "Argument `chrs.max`" try(unitizer:::get_text_capture(cons, "output", TRUE, chrs.max = "howdy")) # Warn max capt cpt0 <- unitizer:::get_text_capture(cons, "output", TRUE) nchar(cpt0) base.char.2 <- paste(rev(rep(letters, 10)), collapse = " ") writeChar(base.char.2, cons@err.c) sink(cons@err.c, type = "message") cpt0.err <- unitizer:::get_text_capture(cons, "message", FALSE) sink(type = "message") all.equal(cpt0.err, substr(base.char.2, 1, 100)) ## for some reason this test stopped working; not sure why, need to look into ## it; seemingly it messes up the pointer for the next read # writeChar("xxxxxx", cons@out.c) # cpt2 <- unitizer:::get_text_capture(cons, "output", TRUE) # expect_equal("xxxxxx", cpt2) writeChar(paste0(rep("yyyyyyy", 20L), collapse = ""), cons@out.c) # warn max capt cpt1 <- unitizer:::get_text_capture(cons, "output", TRUE) all.equal(cpt1, paste0(rep("y", 100), collapse = "")) unitizer:::close_and_clear(cons) options(old.max) # - "get_text" ----------------------------------------------------------------- old.max <- options(unitizer.max.capture.chars = 100L) f <- tempfile() con <- file(f, "w+b") base.char <- paste(letters, collapse = " ") sink(con, type = "message") cat(base.char, file = stderr()) # this needs to temporarily switch the sink to be able to issue the warning # Warn: "Reached maximum" unitizer:::get_text(con, 10) # should still be to writing to our file, 10 chars in cat("boogiewoogy", file = stderr()) sink(type = "message") suppressWarnings(readLines(f)) # incomplete final line... options(old.max) unlink(f) # - "connection capture works" ------------------------------------------------- out.num <- as.integer(stdout()) err.num <- as.integer(stderr()) err.con <- getConnection(sink.number(type = "message")) cons <- new("unitizerCaptCons") cons <- unitizer:::set_capture(cons) cat("hello there\n") cat("goodbye there\n", file = stderr()) capt <- unitizer:::get_capture(cons) cons <- unitizer:::unsink_cons(cons) capt # expect_identical(as.integer(stdout()), out.num) identical(as.integer(stdout()), out.num) identical(as.integer(stderr()), err.num) unitizer:::close_and_clear(cons) # Now, here we add an extra stdout sink. In both cases unsink_cons will not # touch the sinks since we're not in an expected state, leaving # close_and_clear to cleanup err.con <- getConnection(sink.number(type = "message")) cons <- new("unitizerCaptCons") cons <- unitizer:::set_capture(cons) cat("there hello\n") # message does not work with testthat cat("there goodbye\n", file = stderr()) f1 <- tempfile() f2 <- tempfile() c2 <- file(f2, "w") sink(f1) sink(c2, type = "message") cat("12 there hello\n") # message does not work with testthat cat("12 there goodbye\n", file = stderr()) capt <- unitizer:::get_capture(cons) cons <- unitizer:::unsink_cons(cons) unitizer:::close_and_clear(cons) attr(cons@out.c, "waive") attr(cons@err.c, "waive") capt readLines(f1) readLines(f2) close(c2) unlink(c(f1, f2)) # Same, but this time close the sinks properly, so the connections should not # be waived err.con <- getConnection(sink.number(type = "message")) cons <- new("unitizerCaptCons") cons <- unitizer:::set_capture(cons) cat("there hello\n") # message does not work with testthat cat("there goodbye\n", file = stderr()) f1 <- tempfile() f2 <- tempfile() c2 <- file(f2, "w") sink(f1) sink(c2, type = "message") cat("12 there hello\n") # message does not work with testthat cat("12 there goodbye\n", file = stderr()) sink() sink(cons@err.c, type = "message") capt <- unitizer:::get_capture(cons) cons <- unitizer:::unsink_cons(cons) attr(cons@out.c, "waive") # NULL attr(cons@err.c, "waive") # NULL capt unitizer:::close_and_clear(cons) readLines(f1) readLines(f2) close(c2) unlink(c(f1, f2)) # Try to mess up sink counter by replacing the real sink with a fake sink # should lead to a waived connection cons <- new("unitizerCaptCons") cons <- unitizer:::set_capture(cons) f1 <- tempfile() sink() sink(f1) capt <- unitizer:::get_capture(cons) cons <- unitizer:::unsink_cons(cons) attr(cons@out.c, "waive") attr(cons@err.c, "waive") capt # Try to fix so that we don't get a full stack release error sink() sink(cons@out.c) unitizer:::close_and_clear(cons) unlink(f1) # helper function f1 <- tempfile() f2 <- tempfile() c1 <- file(f1, "w+b") c2 <- file(f2, "w+b") sink(c2) unitizer:::is_stdout_sink(f1) sink() sink(c1) unitizer:::is_stdout_sink(f1) sink() close(c1) close(c2) unlink(c(f1, f2)) # - "connection breaking tests" ------------------------------------------------ # # These tests cannot be run as they blow away the entire sink stack which can # # mess up any testing done under capture # # test_that("connection breaking tests", { # # Test the more pernicious error where we substitute the stdout sink # # cons <- new("unitizerCaptCons") # cons <- unitizer:::set_capture(cons) # cat("woohoo\n") # cat("yohooo\n", file=stderr()) # f1 <- tempfile() # sink() # sink(f1) # capt <- unitizer:::get_capture(cons) # cons <- unitizer:::unsink_cons(cons) # sink() # unlink(f1) # expect_true(attr(cons@out.c, "waive")) # expect_null(attr(cons@err.c, "waive")) # expect_identical( # capt, list(output = "woohoo\n", message = "yohooo\n") # ) # expect_identical( # unitizer:::close_and_clear(cons), # structure(c(FALSE, TRUE), .Names = c("output", "message")) # ) # }) # - "close_and_clear" ---------------------------------------------------------- # need some careful handling to make sure we don't mess up the testthat's # sinking (legacy behavior) cons <- new("unitizerCaptCons") err.con <- cons@stderr.con on.exit(sink(err.con, type = "message")) # intended to cause an error cons@stderr.con <- list() # msg: "Unable to restore original " cons.txt <- capture.output(status <- unitizer:::close_and_clear(cons), type = "message") any(grepl("connection", cons.txt)) sink(err.con, type = "message") status["message"] # - "eval with capt" ----------------------------------------------------------- suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) all.equal( (capt <- unitizer:::eval_with_capture(quote(1 + 1), global = glob))[1:8], rds(100) ) is(capt[[9]], "unitizerCaptCons") all.equal( ( capt <- unitizer:::eval_with_capture( cat("wow\n", file = stderr()), global = glob) )[1:8], rds(200) ) is(capt[[9]], "unitizerCaptCons") unitizer/tests/t-item.Rout.save0000644000176200001440000005124114766101222016300 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("item") > > options(unitizer.color = FALSE) > > # These tests are intended to cover all the functions/classes/methods in: > # - item.R > # - item.sub.R > # - test_eval.R # indirectly > # - heal.R > # - unitizer.R > # Basically everything that can be tested non-interactively > # Helper funs > > callDep <- function(x) paste0(deparse(x@call, width.cutoff = 500), + collapse = "") > lsObjs <- function(x) paste0(x@ls$names, x@ls$status, collapse = ", ") > lsStat <- function(x) x@ls$status > lsInv <- function(x) isTRUE(attr(x@ls, "invalid")) > # Get started > > new.exps <- expression( + 1 + 1, + a <- 54, # keep + b <- 38, # keep + a + b, + e <- 5 * a, # keep + a ^ 2, # Keep + f <- e * a, + matrix(rep(f, 20)) # keep + ) > ref.exps <- expression( + 1 + 1, + a <- 54, + b <- 38, + a + b, + e <- 5 * a, + e ^ 3 + ) > > Sys.sleep(0.2) > my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer <- my.unitizer + ref.exps) > my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env()) > # now convert them to reference items > coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new) > # now test against new.exps > coi(my.unitizer2 <- my.unitizer2 + new.exps) > > # - "item funs" ---------------------------------------------------------------- > > item <- my.unitizer@items.new[[1L]] > unitizer:::itemType(item) [1] "new" > try(unitizer:::itemType(item) <- "asdfasd") Error in unitizer:::`itemType<-`(`*tmp*`, value = "asdfasd") : Argument `value` must be in c("new", "reference") > unitizer:::itemType(item) <- "reference" > unitizer:::itemType(item) [1] "reference" > try(unitizer:::itemsType(my.unitizer@items.new) <- as.character(1:1000)) Error in unitizer:::`itemsType<-`(`*tmp*`, value = c("1", "2", "3", "4", : Argument `value` must be length 1L or have same length as argument `x` > try(item$booboo) Error in .local(x, i, j, ...) : Argument `name` must be in c("call", "state", "value", "conditions", "output", "message", "aborted") > > # - "unitizer creation worked as expected" ------------------------------------- > > validObject(my.unitizer, complete = TRUE) [1] TRUE > all.equal(capture.output(show(my.unitizer@items.new[[1L]])), rds(100)) [1] TRUE > identical(length(my.unitizer2), length(new.exps)) [1] TRUE > identical(length(my.unitizer2@items.new), length(new.exps)) [1] TRUE > identical(length(my.unitizer2@items.ref), length(ref.exps)) [1] TRUE > all.equal( + as.expression( + lapply(unitizer:::as.list(my.unitizer2@items.new), slot, "call") + ), + new.exps + ) [1] TRUE > all.equal( + as.expression( + lapply(unitizer:::as.list(my.unitizer2@items.ref), slot, "call") + ), + ref.exps + ) [1] TRUE > vals <- lapply( + unitizer:::as.list(my.unitizer2@items.new), function(x) x@data@value[[1L]] + ) > vals.ign <- unitizer:::ignored(my.unitizer2@items.new) > all.equal(vals[!vals.ign], lapply(new.exps, eval)[!vals.ign]) [1] TRUE > all(vapply(vals[vals.ign], is, logical(1L), "unitizerDummy")) [1] TRUE > > vals <- lapply( + unitizer:::as.list(my.unitizer2@items.ref), function(x) x@data@value[[1L]] + ) > vals.ign <- unitizer:::ignored(my.unitizer2@items.ref) > all.equal(vals[!vals.ign], lapply(ref.exps, eval)[!vals.ign]) [1] TRUE > all(vapply(vals[vals.ign], is, logical(1L), "unitizerDummy")) [1] TRUE > my.unitizer2@items.new.map [1] 1 2 3 4 5 NA NA NA > my.unitizer2@items.ref.map [1] 1 2 3 4 5 NA > my.unitizer2@tests.fail [1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE > my.unitizer2@tests.status [1] Pass Pass Pass Pass Pass New New New Levels: Pass Fail New Deleted Error > my.unitizer2@section.map [1] 1 1 1 1 1 1 1 1 > unitizer:::ignored(my.unitizer2@items.new) [1] FALSE TRUE TRUE FALSE TRUE FALSE TRUE FALSE > unitizer:::ignored(my.unitizer2@items.ref) [1] FALSE TRUE TRUE FALSE TRUE FALSE > > # - "Size Measurement works" --------------------------------------------------- > > # Used to produce warnings because the same base.env was used for every > # unitizer because it was created on package load as part of the S4 class > # definition instead of in "initialize", so any time we instantiated more > # than one object they all shared the same environment, causing issues with > # saveRDS > x <- unitizer:::sizeUntz(my.unitizer2) > is.matrix(x) && is.numeric(x) [1] TRUE > colnames(x) [1] "size" "rds" > > # - "Environment healing works" ------------------------------------------------ > > items.mixed <- my.unitizer2@items.new[4:5] + my.unitizer2@items.ref[[1]] + + my.unitizer2@items.new[c(2, 6, 8)] > items.sorted <- unitizer:::healEnvs(items.mixed, my.unitizer2) > env.anc <- lapply(unitizer:::as.list(items.sorted), function(x) rev(unitizer:::env_ancestry(x@env, + my.unitizer2@base.env))) > max.len <- max(vapply(env.anc, length, 1L)) > env.anc.2 <- lapply(env.anc, function(x) { + length(x) <- max.len + x + }) > env.anc.df <- as.data.frame(env.anc.2, stringsAsFactors = FALSE) > # Here only the first item is reference, all others > length(unique(unlist(env.anc.df[2, ]))) [1] 1 > all( + apply( + env.anc.df[-(1:2), -1], 1, + function(x) length(unique(Filter(Negate(is.na), x))) + ) == 1L + ) [1] TRUE > # First item is reference, all others are new > unitizer:::itemsType(items.sorted) [1] "reference" "new" "new" "new" "new" "new" [7] "new" "new" > # Expected order of ids > vapply(unitizer:::as.list(items.sorted), function(x) x@id, integer(1L)) [1] 1 2 3 4 5 6 7 8 > lapply(unitizer:::as.list(items.sorted), function(x) x@ls$names) [[1]] character(0) [[2]] character(0) [[3]] character(0) [[4]] [1] "a" "b" [[5]] character(0) [[6]] [1] "a" "b" "e" [[7]] character(0) [[8]] [1] "a" "b" "e" "f" > unique(unlist(lapply(unitizer:::as.list(items.sorted), function(x) x@ls$status))) [1] "" > # Tests with conditions > > # - "Items with conditions" ---------------------------------------------------- > > my_fun <- function() { + warning("hello") + 25 + } > ref.exps1a <- expression(stop("boom"), my_fun()) > my.unitizer1a <- new("unitizer", id = 100, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer1a <- my.unitizer1a + ref.exps1a) > > all.equal(capture.output(show(my.unitizer1a@items.new[[1L]])), rds(200)) [1] TRUE > all.equal(capture.output(show(my.unitizer1a@items.new[[2L]])), rds(300)) [1] TRUE > all.equal( + capture.output(show(my.unitizer1a@items.new[[1L]]@data@conditions)), rds(400) + ) [1] TRUE > # - "Environment healing works 2" ---------------------------------------------- > > # Stars highlight items we are selecting, but keep in mind that unitizer only > # cares about non ignored tests, and that the selection status of ignored test > # has nothing to do with what we end up with wrt to ignored tests > > new.exps2 <- expression( + 1 + 1, # 1 * + a <- 54, # 2 + b <- runif(5), # 3 + howdy <- "yowser", # 4 * + a + b, # 5 * + e <- 5 * a, # 6 + a ^ 2, # 7 + f <- e * a, # 8 + matrix(rep(f, 20)) # 9 * + ) > ref.exps2 <- expression( + 1 + 1, # 1 + a <- 54, # 2 + b <- runif(5), # 3 * + 25 + 3, # 4 + q <- b ^ 2 / a, # 5 * + a + b, # 6 + z <- w <- list(1, 2, 3), # 7 + Reduce(`+`, z), # 8 * Doesn't exist, should connect back to `a + b` + e <- 5 * a, # 9 + e ^ 3, # 10 * + e * a # 11 * + ) > > # Note that healEnvs modifies objects that contain environments, and as such > # you won't get the same result if you run this function twice, so don't be > # surprised if tests fail in those circumstances > my.unitizer3 <- new("unitizer", id = 1, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer3 <- my.unitizer3 + ref.exps2) > my.unitizer4 <- new("unitizer", id = 2, zero.env = new.env()) > # now convert them to reference items > coi(my.unitizer4 <- my.unitizer4 + my.unitizer3@items.new) > # now test against new.exps > coi(my.unitizer4 <- my.unitizer4 + new.exps2) > coi( + items.mixed2 <- my.unitizer4@items.ref[c(8, 10, 3, 5, 11)] + + my.unitizer4@items.new[c(1, 4, 5, 9)] + ) > items.sorted2 <- unitizer:::healEnvs(items.mixed2, my.unitizer4) > > env.anc <- lapply(unitizer:::as.list(items.sorted2), function(x) rev(unitizer:::env_ancestry(x@env, + my.unitizer4@base.env))) > max.len <- max(vapply(env.anc, length, 1L)) > env.anc.2 <- lapply(env.anc, function(x) { + length(x) <- max.len + x + }) > # oldest ancestor the same > env.anc.df <- as.data.frame(env.anc.2, stringsAsFactors = FALSE) > length(unique(unname(unlist(env.anc.df[1, ])))) # 1 [1] 1 > # "base.env should be unitizer env") > identical( + env.anc.df[1, 1], unitizer:::env_name(my.unitizer4@base.env) + ) [1] TRUE > # "all tests should also have another sub base.env") > length(unique(unlist(env.anc.df[2, ]))) == 1L [1] TRUE > # "and it should be the items.ref here") > identical( + env.anc.df[2, 1], unitizer:::env_name(my.unitizer4@items.ref@base.env) + ) [1] TRUE > items <- items.sorted2 > items.lst <- unitizer:::as.list(items) > # "new items should all have normal status", > heal.info <- cbind( + type = unitizer:::itemsType(items), ignored = unitizer:::ignored(items), + id = vapply(items.lst, slot, 1L, "id"), + call = vapply(items.lst, callDep, ""), + ls = vapply(items.lst, lsObjs, ""), + ls.invalid = vapply(items.lst, lsInv, TRUE) + ) > # "" > unique(unlist(lapply(items.lst[unitizer:::itemsType(items) == "new"], lsStat))) [1] "" > # "Reference tests should have no ls data", > unique(vapply(items.lst[unitizer:::ignored(items)], lsObjs, "")) [1] "" > all(vapply(items.lst[unitizer:::ignored(items)], lsInv, logical(1L))) [1] TRUE > > # - "ls works" ----------------------------------------------------------------- > > my.unitizer5 <- new("unitizer", id = 2, zero.env = new.env()) > # now add back our composite elements as references > coi(my.unitizer5 <- my.unitizer5 + items.sorted2) > # and new items > coi(my.unitizer5 <- my.unitizer5 + new.exps2) > > # This is an ignored test, so there will be some problems > env.val <- new.env(parent = my.unitizer5@items.new[[3]]@env) > env.eval <- new.env(parent = env.val) > assign(".NEW", my.unitizer5@items.new[[3]], env.val) > assign(".new", my.unitizer5@items.new[[3]]@data@value[[1L]], + env.val) > assign(".REF", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[3]]]], + env.val) > assign(".ref", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[3]]]]@data@value[[1L]], + env.val) > ls.res <- evalq(unitizer:::unitizer_ls(), env.eval) # warn Warning in unitizer:::unitizer_ls() : The ls output for `.ref` is invalid. This may be because you had corrupted environment chains that had to be repaired. Re-generating the `unitizer` with `unitize(..., force.update=TRUE)` should fix the problem. If it persists, please contact maintainer. > # Reference tests won't show up since they were nuked by `healEnvs` > all.equal(ls.res, rds(500)) [1] TRUE > # These are normal tests so should work > env.val <- new.env(parent = my.unitizer5@items.new[[9]]@env) > env.eval <- new.env(parent = env.val) > assign(".NEW", my.unitizer5@items.new[[9]], env.val) > assign(".new", my.unitizer5@items.new[[9]]@data@value[[1L]], + env.val) > assign(".REF", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[9]]]], + env.val) > assign(".ref", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[9]]]]@data@value[[1L]], + env.val) > all.equal(evalq(unitizer:::unitizer_ls(), env.eval), + rds(600)) [1] TRUE > all.equal(capture.output(print(evalq(unitizer:::unitizer_ls(), + env.eval))), rds(700)) [1] TRUE > > # - "Environment Healing Works #3" --------------------------------------------- > # > # Main difference to previous versions is that we're testing that moving the > # order of tests around between ref and new still works > # > # Test that reference tests moving around doesn't cause major issues > > new.exps6 <- expression( + 1 + 1, # 1 * + a <- 54, # 2 + b <- runif(5), # 3 + howdy <- "yowser", # 4 + a + b, # 5 + e <- 5 * a, # 6 + a ^ 2, # 7 * + f <- 25, # 8 * + matrix(rep(f, 20)) # 9 + ) > ref.exps6 <- expression( + 1 + 1, # 1 + a <- 54, # 2 + f <- 25, # 3 + matrix(rep(f, 20)), # 4 * + b <- runif(5), # 5 + boomboom <- "boo", # 6 + a + b, # 7 * + a + b + f, # 8 + e <- 5 * a, # 9 + a ^ 2 # 10 + ) > my.unitizer10 <- new("unitizer", id = 1, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer10 <- my.unitizer10 + ref.exps6) > my.unitizer11 <- new("unitizer", id = 2, zero.env = new.env()) > # now convert them to reference items > coi(my.unitizer11 <- my.unitizer11 + my.unitizer10@items.new) > # now test against new.exps > coi(my.unitizer11 <- my.unitizer11 + new.exps6) > items.mixed3 <- my.unitizer11@items.ref[c(4, 7)] + + my.unitizer11@items.new[c(1, 7, 8)] > items.sorted3 <- unitizer:::healEnvs(items.mixed3, my.unitizer11) > > # Both reference tests get appended to item #1, which means among other things > # that for the second refernce test, the `a` object is absent (but `b` is > # present because it gets sucked in by virtue of being an ignored test just > # ahead of it) > items <- items.sorted3 > items.lst <- unitizer:::as.list(items) > cbind( + type = unitizer:::itemsType(items), ignored = unitizer:::ignored(items), + id = vapply(items.lst, slot, 1L, "id"), + call = vapply(items.lst, callDep, ""), + ls = vapply(items.lst, lsObjs, ""), + ls.invalid = vapply(items.lst, lsInv, TRUE) + ) type ignored id call ls [1,] "new" "FALSE" "1" "1 + 1" "" [2,] "reference" "TRUE" "2" "a <- 54" "" [3,] "reference" "TRUE" "3" "f <- 25" "" [4,] "reference" "FALSE" "4" "matrix(rep(f, 20))" "a, f" [5,] "reference" "TRUE" "5" "b <- runif(5)" "" [6,] "reference" "TRUE" "6" "boomboom <- \"boo\"" "" [7,] "reference" "FALSE" "7" "a + b" "a*, b, boomboom, f*" [8,] "new" "TRUE" "6" "e <- 5 * a" "" [9,] "new" "FALSE" "7" "a^2" "a, b, e, howdy" ls.invalid [1,] "FALSE" [2,] "TRUE" [3,] "TRUE" [4,] "FALSE" [5,] "TRUE" [6,] "TRUE" [7,] "FALSE" [8,] "TRUE" [9,] "FALSE" > # - "No circular environment references" --------------------------------------- > > # This is to test for issue #2, which resulted in a self referential environment > # in the stored items. The following code used to fail: > new.exps3 <- expression(1 + 1, a <- 54, b <- 5, 2 + 2, runif(1)) > ref.exps3 <- expression(1 + 1, a <- 54, 2 + 2, runif(1)) > my.unitizer6 <- new("unitizer", id = 1, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer6 <- my.unitizer6 + ref.exps3) > my.unitizer7 <- new("unitizer", id = 2, zero.env = new.env()) > # now convert them to reference items > coi(my.unitizer7 <- my.unitizer7 + my.unitizer6@items.new) > # now test against new.exps > coi(my.unitizer7 <- my.unitizer7 + new.exps3) > # Note this doesn't test that there are no circular references, only that what > # used to fail no longer fails. > > cbind(my.unitizer7@tests.new, my.unitizer7@tests.result) value conditions output message aborted [1,] FALSE TRUE TRUE TRUE TRUE TRUE [2,] FALSE TRUE TRUE TRUE TRUE TRUE [3,] TRUE FALSE FALSE FALSE FALSE FALSE [4,] FALSE TRUE TRUE TRUE TRUE TRUE [5,] FALSE FALSE TRUE TRUE TRUE TRUE > > # - "testFuns" ----------------------------------------------------------------- > > # Error objects > > # these two should just work fine > is(new("testFuns", output = all.equal, value = function(x, y) TRUE), "testFuns") [1] TRUE > is(new("testFuns"), "testFuns") [1] TRUE > try(new("testFuns", output = all.equal, value = function(x, y, z) TRUE)) Error in validObject(.Object) : invalid class "unitizerItemTestFun" object: Slot `@fun` must be a function with the first two parameters non-optional and all others optional (cannot have any non-optional arguments other than first two). > # this should work too now, since technically has two args > is( + new("testFuns", output = all.equal, value = function(x, y = 1, z = 1) TRUE), + "testFuns" + ) [1] TRUE > try(new("testFuns", cabbage = all.equal)) Error in initialize(value, ...) : Can't initialize invalid slots "cabbage" > > # - "Misc" --------------------------------------------------------------------- > > new.exps4 <- expression(a <- function() b(), b <- function() TRUE, a()) > my.unitizer8 <- new("unitizer", id = 3, zero.env = new.env()) > new.exps5 <- expression(a <- function() b(), NULL, b <- function() TRUE, a()) > my.unitizer9 <- new("unitizer", id = 4, zero.env = new.env()) > coi(x <- my.unitizer9 + new.exps5) > > local({ + fun <- function() quote(stop("This error should not be thrown")) + is( + new( + "unitizerItem", value = fun(), call = quote(fun()), + env = sys.frame(sys.parent() + 1L) + ), + "unitizerItem" + ) + }) [1] TRUE > # Nested environment hand waving can break down under certain circumstances > # this first one should work because there are no tests until after all > # the pieces necessary to run `a()` are defined: > coi(res <- my.unitizer8 + new.exps4) > is(res, "unitizer") [1] TRUE > # this should break because the NULL forces `b` to be stored in a different > # environment to `a`; note: funky error message matching because in > # at least some versions of rdevel reported fun name seems to change > # (possibly related to level 3 bytecode) > # could not find fun > x@items.new[[4]]@data@message[[1]] [1] "Error in b() : could not find function \"b\"\n" > > # - "Comparison Function Errors" ----------------------------------------------- > > exps <- expression(fun <- function(x, y) warning("not gonna work"), + unitizer_sect(compare = fun, expr = { + 1 + 1 + })) > my.unitizer <- new("unitizer", id = 25, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer <- my.unitizer + exps) > coi(my.unitizer2 <- new("unitizer", id = 26, zero.env = new.env()) + + my.unitizer@items.new) > # warn: not gonna work > coi(my.unitizer2 <- my.unitizer2 + exps) Warning in close_and_clear(e1@global$cons) : Test comparison functions appear to have produced output, which should not happen (see `?unitizer_sect` for more details). If you did not provide custom testing functions, contact maintainer. First 50 lines follow: Warning in fun(2, 2) : not gonna work > as.character(my.unitizer2@tests.status) [1] "Pass" "Error" > my.unitizer2@tests.errorDetails[[2]]@value@value [1] "comparison function `fun` signaled a condition of class `c(\"simpleWarning\", \"warning\", \"condition\")`, with message \"not gonna work\" and call `fun(2, 2)`." > > # - "Language Objects Tested Properly" ----------------------------------------- > > exps <- expression(quote(x), quote(x + y), quote(identity(x)), + expression(1 + y), quote(expression(1 + y))) > my.unitizer <- new("unitizer", id = 27, zero.env = new.env()) > # add ref.exps as new items > coi(my.unitizer <- my.unitizer + exps) > coi(my.unitizer2 <- new("unitizer", id = 28, zero.env = new.env()) + + my.unitizer@items.new) > coi(my.unitizer2 <- my.unitizer2 + exps) > # This used to error b/c expressions returning unevaluated calls/symbols were > # not compared as such (they were evaluated) > as.character(my.unitizer2@tests.status) [1] "Pass" "Pass" "Pass" "Pass" "Pass" > > # - "Test Fun Captured Properly" ----------------------------------------------- > > new("unitizerItemTestFun", fun = identical)@fun.name [1] "identical" > > > proc.time() user system elapsed 1.731 0.204 2.182 unitizer/tests/t-search.R0000644000176200001440000002317714766101222015131 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("_helper", "pkgs.R")) unitizer.dummy.list <- list(A = 1, B = 2, C = 3) unitizer.dummy.list.2 <- list(A = 13, B = 24, C = 35) # can't unload `unitizer`, ruins `covr` try(detach("package:unitizer"), silent = TRUE) try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) try(detach("package:unitizerdummypkg2", unload = TRUE), silent = TRUE) while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) state.set <- setNames(rep(2L, length(unitizer:::.unitizer.global.settings.names)), unitizer:::.unitizer.global.settings.names) library(unitizer) library(unitizerdummypkg1, lib.loc = TMP.LIB) library(unitizerdummypkg2, lib.loc = TMP.LIB) # - "Detecting packages" ------------------------------------------------------- unitizer:::is.loaded_package("package:unitizer") unitizer:::is.loaded_package("unitizer") # FALSE unitizer:::is.loaded_package("package:stats") try(unitizer:::is.loaded_package(1)) try(unitizer:::is.loaded_package(letters)) unitizer:::is.loaded_package("Autoloads") # FALSE is.list(pkg.dat <- unitizer:::get_package_data()) all( vapply( pkg.dat, function(x) is.list(x) && identical(names(x), c("names", "lib.loc", "version")), logical(1L) ) ) # - "Path Compression" --------------------------------------------------------- search.init.full <- unitizer:::search_as_envs() search.init <- search.init.full$search.path head(unitizer:::compress_search_data(search.init.full), 3L) # - "Moving Objects on Search Path Works" -------------------------------------- if (length(search.init) < 6L) stop("Unexpetedly short search path") untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, set.global = TRUE) try(unitizer:::move_on_path(5L, 2L, untz.glob)) try(unitizer:::move_on_path(1L, 2L, untz.glob)) unitizer:::move_on_path(2L, 5L, untz.glob) # can't compare actual environments as they change when detached and # re-attached all.equal( names(unitizer:::search_as_envs()$search.path), names(search.init[c(1L, 5L, 2L:4L, 6L:length(search.init))]) ) # Now let's undo the previous move, by pushing second pack back to # original position for (i in rep(5L, 3L)) unitizer:::move_on_path(2L, 5L, untz.glob) unitizer:::search_dat_equal(unitizer:::search_as_envs(), search.init.full) untz.glob$release() # - "Search Path Journaling Works" --------------------------------------------- try(detach("package:unitizer"), silent = TRUE) try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) try(detach("package:unitizerdummypkg2", unload = TRUE), silent = TRUE) library(unitizer) # Initialize a global tracking object. Doing it funny here because we don't # want to run the search_path_trim command yet, and that would happen if we # did a normal init # will be modified later search.ref <- NULL search.init <- unitizer:::search_as_envs() untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, set.global = TRUE) stat.tpl <- new("unitizerGlobalStatus", search.path = 2L, working.directory = 2L, options = 2L, random.seed = 2L, namespaces = 2L) # these need to be done outside of `test_that` b/c `test_that` sets the # rlang_trace_top_env option st.0 <- untz.glob$indices.last st.1 <- untz.glob$state() # Note, these are intended to be run without the shimming in place identical(untz.glob$status, stat.tpl) # state should only be recorded if it changes st.0 identical(st.0, st.1) # Add a package library("unitizerdummypkg1", lib.loc = TMP.LIB) st.2 <- untz.glob$state() # have two recorded states st.2@search.path # should have one more item diff(sapply(untz.glob$tracking@search.path, function(x) length(x$search.path))) environmentName(untz.glob$tracking@search.path[[2L]]$search.path[[2L]]) sp.tmp <- untz.glob$tracking@search.path # note we compare attribute separately because subsetting drops them identical(sp.tmp[[1L]]$search.path, sp.tmp[[2L]]$search.path[-2L]) identical( sp.tmp[[1L]]$ns.dat, sp.tmp[[2L]]$ns.dat[names(sp.tmp[[2L]]$ns.dat) != "unitizerdummypkg1"] ) # Add another package at a different position library("unitizerdummypkg2", pos = 4L, lib.loc = TMP.LIB) st.3 <- untz.glob$state() diff(sapply(untz.glob$tracking@search.path, function(x) length(x$search.path))) environmentName( untz.glob$tracking@search.path[[st.3@search.path]]$search.path[[4L]] ) # Attach a list attach(unitizer.dummy.list) search.ref <- untz.glob$state() environmentName( untz.glob$tracking@search.path[[search.ref@search.path]]$search.path[[2L]] ) identical( as.list( untz.glob$tracking@search.path[[search.ref@search.path]]$search.path[[2L]] ), unitizer.dummy.list ) # And one more, but modified unitizer.dummy.list.2 <- list(A = 13, B = 24, C = 35) attach(unitizer.dummy.list.2, pos = 4L, name = "unitizer.dummy.list") st.4 <- untz.glob$state() curr.sp.ind <- untz.glob$indices.last@search.path environmentName(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[4L]]) # Make sure search path is lining up all.equal( names(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path), search() ) identical( as.list(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[4L]]), unitizer.dummy.list.2 ) identical( as.list(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[2L]]), unitizer.dummy.list ) # should still point to same environment identical( untz.glob$tracking@search.path[[curr.sp.ind - 1L]]$search.path[[2L]], untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[2L]] ) # state shouldn't have changed identical(untz.glob$state(), st.4) # detach some stuff # this is the first list detach(2L) untz.glob$state() curr.sp.ind <- untz.glob$indices.last@search.path identical( untz.glob$tracking@search.path[[curr.sp.ind]]$search.path, untz.glob$tracking@search.path[[curr.sp.ind - 1L]]$search.path[-2L] ) detach("package:unitizerdummypkg2") untz.glob$state() curr.sp.ind <- untz.glob$indices.last@search.path identical( untz.glob$tracking@search.path[[curr.sp.ind]]$search.path, untz.glob$tracking@search.path[[curr.sp.ind - 1L]]$search.path[-5L] ) # - "Resetting search path" ---------------------------------------------------- identical( as.list(as.environment("unitizer.dummy.list")), unitizer.dummy.list.2 ) # set to just after we added the original dummy list untz.glob$reset(search.ref) identical(as.list(as.environment("unitizer.dummy.list")), unitizer.dummy.list) # Confirm we actually set to expected path # NOTE: not sure if with updates this can work all.equal( names(unitizer:::search_as_envs()$search.path), names(untz.glob$tracking@search.path[[search.ref@search.path]]$search.path) ) # Reset to very beginning untz.glob$resetFull() untz.glob$release() # compare with all.equal to make sure we use S4 method unitizer:::search_dat_equal(unitizer:::search_as_envs(), search.init) # - "Search Path Trim / Restore" ----------------------------------------------- search.init <- unitizer:::search_as_envs() untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, set.global = TRUE) library(unitizerdummypkg1, lib.loc = TMP.LIB) library(unitizerdummypkg2, lib.loc = TMP.LIB) unitizer:::search_path_trim(global = untz.glob) untz.glob$state() sp.keep <- unitizer:::keep_sp_default() identical( search(), sp.keep[match(names(search.init$search.path), sp.keep, nomatch = 0L)] ) untz.glob$resetFull() untz.glob$release() unitizer:::search_dat_equal(unitizer:::search_as_envs(), search.init) try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) try(detach("package:unitizerdummypkg2", unload = TRUE), silent = TRUE) while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) # - "Loaded Namespaces don't cause issues" ------------------------------------- # had a problem earlier trying to re-attach namespaces loadNamespace("unitizerdummypkg1", lib.loc = TMP.LIB) untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, set.global = TRUE) unitizer:::search_path_trim(global = untz.glob) unitizer:::namespace_trim(global = untz.glob) untz.glob$state() loadNamespace("unitizerdummypkg2", lib.loc = TMP.LIB) untz.glob$state() "unitizerdummypkg1" %in% loadedNamespaces() # FALSE "unitizerdummypkg2" %in% loadedNamespaces() untz.glob$resetFull() untz.glob$release() "unitizerdummypkg1" %in% loadedNamespaces() "unitizerdummypkg2" %in% loadedNamespaces() # FALSE unloadNamespace("unitizerdummypkg1") # - "Prevent Namespace Unload Works" ------------------------------------------- old.opt <- options(unitizer.namespace.keep = "unitizerdummypkg1") loadNamespace("unitizerdummypkg1", lib.loc = TMP.LIB) glb <- unitizer:::unitizerGlobal$new(set.global = TRUE) glb$status@options <- 2L unitizer:::unload_namespaces("unitizerdummypkg1", global = glb) glb$ns.opt.conflict@conflict glb$ns.opt.conflict@namespaces unloadNamespace("unitizerdummypkg1") options(old.opt) glb$release() # - "Generate unique names" ---------------------------------------------------- unitizer:::unitizerUniqueNames(list(search.path = c(goodbye = "0", hello = "1", goodbye = "2", goodbye = "3"))) # - "Fake Package Re-attach" --------------------------------------------------- # Make sure that aspects of search path management other than search path # survive a failure caused by bad search path env (#252, #253). owd <- getwd() test.f <- paste0(tempfile(), ".R") writeLines(" f <- tempfile() dir.create(f) setwd(f) # Package assumed non-existing; R could disallow this in the future # which could change the test. attach(list(x=42), name='package:adfaadcxuqyojfnkfadsf') 1 + 1", test.f) out <- unitizer:::capture_output( try(unitize(test.f, state='recommended', interactive.mode=FALSE)) ) any(grepl("mismatch between actual search path and tracked", out$message)) identical(owd, getwd()) # confirm working directory restored unitizer/tests/t-misc.R0000644000176200001440000004422114766101222014610 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") # - "Text wrapping" ------------------------------------------------------------ var <- "humpty dumpty sat on a truck and had a big dump" # expect_true(all(nchar(unlist(unitizer:::text_wrap(var, 10))) <= writeLines(unlist(unitizer:::text_wrap(var, 10))) all(nchar(unlist(unitizer:::text_wrap(var, 10))) <= 10) var2 <- rep(var, 4) # expect_true(all(nchar(wrp <- unlist(unitizer:::text_wrap(var2, # c(20, 15)))) <= 20) && length(wrp) == 14) writeLines(unlist(unitizer:::text_wrap(var2, c(20, 15)))) all(nchar(wrp <- unlist(unitizer:::text_wrap(var2, c(20, 15)))) <= 20) && length(wrp) == 14 # - "Headers" ------------------------------------------------------------------ # these basically require visual inspection unitizer:::H1("hello world") unitizer:::H2("hello world") unitizer:::H3("hello world") # cause an error try(print(unitizer:::H1(rep_len("hello world", 10)))) h.w.long <- paste0(rep_len("hello world", 10), collapse = " ") unitizer:::H1(h.w.long) unitizer:::H2(h.w.long) print(unitizer:::H2("No margin"), margin = "none") # no extra line below # - "Valid Names convert names to valid" --------------------------------------- # expect_equal(unitizer:::valid_names("hello"), "hello") unitizer:::valid_names("hello") # expect_equal(unitizer:::valid_names(".hello"), ".hello") unitizer:::valid_names(".hello") # expect_equal(unitizer:::valid_names("1hello"), "`1hello`") unitizer:::valid_names("1hello") # expect_equal(unitizer:::valid_names("hello kitty"), "`hello kitty`") unitizer:::valid_names("hello kitty") # expect_equal(unitizer:::valid_names("h3llo"), "`h3llo`") unitizer:::valid_names("h3llo") # expect_equal(unitizer:::valid_names("h_llo"), "h_llo") unitizer:::valid_names("h_llo") # expect_equal(unitizer:::valid_names("$hot"), "`$hot`") unitizer:::valid_names("$hot") # expect_equal(unitizer:::valid_names("HELLO"), "HELLO") unitizer:::valid_names("HELLO") # - "strtrunc" ----------------------------------------------------------------- # expect_equal(unitizer:::strtrunc("hollywood is for starlets", # 5), "ho...") unitizer:::strtrunc("hollywood is for starlets", 5) # expect_error(unitizer:::strtrunc(5, "hollywood is for starlets")) try(unitizer:::strtrunc(5, "hollywood is for starlets")) # - "environment name tools" --------------------------------------------------- env1 <- new.env(parent = globalenv()) env2 <- new.env(parent = env1) env3 <- new.env(parent = env2) env4 <- new.env(parent = env3) # expect_true(is.character(ename <- unitizer:::env_name(env3)) && # identical(length(ename), 1L)) is.character(ename <- unitizer:::env_name(env3)) && identical(length(ename), 1L) # expect_true(is.character(envanc <- unitizer:::env_ancestry(env4)) && # identical(length(envanc), 5L) && identical(envanc[[5L]], # "R_GlobalEnv")) is.character(envanc <- unitizer:::env_ancestry(env4)) && identical(length(envanc), 5L) && identical(envanc[[5L]], "R_GlobalEnv") # - "deparse peek" ------------------------------------------------------------- expr1 <- quote(1 + 1 + 3) expr2 <- quote(for (i in 1:100) { loop.val <- sample(1:1000, 200, replace = TRUE) loop.val <- loop.val * 200/3000 * mean(runif(20000)) }) # expect_equal("1 + 1 + 3", unitizer:::deparse_peek(expr1, 20L)) unitizer:::deparse_peek(expr1, 20L) # expect_error(unitizer:::deparse_peek(expr1, 3L)) try(unitizer:::deparse_peek(expr1, 3L)) # expect_equal("1 ...", unitizer:::deparse_peek(expr1, 5L)) unitizer:::deparse_peek(expr1, 5L) # expect_equal("for (i in 1:100) { loop.val <- sam...", unitizer:::deparse_peek(expr2, # 40L)) unitizer:::deparse_peek(expr2, 40L) # - "deparse fun" -------------------------------------------------------------- # expect_identical(unitizer:::deparse_fun(quote(fun)), "fun") unitizer:::deparse_fun(quote(fun)) # expect_identical(unitizer:::deparse_fun(quote(function(x) NULL)), # NA_character_) unitizer:::deparse_fun(quote(function(x) NULL)) # expect_identical(unitizer:::deparse_fun("hello"), character(0L)) unitizer:::deparse_fun("hello") # - "deparse_prompt" ----------------------------------------------------------- suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) item <- unitizer:::exec(quote(if (TRUE) { 25 } else { 42 }), new.env(), glob) unitizer:::deparse_prompt(item) # - "deparse_mixed" ------------------------------------------------------------ b <- setNames(1:3, letters[1:3]) x <- quote(1 + b) x[[3]] <- b # expect_equal(unitizer:::deparse_mixed(x), "quote(1 + 1:3)") unitizer:::deparse_mixed(x) y <- quote(1 + 3 + b) y[[3]] <- b # expect_equal(unitizer:::deparse_mixed(y), "quote(1 + 3 + 1:3)") unitizer:::deparse_mixed(y) # - "(Un)ordered Lists" -------------------------------------------------------- vec <- c("hello htere how are you blah blah blah blah blah", "this is helpful you know", "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", letters[1:10]) # expect_equal(as.character(unitizer:::OL(vec), width = 100L), # c(" 1. hello htere how are you blah blah blah blah blah", # " 2. this is helpful you know", " 3. Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut ", # " labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco ", # " laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in ", # " voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat ", # " non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", # " 4. a", " 5. b", " 6. c", " 7. d", " 8. e", " 9. f", # "10. g", "11. h", "12. i", "13. j")) writeLines(as.character(unitizer:::OL(vec), width = 100L)) # expect_equal(as.character(unitizer:::UL(vec), width = 20L), c("- hello htere how ", # " are you blah blah ", " blah blah blah", "- this is helpful ", # " you know", "- Lorem ipsum dolor ", " sit amet, consec-", # " tetur adipisicing ", " elit, sed do ", " eiusmod tempor ", # " incididunt ut ", " labore et dolore ", " magna aliqua. Ut ", # " enim ad minim ", " veniam, quis ", " nostrud exer-", # " citation ullamco ", " laboris nisi ut ", " aliquip ex ea ", # " commodo consequat.", " Duis aute irure ", " dolor in reprehen-", # " derit in voluptate", " velit esse cillum ", " dolore eu fugiat ", # " nulla pariatur. ", " Excepteur sint ", " occaecat cupidatat", # " non proident, sunt", " in culpa qui ", " officia deserunt ", # " mollit anim id est", " laborum.", "- a", "- b", "- c", # "- d", "- e", "- f", "- g", "- h", "- i", "- j")) writeLines(as.character(unitizer:::UL(vec), width = 20L)) # test_that("Messing with traceback", { # warning("Missing traceback tests") # # Main problem with this is that there may not be a good way to cause a trace # # back to register while not also stopping execution of this file, so not # # sure if this can be tested # } ) # - "Compare Conditions" ------------------------------------------------------- lst1 <- new("conditionList", .items = list(simpleWarning("warning", quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), simpleWarning("warning3", quote(yo3 + yo)), simpleError("error1", quote(make_an_error())))) lst2 <- new("conditionList", .items = list(simpleWarning("warning", quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), simpleError("error1", quote(make_an_error())))) all.equal(lst1, lst1) # expect_equal("Condition count mismatch; expected 4 (got 3)", # all.equal(lst1, lst2)) all.equal(lst1, lst2)# # expect_equal("There is one condition mismatch at index [[3]]", # all.equal(lst2, lst1[1L:3L])) all.equal(lst2, lst1[1L:3L]) # expect_equal("There are 2 condition mismatches, first one at index [[1]]", # all.equal(lst2, lst1[2L:4L])) all.equal(lst2, lst1[2L:4L]) attr(lst1[[3L]], "unitizer.printed") <- TRUE # expect_equal("There is one condition mismatch at index [[3]]", # all.equal(lst2, lst1[1L:3L])) all.equal(lst2, lst1[1L:3L]) # expect_equal(c("Condition type mismatch, `target` is 'Error', but `current` is 'Warning'", # "Condition mismatch may involve print/show methods; carefully review conditions with `.NEW$conditions` and `.REF$conditions` as just typing `.ref` or `.new` at the prompt will invoke print/show methods, which themselves may be the cause of the mismatch"), # all.equal(lst2[[3]], lst1[[3]])) all.equal(lst2[[3]], lst1[[3]]) attr(lst1[[3L]], "unitizer.printed") <- NULL lst1[[2L]] <- simpleWarning("warning2", quote(yo2 + yoyo)) # This used to produce "one condition mismatch at index [[2]]", but with the # relation of condition call comparison, no longer fails. Arguably this one # should still fail as none of the parameters are named. all.equal(lst2, lst1[c(1L:2L, 4L)]) # single condition display with a more complex condition large.cond <- simpleWarning(paste0(collapse = "\n", c("This is a complicated warning:", as.character(unitizer:::UL(c("one warning", "two warning", "three warning"))))), quote(make_a_warning())) lst3 <- new("conditionList", .items = list(large.cond)) show1 <- capture.output(show(lst3)) all.equal(show1, rds("misc_cndlistshow1")) attr(lst3[[1L]], "unitizer.printed") <- TRUE lst3[[2L]] <- simpleWarning("warning2", quote(yo2 + yoyo)) lst3 # empty condition lst3[0] # Conditions with mismatched calls (due to instability in call generation for C # errors issue285) lst4a <- new("conditionList", .items = list( simpleWarning("A", quote(fun(a=b, c=d))), simpleWarning("B", quote(fun(a=b, c=d))), simpleWarning("C", quote(fun(a=b, c=d))), simpleWarning("D", quote(fun(a, c=d))), simpleWarning("E", quote(fun())), simpleWarning("F"), simpleWarning("G", quote(fun(a=b, c=d))), simpleWarning("H", quote(fun(a=b, c=d))), simpleWarning("I", quote(foo(a=b, c=d))) )) lst4b <- new("conditionList", .items = list( simpleWarning("A", quote(fun(a=b, c=d))), simpleWarning("B", quote(fun(a=B, c=d))), simpleWarning("C", quote(fun(b, c=d))), simpleWarning("D", quote(fun(a=b, c=d))), simpleWarning("E", quote(fun(a=b, c=d))), simpleWarning("F", quote(fun(a=b, c=d))), simpleWarning("G"), simpleWarning("H", quote(fun())), simpleWarning("I", quote(bar(a=b, c=d))) )) all.equal(lst4a, lst4b) all.equal(lst4a[c(2, 9)], lst4b[c(2, 9)]) # - "Compare Functions With Traces" -------------------------------------------- fun.a <- base::library identical(fun.a, base::library) trace(library, where = .BaseNamespaceEnv) identical(fun.a, base::library) # FALSE unitizer:::identical_fun(fun.a, base::library) unitizer:::identical_fun(base::library, fun.a) # FALSE untrace(library, where = .BaseNamespaceEnv) # expect_error(unitizer:::identical_fun(1, base::library)) try(unitizer:::identical_fun(1, base::library)) # expect_error(unitizer:::identical_fun(base::library, 1)) try(unitizer:::identical_fun(base::library, 1)) unitizer:::identical_fun(base::print, base::print) # make sure all.equal dispatches properly out of namespace # expect_equal(evalq(all.equal(new("conditionList", .items = list(simpleWarning("warning", # quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), # simpleWarning("warning3", quote(yo3 + yo)), simpleError("error1", # quote(make_an_error())))), new("conditionList", .items = list(simpleWarning("warning", # quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), # simpleError("error1", quote(make_an_error()))))), envir = getNamespace("stats")), # "Condition count mismatch; expected 4 (got 3)") evalq(all.equal(new("conditionList", .items = list(simpleWarning("warning", quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), simpleWarning("warning3", quote(yo3 + yo)), simpleError("error1", quote(make_an_error())))), new("conditionList", .items = list(simpleWarning("warning", quote(yo + yo)), simpleWarning("warning2", quote(yo2 + yo)), simpleError("error1", quote(make_an_error()))))), envir = getNamespace("stats")) # - "word_cat" ----------------------------------------------------------------- str <- "Humpty dumpty sat on a wall and took a big fall. All the kings horses and men couldn't put humpty dumpty together again" # expect_equal(capture.output(unitizer:::word_cat(str, width = 20L)), # c("Humpty dumpty sat on", "a wall and took a ", "big fall. All the ", # "kings horses and men", "couldn't put humpty ", "dumpty together ", # "again")) unitizer:::word_cat(str, width = 20L) # expect_error(unitizer:::word_cat(stop("boom"), width = 20L, sep = " "), # "boom") try(unitizer:::word_cat(stop("boom"), width = 20L, sep = " ")) str2 <- rep("goodbye goodbye") str1 <- rep("hello hello hello", 2) # expect_equal(c("hello hello ", "hello hello ", "hello hello ", # "goodbye ", "goodbye"), capture.output()) unitizer:::word_cat(str1, str2, width = 14L) # Make sure default works old.width <- options(width = 20L) # expect_equal(capture.output(unitizer:::word_cat(str)), c("Humpty dumpty sat on", # "a wall and took a ", "big fall. All the ", "kings horses and men", # "couldn't put humpty ", "dumpty together ", "again")) unitizer:::word_cat(str) options(old.width) # - "relativize_path" ---------------------------------------------------------- base <- file.path(system.file(package = "unitizer"), "expkg") wd <- file.path(base, "infer") p1 <- file.path(wd, "R") p2 <- file.path(base, "unitizerdummypkg1") # expect_equal(unitizer:::relativize_path(p1, wd), "R") unitizer:::relativize_path(p1, wd) # expect_equal(unitizer:::relativize_path(p2, wd), "../unitizerdummypkg1") unitizer:::relativize_path(p2, wd) # expect_equal(unitizer:::relativize_path(c(p1, p2), wd), c("R", # "../unitizerdummypkg1")) unitizer:::relativize_path(c(p1, p2), wd) # expect_equal(unitizer:::relativize_path(c(p1, p2), wd), c("R", # "../unitizerdummypkg1")) unitizer:::relativize_path(c(p1, p2), wd) # expect_equal(unitizer:::relativize_path(c(p1, p2, file.path("notarealpath", # "foo")), wd), c("R", "../unitizerdummypkg1", file.path("notarealpath", # "foo"))) unitizer:::relativize_path( c(p1, p2, file.path("notarealpath", "foo")), wd ) # expect_equal(unitizer:::relativize_path("/a/b/c/d/e/x.txt"), # "/a/b/c/d/e/x.txt") unitizer:::relativize_path("/a/b/c/d/e/x.txt", exists = TRUE) # ## This was too difficult to get to behave consistently across windows and # ## other platforms (see docs) # wd <- sub("^[a-zA-Z]:", "", getwd()) # all.equal( # unitizer:::relativize_path( # "/a/b/c/d/e/x.txt", only.if.shorter = FALSE, exists = TRUE # ), # do.call( # file.path, # c( # as.list( # rep( # "..", # length(unlist(strsplit(wd, .Platform$file.sep, fixed = TRUE))) - # 1L # ) ), # list("a/b/c/d/e/x.txt") # ) ) ) # - "path_clean" --------------------------------------------------------------- try(unitizer:::path_clean(list())) unitizer:::path_clean(file.path("a", "", "b", "c")) # - "unitizer:::merge_lists" --------------------------------------------------- unitizer:::merge_lists(list(a = 1, b = 2), list(c = 3)) unitizer:::merge_lists(list(a = 1, b = 2, c = 3), list(d = 5, c = 5)) unitizer:::merge_lists(list(a = 1, b = 2, c = 3), list(a = NULL, d = 5, c = 5)) # - "filename to storeid" ------------------------------------------------------ filename_to_storeid("tests.R") filename_to_storeid("tests.rock") # - "pretty_path" -------------------------------------------------------------- # not supposed to exist res <- unitizer:::pretty_path("xadfasdfxcfasdfasd") # warn if(FALSE) { # "fails CRAN" # expect_identical(res, "xadfasdfxcfasdfasd") res unitizer:::pretty_path(normalizePath(".")) unitizer:::pretty_path(file.path(system.file(package = "stats"), "DESCRIPTION")) } # - "quit" --------------------------------------------------------------------- # for some reason cover tests run via travis can't handle the with_mock, # so we just use truly-quit=FALSE; UPDATE (mabye du to compiler?) # with_mock( # quit=function(...) stop("quit!\n"), { # unitizer:::read_line_set_vals("y") # expect_error(capture.output(unitizer:::unitizer_quit()), "quit!") # unitizer:::read_line_set_vals("n") # capture.output(uq2 <- unitizer:::unitizer_quit()) # expect_equal(uq2, NULL) # unitizer:::read_line_set_vals(c("q", "q", "q", "q", "q", "q")) # expect_error(capture.output(unitizer:::unitizer_quit()), "quit!") # } # ) unitizer:::read_line_set_vals("y") capture.output(q.res.1 <- unitizer:::unitizer_quit(truly.quit = FALSE)) q.res.1 unitizer:::read_line_set_vals("n") capture.output(q.res.2 <- unitizer:::unitizer_quit(truly.quit = FALSE)) q.res.2 # FALSE unitizer:::read_line_set_vals(c("q", "q", "q", "q", "q", "q")) capture.output(q.res.3 <- unitizer:::unitizer_quit(truly.quit = FALSE)) q.res.3 unitizer:::read_line_set_vals(NULL) # - "mock_item" ---------------------------------------------------------------- is(mock_item(), "unitizerItem") # - "diff conditionList" ------------------------------------------------------- cond1 <- new("conditionList", .items = list(simpleWarning("hello", call = quote(fun())), simpleWarning("goodbye", call = quote(fun())))) is(diffobj::diffObj(cond1, cond1), "Diff") # - "Condition object structure" ----------------------------------------------- # We're assuming a particular structure for the condition object in # `faux_prompt` and `unitizer_prompt` so we put in a test here to make sure it # doesn't change cond <- simpleError("hello") is.list(cond) identical(names(cond), c("message", "call")) identical(class(cond), c("simpleError", "error", "condition")) # - "options" ------------------------------------------------------------------ # not great tests... old.opts <- options() new.opts <- unitizer:::options_zero() all(names(new.opts) %in% names(old.opts)) length(new.opts) <= length(old.opts) options(old.opts) unitizer/tests/zz-check.R0000644000176200001440000000003214766101222015122 0ustar liggesuserssource('aammrtf/check.R') unitizer/tests/testthat/0000755000176200001440000000000014766101222015126 5ustar liggesusersunitizer/tests/testthat/README0000644000176200001440000000010514766101222016002 0ustar liggesusersThis is dummy file to trigger the "subdirs" gentler check from CRAN. unitizer/tests/t-random.R0000644000176200001440000000072014766101222015131 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "random seed" -------------------------------------------------------------- dir <- file.path(TMP.DIR, "randdir") dir.create(dir) file <- file.path(dir, "randtest.R") cat("sample(1:100)\n", file = file) set.seed(1) coi(unitize(file, auto.accept = "new")) # changing seed should have no effect on result set.seed(23) coi(res <- unitize(file)) # expect_equal(as.character(res$status), "Passed") as.character(res$status) unitizer/tests/t-prompt.Rout.save0000644000176200001440000001560514766101222016667 0ustar liggesusers R Under development (unstable) (2021-11-21 r81221) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "read_line works" ---------------------------------------------------------- > > # read through prompt vals > > unitizer:::read_line_set_vals(letters[1:3]) > u.ns <- asNamespace("unitizer") > unitizer:::read_line() a [1] "a" > identical(u.ns$.global$prompt.vals, letters[2:3]) [1] TRUE > unitizer:::read_line() b [1] "b" > u.ns$.global$prompt.vals [1] "c" > unitizer:::read_line() c [1] "c" > u.ns$.global$prompt.vals character(0) > > try(unitizer:::read_line()) Error : Internal Error: ran out of predefined readline input; contact maintainer. > > # - "simple prompts" ----------------------------------------------------------- > > unitizer:::read_line_set_vals(c("y", "Y", "n", "N")) > try(unitizer:::simple_prompt(1:5)) Error in unitizer:::simple_prompt(1:5) : Argument `message` must be character > try(unitizer:::simple_prompt("hello", attempts = 1:5)) Error in unitizer:::simple_prompt("hello", attempts = 1:5) : Argument `attempts` must be numeric(1L), not NA, and one or greater > try(unitizer:::simple_prompt("hello", values = NA_character_)) Error in unitizer:::simple_prompt("hello", values = NA_character_) : Argument `values` must be character with no NAs > try(unitizer:::simple_prompt("hello", case.sensitive = 1)) Error in unitizer:::simple_prompt("hello", case.sensitive = 1) : Argument `case.sensitive` must be TRUE or FALSE > > unitizer:::simple_prompt("hello") | hello unitizer> y [1] "Y" > unitizer:::simple_prompt("hello")# | hello unitizer> Y [1] "Y" > unitizer:::simple_prompt("hello") | hello unitizer> n [1] "N" > unitizer:::read_line_set_vals(c("y", "y", "n")) > try(unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE)) | hello unitizer> y | Invalid input, please select one of: Y, N Error in unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE) : Gave up trying to collect user input after 1 attempts. > try(unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE), + silent = TRUE) | hello unitizer> y | Invalid input, please select one of: Y, N > try(unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE)) | hello unitizer> n | Invalid input, please select one of: Y, N Error in unitizer:::simple_prompt("hello", attempts = 1L, case.sensitive = TRUE) : Gave up trying to collect user input after 1 attempts. > > # - "faux prompt" -------------------------------------------------------------- > > unitizer:::read_line_set_vals(c("1 +", "1")) > unitizer:::faux_prompt(prompt = "> ", continue = "+ ")[[1L]] > 1 + + 1 1 + 1 > unitizer:::read_line_set_vals(c("(})")) > try(unitizer:::faux_prompt(prompt = "> ", continue = "+ ")) > (}) Error in "(})" : :1:2: unexpected '}' 1: (} ^ > > ## Test the new readLines based read_line > ## This test will not work in interactive mode, requiring input > unitizer:::read_line_set_vals(c("1 +", "1")) > unitizer:::faux_prompt() > 1 + + 1 expression(1 + 1) > > ## This one embeds a CTRL+C to test interrupt, but we can't test this without > ## read_line_setvals > unitizer:::read_line_set_vals(c("1 +", "\x03", "2 + ", "1")) > unitizer:::faux_prompt() > 1 + +  > 2 + + 1 expression(2 + 1) > > unitizer:::read_line_set_vals(c("\x03", "2 + ", "1")) > unitizer:::faux_prompt() >  | Type "Q" at the prompt to quit unitizer. > 2 + + 1 expression(2 + 1) > > ## Test that changing language doesn't affect partial parsing > lang <- Sys.getenv("LANGUAGE", unset=NA) > Sys.setenv("LANGUAGE"="fr") > unitizer:::read_line_set_vals(c("1 +", "1")) > unitizer:::faux_prompt(prompt = "> ", continue = "+ ") > 1 + + 1 expression(1 + 1) > if(is.na(lang)) Sys.unsetenv("LANGUAGE") else Sys.setenv("LANGUAGE"=lang) > > # - "unitizer prompt" ---------------------------------------------------------- > > # Some of this needs to be done outside of testthat due to sinking > suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) > unitizer:::read_line_set_vals(c("1 +", "1", "H", "Y")) > unitizer:::unitizer_prompt( + "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob + ) unitizer> 1 + + 1 [1] 2 unitizer> H | No help available. | | hello ([Y]es, [N]o, [Q]uit, [H]elp)? unitizer> Y [1] "Y" > > unitizer:::read_line_set_vals(c("1 +", "1", "H", "Q")) > unitizer:::unitizer_prompt("hello", + valid.opts = c(Y = "[Y]es", N = "[N]o"), help = "This is all the help you get", + global = glob) unitizer> 1 + + 1 [1] 2 unitizer> H | This is all the help you get | | hello ([Y]es, [N]o, [Q]uit, [H]elp)? unitizer> Q [1] "Q" > > unitizer:::read_line_set_vals(c("hell())", "Q")) > txt3 <- unitizer:::capture_output(unitizer:::unitizer_prompt("hello", + valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob)) > txt3$message [1] "Error in \"hell())\": :1:7: unexpected ')'" [2] "1: hell())" [3] " ^" > > # and multiline stuff (#242) > unitizer:::read_line_set_vals(c("{\n 1 + 1\n 2 + 1\n}", "N")) > unitizer:::unitizer_prompt( + "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob + ) unitizer> { 1 + 1 2 + 1 } [1] 3 unitizer> N [1] "N" > > try( + unitizer:::unitizer_prompt( + "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), + browse.env = "not an env", global = glob + ) ) Error in unitizer:::unitizer_prompt("hello", valid.opts = c(Y = "[Y]es", : Argument `browse.env` must be an environment > > unitizer:::read_line_set_vals(character()) > try( + unitizer:::unitizer_prompt( + "hello", valid.opts = c(Y = "[Y]es", N = "[N]o"), global = glob + ) ) Error : Internal Error: ran out of predefined readline input; contact maintainer. > unitizer:::read_line_set_vals("1L") > try( + unitizer:::unitizer_prompt( + "hello", + valid.opts = c(Y = "[Y]es", N = "[N]o"), + exit.condition = unitizer:::exit_fun, + valid.vals = 2:3, global = glob + ) ) unitizer> 1L | Type a number in `2:3` at the prompt [1] 1 Error : Internal Error: ran out of predefined readline input; contact maintainer. > unitizer:::read_line_set_vals("2L") > unitizer:::unitizer_prompt("hello", valid.opts = c(Y = "[Y]es", + N = "[N]o"), exit.condition = unitizer:::exit_fun, valid.vals = 2:3, + global = glob) unitizer> 2L [1] 2 > > unitizer/tests/t-random.Rout.save0000644000176200001440000000276514766101222016631 0ustar liggesusers R version 4.0.5 Patched (2021-05-28 r80517) -- "Shake and Throw" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "random seed" -------------------------------------------------------------- > > dir <- file.path(TMP.DIR, "randdir") > dir.create(dir) > file <- file.path(dir, "randtest.R") > cat("sample(1:100)\n", file = file) > set.seed(1) > coi(unitize(file, auto.accept = "new")) Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | Auto-accepting changes... | unitizer updated. > # changing seed should have no effect on result > set.seed(23) > coi(res <- unitize(file)) Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | 1/1 test passed; nothing to review. > # expect_equal(as.character(res$status), "Passed") > as.character(res$status) [1] "Passed" > > > proc.time() user system elapsed 1.456 0.128 1.612 unitizer/tests/t-translate.R0000644000176200001440000000710014766101222015645 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") test.file.dir <- file.path("_helper", "ref-objs", "translate") test.file <- file.path(test.file.dir, "testthat", "test-translate2.R") test.file.min <- file.path(test.file.dir, "testthat2", "test-translate-min.R") target.dir.base <- file.path(TMP.DIR, basename(tempfile())) target.dir <- file.path(target.dir.base, "helper", "translate", "unitizer") # - "Prompt to create dir" ----------------------------------------------------- try( testthat_translate_file( test.file, target.dir, prompt = "always", interactive.mode = FALSE ) ) # translations have to be outside of `testthat`; second translation should fail # except we allow manual input # - "translate a file" --------------------------------------------------------- unitizer:::capture_output({ unitizer:::read_line_set_vals(c("Y")) res1 <- testthat_translate_file(test.file, target.dir, prompt = "always", interactive.mode = TRUE) res1.txt <- readLines(res1) unitizer:::read_line_set_vals(c("Y")) res2 <- testthat_translate_file(test.file, target.dir, prompt = "overwrite", interactive.mode = TRUE) res2.txt <- readLines(res2) unitizer:::read_line_set_vals(NULL) }) dummy <- new("unitizerDummy") all.equal(res1.txt, rds("translate_res1")) all.equal(res1.txt, res2.txt) # Can't do this twice in a row without prompting in non-interactive mode # note test above does work because we use interactive mode to accept prompt any( grepl( "already exists", capture.output( try( testthat_translate_file( test.file, target.dir, prompt = "always", interactive.mode = FALSE ) ), type='message' ) ) ) untz <- get_unitizer(file.path(target.dir, "translate2.unitizer")) all.equal(untz@items.ref.calls.deparse, rds("translate_res2")) lapply(unitizer:::as.list(untz@items.ref), function(x) x@data@value[[1L]]) unlink(target.dir, recursive = TRUE) target.dir.base <- file.path(TMP.DIR, basename(tempfile())) target.dir <- file.path(target.dir.base, "_helper", "translate", "unitizer") test.dir <- file.path("_helper", "ref-objs", "translate", "testthat") # - "translate a dir" ---------------------------------------------------------- unitizer:::capture_output(res2 <- testthat_translate_dir(test.dir, target.dir)) all.equal(lapply(res2, readLines), rds("translate_res3")) untz <- get_unitizer(file.path(target.dir, "translate2.unitizer")) all.equal(untz@items.ref.calls.deparse, rds("translate_res4")) # Note not the same as when we did just the single file because the helper # file is loaded so `fun0` and `fun1` are actually defined lapply(unitizer:::as.list(untz@items.ref), function(x) x@data@value[[1L]]) # Can't do it again since there are files there any( grepl( "safety feature to ensure files are not accidentally overwritten", capture.output( try(testthat_translate_dir(test.dir, target.dir)), type='message' ) ) ) # - minimal -------------------------------------------------------------------- # to test parameters writeLines( readLines( testthat_translate_file( test.file.min, target.dir, prompt = "never", interactive.mode = TRUE, unitize = FALSE ) ) ) writeLines( readLines( testthat_translate_file( test.file.min, target.dir, prompt = "never", interactive.mode = TRUE, use.sects = FALSE, unitize = FALSE ) ) ) writeLines( readLines( testthat_translate_file( test.file.min, target.dir, prompt = "never", interactive.mode = TRUE, use.sects = FALSE, keep.testthat.call = FALSE, unitize = FALSE ) ) ) unitizer/tests/t-global.R0000644000176200001440000000147414766101222015120 0ustar liggesuserssource(file.path("_helper", "init.R")) # Most tests involving global are scattered all over the place, just putting a # few extra ones that are very specifically about global here # # - "Singleton Implementation Working" ----------------------------------------- invisible(unitizer:::unitizerGlobal$new()) # warn glob.first <- unitizer:::unitizerGlobal$new(set.global = TRUE) try(unitizer:::unitizerGlobal$new(set.global = TRUE)) try(unitizer:::unitizerGlobal$new()) glob.first$release() # - "Dummy Display" ------------------------------------------------------------ show(new("unitizerDummy")) # not recorded # - "Disable / Enable" --------------------------------------------------------- suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) glob$disable() glob$enable(c(search.path = 2L)) # warn state setting unitizer/tests/t-get.R0000644000176200001440000002465714766101222014447 0ustar liggesuserssource(file.path("_helper", "init.R")) source(file.path("aammrtf", "mock.R")) toy.path <- file.path("_helper", "unitizers", "misc.unitizer") toy.stor <- readRDS(file.path(toy.path, "data.rds")) # - "Error Cases" -------------------------------------------------------------- try(get_unitizer(1)) try(get_unitizer(letters)) try(get_unitizer("_helper")) try(get_unitizer("t-get.R")) try(set_unitizer(1)) try(set_unitizer(letters)) # 4.3 changed reporting of missing argument errors tryCatch(set_unitizer("a"), error=function(e) conditionMessage(e)) try(set_unitizer("a", "blergh")) !file.exists("a") # TRUE try(suppressWarnings(set_unitizer("tests/# ;!./# \\/", toy.stor))) # - "Get works as expected" ---------------------------------------------------- tmp.dir <- tempfile() dir.create(tmp.dir) tmp.sub.dir <- paste0(tmp.dir, "/get.test.dir") tmp.fake.utz <- paste0(tmp.dir, "/fake.unitizer") # expect_false(get_unitizer("asldkfjskfa")) get_unitizer("asldkfjskfa") # FALSE all.equal(get_unitizer(toy.path), toy.stor) is(toy.stor, "unitizer") dir.create(tmp.fake.utz) fake.utz <- file.path(tmp.fake.utz, "data.rds") cat("# this is not an RDS\n", file = fake.utz) # expect_error(capture.output(get_unitizer(tmp.fake.utz), type = "message"), # "Failed loading unitizer") try(capture.output(get_unitizer(tmp.fake.utz), type = "message")) tmp.sub.dir <- paste0(tmp.dir, "/get.test.dir") tmp.sub.dir2 <- paste0(tmp.dir, "/get.test.dir2") tmp.sub.dir3 <- paste0(tmp.dir, "/load.dirs") # - "Set works as expected" ---------------------------------------------------- dir.create(tmp.sub.dir) set_unitizer(tmp.sub.dir, toy.stor) all.equal(readRDS(paste0(tmp.sub.dir, "/data.rds")), toy.stor) just.a.file <- tempfile() on.exit(unlink(just.a.file)) cat("just a file\n", file = just.a.file) err <- capture.output(try(set_unitizer(just.a.file, toy.stor)), type='message') any(grepl('not a directory', err)) # - "load/store_unitizer" ------------------------------------------------------ # Several different stores in different states (i.e. requiring upgrade, # not unitizers, etc.) dir.create(tmp.sub.dir3) make.path <- lapply(file.path(tmp.sub.dir3, dir("_helper/ref-objs/load/")), dir.create) if (!all(unlist(make.path))) stop("Failed making paths") file.copy(list.files("_helper/ref-objs/load", full.names = TRUE), tmp.sub.dir3, recursive = TRUE) par.frame <- new.env() store.ids <- as.list(list.files(tmp.sub.dir3, full.names = TRUE)) # must be upgraded, but cannot load.try <- unitizer:::capture_output( try( unitizer:::load_unitizers(store.ids, rep(NA_character_, length(store.ids)), par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE ) ) ) any(grepl('could not be loaded', load.try$message)) any(grepl('could not be upgraded', load.try$message)) any(grepl('Cannot proceed', load.try$message)) # handle failure in store_unitizer, we just try this on one of the store ids out <- unitizer:::capture_output( unitizer:::load_unitizers( store.ids[4], rep(NA_character_, length(store.ids))[4], par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = TRUE, show.progress=0L, transcript=FALSE ) ) any(grepl('Upgraded test file does not match original', out$message)) # try weird store ids out <- unitizer:::capture_output( invalid.store <- try( unitizer:::load_unitizers( list(structure("hello", class = "unitizer_error_store")), NA_character_, par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE ) ) ) inherits(invalid.store, "try-error") any(grepl("returned something other than", out$message)) # Load mix of loadable and not loadable objects glob <- suppressWarnings(unitizer:::unitizerGlobal$new()) # with warning: "does not exist|test file does not") out <- unitizer:::capture_output( untzs <- try( unitizer:::load_unitizers( store.ids, rep(NA_character_, length(store.ids)), par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = TRUE, global = glob, show.progress=0L, transcript=FALSE ) ) ) inherits(untzs, "try-error") any(grepl('could not be loaded', out$message)) any(grepl('could not be upgraded', out$message)) any(grepl('Cannot proceed', out$message)) # Test failure of storage of a loaded and upgraded unitizers untzs <- unitizer:::load_unitizers( store.ids[4], NA_character_, par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = TRUE, global = glob, show.progress=0L, transcript=FALSE ) mock(unitizer:::set_unitizer, quote(stop("set fail"))) try(unitizer:::store_unitizer(untzs[[1]])) unmock(unitizer:::set_unitizer) # Try reloading already loaded unitisers reload <- unitizer:::as.list(untzs) # this creates a global object, hence warning untzs1a <- unitizer:::load_unitizers( reload, rep(NA_character_, length(reload)), par.frame = par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE ) all(vapply(unitizer:::as.list(untzs1a), is, logical(1L), "unitizer")) # misc tests # warning Instantiated global object without untzs2 <- unitizer:::load_unitizers( list(tmp.sub.dir2), NA_character_, par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE ) is(untzs2[[1L]], "unitizer") identical(parent.env(untzs2[[1L]]@zero.env), par.frame) # something that won't get reset on load so we can check our re-load untzs2[[1L]]@eval.time <- 33 unitizer:::store_unitizer(untzs2[[1L]]) # warning Instantiated global object without untzs2.1 <- unitizer:::load_unitizers( list(tmp.sub.dir2), NA_character_, par.frame, interactive.mode = FALSE, mode = "unitize", force.upgrade = FALSE, show.progress=0L, transcript=FALSE ) untzs2.1[[1L]]@eval.time # 33 unlink(c(tmp.sub.dir2, tmp.sub.dir3, tmp.sub.dir), recursive = TRUE) # - "is_package" --------------------------------------------------------------- unitizer:::is_package_dir(system.file(package = "stats")) unitizer:::is_package_dir(system.file(package = "methods")) ## Seems like some change now tests no longer installed by default with ## packages, at least in the unix distros, so can't easily test with ## has.tests==TRUE unitizer:::pretty_path(file.path(system.file(package = "stats"), "DESCRIPTION")) old.wd <- getwd() setwd(system.file(package = "stats")) unitizer:::pretty_path(file.path(system.file(package = "stats"), "DESCRIPTION")) unitizer:::pretty_path(file.path(system.file(package = "stats"))) setwd(old.wd) # just picked some folder we know will not work (No Desc) unitizer:::is_package_dir(file.path(system.file(package = "stats"), "R")) unitizer:::is_package_dir("ASDFASDF") unitizer:::is_package_dir(file.path(system.file(package = "unitizer"), "expkg", "baddescription1")) # *get_*package_dir pkg.f <- file.path(system.file(package = "unitizer"), "tests", "interactive", "run.R") length(unitizer:::get_package_dir(pkg.f)) == 1L length(unitizer:::get_package_dir(dirname(pkg.f))) == 1L f <- tempfile() cat("helloworld", file = f) length(unitizer:::get_package_dir(f)) == 0L unlink(f) # some more tests moved to t-demo.R to avoid reloading pkgs # - "is_unitizer_dir" ---------------------------------------------------------- base.dir <- file.path(system.file(package = "unitizer"), "expkg", "infer") unitizer:::is_unitizer_dir(base.dir) # FALSE unitizer:::is_unitizer_dir( file.path(base.dir, "tests", "unitizer", "infer.unitizer") ) # - "infer_unitizer_location" -------------------------------------------------- infer <- function(...) infer_unitizer_location(..., interactive.mode = FALSE) base.dir <- file.path(system.file(package = "unitizer"), "expkg", "infer") # Verify package is still in state we built tests on; need to sort b/c # different platforms have different lexical sorts identical( sort(c("aaa.R", "aaa.unitizer", "abc.R", "abc.unitizer", "inf.R", "inf.unitizer", "infer.R", "infer.unitizer", "zzz.R", "zzz.unitizer")), list.files(file.path(base.dir, "tests", "unitizer")) ) # Package dir unitizer:::capture_output(inf <- infer(base.dir)) basename(inf) unitizer:::capture_output(inf <- infer(base.dir, type = "d")) basename(inf) unitizer:::capture_output(inf <- infer(base.dir, type = "u")) basename(inf) inf.dir <- infer(file.path(base.dir, "*")) # warn identical(file.path(base.dir, "*"), inf.dir) unitizer:::capture_output(inf <- infer(file.path(base.dir, "z"))) basename(inf) unitizer:::capture_output(inf <- infer(file.path(base.dir, "z"), type = "u")) basename(inf) # Normal dir base.dir2 <- file.path(base.dir, "tests", "unitizer") # note don't need * to generate warning out <- unitizer:::capture_output(inf.dir2 <- infer(base.dir2)) # warn any(grepl("5 possible targets", out$message)) identical(base.dir2, inf.dir2) out <- unitizer:::capture_output(infer(file.path(base.dir2, "a"))) any(grepl("2 possible targets", out$message)) out <- unitizer:::capture_output(infer(file.path(base.dir2, "a"), type = "u")) any(grepl("2 possible targets", out$message)) out <- unitizer:::capture_output(fname <- basename(infer(file.path(base.dir2, "z")))) fname any(grepl('Inferred test file location:', out)) out <- unitizer:::capture_output( fname <- basename(infer(file.path(base.dir2, "z"), type="u")) ) fname any(grepl('Inferred unitizer location:', out)) # Random file without setting working dir first, in order for this to work # non-interactivel we need it to work with the R CMD check dir structure, # and possibly with the covr dir structure if (interactive()) infer("tests2") # Interactive mode unitizer:::read_line_set_vals(c("26", "Q")) # warn/output select <- unitizer:::infer_unitizer_location( file.path(base.dir, "*"), type = "f", interactive.mode = TRUE ) identical(select, file.path(base.dir, "*")) unitizer:::read_line_set_vals(c("5")) # output sel.loc <- unitizer:::infer_unitizer_location(file.path(base.dir, "*"), type = "f", interactive.mode = TRUE) basename(sel.loc) unitizer:::read_line_set_vals(NULL) # Non standard inferences # warn out <- unitizer:::capture_output( unitizer:::infer_unitizer_location(NULL, interactive = FALSE) ) any(grepl("too many to unambiguously", out$message)) fake.class <- structure(list(), class = "thisclassdoesn'texist") identical(infer(fake.class), fake.class) # no match since file can't exist (warn) f <- tempfile() out <- capture.output( invisible(unitizer:::infer_unitizer_location(f)), type='message' ) any(grepl("No possible matching files", out)) unlink(tmp.dir, recursive = TRUE) unitizer/tests/t-handledruns.Rout.save0000644000176200001440000000717014766101222017653 0ustar liggesusers R version 4.0.5 Patched (2021-05-28 r80517) -- "Shake and Throw" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "Ensure we get warning if we try to run in handlers" ----------------------- > > try(unitize("_helper/unitizers/trivial.R")) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | 4/4 tests passed; nothing to review. > tryCatch(unitize("_helper/unitizers/trivial.R")) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | 4/4 tests passed; nothing to review. > withRestarts(unitize("_helper/unitizers/trivial.R")) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Warning in history_capt(history, interactive.mode) : Unable to capture history in non-interactive mode. | 4/4 tests passed; nothing to review. > > # need to figure out why running this without `try` in covr causes cover to > # fail with > # Error in aggregate.data.frame(mf[1L], mf[-1L], FUN = FUN, ...) : > # no rows to aggregate > > # - "Ensure we get error if we try to do something stupid..." ------------------ > > try( + withRestarts( + unitize("_helper/unitizers/trivial.R"), + unitizerInteractiveFail = function() NULL + ) + ) Warning in check_call_stack() : It appears you are running unitizer inside an error handling function such as `withCallingHanlders`, `tryCatch`, or `withRestarts`. This is strongly dis- couraged as it may cause unpredictable behavior from unitizer in the event tests produce conditions / errors. We strongly recommend you re-run your tests outside of such handling functions. Error in check_call_stack() : "unitizerInteractiveFail" restart is already defined; unitizer relies on this restart to manage evaluation so unitizer will not run if it is defined outside of `unitize`. If you did not define this restart contact maintainer. > > > proc.time() user system elapsed 1.72 0.14 1.97 unitizer/tests/t-rename.R0000644000176200001440000000137514766101222015127 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "Rename Works" ------------------------------------------------------------- x <- readRDS("_helper/unitizers/trivial.unitizer/data.rds") x.edit <- editCalls(x, quote(x), quote(y), interactive.only = FALSE) x.edit@items.ref.calls.deparse !identical(x@items.ref.calls.deparse, x.edit@items.ref.calls.deparse) identical( x.edit@items.ref.calls.deparse, gsub("\\bx\\b", "y", x@items.ref.calls.deparse) ) # warn unitizer:::read_line_set_vals("Y") x.edit2 <- editCalls(x, quote(x), quote(y), interactive.mode = TRUE) # message unitizer:::read_line_set_vals("N") x.edit3 <- editCalls(x, quote(x), quote(y), interactive.mode = TRUE) identical(x.edit3, x) unitizer:::read_line_set_vals(NULL) x.edit@items.ref.calls.deparse unitizer/tests/t-list.R0000644000176200001440000001021014766101222014617 0ustar liggesuserssource(file.path("_helper", "init.R")) lst <- new("unitizerList") # - "unitizerList basic tests" ------------------------------------------------- length(lst) == 0L is(lst <- unitizer:::append(lst, 5), "unitizerList") length(lst) == 1L is( lst <- unitizer:::append( lst, list("booyah", list(1:3), matrix(1:9, nrow = 3)) ), "unitizerList" ) length(lst) == 4L is(lst[3L], "unitizerList") is(lst[[3L]], "list") lst <- unitizer:::append(lst, list(data.frame(a = letters[1:3])), 2L) is(lst[[3L]], "data.frame") length(lst[1:4]) == 4L lst[[4L]] <- "boo" is(lst[[4L]], "character") lst[4L:5L] <- letters[1:2] c(lst[[4L]], lst[[5L]]) lst[[4L]] is(unitizer:::as.list(lst), "list") length(unitizer:::as.list(lst)) == 5L is(unitizer:::as.expression(lst), "expression") try(unitizer:::getItem(lst)) # error lst <- unitizer:::nextItem(lst) unitizer:::getItem(lst) lst <- unitizer:::nextItem(lst) unitizer:::getItem(lst) lst <- unitizer:::prevItem(lst) unitizer:::getItem(lst) lst <<- lst # leftover from testthat testing? # - "unitizerList pointer seeking" --------------------------------------------- for (i in 1:10) lst <- unitizer:::nextItem(lst) try(unitizer:::getItem(lst)) unitizer:::done(lst) is(lst <- unitizer:::reset(lst, "back"), "unitizerList") try(unitizer:::reset(lst, letters)) try(unitizer:::reset(lst, NA_character_)) try(unitizer:::getItem(lst)) lst <- unitizer:::prevItem(lst) unitizer:::getItem(lst) == "b" while (!unitizer:::done(lst)) { item <- unitizer:::getItem(lst) lst <- unitizer:::prevItem(lst) } item == 5L try(unitizer:::getItem(lst)) withCallingHandlers( lst[[4]] <- "new value", warning = function() stop("A Warning!") ) for (i in 1:5) lst <- unitizer:::nextItem(lst) lst@.pointer # - "unitizerList value replacement and pointer adjustments" ------------------- lst[[4]] <- NULL lst@.pointer unitizer:::reset(lst, "back") lst.len <- length(lst) identical(lst@.pointer, lst.len) lst[2:3] <- letters[1:2] identical(lst@.pointer, lst.len) lst[2:3] <- list(NULL, NULL) identical(lst@.pointer, lst.len) lst[2:3] <- NULL identical(lst@.pointer, lst.len - 2L) lst <- unitizer:::reset(lst, "front") for (i in 1:2) lst <- unitizer:::nextItem(lst) curr.point <- lst@.pointer lst[[3]] <- NULL identical(curr.point, lst@.pointer) lst <- unitizer:::append(lst, list(5, 6, "blaskdjf"), 1L) identical(curr.point + 3L, lst@.pointer) lst <- unitizer:::append(lst, list(matrix(1:9, nrow = 3)), 5L) identical(curr.point + 3L, lst@.pointer) # - "Append Factors Works" ----------------------------------------------------- vec <- factor(letters[1:3], levels = letters) vec2 <- factor(letters[10:15], levels = letters) all.equal(structure(c(1L, 2L, 3L, 10L, 11L, 12L, 13L, 14L, 15L), .Label = c("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"), class = "factor"), append(vec, vec2)) all.equal(structure(c(1L, 2L, 10L, 11L, 12L, 13L, 14L, 15L, 3L), .Label = c("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"), class = "factor"), append(vec, vec2, 2)) all.equal(structure(c(10L, 11L, 12L, 13L, 1L, 2L, 3L, 14L, 15L), .Label = c("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"), class = "factor"), append(vec2, vec, 4)) try(append(vec2, vec, 20)) try(append(vec2, vec, -5)) # - "List coersion works even inside apply functions" -------------------------- ulist <- new("unitizerList", .items = list("a", 1, 2, "b")) identical(lapply(ulist, identity), ulist@.items) # - "Errors" ------------------------------------------------------------------- setClass("uhtsdfoqiuerhzb", slots = c(a = "integer")) dummy <- new("uhtsdfoqiuerhzb", a = 1L) lst2 <- new("unitizerList", .items = list(1, 2, 3)) try(append(lst2, 5, after = -1)) try(append(lst2, dummy)) lst3 <- new("unitizerList", .items = expression(1, 2, 3)) try(append(lst3, dummy)) # - "Set Names" ---------------------------------------------------------------- nlst <- new("unitizerList", .items = list(a = "a", b = "b")) names(nlst) <- toupper(names(nlst)) as.list(nlst) unitizer/tests/t-repairenvs.R0000644000176200001440000000517314766101401016035 0ustar liggesuserssource(file.path("_helper", "init.R")) exps <- expression(1 + 1, a <- 54, b <- 38, a + b, e <- 5 * a, a^2, f <- e * a, matrix(rep(f, 20))) my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) # add ref.exps as new items coi(my.unitizer <- my.unitizer + exps) my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env()) # now convert them to reference items coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new) # - "messed up env ancestry repair works" -------------------------------------- # # Purposefully mess up the environments # # UPDATE: these tests don't work since parent.env<- added checks for circular # # environment chains in r86545. We could probably restore functionality by # # using a different parent env but would have to figure out what the intended # # logic was. # parent.env(my.unitizer2@items.ref[[2]]@env) <- baseenv() # x <- unitizer:::healEnvs(my.unitizer2@items.ref, my.unitizer2) # old.opt <- options(unitizer.max.env.depth = 20) # res <- unitizer:::healEnvs(my.unitizer2@items.ref, my.unitizer2) # is(res, "unitizerItems") # ref.anc <- unitizer:::env_ancestry(x@base.env) # itm.anc <- unitizer:::env_ancestry(x[[1L]]@env) # # Items should belong to base env for reference # identical(rev(ref.anc), head(rev(itm.anc), length(ref.anc))) # options(old.opt) # - "re-assigning to ignored environments handled properly" -------------------- # now `a + b` could try to re-assign to `a <- 54`, but that is same env as # `a + b` b/c it is ignored items.picked <- my.unitizer@items.new[-3L] # expect_error(items.heal <- unitizer:::healEnvs(items.picked, # my.unitizer), NA) # no error items.heal <- unitizer:::healEnvs(items.picked, my.unitizer) # - "full repair process works" ------------------------------------------------ # copy files and then try messing up environment for the object file_test("-d", file.path("_helper")) store <- file.path("_helper", "unitizers", "trivial.unitizer") store.new <- file.path(TMP.DIR, store) dir.create(store.new, recursive = TRUE) cpy.files <- c( list.files(store, full.names = TRUE), file.path("helper", "unitizers", "trivial.R") ) file.copy(cpy.files, file.path(TMP.DIR, cpy.files), overwrite = TRUE) untz <- unitizer:::load_unitizers( list(store.new), NA_character_, par.frame = .GlobalEnv, interactive.mode = TRUE, mode = "unitize", show.progress=0L, transcript=FALSE ) # Break env chain, store, and reload untz[[1L]]@items.ref.calls.deparse[[5L]] parent.env(untz[[1L]]@items.ref[[5L]]@env) <- baseenv() # warning unitizer:::store_unitizer(untz[[1L]]) untz.rep <- repair_environments(store.new) # this should not give warnings unitizer:::healEnvs(untz.rep@items.ref, untz.rep) unitizer/tests/t-parse.Rout.save0000644000176200001440000005535714766101222016470 0ustar liggesusers R Under development (unstable) (2022-01-01 r81419) -- "Unsuffered Consequences" Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") > > txt <- "# This is an early comment\n\n hello <- 25\n\n # multi\n # line\n # comment\n\n matrix(1:9, 3) # and another!\n\n unitizer_sect(\"here is a section\", {\n # test that were not crazy\n\n 1 + 1 == 2 # TRUE hopefully\n\n # Still not crazy\n\n 2 * 2 == 2 ^ 2\n # Tada\n } )\n sample(1:10)\n\n # and this comment belongs to whom?\n\n runif(20)\n print(\"woo\") # and I?\n " > all <- unitizer:::parse_dat_get(text = txt) > prs <- all$expr > dat <- all$dat > dat$parent <- pmax(0L, dat$parent) > # With R4.0 some of the ids started changing > normalize_id <- function(dat) { + idu <- sort(unique(dat[["id"]])) + id <- with(dat, match(id, idu)) + parent <- with(dat, ifelse(parent == 0L, 0L, match(parent, + idu))) + dat[["id"]] <- id + dat[["parent"]] <- parent + dat + } > dat <- normalize_id(dat) > dat.split <- dat.split.2 <- par.ids.3 <- NULL > if.text <- "if # IFFY\n(x > 3 # ifcond\n){ hello\n #whome to attach?\n} else #final\ngoodbye" > > # - "Top Level Parents Identified Correctly" ----------------------------------- > > # "Identified top level parents?" > par.ids <- with(dat, unitizer:::top_level_parse_parents(id, parent)) > par.ids [1] 0 0 7 7 7 7 7 0 0 0 0 24 24 24 24 24 24 24 24 24 24 24 24 24 0 [26] 0 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 [51] 64 64 64 64 64 64 64 64 64 64 64 64 64 64 0 75 75 75 75 75 75 75 75 75 75 [76] 0 0 83 83 83 83 83 83 0 90 90 90 90 90 90 0 > dat.split <- split(dat, par.ids) > > # "Identified sub-level top level parents correctly" > par.ids.2 <- with(dat.split$`64`, unitizer:::top_level_parse_parents(id, + parent, 64L)) > par.ids.2 [1] 28 64 64 31 64 64 64 62 62 62 62 62 62 62 62 62 62 62 62 62 62 62 62 62 62 [26] 62 62 62 62 62 62 62 62 62 62 62 62 64 > dat.split.2 <- split(dat.split$`64`, par.ids.2) > > # "Parent relationships in `unitizer_sect` piece." > > par.ids.3 <- with(dat.split.2$`62`, unitizer:::top_level_parse_parents(id, + parent, 62L)) > par.ids.3 [1] 62 62 62 44 44 44 44 44 44 44 44 44 62 62 62 59 59 59 59 59 59 59 59 59 59 [26] 59 59 59 62 62 > > # - "Comments Are Assigned" ---------------------------------------------------- > > # "Did we assign comments correctly to topmost level?" > lapply(unitizer:::comments_assign(prs, dat.split$`0`), attr, "comment") [[1]] [1] "# This is an early comment" [[2]] [1] "# multi" "# line" "# comment" "# and another!" [[3]] NULL [[4]] NULL [[5]] [1] "# and this comment belongs to whom?" [[6]] [1] "# and I?" > > # "No comments here so no changes should occur" > all.equal(unitizer:::comments_assign(prs[[3]], dat.split.2$`64`), prs[[3]]) [1] TRUE > > # "Comments in `unitizer_sect` body assigned correctly" > lapply(unitizer:::comments_assign(prs[[3]][[3]], split(dat.split.2$`62`, + par.ids.3)$`62`), attr, "comment") [[1]] NULL [[2]] [1] "# test that were not crazy" "# TRUE hopefully" [[3]] [1] "# Still not crazy" > > # - "Ancestry Descend" --------------------------------------------------------- > > x <- unitizer:::parse_dat_get(text = "1 + 1; fun(x, fun(y + z))")$dat > x <- normalize_id(x) > > unitizer:::ancestry_descend(x$id, x$parent, 0) children level [1,] 7 0 [2,] 6 0 [3,] 26 0 [4,] 2 1 [5,] 3 1 [6,] 5 1 [7,] 10 1 [8,] 9 1 [9,] 13 1 [10,] 12 1 [11,] 24 1 [12,] 25 1 [13,] 1 2 [14,] 4 2 [15,] 8 2 [16,] 11 2 [17,] 16 2 [18,] 15 2 [19,] 23 2 [20,] 21 2 [21,] 14 3 [22,] 19 3 [23,] 18 3 [24,] 22 3 [25,] 17 4 [26,] 20 4 > > # - "Clean up Parse Data" ------------------------------------------------------ > > dat <- unitizer:::parse_dat_get(text = "{function(x) NULL;; #comment\n}")$dat > # set negative ids to be top level parents > dat <- transform(dat, parent = ifelse(parent < 0, 0L, parent)) > dat <- normalize_id(dat) > > # "Ancestry Descend" > dat.anc <- unitizer:::ancestry_descend(dat$id, dat$parent, 0L) > dat.anc children level [1,] 15 0 [2,] 1 1 [3,] 13 1 [4,] 12 1 [5,] 14 1 [6,] 11 2 [7,] 10 2 [8,] 9 3 [9,] 8 3 [10,] 2 4 [11,] 3 4 [12,] 4 4 [13,] 5 4 [14,] 7 4 [15,] 6 5 > > # "Excise `exprlist`" > unitizer:::prsdat_fix_exprlist(dat, dat.anc)$token [1] "expr" "'{'" "expr" "FUNCTION" [5] "'('" "SYMBOL_FORMALS" "')'" "NULL_CONST" [9] "expr" "COMMENT" "'}'" > > dat.1 <- unitizer:::parse_dat_get(text = "{1 ; ; ;2;}")$dat > # set negative ids to be top level parents > dat.1 <- transform(dat.1, parent = ifelse(parent < 0, 0L, parent)) > dat.1 <- normalize_id(dat.1) > > # "Another `exprlist` test" > unname( + as.list( + unitizer:::prsdat_fix_exprlist( + dat.1, + unitizer:::ancestry_descend(dat.1$id, dat.1$parent, 0L) + )[c("parent", "token")] + ) ) [[1]] [1] 0 14 3 14 10 14 14 [[2]] [1] "expr" "'{'" "NUM_CONST" "expr" "NUM_CONST" "expr" [7] "'}'" > dat.2 <- unitizer:::parse_dat_get(text = "{NULL; yowza; #comment\nhello\n}")$dat > # set negative ids to be top level parents > dat.2 <- transform(dat.2, parent = ifelse(parent < 0, 0L, parent)) > dat.2 <- normalize_id(dat.2) > > # "Yet another `exprlist`" > unname( + as.list( + unitizer:::prsdat_fix_exprlist( + dat.2, unitizer:::ancestry_descend(dat.2$id, dat.2$parent, 0L) + )[c("parent", "token")] + ) ) [[1]] [1] 0 13 3 13 7 13 13 11 13 13 [[2]] [1] "expr" "'{'" "NULL_CONST" "expr" "SYMBOL" [6] "expr" "COMMENT" "SYMBOL" "expr" "'}'" > > dat.2a <- normalize_id( + unitizer:::parse_dat_get(text = "for(i in x) {if(x) break else next}")$dat + ) > # "`for` cleanup" > > as.list(unitizer:::prsdat_fix_for(dat.2a[-1L, ])) $line1 [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 $col1 [1] 1 5 10 10 13 13 14 14 16 17 17 18 20 20 26 31 31 35 $line2 [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 $col2 [1] 3 5 10 10 35 13 34 15 16 17 17 18 24 24 29 34 34 35 $id [1] 1 3 5 7 22 9 21 10 11 12 14 13 15 16 17 18 19 20 $parent [1] 23 23 7 23 23 22 22 21 21 14 21 21 16 21 21 19 21 22 $token [1] "FOR" "SYMBOL" "SYMBOL" "expr" "expr" "'{'" "expr" "IF" [9] "'('" "SYMBOL" "expr" "')'" "BREAK" "expr" "ELSE" "NEXT" [17] "expr" "'}'" $terminal [1] TRUE TRUE TRUE FALSE FALSE TRUE FALSE TRUE TRUE TRUE FALSE TRUE [13] TRUE FALSE TRUE TRUE FALSE TRUE $text [1] "for" "i" "x" "" "" "{" "" "if" "(" [10] "x" "" ")" "break" "" "else" "next" "" "}" > > dat.3 <- normalize_id(unitizer:::parse_dat_get(text = if.text)$dat) > > # "`if` cleanup" > > unname(as.list(unitizer:::prsdat_fix_if(dat.3[-1, ])[c("id", "token")])) [[1]] [1] 1 2 11 4 6 5 7 8 9 17 12 13 14 15 16 19 20 21 [[2]] [1] "IF" "COMMENT" "expr" "SYMBOL" "expr" "GT" [7] "NUM_CONST" "expr" "COMMENT" "expr" "'{'" "SYMBOL" [13] "expr" "COMMENT" "'}'" "COMMENT" "SYMBOL" "expr" > > # - "Full Parse Works Properly" ------------------------------------------------ > > # "Full Comment Parse" > unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt)) [[1]] NULL [[2]] [[2]][[1]] [1] "# This is an early comment" [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] NULL [[2]][[4]] [[2]][[4]][[1]] NULL [[3]] [[3]][[1]] [1] "# multi" "# line" "# comment" "# and another!" [[3]][[2]] [[3]][[2]][[1]] NULL [[3]][[3]] [[3]][[3]][[1]] NULL [[3]][[3]][[2]] [[3]][[3]][[2]][[1]] NULL [[3]][[3]][[3]] [[3]][[3]][[3]][[1]] NULL [[3]][[3]][[4]] [[3]][[3]][[4]][[1]] NULL [[3]][[4]] [[3]][[4]][[1]] NULL [[4]] [[4]][[1]] NULL [[4]][[2]] [[4]][[2]][[1]] NULL [[4]][[3]] [[4]][[3]][[1]] NULL [[4]][[4]] [[4]][[4]][[1]] NULL [[4]][[4]][[2]] [[4]][[4]][[2]][[1]] NULL [[4]][[4]][[3]] [[4]][[4]][[3]][[1]] [1] "# test that were not crazy" "# TRUE hopefully" [[4]][[4]][[3]][[2]] [[4]][[4]][[3]][[2]][[1]] NULL [[4]][[4]][[3]][[3]] [[4]][[4]][[3]][[3]][[1]] NULL [[4]][[4]][[3]][[3]][[2]] [[4]][[4]][[3]][[3]][[2]][[1]] NULL [[4]][[4]][[3]][[3]][[3]] [[4]][[4]][[3]][[3]][[3]][[1]] NULL [[4]][[4]][[3]][[3]][[4]] [[4]][[4]][[3]][[3]][[4]][[1]] NULL [[4]][[4]][[3]][[4]] [[4]][[4]][[3]][[4]][[1]] NULL [[4]][[4]][[4]] [[4]][[4]][[4]][[1]] [1] "# Still not crazy" [[4]][[4]][[4]][[2]] [[4]][[4]][[4]][[2]][[1]] NULL [[4]][[4]][[4]][[3]] [[4]][[4]][[4]][[3]][[1]] NULL [[4]][[4]][[4]][[3]][[2]] [[4]][[4]][[4]][[3]][[2]][[1]] NULL [[4]][[4]][[4]][[3]][[3]] [[4]][[4]][[4]][[3]][[3]][[1]] NULL [[4]][[4]][[4]][[3]][[4]] [[4]][[4]][[4]][[3]][[4]][[1]] NULL [[4]][[4]][[4]][[4]] [[4]][[4]][[4]][[4]][[1]] NULL [[4]][[4]][[4]][[4]][[2]] [[4]][[4]][[4]][[4]][[2]][[1]] NULL [[4]][[4]][[4]][[4]][[3]] [[4]][[4]][[4]][[4]][[3]][[1]] NULL [[4]][[4]][[4]][[4]][[4]] [[4]][[4]][[4]][[4]][[4]][[1]] NULL [[5]] [[5]][[1]] NULL [[5]][[2]] [[5]][[2]][[1]] NULL [[5]][[3]] [[5]][[3]][[1]] NULL [[5]][[3]][[2]] [[5]][[3]][[2]][[1]] NULL [[5]][[3]][[3]] [[5]][[3]][[3]][[1]] NULL [[5]][[3]][[4]] [[5]][[3]][[4]][[1]] NULL [[6]] [[6]][[1]] [1] "# and this comment belongs to whom?" [[6]][[2]] [[6]][[2]][[1]] NULL [[6]][[3]] [[6]][[3]][[1]] NULL [[7]] [[7]][[1]] [1] "# and I?" [[7]][[2]] [[7]][[2]][[1]] NULL [[7]][[3]] [[7]][[3]][[1]] NULL > > # "EQ_SUB and SYMBOL_SUB test" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "structure(1:3, # the data\nclass # the label\n=#the equal sign\n'hello' # the class\n)" + ) ) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] [1] "# the data" [[2]][[3]][[2]] [[2]][[3]][[2]][[1]] NULL [[2]][[3]][[3]] [[2]][[3]][[3]][[1]] NULL [[2]][[3]][[4]] [[2]][[3]][[4]][[1]] NULL [[2]]$class [[2]]$class[[1]] [1] "# the label" "#the equal sign" "# the class" > > # "Function with `exprlist`" > > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "function(x #first arg\n, y=25 #second arg with default\n) {x + y; # first comment\n; yo #second comment\n x / y; #lastcomment \n;}" + ) ) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] [1] "#first arg" [[2]][[3]] [[2]][[3]][[1]] NULL [[2]][[3]]$x [[2]][[3]]$x[[1]] NULL [[2]][[3]]$y [[2]][[3]]$y[[1]] NULL [[2]][[4]] [[2]][[4]][[1]] [1] "#second arg with default" [[2]][[4]][[2]] [[2]][[4]][[2]][[1]] NULL [[2]][[4]][[3]] [[2]][[4]][[3]][[1]] [1] "# first comment" [[2]][[4]][[3]][[2]] [[2]][[4]][[3]][[2]][[1]] NULL [[2]][[4]][[3]][[3]] [[2]][[4]][[3]][[3]][[1]] NULL [[2]][[4]][[3]][[4]] [[2]][[4]][[3]][[4]][[1]] NULL [[2]][[4]][[4]] [[2]][[4]][[4]][[1]] [1] "#second comment" [[2]][[4]][[5]] [[2]][[4]][[5]][[1]] [1] "#lastcomment " [[2]][[4]][[5]][[2]] [[2]][[4]][[5]][[2]][[1]] NULL [[2]][[4]][[5]][[3]] [[2]][[4]][[5]][[3]][[1]] NULL [[2]][[4]][[5]][[4]] [[2]][[4]][[5]][[4]][[1]] NULL [[2]][[5]] [[2]][[5]][[1]] NULL [[2]][[5]][[2]] [[2]][[5]][[2]][[1]] NULL [[2]][[5]][[3]] [[2]][[5]][[3]][[1]] NULL [[2]][[5]][[4]] [[2]][[5]][[4]][[1]] NULL [[2]][[5]][[5]] [[2]][[5]][[5]][[1]] NULL [[2]][[5]][[6]] [[2]][[5]][[6]][[1]] NULL [[2]][[5]][[7]] [[2]][[5]][[7]][[1]] NULL [[2]][[5]][[8]] [[2]][[5]][[8]][[1]] NULL [[2]][[5]][[9]] [[2]][[5]][[9]][[1]] NULL > > # "`for` loop" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "for(i #in counter\nin 1:10#incounter again\n) {x + y; # first comment\n; next; yo #second comment\n x / y; break; #lastcomment \n;}" + ) ) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] [1] "#in counter" [[2]][[4]] [[2]][[4]][[1]] [1] "#incounter again" [[2]][[4]][[2]] [[2]][[4]][[2]][[1]] NULL [[2]][[4]][[3]] [[2]][[4]][[3]][[1]] NULL [[2]][[4]][[4]] [[2]][[4]][[4]][[1]] NULL [[2]][[5]] [[2]][[5]][[1]] NULL [[2]][[5]][[2]] [[2]][[5]][[2]][[1]] NULL [[2]][[5]][[3]] [[2]][[5]][[3]][[1]] [1] "# first comment" [[2]][[5]][[3]][[2]] [[2]][[5]][[3]][[2]][[1]] NULL [[2]][[5]][[3]][[3]] [[2]][[5]][[3]][[3]][[1]] NULL [[2]][[5]][[3]][[4]] [[2]][[5]][[3]][[4]][[1]] NULL [[2]][[5]][[4]] [[2]][[5]][[4]][[1]] NULL [[2]][[5]][[5]] [[2]][[5]][[5]][[1]] [1] "#second comment" [[2]][[5]][[6]] [[2]][[5]][[6]][[1]] NULL [[2]][[5]][[6]][[2]] [[2]][[5]][[6]][[2]][[1]] NULL [[2]][[5]][[6]][[3]] [[2]][[5]][[6]][[3]][[1]] NULL [[2]][[5]][[6]][[4]] [[2]][[5]][[6]][[4]][[1]] NULL [[2]][[5]][[7]] [[2]][[5]][[7]][[1]] [1] "#lastcomment " > > # "`if` statement" > unitizer:::comm_extract(unitizer:::parse_with_comments(text = if.text)) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] [1] "# IFFY" [[2]][[3]] [[2]][[3]][[1]] [1] "# ifcond" [[2]][[3]][[2]] [[2]][[3]][[2]][[1]] NULL [[2]][[3]][[3]] [[2]][[3]][[3]][[1]] NULL [[2]][[3]][[4]] [[2]][[3]][[4]][[1]] NULL [[2]][[4]] [[2]][[4]][[1]] NULL [[2]][[4]][[2]] [[2]][[4]][[2]][[1]] NULL [[2]][[4]][[3]] [[2]][[4]][[3]][[1]] NULL [[2]][[5]] [[2]][[5]][[1]] [1] "#final" > > # "formula" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = ". + x # hello\n#yowza\n~#bust a move\ny" + ) ) [[1]] NULL [[2]] [[2]][[1]] [1] "# hello" [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] NULL [[2]][[4]] [[2]][[4]][[1]] NULL [[3]] [[3]][[1]] [1] "#yowza" [[3]][[2]] [[3]][[2]][[1]] [1] "#bust a move" [[3]][[3]] [[3]][[3]][[1]] NULL > > # "`repeat`" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "repeat #first\n{runif(10); #comm\nbreak;}" + ) ) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] [1] "#first" [[2]][[3]] [[2]][[3]][[1]] NULL [[2]][[3]][[2]] [[2]][[3]][[2]][[1]] NULL [[2]][[3]][[3]] [[2]][[3]][[3]][[1]] [1] "#comm" [[2]][[3]][[3]][[2]] [[2]][[3]][[3]][[2]][[1]] NULL [[2]][[3]][[3]][[3]] [[2]][[3]][[3]][[3]][[1]] NULL [[2]][[3]][[4]] [[2]][[3]][[4]][[1]] NULL > > # "S4 slot" > unitizer:::comm_extract( + unitizer:::parse_with_comments(text = "test@#comment\nhello <- 3") + ) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] NULL [[2]][[3]][[2]] [[2]][[3]][[2]][[1]] [1] "#comment" [[2]][[3]][[3]] [[2]][[3]][[3]][[1]] NULL [[2]][[3]][[4]] [[2]][[3]][[4]][[1]] NULL [[2]][[4]] [[2]][[4]][[1]] NULL > > # "`while`" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "while(x > 5 # a comment\n) { hello; goodbye } #yay" + ) ) [[1]] NULL [[2]] [[2]][[1]] NULL [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] [1] "# a comment" [[2]][[3]][[2]] [[2]][[3]][[2]][[1]] NULL [[2]][[3]][[3]] [[2]][[3]][[3]][[1]] NULL [[2]][[3]][[4]] [[2]][[3]][[4]][[1]] NULL [[2]][[4]] [[2]][[4]][[1]] NULL [[2]][[4]][[2]] [[2]][[4]][[2]][[1]] NULL [[2]][[4]][[3]] [[2]][[4]][[3]][[1]] NULL [[2]][[4]][[4]] [[2]][[4]][[4]][[1]] NULL > > txt2 <- "library(functools)\n fun <- function(a=1, bravo, card=25, ..., xar=list(\"aurochs\", 1), z) {}\n\n # Need to add tests:\n # - with complex objects? (did I mean in the definition? Or the call??)\n (NULL)\n # These should be identical to match.call()\n\n body(fun) <- parse(text=\"{print(match_call()); print(match.call())}\")\n\n calls <- c(\n 'fun(54, \"hello\", \"wowo\", \"blergh\", 8, 9)',\n 'fun(54, \"hello\", \"wowo\", \"blergh\", a=8, z=9)',\n 'fun(54, \"hello\", z=\"wowo\", \"blergh\", 8, 9)',\n 'fun(54, \"hello\", z=\"wowo\", x=\"blergh\", 8, 9)',\n 'fun(54, c=\"hello\", z=\"wowo\", xar=3, 8, 9)'\n )\n invisible(lapply(calls, function(x){cat(\"-- New Call --\", x, sep=\"\n\"); eval(parse(text=x))}))\n " > test.comp <- unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt2)) > > # "A more complex test" > lapply(test.comp[4:5], `[[`, 1) [[1]] [1] "# Need to add tests:" [2] "# - with complex objects? (did I mean in the definition? Or the call??)" [[2]] [1] "# These should be identical to match.call()" > > # "Added SYMBOL_PACKAGE token" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "# a comment before\nunitizer:::browse() #a comment after" + ) ) [[1]] NULL [[2]] [[2]][[1]] [1] "# a comment before" "#a comment after" > # "Added SYMBOL_PACKAGE token v2" > unitizer:::comm_extract( + unitizer:::parse_with_comments( + text = "# a comment before\nunitizer::browse() #a comment after" + ) ) [[1]] NULL [[2]] [[2]][[1]] [1] "# a comment before" "#a comment after" > # LBB used to break stuff > txt3 <- "# This is an early comment\n hello <- 25\n # multi\n hello[[1]] # and another!" > # "LBB test" > unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt3)) [[1]] NULL [[2]] [[2]][[1]] [1] "# This is an early comment" [[2]][[2]] [[2]][[2]][[1]] NULL [[2]][[3]] [[2]][[3]][[1]] NULL [[2]][[4]] [[2]][[4]][[1]] NULL [[3]] [[3]][[1]] [1] "# multi" "# and another!" [[3]][[2]] [[3]][[2]][[1]] NULL [[3]][[3]] [[3]][[3]][[1]] NULL [[3]][[4]] [[3]][[4]][[1]] NULL > > # - "Weird missing comment on `res` works" ------------------------------------- > > txt3 <- "# Calls to `library` and assignments are not normally considered tests, so\n# you will not be prompted to review them\n\nlibrary(utzflm)\nx <- 1:100\ny <- x ^ 2\nres <- fastlm(x, y)\n\nres # first reviewable expression\nget_slope(res)\nget_rsq(res)\n\nfastlm(x, head(y)) # This should cause an error; press Y to add to store" > expr <- unitizer:::parse_with_comments(text = txt3) > my.unitizer <- new("unitizer", id = 1, zero.env = new.env()) > capture.output(my.unitizer <- my.unitizer + expr) character(0) > > lapply(unitizer:::as.list(my.unitizer@items.new), slot, "comment") [[1]] [1] "# Calls to `library` and assignments are not normally considered tests, so" [2] "# you will not be prompted to review them" [[2]] character(0) [[3]] character(0) [[4]] character(0) [[5]] [1] "# first reviewable expression" [[6]] character(0) [[7]] character(0) [[8]] [1] "# This should cause an error; press Y to add to store" > > # - "exprlist excission with negative par ids" --------------------------------- > > txt <- "# For random tests\n\nunitizer_sect(\"blah\", {\n identity(1);\n})\n" > prs.dat <- unitizer:::parse_dat_get(text = txt)$dat > # set negative ids to be top level parents > prs.dat <- transform(prs.dat, parent = ifelse(parent < 0, 0L, + parent)) > prs.dat <- normalize_id(prs.dat) > ancestry <- with(prs.dat, unitizer:::ancestry_descend(id, parent, + 0L)) > x <- unitizer:::prsdat_fix_exprlist(prs.dat, ancestry) > unname(as.matrix(x[, 5:6])) [,1] [,2] [1,] 1 0 [2,] 21 0 [3,] 2 4 [4,] 4 21 [5,] 3 21 [6,] 5 7 [7,] 7 21 [8,] 6 21 [9,] 19 21 [10,] 8 19 [11,] 15 19 [12,] 9 11 [13,] 11 15 [14,] 10 15 [15,] 12 13 [16,] 13 15 [17,] 14 15 [18,] 18 19 [19,] 20 21 > > # - "empty symbols handled okay" ----------------------------------------------- > > # the empty second argument to `[` caused problems before > txt <- "mtcars[1:10,]\n" > # shouldn't cause error > unitizer:::parse_with_comments(text = txt) expression(mtcars[1:10,]) > > # - "uncommenting works" ------------------------------------------------------- > > unitizer:::uncomment(expr[[1]]) library(utzflm) > > # "don't blow away function arg names" > unitizer:::uncomment(quote(function(a, b) NULL)) function(a, b) NULL > # > # Recover comments and uncomment > txt <- ".alike( # FALSE, match.call disabled\n quote(fun(b=fun2(x, y), 1, 3)), # first sub.call\n quote(fun(NULL, fun2(a, b), 1)), # second sub.call\n alike_settings(lang.mode=1))" > exp <- unitizer:::parse_with_comments(text = txt) > candc <- unitizer:::comm_and_call_extract(exp) > > candc$call[[1L]] .alike(quote(fun(b = fun2(x, y), 1, 3)), quote(fun(NULL, fun2(a, b), 1)), alike_settings(lang.mode = 1)) > > candc$comments [1] "# FALSE, match.call disabled" "# first sub.call" [3] "# second sub.call" > > # - "failing parses produce proper errors" ------------------------------------- > > txt <- "this is a + syntax error that cannot be parsed" > try(capture.output(unitizer:::parse_tests(text = txt), type = "message")) Error in value[[3L]](cond) : Unable to parse test file; see previous messages > f <- tempfile() > on.exit(unlink(f)) > cat(txt, "\n", sep = "", file = f) > try(capture.output(unitizer:::parse_tests(f), type = "message")) Error in value[[3L]](cond) : Unable to parse test file; see previous messages > # try in normal mode (just fall back to normal parse) > try(unitizer:::parse_tests(text = txt, comments = FALSE)) Error in parse(text = text, keep.source = FALSE) : :1:6: unexpected symbol 1: this is ^ > > any( + grepl( + "unexpected symbol", + capture.output(try(unitizer:::parse_tests(f, comments = FALSE)), type='message'), + ) ) [1] TRUE > > # - "NULL, constants, and new tokens" ------------------------------------------ > > # These were added with 3.6.3? Previously, it seems that the equal assign did > # not generate a master expression to wrap all the pieces, which means these > # tests just don't work because all the eq_assign at the top level end up with > # the same parent and the parser gets confused. > > txt <- c("a = 2", "# ho how", "b = 3", "", "b + a # oh here", + "", "b + # oh there", "a # bear", "", "NULL") > if(getRversion() >= "3.6.3") { + identical( + unitizer:::comm_extract(unitizer:::parse_with_comments(text = txt)), + rds('parse-eq') + ) + } else TRUE [1] TRUE > > with.const <- unitizer:::parse_with_comments(text = "3 # comment on const") > unitizer:::symb_mark_rem(with.const[[1]]) [1] 3 > > > proc.time() user system elapsed 1.103 0.115 1.228 unitizer/tests/t-utz1.R0000644000176200001440000002535714766101222014571 0ustar liggesusers# - "No Attach Test" ----------------------------------------------------------- f <- paste0(tempfile(), ".R") writeLines("1 + 1", f) try(unitizer::unitize(f)) unlink(f) # - "Usual Setup" -------------------------------------------------------------- source(file.path("_helper", "init.R")) source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("refobjs") source(file.path("_helper", "pkgs.R")) # - "custom history file" ------------------------------------------------------ # Random history file unitizer:::read_line_set_vals(c("1 + 1", "Y", "Y", "Y", "Y", "N")) hist.file <- tempfile() invisible( unitizer:::capture_output( unitize(FLM.TEST.FILE, interactive.mode = TRUE, history = hist.file) ) ) hist.dat <- readLines(hist.file) unlink(hist.file) # History only works in interactive mode if (interactive()) { identical(hist.dat, c("## (original history will be restored on exit)", "library(utzflm, lib.loc = getOption(\"unitizer.tmp.lib.loc\"))", "dat <- data.frame(x = 1:100, y = (1:100)^2)", "res <- fastlm(dat$x, dat$y)", "res", "1 + 1", "get_slope(res)", "get_rsq(res)", "fastlm(1:100, 1:10)")) } else { identical(hist.dat, character()) } # - "bad history" -------------------------------------------------------------- bad.hist <- try(unitize(FLM.TEST.FILE, history = list()), silent = TRUE) inherits(bad.hist, "try-error") conditionMessage(attr(bad.hist, "condition")) # - "bad seed" ----------------------------------------------------------------- # gsub needed b/c of inconsistent error calls in 3.3.2 and 3.4 old.opt <- options(unitizer.seed = "bad.seed") txtopt1 <- unitizer:::capture_output(try(unitize(FLM.TEST.FILE))) options(unitizer.seed = list("bad.seed")) txtopt2 <- unitizer:::capture_output(try(unitize(FLM.TEST.FILE))) # set.seed gained an argument c.a. R3.6 that caused error mismatch txtopt2$message[grepl("\\(function \\(seed", txtopt2$message, ignore.case = TRUE)] <- "" options(old.opt) unitizer:::clean_eval_exp(txtopt1) # supplied seed not valid int # unexpectedly exited; not clear why all stderr is not being captured by # capture_output... txtopt2 # - "create dir" --------------------------------------------------------------- # Unitizers in different directories that don't exist; also test using a # function to generate those directories get_store_id <- function(x) { file <- basename(x) dir <- dirname(dirname(x)) file.path(dir, "unitizer2", sub("(.*)\\.R", "\\1.unitizer", file)) } unitizer:::read_line_set_vals(c("N")) txt1 <- unitizer:::capture_output( untz1 <- try(unitize_dir(FLM.TEST.DIR, get_store_id, interactive.mode = TRUE)) ) unitizer:::read_line_set_vals(c("Y", "Q")) txt2 <- unitizer:::capture_output(untz2 <- unitize_dir(FLM.TEST.DIR, get_store_id, interactive.mode = TRUE)) inherits(untz1, "try-error") inherits(untz2, "unitizer_results") # Some of the text must be ablated rem_txt <- function(x) { crd <- grep("Create directory\\?", x) if (!length(crd)) stop("Logic Error: this must be a create directory test") x[-(2L:(crd[[1L]] - 1L))] } txt1$output <- rem_txt(txt1$output) txt2$output <- rem_txt(txt2$output) # must create the following directory # cannot proceed w/o creating directories txt1 txt2 # - print / dir ---------------------------------------------------------------- # quit from all at once unitizer:::read_line_set_vals(c("A", "QQ", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # Now test `unitize_dir`; we are testing all different combination of whether # a unitizer is accepted and updated # Review all # Accept all # Quit # Quit # Re-evalute # Review remaining # Accept all # Quit from review # Quit completely unitizer:::read_line_set_vals(c("A", "Y", "Y", "Y", "Y", "Y", "Q", "Q", "R", "A", "Y", "Y", "Q", "Q")) untz3a <- unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) untz3a.get.all <- vapply(get_unitizer(untz3a), class, character(1L)) identical(untz3a.get.all, c("unitizer", "unitizer", "logical")) print(untz3a) untz3a.first <- untz3a[[1L]] print(untz3a.first) identical(class(untz3a), "unitizer_results") identical( lapply(untz3a, class), replicate(3L, c("unitizer_result", "data.frame"), simplify = FALSE) ) untz3a.cpy <- untz3a # need to drop temp file attributes for tests for (i in seq_along(untz3a.cpy)) { attr(untz3a.cpy[[i]], "test.file") <- basename(attr(untz3a.cpy[[i]], "test.file")) attr(untz3a.cpy[[i]], "store.id") <- basename(attr(untz3a.cpy[[i]], "store.id")) } all.equal(untz3a.cpy, rds("unitize_res1")) # dummy class for errors untz3a.first.bad <- untz3a.first setClass("uhtsdfoqiuerhzb", slots=c(a='integer')) attr(untz3a.first.bad, "store.id") <- new("uhtsdfoqiuerhzb") print(untz3a.first.bad) # this is a bit contrived as it isn't possible to directly create an empty # unitize dir result untz3a.empty <- untz3a[0] class(untz3a.empty) <- class(untz3a) print(untz3a.empty) # Now accept the last remaining tests # unlink(list.files(test.dir, pattern="\\.unitizer$", full.names=TRUE), # recursive=TRUE) # Invalid input # Review third unitizer # Accept all # Re-eval and exit (again, not clear this is right thing to do) unitizer:::read_line_set_vals(c("3000", "3", "Y", "Y", "Y", "Y", "R")) untz3b <- unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) print(untz3b) identical( vapply(get_unitizer(untz3b), class, character(1L)), rep("unitizer", 3L) ) # - "namespace conflict" ------------------------------------------------------- # Namespace conflicts; unfortunately if either `covr` or `data.table` are # loaded this may not work quite right. Also as of `covr` 2.2.2 it seems that # the R session `covr` launches now seems to load the covr namespace. The # logic here ensures covr namespace is always loaded for this tests, if # possible. So we omit the line were what namespaces could not be unloaded are # mentioned. unitizer:::read_line_set_vals("Y") ns.conf1 <- unitizer:::capture_output( unitize_dir(FLM.TEST.DIR, state = "pristine", interactive.mode = TRUE) ) ns.conf1$message <- ns.conf1$message[-3] ns.conf1 unitizer:::read_line_set_vals("N") ns.conf2 <- unitizer:::capture_output( unitize_dir(FLM.TEST.DIR, state = "pristine", interactive.mode = TRUE) ) ns.conf2$message <- ns.conf2$message[-3] ns.conf2 # Non-interactive; also testing what happens when we run a test with errors # inside a try block try(unitize_dir(FLM.TEST.DIR, state = "pristine", interactive.mode = FALSE)) ns.conf3 <- unitizer:::capture_output( try( unitize( file.path(FLM.TEST.DIR, "fastlm2.R"), state = "pristine", interactive.mode = FALSE ) ) ) ns.conf3$message <- ns.conf3$message[-grep('unloaded', ns.conf3$message)] ns.conf3 # - "Removing Tests" ----------------------------------------------------------- # Removing tests; del2 has the same tests as del1, but with some removed extra.dir <- file.path(FLM.TEST.DIR, "..", "extra") unitize(file.path(extra.dir, "del1.R"), auto.accept = "new", interactive.mode = FALSE) unitizer:::read_line_set_vals(c("Y", "YY", "Y", "Y")) unitize( file.path(extra.dir, "del2.R"), store.id = file.path(extra.dir, "del1.unitizer"), interactive.mode = TRUE ) # - "navigate" ----------------------------------------------------------------- # Update `fastlm` to cause unitizers to fail, and go through the errors update_fastlm(FLM, version = "0.1.1") inst_pak(FLM) # Try navigating through the unitizer unitizer:::read_line_set_vals(c("P", "B", "3", "N", "U", "N", "N", "B", "U", "Q")) untz7a <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) attr(untz7a, "test.file") <- basename(attr(untz7a, "test.file")) attr(untz7a, "store.id") <- basename(attr(untz7a, "store.id")) path <- attr(untz7a, "test.file") path (path.norm <- unitizer:::normalize_path(path, mustWork=FALSE, exists=TRUE)) (rel.path <- unitizer:::relativize_path(path.norm, wd=NULL, only.if.shorter=TRUE, exists=TRUE)) (pkg.dir <- unitizer:::get_package_dir(path.norm, exists=TRUE)) untz7a # - "review dir" --------------------------------------------------------------- # list help, review first item, but do nothing unitizer:::read_line_set_vals(c("H", "1", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # incorrect selection unitizer:::read_line_set_vals(c("H", "4", "1", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # simulate slow unitizer review old.opt <- options(unitizer.prompt.b4.quit.time = 0) unitizer:::read_line_set_vals(c("H", "1", "Q", "Q", "Q", "Y")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) options(old.opt) # Failures in non-interactive mode (note, can't run on the actual "fastlm.R" # file b/c we need to do this under a `try`): try( unitize_dir(FLM.TEST.DIR, pattern = "unitize|fastlm2", interactive.mode = FALSE) ) # review all that need review, but don't do anything unitizer:::read_line_set_vals(c("A", "Q", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # review all, but don't do anything unitizer:::read_line_set_vals(c("AA", "Q", "Q", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # review one, and Re-eval despite no change unitizer:::read_line_set_vals(c("1", "R", "Y", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) unitizer:::read_line_set_vals(c("1", "RR", "Y", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # Test force eval # first run, force update and accept # second run, R from dir summary doesn't set bookmarks unitizer:::read_line_set_vals(c("1", "O", "Q", "Y", "R", "1", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # Variations on YY, YYY, and YYY unitizer:::read_line_set_vals(c("1", "YY", "Y", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) unitizer:::read_line_set_vals(c("1", "YYY", "Y", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) unitizer:::read_line_set_vals(c("1", "YYYY", "Y", "Q", "Q")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # review all, accepting all changes, and reevaluting everything; note that this # means we're accepting tests that are not correct unitizer:::read_line_set_vals(c("A", "Y", "Y", "Y", "Y", "Y", "Y", "RR")) unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE) # - "multi-sect" --------------------------------------------------------------- # Upgrade again, and try with deleted tests and other things update_fastlm(FLM, version = "0.1.2") inst_pak(FLM) unitizer:::read_line_set_vals(c("3", "ref(res)", "Y", "Y", "B", "1", "B", "U", "Y", "RR", "Y", "Q")) txt20 <- unitizer:::capture_output(unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE)) txt20$output <- gsub("^<\\w+: .*?>", "", txt20$output) txt20 # - "Load Fail" ---------------------------------------------------------------- # Purposefully mess up one of the unitizers to see if the load fail stuff works saveRDS(list(1, 2, 3), file.path(FLM.TEST.DIR, "fastlm1.unitizer", "data.rds")) try(unitize_dir(FLM.TEST.DIR, interactive.mode = TRUE)) unitizer:::read_line_set_vals(NULL) unitizer/tests/t-state.R0000644000176200001440000002243414766101222014777 0ustar liggesuserssource(file.path("_helper", "init.R")) options(unitizer.color = FALSE, width = 80L) # - "Random Seed" -------------------------------------------------------------- old.seed <- if (!exists(".Random.seed")) NULL else .Random.seed seed.dat <- getOption("unitizer.seed") suppressWarnings( untz.glob <- unitizer:::unitizerGlobal$new(enable.which = setNames(2L, "random.seed")) ) do.call(set.seed, seed.dat) new.seed <- .Random.seed state <- untz.glob$state() invisible(runif(10)) # see if we can reset state after this untz.glob$reset(state) identical(.Random.seed, new.seed) untz.glob$resetFull() if (is.null(old.seed)) { !isTRUE(exists(".Random.seed")) } else identical(old.seed, .Random.seed) # - "State Show" --------------------------------------------------------------- show(unitizer:::unitizerStatePristine()) # - "all.equal.unitizerDummy" -------------------------------------------------- dummy <- new("unitizerDummy") blah <- "hello" ref.txt <- "`.REF` value was not recorded, but `.NEW` value was; they are likely different" identical(all.equal(dummy, blah), ref.txt) all.equal(dummy, dummy) identical( all.equal(blah, dummy), "`.NEW` value was not recorded, but `.REF` value was; they are likely different" ) # testing S4 / S3 methods, first works, second doesn't since we can't # have an S3 generic with dispatch on 2nd arg identical( evalq(all.equal(new("unitizerDummy"), "hello"), getNamespace("stats")), ref.txt ) evalq(all.equal("hello", new("unitizerDummy")), getNamespace("stats")) # - "All Equal States" --------------------------------------------------------- # Doesn't seem like we're comparing these to anything? Maybe should look into # doing so? state.A <- new("unitizerGlobalState", search.path = letters[1:3], options = list(a = 5:7, b = new("unitizerDummy"), c = "hello"), working.directory = "a/b/c") state.B <- new("unitizerGlobalState", search.path = letters[1:3], options = list(a = 5:7, b = new("unitizerDummy"), d = "goodbye", c = new("unitizerDummy")), working.directory = new("unitizerDummy"), random.seed = 1:3) state.C <- new("unitizerGlobalState", search.path = letters, options = list(a = list(5, 6, 7), c = LETTERS), working.directory = new("unitizerDummy"), random.seed = 1:3) # just compare to A state.D <- new("unitizerGlobalState", search.path = letters[1:3], options = list(a = list(1, 2, 3), b = new("unitizerDummy"), c = "hello"), working.directory = "a/b/c") state.E <- new("unitizerGlobalState", options = setNames(as.list(1:20), head(letters, 20))) state.F <- new("unitizerGlobalState", options = setNames(as.list(1:20), tail(letters, 20))) # This one is supposed to return something non-character or TRUE when used # with the provided all.equal state.G <- new("unitizerGlobalState", options = list(a = structure(TRUE, class = "unitizer_glob_state_test"), b = 0)) state.H <- new("unitizerGlobalState", options = list(a = structure(FALSE, class = "unitizer_glob_state_test"), b = 2)) # - "as.state" ----------------------------------------------------------------- identical( unitizer:::as.state("recommended"), unitizer:::as.state(unitizer:::unitizerStateSuggested()) ) identical( unitizer:::as.state("suggested"), unitizer:::as.state(unitizer:::unitizerStateSuggested()) ) identical( unitizer:::as.state("pristine"), unitizer:::as.state(unitizer:::unitizerStatePristine()) ) # unitizerStateProcessed should produce the default object (which currently # is "off") all.equal( unitizer:::as.state(.GlobalEnv), unitizer:::as.state(unitizer:::unitizerStateSuggested(par.env = .GlobalEnv)) ) all.equal( unitizer:::as.state(in_pkg("stats")), unitizer:::as.state( unitizer:::unitizerStateSuggested(par.env = getNamespace("stats")) ) ) stats.lib <- file.path(system.file(package = "stats"), "R") all.equal( unitizer:::as.state(in_pkg(), test.files = stats.lib), unitizer:::as.state( unitizer:::unitizerStateSuggested(par.env = getNamespace("stats")) ) ) try(unitizer:::as.state(200)) state <- unitizer:::unitizerStateOff() # bypass validity method state@options <- 2L try(validObject(state)) # state raw conversions identical( unitizer:::as.state(unitizer:::unitizerStateRaw()), unitizer:::unitizerStateProcessed() ) identical( unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = "stats")), unitizer:::unitizerStateProcessed(par.env = getNamespace("stats")) ) state@options <- 0L state.proc <- unitizer:::as.unitizerStateProcessed(state) state.raw <- unitizer:::as.unitizerStateRaw(state.proc) is(state.raw, "unitizerStateRaw") all.equal( lapply(slotNames(state), slot, object = state.proc), lapply(slotNames(state.raw), slot, object = state.raw) ) try(unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = in_pkg()))) identical( unitizer:::as.state(unitizer:::unitizerStateRaw(par.env = in_pkg("stats"))), unitizer:::unitizerStateProcessed(par.env = getNamespace("stats")) ) try( unitizer:::as.state( unitizer:::unitizerStateRaw(par.env = in_pkg("asdfalkdfasd")) ) ) try( unitizer:::as.state( unitizer:::unitizerStateRaw(par.env = in_pkg("")), test.files = getwd() ) ) # impossible states state.obj <- unitizer:::unitizerStateRaw() state.obj@options <- 2L try(unitizer:::as.state(state.obj)) state.obj@namespaces <- 2L state.obj@search.path <- 1L try(unitizer:::as.state(state.obj)) # - "as.state_raw" ------------------------------------------------------------- old.opt.loc <- options(unitizer.state = .GlobalEnv) try(unitizer:::as.state_raw(.GlobalEnv)) options(unitizer.state = 42L) try(unitizer:::as.state_raw(.GlobalEnv)) state.raw <- unitizer:::as.unitizerStateRaw(unitizer:::unitizerStateOff()) state.proc <- unitizer:::as.unitizerStateProcessed(state.raw) my.env <- new.env() options(unitizer.state = state.raw) state.raw@par.env <- my.env all.equal(unitizer:::as.state_raw(my.env), state.raw) options(unitizer.state = state.proc) my.env <- new.env() state.proc@par.env <- my.env all.equal( unitizer:::as.state_raw(my.env), unitizer:::as.unitizerStateRaw(state.proc) ) options(old.opt.loc) # - "state" -------------------------------------------------------------------- # all these assume we set the options to be in recommended mode all.equal(state("stats"), unitizer:::unitizerStateSuggested(par.env = "stats")) all.equal( state(in_pkg("stats")), unitizer:::unitizerStateSuggested(par.env = in_pkg("stats")) ) all.equal( state(in_pkg()), unitizer:::unitizerStateSuggested(par.env = in_pkg()) ) all.equal( state(search.path = 1), unitizer:::unitizerStateSuggested(search.path = 1L) ) s1 <- unitizer:::unitizerStateSuggested(par.env = .GlobalEnv) for (i in setdiff(slotNames(s1), "par.env")) slot(s1, i) <- 0L s2 <- unitizer:::unitizerStateOff() all.equal(s1, s2) # invalid state try(state(search.path = 3)) try(state(options = 2, namespaces = 1)) try(state(namespaces = 2, search.path = 1)) state.inv <- unitizer:::unitizerStateProcessed() state.inv@options <- 2L try(unitizer:::as.state(state.inv)) state.inv@namespaces <- 2L try(unitizer:::as.state(state.inv)) # captured any(grepl("", capture.output(show(state(in_pkg()))))) any(grepl("", capture.output(show(state(in_pkg("stats")))))) any(grepl("namespace:stats", capture.output(show(state(asNamespace("stats")))))) # - "in_pkg" ------------------------------------------------------------------- try(in_pkg("")) identical(as.character(in_pkg()), "") identical(as.character(in_pkg("stats")), "") identical(capture.output(show(in_pkg())), "") try(unitizer:::in_pkg_to_env(in_pkg(), "/")) # - "merge states" ------------------------------------------------------------- trk.new <- new("unitizerGlobalTrackingStore", search.path = list(1, 2, 3), options = list("a", "b")) trk.ref <- new("unitizerGlobalTrackingStore", search.path = list(4, 5, 6), options = list("c", "d")) items <- new("unitizerItems") items <- items + new("unitizerItem", call = quote(1 + 1), glob.indices = new("unitizerGlobalIndices", search.path = 1L, options = 2L)) items <- items + new("unitizerItem", call = quote(2 + 1), glob.indices = new("unitizerGlobalIndices", search.path = 2L, options = 1L)) items <- items + new("unitizerItem", call = quote(1 * 1), reference = TRUE, glob.indices = new("unitizerGlobalIndices", search.path = 1L, options = 1L)) items <- items + new("unitizerItem", call = quote(2 * 1), reference = TRUE, glob.indices = new("unitizerGlobalIndices", search.path = 3L, options = 2L)) res <- unitizer:::mergeStates(items, trk.new, trk.ref) sapply(res$items, function(x) as.integer(slot(x, "glob.indices"))) s.n.to.check <- c("search.path", "options", "working.directory", "random.seed", "namespaces") sapply(s.n.to.check, slot, object = res$states) # No reference items items.no.ref <- items[1:2] identical( unitizer:::mergeStates(items.no.ref, trk.new, trk.ref), list(items = items.no.ref, states = trk.new) ) # No new items; note that we only remap the used states to the new state # which is why we need all the .mod objects items.no.new <- items[3:4] items.no.new.mod <- items.no.new items.no.new.mod[[2L]]@glob.indices@search.path <- 2L trk.ref.mod <- trk.ref trk.ref.mod@search.path[[2L]] <- NULL identical( unitizer:::mergeStates( items.no.new, new("unitizerGlobalTrackingStore"),trk.ref ), list(items = items.no.new.mod, states = trk.ref.mod) ) unitizer/tests/t-global.Rout.save0000644000176200001440000000500114766101222016573 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # Most tests involving global are scattered all over the place, just putting a > # few extra ones that are very specifically about global here > # > # - "Singleton Implementation Working" ----------------------------------------- > > invisible(unitizer:::unitizerGlobal$new()) # warn Warning in .Object$initialize(...) : Instantiated global object without global namespace registry; you should only see this warning you are using `repair_environments`. > glob.first <- unitizer:::unitizerGlobal$new(set.global = TRUE) > try(unitizer:::unitizerGlobal$new(set.global = TRUE)) Error in .Object$initialize(...) : Internal Error: global tracking object already exists; this should never happen; contact maintainer > try(unitizer:::unitizerGlobal$new()) Error in .Object$initialize(...) : Internal Error: global tracking object already exists; this should never happen; contact maintainer > glob.first$release() > > # - "Dummy Display" ------------------------------------------------------------ > > show(new("unitizerDummy")) # not recorded > > # - "Disable / Enable" --------------------------------------------------------- > > suppressWarnings(glob <- unitizer:::unitizerGlobal$new()) > glob$disable() An object of class "unitizerGlobalStatus" Slot "search.path": [1] 0 Slot "options": [1] 0 Slot "working.directory": [1] 0 Slot "random.seed": [1] 0 Slot "namespaces": [1] 0 > glob$enable(c(search.path = 2L)) # warn state setting Warning in glob$enable(c(search.path = 2L)) : State setting for `search.path` has already been disabled and cannot be re-enabled An object of class "unitizerGlobalStatus" Slot "search.path": [1] 0 Slot "options": [1] 0 Slot "working.directory": [1] 0 Slot "random.seed": [1] 0 Slot "namespaces": [1] 0 > > > proc.time() user system elapsed 0.775 0.109 0.887 unitizer/tests/t-text.R0000644000176200001440000001722614766101222014646 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "cap_first" ---------------------------------------------------------------- set.seed(1, "Mersenne-Twister") words <- replicate(2, paste0(sample(letters, 5), collapse = "")) WORDS <- toupper(words) unitizer:::cap_first(c("", letters[1:2], letters[25:26], words, WORDS)) unitizer:::decap_first(c("", letters[1:2], letters[25:26], words, WORDS)) # - "header" ------------------------------------------------------------------- try(unitizer:::header("hello world", letters)) try(unitizer:::header(letters, 1)) # - "word_wrap" ---------------------------------------------------------------- lorem1 <- "Today, with Kiernan on the stand offering confirmation, Howard walked the jury through the enormous amount of data pulled from Ulbricht's computer. Defense lawyers haven't had a chance yet to respond to this evidence—that will likely come tomorrow. The mountain they have to climb looks higher than ever, though. Last week, Ulbricht's lawyer outlined a defense in which Ulbricht walked away from the marketplace he created and was \"lured back.\" But what will explain the dozens of folders of data on this laptop, with data from the upper echelons of Silk Road management—mixed with the most intimate details of Ulbricht's personal life?" lorem2 <- "/Volumes/FIXED/folder1/folder2/folder.2345/folderabac/file.text.batch" lorem3 <- "\"untz.state.test\", \"add.smooth\", \"bitmapType\", \"browser\", \"browserNLdisabled\", \"CBoundsCheck\", \"check.bounds\", \"citation.bibtex.max\", \"continue\", \"contrasts\"" range(nchar(head(unitizer:::word_wrap(lorem1, 25L), -1L))) t.rn <- range(nchar(head(unitizer:::word_wrap(lorem1, 25L, 3L), -1L))) # for some reason can't get test to produce same thing in windows when # running all tests vs. single one at the prompt; the > 20 is a cop-out that # should catch both the expected case (23) and what actually happens when # you run the tests on windows # expect_true(min(t.rn) > 20 && max(t.rn) <= 25) min(t.rn) > 20 && max(t.rn) <= 25 unitizer:::word_wrap(substr(lorem1, 1, 147), 45L, 3L) unitizer:::word_wrap(substr(lorem1, 1, 147), 45L, 3L, FALSE) unitizer:::word_wrap(lorem2, 15L, 3L) unitizer:::word_wrap(lorem2, 15L, 8L) unitizer:::word_wrap(lorem3, 76L, 8L) unitizer:::word_wrap("hello sunset \nthere moonrise", width = 12L) x1 <- c("this is supposed to be a particularly long string\nthat allows us to test the behavior of bullets once we start seeing\nsome wrapping kicking in which was a problem once upon a time") unitizer:::word_wrap(x1, unlist = FALSE, width = 80L) com <- "# this is supposed to be a relatively long comment that will get re-flowed" old.opt <- options(crayon.enabled = FALSE) unitizer:::word_comment(com, width = 30L) unitizer:::word_wrap(c("\nhello\nthere", "\nhow")) # too narrow no.wrap <- "hello I won't be wrapped" unitizer:::word_wrap(no.wrap, width = 3) # warning options(old.opt) # - "bullets" ------------------------------------------------------------------ x <- c("there was once a time when the fantastic unicorns could fly", "bugs bunny ate carrots and drank milk while hunting ducks") xx <- unitizer:::UL(x) as.character(xx, width = 30L) print(xx, width = 80L) yy <- unitizer:::OL(x) as.character(yy, width = 30L) # hopefully always C locale collation in tests? sort(as.character(unitizer:::OL(rep(letters, 2), style = "LETTERS"))) xl <- as.list(x) y <- unitizer:::UL(c(xl, list(unitizer:::OL(c(xl, list(unitizer:::UL(x))))), "yowza it is raining toads today!")) as.character(y, width = 30) try(unitizer:::as.character.bullet(hello, 1:10)) # Extra args to word_wrap try(as.character(unitizer:::OL(c("hello", "there")), unlist = TRUE)) as.character(unitizer:::OL("asdfasdfqwerjhdfkasdfasdfasd"), width = 20L) as.character(unitizer:::OL("asdfasdfqwerjhdfkasdfasdfasd"), width = 20L, hyphens = FALSE) # - "substr_const" ------------------------------------------------------------- unitizer:::substr_cons(c("ab", "abcde", "abce"), 4L) unitizer:::substr_cons(c("ab", "abcde", "abce"), 4L, justify = "right") unitizer:::substr_cons(c("NEW", "PASS", "FAIL", "DELETED", "Error"), 4L) # - "str_reduce_unique" -------------------------------------------------------- str1 <- c("abcdef", "abcdefgh", "abcql") res1 <- c("def", "defgh", "ql") unitizer:::str_reduce_unique(str1) unitizer:::str_reduce_unique(str1, from = "right") str2 <- vapply(strsplit(str1, ""), function(x) paste0(rev(x), collapse = ""), "") res2 <- vapply(strsplit(res1, ""), function(x) paste0(rev(x), collapse = ""), "") all.equal(unitizer:::str_reduce_unique(str2, from = "right"), res2) unitizer:::str_reduce_unique("aaa") identical(unitizer:::str_reduce_unique(rep("aaa", 5L)), rep("", 5L)) # - "strtrunc" ----------------------------------------------------------------- str1 <- c(paste0(letters, collapse = ""), paste0(LETTERS, collapse = "")) unitizer:::strtrunc(str1, 10L) unitizer:::strtrunc(str1, 10L, from = "left") unitizer:::strtrunc(c("abc", "cab"), 3L) try(unitizer:::strtrunc(c("abc", "cab"), 2L)) # - "oneline" ------------------------------------------------------------------ dep <- c("res <- data %>% group_by(ID) %>% summarise(date2 = nth(date, ", " 2), time2 = nth(time, 2), first_date = first(date), last_date = last(date), ", " first_time = first(time), last_time = last(time))") unitizer:::one_line(dep) unitizer:::one_line(dep, 50) # - "let_comb_fun" ------------------------------------------------------------- (unitizer:::make_let_combn_fun(letters))(12) # - "cc" ----------------------------------------------------------------------- unitizer:::cc("a", "b") unitizer:::cc(c("a", "b"), "c") unitizer:::cc(c("a", "b"), "c", c = " ") # - "screen_out" --------------------------------------------------------------- string <- "once upon a time in a fairy land very far away lived a green dragon" unitizer:::screen_out(string, max.len = c(3L, 2L), width = 13L) # - "text_wrap" ---------------------------------------------------------------- try(unitizer:::text_wrap(list(1, 2, 3), 5)) try(unitizer:::text_wrap(letters, 1:3)) # - "capture_output" ----------------------------------------------------------- capt <- unitizer:::capture_output({ cat("hello") cat("goodbye", file = stderr()) }) capt sum(grepl("Output|Message", capture.output(print(capt)))) # - "meta_word_cat" ------------------------------------------------------------ unitizer:::meta_word_cat("hello") capture.output(unitizer:::meta_word_cat("hello", trail.nl = FALSE)) # Newline issues unitizer:::meta_word_cat("hello\n", sep = "") unitizer:::meta_word_cat("hello", "there") unitizer:::meta_word_cat("hello", "there", sep = " ") # - "meta_word_msg" ------------------------------------------------------------ unitizer:::meta_word_msg("hello") txt <- "hello there how are you this wraps" unitizer:::meta_word_msg(txt, width = 20) # legacy fun unitizer:::word_msg("hello") # - "desc" --------------------------------------------------------------------- obj1 <- list(a = iris, b = lm(dist ~ speed, cars), 1:10, matrix(letters, 2)) desc(obj1, 80) desc(obj1, 40) desc(iris, 80) desc(iris, 200) desc(list(NULL, 1L)) desc(NULL) unitizer:::desc(NULL) unitizer:::desc(lm(y ~ x, data.frame(y = 1:10, x = runif(10)))) unitizer:::desc(new("unitizerItem", call = quote(1 + 1), env = new.env())) unitizer:::desc(array(1:27, dim = rep(3, 3))) unitizer:::desc(data.frame(a = letters[1:10], b = 1:10, stringsAsFactors = TRUE)) # - "char_to_eng" -------------------------------------------------------------- unitizer:::char_to_eng(character(), "", "") unitizer:::char_to_eng(letters[1:4], "", "") unitizer:::char_to_eng(letters[1:2], "", "") unitizer:::char_to_eng(letters[1], "", "") unitizer:::char_to_eng(letters[1]) unitizer:::char_to_eng(letters[1:2]) unitizer/tests/t-nav.R0000644000176200001440000000063714766101222014444 0ustar liggesuserssource(file.path("_helper", "init.R")) nav <- file.path("_helper", "unitizers", "nav.R") # Simple navigation tests that don't require complex unitizers # - "Re-run bookmark" -----=---------------------------------------------------- # Relates to #278. Tests both Review and Browse unitizer:::read_line_set_vals( c("R", "Y", "B", "7", "R", "Y", "B", "9", "R", "Y", "Q") ) unitize(nav, interactive.mode=TRUE) unitizer/tests/t-error.Rout.save0000644000176200001440000000316514766101222016475 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > > # - "Test Error Diffs" --------------------------------------------------------- > > diffs <- new( + "unitizerItemTestsErrorsDiffs", + value = new("unitizerItemTestsErrorsDiff", + txt = "value", err = TRUE, diff = diffobj::diffChr(1, 2)) + ) > diffs$value@diff@target [1] 1 > diffs$value@diff@current [1] 2 > try(diffs$values) Error in .local(x, i, j, ...) : Argument `i` must be one of c("value", "conditions", "output", "message", "aborted", "state") > try(diffs[[NA]]) Error in .local(x, i, j, ...) : Argument `i` must be character(1L) and not NA > err <- new( + "unitizerItemTestsErrors", + value = new( + "unitizerItemTestError", compare.err = TRUE, value = c("compare", "error") + ) ) > # - "Show Test Error" ---------------------------------------------------------- > > is(unitizer:::as.Diffs(err)@value, "unitizerItemTestsErrorsDiff") [1] TRUE > > proc.time() user system elapsed 0.891 0.137 1.072 unitizer/tests/t-upgrade.R0000644000176200001440000001014314766101222015300 0ustar liggesuserssource(file.path("_helper", "init.R")) blat_vers <- function(x) sub("'\\d+(?:\\.\\d+)*'", "''", x) # - "Upgrade works" ------------------------------------------------------------ # this is also now tested as part of load unitizer <- get_unitizer(file.path("_helper", "unitizers", "trivial.unitizer.0.4.2")) try(validObject(unitizer, complete = TRUE)) as.character(unitizer@version) unitizer.up <- unitizer:::upgrade_internal(unitizer) # warning validObject(unitizer.up) identical(unitizer.up@version, as.character(packageVersion("unitizer"))) # - Upgrade Warnings in Unitize ------------------------------------------------ tdir <- tempfile() dir.create(tdir) dir.create(file.path(tdir, "trivial.unitizer")) file.copy(file.path("_helper", "unitizers", "trivial.R"), tdir) file.copy( file.path("_helper", "unitizers", "trivial.unitizer.0.4.2", "data.rds"), file.path(tdir, "trivial.unitizer") ) odir <- setwd(tdir) unitizer:::read_line_set_vals('N') out <- unitizer:::capture_output( try(unitize(file.path(tdir, "trivial.R"), interactive.mode=TRUE)) ) out[] <- lapply(out, blat_vers) out unitizer:::read_line_set_vals(c('Y','Q')) out <- unitizer:::capture_output( unitize(file.path(tdir, "trivial.R"), interactive.mode=TRUE) ) out[] <- lapply(out, blat_vers) out unitizer:::read_line_set_vals(NULL) setwd(odir) unlink(tdir, recursive=TRUE) # - Upgrade Multiple Unitizers Unitize ----------------------------------------- tdir <- tempfile() dir.create(tdir) dir.create(file.path(tdir, "trivial1.unitizer")) dir.create(file.path(tdir, "trivial2.unitizer")) file.copy( file.path("_helper", "unitizers", "trivial.R"), file.path(tdir, c("trivial1.R", "trivial2.R")) ) file.copy( file.path("_helper", "unitizers", "trivial.unitizer.0.4.2", "data.rds"), file.path(tdir, "trivial1.unitizer") ) file.copy( file.path("_helper", "unitizers", "trivial.unitizer.0.4.2", "data.rds"), file.path(tdir, "trivial2.unitizer") ) odir <- setwd(tdir) unitizer:::read_line_set_vals(c('Y','Q')) out <- unitizer:::capture_output( unitize_dir(tdir, interactive.mode=TRUE) ) out[] <- lapply(out, blat_vers) out unitizer:::read_line_set_vals(NULL) setwd(odir) unlink(tdir, recursive=TRUE) # - "Rename" ------------------------------------------------------------------- setClass("untzUpgrTest", slots = c(a = "character")) x <- new("untzUpgrTest", a = letters) validObject(x) setClass("untzUpgrTest", slots = c(b = "character")) try(validObject(x)) try(capture.output(unitizer:::renameSlot(x, "c", "b"), type = "message")) x.rename <- unitizer:::renameSlot(x, "a", "b") validObject(x.rename) # - "Later but valid version" -------------------------------------------------- test.file <- file.path(TMP.DIR, "tests.R") cat("1 + 1", file = test.file) unitizer:::capture_output(unitize(test.file, auto.accept = "new")) version <- unlist(strsplit(as.character(packageVersion("unitizer")), ".", fixed = TRUE)) version[1] <- as.character(as.numeric(version[1]) + 1) version.new <- paste0(version, collapse = ".") unitizer.rds <- readRDS(file.path(TMP.DIR, "tests.unitizer", "data.rds")) unitizer.rds@version <- version.new # this should work !nchar(unitizer:::unitizer_valid(unitizer.rds)) # now lets cause an error unitizer.rds@eval.time <- runif(5) grepl("NB: ", unitizer:::unitizer_valid(unitizer.rds)) # - "Failing Test w/ Upgrade" -------------------------------------------------- # Unitizer will fail, but also requires an upgrade. This ensures the failure is # shown despite the need for an upgrade. tdir <- tempfile() dir.create(tdir) dir.create(file.path(tdir, "fail-and-upgrade.unitizer")) file.copy(file.path("_helper", "unitizers", "fail-and-upgrade.R"), tdir) file.copy( file.path("_helper", "unitizers", "fail-and-upgrade.unitizer", "data.rds"), file.path(tdir, "fail-and-upgrade.unitizer") ) odir <- setwd(tdir) try(unitize(file.path("fail-and-upgrade.R"))) # Confirm upgrade needed capture.output(unitizer:::read_line_set_vals(c('Y', 'Q'))) out <- unitizer:::capture_output( unitize(file.path("fail-and-upgrade.R"), interactive.mode=TRUE) ) out[] <- lapply(out, blat_vers) out unitizer:::read_line_set_vals(NULL) setwd(odir) unlink(tdir, recursive=TRUE) unitizer/tests/t-demo.R0000644000176200001440000001233014766101222014575 0ustar liggesuserssource(file.path("aammrtf", "mock.R")) source(file.path("_helper", "init.R")) source(file.path("_helper", "pkgs.R")) # Mostly makes sure the demo steps work, but since it is a convenient way of # generating a unitizer with actual errors and so forth, we use it to test a few # other things as well in the context of those unitizers # - "in_pkg" ------------------------------------------------------------------- base.dir <- file.path(FLM, "tests", "extra") in.pkg.file <- file.path(base.dir, "inpkg.R") unitizer:::read_line_set_vals(c("Q")) txt1 <- unitizer:::capture_output(unitize(in.pkg.file, interactive.mode = TRUE)) # `sub` needed due to inconsistencies in R 3.4 and 3.3 for top level error # messages txt1$message <- sub("^Error.*:", "", txt1$message) txt1 unitizer:::read_line_set_vals(c("Q")) unitize(in.pkg.file, state = in_pkg(), interactive.mode = TRUE) unitizer:::read_line_set_vals(c("Q")) try(unitize(in.pkg.file, state = in_pkg("ASDFASDFA"), interactive.mode = TRUE)) # - "copy fastlm dir works" ---------------------------------------------------- sort(tolower(list.files("."))) readLines(file.path(".", "DESCRIPTION"))[[5L]] # v0.1.0 update_fastlm(".", version = "0.1.1") readLines(file.path(".", "DESCRIPTION"))[[5L]] update_fastlm(".", version = "0.1.2") readLines(file.path(".", "DESCRIPTION"))[[5L]] # - "show_file" ---------------------------------------------------------------- f <- tempfile() cat("this is a\ntest code\nfile\n", file = f) file.show <- capture.output(show_file(f)) file.show[[1L]] start.file <- grep("+---+-----------+", file.show, fixed = TRUE) length(start.file) # 2 writeLines(file.show[start.file[[1L]]:start.file[[2L]]]) unlink(f) # Run actual demo bits; note we want to force `interactive.mode=TRUE` so that # `read_line_vals` values are used as user input; note that until we fix # / rationalize how sinking behaves within unitizer when the standard streams # come in sunk, we won't be able to fully test everything, since for example # the display of the captured stdout just won't happen. # - "demo create worked" ------------------------------------------------------- # In tests, initial version of package should be 0.1.0; the test store # does not exist so it doesn't get overwritten with subsequent updates # Note the initial install happens in the test running script unitizer:::update_fastlm(".", version = "0.1.0") inst_pak(".") unitizer:::read_line_set_vals(c("Y", "Y", "Y", "Y", "Y")) untz <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) is(untz, "unitizer_result") print(untz) # Re-running doesn't change unitizer untz2 <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) print(untz2) # Rejecting failed tests does not change unitizer update_fastlm(".", version = "0.1.1") inst_pak(".") unitizer:::read_line_set_vals(c("N", "N", "Y")) unitizer:::capture_output( untz3 <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) ) print(untz3) # - "demo review" -------------------------------------------------------------- # review is always in interactive mode unitizer:::read_line_set_vals(c("5", "Q")) review(FLM.TEST.STORE) # - "use.diff" ----------------------------------------------------------------- # Use this opportunity to make sure `use.diff=FALSE` works as intended unitizer:::read_line_set_vals("Q") unitize(FLM.TEST.FILE, interactive.mode = TRUE, use.diff = FALSE) unitizer:::read_line_set_vals(c(".DIFF$state", "Q")) unitize(FLM.TEST.FILE, interactive.mode = TRUE, use.diff = FALSE) # - "failing diff" ------------------------------------------------------------- unitizer:::read_line_set_vals("Q") mock(diffobj::diffObj, quote(stop("A failing diff."))) unitize(FLM.TEST.FILE, interactive.mode = TRUE) unmock(diffobj::diffObj) # - "multi-accept" ------------------------------------------------------------- # Test what happens if we back out of a multi-accept unitizer:::read_line_set_vals(c("YY", "N", "Q")) unitize(FLM.TEST.FILE, interactive.mode = TRUE) # - "multi-input" -------------------------------------------------------------- # Or if we request to go to unreviewed when there are none unitizer:::read_line_set_vals(c("YY", "Y", "B", "U", "Q")) unitize(FLM.TEST.FILE, interactive.mode = TRUE) # - "warn in parse" ------------------------------------------------------------ # Make sure parse warnings are issued unitizer:::read_line_set_vals(c("-2147483648L", "Q")) txt8 <- unitizer:::capture_output(unitize(FLM.TEST.FILE, interactive.mode = TRUE)) any(grepl("qualified with L", txt8$message)) # - "demo changes" ------------------------------------------------------------- # # Now actually accept the changes unitizer:::read_line_set_vals(c("Y", "Y", "Y")) untz5 <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) unitizer:::read_line_set_vals(NULL) # - "get_package_dir" ---------------------------------------------------------- # These were in t-get but we moved them here to avoid re-loading pkgs.R unitizer:::get_package_dir(f) # empty test.dir.1 <- file.path(".", "utzflm.Rcheck", "utzflm", "R") identical( unitizer:::get_package_dir(test.dir.1), normalizePath(dirname(test.dir.1), winslash = "/") ) test.dir.2 <- file.path(".", "utzflm.Rcheck") identical( unitizer:::get_package_dir(file.path(test.dir.2, "tests", "tests.R")), normalizePath(file.path(test.dir.2, "utzflm"), winslash = "/") ) unitizer/tests/t-search.Rout.save0000644000176200001440000003355414766101222016616 0ustar liggesusers R Under development (unstable) (2022-02-01 r81609) -- "Unsuffered Consequences" Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("_helper", "init.R")) > source(file.path("_helper", "pkgs.R")) Install Packages Setup Demos > > unitizer.dummy.list <- list(A = 1, B = 2, C = 3) > unitizer.dummy.list.2 <- list(A = 13, B = 24, C = 35) > # can't unload `unitizer`, ruins `covr` > try(detach("package:unitizer"), silent = TRUE) > try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) > try(detach("package:unitizerdummypkg2", unload = TRUE), silent = TRUE) > while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) > state.set <- setNames(rep(2L, length(unitizer:::.unitizer.global.settings.names)), + unitizer:::.unitizer.global.settings.names) > library(unitizer) > library(unitizerdummypkg1, lib.loc = TMP.LIB) > library(unitizerdummypkg2, lib.loc = TMP.LIB) > > # - "Detecting packages" ------------------------------------------------------- > > unitizer:::is.loaded_package("package:unitizer") [1] TRUE > unitizer:::is.loaded_package("unitizer") # FALSE [1] FALSE > unitizer:::is.loaded_package("package:stats") [1] TRUE > try(unitizer:::is.loaded_package(1)) Error in unitizer:::is.loaded_package(1) : Argument `pkg.name` must be character 1L > try(unitizer:::is.loaded_package(letters)) Error in unitizer:::is.loaded_package(letters) : Argument `pkg.name` must be character 1L > unitizer:::is.loaded_package("Autoloads") # FALSE [1] FALSE > is.list(pkg.dat <- unitizer:::get_package_data()) [1] TRUE > all( + vapply( + pkg.dat, function(x) is.list(x) && identical(names(x), + c("names", "lib.loc", "version")), logical(1L) + ) ) [1] TRUE > > # - "Path Compression" --------------------------------------------------------- > > search.init.full <- unitizer:::search_as_envs() > search.init <- search.init.full$search.path > > head(unitizer:::compress_search_data(search.init.full), 3L) [1] ".GlobalEnv" "package:unitizerdummypkg2 (v0.1)" [3] "package:unitizerdummypkg1 (v0.1)" > > # - "Moving Objects on Search Path Works" -------------------------------------- > > if (length(search.init) < 6L) stop("Unexpetedly short search path") > untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, + set.global = TRUE) > > try(unitizer:::move_on_path(5L, 2L, untz.glob)) Error in unitizer:::move_on_path(5L, 2L, untz.glob) : old.pos > new.pos is not TRUE > try(unitizer:::move_on_path(1L, 2L, untz.glob)) Error in unitizer:::move_on_path(1L, 2L, untz.glob) : new.pos > 1L is not TRUE > unitizer:::move_on_path(2L, 5L, untz.glob) > # can't compare actual environments as they change when detached and > # re-attached > > all.equal( + names(unitizer:::search_as_envs()$search.path), + names(search.init[c(1L, 5L, 2L:4L, 6L:length(search.init))]) + ) [1] TRUE > # Now let's undo the previous move, by pushing second pack back to > # original position > for (i in rep(5L, 3L)) unitizer:::move_on_path(2L, 5L, untz.glob) > unitizer:::search_dat_equal(unitizer:::search_as_envs(), search.init.full) [1] TRUE > untz.glob$release() > > # - "Search Path Journaling Works" --------------------------------------------- > > try(detach("package:unitizer"), silent = TRUE) > try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) > try(detach("package:unitizerdummypkg2", unload = TRUE), silent = TRUE) > library(unitizer) > # Initialize a global tracking object. Doing it funny here because we don't > # want to run the search_path_trim command yet, and that would happen if we > # did a normal init > # will be modified later > search.ref <- NULL > search.init <- unitizer:::search_as_envs() > untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, + set.global = TRUE) > > stat.tpl <- new("unitizerGlobalStatus", search.path = 2L, working.directory = 2L, + options = 2L, random.seed = 2L, namespaces = 2L) > # these need to be done outside of `test_that` b/c `test_that` sets the > # rlang_trace_top_env option > st.0 <- untz.glob$indices.last > st.1 <- untz.glob$state() > > # Note, these are intended to be run without the shimming in place > identical(untz.glob$status, stat.tpl) [1] TRUE > > # state should only be recorded if it changes > st.0 An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 1 > identical(st.0, st.1) [1] TRUE > # Add a package > library("unitizerdummypkg1", lib.loc = TMP.LIB) > st.2 <- untz.glob$state() > # have two recorded states > st.2@search.path [1] 2 > # should have one more item > diff(sapply(untz.glob$tracking@search.path, function(x) length(x$search.path))) [1] 1 > environmentName(untz.glob$tracking@search.path[[2L]]$search.path[[2L]]) [1] "package:unitizerdummypkg1" > sp.tmp <- untz.glob$tracking@search.path > # note we compare attribute separately because subsetting drops them > identical(sp.tmp[[1L]]$search.path, sp.tmp[[2L]]$search.path[-2L]) [1] TRUE > > identical( + sp.tmp[[1L]]$ns.dat, + sp.tmp[[2L]]$ns.dat[names(sp.tmp[[2L]]$ns.dat) != "unitizerdummypkg1"] + ) [1] TRUE > # Add another package at a different position > library("unitizerdummypkg2", pos = 4L, lib.loc = TMP.LIB) > st.3 <- untz.glob$state() > diff(sapply(untz.glob$tracking@search.path, function(x) length(x$search.path))) [1] 1 1 > environmentName( + untz.glob$tracking@search.path[[st.3@search.path]]$search.path[[4L]] + ) [1] "package:unitizerdummypkg2" > # Attach a list > attach(unitizer.dummy.list) > search.ref <- untz.glob$state() > environmentName( + untz.glob$tracking@search.path[[search.ref@search.path]]$search.path[[2L]] + ) [1] "unitizer.dummy.list" > identical( + as.list( + untz.glob$tracking@search.path[[search.ref@search.path]]$search.path[[2L]] + ), + unitizer.dummy.list + ) [1] TRUE > # And one more, but modified > unitizer.dummy.list.2 <- list(A = 13, B = 24, C = 35) > attach(unitizer.dummy.list.2, pos = 4L, name = "unitizer.dummy.list") The following objects are masked _by_ unitizer.dummy.list (pos = 2): A, B, C > st.4 <- untz.glob$state() > curr.sp.ind <- untz.glob$indices.last@search.path > environmentName(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[4L]]) [1] "unitizer.dummy.list" > # Make sure search path is lining up > all.equal( + names(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path), search() + ) [1] TRUE > identical( + as.list(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[4L]]), + unitizer.dummy.list.2 + ) [1] TRUE > identical( + as.list(untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[2L]]), + unitizer.dummy.list + ) [1] TRUE > # should still point to same environment > identical( + untz.glob$tracking@search.path[[curr.sp.ind - 1L]]$search.path[[2L]], + untz.glob$tracking@search.path[[curr.sp.ind]]$search.path[[2L]] + ) [1] TRUE > # state shouldn't have changed > identical(untz.glob$state(), st.4) [1] TRUE > > # detach some stuff > # this is the first list > detach(2L) > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 6 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 3 > curr.sp.ind <- untz.glob$indices.last@search.path > identical( + untz.glob$tracking@search.path[[curr.sp.ind]]$search.path, + untz.glob$tracking@search.path[[curr.sp.ind - 1L]]$search.path[-2L] + ) [1] TRUE > detach("package:unitizerdummypkg2") > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 7 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 3 > curr.sp.ind <- untz.glob$indices.last@search.path > identical( + untz.glob$tracking@search.path[[curr.sp.ind]]$search.path, + untz.glob$tracking@search.path[[curr.sp.ind - 1L]]$search.path[-5L] + ) [1] TRUE > > # - "Resetting search path" ---------------------------------------------------- > > identical( + as.list(as.environment("unitizer.dummy.list")), unitizer.dummy.list.2 + ) [1] TRUE > # set to just after we added the original dummy list > untz.glob$reset(search.ref) An object of class "unitizerGlobalIndices" Slot "search.path": [1] 4 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 3 > identical(as.list(as.environment("unitizer.dummy.list")), unitizer.dummy.list) [1] TRUE > # Confirm we actually set to expected path > # NOTE: not sure if with updates this can work > all.equal( + names(unitizer:::search_as_envs()$search.path), + names(untz.glob$tracking@search.path[[search.ref@search.path]]$search.path) + ) [1] TRUE > # Reset to very beginning > untz.glob$resetFull() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 1 > untz.glob$release() > # compare with all.equal to make sure we use S4 method > unitizer:::search_dat_equal(unitizer:::search_as_envs(), search.init) [1] TRUE > > # - "Search Path Trim / Restore" ----------------------------------------------- > > search.init <- unitizer:::search_as_envs() > untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, + set.global = TRUE) > library(unitizerdummypkg1, lib.loc = TMP.LIB) > library(unitizerdummypkg2, lib.loc = TMP.LIB) > unitizer:::search_path_trim(global = untz.glob) > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 2 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 2 > sp.keep <- unitizer:::keep_sp_default() > identical( + search(), + sp.keep[match(names(search.init$search.path), sp.keep, nomatch = 0L)] + ) [1] TRUE > untz.glob$resetFull() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 1 > untz.glob$release() > unitizer:::search_dat_equal(unitizer:::search_as_envs(), search.init) [1] TRUE > try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) > try(detach("package:unitizerdummypkg2", unload = TRUE), silent = TRUE) > while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) > > # - "Loaded Namespaces don't cause issues" ------------------------------------- > > # had a problem earlier trying to re-attach namespaces > loadNamespace("unitizerdummypkg1", lib.loc = TMP.LIB) > untz.glob <- unitizer:::unitizerGlobal$new(enable.which = state.set, + set.global = TRUE) > unitizer:::search_path_trim(global = untz.glob) > unitizer:::namespace_trim(global = untz.glob) > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 2 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 2 > loadNamespace("unitizerdummypkg2", lib.loc = TMP.LIB) > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 3 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 3 > "unitizerdummypkg1" %in% loadedNamespaces() # FALSE [1] FALSE > "unitizerdummypkg2" %in% loadedNamespaces() [1] TRUE > untz.glob$resetFull() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 1 > untz.glob$release() > "unitizerdummypkg1" %in% loadedNamespaces() [1] TRUE > "unitizerdummypkg2" %in% loadedNamespaces() # FALSE [1] FALSE > unloadNamespace("unitizerdummypkg1") > > # - "Prevent Namespace Unload Works" ------------------------------------------- > > old.opt <- options(unitizer.namespace.keep = "unitizerdummypkg1") > loadNamespace("unitizerdummypkg1", lib.loc = TMP.LIB) > glb <- unitizer:::unitizerGlobal$new(set.global = TRUE) > glb$status@options <- 2L > unitizer:::unload_namespaces("unitizerdummypkg1", global = glb) NULL > glb$ns.opt.conflict@conflict [1] TRUE > glb$ns.opt.conflict@namespaces [1] "unitizerdummypkg1" > unloadNamespace("unitizerdummypkg1") > options(old.opt) > glb$release() > > # - "Generate unique names" ---------------------------------------------------- > > unitizer:::unitizerUniqueNames(list(search.path = c(goodbye = "0", + hello = "1", goodbye = "2", goodbye = "3"))) [1] "goodbye" "hello" "goodbye.1" "goodbye.2" > > # - "Fake Package Re-attach" --------------------------------------------------- > > # Make sure that aspects of search path management other than search path > # survive a failure caused by bad search path env (#252, #253). > > owd <- getwd() > test.f <- paste0(tempfile(), ".R") > writeLines(" + f <- tempfile() + dir.create(f) + setwd(f) + # Package assumed non-existing; R could disallow this in the future + # which could change the test. + attach(list(x=42), name='package:adfaadcxuqyojfnkfadsf') + 1 + 1", test.f) > out <- unitizer:::capture_output( + try(unitize(test.f, state='recommended', interactive.mode=FALSE)) + ) > any(grepl("mismatch between actual search path and tracked", out$message)) [1] TRUE > identical(owd, getwd()) # confirm working directory restored [1] TRUE > > > proc.time() user system elapsed 3.534 0.721 4.428 unitizer/tests/t-change.R0000644000176200001440000000111214766101222015072 0ustar liggesuserssource(file.path("_helper", "init.R")) # - "Construction works" ------------------------------------------------------- # invalid slot try(new("unitizerChanges", removed = 1:3)) # invalid/ got character try(new("unitizerChanges", failed = letters[1:2])) # - "Output as expected" ------------------------------------------------------- my.changes <- new("unitizerChanges", failed = c(1L, 10L), new = c(1L, 5L), removed = c(2L, 4L), corrupted = c(3L, 8L)) show(my.changes) # - "Length Works" ------------------------------------------------------------- length(my.changes) # 7 unitizer/tests/t-demo.Rout.save0000644000176200001440000006251114766101222016270 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("aammrtf", "mock.R")) > source(file.path("_helper", "init.R")) > source(file.path("_helper", "pkgs.R")) Install Packages Setup Demos > > # Mostly makes sure the demo steps work, but since it is a convenient way of > # generating a unitizer with actual errors and so forth, we use it to test a few > # other things as well in the context of those unitizers > > # - "in_pkg" ------------------------------------------------------------------- > > base.dir <- file.path(FLM, "tests", "extra") > in.pkg.file <- file.path(base.dir, "inpkg.R") > > unitizer:::read_line_set_vals(c("Q")) > txt1 <- unitizer:::capture_output(unitize(in.pkg.file, interactive.mode = TRUE)) > # `sub` needed due to inconsistencies in R 3.4 and 3.3 for top level error > # messages > txt1$message <- sub("^Error.*:", "", txt1$message) > txt1 - Output ----------------------------------------------------------------------- +------------------------------------------------------------------------------+ | unitizer for: extra/inpkg.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? # should fail normally, but return TRUE if run in fastlm > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > hidden_fun() unitizer> Q | unitizer unchanged. - Message ---------------------------------------------------------------------- could not find function "hidden_fun" | No changes recorded. > unitizer:::read_line_set_vals(c("Q")) > unitize(in.pkg.file, state = in_pkg(), interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: extra/inpkg.R | +------------------------------------------------------------------------------+ Pass Fail New - - 1 ........................... - - 1 - New -------------------------------------------------------------------------- | The following test is new. Add test to store ([Y]es, [N]o, [P]rev, [B]rowse, | [R]erun, [Q]uit, [H]elp)? # should fail normally, but return TRUE if run in fastlm > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > hidden_fun() [1] TRUE unitizer> Q | No changes recorded. | unitizer unchanged. > unitizer:::read_line_set_vals(c("Q")) > try(unitize(in.pkg.file, state = in_pkg("ASDFASDFA"), interactive.mode = TRUE)) Error in loadNamespace(name) : there is no package called 'ASDFASDFA' Error in in_pkg_to_env(x.raw@par.env, test.files) : Unable to load "ASDFASDFA" namespace to use as parent environment; see `? unitizerState` for instructions on how to specify a package namespace as a parent environment for tests. Error in as.state(state, test.files) : Unable to convert `par.env` value to a namespace environment Error in unitize_core(test.file.inf, list(store.id.inf), state = state, : Argument `state` could not be evaluated. > > # - "copy fastlm dir works" ---------------------------------------------------- > > sort(tolower(list.files("."))) [1] "description" "man" "namespace" "r" [5] "tests" "utzflm.rcheck" > readLines(file.path(".", "DESCRIPTION"))[[5L]] # v0.1.0 [1] "Version: 0.1.0" > update_fastlm(".", version = "0.1.1") > readLines(file.path(".", "DESCRIPTION"))[[5L]] [1] "Version: 0.1.1" > update_fastlm(".", version = "0.1.2") > readLines(file.path(".", "DESCRIPTION"))[[5L]] [1] "Version: 0.1.2" > > # - "show_file" ---------------------------------------------------------------- > > f <- tempfile() > cat("this is a\ntest code\nfile\n", file = f) > file.show <- capture.output(show_file(f)) > file.show[[1L]] [1] "+---------------+" > start.file <- grep("+---+-----------+", file.show, fixed = TRUE) > length(start.file) # 2 [1] 2 > writeLines(file.show[start.file[[1L]]:start.file[[2L]]]) +---+-----------+ | 1 | this is a | | 2 | test code | | 3 | file | +---+-----------+ > unlink(f) > > # Run actual demo bits; note we want to force `interactive.mode=TRUE` so that > # `read_line_vals` values are used as user input; note that until we fix > # / rationalize how sinking behaves within unitizer when the standard streams > # come in sunk, we won't be able to fully test everything, since for example > # the display of the captured stdout just won't happen. > > # - "demo create worked" ------------------------------------------------------- > > # In tests, initial version of package should be 0.1.0; the test store > # does not exist so it doesn't get overwritten with subsequent updates > # Note the initial install happens in the test running script > > unitizer:::update_fastlm(".", version = "0.1.0") > inst_pak(".") > unitizer:::read_line_set_vals(c("Y", "Y", "Y", "Y", "Y")) > untz <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail New - - 4 ........................... - - 4 - New -------------------------------------------------------------------------- | The 4 tests in this section are new. Add tests to store ([Y]es, [N]o, [P]rev, | [B]rowse, [R]erun, [Q]uit, [H]elp)? # Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # The `unitizer>` prompt is like the standard R prompt. You may # enter expressions such as `lm(y ~ x, dat)$coefficients`, or # `str(res)`. # # Once you are done reviewing, you need to tell `unitizer` you # accept the test by typing 'Y' at the prompt. Enter 'H' for help. > res intercept slope rsq -1717.000 101.000 0.939 attr(,"class") [1] "fastlm" unitizer> Y # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> Y > get_rsq(res) [1] 0.939 unitizer> Y # This last test is expected to cause an error; press 'Y' to # accept it so future checks can confirm the same error persists > fastlm(1:100, 1:10) Error in fastlm(1:100, 1:10) : Arguments `x` and `y` must be the same length. unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Adding 4 out of 4 new tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Y | unitizer updated. > is(untz, "unitizer_result") [1] TRUE > print(untz) Test File: tests/unitizer/fastlm1.R Store ID: tests/unitizer/fastlm1.unitizer id call ignored status user reviewed 1 1 library(utzflm, lib.loc = g... * New N FALSE 2 2 dat <- data.frame(x = 1:100... * New N FALSE 3 3 res <- fastlm(dat$x, dat$y) * New N FALSE 4 4 res New Y TRUE 5 5 get_slope(res) New Y TRUE 6 6 get_rsq(res) New Y TRUE 7 7 fastlm(1:100, 1:10) New Y TRUE > # Re-running doesn't change unitizer > untz2 <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) | 4/4 tests passed; nothing to review. > print(untz2) Test File: tests/unitizer/fastlm1.R Store ID: tests/unitizer/fastlm1.unitizer id call ignored status user reviewed 1 1 library(utzflm, lib.loc = g... * Passed Y FALSE 2 2 dat <- data.frame(x = 1:100... * Passed Y FALSE 3 3 res <- fastlm(dat$x, dat$y) * Passed Y FALSE 4 4 res Passed Y FALSE 5 5 get_slope(res) Passed Y FALSE 6 6 get_rsq(res) Passed Y FALSE 7 7 fastlm(1:100, 1:10) Passed Y FALSE You chose NOT to save these changes to the unitizer store > # Rejecting failed tests does not change unitizer > update_fastlm(".", version = "0.1.1") > inst_pak(".") > > unitizer:::read_line_set_vals(c("N", "N", "Y")) > unitizer:::capture_output( + untz3 <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) + ) > print(untz3) Test File: tests/unitizer/fastlm1.R Store ID: tests/unitizer/fastlm1.unitizer id call ignored status user reviewed 1 1 library(utzflm, lib.loc = g... * Failed N FALSE 2 2 dat <- data.frame(x = 1:100... * Failed N FALSE 3 3 res <- fastlm(dat$x, dat$y) * Failed N FALSE 4 4 res Failed N TRUE 5 5 get_slope(res) Failed N TRUE 6 6 get_rsq(res) Passed Y FALSE 7 7 fastlm(1:100, 1:10) Passed Y FALSE You chose NOT to save these changes to the unitizer store > > # - "demo review" -------------------------------------------------------------- > > # review is always in interactive mode > unitizer:::read_line_set_vals(c("5", "Q")) > review(FLM.TEST.STORE) +------------------------------------------------------------------------------+ | unitizer for: tests/unitizer/fastlm1.unitizer | +------------------------------------------------------------------------------+ *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . . Passed:- 5. get_slope(res) . . . . . . . . . . . . . . . . Passed:- 6. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> 5 - Passed ----------------------------------------------------------------------- | The 4 tests in this section passed. Keep tests in store ([Y]es, [N]o, [P]rev, | [B]rowse, [Q]uit, [H]elp)? # There are three more tests to review; accept them with 'Y' > get_slope(res) [1] 101 unitizer> Q | No changes recorded. | unitizer unchanged. > > # - "use.diff" ----------------------------------------------------------------- > > # Use this opportunity to make sure `use.diff=FALSE` works as intended > unitizer:::read_line_set_vals("Q") > unitize(FLM.TEST.FILE, interactive.mode = TRUE, use.diff = FALSE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: [1] "Mean relative difference: 1.99e+10" | State mismatch; see `.NEW$state` and `.REF$state`. unitizer> Q | No changes recorded. | unitizer unchanged. > unitizer:::read_line_set_vals(c(".DIFF$state", "Q")) > > unitize(FLM.TEST.FILE, interactive.mode = TRUE, use.diff = FALSE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: [1] "Mean relative difference: 1.99e+10" | State mismatch; see `.NEW$state` and `.REF$state`. unitizer> .DIFF$state | State mismatch: Attributes: < Component "search.path": 1 string mismatch > unitizer> Q | No changes recorded. | unitizer unchanged. > > # - "failing diff" ------------------------------------------------------------- > > unitizer:::read_line_set_vals("Q") > mock(diffobj::diffObj, quote(stop("A failing diff."))) > unitize(FLM.TEST.FILE, interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" Error in diffObj(curr.err@.ref, curr.err@.new, tar.banner = make_cont(".ref"), : A failing diff. | Value: | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. > unmock(diffobj::diffObj) > > # - "multi-accept" ------------------------------------------------------------- > > # Test what happens if we back out of a multi-accept > > unitizer:::read_line_set_vals(c("YY", "N", "Q")) > unitize(FLM.TEST.FILE, interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> YY 4. res . . . . . Failed:- 5. get_slope(res) . Failed:- Choose 'Y' for the 2 tests shown above ([Y]es, [N]o)? unitizer> N # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Q | No changes recorded. | unitizer unchanged. > > # - "multi-input" -------------------------------------------------------------- > > # Or if we request to go to unreviewed when there are none > unitizer:::read_line_set_vals(c("YY", "Y", "B", "U", "Q")) > unitize(FLM.TEST.FILE, interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> YY 4. res . . . . . Failed:- 5. get_slope(res) . Failed:- Choose 'Y' for the 2 tests shown above ([Y]es, [N]o)? unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> B *1. library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . . Failed:Y 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:Y 6. get_rsq(res) . . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- | What test do you wish to review (input a test number, [U]nreviewed)? unitizer> U | No unreviewed tests. = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Q | Changes discarded. | unitizer unchanged. > > # - "warn in parse" ------------------------------------------------------------ > > # Make sure parse warnings are issued > unitizer:::read_line_set_vals(c("-2147483648L", "Q")) > txt8 <- unitizer:::capture_output(unitize(FLM.TEST.FILE, + interactive.mode = TRUE)) > > any(grepl("qualified with L", txt8$message)) [1] TRUE > > # - "demo changes" ------------------------------------------------------------- > # > # Now actually accept the changes > unitizer:::read_line_set_vals(c("Y", "Y", "Y")) > untz5 <- unitize(FLM.TEST.FILE, interactive.mode = TRUE) +------------------------------------------------------------------------------+ | unitizer for: unitizer/fastlm1.R | +------------------------------------------------------------------------------+ Pass Fail 2 2 ...................... 2 2 - Failed ----------------------------------------------------------------------- | The 2 tests in this section failed because the new evaluations do not match | the reference values from the store. Overwrite with new results ([Y]es, [N]o, | [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? > library(utzflm, lib.loc = getOption("unitizer.tmp.lib.loc")) > dat <- data.frame(x = 1:100, y = (1:100)^2) > res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res intercept slope rsq -3.54e+13 7.01e+11 9.39e-01 attr(,"class") [1] "fastlm" | Value mismatch: < .ref > .new @@ 1,4 @@ @@ 1,4 @@ intercept slope rsq intercept slope rsq < -1717.000 101.000 0.939 > -3.54e+13 7.01e+11 9.39e-01 attr(,"class") attr(,"class") [1] "fastlm" [1] "fastlm" | State mismatch; see `.DIFF$state` for details. unitizer> Y # This one is also incorrect; reject with 'N' > get_slope(res) [1] 7.01e+11 | Value mismatch: < .ref > .new @@ 1 @@ @@ 1 @@ < [1] 101 > [1] 7.01e+11 | State mismatch; see `.DIFF$state` for details. unitizer> Y = Finalize Unitizer ============================================================ | You will IRREVERSIBLY modify 'unitizer/fastlm1.unitizer' by: | - Replacing 2 out of 2 failed tests | Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> Y | unitizer updated. > unitizer:::read_line_set_vals(NULL) > > # - "get_package_dir" ---------------------------------------------------------- > > # These were in t-get but we moved them here to avoid re-loading pkgs.R > > unitizer:::get_package_dir(f) # empty character(0) > test.dir.1 <- file.path(".", "utzflm.Rcheck", "utzflm", "R") > identical( + unitizer:::get_package_dir(test.dir.1), + normalizePath(dirname(test.dir.1), winslash = "/") + ) [1] TRUE > test.dir.2 <- file.path(".", "utzflm.Rcheck") > identical( + unitizer:::get_package_dir(file.path(test.dir.2, "tests", "tests.R")), + normalizePath(file.path(test.dir.2, "utzflm"), winslash = "/") + ) [1] TRUE > > proc.time() user system elapsed 11.66 2.41 15.16 unitizer/tests/aammrtf/0000755000176200001440000000000014766101222014715 5ustar liggesusersunitizer/tests/aammrtf/ref.R0000644000176200001440000000512314766101222015615 0ustar liggesusers# Copyright (C) 2022 Brodie Gaslam # This file is part of "aammrtf - An Almost Most Minimal R Test Framework" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 or 3 of the License. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. ## Generate Reference Object Accessor Functions ## ## Helper functions to simplify reading and writing reference files. You will ## need to create the target directory, which by default is "aammrtf-ref-objs". ## The expectation is that this will be a subdirectory to "pkg/tests". ## ## @param name character(1) a name to use as a subfolder under `obj.dir`. ## @param obj.dir character(1L) directory to reference objects in. ## @return a list of reading ("rds", "txt"), and writing functions, ("rds_save", ## "txt_save"). ## @examples ## ## Load the functions into env so we can access them directly. ## list2env(make_file_funs("myfile"), environment()) ## ## Test against stored RDS ## # rds_save(my_fun(), "my_fun_out") # previously stored value ## all.equal(my_fun(), rds("my_fun_out")) make_ref_obj_funs <- function( name, obj.dir=getOption("aammrtf.ref.objs", file.path("aammrtf-ref-objs")), env=parent.frame() ) { dir <- file.path(getwd(), obj.dir) if(!file_test('-d', dir)) stop("`dir` (", dir, ") is not a directory or does not exist.") res <- list( rds= function(x) { old.dir <- setwd(dir); on.exit(setwd(old.dir)) readRDS(file.path(dir, name, sprintf("%s.rds", x))) }, rds_save= function(x, i) { old.dir <- setwd(dir); on.exit(setwd(old.dir)) saveRDS( x, file.path(name, sprintf("%s.rds", i)), version=2 ) }, txt= function(x) { old.dir <- setwd(dir); on.exit(setwd(old.dir)) readLines(file.path(name, sprintf("%s.txt", x))) }, txt_save= function(x, i) { old.dir <- setwd(dir); on.exit(setwd(old.dir)) writeLines( x, file.path(NAME, sprintf("%s.txt", i)) ) } ) if( any( c('rds', 'rds_save', 'txt', 'txt_save') %in% ls(env) ) ) { warning('target objects already defined, not writing them to `env`') } else list2env(res, env) invisible(res) } unitizer/tests/aammrtf/mock.R0000644000176200001440000000331014766101222015766 0ustar liggesusers# Copyright (C) 2022 Brodie Gaslam # This file is part of "aammrtf - An Almost Most Minimal R Test Framework" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 or 3 of the License. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. ## Mock a Function During Testing ## ## Replaces the guts of a function using the `trace` mechanism. This may not ## work with functions that are inlined by the byte compiler, e.g. primitives. ## A work-around is to put these inside a wrapper function in your code, ## although of course that comes with some overhead. ## ## @param f function to mock ## @inheritParams trace (see `?trace` for other parameters. ## @examples ## expr <- quote(as.POSIXct('1999-12-31 23:59:59')) ## local({ ## mock(base::Sys.time, expr) ## on.exit(unmock(base::Sys.time)) ## Sys.time() ## }) mock <- function(f, tracer, where=f, print=FALSE) { editor <- function(name, file, title) {body(name) <- tracer; name} old.edit <- options(editor=editor) on.exit(options(old.edit)) invisible( suppressMessages( eval( bquote(trace(.(substitute(f)), edit=TRUE, print=FALSE, where=.(where))), parent.frame() ) ) ) } unmock <- function(f, where=f) { invisible( suppressMessages( eval(bquote(untrace(.(substitute(f)), where=.(where))), parent.frame()) ) ) } unitizer/tests/aammrtf/check.R0000644000176200001440000000265114766101222016121 0ustar liggesusers# Copyright (C) 2022 Brodie Gaslam # This file is part of "aammrtf - An Almost Most Minimal R Test Framework" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 or 3 of the License. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. flist <- function(x, y) paste0(x, paste0("'", basename(y), "'", collapse=", ")) report <- function(x) {writeLines(character(13)); stop(x, call.=FALSE)} test.out <- list.files(pattern="\\.Rout$") non.ascii <- which(lengths(lapply(test.out, tools::showNonASCIIfile)) > 0) if(length(non.ascii)) warning(flist("Some outputs contain non-ASCII:\n", test.out[non.ascii])) tar <- list.files(pattern='\\.Rout\\.save$', full.names=TRUE) cur <- file.path(dirname(tar), sub('\\.save$', '', basename(tar))) awol <- !file.exists(cur) if(any(awol)) report(flist(".Rout files missing (failed?):\n", cur[awol])) diff.dat <- Map(tools::Rdiff, tar[!awol], cur[!awol], useDiff=TRUE, Log=TRUE) diffs <- vapply(diff.dat, '[[', 1, 'status') if(any(!!diffs)) report(flist("Test output differences:\n", cur[!!diffs])) unitizer/tests/aammrtf/init.R0000644000176200001440000000065714766101222016013 0ustar liggesusers# Update this file with any common steps you wish all your test files to use, # and add e.g. `source('aammrtf/init.R')` to each of them. options( warn=1, # don't accumulate warnings useFancyQuotes=FALSE, # all.equals uses fancy quotes encoding="UTF-8", # Assume UTF-8 input in non-UTF-8 locales warnPartialMatchArgs=TRUE, warnPartialMatchAttr=TRUE, warnPartialMatchDollar=TRUE ) unitizer/tests/t-shim.Rout.save0000644000176200001440000002500514766101222016301 0ustar liggesusers R Under development (unstable) (2021-07-17 r80639) -- "Unsuffered Consequences" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin17.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > source(file.path("aammrtf", "mock.R")) > source(file.path("_helper", "init.R")) > source(file.path("_helper", "pkgs.R")) Install Packages Setup Demos > > old.state <- tracingState(TRUE) > > # - "trace_at_end" ------------------------------------------------------------- > > if (is(unitizer:::trace_test_fun, "functionWithTrace")) + untrace("trace_test_fun", where = asNamespace("unitizer")) > unitizer:::trace_at_end("trace_test_fun", quote(if (!inherits(.res, + "try-error")) cat(sprintf("x: %d\n", .res$value))), print = FALSE, + where = asNamespace("unitizer")) Tracing function "trace_test_fun" in package "namespace:unitizer" > coi(unitizer:::trace_test_fun()) > tracingState(FALSE) [1] TRUE > identical(capture.output(unitizer:::trace_test_fun()), character()) [1] TRUE > tracingState(TRUE) [1] FALSE > > err <- try(unitizer:::trace_test_fun(stop("hello")), silent = TRUE) > cond <- attr(err, "condition") > conditionMessage(cond) [1] "hello" > conditionCall(cond) unitizer:::trace_test_fun(stop("hello")) > # return/missing etc. corner cases > f <- function(x, y, z = 5) { + if (missing(x)) { + return(TRUE) + } + else if (z > 5) { + stop("OMG, z > 5") + } + else if (identical(substitute(y), "hey")) { + "substitute!" + } + else FALSE + } > unitizer:::trace_at_end("f", quote(cat("hello\n")), FALSE, environment()) > res <- f() hello > res [1] TRUE > res2 <- f(1) hello > res2 # FALSE [1] FALSE > err <- try(f(1, z = 6), silent = TRUE) hello > is(err, "try-error") [1] TRUE > attr(err, "condition") 5> > res3 <- f(1, y = "hey") hello > res3 [1] "substitute!" > > # - "Parent Env Stays on Top" -------------------------------------------------- > > try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) > while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) > unitizer.dummy.list <- list(z = 23, x = 1, y = "hello") > my.env <- new.env() > state.set <- c(search.path = 2L) > # make sure to unset this at end > untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, + enable.which = state.set, set.global = TRUE) > untz.glob$shimFuns() [1] TRUE > sp <- search() > curr2 <- sp[[2L]] > > > identical(environmentName(parent.env(my.env)), curr2) [1] TRUE > library("unitizerdummypkg1", lib.loc = TMP.LIB) > identical(environmentName(parent.env(my.env)), "package:unitizerdummypkg1") [1] TRUE > attach(unitizer.dummy.list) > identical(environmentName(parent.env(my.env)), "unitizer.dummy.list") [1] TRUE > detach("unitizer.dummy.list") > identical(environmentName(parent.env(my.env)), "package:unitizerdummypkg1") [1] TRUE > detach("package:unitizerdummypkg1", unload = TRUE) > identical(environmentName(parent.env(my.env)), curr2) [1] TRUE > untz.glob$checkShims() [1] TRUE > > # - "Parent env tracking with search path manip" ------------------------------- > > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 0 Slot "working.directory": [1] 0 Slot "random.seed": [1] 0 Slot "namespaces": [1] 0 > keep.more <- c(getOption("unitizer.search.path.keep.base")) > unitizer:::search_path_trim(keep.more, global = untz.glob) > untz.glob$state() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 0 Slot "working.directory": [1] 0 Slot "random.seed": [1] 0 Slot "namespaces": [1] 0 > identical(environmentName(parent.env(my.env)), search()[[2L]]) [1] TRUE > untz.glob$resetFull() An object of class "unitizerGlobalIndices" Slot "search.path": [1] 1 Slot "options": [1] 1 Slot "working.directory": [1] 1 Slot "random.seed": [1] 1 Slot "namespaces": [1] 1 > identical(environmentName(parent.env(my.env)), curr2) [1] TRUE > > # - "Disable Unshims, etc." ---------------------------------------------------- > > untz.glob$unshimFuns() [1] TRUE > !any(vapply(list(library, detach, attach), inherits, logical(1L), + "functionWithTrace")) [1] TRUE > untz.glob$release() > > # - "Checks, errors, etc." ----------------------------------------------------- > > # make sure to unset this at end > untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, + enable.which = state.set, set.global = TRUE) > tracingState(FALSE) [1] TRUE > untz.glob$shimFuns() # warning Warning in untz.glob$shimFuns() : Unable to shim required functions to run with `par.env=NULL` because tracing state is FALSE. Setting `par.env=.GlobalEnv`. [1] FALSE > parent.env(my.env) > tracingState(TRUE) [1] FALSE > untz.glob$release() > untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, + set.global = TRUE) > trace("library", quote(cat("I am traced\n")), where = .BaseNamespaceEnv) Tracing function "library" in package "namespace:base" [1] "library" > lib.trace <- library > untz.glob$shimFuns() # warning Warning in untz.glob$shimFuns() : Unable to shim required functions to run with `par.env=NULL` because they are already traced. Setting `par.env=.GlobalEnv`. [1] FALSE > parent.env(my.env) > inherits(attach, "functionWithTrace") # FALSE [1] FALSE > inherits(detach, "functionWithTrace") # FALSE [1] FALSE > inherits(library, "functionWithTrace") [1] TRUE > identical(lib.trace, library) [1] TRUE > untrace("library", where = .BaseNamespaceEnv) Untracing function "library" in package "namespace:base" > untz.glob$release() > untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, + set.global = TRUE) > untz.glob$shimFuns() [1] TRUE > trace("attach", quote(cat("I am traced\n")), where = .BaseNamespaceEnv) Tracing function "attach" in package "namespace:base" [1] "attach" > attach.trace <- attach > untz.glob$checkShims() # warning Warning in untz.glob$checkShims() : Traced functions unexpectedly changed, disabling clean parent env Warning in unshimFuns() : `attach` was not untraced because they were modified by something other than unitizer. `FALSE`, `TRUE`, and `FALSE` were not untraced for unknown reasons; please report to maintainer. you should consider manually untracing the function, or restarting your R session to restore function to original value. [1] FALSE > parent.env(my.env) > inherits(detach, "functionWithTrace") # FALSE [1] FALSE > inherits(library, "functionWithTrace") # FALSE [1] FALSE > inherits(attach, "functionWithTrace") [1] TRUE > identical(attach.trace, attach) [1] TRUE > untrace("attach", where = .BaseNamespaceEnv) Untracing function "attach" in package "namespace:base" > untz.glob$release() > untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, + set.global = TRUE) > untz.glob$shimFuns() [1] TRUE > tracingState(FALSE) [1] TRUE > untz.glob$checkShims() # warning Warning in untz.glob$checkShims() : Tracing state off, so disabling clean parent env [1] FALSE > parent.env(my.env) > tracingState(TRUE) [1] FALSE > inherits(detach, "functionWithTrace") # FALSE [1] FALSE > inherits(library, "functionWithTrace") # FALSE [1] FALSE > inherits(attach, "functionWithTrace") # FALSE [1] FALSE > # try tracing some stuff that shouldn't be > untz.glob$shimFuns("baljevzxhjLsdc") # Warning Warning in untz.glob$shimFuns("baljevzxhjLsdc") : Unable to shim required functions to run with `par.env=NULL` because some cannot be found. Setting `par.env=.GlobalEnv`. [1] FALSE > # test unexpected message or behavior from `trace_at_end` > try(untz.glob$shimFun("sum")) Error in untz.glob$shimFun("sum") : Internal Error: missing shim data > > mock(unitizer:::trace_at_end, quote(stop("trace_at_end fail"))) > any( + grepl( + "trace_at_end fail", + capture.output( + trace.fail <- untz.glob$shimFun("library"), type = "message" + ), + fixed = TRUE + ) + ) [1] TRUE > unmock(unitizer:::trace_at_end) > > trace.fail # FALSE [1] FALSE > mock(unitizer:::trace_at_end, quote(message("random message"))) > untz.glob$shimFun("library") random message Warning in untz.glob$shimFun("library") : Function `library` was not traced even though tracing attempt did not produce errors. [1] FALSE > unmock(unitizer:::trace_at_end) > > mock(unitizer:::trace_at_end, quote(TRUE)) > dont.trace <- untz.glob$shimFun("library") # Warning "not traced" Warning in untz.glob$shimFun("library") : Function `library` was not traced even though tracing attempt did not produce errors. > unmock(unitizer:::trace_at_end) > > dont.trace # FALSE [1] FALSE > untz.glob$release() > # untrace condition > untz.glob <- unitizer:::unitizerGlobal$new(par.env = my.env, set.global = TRUE) > untz.glob$shimFuns() [1] TRUE > > mock( + unitizer:::untrace_utz, + quote({ + message("untrace dummy") + base::untrace(what = what, signature = signature, where = where) + }) + ) > untz.glob$unshimFuns() # message untrace dummy untrace dummy untrace dummy untrace dummy [1] TRUE > unmock(unitizer:::untrace_utz) > untz.glob$release() > > try(detach("package:unitizerdummypkg1", unload = TRUE), silent = TRUE) > > while ("unitizer.dummy.list" %in% search()) try(detach("unitizer.dummy.list")) > > # - "find_returns" ------------------------------------------------------------- > > fun <- function() { + if (TRUE) + return(1) + else { + { + 2 + 2 + identity(c(1, 2, return(3), { + list(1, 2, 5) + return(return(4)) + })) + return(5) + } + return(6) + } + if (TRUE) + return(7) + else return(8) + return(9) + return(10) + } > ret.loc <- unitizer:::find_returns(fun) > ret.loc [[1]] [1] 2 3 [[2]] [1] 2 4 2 3 2 4 [[3]] [1] 2 4 2 3 2 5 3 [[4]] [1] 2 4 2 4 [[5]] [1] 2 4 3 [[6]] [1] 3 3 [[7]] [1] 3 4 [[8]] [1] 4 [[9]] [1] 5 > > # Validate visually that this worked > > all(vapply(unitizer:::get_returns(fun, ret.loc), function(x) x[[1L]] == + quote(return), logical(1L))) [1] TRUE > > > proc.time() user system elapsed 4.83 1.32 6.59 unitizer/MD50000644000176200001440000004615114766411142012450 0ustar liggesusers2cfa4a05d36bbbac9a32d946cbfa4849 *COPYING f2a2af18799e392853874fb0e8e29e54 *DESCRIPTION eecebe91154b7184dca264536e65e86f *NAMESPACE e31b84aac6aa467ebbba040c4988debe *NEWS.md 26f577bdf6d96f0fc1145b14286b119f *R/asciiml.R 9e2a90ccc1b6d8f4034458caefb0eee0 *R/browse.R 6fcd358bcb479628b86dfa7952b21507 *R/browse.struct.R 4869b3b57350a67b860ce4fd9abc96b3 *R/capture.R 9d81208f28b2794bdaa5d1ba95e5ed6c *R/change.R 9b969b02d845951d29bfe1c82d6b6832 *R/class_unions.R e2fa7f73426e4c87e9d0901aa5aaa36b *R/conditions.R 75dfa8e67d02e63b4cb1df1ddc842b91 *R/demo.R 4af7b1f695a97ab49b2e2e3daa283c5f *R/deparse.R 07f52ed9b4f33c2ced0066775c0311ba *R/diff.R ed995625c512758caee2f804f1ed2cc2 *R/exec.R 5aab311660f22ee777d8b09142cbe704 *R/faux_prompt.R 20d821c5c91dcfb61eb756f4e4f6fe8e *R/get.R c2c648c27aa0170335289a8edd8e14e3 *R/global.R 29c05e43e37547ce1718e1319f4a2b75 *R/heal.R c3b4ac58790d089a5e84db8544887587 *R/is.R ee09017a2489c07413fd59f0fef6f2ab *R/item.R ee6752bcbdfcff00a7ea51d93f6009da *R/item.sub.R a06bef00d3690324444cee9e42876684 *R/list.R 12404a98e87a8418f0c0ef97b3d9ce83 *R/load.R f660abf27c4ff80d6cc3e483d0895413 *R/ls.R 43803a353f6965a0dbdb53e4c1cd002c *R/misc.R 7a725ff74a3d57620a44536e023daf5b *R/onload.R 12de14c6f6d1333b635a45e5d8b58193 *R/options.R 96ccb77ac7f0eff1f3bb05a94776feb4 *R/parse.R 725c7c4a92466bd9b4f23ba69abd30a7 *R/prompt.R 2e9d9cb394f6df99ee0e8af422c7c1ac *R/rename.R d108181f336a2300b6dc21dfef57f7ee *R/repairenvs.R 6f572d897aebb1cc969695e96b5982bf *R/result.R 9ff70b1ebbe3ffdb36abc978f984d0a0 *R/search.R 8c3cae2d1c3a3c6c6d130b55b3db194e *R/section.R f667610269dfeeec8d5ee37652109d42 *R/shims.R d9fd08a639dcfd069e275c6b14233e20 *R/size.R 12fd85f2544b1c1795c37f83d0c2f212 *R/state.R 0e36e90f1faec5c452c3e10ee3e0ffd1 *R/state.compare.R 1efe96f8d3db67d22a61356b8d24c2a2 *R/test.R 079567f9e6bb7a0ade36586ac1c58ef2 *R/text.R 798fe3719b0a2688723cae3f5ca6a689 *R/traceback.R 38898facf2d2ea15d785a1abd8b43474 *R/translate.R 7bc1f6ac7625c25ee9597b61d1fd8cce *R/unitize.R 4b6de22fc8542d9288e282756d7b628c *R/unitize.core.R bad98055c53de0ff4f7fbc657b585833 *R/unitizer-package.R 1eb089b4e0722901b4d6a70125e24d16 *R/unitizer.R 852abcca628a1808c9b3a9d506e7ac78 *R/unitizer.add.R 736f8c5a66e0b58dde126568d0d875c8 *R/upgrade.R a3f4bb023c43c46a4da14b847f894599 *README.md b79c6b8f41ba4d61528f2615792f013c *build/vignette.rds 8fbb6fba3b80b2c02660bc50e8753b67 *demo/00Index 456084abc585ba5f7a706a117c286b21 *demo/unitizer.R b7b977bc5e5ba8b88c2dbf4184cd2709 *inst/doc/rmdhunks/intro.Rmd 6877d0d22e41065f71e31ff6096c38ef *inst/doc/rmdhunks/usage.Rmd 581d1fb1675e0bbfa63680e7b496a177 *inst/doc/styles.css 77c3c89384af0dc551e34f166553c899 *inst/doc/u0_unitizer_index.Rmd 2dc992726ac3489077158bd4b0bfe9d8 *inst/doc/u0_unitizer_index.html 37b7fd6238f9a04ca2e8f620da294351 *inst/doc/u1_intro.R 8a12b56418b1c25e0b90bc96eb72111c *inst/doc/u1_intro.Rmd 1ed069737e62c67aefa895a1bfbe68b9 *inst/doc/u1_intro.html 89a772d34ed168ddab967a75f78f5fb6 *inst/doc/u2_tests.Rmd 1aa57d0c79baa1ea06738620539734e8 *inst/doc/u2_tests.html aafc9cd6502d3b16e5f1d85b5508de6d *inst/doc/u3_interactive-env.Rmd 7fc032c5eff4bb1adb9c7971c354cb89 *inst/doc/u3_interactive-env.html eb994f55094165b9f1b0c48097d84749 *inst/doc/u4_reproducible-tests.Rmd 3026d2a1f8496bd0b42cfa25400b08fe *inst/doc/u4_reproducible-tests.html 3d377c485d57a4a8cb2a020ede3f5fe6 *inst/doc/u5_miscellaneous.Rmd 7cc2c6d6f75e17cec5a78d62a6a4ede5 *inst/doc/u5_miscellaneous.html ef1d9ebf8f8e64a45ac1df1c026865fb *inst/expkg/baddescription0/DESCRIPTION bee9c689c7237b41a12a00ae4aefab4a *inst/expkg/baddescription0/NAMESPACE 4dc7855f8fd74b41f42def9370dc634b *inst/expkg/baddescription0/R/dummy.R d2121a786c9f8441df62c3258b3e0cb3 *inst/expkg/baddescription0/man/dummy_fun2.Rd e2f4398dc4ffd38cb9a493e381efca2c *inst/expkg/baddescription1/DESCRIPTION bee9c689c7237b41a12a00ae4aefab4a *inst/expkg/baddescription1/NAMESPACE 4dc7855f8fd74b41f42def9370dc634b *inst/expkg/baddescription1/R/dummy.R d2121a786c9f8441df62c3258b3e0cb3 *inst/expkg/baddescription1/man/dummy_fun2.Rd e90274d1c8876b05ff89ab0028813456 *inst/expkg/flm0/DESCRIPTION 4ea5895e46491248412e41055e334ad4 *inst/expkg/flm0/NAMESPACE 16134c2436cb5683014ecc5ffee473c5 *inst/expkg/flm0/R/fastlm-package.r 56959b086b68d2e3ce1a420cbbec9f00 *inst/expkg/flm0/R/fastlm.R f2fd7ce9aa6db90c61d9ceb563af92b1 *inst/expkg/flm0/man/fastlm.Rd 32a4e35d0fb4c837398628f90a7d8934 *inst/expkg/flm0/man/get_slope.Rd 4fd65f663295cc670dc8e3da93d8283a *inst/expkg/flm0/tests/extra/del1.R 92d9005b764f922c8eca856251d85fb7 *inst/expkg/flm0/tests/extra/del2.R 5f66bd345e5736a834178ee6c1950c50 *inst/expkg/flm0/tests/extra/inpkg.R ded4c0eeae0caa384d5481ba4fdb4409 *inst/expkg/flm0/tests/tests.R c060de8c95431fb90ecf52266f8463ad *inst/expkg/flm0/tests/unitizer/fastlm1.R 1d2b67ce016f89101a07cd8df557ed8d *inst/expkg/flm0/tests/unitizer/fastlm2.R bddff717d2227e5f5dc56bcaa1838c97 *inst/expkg/flm0/tests/unitizer/unitizer.fastlm.R ded4c0eeae0caa384d5481ba4fdb4409 *inst/expkg/flm0/utzflm_Rcheck/tests/tests.R 8f9927192f45efea79858e071cc7b0d3 *inst/expkg/flm0/utzflm_Rcheck/utzflm/_DESCRIPTION 680566f8b11039d69d446217cdd8d117 *inst/expkg/flm0/utzflm_Rcheck/utzflm/_INDEX 4ea5895e46491248412e41055e334ad4 *inst/expkg/flm0/utzflm_Rcheck/utzflm/_NAMESPACE 43aef3ece4f54261949a7a72fce1deff *inst/expkg/flm0/utzflm_Rcheck/utzflm/_R/readme.txt e3ff753fa9fab58a707e4efa7f43e1ca *inst/expkg/flm1/DESCRIPTION 4ea5895e46491248412e41055e334ad4 *inst/expkg/flm1/NAMESPACE 16134c2436cb5683014ecc5ffee473c5 *inst/expkg/flm1/R/fastlm-package.r 36a51e1b174358e24e1825245b46f7e6 *inst/expkg/flm1/R/fastlm.R f2fd7ce9aa6db90c61d9ceb563af92b1 *inst/expkg/flm1/man/fastlm.Rd 32a4e35d0fb4c837398628f90a7d8934 *inst/expkg/flm1/man/get_slope.Rd b433e47bc9dc2607272a25cb1feb8ffb *inst/expkg/flm1/tests/tests.R a94210e34756eaf809ab5c867597e455 *inst/expkg/flm1/tests/unitizer/fastlm1.R 1d2b67ce016f89101a07cd8df557ed8d *inst/expkg/flm1/tests/unitizer/fastlm2.R bddff717d2227e5f5dc56bcaa1838c97 *inst/expkg/flm1/tests/unitizer/unitizer.fastlm.R 3d3c80c68c21ee3af0de3beba15f95bc *inst/expkg/flm2/DESCRIPTION 4ea5895e46491248412e41055e334ad4 *inst/expkg/flm2/NAMESPACE 16134c2436cb5683014ecc5ffee473c5 *inst/expkg/flm2/R/fastlm-package.r 7383e349ce48ce91281fb1f6b7c6e472 *inst/expkg/flm2/R/fastlm.R f2fd7ce9aa6db90c61d9ceb563af92b1 *inst/expkg/flm2/man/fastlm.Rd 32a4e35d0fb4c837398628f90a7d8934 *inst/expkg/flm2/man/get_slope.Rd b5b139e8a84c44d3d2b6a0ce0e969773 *inst/expkg/flm2/tests/unitizer/fastlm1.R 1d2b67ce016f89101a07cd8df557ed8d *inst/expkg/flm2/tests/unitizer/fastlm2.R 02fd9e3c28f71e413077ee62e4d64729 *inst/expkg/flm2/tests/unitizer/unitizer.fastlm.R 6511385bd1d323a024ef2715844423f5 *inst/expkg/flm2/tests/unitizer/unitizer.fastlm2.R da662ddcbe4c611e9694c3b391a1f0eb *inst/expkg/infer/DESCRIPTION 012592abf4b40a8d741b299df2ded05a *inst/expkg/infer/NAMESPACE 1c7e7d38cd9f001a0da84d7b306d3dfd *inst/expkg/infer/R/infer.R 63af689f5effe7de59a99c90ed33d3e9 *inst/expkg/infer/tests/unitizer/aaa.R d500123848eda3236b3ba231761fdb98 *inst/expkg/infer/tests/unitizer/aaa.unitizer/data.rds 63af689f5effe7de59a99c90ed33d3e9 *inst/expkg/infer/tests/unitizer/abc.R 1dc5c3d8707fbfa9210b931e798fe9bf *inst/expkg/infer/tests/unitizer/abc.unitizer/data.rds 63af689f5effe7de59a99c90ed33d3e9 *inst/expkg/infer/tests/unitizer/inf.R e64cd65d3024ab8dc30bf536b0669b8c *inst/expkg/infer/tests/unitizer/inf.unitizer/data.rds 63af689f5effe7de59a99c90ed33d3e9 *inst/expkg/infer/tests/unitizer/infer.R 464f3d40e093856cbf092bdea1b029e2 *inst/expkg/infer/tests/unitizer/infer.unitizer/data.rds 63af689f5effe7de59a99c90ed33d3e9 *inst/expkg/infer/tests/unitizer/zzz.R 20fe39597eb6723ff7e2a18e6bf8cc90 *inst/expkg/infer/tests/unitizer/zzz.unitizer/data.rds 11a2c6d0ca138fa51221693f79268e16 *inst/expkg/rcw/rcw-code.R 21f6577a6199f4d7e98e154870becb7f *inst/expkg/rcw/rcw-test.R 8ea996d90db75f7bb7988b79378459d1 *inst/expkg/unitizerdummypkg1/DESCRIPTION d3b3281c5cac8d21839f9d6bdde5100e *inst/expkg/unitizerdummypkg1/NAMESPACE 2e5f1a96c295d4472c79dd697bd7d845 *inst/expkg/unitizerdummypkg1/R/dummy.R bb1ebddf1e15b7170e47b13980354621 *inst/expkg/unitizerdummypkg2/DESCRIPTION 248b3bfe042e969cc0274e869a650fb9 *inst/expkg/unitizerdummypkg2/NAMESPACE 618f02859f61b6b6553666a19ded3034 *inst/expkg/unitizerdummypkg2/R/dummy.R f2117342cf3a4c2b4d3f595458dc5a20 *man/all.equal.condition.Rd 5b60d19170132235d9dfe5b25e671ee9 *man/all_eq.Rd 2d57a28f7042e593756a91b661074152 *man/as.character-unitizerChanges-method.Rd d154fd60225f0ff6423637d27f9d7224 *man/as.character.bullet.Rd 8159a4a8fafa3719b0e5de307e6fae0a *man/as.expression-unitizerList-method.Rd ccb4fe76f9f468efb55a21d0ed855f89 *man/cap_first.Rd eaf1b0d9e1ab3bfb1dc975247a411209 *man/capture_output.Rd 9323cc9fde28a686492918b7b01801c4 *man/conditionList.Rd 14aec84ce78f907734b5b50cc9d3dc56 *man/demo.Rd 6786dcda6a3ef0b5b1c6ca85ba537c9b *man/desc.Rd 163315ef995dfd15b600aba20cf38263 *man/editCalls.Rd 470ef7139d6829791f4cd87bcf39ab0e *man/extract-unitizerItem-method.Rd 2a6bc851a97f9a5e6fd7c69f5aa23470 *man/extract-unitizerItemTestsErrorsDiffs-method.Rd f5109c9ab59da028c1d54afa92670ddb *man/filename_to_storeid.Rd f8a789389eb33108a86d76f9461beb1b *man/flattenUntz.Rd 3c87a410d03ac631036b1d3de046ddde *man/getFun.Rd 2959d981b7bf1a219e7bc7f253563124 *man/global_structures.Rd 4f6a6a9b735bfa31edced45c3be54281 *man/healEnvs.Rd 8f6ac78605135f1611b70945280ee927 *man/infer_unitizer_location.Rd f1e2c57c0b64385523ccd1d5f6551b9b *man/invalidateLs.Rd 755e6e73acb6b7a6d974b3dc92f482ef *man/length-unitizerChanges-method.Rd f5dfe82e3e4823f3713b466a008e3a7a *man/length-unitizerSection-method.Rd f03650afe2572a7ce2b577f99d7a9acf *man/mock_item.Rd 2d3336bdee498b1ffafd5d5f089a57ca *man/nextItem-unitizerList-method.Rd 5f2bab5f3c469e95a0456f0e781dc7af *man/options_extra.Rd ef02ada137edebb56ad9f4ae9e2a8bb6 *man/print.bullet.Rd 1315a260ad102f0a8131f058ea54f60a *man/repair_environments.Rd ea94ad0243b624e62070b34bd020c1e9 *man/run_ls.Rd c96d666de17384c00017cb6afcf532b3 *man/set_unitizer.Rd 93fe102d0997f4f5415530e9ffcb65de *man/show-unitizerChanges-method.Rd 8e3af513ba5a8cb7fa807c3d55aacfdc *man/show-unitizerItemTestsErrorsDiff-method.Rd 3497879b89d1a95ea31c1956facd93ca *man/show-unitizerItemTestsErrorsDiffs-method.Rd 6688732abeb2c2d18cce315538e7a784 *man/show.conditionList.Rd f195af811fe0f31d7752eba9737ff0fb *man/sizeRDS.Rd 85261dbb64714b360ba70c043181adef *man/sizeUntz.Rd 431b89d856499d1ce67af5b3f2de9f7f *man/testFuns.Rd 74f92147fa29dfa0d71c478e736347d5 *man/testthat_transcribe_file.Rd a00f484bcdc8963d9269b75e436b73f3 *man/testthat_translate_file.Rd 8a8cbb0350c94744b4fcf2d32d44c46e *man/text_wrap.Rd 2d4d19929f19e8abc67da4a31039b0a7 *man/unitize.Rd c2c2295d05efb87a0019777602546eb9 *man/unitizer.Rd a63af48e2d8a22869837ab05d0c9752c *man/unitizer.opts.Rd 44ed458f1502305074968f7542cfe354 *man/unitizerChanges-class.Rd cf7c4ecb0d98f69d210426e4eaf9e527 *man/unitizerList.Rd f30c9a35485aa5427bc4d23bc822fcc0 *man/unitizerSection-class.Rd 5496a6e4fca191695b8c752ffa8224b4 *man/unitizerState.Rd ddc3f49ba68590384aee694116bac2c1 *man/unitizerTests-class.Rd 524c83149f10a66d578ae18e3b144832 *man/unitizer_ls.Rd c080e68ba5a9f448084ff91ccee784cd *man/unitizer_prompt.Rd 6e6e44dd00fb7f5ea2107b1560171d2b *man/unitizer_result.Rd 73ef008e4c4ba45a9e6dadfb2496ad3f *man/unitizer_s4method_doc.Rd c220b88c58ecaae62a34c93d802b3e7a *man/unitizer_sect.Rd 92bb6eefe96bf4bdf4199e403a8b2c4e *man/valid_names.Rd 40335497dc288ca4396e487866008f3e *man/validate_pre_post.Rd 6a16942cf4f5c3302a72a152836a2532 *tests/_helper/init.R ae9aaf70ff7a7c20f7283b9967e6fb7a *tests/_helper/pkgs.R 0ee1899c8da0b6de273be5f3e30dd680 *tests/_helper/ref-objs/capture/100.rds 87d719512503ff83c92dd1d54e7709c4 *tests/_helper/ref-objs/capture/200.rds 29b0edeadd6032f91d07ffc68cfdda62 *tests/_helper/ref-objs/exec/100.rds 4832052627ae5c888fcbececad8857e2 *tests/_helper/ref-objs/exec/200.rds 1fce5c7837f0563029fa825dbc713021 *tests/_helper/ref-objs/exec/300.rds 1fce5c7837f0563029fa825dbc713021 *tests/_helper/ref-objs/exec/400.rds 49faa5b9314791d338adc71be88d4258 *tests/_helper/ref-objs/exec/500.rds 49faa5b9314791d338adc71be88d4258 *tests/_helper/ref-objs/exec/600.rds 869380730cdaeab1bffe0e2ba5a78aa1 *tests/_helper/ref-objs/exec/700.rds 19c73d9fe70e6eb07f4c7eaabc93a745 *tests/_helper/ref-objs/exec/800.rds ea611dd645fe66243eb98cbf64bd3858 *tests/_helper/ref-objs/exec/900.rds ce137449545f764a5e69ee0a84563fe1 *tests/_helper/ref-objs/item/100.rds 56adf78ebc9dedaa0c21f4d12071becd *tests/_helper/ref-objs/item/200.rds f76ab136da97ba429bba026ef283622e *tests/_helper/ref-objs/item/300.rds 9dc1b004ed6630f758b9e145c1399b94 *tests/_helper/ref-objs/item/400.rds 2b418e0e17aa6a047112c1e932f86f73 *tests/_helper/ref-objs/item/500.rds 1df28ad08de71e1319733df8a656b540 *tests/_helper/ref-objs/item/600.rds 8c36e42bc3239fd35042df4e8803583b *tests/_helper/ref-objs/item/700.rds a7c35b5d52e6f9a79a5925c379253699 *tests/_helper/ref-objs/load/borked1.unitizer/data.rds b8a408de1c763bec87ec35c3ea14832e *tests/_helper/ref-objs/load/borked2.unitizer/data.rds 1310f2b3c5b862b86a113962c9abc5a1 *tests/_helper/ref-objs/load/borked3.unitizer/data.rds a6a2583a5c80a7042af4a8cdc4ce2b13 *tests/_helper/ref-objs/load/internals.unitizer/data.rds 1b1055237c734fc76d391018e33df708 *tests/_helper/ref-objs/load/nth-value.unitizer/data.rds fe88cf9470716038e9e99b9168be2820 *tests/_helper/ref-objs/load/old.unitizer/data.rds d481855cb06cb1f0d37790a716298643 *tests/_helper/ref-objs/refobjs/browse_aschar1.rds ecada13d5c71bd558419c2ccacaa78e7 *tests/_helper/ref-objs/refobjs/browse_aschar2.rds 06c2738b2cf6a76f4f3efc4057b24f79 *tests/_helper/ref-objs/refobjs/browse_aschar3.rds bf7351f01ba1ce743dbe87a1e9e8d7df *tests/_helper/ref-objs/refobjs/browse_ascharnarrow.rds 8e09829a384fa3902bac5ec2cd504750 *tests/_helper/ref-objs/refobjs/browse_df1.rds 485dec7e06571315ba56763e269baf23 *tests/_helper/ref-objs/refobjs/browse_itemord.rds 6e3b0180f105cb65bf68e6b675d558af *tests/_helper/ref-objs/refobjs/misc_cndlistshow1.rds dc3c172eb6371d9cda95585f46815f92 *tests/_helper/ref-objs/refobjs/parse-eq.rds 73fb960ebf1379e997f8484e05db340e *tests/_helper/ref-objs/refobjs/translate_res1.rds 0513954bfdc214fddfdce9b75b669a11 *tests/_helper/ref-objs/refobjs/translate_res2.rds 2f2ab2d8cdba3a54510a11c77f24b157 *tests/_helper/ref-objs/refobjs/translate_res3.rds 0513954bfdc214fddfdce9b75b669a11 *tests/_helper/ref-objs/refobjs/translate_res4.rds 969258aadcf745bc600e401df0b34d1e *tests/_helper/ref-objs/refobjs/unitize_res1.rds b54293fc77b27e3768e7e720cb956cbb *tests/_helper/ref-objs/translate/testthat/helper-translate.R adb38235b9b05eed7b4cce92ff6f4548 *tests/_helper/ref-objs/translate/testthat/test-translate1.R b7d0b4294ced8327034aa58e38004c39 *tests/_helper/ref-objs/translate/testthat/test-translate2.R c870b3e30f8d8affa40a2dad4dc5f95e *tests/_helper/ref-objs/translate/testthat2/test-translate-min.R 2346afa8993c37f2f71d11f1bc4dc9ac *tests/_helper/unitizers/fail-and-upgrade.R 3069425006c291ad21617f7d33ff7ecc *tests/_helper/unitizers/fail-and-upgrade.unitizer/data.rds 81cefb43b7f51d2bab8f2c7adf93e846 *tests/_helper/unitizers/misc.R 2964a02d6182640ba53a1ebadd7e6228 *tests/_helper/unitizers/misc.unitizer/data.rds c4fd35bfedbf93139593d642bbd85cd9 *tests/_helper/unitizers/nav.R 035543c873119f53b7f7836e74d388c8 *tests/_helper/unitizers/sects.R eac17b98a51469702809435d795fa3e2 *tests/_helper/unitizers/trivial.R bc743a60d3bcd5218ebe0aa344ae1cb9 *tests/_helper/unitizers/trivial.unitizer.0.4.2/README fe88cf9470716038e9e99b9168be2820 *tests/_helper/unitizers/trivial.unitizer.0.4.2/data.rds 4e56926674d6d5da09a306423e4142b9 *tests/_helper/unitizers/trivial.unitizer/data.rds 93130875fd094725cf84f6f8e6b474fa *tests/aammrtf/check.R f74b19322452dc0e0b9059ab4ebbe536 *tests/aammrtf/init.R 2f7d409c5b7393f50e90c14a18de15aa *tests/aammrtf/mock.R 20df77e148ec956f23e427e464613f61 *tests/aammrtf/ref.R 9395e6af58ae81b300962f1c8642a7b3 *tests/not-cran.R 61fdff310c91b4e7a7c9192fa289779f *tests/t-browser.R e40682fb1d2a0259917a9216529f9d14 *tests/t-browser.Rout.save 68caa9cfe87c9481e5d00ade7c849ce8 *tests/t-capture.R e8bec6f6fdf674854df0ffd33cd4f488 *tests/t-capture.Rout.save ebaa62351e452b595cf8bb596015c036 *tests/t-change.R a20ddb47504f14b97ad256b3d93c3744 *tests/t-change.Rout.save 2eda2a0efeaa604d263e52a9bd2e4f69 *tests/t-demo.R e52e4aca5987fbf211b58fe9204d42a0 *tests/t-demo.Rout.save 8452f028d2a96da42b8a34a19fd786db *tests/t-error.R 70227c8ad478ef051288ab6789c6bd36 *tests/t-error.Rout.save 3742b92dc563da304720b8567552d2a5 *tests/t-exec.R da05971924d907a39ac0c2d0924c8a97 *tests/t-exec.Rout.save 0ce84fb5295d6b9c84622bedf1a37b1d *tests/t-get.R 5a19d899a5b7c36dcbc3678954289be0 *tests/t-get.Rout.save f18ec25669f0c2dc3df0a0133f08320e *tests/t-global.R 0dab98c8f3cce118b889500c6592ca63 *tests/t-global.Rout.save 2d6b362d88a5d66dec436eec9fdc3993 *tests/t-handledruns.R 8c5223c2ec6f574d1bc3a7bdd9affa03 *tests/t-handledruns.Rout.save 6d754caa40bf36316ec7819008d49dbd *tests/t-ischecks.R 65a7c21a8cd053343903c602e3cfd87b *tests/t-ischecks.Rout.save ca3328d23aea8c6607025ed8a1a16469 *tests/t-item.R 368e2a600b3c8c21614ce9dc6e5dd98b *tests/t-item.Rout.save 529f3296f60ec020386c6e3158e925ed *tests/t-list.R d69dc59921392d83e8415b6379914d6f *tests/t-list.Rout.save f9ba6b7a38c47141de50c0c73596c610 *tests/t-misc.R 4b1217b01456e4f76aa7918d16c250ed *tests/t-misc.Rout.save 5a0c13d88368f1ed1af7139a5ceba795 *tests/t-nav.R 98bbe39dc6339c33f8901e7d3ab2195d *tests/t-nav.Rout.save 087ee48415448850bf20e049d6a0448a *tests/t-parse.R 0afd2f255e5249c0237fbeb907c56d39 *tests/t-parse.Rout.save 4304bb04ce805eff14418f44eebb0651 *tests/t-prompt.R 0515951018235e638cc7b35625e79864 *tests/t-prompt.Rout.save 46ae28b24ba5ac8ec666d8404c20f3d4 *tests/t-random.R 267fb047561dfaf5674dde7118db5df6 *tests/t-random.Rout.save ebab94559844559230171c8c3067d5d3 *tests/t-rename.R 28203e74f04708dd0ce525e713d8a35a *tests/t-rename.Rout.save 39199f202351b7238ee467363b6d0d19 *tests/t-repairenvs.R 906a7cd33db04bd7b3bff981a29a2dea *tests/t-repairenvs.Rout.save 87b617a44642e8b207e332228af86cdb *tests/t-search.R bf4fbdcbf84486340896e3542c593b96 *tests/t-search.Rout.save 5252802d2c1ba6f538e1d7df62614bf2 *tests/t-section.R 2b524bc5cc3a5014ed7b58d4cb60dc78 *tests/t-section.Rout.save c9363133fa5b30ae392db16e3f4c36cd *tests/t-shim.R 1da215be59ed8408789d9bce4f0795e4 *tests/t-shim.Rout.save 5a18ba39af57e655053606147b54a746 *tests/t-state.R c2d53b01213fd52ebaff2d579e2b10e4 *tests/t-state.Rout.save 33c8fb04d1b8a156a60438ef1ca6123d *tests/t-text.R ed9bedea4e3155c5e86f9167120ab36b *tests/t-text.Rout.save d07a5562787a6d9669b553f1003863f5 *tests/t-translate.R 2f1164750f770fd7b06ecb014a955bb7 *tests/t-translate.Rout.save 4171aa3fb47064ba0649cda87a32e3a7 *tests/t-upgrade.R 2256b36841a0e67db00c5b4ae159efd5 *tests/t-upgrade.Rout.save b767c46b44b6cdf23d9ad7d03d62f85e *tests/t-utz1.R cc8a2f2d0cd9782429c682f7589a8222 *tests/t-utz1.Rout.save ef7cdcc4450d265dd34d4595cadf4527 *tests/t-utz2.R bfee1b380d2ceceb457c7fead1149b18 *tests/t-utz2.Rout.save 58084bef533125107eb1d53553def112 *tests/testthat/README 64229fd4a66b0c378eea1ee0226f9b27 *tests/zz-check.R b7b977bc5e5ba8b88c2dbf4184cd2709 *vignettes/rmdhunks/intro.Rmd 6877d0d22e41065f71e31ff6096c38ef *vignettes/rmdhunks/usage.Rmd 581d1fb1675e0bbfa63680e7b496a177 *vignettes/styles.css 77c3c89384af0dc551e34f166553c899 *vignettes/u0_unitizer_index.Rmd 8a12b56418b1c25e0b90bc96eb72111c *vignettes/u1_intro.Rmd 89a772d34ed168ddab967a75f78f5fb6 *vignettes/u2_tests.Rmd aafc9cd6502d3b16e5f1d85b5508de6d *vignettes/u3_interactive-env.Rmd eb994f55094165b9f1b0c48097d84749 *vignettes/u4_reproducible-tests.Rmd 3d377c485d57a4a8cb2a020ede3f5fe6 *vignettes/u5_miscellaneous.Rmd unitizer/R/0000755000176200001440000000000014766360070012335 5ustar liggesusersunitizer/R/size.R0000644000176200001440000000556214766101401013431 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R NULL #' Utility To Examine Object Size #' #' Funny name is just to avoid conflicts with functions with same names in #' other packages. #' @keywords internal setGeneric("sizeUntz", function(x, ...) StandardGeneric("sizeUntz")) # nocov setMethod( "sizeUntz", "ANY", function(x, ...) c(size=object.size(x), rds=sizeRDS(x)) ) setMethod( "sizeUntz", "unitizerItems", function(x, ...) { items <- flattenUntz(x) if(!length(items)) return(c(size=0, rds=0)) t(apply(items, 2, function(x) c(size=object.size(x), rds=sizeRDS(x)))) } ) setMethod("sizeUntz", "unitizer", function(x, ...) { res <- lapply(slotNames(x), function(y) { size.tmp <- sizeUntz(slot(x, y)) if(is.matrix(size.tmp)) { rbind( matrix(apply(size.tmp, 2, sum), ncol=2, dimnames=list(y, NULL)), `rownames<-`(size.tmp, paste0(" ", rownames(size.tmp))) ) } else matrix(size.tmp, ncol=2, dimnames=list(y, NULL)) } ) do.call(rbind, res) } ) #' Reduce S4 objects Into Lists #' #' This is particularly useful with "list" type S4 objects, and relates loosely #' to the subsetting functions defined for \code{unitizerBrowse} objects. #' #' Currently we only define a method for \code{unitizerItems-class} objects #' @keywords internal setGeneric( # nocov start "flattenUntz", function(x, ...) StandardGeneric("flattenUntz") ) # nocov end setMethod( "flattenUntz", "unitizerItems", function(x, ...) { rows <- length(x) if(!rows) return(list()) dat.base <- setdiff(slotNames(x[[1L]]), "data") dat.extra <- slotNames(x[[1L]]@data) col.names <- c(dat.base, dat.extra) cols <- length(col.names) items <- structure( vector("list", cols * rows), dim=c(rows, cols), dimnames=list(NULL, col.names) ) for(i in seq.int(rows)) { items[i, ] <- c( lapply(dat.base, function(z) slot(x[[i]], z)), lapply(dat.extra, function(z) slot(x[[i]]@data, z)) ) } items } ) #' Measure object size as an RDS #' @keywords internal sizeRDS <- function(object) { f <- tempfile() if(inherits(try(saveRDS(object, f, version=2)), "try-error")) return(NA) size <- file.info(f)$size unlink(f) size } unitizer/R/traceback.R0000644000176200001440000000715314766101401014374 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Code in this file is adapted from the R functions `traceback` and # `.traceback` in the base R package. Original copyright notice: # # File src/library/base/R/traceback.R # Part of the R package, https://www.R-project.org # # Copyright (C) 1995-2019 The R Core Team # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # https://www.R-project.org/Licenses/ unitizer_traceback <- function( x = NULL, max.lines = getOption("traceback.max.lines", getOption("deparse.max.lines", -1L)) ) { n <- length(x <- unitizer_dottraceback(x, max.lines = max.lines)) if (n == 0L) cat(gettext("No traceback available"), "\n") else { for (i in 1L:n) { xi <- x[[i]] label <- paste0(n - i + 1L, ": ") m <- length(xi) srcloc <- if (!is.null(srcref <- attr(xi, "srcref"))) { srcfile <- attr(srcref, "srcfile") paste0(" at ", basename(srcfile$filename), "#", srcref[1L]) } if (isTRUE(attr(xi, "truncated"))) { xi <- c(xi, " ...") m <- length(xi) } if (!is.null(srcloc)) { xi[m] <- paste0(xi[m], srcloc) } if (m > 1) label <- c( label, rep(substr(" ", 1L, nchar(label, type = "w")), m - 1L) ) cat(paste0(label, xi), sep = "\n") } } invisible(x) } unitizer_dottraceback <- function ( x = NULL, max.lines = getOption("traceback.max.lines", getOption("deparse.max.lines", -1L)) ) { if(!is.null(x)) stop( "You are using an overloaded `.traceback` that requires `x` to be ", "NULL; you can use standard `traceback` with `base::traceback`." ) stopifnot(length(max.lines) <= 1) .is.positive.intlike <- function(x) is.numeric(x) && length(x) == 1L && !is.na(x) && as.integer(x) >= 0L if (is.null(x) && !is.null(x <- .global$traceback)) { valid.max.lines <- .is.positive.intlike(max.lines) nlines <- if (valid.max.lines) max.lines + 1L else max.lines for (i in seq_along(x)) { srcref <- attr(x[[i]], "srcref") # unitizer's own traceback used the "keepInteger" control prior to # change in 1.4.13. if (typeof(x[[i]]) == "language") x[[i]] <- deparse(x[[i]], nlines = nlines, control="keepInteger") if (valid.max.lines && length(x[[i]]) > max.lines) { x[[i]] <- x[[i]][seq_len(max.lines)] attr(x[[i]], "truncated") <- TRUE } attr(x[[i]], "srcref") <- srcref } } x } unitizer/R/demo.R0000644000176200001440000002156514766101401013404 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Demo Details and Helper Functions #' #' \code{unitizer} provides an interactive demo you can run with #' \code{demo("unitizer")}. #' #' @section Demo Details: #' #' The demo centers around simulated development of the \code{utzflm} #' package. \code{unitizer} includes in its sources three copies of the source #' code for the \code{utzflm} package, each at a different stage of #' development. This allows us to create reference \code{unitizer} tests under #' one version, move to a new version and check for regressions, and finally #' fix the regressions with the last version. The version switching is #' intended to represent the package development process. #' #' The demo manages the \code{utzflm} code changes, but between each #' update allows the user to interact with \code{unitizer}. The demo operates #' under the assumption that the user will accept the first set of tests and #' reject the failing tests after the first update. If the user does anything #' different then the demo commentary may not apply anymore. #' #' @section \code{utzflm}: #' #' \code{utzflm} is a "dummy" package that implements a faster #' computation of slope, intercept, and R^2 for single variable linear #' regressions than is available via \code{summary(lm()...)}. #' #' @section Helper Functions: #' #' \code{copy_fastlm_to_tmpdir} copies the initial version of the #' \code{utzflm} sources to a temporary directory, \code{show_file} #' displays the contents of a source code file, \code{update_fastlm} changes the #' source code of \code{utzflm}, and \code{unitizer_check_demo_state} #' and \code{unitizer_cleanup_demo} perform janitorial functions. None of #' these functions are intended for use outside of the unitizer demo. #' #' @rdname demo #' @name unitizer_demo #' @param f path to a file #' @param dir path to the temporary package #' @param width display width in characters #' @param version one of "0.1.0", "0.1.1", "0.1.2" #' @return character(1L) NULL # nocov start #' @export #' @rdname demo `[Press ENTER to Continue]` <- function() invisible(readline()) # nocov end #' @export #' @rdname demo show_file <- function(f, width=getOption("width", 80L)) { stopifnot(is.chr1(f)) txt <- try(readLines(f)) pkg.dir <- get_package_dir(f) if(length(pkg.dir)) f <- relativize_path(f, pkg.dir) if(inherits(txt, "try-error")) stop("Unable to open file") line.num <- seq_along(txt) line.chars <- max(nchar(line.num)) txt.wrap <- lapply(txt, word_wrap, width=width - 7L) txt.wrap.lines <- vapply(txt.wrap, length, integer(1L)) line.txt <-format( unlist( Map(function(x, y) c(x, rep("", y - 1L)), line.num, txt.wrap.lines) ), justify="right" ) line.txt.chars <- nchar(line.txt[[1L]]) + 2L body <- paste0("| ", line.txt, " | ", format(unlist(txt.wrap)), " |") body.chrs <- nchar(body[[1L]]) file.disp <- word_wrap(f, width=nchar(body[[1L]]) - 4L, hyphens=FALSE) bar <- paste0( c( "+", rep("-", line.txt.chars), "+", rep("-", body.chrs - line.txt.chars - 3L), "+" ), collapse="" ) top.bar <- paste0(c("+", rep("-", body.chrs - 2L), "+"), collapse="") file.disp[[1L]] <- paste0( c( file.disp[[1L]], rep(" ", max(body.chrs - nchar(file.disp[[1L]]) - 4L, 0L)) ), collapse="" ) res <- c(top.bar, paste0("| ", format(file.disp), " |"), bar, body, bar) cat(res, sep="\n") invisible(res) } #' @export #' @rdname demo copy_fastlm_to_tmpdir <- function() { dir <- file.path(tempfile(), "utzflm") if(inherits(try(dir.create(dir, recursive=TRUE)), "try-error")) stop("Unable to create temporary directory '", dir, "'") untz.dir <- system.file(package="unitizer") fastlm.dir <- file.path(untz.dir, "expkg", "flm0") fastlm.files <- list.files( fastlm.dir, full.names=TRUE, include.dirs=TRUE, no..=TRUE ) if(inherits(try(file.copy(fastlm.files, dir, recursive=TRUE)), "try-error")) stop("Unable to copy `fastlm` sources") # need to do this because R CMD build removes files ending in .Rcheck, and # complains about "pre-installed" package in sources, when we explcitly need a # pre installed structure for a different dummy package for our tests fastlm.check <- file.path(dir, "utzflm_Rcheck") fastlm.check.new <- file.path(dir, "utzflm.Rcheck") if(inherits(try(file.rename(fastlm.check, fastlm.check.new)), "try-error")) stop("Unable to rename fastlm check directory") check.dirs <- list.files( file.path(fastlm.check.new, "utzflm"), full.names=TRUE ) if( inherits( try( file.rename( check.dirs, file.path(dirname(check.dirs), sub("^_", "", basename(check.dirs))) ) ), "try-error" ) ) stop("Unable to unmask package sub dirs") dir } # Helper fun for update_fastlm_* .test.core.files <- c( "DESCRIPTION", file.path("R", "fastlm.R"), file.path( "tests", "unitizer", c("fastlm1.R", "fastlm2.R", "unitizer.fastlm.R") ) ) check_test_dir <- function(dir) { stopifnot( file_test("-d", dir), file_test("-d", file.path(dir, "tests", "unitizer")), all(file_test("-f", file.path(dir, .test.core.files))) ) } #' @export #' @rdname demo update_fastlm <- function(dir, version) { check_test_dir(dir) try(detach("package:utzflm", unload=TRUE), silent=TRUE) stopifnot(version %in% c("0.1.0", "0.1.1", "0.1.2")) lm.dir <- switch( version, "0.1.0"="flm0", "0.1.1"="flm1", "0.1.2"="flm2", stop("Internal Error; unknown version") # nocov ) untz.dir <- system.file(package="unitizer") lm.dir.full <- file.path(untz.dir, "expkg", lm.dir) cpy.files <- .test.core.files cpy.from <- file.path(lm.dir.full, cpy.files) cpy.to <- file.path(dir, cpy.files) invisible(file.copy(cpy.from, cpy.to, overwrite=TRUE)) } # copy extra file for tests, this is primarily just for the section tests and # should be used with care as it will mess up all the other tests by adding # an extra file. This also installs version 0.1.2 update_fastlm_extra <- function(dir) { try(detach("package:utzflm", unload=TRUE), silent=TRUE) check_test_dir(dir) lm.dir <- "flm2" untz.dir <- system.file(package="unitizer") lm.dir.full <- file.path(untz.dir, "expkg", lm.dir) file.extra <- file.path("tests", "unitizer", "unitizer.fastlm2.R") stopifnot( file_test("-f", file.path(lm.dir.full, file.extra)) ) cpy.files <- c(.test.core.files, file.extra) cpy.from <- file.path(lm.dir.full, cpy.files) cpy.to <- file.path(dir, cpy.files) invisible(file.copy(cpy.from, cpy.to, overwrite=TRUE)) } # nocov start #' @export #' @rdname demo unitizer_check_demo_state <- function() { vars <- c(".unitizer.fastlm", ".unitizer.test.file") vars.exist <- logical(length(vars)) for(i in seq_along(vars)) vars.exist[[i]] <- exists(vars[[i]], envir=parent.frame(), inherits=FALSE) if(any(vars.exist)) { meta_word_msg( "Variables", paste0("`", vars, "`", collapse=", "), " already exist, but", "must be overwritten for demo to proceed. These could have been left", "over by a previous run of the demo that did not complete properly.", sep=" " ) choice <- simple_prompt("Overwrite variables?") if(!identical(choice, "Y")) stop("Cannot continue demo.") rm(list=vars[vars.exist], envir=parent.frame()) } if("utzflm" %in% rownames(installed.packages())) { meta_word_msg( "'utzflm' pacakge already installed. This could be because of ", "a prior demo run that was unable to clean-up properly after itself. ", "Continuing with demo will overwrite existing installation.", sep=" " ) choice <- simple_prompt("Overwrite existing installation?") if(!identical(choice, "Y")) stop("Cannot continue demo.") } } # nocov end #' @export #' @rdname demo unitizer_cleanup_demo <- function() { vars <- c(".unitizer.fastlm", ".unitizer.test.file") try(detach("package:utzflm"), silent=TRUE) try(unloadNamespace("utzflm"), silent=TRUE) try(remove.packages("utzflm", .libPaths()[[1L]]), silent=TRUE) pkg.dir <- try(get(".unitizer.fastlm", envir=parent.frame())) if( !inherits(pkg.dir, "try-error") && is.chr1plain(pkg.dir) && file_test("-d", pkg.dir) && grepl("unitizer\\.fastlm$", pkg.dir) ) unlink(pkg.dir, recursive=TRUE) unlink(getOption('unitizer.tmp.lib.loc'), recursive=TRUE) options(unitizer.tmp.lib.loc=NULL) rm(list=vars, envir=parent.frame()) } unitizer/R/parse.R0000644000176200001440000011540214766101401013564 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Strategy for parsing comments: # # Look up all entries with parent == 0; these are the top level entries # All the comments that are -id are top level comments. The id refers to the # next statement. Comments don't have parents when they are the last thing in # the file. So logic, using getParseData(): # # # - Get all top level ids # - Get all comments that have -ids or 0 ids # - For each comment with -id, check whether comment line is same as the previous # top level comment end line # + if yes, associate with that statement # + if not, associate with the -id statement # - For zero ids, just check if on same line as last top level statement # # After this, need to break up the data frame into pieces based on what the # top level parent is. This is fine and well, though we need to reset the # top level parents so we can do this recursively for unitizer_sect # # Unfortunately, this gets seriously complicated by the fact that comments # inside calls have for parent the call, irrespective of where they are. # So we need to figure out (ONLY FOR TOP LEVEL COMMENTS): # - is a comment on it's own line? # - if yes, find the next "top level" item # - if no, find previous "top level" item # # Basically, the process is as follows: # 1. define top level (starts of at zero, and for zero, make sure # any negative parents are zero) # 2. Split data frame by top level, and: # - assign comments to each top level object # - assign data frame chunks to each top level object # 3. Recurse through all the objects until we get to terminals # # Net result should be an expression that, for each non terminal # object will have a piece of the original parse data frame attached, # as well as comments (do we need the original parse data frame, maybe # not if we process it all in one go?) # Searches Through Generations Until it Finds Top Level # # Returns the id of the ancestor that is just before \code{`top.level`}, # or \code{`top.level`} if the parent already is \code{`top.level`}. The # idea is to reduce the set of parents for all elements to just the top # level parents as this allows us to split the parse data into sections, # including the calls that were direct children of top level, as well as # the children to those sections. # # @param ids integer the ids to look through # @param par.ids integer the parenthood relationships # @param top.level the id of the top level # @return integer the top level parent ids for \code{`ids`} top_level_parse_parents <- function(ids, par.ids, top.level=0L) { if( !is.integer(ids) || !is.integer(par.ids) || !identical(length(ids), length(par.ids)) ) stop("Arguments `ids` and `par.ids` must be equal length integer vectors") if(!identical(length(setdiff(abs(par.ids), c(ids, top.level))), 0L)) stop("Argument `par.ids` contains ids not in `ids`.") if(!is.integer(top.level) && !identical(length(top.level), 1L)) stop("Argument `top.level` must be a one length integer") if(identical(top.level, 0L)) { par.ids <- pmax(0L, par.ids) } else if (any(par.ids) < 0) { # nocov start stop( "Advanced Parse Error: Argument `par.ids` contains values less than ", "zero, but that is only allowed when `top.level` == 0L." ) # nocov end } # Create lookup matrix so we can look up ids directly. This will be a slightly # sparse matrix to the extend `ids` doesn't contain every number between # range(ids). The idea is to be able to lookup id-par pairs by direct index # access. This is not super efficient since we keep recalculating some of the # data over and over with each recursion. id.range <- range(ids) if(id.range[[1L]] < 1L) stop("Advanced Parse Error: Expected only strictly positive unique ids") par.full <- rep(NA_integer_, id.range[[2L]]) par.full[ids] <- par.ids res <- rep(NA_integer_, length(ids)) for(i in seq_along(par.ids)) { cur.id <- new.id <- par.ids[[i]] while(cur.id != top.level) { new.id <- par.full[[cur.id]] if(is.na(new.id)) break; if(new.id == top.level) { new.id <- cur.id break; } cur.id <- new.id } res[[i]] <- new.id } res } # For Each ID Determines Generation # # @param ids integer() the object ids # @param par.ids integer() the parents of each \code{ids} # @param id integer() the first parent # @return matrix containing ids and corresponding generation for the ids ancestry_descend <- function(ids, par.ids, id, level=0L) { # Initialize result matrix, can be no bigger than ids max.size <- length(ids) res <- matrix( rep(NA_integer_, max.size * 2L), ncol=2L, dimnames=list(NULL, c("children", "level")) ) ind.start <- 1L par.idx <- 1L par.list <- id id.split <- list2env(split(ids, par.ids)) repeat { if(!length(par.list)) break child.len <- length(children <- id.split[[as.character(par.list[[par.idx]])]]) if(child.len) { ind.end <- ind.start + child.len - 1L inds <- ind.start:ind.end res[inds, 1L] <- children res[inds, 2L] <- level ind.start <- ind.end + 1L } par.idx <- par.idx + 1L if(par.idx > length(par.list)) { par.list <- res[which(res[, 2L] == level), 1L] level <- level + 1L par.idx <- 1L } } res[!is.na(res[, 1L]), ] } # Need this to pass R CMD check; problems likely caused by `transform` and # `subset`. if(getRversion() >= "2.15.1") utils::globalVariables(c("token", "col1", "line1")) # Assign Comments From Parse Data to Expression Elements # # Based on parse data from \code{`\link{getParseData}`}, figures # out what comments belong to what expression. If a comment is # on the same line as an expression, the comment is assigned to that # expression (or whatever the nearest expression is on that line if # there is more than one). If a comment is on it's own line, # then the match is done to the next expression. # # The expectation is that only "top level" expressions will # be submitted as part of `comment.dat` (i.e. they all have # the same parent, they don't strictly have to be top.level). # # @param expr and expression # @param comment.dat a data frame derived from \code{`\link{getParseData}`} # @return an expression with comments attached as attributes to each # expression component comments_assign <- function(expr, comment.dat) { if(!identical(length(unique(comment.dat$parent)), 1L)) stop( # nocov start "Advanced Parse Error: there were multiple parent ids in argument ", "`comment.dat`; this should not happen." ) # nocov end if(!length(expr) || !length(which(comment.dat$token == "COMMENT"))) return(expr) # Make sure `comment.dat` is in format we understand # Theory: everything not "COMMENT" should be included, except: # - opening parens on second row (these denote a function call) # - closing braces of any kind on last row # Additionally, in order for stuff to match up properly, anything that is not # "expr" needs to be moved to the front (in theory, should be at most one thing # and should be an infix operator of some sort) if( !tail(comment.dat$token, 1L) %in% c("COMMENT", "expr", tk.lst$non.exps, tk.lst$brac.close, "';'") ) # nocov start stop( "Advanced Parse Error: unexpected ending token in parse data." ) # nocov end if( length(which(comment.dat$token %in% tk.lst$brac.open)) > 1L || length(which(comment.dat$token %in% tk.lst$brac.close)) > 1L ) { stop( # nocov start "Advanced Parse Error: more than one bracket at top level." ) # nocov end } if( length(brac.pos <- which(comment.dat$token %in% tk.lst$brac.close)) && !identical(brac.pos, nrow(comment.dat)) ) { # nocov start # shouldn't happen, can't test if( !identical(comment.dat$token[brac.pos], "')'") || !identical(brac.pos, nrow(comment.dat) - 1L) || !identical(comment.dat$token[[1L]], "FUNCTION") ) { stop( "Advanced Parse Error: closing brackets may only be on last row, ", "unless a paren and part of a functions formal definition." ) } # nocov end } if( !all(match(comment.dat$token, tk.lst$brac.open[-3L], 0L) <= 1L) || !all(match(comment.dat$token, tk.lst$brac.open[3L], 0L) <= 2L) ) { stop( # nocov start "Advanced Parse Error: opening brackets may only be on first row, ", "or second if paren." ) # nocov end } if( !identical( which(tk.lst$brac.open %in% comment.dat$token), which(tk.lst$brac.close %in% comment.dat$token) ) ) stop("Advanced Parse Error: mismatched brackets.") # nocov # extra.toks <- if(any(brac.open %in% comment.dat$token)) 2L else 1L # Trim our data to just what matters: comm.notcomm <- prsdat_reduce(comment.dat) if(!identical(nrow(comm.notcomm), length(expr))) { # nocov start stop( "Advanced Parse Error: Argument `expr` length cannot be matched with ", "values in `comment.dat`" ) # nocov end } # for the purposes of this process, constants and symbols are basically # expressions comm.notcomm <- transform( comm.notcomm, token=ifelse( token %in% c( tk.lst$exps, tk.lst$non.exps, tk.lst$non.exps.extra, tk.lst$ops ), "expr", token ) ) # what comments are on same line as something else comm.comm <- subset(comment.dat, token=="COMMENT") comm.expr <- subset(comm.notcomm, token=="expr") # identify whether a token is the first or last on it's line. Values mean # - 3L is only item on line (we think) # - 2L is last item on line (we think) comm.expr$first.last.on.line <- with( comm.expr, ave( col1, line1, FUN=function(x) if(length(x) == 1L) 3L else ifelse(x == max(x), 2L, ifelse(x == min(x), 1L, 0L)) ) ) # For each comment on a line that also has an expression, find the expression # that is also on that line comm.comm$assign.to.prev <- with( comm.expr, line2[match(comm.comm$line1, line2)] ) comm.comm$match <- with(comm.expr, { last.or.only <- first.last.on.line %in% 2L:3L id[last.or.only][match(comm.comm$assign.to.prev, line1[last.or.only])] } ) # For each comment on its own line, find the expression that follows it first.or.only <- comm.expr$first.last.on.line %in% c(1L, 3L) comm.comm$assign.to.next <- vapply( comm.comm$line1, function(x) if(any(idx <- (comm.expr$line1 > x))) min(comm.expr$line1[idx]) else NA_integer_, integer(1L) ) comm.comm$match <- ifelse( is.na(comm.comm$match), comm.expr$id[first.or.only][ match(comm.comm$assign.to.next, comm.expr$line1[first.or.only]) ], comm.comm$match ) # Assign comments to matching expression in attributes for(i in seq_along(comm.comm$match)) { if(is.na(comm.comm$match[[i]])) next expr.pos <- which(comm.notcomm$id == comm.comm$match[[i]]) if(!identical(length(expr.pos), 1L)) stop("Advanced Parse Error.") # nocov if(!is.null(expr[[expr.pos]])) { # names are registered in global pool, so you can only attach attributes # to as single unique in memory instance, irrespective of where or how # many times a name occurs in an expression. Because of this, we must # turn names that we want to attach comments to into simple language by # adding parens. Note this changes structure of expression but hopefully # doesn't mess anything up later on... # # Also, constants, NULL, etc. if(length(expr[[expr.pos]]) < 2) { expr[[expr.pos]] <- call("(", expr[[expr.pos]]) attr(expr[[expr.pos]], "unitizer_parse_symb") <- TRUE } attr(expr[[expr.pos]], "comment") <- c(attr(expr[[expr.pos]], "comment"), comm.comm$text[[i]]) } } expr } # Need this to pass R CMD check; problems likely caused by `transform` and # `subset`. if(getRversion() >= "2.15.1") utils::globalVariables(c("id", "parent", "token", "line2")) # Recursively Descends Through a Parsed Expression and Assigns Comments # # In order to implement this we had to make several assumptions about the # behaviour of \code{`\link{getParseData}`}. In particular: # \itemize{ # \item Top level comments show up with negative ids, but are top level # for all intents and purposes # \item All content tokens (i.e. anything other than brackets, commas, # etc.) are contained inside an \code{`expr`}, even if the only thing the # `expr` contains is a simple constant (note some exceptions exist to # this (search for FUCK in the source). # \item Comments are not content tokens and can exist on the top level # without being wrapped in an \code{`expr`} # \item The only tokens that count as elements in an expression are # opening brackets and \code{`expr`}; this assumption is necessary # to allow mapping the parsed data back to the expression. What # confuses the issue a bit is that operators show up at the top level, # but you can actually # ignore them. Also, parentheses should only be kept if they are the # topmost item, as otherwise they are part of a function call and # should be ignored. # \item Comments inside function formals are not assigned to the formals # proper # \item `exprlist` tokens are removed completely b/c as far as we can # tell they are not part of the parsed object (but exist in parse # data). # \item known issue: comments in formals after a line break are assigned # to the body of the function as opposed to \code{`function`}, but this # should not be apparent in common use. # \item you cannot attach comments to \code{`NULL`}, if you must use # \code{`(NULL)`}. This is a feature, as it proivdes a way to put # comments in the file without them showing up during \code{`unitizer`} # use. # } # Note that as a result of this trial and error interpretation of # \code{`\link{getParseData}`} it is likely that comment parsing is # not 100 percent robust. # # Due to some reference weirdness going on when dealing directly with # expressions had to change this function to accept text/file rather # than an expression as an input (but even that didn't fix it!!!) # # @keywords internal # @aliases parse_tests # @seealso comments_assign, getParseData, parse # @param file containing code to parse with comments # @param text optional, text to parse if \code{`file`} is not specified # @param comment logical(1L) whether to try to get comments # @return an expression with comments retrieved from the parse attached # to the appropriate sub-expressions/calls as a \dQuote{comment} \code{`\link{attr}`} parse_with_comments <- function(file, text=NULL) { # Looping to deal with issue #41 res <- parse_dat_get(file, text) parse.dat.raw <- res$dat expr <- res$expr if(!length(expr)) return(expr) # Now proceed with actual parsing # hack to deal with issues with expressions retaining previous assigned # comments (need to examine this further) expr <- comm_reset(expr) # set negative ids to be top level parents parse.dat.raw.1 <- transform( parse.dat.raw, parent=ifelse(parent < 0, 0L, parent) ) ancestry <- with(parse.dat.raw.1, ancestry_descend(id, parent, 0L)) parse.dat <- prsdat_fix_exprlist(parse.dat.raw.1, ancestry) if(is.null(parse.dat)) stop("Argument `expr` did not contain any parse data") if(!is.data.frame(parse.dat)) stop("Argument `expr` produced parse data that is not a data frame") if(!nrow(parse.dat)) return(expr) if(! identical( names(parse.dat), c( "line1", "col1", "line2", "col2", "id", "parent", "token", "terminal", "text" ) ) ) stop("Argument `expr` produced parse data with unexpected column names") if(!identical(unname(vapply(parse.dat, class, "")), c("integer", "integer", "integer", "integer", "integer", "integer", "character", "logical", "character"))) stop("Argument `expr` produced data with unexpected column data types") if(!all(parse.dat$token %in% unlist(tk.lst))) { # nocov start # shouldn't happen, can't test stop( "Advanced Parse Error: unexpected tokens in parse data (", paste0(parse.dat$token[!parse.dat$token %in% unlist(tk.lst)]) , ")." ) # nocov end } prsdat_recurse <- function(expr, parse.dat, top.level) { if(identical(parse.dat$token[[1L]], "FUNCTION")) parse.dat <- prsdat_fix_fun(parse.dat) if(identical(parse.dat$token[[1L]], "FOR")) parse.dat <- prsdat_fix_for(parse.dat) if(identical(parse.dat$token[[1L]], "IF")) parse.dat <- prsdat_fix_if(parse.dat) if(identical(parse.dat$token[[1L]], "WHILE")) parse.dat <- prsdat_fix_while(parse.dat) par.ids <- with(parse.dat, top_level_parse_parents(id, parent, top.level)) parse.dat.split <- split(parse.dat, par.ids) prsdat.par <- parse.dat.split[[as.character(top.level)]] prsdat.children <- parse.dat.split[names(parse.dat.split) != as.character(top.level)] # Check that the parse data doesn't break the assumptions we've made, # particularly, that for any child section, there are no overlapping # sections at the top level line.dat <- vapply( prsdat.children, function(x) with(x, c(max=max(line2), min=min(line1))), c(max=0L, min=0L) ) col.dat <- vapply( seq_along(prsdat.children), function(i) with( prsdat.children[[i]], { c( max=max(col2[which(line2 == line.dat["max", i])]), min=min(col1[which(line1 == line.dat["min", i])]) ) } ), c(max=0L, min=0L) ) if( any(head(line.dat["max", ], -1L) > tail(line.dat["min", ], -1L)) || any( head(line.dat["max", ], -1L) == tail(line.dat["min", ], -1L) & head(col.dat["max", ], -1L) >= tail(col.dat["min", ], -1L) ) ) { # nocov start # shouldn't happen, can't test stop("Advanced Parse Error: expression parse data overlapping.") # nocov end } # For each parent expression, assign comments; parent expressions that # include a function definition have to exclude the formals part (which is a # pairlist) because the `getParseData` output does not produce a parent # element for the formals; in practice this shouldn't have any impact # because test items will never be at such a low level (i.e. any comments at # this level would never be shown anyway). assignable.elems <- vapply( expr, function(x) !identical(typeof(x), "pairlist") && !any("srcref" == class(x)), logical(1L) ) if(!is.call(expr) && !is.expression(expr) && !is.null(expr)) { if(!length(assignable.elems) %in% c(1L)) { stop( # nocov start "Advanced Parse Error: expression is terminal token yet multiple ", "assignable elems." ) # nocov end } if(isTRUE(assignable.elems)) expr <- comments_assign(expr, prsdat.par) } else if (!is.null(expr)) { expr[assignable.elems] <- comments_assign(expr[assignable.elems], prsdat.par) } # Now do the same for the child expression by recursively calling this # function until there are no children left, but need to be careful here # because we only need to call this for non-terminal leaves of the parse # tree. Simply removing non terminal leaves from call should leave # everything in correct order because the only time there are order # mismatches are with infix operators and those are terminal leaves anyway. if( !any( vapply( prsdat.children, function(child) with(child, "COMMENT" %in% token), logical(1L) ) ) ) return(expr) # stuff that corresponds to elements in `expr`, will re-order to match `expr` prsdat.par.red <- prsdat_reduce(prsdat.par) if(!identical(nrow(prsdat.par.red), length(which(assignable.elems)))) { # nocov start stop( "Advanced Parse Error: mismatch between expression and parse data." ) # nocov end } j <- 1 if(!is.expression(expr) && !is.call(expr)) { # nocov start # shouldn't happen, can't test if(term.len <- length(which(!prsdat.par.red$terminal)) > 1L) { stop( "Advanced Parse Error: terminal expression has more than one token." ) } else if (term.len) { expr <- Recall( expr, prsdat.children[[j]], as.integer(names(prsdat.children)[[j]]) ) } # nocov end } else { for(i in 1:nrow(prsdat.par.red)) { if(prsdat.par.red$terminal[[i]]) next new.val <- Recall( expr[assignable.elems][[i]], prsdat.children[[j]], as.integer(names(prsdat.children)[[j]]) ) if(!is.null(new.val)) expr[assignable.elems][[i]] <- new.val j <- j + 1 } } expr } prsdat_recurse(expr, parse.dat, top.level=0L) } # Handle the issues with needing to run parse twice due to weird getParseData # output parse_dat_get <- function(file, text) { parse.dat.raw <- NULL for(i in 1:2) { if(!is.null(text)) { if(!missing(file)) # nocov start stop("Internal Error: cannot specify both `file` and `text` arguments.") # nocov end expr <- try(parse(text=text, keep.source=TRUE)) } else { expr <- try(parse(file, keep.source=TRUE)) } if(inherits(expr, "try-error")) stop("parsing failed") if(!length(expr)) break parse.dat.raw <- getParseData(expr) if(is.null(parse.dat.raw)) break if(!nrow(parse.dat.raw)) stop("Advanced Parse Error: parse data mismatch.") # nocov parse.dat.check <- cbind( parse.dat.raw[ match(parse.dat.raw$parent, parse.dat.raw$id), c("line1", "col1") ], setNames( parse.dat.raw[, c("line1", "col1")], c("line1.child", "col1.child") ) ) if( length( with(parse.dat.check, which( line1.child < line1 | (line1.child == line1) & col1.child < col1 ) ) ) ) { # Parsing is not self consistent; some child items have for parents items # that are lexically posterior if(identical(i, 1L)) # Try again once to see if that fixes it next # nocov start stop("Advanced Parse Error: cannot retrieve self consistent parse data") # nocov end } break # Parsing worked as expected } list(expr=expr, dat=parse.dat.raw) } parse_tests <- function(file, comments=TRUE, text=NULL) { if(!isTRUE(comments) && !identical(comments, FALSE)) stop("Argument `comments` must be TRUE or FALSE") if(!is.null(text) && !missing(file)) stop("If Argument `text` is specified, argument `file` must be missing") parsed <- NULL if(comments) { parsed <- tryCatch( parse_with_comments(file, text), error=function(e) { if(identical(conditionMessage(e), "parsing failed")) stop("Unable to parse test file; see previous messages") warning( "Unable to recover comments in advanced parse because:\n\n", paste0( " ", strwrap(conditionMessage(e), getOption('width') - 10), "\n" ), "\nFalling back to simple parse.", immediate.=TRUE, call.=FALSE ) NULL } ) } # Either no comment mode, or couldn't extract in comment mode if(is.null(parsed)) { if(is.null(text)) { parse(file, keep.source=FALSE) } else parse(text=text, keep.source=FALSE) } else parsed } # Need this to pass R CMD check; problems likely caused by `transform` and # `subset`. if(getRversion() >= "2.15.1") utils::globalVariables(c("token")) # Reduce Parsed Data to Just the Things That should Exist In Expression # # additionally, special handling due to function and formals not getting wrapped # in their own `expr` (why the FUCK!!!!) # # @aliases prsdat_remove_fun # @param parse.dat top level parse data # @return parse data reduced to key elements, ordered so that infix operators # show up first instead of in middle prsdat_reduce <- function(parse.dat) { parse.dat.red <- subset( parse.dat, !token %in% c(tk.lst$brac.close, tk.lst$unassign, tk.lst$seps, "COMMENT") & !(token == "'('" & 1L:length(token) == 2L) ) # at this point, must be all expressions, an opening bracket, or an operator of some # sort, and iff the operator is @ or $, or if there is only one item in the data frame # then it can be NUM_CONST or STR_CONST or symbol for the second one if(any(c("'$'", "'@'") %in% parse.dat.red$token)) { if(!identical(nrow(parse.dat.red), 3L)) { # nocov start stop( "Advanced Parse Error: top level statement with `@` or `$` must be ", "three elements long" ) # nocov end } if(!identical(parse.dat.red$token[[1L]], "expr")) { # nocov start stop( "Advanced Parse Error: left argument to `@` or `$` must be an ", " expression" ) # nocov end } if( identical(parse.dat.red$token, "'@'") && !identical(parse.dat.red$token[[3L]], "SLOT") ) { # nocov start stop("Advanced Parse Error: right argument to `@` must be SLOT") # nocov end } if( identical(parse.dat.red$token, "'$'") && !identical(parse.dat.red$token[[3L]], "SYMBOL") ) { # nocov start stop("Advanced Parse Error: right argument to `$` must be SYMBOL") # nocov end } } else if (nrow(parse.dat.red) == 1L) { if( !parse.dat.red$token[[1L]] %in% c("expr", tk.lst$non.exps, tk.lst$non.exps.extra, tk.lst$brac.open) ) { # nocov start stop( "Advanced Parse Error: single element parent levels must be symbol or ", "constant or expr" ) # nocov end } } else if ( length( which( parse.dat.red$token %in% c(tk.lst$exps, tk.lst$non.exps, tk.lst$non.exps.extra) ) ) < nrow(parse.dat.red) - 1L ) { # nocov start stop( "Advanced Parse Error: in most cases all but at most one token must be ", "type `expr` or `exprlist`." ) # nocov end } parse.dat.red[ order( parse.dat.red$token %in% c(tk.lst$exps, tk.lst$non.exps, tk.lst$non.exps.extra) ), ] } # Need this to pass R CMD check; problems likely caused by `transform` and # `subset`. if(getRversion() >= "2.15.1") utils::globalVariables(c("id", "token")) # Functions to Adjust Parse Data To Match Expression # # \itemize{ # \item \code{`prsdat_fix_fun`} extract all comments from formals and brings them # up a level, and then removes formals # \item \code{`prsdat_fix_for`} brings contents of `forcond` to same level as # `for` to match up with expression # \item \code{`prsdat_fix_for`} extracts expression from the condition (though # apparently not from `ifcond`) # \item \code{`prsdat_fix_exprlist`} excises the \code{`exprlist`} portions of # \code{`exprlist`} as those don't exist in the expressions proper; they # don't do anything, and have extraneous semi colons. We need to remove # them, and then make sure all their children become children of the # parent of the exprlist # parent # \item \code{`prsdat_find_paren`} returns locations of first set # of open and close parens # } # @aliases prsdat_fix_for, prsdat_find_paren, prsdat_fix_exprlist # @param parse.dat a data frame of the type produced by \code{`\link{getParseData}`} # @return \itemize{ # \item for \code{`parsdat_fix*`}, a data frame of the type produced by \code{`\link{getParseData}`} # \item for \code{`parsdat_find_paren`}, a length two integer vector with the ids of the parens # } prsdat_fix_fun <- function(parse.dat) { if(!identical(parse.dat$token[[1L]], "FUNCTION")) stop("Argument `parse.dat` must start with a 'FUNCTION' token.") subset( parse.dat, 1L:nrow(parse.dat) > which(id == prsdat_find_paren(parse.dat)[[2]]) | token == "COMMENT" | 1L:nrow(parse.dat) == 1L ) } # Need this to pass R CMD check; problems likely caused by `transform` and # `subset`. if(getRversion() >= "2.15.1") utils::globalVariables(c("id", "parent", "token")) prsdat_fix_for <- function(parse.dat) { if(!identical(parse.dat$token[[1L]], "FOR")) stop("Argument `parse.dat` must start with a 'FOR' token.") if(!identical(parse.dat$token[parse.dat$token != "COMMENT"][[2]], "forcond")) stop("Argument `parse.dat` does not have token `forcond` in expected location") if(!identical(length(which(parse.dat$token == "forcond")), 1L)) stop("Argument `parse.dat` should have exactly one `forcond` token") par.range <- prsdat_find_paren(parse.dat) par.level <- subset(parse.dat, id == par.range[[1]])$parent tokens <- tail(head(subset(parse.dat, parent==par.level)$token, -1L), -1L) tokens.no.comm <- tokens[tokens != "COMMENT"] if(!identical(length(tokens.no.comm), 3L)) stop("Logic error: `forcond` should have three elements") if(!identical(which(tokens.no.comm == "IN"), 2L)) stop("Logic error: `forcond` should have exactly one 'IN' in position 2L") parse.dat.mod <- subset(parse.dat, !token %in% c("forcond", "IN") & ! id %in% par.range) `[<-`(parse.dat.mod, parse.dat.mod$parent == par.level, "parent", parse.dat[1L, "parent"]) } # Need this to pass R CMD check; problems likely caused by `transform` and # `subset`. if(getRversion() >= "2.15.1") utils::globalVariables(c("id", "parent", "token")) prsdat_fix_simple <- function(parse.dat, tok) { if(! tok %in% c("IF", "WHILE")) # nocov start stop( "Advanced Parse Error: this function only supports 'IF' and 'WHILE' ", "tokens" ) # nocov end if(!identical(parse.dat$token[[1L]], tok)) stop("Argument `parse.dat` must start with an '", tok, "' token.") par.id <- parse.dat$parent[[1L]] par.range <- prsdat_find_paren(parse.dat) early.tokens <- parse.dat$token[1L:(which(parse.dat$id == par.range[[1L]]) - 1L)] if( any(! early.tokens %in% c(tok, "COMMENT")) || !identical(length(which(early.tokens == tok)), 1L) ) # nocov start stop( "Advanced Parse Error: could not parse ", tok, " statement." ) # nocov end parse.delete <- subset(parse.dat, parent == par.id & token %in% c("'('", "')'", "ELSE")) if(!nrow(parse.delete) %in% c(2L, 3L)) # nocov start stop( "Advanced Parse Error: unexpected number of ", tok, " statement sub-components; contact maintainer." ) # nocov end if(any(parse.dat$parent %in% parse.delete$id)) # nocov start stop( "Advanced Parse Error: unexpected parent relationships in ", tok, " statement." ) # nocov end subset(parse.dat, ! id %in% parse.delete$id) } prsdat_fix_if <- function(parse.dat) prsdat_fix_simple(parse.dat, "IF") prsdat_fix_while <- function(parse.dat) prsdat_fix_simple(parse.dat, "WHILE") prsdat_find_paren <- function(parse.dat) { par.clos.pos <- match("')'", parse.dat$token) if(is.na(par.clos.pos)) # nocov start stop( "Advanced Parse Error: failed attempting to parse function block." ) # nocov end par.op.pos <- match("'('", parse.dat$token[1:par.clos.pos]) if(is.na(par.op.pos)) if( !identical(par.op.pos, 2L) && !identical(unique(parse.dat$token[2L:(par.op.pos - 1L)]), "COMMENT") ) # nocov start stop( "Advanced Parse Error: failed attempting to `for` function block." ) # nocov end c(open=parse.dat$id[[par.op.pos]], close=parse.dat$id[[par.clos.pos]]) } prsdat_fix_exprlist <- function(parse.dat, ancestry) { z <- ancestry z[, "level"] <- z[match(parse.dat$id, z[, "children"]), "level"] # order by level to make sure we remove exprlists in correct order lev.ord <- order(z[, "level"]) dat.ord <- parse.dat[lev.ord, ] ind.all <- seq.int(nrow(dat.ord)) # map parents vs. position in ordered list par.map <- list2env(split(ind.all, dat.ord[["parent"]])) dat.exprlist <- which(dat.ord[["token"]] == "exprlist") ind.exp <- seq_along(dat.exprlist) ind.exclude <- logical(length(ind.all)) if(length(dat.exprlist)) { dat.ord <- within( dat.ord, { for(exprlist.ind in dat.exprlist) { # Find first `exprlist` exprlist.par <- parent[[exprlist.ind]] # Promote all children of exprlist and remove semi-colons and actual # exprlist. This requires updating the value of the parent column in # `dat.ord`, and then re-assigning the parent ship relationship exprlist.par.chr <- as.character(exprlist.par) exprlist.id.chr <- as.character(id[[exprlist.ind]]) exprlist.children <- par.map[[exprlist.id.chr]] # semi colons with exprlist as parent need to be discarded semicol.ind <- exprlist.children[which(token[exprlist.children] == "';'")] # change exprlist children parent to exprlist parent parent[exprlist.children] <- exprlist.par # Update mapping to reflect new parentship par.map[[exprlist.par.chr]] <<- c( par.map[[exprlist.par.chr]], par.map[[exprlist.id.chr]] ) par.map[[exprlist.id.chr]] <<- NULL # extend exclusion list ind.exclude[c(exprlist.ind, semicol.ind)] <<- TRUE } rm( exprlist.par, exprlist.par.chr, exprlist.id.chr, exprlist.children, exprlist.ind, semicol.ind ) } ) } # Now actually remove the exprlist and semi colons, and re-order parse.dat.mod <- dat.ord[order(lev.ord), ][which(!ind.exclude[order(lev.ord)]), ] if(!all(parse.dat.mod$parent %in% c(0, parse.dat.mod$id))) stop("Advanced Parse Error: `exprlist` excision did not work!") # nocov parse.dat.mod } # Removes Symbol Marker Used To Hold Comments symb_mark_rem <- function(x) { if(isTRUE(attr(x, "unitizer_parse_symb"))) { if(length(x) != 2L || x[[1L]] != as.name("(") || length(x[[2L]]) != 1L) { stop( # nocov start "Advanced Parse Error: Unexpected structure for object with language ", "with 'unitizer_parse_symb' attribute attached." ) } # nocov end x <- x[[2L]] } x } # Utility Function to Extract Comments From Expression # # Note that when dealing with expressions the very first item will typically # be NULL to allow for logic that works with nested structures. # # \code{comm_and_call_extract} also pulls out a cleaned up version of the call # along with the comments, but the comments come out in a vector instead of a # list showing the structure where the comments were pulled from. # # Used mostly for testing purposes. comm_extract <- function(x) { if(missing(x)) return(list(NULL)) comm <- attr(x, "comment") x <- symb_mark_rem(x) # get rid of comment container if(missing(x)) return(list(NULL)) # need to do this twice because missing args that are parsed aren't necessarily recognized as missing immediately if(is.expression(x) || length(x) > 1L) { return(c(list(comm), lapply(x, comm_extract))) } else { return(list(comm)) } } comm_and_call_extract <- function(x) { comments <- character() rec <- function(call) { if(missing(call)) return(call) comm <- attr(call, "comment") if(!is.null(comm)) { comments <<- c(comments, comm) attr(call, "comment") <- NULL } call.clean <- symb_mark_rem(call) # get rid of comment container if(missing(call.clean)) return(call.clean) # need to do this twice because missing args that are parsed aren't necessarily recognized as missing immediately if(is.expression(call.clean) || length(call.clean) > 1L) { for(i in seq_along(call.clean)) { call.sub <- call.clean[[i]] if(!missing(call.sub) && !is.null(call.sub)) call.clean[[i]] <- rec(call.clean[[i]]) } } call.clean } list(call=rec(x), comments=comments) } # Utility Function to Reset Comments # # Required due to bizarre behavior (bug?) where some expression attributes # appear to have reference like behavior even when they are re-generated # from scratch from a text expression (wtf, really). comm_reset <- function(x) { if(is.null(x) || is.name(x) && !nchar(x)) return(x) attr(x, "comment") <- NULL if(is.pairlist(x)) return(x) if(length(x) > 1L || is.expression(x)) for(i in seq_along(x)) if(!is.null(x[[i]])) x[[i]] <- Recall(x[[i]]) x } # Listing on known tokens # # As of this writing, the following tokens from \file{src/main/gram.c} are # not handled: # # [,1] [,2] [,3] [,4] # [1,] "'\\n'" "cr" "ifcond" "sub" # [2,] "'%'" "END_OF_INPUT" "INCOMPLETE_STRING" "sublist" # [3,] "$accept" "equal_assign" # [4,] "$end" "error" "LINE_DIRECTIVE" "TILDE" # [5,] "$undefined" "ERROR" "LOW" "UMINUS" # [6,] "COLON_ASSIGN" "expr_or_assign" "NOT" "UNOT" # [7,] "cond" "formlist" "prog" "UPLUS" # # So far, we have not been able to produce \code{`getParseData`} data frames # that contain them. It may not be possible to do so for all of them. For # example, \code{`INCOMPLETE_STRING`} shows up during a parse error, so could # never be part of a fully parsed expression. # # Updates 11/2020: We've now seen "expr_or_assign_or_help", and according to # Kalibera "equal_assign" is now in use, although the example he gave `a = 1` # produces "expr_or_assign_or_help". # # Updates 11/2020: Turns out these are generated in 3.6.3, but apparently not in # 4.0+. tk.lst <- list( comment="COMMENT", brac.close=c("'}'", "']'", "')'"), brac.open=c("'{'", "'['", "'('", "LBB"), exps=c("expr", "exprlist", "equal_assign", "expr_or_assign_or_help"), # no comments on these as they are just removed seps=c("','", "';'"), # in addition to `expr`, these are the ones that can get comments attached non.exps=c( "SYMBOL", "STR_CONST", "NUM_CONST", "NULL_CONST", "SLOT", "NEXT", "BREAK", "SYMBOL_FUNCTION_CALL" ), # these can also get comments attached, but shouldn't be at the end of a # parse data block non.exps.extra=c( "FUNCTION", "FOR", # not 100% sure SYMBOL_PACKAGE belongs here; it can't possibly have # comments right after it on the same line "IF", "REPEAT", "WHILE", "SYMBOL_PACKAGE" ), ops=c( paste0( "'", c("-", "+", "!", "~", "?", ":", "*", "/", "^", "$", "@"), "'" ), "SPECIAL", "GT", "GE", "LT", "LE", "EQ", "NE", "AND", "AND2", "OR", "OR2", "LEFT_ASSIGN", "RIGHT_ASSIGN", "EQ_ASSIGN" ), # note these should never show up at top level ops.other=c("NS_GET", "NS_GET_INT"), # these cannot have comments attached to them unassign=c( "EQ_SUB", "SYMBOL_SUB", "EQ_FORMALS", "SYMBOL_FORMALS", "IN", "forcond", "ELSE" ) ) unitizer/R/browse.struct.R0000644000176200001440000012127314766101401015301 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R #' @include unitizer.R #' @include class_unions.R NULL # Prepares a \code{`unitizer`} Object for Review # # Mainly, splits up the tests by section and subsection and creates an indexing # structure to keep track of what tests are in which section/subsection. This # simplifies implementation of non-linear navigation through the tests. # # @param start.at.browser used to force the review of the unitizer to start at # browser, useful when in review mode, or when all tests passed but user # elected to review unitizer anyway from the unitize_dir menu setGeneric("browsePrep", function(x, mode, ...) standardGeneric("browsePrep")) setMethod("browsePrep", c("unitizer", "character"), valueClass="unitizerBrowse", function( x, mode, hist.con=NULL, interactive=FALSE, start.at.browser=FALSE, use.diff=TRUE, ... ) { if(length(mode) != 1L || !mode %in% c("review", "unitize")) stop("Argument `mode` must be one of \"review\" or \"unitize\"") unitizer.browse <- new( "unitizerBrowse", mode=mode, hist.con=hist.con, interactive=interactive, global=x@global, start.at.browser=start.at.browser, use.diff=use.diff ) # Assign the `show.diff` status to the errors, this isn't done when the # tests are evaluated. for(i in seq_along(x@tests.errorDetails)) x@tests.errorDetails[[i]]@.use.diff <- use.diff # - Unitize ---------------------------------------------------------------- # At some point need to rationalize this to a simpler instantiator for the # sub section objects since so much of the logic is similar if(identical(mode, "unitize")) { # Re-assign any ignored tests to be of the type of the next non-ignored # test, irrespective of what the ignored test was (only within a section) ign.test <- ignored(x@items.new) ign.split <- split(ign.test, x@section.map) ign.split.map.interim <- lapply( # find next non-ignored in section ign.split, function(x) { oob <- length(x) + 1L id.seq <- seq_along(x) ids <- integer(length(x)) ids <- ifelse(x, oob, id.seq) res <- rev(cummin(rev(ids))) res[res == oob] <- id.seq[res == oob] res } ) ids.split <- split(seq_along(x@items.new), x@section.map) ign.map <- unlist( # map back to non-ignored id lapply( seq_along(ids.split), function(x) ids.split[[x]][ign.split.map.interim[[x]]] ) ) # Copy over non-ignored outcomes; one slot we don't change is # `tests.conditions.new` because we still want to use that to show errors # if they happen. fields.to.map <- c( "tests.fail", "tests.error", "tests.new", "tests.status", "tests.result" ) for(i in seq_along(ign.map)[ign.test]) { for(j in fields.to.map) { if(is.matrix(slot(x, j))) { slot(x, j)[i, ] <- slot(x, j)[ign.map[i], ] } else { slot(x, j)[i] <- slot(x, j)[ign.map[i]] } } } # Add sub-sections rem.count.all <- 0L # Loop through parent sections for(i in sort(unique(x@section.parent))) { sect.par <- which(x@section.parent == i) # all items in parent section sect.map <- x@section.map %in% sect.par sect.map.ref <- which( is.na(x@items.ref.map) & !ignored(x@items.ref) & x@section.ref.map == i ) rem.item.count <- length(sect.map.ref) rem.count.all <- rem.count.all + rem.item.count if( !sum(vapply(x@sections[sect.par], length, integer(1L))) && !rem.item.count ) next browse.sect <- new( "unitizerBrowseSection", section.id=i, section.title=x@sections[[i]]@title ) # Note: anything querying reference items has to go through items.new.map # since order isn't same. # Failed tests browse.sect <- browse.sect + new( "unitizerBrowseSubSectionFailed", show.out=TRUE, show.msg=TRUE, items.new=x@items.new[x@tests.fail & sect.map], show.fail=x@tests.errorDetails[x@tests.fail & sect.map], items.ref=x@items.ref[x@items.new.map[x@tests.fail & sect.map]], new.conditions=x@tests.conditions.new[x@tests.fail & sect.map], tests.result=x@tests.result[x@tests.fail & sect.map, , drop=FALSE] ) # New tests browse.sect <- browse.sect + new( "unitizerBrowseSubSectionNew", show.msg=TRUE, show.out=TRUE, items.new=x@items.new[x@tests.new & sect.map], new.conditions=x@tests.conditions.new[x@tests.new & sect.map], tests.result=x@tests.result[x@tests.new & sect.map, , drop=FALSE] ) # Corrupted tests browse.sect <- browse.sect + new( "unitizerBrowseSubSectionCorrupted", items.new=x@items.new[x@tests.error & sect.map], show.fail=x@tests.errorDetails[x@tests.error & sect.map], items.ref=x@items.ref[x@items.new.map[x@tests.error & sect.map]], new.conditions=x@tests.conditions.new[x@tests.error & sect.map], tests.result=x@tests.result[x@tests.error & sect.map, , drop=FALSE] ) # Passed tests browse.sect <- browse.sect + new( "unitizerBrowseSubSectionPassed", items.new=x@items.new[x@tests.status == "Pass" & sect.map], items.ref=x@items.ref[ x@items.new.map[x@tests.status == "Pass" & sect.map] ], show.fail=FALSE, new.conditions=rep(F, sum(x@tests.status == "Pass" & sect.map)), tests.result=x@tests.result[ x@tests.status == "Pass" & sect.map, , drop=FALSE ] ) # Removed tests are a little funky b/c they are not part of the main # data array; by definition can't have new conditions on removed test browse.sect <- browse.sect + new( "unitizerBrowseSubSectionRemoved", items.ref=x@items.ref[sect.map.ref], new.conditions=rep(FALSE, rem.item.count), tests.result=tests_result_mat(rem.item.count) ) # Add entire section unitizer.browse <- unitizer.browse + browse.sect NULL # SO above isn't last step in loop used for debugging } # Removed tests that couldn't be mapped rem.unmapped <- !ignored(x@items.ref) & is.na(x@section.ref.map) & is.na(x@items.ref.map) if(length(which(rem.unmapped))) { browse.sect <- new( "unitizerBrowseSection", section.id=0L, section.title=paste0(if(rem.count.all) "Other ", "Removed Items") ) rem.item.count <- length(which(rem.unmapped)) # by definition can't have new conditions on removed tests browse.sect <- browse.sect + new( "unitizerBrowseSubSectionRemoved", items.ref=x@items.ref[rem.unmapped], new.conditions=rep(FALSE, rem.item.count), tests.result=tests_result_mat(rem.item.count) ) unitizer.browse <- unitizer.browse + browse.sect } } else if(identical(mode, "review")) { # - Review ----------------------------------------------------------------- for(i in seq_along(x@sections.ref)) { # Loop through parent sections # will have to check what the section numbers are, this might not be # right sect.map <- x@section.ref.map == i if(!length(which(sect.map))) next browse.sect <- new( "unitizerBrowseSection", section.id=i, section.title=x@sections.ref[[i]]@title ) # Note: anything querying reference items has to go through items.new.map # since order isn't same. # Passed tests browse.sect <- browse.sect + new( "unitizerBrowseSubSectionPassed", items.new=x@items.ref[sect.map], show.msg=TRUE, new.conditions=rep(FALSE, sum(sect.map)), tests.result=tests_result_mat(sum(sect.map)) ) unitizer.browse <- unitizer.browse + browse.sect NULL # SO above isn't last step in loop used for debugging } } else stop("Internal Error: unexpected `mode`") # nocov unitizer.browse } ) setGeneric("bookmarked", function(x, ...) standardGeneric("bookmarked")) setMethod("bookmarked", "unitizerObjectList", function(x, ...) { bookmarked <- vapply( x, function(y) is(y, "unitizer") && is(y@bookmark, "unitizerBrowseBookmark"), logical(1L) ) bookmarked } ) # Keeps track of All Test Review Data # # Seemed like a brilliant idea to make this an object to simplify validation, # but as result cycling through the items is incredibly annoying. Need to # develop better ways to iterate through each item while getting all the data # here, as well as ways of easily knowing which sections/subsections are # ignored. # # The real issue with all this stuff is that \code{`item.new`} and # \code{`item.ref`} can be NULL, and whether on or the other or neither are # NULL changes the processing logic. Probably the thing to do is extract the # non NULL values (i.e. item.main) and store them in a list, along with a # list highlighting which of \code{`item.new`} or \code{`item.ref`} has been # picked. # # @slot item.id unique, 1 incrementing up to total number of reviewable items # @slot item.id.rel non-unique, unique within each sec/sub.sec # @slot item.id.orig the original id of the item used to re-order tests in the # order they show up in the original files # @slot item.id.ord seems to be like item.id.orig, except that deleted items # will be moved to a different location (end)? This was not documented # originally. See `getIdOrder`. # @slot item.ref whether a test is a reference test or not # @slot reviewed whether a test has been reviewed # @slot review.val what action the user decided ("N") is default setClass("unitizerBrowseMapping", slots=c( item.id="integer", item.id.rel="integer", item.id.orig="integer", item.id.ord="integer", item.ref="logical", sec.id="integer", sub.sec.id="integer", reviewed="logical", review.val="character", review.def="character", review.type="factor", tests.result="matrix", ignored="logical", new.conditions="logical" ), prototype=list( review.type=factor(levels=c("New", "Passed", "Failed", "Removed", "Corrupted")), tests.result=tests_result_mat(0L) ), validity=function(object) { if( !identical( levels(object@review.type), c("New", "Passed", "Failed", "Removed", "Corrupted") ) || any(is.na(object@review.type)) ) { return("Invalid slot `@review.type`") } if(any(is.na(object@item.ref))) { return("Invalid slot `@item.ref` must be logical and not NA") } TRUE } ) # Helper Object for Browsing # # Key element here is the \code{`@@mapping`} slot which is generated by # \code{`\link{+,unitizerBrowse,unitizerBrowseSection-method}`}, which allows us # to navigate all the tests. setClass("unitizerBrowse", contains="unitizerList", slots=c( mapping="unitizerBrowseMapping", last.id="integer", # so that `reviewNext` knows what to show next # so that `reviewNext` knows what headers to display last.reviewed="integer", jumping.to="integer", # what test to re-eval jump to, 0 if none hist.con="ANY", # should be 'fileOrNULL', but setOldClass` issues mode="character", review="integer", # counter to figure out when browse/review menu inspect.all="logical", # force inspection of all elements # user has triggered at least one navigation command navigating="logical", browsing="integer", # current test selected via browse human="logical", # whether user has had any interaction at all # so navprompt can communicate back re-eval status re.eval="integer", force.up="logical", # force update even if no changes interactive="logical", # whether to browse in interactive mode # whether in non-interactive mode but required input interactive.error="logical", global="unitizerGlobal", # object for global settings # indicate whether any auto-accepts were triggered auto.accept="logical", multi="logical", # whether many unitizers are being browsed multi.quit="logical", # whether many unitizers are being browsed # whether to show browser first, also disables warnings about reviewing # tests that are not usually reviewed start.at.browser="logical", use.diff="logical" # Whether to use a diff in failure comparisons ), prototype=list( mapping=new("unitizerBrowseMapping"), last.id=0L, last.reviewed=0L, jumping.to=0L, hist.con=NULL, mode="unitize", review=1L, inspect.all=FALSE, navigating=FALSE, browsing=0L, human=FALSE, re.eval=0L, force.up=FALSE, interactive=FALSE, interactive.error=FALSE, auto.accept=FALSE, multi=FALSE, multi.quit=FALSE, start.at.browser=FALSE ), validity=function(object) { if(length(object@mode) != 1L || ! object@mode %in% c("unitize", "review")) { return("Slot `@mode` must be character(1L) in c(\"unitize\", \"review\")") } if(!is.TF(object@inspect.all)) return("Slot `@inspect.all` must be TRUE or FALSE") if(!is.TF(object@start.at.browser)) return("Slot `@start.at.browser` must be TRUE or FALSE") if(!is.TF(object@navigating)) return("Slot `@navigating` must be TRUE or FALSE") if(!is.int.1L(object@browsing) && object@browsing >= 0L) return("Slot `browsing` must be positive integer scalar") if(!is.int.1L(object@jumping.to) && object@jumping.to >= 0L) return("Slot `jumping.to` must be positive integer scalar") if(!is.TF(object@auto.accept)) return("Slot `@auto.accept` must be TRUE or FALSE") if(!is.TF(object@force.up)) return("Slot `force.up` must be TRUE or FALSE") if(length(object@re.eval) != 1L || !isTRUE(object@re.eval %in% 0:2)) return("Slot `@re.eval` must be integer(1L) and in 0:2") if(!is.TF(object@multi)) return("Slot `multi` must be TRUE or FALSE") TRUE } ) # Display Summary of Tests and User Decisions # # Used to help navigate tests. Will only show reviewed tests because # implementing the ability to skip ahead has several annoying implications # that we did not want to support (need to check that eventually all tests # are reviewed, etc.) #' @rdname unitizer_s4method_doc setMethod("show", "unitizerBrowse", function(object) { obj.rendered <- as.character(object) cat(obj.rendered, "\n", sep="") invisible(obj.rendered) } ) setGeneric("getIdOrder", function(object, ...) standardGeneric("getIdOrder")) setMethod( "getIdOrder", "unitizerBrowse", function(object, ...) { # Figure out order as stuff showed up in original file; deletd reference ids # are put at the end. Note the implicit assumption here is that the stuff in # sections is in the same order in file and here, which is almost certainly # true except for stuff outside of sections ids <- object@mapping@item.id.orig max.id.orig <- max(c(0L, ids[!object@mapping@item.ref])) if(any(object@mapping@item.ref)) { ids[object@mapping@item.ref] <- rank(ids[object@mapping@item.ref], ties.method="first") + max.id.orig } ids } ) # Create a Text Representation of an Object # # @param object object to render # @param width how many characters to display max per line, use 0L to use the # terminal window width as determined by \code{`getOption("width")`}; note # this is a guideline, if you pass numbers that lead to too narrow renderings # it will be ignored. # @param ... not used # @return character vector, one element per line, for use with e.g. # \code{`cat(x, sep=\n`)} #' @rdname unitizer_s4method_doc setMethod("as.character", "unitizerBrowse", valueClass="character", function(x, width=0L, ...) { if(!is.numeric(width) || width < 0 || length(width) != 1L) { stop("Argument `width` must be a positive scalar numeric.") } width <- as.integer(width) width.max <- if(width) width else getOption("width") # this used to limit what test were shown tests.to.show <- rep(TRUE, length(x@mapping@review.type)) out.calls <- character(sum(tests.to.show)) out.calls.idx <- integer(sum(tests.to.show)) out.sec <- character(length(unique(x@mapping@sec.id[tests.to.show]))) out.sec.idx <- integer(length(out.sec)) out <- character(length(out.calls) + length(out.sec)) # Work on figuring out all the various display lengths min.deparse.len <- 20L sec.id.prev <- 0L item.id.formatted <- format(justify="right", paste0(ifelse(x@mapping@ignored, "*", ""), x@mapping@item.id.ord) ) num.pad <- ". " front.pad <- " " rev.type <- format(as.character(x@mapping@review.type), justify="right") rev.fail.corr <- x@mapping@review.type %in% c("Failed", "Corrupted") rev.new <- x@mapping@review.type == "New" if(isTRUE(x@global$unitizer.opts[["unitizer.color"]])) { rev.type[rev.fail.corr] <- crayon::yellow(rev.type[rev.fail.corr]) rev.type[rev.new] <- crayon::blue(rev.type[rev.new]) } rev.type <- ifelse(!x@mapping@ignored, rev.type, "-") rev.type.n <- crayon::col_nchar(rev.type) rev.type.pad <- max(rev.type.n) - rev.type.n pads <- vapply(Map(rep, " ", rev.type.pad), paste0, collapse="", character(1L)) review.formatted <- paste(sep=":", paste0(" ", pads, rev.type), format( ifelse(x@mapping@reviewed, as.character(x@mapping@review.val), "-") ) )[tests.to.show] disp.len <- width.max - max(nchar(item.id.formatted)) - max(nchar(crayon::strip_style(review.formatted))) - nchar(num.pad) - nchar(front.pad) if(disp.len < min.deparse.len) { warning("Selected display width too small, will be ignored") disp.len <- min.deparse.len } j <- k <- l <- 0L # Display in order tests appear in file; note this is not in same order # as they show up in review (also, we're still really ordering by section) # first, and only then by original id id.ord <- x@mapping@item.id[order(x@mapping@sec.id, getIdOrder(x))] for(i in id.ord) { if(!tests.to.show[[i]]) next j <- j + 1L l <- l + 1L sec.id <- x@mapping@sec.id[[i]] sub.sec.id <- x@mapping@sub.sec.id[[i]] id.rel <- x@mapping@item.id.rel[[i]] item <- if(is.null(x[[sec.id]][[sub.sec.id]]@items.new[[id.rel]])) { x[[sec.id]][[sub.sec.id]]@items.ref[[id.rel]] } else { x[[sec.id]][[sub.sec.id]]@items.new[[id.rel]] } if(!identical(sec.id.prev, sec.id)) { k <- k + 1L out.sec[[k]] <- x[[sec.id]]@section.title out.sec.idx[[k]] <- l sec.id.prev <- sec.id l <- l + 1L } # Now paste the call together, substituting into the padding template call.dep <- paste0(one_line(item@call.dep, disp.len - 1L), " ") out.calls[[j]] <- call.dep out.calls.idx[[j]] <- l } # Combine all the call pieces, start by resizing template call.chrs <- nchar(out.calls) call.chrs.max <- max(call.chrs) tar.len <- min(disp.len, max(call.chrs.max + 3L, 15L)) dot.pad <- substr( # this will be the padding template paste0(rep(" . ", ceiling(tar.len / 3)), collapse=""), 1L, tar.len ) calls.fin <- rep(dot.pad, length(call.chrs)) substr(calls.fin, 1L, call.chrs) <- out.calls out.fin <- paste0( front.pad, item.id.formatted[id.ord], num.pad, calls.fin, review.formatted[id.ord], "\n" ) # Now generate headers and interleave them out.width <- max(nchar(crayon::strip_style(out.fin))) - 1L out.sec.proc <- vapply( out.sec, function(x) as.character(H2(x), margin="none", width=out.width), character(1L) ) out[out.calls.idx] <- out.fin out[out.sec.idx] <- out.sec.proc if(length(out.sec) == 1L) out[-out.sec.idx] else out } ) #' @rdname unitizer_s4method_doc setMethod( "as.data.frame", "unitizerBrowse", function(x, row.names = NULL, optional = FALSE, ...) { id.order <- getIdOrder(x) calls.dep <- deparseCalls(x) if(is.null(calls.dep)) calls.dep <- character() sec.titles <- vapply(x@mapping@sec.id, function(y) x[[y]]@section.title, character(1L)) res <- data.frame( id=x@mapping@item.id, call=calls.dep, section=sec.titles, ignored=x@mapping@ignored, status=x@mapping@review.type, user=factor(x@mapping@review.val, levels=c("Y", "N")), reviewed=x@mapping@reviewed, stringsAsFactors=FALSE )[order(x@mapping@sec.id, id.order), ] rownames(res) <- NULL res } ) # Indicate Whether to Exit Review Loop setMethod("done", "unitizerBrowse", valueClass="logical", function(x, ...) { isTRUE(x@last.id >= max(x@mapping@item.id)) } ) # Based on User Input, Return Either Reference Or New Items # # Translates "Y", "N", etc. into c("A", "B", "C"), where "A" means return value # from new item list, "B" return value from old item list (the original store) # and "C" means return NULL. setGeneric("processInput", function(x, ...) standardGeneric("processInput")) setMethod("processInput", "unitizerBrowse", valueClass="unitizerItems", function(x, ...) { items <- new("unitizerItems") for(i in x@mapping@item.id) { # while it was nice to have mapping as an object for validation, this is # terrible sec <- x@mapping@sec.id[[i]] sub.sec <- x@mapping@sub.sec.id[[i]] id.rel <- x@mapping@item.id.rel[[i]] input <- x@mapping@review.val[[i]] input.translate <- x[[sec]][[sub.sec]]@actions[[input]] item <- switch( input.translate, A=x[[sec]][[sub.sec]]@items.new[[id.rel]], B=x[[sec]][[sub.sec]]@items.ref[[id.rel]], C=NULL ) # Note here we over-write existing section.id because if we pick a reference # item, we still want to associate it with the section of the new item it # was matched to, unless we're dealing with a deleted item, in which case # there is no section if(!is.null(item)) { if(identical(as.character(x@mapping@review.type[[i]]), "Removed")) { sec <- NA_integer_ } item@section.id <- sec } items <- items + item } items } ) # Get id for unreviewed test setGeneric("unreviewed", function(x, ...) standardGeneric("unreviewed")) setMethod("unreviewed", "unitizerBrowse", function(x, ...) { unreviewed <- which( !x@mapping@reviewed & !x@mapping@ignored & ( if(!identical(x@mode, "review")) x@mapping@review.type != "Passed" else TRUE ) ) sort(unreviewed) } ) # Represents a \code{`unitizer_sect`} setClass("unitizerBrowseSection", contains="unitizerList", slots=c( section.id="integer", section.title="character", review.val="character" ) ) # Add Sections to Our Main Browse Object # # Primarily we're contructing the \code{`@@mapping`} slot which will then allow # us to carry out requisite computations later. See # \code{`\link{unitizerBrowseMapping-class}`} for details on what each of the # slots in \code{`mapping`} does. # # Also, some more discussion of this issue in the docs for \code{`\link{unitizer-class}`}. #' @rdname unitizer_s4method_doc setMethod("+", c("unitizerBrowse", "unitizerBrowseSection"), valueClass="unitizerBrowse", function(e1, e2) { e1 <- append(e1, list(e2)) item.count <- unlist(lapply(as.list(e2), length)) test.types <- unlist(lapply(as.list(e2), slot, "title")) max.item <- length(e1@mapping@item.id) max.sub.sec <- if(max.item) max(e1@mapping@sub.sec.id) else 0L # New items if available, ref items otherwise sec.item.list <- as.list(extractItems(e2)) action.default <- vapply(as.list(e2), slot, character(1L), "action.default") mapping.new <- new("unitizerBrowseMapping", # This id tracks the order of tests as we intend to review them # is it possible for sum(item.count) to be zero? item.id=(max.item + 1L):(max.item + sum(item.count)), item.id.rel=unlist(lapply(item.count, function(x) seq(length.out=x))), item.id.orig=vapply(sec.item.list, slot, 1L, "id"), item.ref=vapply(sec.item.list, slot, FALSE, "reference"), sec.id=rep(length(e1), sum(item.count)), sub.sec.id=rep( seq_along(item.count), item.count ), review.val=rep(action.default, item.count), review.def=rep(action.default, item.count), reviewed=rep(FALSE, sum(item.count)), review.type=factor( rep(test.types, item.count), levels=levels(e1@mapping@review.type) ), ignored=unlist(lapply(as.list(e2), ignored)), new.conditions=unlist(lapply(as.list(e2), slot, "new.conditions")), # get conditions from each sub-section tests.result=do.call(rbind, lapply(as.list(e2), slot, "tests.result")) ) for(i in slotNames(e1@mapping)) { comb_fun <- if(is.matrix(slot(e1@mapping, i))) rbind else append slot(e1@mapping, i) <- comb_fun(slot(e1@mapping, i), slot(mapping.new, i)) } # Update the id ord; this is a bit redundant as ideally we would just do it # once at the end, but since this function is used in different places we # just do it here and accept that it is a bit repetitive e1@mapping@item.id.ord <- getIdOrder(e1) e1 } ) # Represents A Section/Action Type when Browsing # # @keywords internal # @slot items.new the new items associated with this sub sections # @slot items.ref the reference items associated with this sub sections # @slot title character 1 length current test types (failed, added, removed, corrupted) # @slot prompt character 1 length what to prompt the user to do # @slot actions character 2 length containing c("A", "B", "C"), where "A" # means return value from new item list, "B" return value from old item # list (the original store) and "C" means return NULL. The first value # corresponds to the action on user typing `Y`, the second the action on # user typing `N`. # @slot show.msg logical whether to automatically show stderr produced during # evaluation # @slot show.out logical whether to automatically show stdout produced during # evaluation # @slot show.fail FALSE, or a unitizerItemsTestsErrors-class object if you want # to show the details of failure # @slot new.conditions whether the items produced new conditions setClass("unitizerBrowseSubSection", slots=c( items.new="unitizerItemsOrNULL", items.ref="unitizerItemsOrNULL", title="character", prompt="character", detail.s="character", detail.p="character", help="character", actions="character", action.default="character", show.out="logical", show.msg="logical", show.fail="unitizerItemsTestsErrorsOrLogical", new.conditions="logical", tests.result="matrix" ), prototype=list( show.msg=FALSE, show.fail=FALSE, show.out=TRUE, action.default="N", show.msg=TRUE ), validity=function(object) { if( !is.null(object@items.ref) && !is.null(object@items.new) && length(object@items.ref) != length(object@items.new) ) { return("Ref list must have the same number of items as new list, or be NULL") } else if(is.null(object@items.ref) && is.null(object@items.new)) { return("Reference and New Items cannot both be NULL") } else if ( !is.character(object@actions) || !all(object@actions %in% c("A", "B", "C")) || length(object@actions) != length(unique(object@actions)) || is.null(names(object@actions)) | !all(names(object@actions) %in% c("Y", "N")) ) { return("`actions` input incorrect") } else if (!is.logical(object@show.out) || length(object@show.out) != 1L) { return("Argument `show.out` must be a 1 length logical") } else if (!is.logical(object@show.msg) || length(object@show.msg) != 1L) { return("Argument `show.msg` must be a 1 length logical") } else if ( !is(object@show.fail, "unitizerItemsTestsErrors") && !identical(length(object@show.fail), 1L) ) { return("Argument `show.fail` must be a 1 length logical or a \"unitizerItemsTestsErrors\" object") } else if (!is.character(object@prompt) || length(object@prompt) != 1L) { return("Argument `prompt` must be a 1 length character") } else if (!is.character(object@detail.s) || length(object@detail.s) != 1L) { return("Argument `detail.s` must be a 1 length character") } else if ( !is.character(object@detail.p) || length(object@detail.p) != 1L || is.na(object@detail.p) || !isTRUE(grepl("%s", object@detail.p)) ) { return( "Argument `detail.p` must be character(1L), non-NA, and contain '%s'" ) } else if ( length(object@new.conditions) != max(length(object@items.ref), length(object@items.new)) ) { return("Argument `new.condtions` must be supplied and be the same length as the items.") } else if (any(is.na(object@new.conditions))) { return("Argument `new.conditions` may not contain any NA values.") } else if( !is.logical(object@tests.result) || !identical(colnames(object@tests.result), slotNames("unitizerItemData")) ) { return( paste0( "Argument `tests.result` must be logical matrix with colnames equal ", "to slot names for `unitizerItemData`" ) ) } else if( !identical(length(object@action.default), 1L) || !length(which(object@action.default %in% c("Y", "N"))) ) { return("Argument `action.default` must be \"Y\" or \"N\"") } TRUE } ) # Compute Length of a \code{\link{unitizerBrowseSubSection-class}} #' @rdname unitizer_s4method_doc setMethod("length", "unitizerBrowseSubSection", valueClass="logical", function(x) max(length(x@items.new), length(x@items.ref)) ) setMethod("ignored", "unitizerBrowseSubSection", valueClass="logical", function(x, ...) { sub.sect <- if(is.null(x@items.new)) x@items.ref else x@items.new vapply(as.list(sub.sect), ignored, logical(1L)) } ) # Subset A \code{unitizerBrowse} Object # # Used primarily to confirm actions on multiple items. Note this means ids # are no longer continuous, something that we assume when we cycle through # items. Need to think about this a bit... # # Generally, be careful about using a subsetted browse object as you would # a non-subsetted one until we get around to making cycling more robust. # # Finally, note that this conflicts with the underlying nature of a # \code{unitizerList} since we're overriding the \code{[} method. All of this # is caused by the nested nature of sections and sub-sections, which is # feeling like a worse design decision every time I look at it. Note also that # something like \code{ubobj[4]} and \code{ubobj[[4]]} will likely return # completely different things as in the former we are subsetting based on the # order implied by \code{ubobj@@mapping}, whereas in the latter we're directly # pulling out an entire section. Obviously not ideal, but since this is # internal we're going to ignore the problem for now. #' @rdname unitizer_s4method_doc setMethod( "[", signature(x="unitizerBrowse", i="subIndex", j="missing", drop="missing"), function(x, i) { if(!is.numeric(i) || any(is.na(i)) || any(i < 0)) stop("Argument `i` must be stricitly positive numeric") i <- as.integer(i) ub.new <- new("unitizerBrowse") if((length(i) == 1L) && !i || !any(i)) return(ub.new) if(!all(i %in% c(0L, x@mapping@item.id))) stop("Index out of bounds") id.ind <- match(i, x@mapping@item.id) # need to select all sections and subsections, even including empty ones? # won't for now, but need to think about whether this could cause problems id.df <- data.frame( i=x@mapping@sec.id, j=x@mapping@sub.sec.id, k=x@mapping@item.id.rel )[id.ind, ] ids.split <- lapply( split(id.df[-1L], id.df$i), function(x) split(x$k, x$j) ) for(i in names(ids.split)) { ub.sec <- x[[as.integer(i)]][0L] # get section with no contents # Cycle through selected sub-sections, and add them to our empty section # after subsetting them for(j in names(ids.split[[i]])) { ub.sec <- ub.sec + x[[as.integer(i)]][[as.integer(j)]][ids.split[[i]][[j]]] } # Now add section to new browser object ub.new <- ub.new + ub.sec } ub.new } ) # Subset a \code{unitizerBrowseSubSection} Object #' @rdname unitizer_s4method_doc setMethod("[", signature( x="unitizerBrowseSubSection", i="subIndex", j="missing", drop="missing" ), function(x, i) { if(!is.numeric(i) || any(is.na(i)) || any(i < 0)) stop("Argument `i` must be stricitly positive numeric") i <- as.integer(i) if(!all(i %in% 0:max(length(x)))) stop("Index out of bounds") new.sub <- new(class(x)) # Unfortunately we have a hodgepodge of slots that need subsetting vs not # and no systematic way of knowing which is which subset.slots <- c( "items.new", "items.ref", "new.conditions", "show.fail", "tests.result" ) for(s.name in slotNames(x)) { if(s.name %in% subset.slots) { slot.old <- slot(x, s.name) slot(new.sub, s.name) <- if(is.matrix(slot.old)) slot.old[i, , drop=FALSE] else slot.old[i] } else { slot(new.sub, s.name) <- slot(x, s.name) } } return(new.sub) } ) # Pull Out Deparsed Calls From Objects # # Used primarily as a debugging tool, should probably be migrated to use # \code{\link{extractItems}} # # @return character the deparsed calls setGeneric("deparseCalls", function(x, ...) standardGeneric("deparseCalls")) setMethod("deparseCalls", "unitizerBrowse", function(x, ...) { unlist(lapply(as.list(x), deparseCalls)) } ) setMethod("deparseCalls", "unitizerBrowseSection", function(x, ...) { unlist(lapply(as.list(x), deparseCalls)) } ) setMethod("deparseCalls", "unitizerBrowseSubSection", function(x, ...) { if(is.null(x@items.new) && is.null(x@items.ref)) return(character()) items <- if(!is.null(x@items.new)) x@items.new else x@items.ref deparseCalls(items) } ) setMethod("deparseCalls", "unitizerItems", function(x, ...) { vapply(as.list(x), slot, character(1L), "call.dep" ) } ) # Pull out items from unitizerBrowse objects setGeneric("extractItems", function(x, ...) standardGeneric("extractItems")) setMethod("extractItems", "unitizerBrowse", valueClass="unitizerItems", function(x, ...) { Reduce(append, lapply(as.list(x), extractItems)) } ) setMethod("extractItems", "unitizerBrowseSection", valueClass="unitizerItems", function(x, ...) { item.list <- lapply( as.list(x), function(y) { if(is.null(y@items.new) && is.null(y@items.ref)) return(new("unitizerItems")) if(!is.null(y@items.new)) y@items.new else y@items.ref } ) Reduce(append, item.list) } ) # Specific Sub-Section defaults setClass("unitizerBrowseSubSectionFailed", contains="unitizerBrowseSubSection", prototype=list( title="Failed", prompt="Overwrite with new result%s", detail.s=paste0( "The following test failed because the new evaluation does not match ", "the reference value from the store." ), detail.p=paste0( "The %s tests in this section failed because the new evaluations do not ", "match the reference values from the store." ), help=paste0( "Tests fail when a test expression produces ", "different results than when it was originally added to the store. ", "You should type N at the prompt unless you know the previous result ", "is incorrect and should be replaced by the new result.\n\n", "Test failure in this case is caused by %s; see `?unitizer_sect` for ", "more details on what causes test failures and how to customize that ", "behavior.\n\n", "If you wish to examine test values more closely you can retrieve the ", "reference value with `.ref`, and the newly evaluated one with `.new`. ", "`.diff` contains a precomputed diff (i.e. ", "`diffobj::diffObj(.ref, .new)`). `.NEW` and `.REF` contain all stored ", "components of the test, and `.DIFF` contains the diffs ", "between each of those components. `.new`, `.ref`, and `.diff` ", "are each respectively copies of `.NEW$value`, `.REF$value`, ", "and `.DIFF$value` provided for convenience.", "%s" ), actions=c(Y="A", N="B") ) ) setClass("unitizerBrowseSubSectionNew", contains="unitizerBrowseSubSection", prototype=list( title="New", prompt="Add test%s to store", detail.s="The following test is new.", detail.p="The %s tests in this section are new.", help=paste0( "A new test will be used as the reference value for future tests, so ", "make sure you review the value carefully before you add it to the ", "store by selecting 'Y' at the prompt.%s%s" ), actions=c(Y="A", N="C"), show.out=TRUE ) ) setClass("unitizerBrowseSubSectionCorrupted", contains="unitizerBrowseSubSection", prototype=list( title="Corrupted", prompt="Overwrite with new result%s", detail.s=paste0( "The test outcome for the following test cannot be assessed because ", "errors occurred while attempting comparison. Please review the errors ", "and contemplate using a different comparison function with ", "`unitizer_sect`." ), detail.p=paste0( "The test outcome for the %s tests in this section cannot be assessed ", "because errors occurred while attempting comparison. Please review the ", "errors and contemplate using a different comparison function with ", "`unitizer_sect`." ), help=paste0( "unitizer is unable to compare the reference and new test values ", "because the comparison function itself caused an error. You can ", "change the unitizer function with `unitizer_sect`. You can also ", "manually compare `.NEW` and `.REF` and decide whether to replace the ", "old value with the new one by selecting 'Y' at the prompt.%s%s" ), actions=c(Y="A", N="B") ) ) setClass("unitizerBrowseSubSectionRemoved", contains="unitizerBrowseSubSection", prototype=list( title="Removed", prompt="Remove test%s from store", detail.s=paste0( "The following test exists in the unitizer store but not in the new ", "test script." ), detail.p=paste0( "The %s tests in this section exist in the unitizer store but not in the ", "new test script." ), help=paste0( "A previously stored test no longer exists in the test file; you can ", "remove the stored value by selecting 'Y' at the prompt.%s%s" ), actions=c(Y="C", N="B") ) ) setClass("unitizerBrowseSubSectionPassed", contains="unitizerBrowseSubSection", prototype=list( title="Passed", prompt="Keep test%s in store", detail.s="The following test passed.", detail.p="The %s tests in this section passed.", actions=c(Y="A", N="C"), action.default="Y", show.out=TRUE ) ) # Add a browsing sub-section to a browse section # # @param e1 a \code{\link{unitizerBrowseSection-class}} # @param e2 a \code{\link{unitizerBrowseSubSection-class}} # @return a \code{\link{unitizerBrowseSection-class}} #' @rdname unitizer_s4method_doc setMethod("+", c("unitizerBrowseSection", "unitizerBrowseSubSection"), valueClass="unitizerBrowseSection", function(e1, e2) { e1 <- append(e1, list(e2)) } ) # Return value for \code{browseUnitizerInternal} setClass( "unitizerBrowseResult", slots=c( unitizer="unitizer", re.eval="integer", updated="logical", interactive.error="logical", data="data.frame", bookmark="unitizerBrowseBookmarkOrNULL", multi.quit="logical" ), prototype=list(multi.quit=FALSE), validity=function(object) { if( !identical(length(object@re.eval), 1L) || is.na(object@re.eval) || !object@re.eval %in% 0L:2L ) return("slot `re.eval` must be integer(1L) in 0:2") if(!isTRUE(object@updated) && !identical(object@updated, FALSE)) return("slot `updated` must be TRUE or FALSE") if( !isTRUE(object@interactive.error) && !identical(object@interactive.error, FALSE) ) return("slot `interactive.error` must be TRUE or FALSE") if(!isTRUE(dat.err <- is.unitizer_result_data(object@data))) return(paste0("slot `data` in unexpected format: ", dat.err)) if(!is.TF(object@multi.quit)) return("slot `multi.quit` must be TRUE or FALSE") TRUE } ) unitizer/R/item.sub.R0000644000176200001440000003211714766360057014217 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # - Required Code ------------------------------------------------------------- #' @include conditions.R #' @include class_unions.R #' @include text.R #' @include deparse.R #' @include list.R #' @include item.R NULL unitizerItemDataSlots <- slotNames("unitizerItemData") # cache this for validity # Virtual Class To Enforce Slots on Subclasses # # @keywords internal setClass("unitizerItemTests", contains="VIRTUAL", validity=function(object) { if(!all(slotNames(getClass(object)) == unitizerItemDataSlots)) return("slots must be defined as ", deparse(unitizerItemDataSlots)) TRUE } ) # Validates Functions for Use in New vs. Reference Object Comparison # @keywords internal setClass( "unitizerItemTestFun", slots=c(fun="function", fun.name="character"), prototype=list(fun=all.equal), validity=function(object) { if(!isTRUE(err <- is.two_arg_fun(object@fun))) return( cc( "Slot `@fun` must be a function with the first two parameters ", "non-optional and all others optional (", err, ")." ) ) TRUE } ) setMethod("initialize", "unitizerItemTestFun", function(.Object, ...) { dots <- list(...) if(!("fun" %in% names(dots))) stop("Argument `fun` required.") if(!("fun.name" %in% names(dots))) { fun.name <- deparse_fun(substitute(list(...))[["fun"]]) return(callNextMethod(.Object, fun.name=fun.name, ...)) } return(callNextMethod()) } ) # Stores Errors from Evaluating New vs. Ref Comparisons # # There various nested objects involved: # \itemize{ # \item \code{`unitizerItemTestError`} contains the error produced from a # comparison # \item \code{`unitizerItemTestsErrors`} aggregates the errors for each slot # of an item # \item \code{`unitizerItemsTestsErrors`} aggregates all the errors for the # \code{`\link{unitizer-class}`} object # } # # @aliases unitizerItemsTestsErrors-class, unitizerItemTestsErrors-class # @keywords internal setClass("unitizerItemTestError", representation( value="characterOrNULL", compare.err="logical", .new="ANY", .ref="ANY" ), prototype(value=NULL, compare.err=FALSE, .new=NULL, .ref=NULL), validity=function(object) { if(!identical(length(object@compare.err), 1L)) return("slot `@compare.err` must be a 1 length logical") } ) setClass("unitizerItemTestsErrors", representation( value="unitizerItemTestError", conditions="unitizerItemTestError", output="unitizerItemTestError", message="unitizerItemTestError", aborted="unitizerItemTestError", .fail.context="numericOrNULL", # for passing around options for .use.diff="logical" ), prototype(.use.diff=TRUE) ) unitizerItemTestsErrorsSlots <- grep("^[^.]", slotNames("unitizerItemTestsErrors"), value=TRUE) # used to do this with virtual class, but slow if(!identical(unitizerItemDataSlots, unitizerItemTestsErrorsSlots)) { stop( "Install error: `unitizerItemData` and `unitizerItemTestsErrors` slots ", "not identical; contact maintainer." ) } unitizerItemTestErrorObj <- new("unitizerItemTestError") setMethod("initialize", "unitizerItemTestsErrors", function(.Object, ...) { dots <- list(...) if(!all((s.n <- names(dots)) %in% unitizerItemTestsErrorsSlots)) stop("Unused arguments ", paste0(deparse(names(dots)[!s.n]))) for(i in seq_along(dots)) slot(.Object, s.n[[i]]) <- if(is.null(dots[[i]])) { unitizerItemTestErrorObj } else dots[[i]] .Object } ) ## Track Diff And Comparison Error Text ## ## Store whether to show the diff or not in `show.diff`, and the alternate ## text to show in that circumstances in `diff.alt`. `txt` and `txt.alt` are ## the "headers" shown ahead of `diff` or `diff.alt` setClass("unitizerItemTestsErrorsDiff", slots=c( diff="DiffOrNULL", diff.alt="character", txt="character", txt.alt="character", err="logical", show.diff="logical", # whether to display the diff use.diff="logical" # whether to use diff or all.equal ), prototype=list(show.diff=TRUE, use.diff=TRUE, diff.alt=character()) ) setClassUnion( "unitizerItemTestsErrorsDiffOrNULL", c("unitizerItemTestsErrorsDiff", "NULL") ) # Hold diffs for display; only used when a test actually fails and is queued up # for review by user setClass("unitizerItemTestsErrorsDiffs", slots=c( value="unitizerItemTestsErrorsDiffOrNULL", conditions="unitizerItemTestsErrorsDiffOrNULL", output="unitizerItemTestsErrorsDiffOrNULL", message="unitizerItemTestsErrorsDiffOrNULL", aborted="unitizerItemTestsErrorsDiffOrNULL", state="unitizerItemTestsErrorsDiffOrNULL" ) ) if("state" %in% unitizerItemDataSlots) stop( "Install error: `unitizerItemData` may not contain a \"state\" slot; ", "contact maintainer." ) if( !identical( c(unitizerItemDataSlots, "state"), slotNames("unitizerItemTestsErrorsDiffs") ) ){ stop( "Install error: `unitizerItemData` and `unitizerItemTestsErrorsDiffs` ", "slots not identical; contact maintainer." ) } #' Subsetting Methods for unitizerItemTestsErrorsDiffs objects #' #' @rdname extract-unitizerItemTestsErrorsDiffs-method #' @keywords internal setMethod("$", "unitizerItemTestsErrorsDiffs", function(x, name) { what <- substitute(name) what <- if(is.symbol(what)) as.character(what) else name x[[what]] } ) #' @rdname extract-unitizerItemTestsErrorsDiffs-method #' @keywords internal setMethod("[[", "unitizerItemTestsErrorsDiffs", function(x, i, j, ..., exact=TRUE) { if(!is.chr1plain(i)) stop("Argument `i` must be character(1L) and not NA") sn <- slotNames(x) if(!i %in% sn) stop( "Argument `i` must be one of ", paste0(deparse(sn, width.cutoff=500L), collapse="") ) slot(x, i) }) setClass( "unitizerItemsTestsErrors", contains="unitizerList" # ,validity=function(object) { # commented out for computation cost # tests <- vapply( # as.list(object), is, logical(1L), class2="unitizerItemTestsErrors" # ) # if(!all(tests)) # return( # paste0( # "\"unitizerItemsTestsErrors\" may only contain objects of class ", # "\"unitizerItemTestsErrors\"" # ) # TRUE # } ) setClassUnion( "unitizerItemsTestsErrorsOrLogical", c("unitizerItemsTestsErrors", "logical") ) setGeneric("as.Diffs", function(x, ...) StandardGeneric("as.Diff")) # nocov setMethod("as.Diffs", "unitizerItemTestsErrors", function(x, width=getOption("width"), ...) { slots <- grep("^[^.]", slotNames(x), value=TRUE) slot.errs <- vapply( slots, function(y) !is.null(slot(x, y)@value), logical(1L) ) diffs <- vector("list", length(slots)) names(diffs) <- slots for(i in slots[slot.errs]) { curr.err <- slot(x, i) mismatch <- if(curr.err@compare.err) { paste0("Unable to compare ", i, ": ") } else { paste0(cap_first(i), " mismatch: ") } out <- if(length(curr.err@value) < 2L) { paste0(mismatch, decap_first(curr.err@value)) } else { c(mismatch, as.character(UL(decap_first(curr.err@value)), width=width)) } make_cont <- function(x) { res <- if(identical(i, "value")) { as.name(x) } else call("$", as.name(toupper(x)), as.name(i)) call("quote", res) } diff <- if(x@.use.diff) try( diffObj( curr.err@.ref, curr.err@.new, tar.banner=make_cont(".ref"), cur.banner=make_cont(".new") ) ) diffs[[i]] <- if(inherits(diff, "try-error")) { new( "unitizerItemTestsErrorsDiff", diff=NULL, txt=sprintf("%s: ", cap_first(i)), txt.alt=sprintf("%s: ", cap_first(i)), err=curr.err@compare.err, show.diff=FALSE, use.diff=FALSE ) } else if(is.null(diff)) { new( "unitizerItemTestsErrorsDiff", diff=diff, txt=out, txt.alt=out, err=curr.err@compare.err, diff.alt=capture.output(all.equal(curr.err@.ref, curr.err@.new)), use.diff=FALSE, show.diff=TRUE ) } else { new( "unitizerItemTestsErrorsDiff", diff=diff, txt=out, err=curr.err@compare.err, use.diff=x@.use.diff, show.diff=TRUE ) } } invisible(do.call("new", c(list("unitizerItemTestsErrorsDiffs"), diffs))) } ) #' Show Method for unitizerItemTestsErrorsDiffs objects #' #' @rdname show-unitizerItemTestsErrorsDiffs-method #' @keywords internal setMethod("show", "unitizerItemTestsErrorsDiffs", function(object) { sn <- slotNames(object) null.slots <- vapply(sn, function(x) is.null(slot(object, x)), logical(1L)) if(!all(null.slots)) { for(i in sn[!null.slots]) show(slot(object, i)) } invisible(object) } ) #' Show Method for unitizerItemTestsErrorsDiff objects #' #' @rdname show-unitizerItemTestsErrorsDiff-method #' @keywords internal setMethod("show", "unitizerItemTestsErrorsDiff", function(object) { cat_fun <- if(object@err) meta_word_msg else meta_word_cat cat_fun(if(object@show.diff) object@txt else object@txt.alt) if(object@show.diff) { if(object@use.diff) show(object@diff) else cat(object@diff.alt, sep='\n') cat("\n") } invisible(NULL) } ) #' Like all.equal but Returns Empty String If Not all.equal #' #' Used as the default value comparison function since when values mismatch #' we use \code{\link[diffobj]{diffObj}} which would make the text output from #' \code{\link{all.equal}} somewhat redundant. #' #' @export #' @param target R object #' @param current other R object to be compared to \code{target} #' @param ... arguments to pass to \code{\link{all.equal}} #' @return TRUE if \code{all.equal} returns TRUE, "" otherwise #' all_eq(1, 1L) #' all_eq(1, 2) #' isTRUE(all_eq(1, 2)) all_eq <- function(target, current, ...) if(isTRUE(all.equal(target, current, ...))) TRUE else "" #' Store Functions for New vs. Reference Test Comparisons #' #' \code{testFuns} contains the functions used to compare the results and side #' effects of running test expressions. \dQuote{testFuns} objects can be used #' as the \code{compare} argument for \code{\link{unitizer_sect}}, thereby #' allowing you to specify different comparison functions for different aspects #' of test evaluation. #' #' The default comparison functions are as follows: #' \itemize{ #' \item value: \code{\link{all_eq}} #' \item conditions: \code{\link{all_eq}} #' \item output: \code{function(x, y) TRUE}, i.e. not compared #' \item message: \code{function(x, y) TRUE}, i.e. not compared as conditions #' should be capturing warnings/errors #' \item aborted: \code{function(x, y) TRUE}, i.e. not compared as conditions #' should also be capturing this implicitly #' } #' @seealso \code{\link{unitizer_sect}} for more relevant usage examples, #' \code{\link{all_eq}} #' @rdname testFuns #' @name testFuns #' @export testFuns #' @examples #' # use `identical` instead of `all.equal` to compare values #' testFuns(value=identical) testFuns <- setClass( "testFuns", contains="unitizerItemTests", representation( value="unitizerItemTestFun", conditions="unitizerItemTestFun", output="unitizerItemTestFun", message="unitizerItemTestFun", aborted="unitizerItemTestFun" ), prototype( value=new("unitizerItemTestFun", fun=all_eq), # note this will dispatch all.equal.condition_list conditions=new("unitizerItemTestFun", fun=all_eq), output=new("unitizerItemTestFun", fun=function(target, current) TRUE), message=new("unitizerItemTestFun", fun=function(target, current) TRUE), aborted=new("unitizerItemTestFun", fun=function(target, current) TRUE) ) ) # Ensures Functions are In Correct Format # # Also, allows the user to specify functions directly instead of having # to instantiate \code{`\link{unitizerItemTestFun-class}`} for each function. # Finally, recovers the deparsed passed function name. # @keywords internal setMethod("initialize", "testFuns", function(.Object, ...) { dots <- list(...) if(!all(err.slots <- names(dots) %in% slotNames(getClass(.Object)))) stop("Can't initialize invalid slots ", deparse(names(dots)[!err.slots])) fun.names <- vapply(substitute(list(...))[-1L], deparse_fun, character(1L)) if(!all(names(fun.names) %in% names(dots))) stop("Internal Error: contact package maintainer.") # nocov for(i in names(dots)) { slot(.Object, i) <- if(is(dots[[i]], "unitizerItemTestFun")) { dots[[i]] } else { new("unitizerItemTestFun", fun=dots[[i]], fun.name=fun.names[[i]]) } } .Object } ) unitizer/R/unitizer.add.R0000644000176200001440000002427714766101401015063 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R #' @include item.sub.R #' @include unitizer.R NULL # Add a \code{`\link{unitizerSection-class}`} to a \code{`\link{unitizer-class}`} # # Registers the section, and the mapping of items to section. #' @rdname unitizer_s4method_doc setMethod("+", c("unitizer", "unitizerSection"), valueClass="unitizer", function(e1, e2) { # the map is index (item) to value (section), id auto-increments # with how many sections, and start tracks how many items exist in the # list; if we add a section, we basically blow away the section assignment # for the item that became a section, and replace it with the full section id <- length(e1@sections) + 1L start <- length(e1@items.new) + 1L # because sections added before items if(start == 1L & length(e1@section.map) == 0L) { e1@section.map <- rep(id, length(e2)) } else { # If not initial section add, then must be a nested section, so have to # remove value # reduce length of section with nested unitizer section e1@sections[[e1@section.map[start]]]@length <- e1@sections[[e1@section.map[start]]]@length - 1L # remove mapping for the unitizer section element that we are expanding e1@section.map <- e1@section.map[-start] # add mapping for the now expanded section e1@section.map <- append(e1@section.map, rep(id, length(e2)), start - 1L) } e1@section.parent <- c( e1@section.parent, if(isTRUE(is.na(e2@parent))) id else e2@parent ) if( e2@title %in% (titles <- vapply(e1@sections, function(x) x@title, character(1L))) ) { e2@title <- tail(make.unique(c(titles, e2@title)), 1L) } e1@sections <- append(e1@sections, list(e2)) e1 } ) # Adds Expressions to unitizer # # Expressions can be added as \code{\link{unitizerTests-class}} object # or a straight up expression, though in most cases it should be the # latter. # # NOTE: you can only do this once for a \code{unitizer}. #' @rdname unitizer_s4method_doc setMethod("+", c("unitizer", "unitizerTestsOrExpression"), valueClass="unitizer", function(e1, e2) { start.time <- proc.time() if(length(e1@sections)) # nocov start stop( "Internal Error: you are attempting to add more than one set ", "of tests or expressions to this `unitizer`" ) # nocov end if(is.expression(e2)) e2 <- new("unitizerTests") + e2 e1 <- e1 + new("unitizerSection", length=length(e2)) matched.calls <- rep(NA_integer_, length(e2)) i <- 1L sect.par <- NA_integer_ # Used to track if there is an active section and to manage nested sections sect.end <- 0L test.env <- new.env(parent=e1@items.new@base.env) chr.width <- getOption("width") e1@global$cons <- new("unitizerCaptCons") old.warn <- getOption('warn') on.exit({ # have to do this here because some test call this diretly options(warn=old.warn) close_and_clear(e1@global$cons) }) repeat { if(done(e2 <- nextItem(e2))) break # We used to show this after exec because we wanted to swallow the # unitizer_sect calls (speculation); we'll just let them be shown so they # run before exec. call <- getItem(e2) if(e1@show.progress > 2L) over_print( deparse(call)[[1L]], append=TRUE, overwrite=!e1@transcript ) item <- exec(call, test.env, e1@global) # If item is a section, added to the store and update the tests with the # contents of the section, and re-loop (this is how we handle nested # tests), if not, store the evaluated test if(is(item@data@value[[1L]], "unitizerSectionExpression")) { sect.obj <- item@data@value[[1L]] if(i <= sect.end) { sect.end <- i + length(sect.obj) - 1L sect.par <- e1@section.parent[e1@section.map[[i]]] } else if (i > sect.end) { sect.end <- i + length(sect.obj) - 1L sect.par <- NA_integer_ } e1 <- e1 + new( "unitizerSection", title=sect.obj@title, details=sect.obj@details, length=length(sect.obj), parent=sect.par, compare=sect.obj@compare ) e2 <- e2 + sect.obj next } # record parent section id for when we create reference sections item@section.id <- e1@section.parent[[e1@section.map[[i]]]] # record name for attempting to match deleted tests to section item@section.name <- e1@sections[[item@section.id]]@title e1 <- e1 + item # store evaluated test and compare it to reference one # ignored items share environment with subsequent items if(!ignored(item)) test.env <- new.env(parent=test.env) i <- i + 1L } # Map reference tests to sections. Tests that match directly are assigned # to the corresponding new section. For deleted reference tests to new # sections, though we only map to parent sections, and match purely based on # section names e1@section.ref.map <- e1@section.map[e1@items.ref.map] e1@sections.ref <- e1@sections deleted <- which(is.na(e1@items.ref.map)) if(length(deleted)) { sec.titles <- vapply(e1@sections, slot, character(1L), "title") sec.parents <- unique(e1@section.parent) par.titles <- sec.titles[sec.parents] for(i in deleted) { sec.match <- Filter( Negate(is.na), match(e1@items.ref[[i]]@section.name, par.titles) ) if(identical(length(sec.match), 1L)) { e1@section.ref.map[[i]] <- sec.parents[[sec.match]] } else { e1@section.ref.map[[i]] <- NA_integer_ } } } # Finalize if(e1@show.progress > 2L) over_print("", overwrite=!e1@transcript) e1@eval.time <- (proc.time() - start.time)[["elapsed"]] on.exit() close_and_clear(e1@global$cons) e1@global$cons <- NULL e1 } ) # Adds \code{`\link{unitizerItems-class}`} objects to unitizer # # Any added \code{`\link{unitizerItems-class}`} objects are treated as # reference items. The only way to add new items is by adding each # item individually with \code{`\link{+,unitizer,unitizerItem-method}`}. # # One aspect of copying reference items which isn't handled here is moving # over the section data because this is kept at the \code{`\link{unitizer-class}`} # level, not at the \code{`\link{unitizerItems-class}`} level. The # section copying is handled by \code{`\link{refSections,unitizer,unitizer-method}`}. # This is something that we should clean-up eventually. #' @rdname unitizer_s4method_doc setMethod("+", c("unitizer", "unitizerItems"), valueClass="unitizer", function(e1, e2) { itemsType(e2) <- "reference" parent.env(e2@base.env) <- e1@base.env e1@items.ref <- e2 if(length(e1@items.ref)) { e1@items.ref.calls.deparse <- vapply( as.list(e1@items.ref), slot, character(1L), "call.dep" ) e1@items.ref.map <- rep(NA_integer_, length(e1@items.ref)) } e1 } ) setGeneric("refSections", function(x, y) standardGeneric("refSections")) # Extract Reference Section Data # # Using one unitizer with existing new items, and another unitizer that we # just created from it by pulling out the tests we intend to keep, recreate # the sections for the tests we intend to keep. # # This isn't super robust as we're not ensuring that the two unitizers used # here are related in any way. Would be better to have something that does # this properly... # # @param x the new unitizer that will be stored with the reference tests # @param y the unitizer that will be used to generate the sections setMethod("refSections", c("unitizer", "unitizer"), valueClass="unitizer", function(x, y) { if(!length(x@items.ref)) return(x) sections.ref.ids <- vapply(as.list(x@items.ref), slot, 1L, "section.id") sections.unique <- Filter(Negate(is.na), sort(unique(sections.ref.ids))) if(!length(sections.unique)) return(x) if(!all(sections.unique %in% seq_along(y@sections))) { # nocov start stop( "Internal Error: reference tests referencing non-existing sections in ", "original; contact maintainer" ) # nocov end } sects <- y@sections[sections.unique] sects.ranks <- rank(sections.unique, ties.method="first") sections.ref.mapped <- sects.ranks[match(sections.ref.ids, sections.unique)] sects.map <- ifelse( is.na(sections.ref.mapped), max(sections.unique) + 1L, sections.ref.mapped ) if(na.sects <- sum(is.na(sections.ref.ids))) { na.sect <- new("unitizerSectionNA", length=na.sects) sects <- c(sects, list(na.sect)) } x@sections.ref <- sects x@section.ref.map <- sects.map # Re-sequence ids so they map to our reference mapping for(i in 1:length(x@items.ref)) x@items.ref[[i]]@id <- i x } ) # Adds \code{`\link{unitizerItem-class}`} to \code{`\link{unitizer-class}`} # # All tests are run on addition, and mapping information between reference and # new tests is also recored. # # @seealso \code{`\link{registerItem,unitizer,unitizerItem-method}`} #' @rdname unitizer_s4method_doc setMethod("+", c("unitizer", "unitizerItem"), function(e1, e2) { e2 <- try(updateLs(e2, e1@items.new@base.env)) if(inherits(e2, "try-error")) # nocov start stop( "Internal Error: unable to update LS for new item; contact maintainer." ) # nocov end e1 <- registerItem(e1, e2) e1 <- testItem(e1, e2) e1 } ) # Add Test Errors to \code{`\link{unitizer-class}`} #' @rdname unitizer_s4method_doc setMethod("+", c("unitizer", "unitizerItemTestsErrors"), function(e1, e2) { e1@tests.errorDetails <- append(e1@tests.errorDetails, list(e2)) e1 } ) unitizer/R/onload.R0000644000176200001440000000267514766101401013735 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include options.R #' @include global.R NULL .loaded <- FALSE .onLoad <- function(libname, pkgname) { # nocov start options( .unitizer.opts.default[ setdiff(names(.unitizer.opts.default), names(options())) ] ) .loaded <<- TRUE # nocov end } .onUnload <- function(libpath) { } .onAttach <- function(libname, pkgname) { if(is.null(getOption('unitizer.state'))) { packageStartupMessage( "State tracking is disabled by default to comply with CRAN policies. ", "Add `options(unitizer.state='suggested')` to your 'Rprofile' file ", "to enable, or `options(unitizer.state='off')` to quash this message ", "without enabling. Prior to enabling, be sure to read `?unitizerState`,", "in particular the 'CRAN non-compliance' section." ) } } unitizer/R/state.compare.R0000644000176200001440000001401114766340624015225 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # This used to have all the state comparison methods, but those just became # unneeded with the advent of diffobj # # \code{all.equal} methods involving dummy #' @rdname unitizer_s4method_doc setMethod( # We could just drop this altogether, but leaving it for future use "all.equal", c("unitizerDummy", "unitizerDummy"), function(target, current, ...) TRUE ) #' @rdname unitizer_s4method_doc setMethod( "all.equal", c("unitizerDummy", "ANY"), function(target, current, ...) paste( "`.REF` value was not recorded, but `.NEW` value was; they are likely", "different" ) ) #' @rdname unitizer_s4method_doc setMethod( "all.equal", c("ANY", "unitizerDummy"), function(target, current, ...) paste( "`.NEW` value was not recorded, but `.REF` value was; they are likely", "different" ) ) #' @export #' @rdname unitizer_s4method_doc setMethod("all.equal", c("unitizerStateRaw", "unitizerStateRaw"), function(target, current, ...) { for(i in slotNames(target)) { if(!isTRUE(diff <- all.equal(slot(target, i), slot(current, i)))) return(sprintf("Slot `%s` is not all equal: %s", i, diff)) } TRUE } ) # To force recognizing the S4 method when called from inside another package # which happens when we're doing `in_pkg`; will only work if the first argument # is `unitizerDummy`, which should be the most common use case #' @method all.equal unitizerDummy #' @exportS3Method all.equal unitizerDummy all.equal.unitizerDummy <- function(target, current, ...) { all.equal(target, current, ...) } #' @method all.equal unitizerStateRaw #' @exportS3Method all.equal unitizerStateRaw all.equal.unitizerStateRaw <- function(target, current, ...) { all.equal(target, current, ...) } # specifically an all.equal that returns garbage for testing; unfortunately # this needs to be exported to be useable (blergh) (IS THIS STILL USED?) # nocov start #' @method all.equal unitizer_glob_state_test #' @exportS3Method all.equal unitizer_glob_state_test all.equal.unitizer_glob_state_test <- function(target, current, ...) list(1, 2, list("woohoo")) # nocov end ## Merge State Data Between Reference and New Indices ## ## Required because we track these separately, but when we merge new and ## reference items we have to account for states from both. ## ## The items will be what is created by the review process and will contain a ## mix of new and reference items. We go through and identify the reference ## items, and pull out the relevant states from the ref states tracking store ## and append them to the new states. As part of this process, we need to ## re-index all the reference state elements to start counting after the end of ## the new state elements. ## ## @param x items, typically "reference" item being prepared for storage ## @param y new states ## @param z ref states setGeneric("mergeStates", function(x, y, z, ...) standardGeneric("mergeStates")) setMethod( "mergeStates", c( "unitizerItems", "unitizerGlobalTrackingStore", "unitizerGlobalTrackingStore" ), function(x, y, z, ...) { types <- itemsType(x) types.ref <- which(types == "reference") if(length(types.ref)) { ref.indices <- lapply(x[types.ref], slot, "glob.indices") max.indices <- unitizerStateMaxIndices(y) # max new index # Map the global indices in reference to values starting from 1 up beyond # the end of the indices in the new indices, though use zeros for zero; # these are the index location for the reference items once we append # them to the tracking object; use `do.call` because `vapply`/`apply` # unstable in 1 column vs multi column inputs (#212, #199) remap <- function(w) match(w, sort(Filter(as.logical, unique(w))), nomatch=0L) ref.ind.mx <- do.call(cbind, lapply(ref.indices, as.integer)) ref.ind.mx.map <- do.call( rbind, lapply(split(ref.ind.mx, row(ref.ind.mx)), remap) ) + as.integer(max.indices) rownames(ref.ind.mx.map) <- rownames(ref.ind.mx) if(!identical(attributes(ref.ind.mx), attributes(ref.ind.mx.map))) { stop( # nocov start "Internal Error: global index mapping matrix malformed; contact ", "maintainer." ) # nocov end } ref.ind.mx.map[!ref.ind.mx] <- 0L # these all map to the starting state # Pull out the states from ref and copy them into new; note that it is # possible for reference states to all reference the 0 index, meaning a # state wasn't captured, in that case we don't do anything for(i in slotNames(y)) { needed.state.ids <- unique(ref.ind.mx[i, ]) needed.state.ids.map <- unique(ref.ind.mx.map[i, ]) max.map.id <- max(needed.state.ids.map) if(max.map.id) { # 0 index only length(slot(y, i)) <- max.map.id for(j in seq_along(needed.state.ids)) { id <- needed.state.ids[[j]] id.map <- needed.state.ids.map[[j]] if(!id.map) next slot(y, i)[[id.map]] <- slot(z, i)[[id]] } } } # For each ref index, remap to the new positions in new state for(i in seq_along(types.ref)) { old.id <- types.ref[[i]] x[[old.id]]@glob.indices <- do.call( "new", c(list("unitizerGlobalIndices"), as.list(ref.ind.mx.map[, i])) ) } } # Return a list with the update item list and the states list(items=x, states=y) } ) unitizer/R/item.R0000644000176200001440000003377014766101401013417 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # - Required Code ------------------------------------------------------------- #' @include conditions.R #' @include class_unions.R #' @include list.R #' @include global.R NULL # - Validity ------------------------------------------------------------------ # Used to run "validity" methods # # This is to avoid having to automatically run validity on object # instantiation as is the case with actual built-in validity objects. We can # create a bunch of objects, and then only run validity when # # @param object object to validate # @param ... additional arguments # @return TRUE on success, character vector explaining failure otherwise setGeneric( # nocov start "isValid", function(object, ...) standardGeneric("isValid") # nocov end ) # - Classes ------------------------------------------------------------------- # Data Produced During Evaluation of \code{`unitizer`} Test # # Kept separate from the \code{`\link{unitizerItem-class}`} because these # are the slots that get compared from the new item to the reference items # which means there are a whole bunch of other classes that need to have the # same structure as this and by definining it we let those other classes # confirm they have the correct structure. setClass( "unitizerItemData", representation( value="list", conditions="conditionList", output="character", message="character", aborted="logical" # more generally, should this be a withRestarts slot? ) ) # Full Representation Of an Evaluated \code{`unitizer`} Test # # Note we have both a `call` and `call.dep` object due to the # # @slot call the call that is tested # @slot call.dep deparsed version of the call # @slot reference whether this is a reference or new \code{`unitizerItem`} # @slot ignore whether this test should be treated as a test or just a step # towards compiling a test # @slot environment the environment the test was evaluated in, should contain # all relevant objects # @slot data the container for the results of the evaluation of \code{`call`} # @slot the \code{`unitizer_sect`} from the newly added items this test item # corresponds to; can be NA if section not known; this is used primarily to # keep track of original sections when storing reference tests. setClass( "unitizerItem", representation( call="ANY", call.dep="character", id="integer", reference="logical", env="environmentOrNULL", ignore="logical", ls="data.frame", comment="characterOrNULL", trace="list", data="unitizerItemData", section.id="integer", section.name="character", glob.indices="unitizerGlobalIndices", state="unitizerGlobalState" ), prototype( reference=FALSE, ignore=FALSE, id=1L, ls=data.frame(names=character(), status=character()), section.id=NA_integer_ ) ) unitizerItemSlotNames <- slotNames("unitizerItem") # cache names setMethod("isValid", "unitizerItem", function(object) { if(!identical(length(object@reference), 1L)) return("Slot `@reference` must be length 1") if(!identical(length(object@id), 1L) || !isTRUE(object@id > 0)) return("Slot `@id` must be length 1 and greater than zero.") if(!identical(names(object@ls), c("names", "status")) || !identical(unname(vapply(object@ls, class, "")), rep("character", 2L))) { return("Slot `@ls` has incorrect data structure") # nocov } if( length(object@section.id) != 1L || ( !is.na(object@section.id) && object@section.id < 1L # not 100% about allowing NA section ids, seems required for sectionless reference tests ) ) { return("Slot `@section.id` must be integer(1L) >= 1L") # nocov } if(!identical(length(object@section.name), 1L)) return("Slot `@section.name` must be character(1L)") TRUE } ) setClassUnion("unitizerItemOrNULL", c("unitizerItem", "NULL")) # Initialize A \code{`\link{unitizerItem-class}`} # # Makes the fact that most of the data needs to be part of a # \code{`\link{unitizerItemData-class}`} object transparent to the user. #' @rdname unitizer_s4method_doc setMethod("initialize", "unitizerItem", function(.Object, ...) { dots.all <- list(...) dots.names <- names(dots.all) if("call" %in% dots.names) { .Object@call <- dots.all$call .Object@call.dep <- deparse_call(dots.all$call) } else .Object@call <- NULL if("env" %in% dots.names) .Object@env <- dots.all$env if("comment" %in% dots.names) .Object@comment <- dots.all$comment if("trace" %in% dots.names) .Object@trace <- dots.all$trace if("reference" %in% dots.names) .Object@reference <- dots.all$reference if("glob.indices" %in% dots.names) .Object@glob.indices <- dots.all$glob.indices dots <- dots.all[!(dots.names %in% unitizerItemSlotNames)] if("ignore" %in% dots.names) { .Object@ignore <- dots.all$ignore if(.Object@ignore) dots[["value"]] <- new("unitizerDummy") } dots[["value"]] <- list(dots[["value"]]) # to avoid S3 validity issues .Object@data <- do.call("new", c(list("unitizerItemData"), dots), quote=TRUE) .Object } ) # Collection of \code{\link{unitizerItem-class}} Objects setClass("unitizerItems", contains="unitizerList", representation( base.env="environment" # should be enclosure of first item ), validity=function(object) { if(!all(vapply(object@.items, is, logical(1L), "unitizerItem"))) return("slot `items` may only contain objects \"unitizerItem\"") if(!(obj.len <- length(object))) return(TRUE) # Need to test items in addition to what the unitizerList validity does # because we cannot actually have a validity method attached to # each unitizer item (way too slow) idx.to.test <- unique( c(1L, max(1L, as.integer(floor(obj.len / 2))), obj.len)) test <- lapply(as.list(object[idx.to.test]), isValid) success <- vapply(test, isTRUE, logical(1L)) if(all(success)) TRUE else unlist(test[!success]) } ) setClassUnion("unitizerItemsOrNULL", c("unitizerItems", "NULL")) # - Single Object Methods ----------------------------------------------------- # Display a \code{`\link{unitizerItem-class}`} Object # # Highly summarized view of the unitizer object. #' @rdname unitizer_s4method_doc setMethod("show", "unitizerItem", function(object) { cat("~~~ ") if(object@reference) cat("Reference") else cat("New") cat(" Test ~~~\n") cat(object@call.dep, sep="\n") cat( "* value:", paste0( desc(object@data@value[[1L]], limit=getOption("width") - 7L), "\n" ) ) if(out.len <- sum(nchar(object@data@output))) cat("* output:", out.len, "chars\n") if(err.len <- sum(nchar(object@data@message))) cat("* message:", err.len, "chars\n") if(cond.len <- length(object@data@conditions)) { cond.types <- vapply( as.list(object@data@conditions), function(x) { if(inherits(x, "error")) { "error" } else if (inherits(x, "warning")) { "warning" } else if (inherits(x, "message")) { "message" } else { "other" } }, character(1L) ) cond.types.summ <- Filter( Negate(is.na), tapply( cond.types, factor( cond.types, levels=c("error", "warning", "message", "other")), length ) ) cat( "* conditions:", paste0( cond.types.summ, " ", paste0( names(cond.types.summ), ifelse(cond.types.summ > 1L, "s", "") ), "\n", collapse=", " ) ) } cat( "\nAccess components with `$`, e.g.", paste0("`", if(object@reference) ".REF" else ".NEW", "$value`;"), "see `help(\"$\", \"unitizer\")`\n" ) } ) # Methods to Track Whether a \code{\link{unitizerItem-class}} Object is New Or Reference # # Necessitated due to the awkward structure around # \code{\link{reviewNext,unitizerBrowse-method}}, where the only return value is # a \code{\link{unitizerItems-class}} object and there is no easy way to tell # which objects have been kept from reference vs which ones are # new. # nocov start setGeneric("itemType", function(x, ...) standardGeneric("itemType")) setGeneric("itemType<-", function(x, value) standardGeneric("itemType<-")) setGeneric("itemsType<-", function(x, value) standardGeneric("itemsType<-")) setGeneric("itemsType", function(x, ...) standardGeneric("itemsType")) # nocov end setMethod( "itemType", "unitizerItem", function(x) if(x@reference) "reference" else "new" ) setReplaceMethod("itemType", c("unitizerItem", "character"), function(x, value) { if(!(value %in% c("new", "reference"))) stop("Argument `value` must be in ", deparse(c("new", "reference"))) x@reference <- identical(value, "reference") x } ) setMethod("itemsType", "unitizerItems", function(x) { vapply( as.list(x), function(y) if(y@reference) "reference" else "new", character(1L) ) } ) setReplaceMethod("itemsType", c("unitizerItems", "character"), function(x, value) { if(length(value) != 1L & !identical(length(x), length(value))) { stop( "Argument `value` must be length 1L or have same length as argument `x`") } if(!all(value %in% c("reference", "new"))) stop("Argument `value` may only contain ", deparse(c("new", "reference"))) if(length(x)) { x@.items <- mapply(function(y, z) { y@reference <- identical(z, "reference") y }, x@.items, value, SIMPLIFY=F ) } x } ) setGeneric("ignored", function(x, ...) standardGeneric("ignored")) # Determines Which Items In \code{\link{unitizerItems-class}} Are Not Full Tests # # In order to simplify user interaction, some statements are not considered # to be tests, rather, they are set up steps for the actual test. At the # time of this writing, top level assignments are included in this group. setMethod( "ignored", "unitizerItems", function(x, ...) vapply(as.list(x), function(y) y@ignore, logical(1L)) ) setMethod("ignored", "unitizerItem", function(x, ...) x@ignore) # - Multi Object Methods ------------------------------------------------------- # Add a \code{\link{unitizerItem-class}} to a \code{\link{unitizerItems-class}} #' @rdname unitizer_s4method_doc setMethod("+", c("unitizerItems", "unitizerItemOrNULL"), function(e1, e2) { if(is.null(e2)) return(e1) e1 <- append(e1, list(e2)) e1 } ) # Add a \code{\link{unitizerItem-class}} to a \code{\link{unitizerItems-class}} #' @rdname unitizer_s4method_doc setMethod("+", c("unitizerItems", "unitizerItems"), function(e1, e2) append(e1, e2) ) #' Retrieve Test Contents From Test Item #' #' Intended for use within the \code{unitizer} interactive environment, allows #' user to retrieve whatever portions of tests are stored by \code{unitizer}. #' #' Currently the following elements are available: #' #' \itemize{ #' \item \code{call} the call that was tested as an unevaluated call, #' but keep in mind that if you intend to evaluate this for a reference #' item the environment may not be the same so you could get different #' results (\code{ls} will provide more details) #' \item \code{value} the value that results from evaluating the test, note #' this is equivalent to using \code{.new} or \code{.ref}; note that the #' value is displayed using \code{\link{desc}} when viewing all of #' \code{.NEW} or \code{.REF} #' \item \code{output} the screen output (i.e. anything produced by cat/print, #' or any visible evaluation output) as a character vector #' \item \code{message} anything that was output to \code{stderr}, mostly #' this is all contained in the conditions as well, though there could be #' other output here, as a character vector #' \item \code{conditions} a \code{\link{conditionList}} containing all #' the conditions produced during test evaluation #' \item \code{aborted} whether the test call issues a restart call to the #' `abort` restart, as `stop` does. #' } #' @export #' @aliases $,unitizerItem-method #' @name $.unitizerItem #' @rdname extract-unitizerItem-method #' @param x a \code{unitizerItem} object, typically \code{.NEW} or \code{.REF} #' at the \code{unitizer} interactive prompt #' @param name a valid test sub-component #' @param i a valid test sub-component as a character string, or a sub-component #' index #' @param j missing for compatibility with generic #' @param ... missing for compatibility with generic #' @param exact unused, always matches exact #' #' @return the test component requested #' @examples #' ## From the unitizer> prompt: #' .NEW <- mock_item() # .NEW is normally available at unitizer prompt #' .NEW$call #' .NEW$conditions #' .NEW$value # equivalent to `.new` setMethod("$", c("unitizerItem"), function(x, name) { what <- substitute(name) what <- if(is.symbol(what)) as.character(what) else name x[[what]] } ) #' @export #' @rdname extract-unitizerItem-method setMethod( "[[", signature=c(x="unitizerItem"), function(x, i, j, ..., exact=TRUE) { what <- i data.slots <- slotNames(x@data) extras <- c("call", "state") valid <- c(extras, data.slots) if(identical(what, "call")) return(parse(text=x@call.dep)[[1L]]) if(identical(what, "state")) return(x@state) if(length(what) != 1L || !what %in% data.slots) { stop( "Argument `name` must be in ", paste0(deparse(valid, width.cutoff=500L), collapse="") ) } if(identical(what, "value")) return(x@data@value[[1L]]) slot(x@data, what) } ) unitizer/R/list.R0000644000176200001440000002512214766101401013424 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include class_unions.R NULL #' S4 Object To Implement Base List Methods #' #' Internal \code{unitizer} objects used to manage lists of objects. The only #' user facing instance of these objects are \code{\link{conditionList}} #' objects. For the most part these objects behave like normal S3 lists. The #' list contents are kept in the \code{.items} slot, and the following methods #' are implemented to make the object mostly behave like a standard R list: #' \code{[}, \code{[[}, \code{[<-}, \code{[[<-}, \code{as.list}, \code{append}, #' \code{length}, \code{names}, and \code{names<-}. #' #' The underlying assumption is that the `.items` slot is a list #' (or an expression), and that slot is the only slot for which #' it's order and length are meaningful (i.e. there is no other list #' or vector of same length as `.items` in a different slot that is #' supposed to map to `.items`). This last assumption allows us #' to implement the subsetting operators in a meaningful manner. #' #' The validity method will run \code{validObject} on the first, last, and #' middle items (if an even number of items, then the middle closer to the #' first) assuming they are S4 objects. We don't run on every object to avoid #' potentially expensive computation on all objects. #' #' @name unitizerList #' @rdname unitizerList #' @seealso \code{\link{conditionList}} #' @slot .items a list or expression #' @slot .pointer integer, used for implementing iterators #' @slot .seek.fwd logical used to track what direction iterators are going #' @examples #' new('unitizerList', .items=list(1, 2, 3)) setClass( "unitizerList", representation( .items="listOrExpression", .pointer="integer", .seek.fwd="logical" ), prototype(.pointer=0L, .seek.fwd=TRUE), validity=function(object) { obj.len <- length(object) if(!length(object)) return(TRUE) idx.to.test <- unique( c(1L, max(1L, as.integer(floor(obj.len / 2))), obj.len) ) lapply( idx.to.test, function(x) if(isS4(object[[x]])) validObject(object[[x]], complete=TRUE) ) TRUE } ) # - Methods ------------------------------------------------------------------- # Compute Number of Items in \code{\link{unitizerList-class}} #' @rdname unitizer_s4method_doc setMethod("length", "unitizerList", function(x) length(x@.items)) # Subsetting Method for \code{\link{unitizerList-class}} #' @rdname unitizer_s4method_doc setMethod("[", signature(x="unitizerList", i="subIndex", j="missing", drop="missing"), function(x, i) { x@.items <- x@.items[i] x } ) # Subsetting Method for \code{\link{unitizerList-class}} #' @rdname unitizer_s4method_doc setMethod("[[", signature(x="unitizerList", i="subIndex"), function(x, i) { x@.items[[i]] } ) # Replace Method for \code{\link{unitizerList-class}} #' @rdname unitizer_s4method_doc setReplaceMethod("[", signature(x="unitizerList", i="subIndex"), function(x, i, value) { pointer.reset <- ( is.logical(i) && (lt <- sum(which(i) <= x@.pointer)) || is.numeric(i) && (lt <- sum(floor(i) <= x@.pointer)) || is.character(i) && (lt <- sum(match(i, names(x)) <= x@pointer)) ) && is.null(value) x@.items[i] <- if(is(value, "unitizerList")) value@.items else value if(pointer.reset) x@.pointer <- x@.pointer - lt x } ) # Replace Method for \code{\link{unitizerList-class}} #' @rdname unitizer_s4method_doc setReplaceMethod("[[", signature(x="unitizerList", i="subIndex"), function(x, i, value) { pointer.reset <- ( is.numeric(i) && floor(i[[1L]]) <= x@.pointer || is.character(i) && match(i[[1L]], names(x)) <= x@pointer ) && is.null(value) x@.items[[i]] <- value if(pointer.reset) x@.pointer <- x@.pointer - 1L x } ) # Coerce to list by returning items #' @rdname unitizer_s4method_doc setMethod("as.list", "unitizerList", function(x, ...) x@.items) # So that S3 dispatch works #' @method as.list unitizerList #' @export as.list.unitizerList <- function(x, ...) as.list(x, ...) #' Coerce to expression by returning items coerced to expressions #' #' Really only meaningful for classes that implement the \code{.items} #' slot as an expression, but works for others to the extent #' \code{.items} contents are coercible to expressions #' #' @keywords internal setMethod("as.expression", "unitizerList", function(x, ...) as.expression(x@.items, ...)) setGeneric("nextItem", function(x, ...) standardGeneric("nextItem")) #' Iterate through items of a \code{\link{unitizerList}} ObjectJK #' #' Extraction process is a combination of steps: #' \enumerate{ #' \item Move Internal pointer with \code{nextItem} or \code{prevItem} #' \item Retrieve item \code{getItem} #' \item Check whether we're done iterating with \code{done} #' } #' \code{done} will return TRUE if the pointer is on either the #' first or last entry depending on what direction you are iterating. #' If you wish to iterate from the last item forward, you should either #' \code{reset} with parameter \code{reverse} set to TRUE, or re-order #' the items. #' #' @aliases nextItem,unitizerList-method prevItem,unitizerList-method #' getItem,unitizerList-method reset,unitizerList-method, #' done,unitizerList-method #' @keywords internal #' @param x a \code{\link{unitizerList}} object #' @return \code{\link{unitizerList}} for \code{getItem}, #' an item from the list, which could be anything setMethod("nextItem", "unitizerList", valueClass="unitizerList", function(x) { x@.pointer <- x@.pointer + 1L x@.seek.fwd <- TRUE x } ) setGeneric("prevItem", function(x, ...) standardGeneric("prevItem")) setMethod("prevItem", "unitizerList", valueClass="unitizerList", function(x) { x@.pointer <- x@.pointer - 1L x@.seek.fwd <- FALSE x } ) setGeneric("reset", function(x, ...) standardGeneric("reset")) setMethod("reset", "unitizerList", valueClass="unitizerList", function(x, position=NULL) { if( !is.null(position) && (!is.character(position) || !identical(length(position), 1L) || !(position %in% c("front", "back"))) ) { stop("Argument `position` must be `NULL`, or \"front\" or \"back\"") } if(is.null(position)) position <- if(x@.seek.fwd) "front" else "back" if(identical(position, "front")) { x@.seek.fwd <- TRUE x@.pointer <- 0L } else if (identical(position, "back")) { x@.seek.fwd <- FALSE x@.pointer <- length(x) + 1L } else { stop("Internal Error; unexpected `position` argument") # nocov } x } ) setGeneric("getItem", function(x, ...) standardGeneric("getItem")) setMethod("getItem", "unitizerList", function(x) { if(!(x@.pointer %in% seq_along(x))) { if(x@.pointer %in% c(0L, length(x) + 1L)) { if(identical(x@.pointer, 0L) & x@.seek.fwd) { stop("Internal pointer for `x` not initialized; initialize with `nextItem`") } else if (identical(x@.pointer, length(x) + 1L) & !x@.seek.fwd) { stop("Internal pointer for `x` not initialized; initialize with `prevItem`") } stop( "Internal pointer for `x` outside of range for `x`; test for ", "this condition with `done`, or reset with `reset`" ) } else { stop("Internal pointer for `x` is corrupted") } } x@.items[[x@.pointer]] } ) setGeneric("done", function(x, ...) standardGeneric("done")) setMethod("done", "unitizerList", function(x) { if(x@.seek.fwd & x@.pointer > length(x)) return(TRUE) else if (!x@.seek.fwd & identical(x@.pointer, 0L)) return(TRUE) FALSE } ) #' @export setGeneric("append") # Append To a \code{\link{unitizerList}} Object # # \code{values} is coerced to list or expression depending on # type of \code{x} \code{.items} slot. # # The resulting object is not tested for validity as this is too expensive # on a regular basis. You should check validity with \code{validObject} # # @param x the object to append to # @param values the object to append # @param after a subscript, after which the values are to be appended. #' @rdname unitizer_s4method_doc setMethod("append", c("unitizerList", "ANY"), function(x, values, after=length(x)) { attempt <- try( if(is.list(x@.items)) { values <- as.list(values) } else if (is.expression(x@.items)) { values <- as.expression(values) } ) if(inherits(attempt, "try-error")) { stop("Unable to coerce argument `values` to appropriate type; see previous errors for details.") } if(!is.numeric(after) || !identical(length(after), 1L) || after < 0) { stop("Argument `after` must be a length 1 numeric greater than zero") } y <- x x <- x@.items y@.items <- callNextMethod() if(y@.pointer > after) y@.pointer <- y@.pointer + length(values) # validObject(y) # too expensive, commented y } ) ## Concatenate to a \code{\link{unitizerList}} #' @rdname unitizer_s4method_doc setMethod("c", c("unitizerList"), function(x, ..., recursive=FALSE) { stop("This method is not implemented yet") # nocov } ) # Append Factors # # Note this is not related to \code{\link{append,unitizerList,ANY-method}} # except in as much as it is the same generic, so it just got thrown in here. # # @keywords internal #' @rdname unitizer_s4method_doc setMethod("append", c("factor", "factor"), function(x, values, after=length(x)) { if(!identical(attributes(x), attributes(values))) NextMethod() if( !is.numeric(after) || round(after) != after || length(after) != 1L || after > length(x) || after < 0L ) stop("Argument after must be integer like between 0 and length(x)") if(!length(values)) return(x) len.x <- length(x) length(x) <- length(x) + length(values) if(after < len.x) { x[(after + 1L + length(values)):length(x)] <- x[(after + 1L):(len.x)] } x[(after + 1L):(after + length(values))] <- values x } ) #' @rdname unitizer_s4method_doc setMethod("names", "unitizerList", function(x) names(x@.items)) #' @rdname unitizer_s4method_doc setReplaceMethod("names", "unitizerList", function(x, value) { names(x@.items) <- value x } ) unitizer/R/unitize.R0000644000176200001440000003625414766101401014150 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Unitize an R Test Script #' #' Turn standard R scripts into unit tests by storing the expressions therein #' along with the results of their evaluation, and provides an interactive #' prompt to review tests. #' #' \code{unitize} creates unit tests from a single R file, and #' \code{unitize_dir} creates tests from all the R files in the specified #' directory (analogous to \code{testthat::test_dir}). #' #' \code{unitizer} stores are identified by \code{unitizer} ids, which by #' default are character strings containing the location of the folder the #' \code{unitizer} RDS files are kept in. \code{unitize} and #' friends will create a \code{unitizer} id for you based on the test file #' name and location, but you can specify your own location as an id, or even #' use a completely different mechanism to store the \code{unitizer} data by #' implementing S3 methods for \code{\link{get_unitizer}} and #' \code{\link{set_unitizer}}. For more details about storage see those #' functions. #' #' \code{review} allows you to review existing \code{unitizer}s and modify them #' by dropping tests from them. Tests are not evaluated in this mode; you are #' just allowed to review the results of previous evaluations of the tests #' Because of this, no effort is made to create reproducible state in the #' browsing environments, unlike with \code{unitize} or \code{unitize_dir} #' (see \code{state} parameter). #' #' You are strongly encouraged to read through the vignettes #' for details and examples (\code{browseVignettes("unitizer")}). The demo #' (\code{demo("unitizer")}) is also a good introduction to these functions. #' #' @section Note: #' #' \code{unitizer} approximates the semantics of sourcing an R file when running #' tests, and those of the interactive prompt when reviewing them. The #' semantics are not identical, and in some cases you may notice differences. #' For example, when running tests: #' #' \itemize{ #' \item All expressions are run with \code{options(warn=1)}, #' irrespective of what the user sets that option to. #' \item \code{on.exit(...)} expressions will be evaluated immediately for #' top-level statements (either in the test file or in an #' \code{\link{unitizer_sect}}, thereby defeating their purpose). #' \item Each test expression is run in its own environment, which is enclosed #' by that of previous tests. #' \item Output and Message streams are sunk so any attempt to debug directly #' will be near-impossible as you won't see anything. #' \item For portable tests it is best to use ASCII only string literals #' (avoiding even escaped bytes or Unicode characters), round numbers, etc., #' because \code{unitizer} uses deparsed test expressions as indices #' to retrieve reference values. See \code{vignette('u1_intro', #' package='unitizer')} for details and work-arounds. #' } #' #' When reviewing them: #' #' \itemize{ #' \item \code{ls()} and \code{q()} are over-ridden by \code{unitizer} utility #' functions. #' \item Expressions are evaluated with \code{options(warn=1)} or greater, #' although unlike in test running it is possible to set and keep #' \code{options(warn=2)}. #' \item Some single upper case letters will be interpreted as \code{unitizer} #' meta-commands. #' } #' #' For a more complete discussion of these differences see the introductory #' vignette (\code{vignette('u1_intro')}), the "Special Semantics" section of #' the tests vignette (\code{vignette('u2_tests')}), and the "Evaluating #' Expressions at the \code{unitizer} Prompt" section of the interactive #' environment vignette (\code{vignette('u3_interactive-env')}). #' #' @section Default Settings: #' #' Many of the default settings are specified in the form \code{getOption("...")} #' to allow the user to "permanently" set them to their preferred modes by #' setting options in their \code{.Rprofile} file. #' #' @export #' @aliases review unitize_dir #' @param test.file path to the file containing tests, if supplied path does not #' match an actual system path, \code{unitizer} will try to infer a possible #' path. If NULL, will look for a file in the \dQuote{tests/unitizer} package #' folder if it exists, or in \dQuote{.} if it does not. #' See \code{\link{infer_unitizer_location}}) for details. #' @param test.dir the directory to run the tests on; if NULL will use the #' \dQuote{tests/unitizer} package folder if it exists, or \dQuote{.} if it #' does not. See \code{\link{infer_unitizer_location}}) for details. #' @param pattern a regular expression used to match what subset of files in #' \code{test.dir} to \code{unitize} #' @param store.id if NULL (default), \code{unitizer} will select a directory #' based on the \code{test.file} name by replacing \code{.[rR]} with #' \code{.unitizer}. You can also specify a directory name, or pass any #' object that has a defined \code{\link{get_unitizer}} method which allows #' you to specify non-standard \code{unitizer} storage mechanisms (see #' \code{\link{get_unitizer}}). Finally, you can pass an actual #' \code{unitizer} object if you are using \code{review}; see \code{store.ids} #' for \code{unitize_dir} #' @param store.ids one of \itemize{ #' \item a function that converts test file names to \code{unitizer} ids; if #' \code{unitize}ing multiple files will be \code{lapply}ed over each file #' \item a character vector with \code{unitizer} ids, must be the same #' length as the number of test files being reviewed (see \code{store.id}) #' \item a list of unitizer ids, must be the same length as the number of #' test files being reviewed; useful when you implement special storage #' mechanisms for the \code{unitizers} (see \code{\link{get_unitizer}}) #' } #' @param state character(1L) one of #' \code{c("prisitine", "suggested", "basic", "off", "safe")}, an #' environment, or a state object produced by \code{\link{state}} or #' \code{\link{in_pkg}}; modifies how \code{unitizer} manages aspects of #' session state that could affect test evaluation, including the parent #' evaluation environment. For more details see \code{\link{unitizerState}} #' documentation and \code{vignette("unitizer_reproducible_tests")} #' @param pre NULL, or a character vector pointing to files and/or directories. #' If a character vector, then any files referenced therein will be sourced, #' and any directories referenced therein will be scanned non-recursively for #' visible files ending in ".r" or ".R", which are then also sourced. If #' NULL, then \code{unitizer} will look for a directory named "_pre" in the #' directory containing the first test file and will treat it as if you had #' specified it in \code{pre}. Any objects created by those scripts will be #' put into a parent environment for all tests. This provides a mechanism for #' creating objects that are shared across different test files, as well as #' loading shared packages. Unlike objects created during test evaluation, #' any objects created here will not be stored in the \code{unitizer} so you #' will have not direct way to check whether these objects changed across #' \code{unitizer} runs. Additionally, typing \code{ls} from the review #' prompt will not list these objects. #' @param post NULL, or a character vector pointing to files and/or directories. #' See \code{pre}. If NULL will look for a directory named "_post" in the #' directory containing the first test file. Scripts are run just prior to #' exiting \code{unitizer}. \code{post} code will be run in an environment #' with the environment used to run \code{pre} as the parent. This means that #' any objects created in \code{pre} will be available to \code{post}, which #' you can use to your advantage if there are some things you do in \code{pre} #' you wish to undo in \code{post}. Keep in mind that \code{unitizer} can #' manage most aspects of global state, so you should not need to use this #' parameter to unload packages, remove objects, etc. See details. #' @param history character(1L) path to file to use to store history generated #' during interactive unitizer session; the default is an empty string, which #' leads to \code{unitizer} using a temporary file, set to NULL to disable #' history capture. #' @param interactive.mode logical(1L) whether to run in interactive mode ( #' request user input when needed) or not (error if user input is required, #' e.g. if all tests do not pass). #' @param force.update logical(1L) if TRUE will give the option to re-store a #' unitizer after re-evaluating all the tests even if all tests passed. #' You can also toggle this option from the unitizer prompt by typing \code{O} #' (capital letter "o"), though \code{force.update=TRUE} will force update #' irrespective of whether you type \code{O} at the prompt #' @param auto.accept character(X) ADVANCED USE ONLY: YOU CAN EASILY DESTROY #' YOUR \code{unitizer} WITH THIS; whether to auto-accept tests without #' prompting, use values in \code{c("new", "failed", "deleted", "error")} to #' specify which type(s) of test you wish to auto accept (i.e. same as typing #' \code{"Y"} at the \code{unitizer} prompt) or empty character vector to turn #' off (default) #' @param use.diff TRUE or FALSE, whether to use diffs when there is an error, #' if FALSE uses \code{\link{all.equal}} instead. #' @param show.progress TRUE or FALSE or integer(1L) in 0:3, whether to show #' progress updates for each part of the process (TRUE or > 0), for each file #' processed (TRUE or > 1), and for each test processed (TRUE or > 2). #' @param transcript TRUE (default in non-interactive mode) or FALSE (default in #' interactive mode) causes immediate output of stdout/stderr during test #' evaluation instead of deferred display during test review. This also #' causes progress updates to display on new lines instead of overlaying on #' the same line. One limitation of running in this mode is that stderr is no #' longer captured at all so is unavailable in the review stage. stderr #' text that is also part of a signalled condition (e.g. "boom" in #' `stop("boom")`) is still shown with the conditions in the review step. To #' see direct stderr output in transcript mode scroll up to the test #' evaluation point. #' @return \code{unitize} and company are intended to be used primarily for #' the interactive environment and side effects. The functions do return #' summary data about test outcomes and user input as #' \code{unitizer_result} objects, or for \code{unitize_dir} as #' \code{unitizer_results} objects, invisibly. See #' \code{\link{unitizer_result}}. #' @seealso \code{\link{unitizerState}}, \code{\link{unitizer.opts}}, #' \code{\link{get_unitizer}}, \code{\link{infer_unitizer_location}}, #' \code{\link{unitizer_result}} unitize <- function( test.file=NULL, store.id=NULL, state=getOption("unitizer.state"), pre=NULL, post=NULL, history=getOption("unitizer.history.file"), interactive.mode=interactive(), force.update=FALSE, auto.accept=character(0L), use.diff=getOption("unitizer.use.diff"), show.progress=getOption("unitizer.show.progress", TRUE), transcript=getOption("unitizer.transcript", !interactive.mode) ) { # Initial spacer, must be done in each top level call cat("\n") test.file.inf <- infer_unitizer_location(test.file) if(!file_test("-f", test.file.inf)) stop("Argument `test.file` must resolve to a file") store.id.inf <- store.id if(is.null(store.id)) store.id.inf <- filename_to_storeid(test.file.inf) invisible( unitize_core( test.file.inf, list(store.id.inf), state=state, pre=pre, post=post, history=history, interactive.mode=interactive.mode, force.update=force.update, auto.accept=auto.accept, mode="unitize", use.diff=use.diff, show.progress=show.progress, transcript=transcript )[[1L]] ) } #' @rdname unitize #' @export review <- function( store.id=NULL, use.diff=getOption("unitizer.use.diff"), show.progress=getOption("unitizer.show.progress", TRUE) ) { # Initial spacer, must be done in each top level call cat("\n") invisible( unitize_core( test.files=NA_character_, store.ids=list(infer_unitizer_location(store.id, type="u")), state="off", pre=FALSE, post=FALSE, history=getOption("unitizer.history.file"), interactive.mode=TRUE, force.update=FALSE, auto.accept=character(0L), mode="review", use.diff=use.diff, show.progress=show.progress, transcript=FALSE )[[1L]] ) } #' @rdname unitize #' @export unitize_dir <- function( test.dir=NULL, store.ids=filename_to_storeid, pattern="^[^.].*\\.[Rr]$", state=getOption("unitizer.state"), pre=NULL, post=NULL, history=getOption("unitizer.history.file"), interactive.mode=interactive(), force.update=FALSE, auto.accept=character(0L), use.diff=getOption("unitizer.use.diff"), show.progress=getOption("unitizer.show.progress", TRUE), transcript=getOption("unitizer.transcript", !interactive.mode) ) { # Validations if( (!is.character(test.dir) || length(test.dir) != 1L || is.na(test.dir)) && !is.null(test.dir) ) stop("Argument `test.dir` must be character(1L) and not NA, or NULL.") if(!is.character(pattern) || length(pattern) != 1L || is.na(pattern)) stop("Argument `pattern` must be character(1L) and not NA.") if(!is.null(test.dir) && file.exists(test.dir) && !file_test("-d", test.dir)) stop("Argument `test.dir` points to a file instead of a directory") # Initial spacer, must be done in each top level call cat("\n") # Infer test.dir <- infer_unitizer_location(test.dir, type="d") if(!file_test("-d", test.dir)) stop("Argument `test.dir` must point to a direcctory") test.files <- Filter( function(x) file_test("-f", x), sort( list.files( path=test.dir, pattern=pattern, all.files=TRUE, full.names=TRUE, no..=TRUE ) ) ) if(!length(test.files)) stop("No files to test in '", test.dir, "'") # And unitizers if(is.function(store.ids)) { store.ids <- try(lapply(test.files, store.ids)) if(inherits(store.ids, "try-error")) { stop( "Argument `store.ids` is a function, but caused an error when ", "attempting to use it to convert test file names to `unitizer` ids." ) } } invisible( unitize_core( test.files=test.files, store.ids=store.ids, state=state, pre=pre, post=post, history=history, interactive.mode=interactive.mode, force.update=force.update, auto.accept=auto.accept, mode="unitize", use.diff=use.diff, show.progress=show.progress, transcript=transcript ) ) } unitizer/R/prompt.R0000644000176200001440000003772614766101401014007 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include exec.R NULL #' Interactively Retrieve User Input #' #' Different functions used in different contexts to capture user input. #' \code{unitizer_prompt}, \code{navigate_prompt}, and \code{review_prompt} are #' more advanced and allow evaluation of arbitrary expressions, in addition to #' searching for specific commands such as "Y", "N", etc. \code{simple_prompt} #' only matches along specified values. #' #' The set-up is intended to replicate something similar to what happens when #' code hits a \code{browse()} statement. User expressions are evaluated #' and output to screen, and special expressions as described above cause the #' evaluation loop to terminate. #' #' \code{navigate_prompt} is just a wrapper around \code{unitizer_prompt} that #' provides the special shortcuts to navigate to other tests in the #' \code{unitizer}. #' #' \code{review_prompt} is also a wrapper, but used only when at the menu that #' presents available test items to navigate to. #' #' \code{simple_prompt} simpler prompting function used to allow user to select #' from pre-specified values. #' #' \code{exit_fun} is used as a generic function to pass to the #' \code{exit.condition} argument of \code{unitizer_prompt}. #' #' \code{read_line} and \code{read_line_set_vals} are utility functions that #' are used to implement a version of \code{\link{readline}} that can be #' automated for testing. #' #' @keywords internal #' @seealso browse_unitizer_items #' @param text the prompt text to display #' @param browse.env the environment to evaluate user expressions in; typically #' this will contain interesting objects (use \code{ls()} to review) #' @param valid.opts the special letters user can type to get a special action, #' typically a character vector where the names are one letter (though they #' don't actually have to be) and are looked for as user typed input; note that #' the quit and help options will always be appended to this #' @param help a character vector with help suggestions: the first value in the #' vector is \code{\link{word_cat}} output, the rest normal \code{cat} #' @param help.opts a character vector of help options #' @param hist.con connection to save history to #' @param exit.condition function used to evaluate whether user input should #' cause the prompt loop to exit; this function should accept two parameters: #' \itemize{ #' \item expression typed in by the user #' \item environment the environment user expressions get evaluated in #' } #' The function can then decide to exit or not based on either the literal #' expression or evaluate the expression and decide based on the result. This #' is implemented this way because \code{eval_user_exp} will print to screen #' which may not be desirable. Function should return a value which will then #' be returned by \code{unitizer_prompt}, unless this value is \code{FALSE} #' in which case \code{unitizer_prompt} will continue with normal evaluation. #' @param x a unitizerBrowse object #' @param browse.env1 environment to have user review tests, run commands, etc #' @param browse.env2 navigation environment #' @param curr.id which id we are currently browsing #' @param nav.env an environment #' @param ... additional arguments for \code{exit.condition} #' @param message character ask the user a question #' @param values character valid responses #' @param prompt see \code{\link{readline}} #' @param attempts how many times to try before erroring #' @param case.sensitive whether to care about case sensitivity when matching #' user input #' @param global unitizerGlobal or NULL, if the global state tracking object; #' will be used to record state after evaluating user expressions #' @param warn.sticky TRUE or FALSE (default) whether any changes to the "warn" #' global option made by the evaluation of an R expression under the prompt #' should be allowed to stick after the evaluation. Normally that option value #' is reset after each evaluation. #' @return \itemize{ #' \item \code{unitizer_prompt}: mixed allowable user input #' \item \code{navigate_prompt}: a \code{unitizerBrowse} object, or allowable #' user input #' \item \code{review_prompt}: a \code{unitizerBrowse} object, or "Q" if the #' user chose to quit #' \item \code{simple_prompt}: one of \code{values} as selected by user #' } unitizer_prompt <- function( text, browse.env=baseenv(), help=character(), help.opts=character(), valid.opts, hist.con=NULL, exit.condition=function(exp, env) FALSE, global, warn.sticky=FALSE, ... ) { if(!is.null(hist.con) && (!inherits(hist.con, "file") || !isOpen(hist.con))) stop("Argument `hist.con` must be an open file connection or NULL") if(!is.environment(browse.env)) { stop("Argument `browse.env` must be an environment") } if(!is.character(valid.opts)) stop("Argument `valid.opts` must be character") if(!is(global, "unitizerGlobal") && !is.null(global)) stop("Argument `global` must be \"unitizerGlobal\" or NULL") valid.opts <- c(valid.opts, Q="[Q]uit", H="[H]elp") # should validate other parameters as well opts.txt <- paste0( "(", paste0(valid.opts[nchar(valid.opts) > 0], collapse=", "), ")?" ) repeat { prompt.txt <- sprintf("%s> ", "unitizer") interrupted <- FALSE withRestarts( withCallingHandlers( val <- tryCatch( faux_prompt(prompt.txt), simpleError=function(e) e ), interrupt=function(e) invokeRestart("unitizerInterrupt") ), unitizerInterrupt=function(e) interrupted <<- TRUE ) on.exit(NULL) if(interrupted) { cat("\n") return(character()) } if(inherits(val, "simpleError")) { cond.chr <- as.character(val) cat(cond.chr, file=stderr()) next } if( # Input matches one of the options length(val) == 1L && is.symbol(val[[1L]]) && as.character(val[[1L]]) %in% names(valid.opts) && !(as.character(val[[1L]]) %in% c("Q", "H")) ) { cat("\n") return(as.character(val[[1L]])) } else if (length(val) == 1L && identical(val[[1L]], quote(Q))) { cat("\n") return(as.character(val[[1L]])) } else if (length(val) == 1L && identical(val[[1L]], quote(H))) { cat("\n") if(!length(help)) { meta_word_cat("No help available.", "", paste(text, opts.txt), sep="\n") } else { meta_word_cat(help, trail.nl=FALSE) if(length(help.opts)) meta_word_cat( as.character(UL(help.opts), width=getOption("width") - 2L), trail.nl=FALSE ) meta_word_cat("", paste(text, opts.txt)) } next } # Check whether input should be captured specially res <- try(exit.condition(val, browse.env, ...)) if(inherits(res, "try-error")) { # nocov start stop("Internal Error: exit condition function failed; contact maintainer.") # nocov end } else { if(!identical(res, FALSE)) return(res) } # Note `val` here is the expression the user inputted, not the result of the # evaluation. The latter will be in res$value res <- eval_user_exp(val, browse.env, global=global, warn.sticky=warn.sticky) # store / record history if(!is.null(hist.con) && length(val) == 1L) { dval <- deparse(val[[1L]]) history_write(hist.con, dval) } # error or no user input, re-prompt user if(res$aborted || !length(val)) { cat("\n") meta_word_cat(text, opts.txt, sep=" ") } # make error trace available for `traceback()` if(res$aborted && !is.null(res$trace)) set_trace(res$trace) } } #' @rdname unitizer_prompt #' @keywords internal navigate_prompt <- function( x, curr.id, text, browse.env1=globalenv(), browse.env2=globalenv(), help=character(), help.opts=character(), valid.opts, warn.sticky=FALSE ) { if(!is(x, "unitizerBrowse")) { stop( # nocov start "Internal Error, expected unitizerBrowse object as param `x`; ", "contact maintainer." ) } # nocov end # User input prompt.val <- unitizer_prompt( text, browse.env=browse.env1, help=help, help.opts=help.opts, valid.opts=valid.opts, hist.con=x@hist.con, global=x@global, warn.sticky=warn.sticky ) if(identical(prompt.val, "P")) { # Go back to previous prev.tests <- x@mapping@item.id < curr.id & !x@mapping@ignored & ( if(!identical(x@mode, "review")) x@mapping@review.type != "Passed" else TRUE ) x@last.id <- if(any(prev.tests)) max(which(prev.tests)) - 1L else 0L if(!x@last.id) meta_word_msg("At first reviewable item; nothing to step back to") x@navigating <- TRUE return(x) } else if (identical(prompt.val, "B")) { return(review_prompt(x, browse.env2)) } else if (identical(prompt.val, "U")) { unreviewed <- unreviewed(x) if(!length(unreviewed)) { meta_word_msg("No unreviewed tests.") x@last.id <- tail(x@mapping@item.id, 1L) } else x@last.id <- head(unreviewed, 1L) - 1L x@navigating <- TRUE return(x) } return(prompt.val) } #' @rdname unitizer_prompt #' @keywords internal review_prompt <- function(x, nav.env) { if(!is(x, "unitizerBrowse") || !is.environment(nav.env)) stop( # nocov start "Internal Error: unexpected inputs to internal function; contact ", "maintainer." ) # nocov end # Navigation Prompt nav.help <- paste0( "Select a test to review by typing that test's number at the prompt. ", "Tests that start with a `*`", if(identical(x@mode, "unitize")) ", or with status \"Passed\",", " are not typically reviewed in this mode. The letter after the test ", "status represents prior user input to test review (a `-` indicates test ", "has not been reviewed). Type \"U\" to jump to the first unreviewed ", "test.\n\n", "Note that tests are displayed in the order they appear in the test", "file, not in the order they would be reviewed in.\n" ) nav.opts <- c( "input a test number", U="[U]nreviewed" ) nav.prompt <- "What test do you wish to review" show(x) meta_word_cat( nav.prompt, paste0("(", paste0(nav.opts, collapse=", "), ")?"), sep=" " ) nav.id <- unitizer_prompt( text=nav.prompt, help=nav.help, browse.env=nav.env, exit.condition=exit_fun, valid.opts=nav.opts, valid.vals=x@mapping@item.id, global=x@global ) if(identical(nav.id, "Q")) { return("Q") } else if (identical(nav.id, "U")) { # Go to unreviewed test unreviewed <- unreviewed(x) nav.id <- if(!length(unreviewed)) { meta_word_msg("No unreviewed tests.") tail(x@mapping@item.id, 1L) + 1L } else head(unreviewed, 1L) } else if ( !is.numeric(nav.id) || length(nav.id) != 1L || as.integer(nav.id) != nav.id ) { stop( # nocov start "Internal Error: Unexpected user input allowed through in Review mode; ", "contact maintainer" ) # nocov end } else { # Remap our nav.id to the actual review order instead of file order nav.id <- x@mapping@item.id[match(nav.id, x@mapping@item.id.ord)] if(is.na(nav.id)) # nocov start stop( "Internal Error: failed retrieving internal item id; contact maintainer." ) # nocov end } # Determine whether test we selected is a test we would normally not review # note nav.id can be greater than length if we select Unreviewed and there are # no unreviewed if(nav.id <= length(x@mapping@ignored)) { x@inspect.all <- x@mapping@ignored[[nav.id]] || ( identical(x@mode, "unitize") && !x@start.at.browser && identical(as.character(x@mapping@review.type[[nav.id]]), "Passed") ) x@review <- if(x@inspect.all) -1L else 1L if(x@inspect.all) { cat("\n") meta_word_msg( "You selected a test that is not normally reviewed in this mode;", "as such, upon test completion, you will be brought back to this menu", "instead of being taken to the next reviewable test." ) } } # Set last.id to test just before the one we want to review as process will # then cause desired test to be reviewed id <- as.integer(nav.id) offset <- (!x@inspect.all) * find_lead_offset(nav.id, x@mapping) x@last.id <- id - (1L + offset) x@browsing <- id x@navigating <- TRUE return(x) } #' @rdname unitizer_prompt #' @keywords internal simple_prompt <- function( message, values=c("Y", "N"), prompt="unitizer> ", attempts=5L, case.sensitive=FALSE ) { if(!is.character(message)) stop("Argument `message` must be character") if(!is.character(values) || length(values) < 1L || any(is.na(values))) stop("Argument `values` must be character with no NAs") if(!is.character(prompt) || length(prompt) != 1L || is.na(prompt)) stop("Argument `prompt` must be character(1L) and not NA") if( !is.numeric(attempts) || length(attempts) != 1L || is.na(attempts) || attempts < 1 ) stop("Argument `attempts` must be numeric(1L), not NA, and one or greater") if(!is.TF(case.sensitive)) stop("Argument `case.sensitive` must be TRUE or FALSE") attempts <- attempts.left <- as.integer(attempts) val.tran <- if(!case.sensitive) tolower(values) meta_word_cat(message) while(attempts.left > 0L) { x <- read_line(prompt) if(!case.sensitive) x <- tolower(x) if(!(res.ind <- match(x, val.tran, nomatch=0L))) { meta_word_cat( paste( "Invalid input, please select one of:", paste(values, collapse=", ") ) ) } else return(values[[res.ind]]) attempts.left <- attempts.left - 1L } stop("Gave up trying to collect user input after ", attempts, " attempts.") } #' @keywords internal #' @rdname unitizer_prompt exit_fun <- function(y, env, valid.vals) { # keep re-prompting until user types in valid value if(!is.expression(y)) stop("Argument `y` should be an expression.") if( length(y) != 1L || !is.numeric(y[[1L]]) || length(y[[1L]]) != 1L || y[[1L]] != as.integer(y[[1L]]) ) return(FALSE) if(!isTRUE(y[[1L]] %in% valid.vals)) { meta_word_msg( "Type a number in `", deparse(valid.vals), "` at the prompt", sep="", trail.nl=FALSE ) return(FALSE) } return(y[[1L]]) } ## Tried to switch to `readLines` based on Lisa Bruine's tip that ## `readLines(con=stdin(), n=1)` can replace `readline`. Unfortunately if we do ## that, at least on OS X, a backspace after any input is typed in will delete ## the prompt. Also, no way to test CTRL+C. So we reverted it. #' @keywords internal #' @rdname unitizer_prompt read_line <- function(prompt="") { stopifnot(is.chr1(prompt)) if(is.null(.global$prompt.vals)) { # Sadly readLines(con=stdin(), n=1) doesn't quite work. readline(prompt) # nocov can't test this in non-interactive } else if(!is.character(.global$prompt.vals)) { stop( # nocov start "Internal Error: internal object `.global$prompt.vals` has unexpected ", "value; contact maintainer." ) # nocov end } else if(!length(.global$prompt.vals)) { # Need dedicated condition so `unitizer_prompt` can catch it cond <- simpleCondition( "Internal Error: ran out of predefined readline input; contact maintainer." ) class(cond) <- c("readError", "error", class(cond)) stop(cond) } else { res <- .global$prompt.vals[[1L]] .global$prompt.vals <- tail(.global$prompt.vals, -1L) cat(prompt, res, "\n", sep="") res } } #' @keywords internal #' @rdname unitizer_prompt read_line_set_vals <- function(vals) { stopifnot(is.character(vals) || is.null(vals)) .global$prompt.vals <- vals } unitizer/R/options.R0000644000176200001440000004612614766101401014153 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include search.R NULL #' Unitizer Options #' #' Description of major \code{unitizer} option settings. Once \code{unitizer} #' is loaded, you can see a full list of \code{unitizer} options with #' \code{grep("^unitizer", options(), value=TRUE)}. #' #' @section Basic State Options: #' #' Basic state options: #' #' \itemize{ #' \item \code{unitizer.state}: default state tracking setting (see #' \code{unitizerState}) #' \item \code{unitizer.seed}: default seed to use when random seed tracking #' is enabled; this is of type "Wichman-Hill" because it is a lot more #' compact than the default R random seed, and should be adequate for most #' unit testing purposes. #' } #' @section Options State Options: #' #' Additionally, when tracking option state we set options to what you would #' find in a freshly loaded vanilla R session, except for systems specific #' options which we leave unchanged (e.g. \code{getOption("papersize")}). #' If you want to add default option values or options to leave unchanged, you #' can use: #' #' \itemize{ #' \item \code{unitizer.opts.init}: named list, where names are options, and #' the associated value is the value to use as the default value for that #' option when a \code{unitizer} is launched with options tracking enabled. #' \item \code{unitizer.opts.asis}: character, containing regular expressions #' to match options to leave unchanged (e.g \code{"^unitizer\\."}) #' } #' @section Search Path and Namespace State Options: #' #' We also provide options to limit what elements can be removed from #' the search path and/or have their namespaces unloaded when \code{unitizer} #' tracks the search path state. For example, we use this mechanism to prevent #' removal of the \code{unitizer} package itself as well as the default #' R vanilla session packages. #' #' \itemize{ #' \item \code{unitizer.namespace.keep}: character, names of namespaces to #' keep loaded (e.g. \code{"utils"}); note that any imported namespaces #' imported by namespaces listed here will also remain loaded #' \item \code{unitizer.search.path.keep}: character, names of objects to #' keep on search path (e.g. \code{"package:utils"}, note the #' \code{"package:"}); associated namespaces will also be kept loaded #' } #' \bold{IMPORTANT}: There is a dependency between options tracking and search #' path / namespace exceptions that stems from most packages setting their #' default options when they are loaded. As a result, if you add any packages #' or namespaces to these options and options state tracking is enabled, then #' you must also add their options to \code{unitizer.opts.init} or #' \code{unitizer.opts.asis} to ensure those options remain loaded or at least #' set to reasonable values. If you do not do this the packages risk having #' their options unset. #' #' Some packages cannot be easily loaded and unloaded. For example #' \code{data.table} (<= 1.9.5) cannot be unloaded without causing a segfault #' (see issue \href{https://github.com/Rdatatable/data.table/issues/990}{#990}). #' For this reason \code{data.table} is included in #' \code{getOption("unitizer.namespace.keep")} by default. #' #' @section Sytem Default State Options: #' #' The following options hold the default system values for the search #' path / namespace and options state tracking options: #' \itemize{ #' \item \code{unitizer.namespace.keep.base}: namespaces that are known to #' cause problems when unloaded (as of this writing includes #' \code{data.table}) #' \item \code{unitizer.search.path.keep.base}: vanilla R session packages, #' plus \code{"package:unitizer"} and \code{"tools:rstudio"}, the latter #' because its implementation prevents re-attaching it if it is detached. #' \item \code{unitizer.opts.asis.base}: system specific options that should #' not affect test evaluation (e.g. \code{getOption("editor")}). #' \item \code{unitizer.opts.init.base}: base options (e.g. #' \code{getOption("width")} that will be set to what we believe are the #' factory settings for them. #' } #' These are kept separate from the user specified ones to limit the possibility #' of inadvertent modification. They are exposed as options to allow the user to #' unset single values if required, though this is intended to be rare. #' \code{unitizer} runs with the union of user options and the system versions #' described here. For \code{unitizer.opts.init}, any options set that are #' also present in \code{unitizer.opts.init.base} will overrule the base #' version. #' #' @section Display / Text Capture Options: #' #' These options control how \code{unitizer} displays data such as diffs, test #' results, etc. #' #' \itemize{ #' \item \code{unitizer.test.out.lines}: integer(2L), where first values is #' maximum number of lines of screen output to show for each test, and #' second value is the number of lines to show if there are more lines than #' allowed by the first value #' \item \code{unitizer.test.msg.lines}: like \code{unitizer.test.out.lines}, #' but for \code{stderr output} #' \item \code{unitizer.test.fail.context.lines}: integer(2L), used #' exclusively when comparing new to references tests when test faile; first #' values is maximum number of lines of context to show around a test, #' centered on differences if there are any, and second value is the number #' of context lines to show if using the first value is not sufficient to #' fully display the test results #' \item \code{unitizer.show.output}: TRUE or FALSE, whether to display test #' \code{stdout} and \code{stderr} output as it is evaluated. #' \item \code{unitizer.disable.capt}: logical(2L), not NA, with names #' \code{c("output", "message")} where each value indicates whether the #' corresponding stream should be captured or not. For \code{stdout} the #' stream is still captured but setting the value to FALSE tees it. #' \item \code{unitizer.max.capture.chars}: integer(1L) maximum number of #' characters to allow capture of per test #' \item \code{unitizer.color} whether to use ANSI color escape sequences, #' set to TRUE to force, FALSE to force off, or NULL to attempt to auto #' detect (based on code from package:crayon, thanks Gabor Csardi) #' \item \code{unitizer.use.diff} TRUE or FALSE, whether to use a diff of #' test errors (defaults to TRUE) #' } #' @section Misc Options: #' #' \itemize{ #' \item \code{unitizer.history.file} character(1L) location of file to use #' to store history of command entered by user in in interactive #' \code{unitizer} prompt; \code{""} is interpreted as tempfile() #' \item \code{unitizer.prompt.b4.quit.time} integer(1L) \code{unitizers} that #' take more seconds than this to evaluate will post a confirmation prompt #' before quitting; this is to avoid accidentally quitting after running a #' \code{unitizer} with many slow running tests and having to re-run them #' again. #' } #' #' @name unitizer.opts #' @rdname unitizer.opts #' @seealso \code{\link{unitizerState}} NULL .unitizer.opts.base <- list( add.smooth = TRUE, browserNLdisabled = FALSE, CBoundsCheck = FALSE, check.bounds = FALSE, citation.bibtex.max = 1, continue = "+ ", contrasts = structure( c("contr.treatment", "contr.poly"), .Names = c("unordered", "ordered") ), defaultPackages = c("datasets", "utils", "grDevices", "graphics", "stats", "methods"), demo.ask = "default", deparse.cutoff = 60L, device.ask.default = FALSE, digits = 7L, echo = TRUE, encoding = "native.enc", "NA" = NULL, example.ask = "default", expressions = 5000L, help.search.types = c("vignette", "demo", "help"), help.try.all.packages = FALSE, internet.info = 2, keep.source = TRUE, keep.source.pkgs = FALSE, locatorBell = TRUE, max.print = 99999L, na.action = "na.omit", nwarnings = 50L, OutDec = ".", prompt = "> ", repos = structure("http://cran.r-project.org", .Names = "CRAN"), rl_word_breaks = " \t\n\"\\'`><=%;,|&{()}", scipen = 0, show.coef.Pvalues = TRUE, show.error.messages = TRUE, show.signif.stars = TRUE, str = list(strict.width = "no", digits.d = 3, vec.len = 4), str.dendrogram.last = "`", timeout = 60, ts.eps = 1e-05, ts.S.compat = FALSE, useFancyQuotes = TRUE, verbose = FALSE, warn = 0, warning.length = 1000L, width = 80L ) if(getRversion() < '4.0') .unitizer.opts.base <- c(.unitizer.opts.base, list(stringsAsFactors=TRUE)) .unitizer.opts.asis <- c( "^browser$", "^device$", "^dvipscmd$", "^mailer$", "^pager$", "^pdfviewer$", "^pkgType$", "^printcmd$", "^HTTPUserAgent$", "^texi2dvi$", "^unzip$", "^editor$", "^papersize$", "^bitmapType$", "^menu\\.graphics$", "^unitizer\\." ) ## Need `covr` so tests run under it otherwise nasty stuff happens .unitizer.namespace.keep <- c("data.table", "crayon", "tools", "covr") .unitizer.base.packages <- c( "package:stats", "package:graphics", "package:grDevices", "package:utils", "package:datasets", "package:methods", "Autoloads", "package:base", ".GlobalEnv" ) #' Set Options to Initial Zero State #' #' @rdname options_extra #' @keywords internal options_zero <- function( base=merge_lists( getOption("unitizer.opts.init.base"), getOption("unitizer.opts.init") ), as.is=union( getOption("unitizer.opts.asis.base"), getOption("unitizer.opts.asis") ) ) { if( !is.list(base) || !is.character(nms <- attr(base, "names")) || length(nms) != length(base) || any(is.na(nms)) ) { stop("Option `unitizer.opts.init` must be a named list") } if(!is.character(as.is) || any(is.na(as.is))) stop("Option `unitizer.opts.asis` must be character and not contain NA") curr.opts <- options() curr.opts.nms <- names(curr.opts) curr.opts.asis <- unlist(lapply(as.is, grep, curr.opts.nms, value=TRUE)) # Drop unneeded options; need to do 1 by 1 as some options cannot be easily # reset null.opts <- setdiff(names(curr.opts), c(nms, curr.opts.asis)) all.opts <- c( setNames(vector("list", length(null.opts)), null.opts), base ) opt.success <- vapply(names(all.opts), function(opt.name) { opt.attempt <- try(options(all.opts[opt.name]), silent=TRUE) return(!inherits(opt.attempt, "try-error")) }, logical(1L) ) if(!all(opt.success)) { warning( word_wrap( cc( "Unable to reset following options: ", deparse(names(all.opts)[!opt.success], width.cutoff=500L) ) ) ) } # Reset others options(base) return(NULL) } #' Set Options to Specified State #' #' This makes sure to unset options not present in target. #' #' @rdname options_extra #' @keywords internal options_update <- function(tar.opts) { stopifnot(is.list(tar.opts), is.character(names(tar.opts))) cur.opts <- names(options()) to.rem <- setdiff(cur.opts, names(tar.opts)) to.rem.vec <- setNames(vector("list", length(to.rem)), to.rem) options(to.rem.vec) options(tar.opts) } .unitizer.opts.default <- list( # NULL means use the special unitizer environment unitizer.par.env=NULL, # Will display output/msg to stdout/stderr in addition to capturing it unitizer.show.output=FALSE, # Attempt to ANSI colorize output, TRUE to force, FALSE to force off, NULL to # auto-detect based on terminal capability unitizer.color=NULL, # TRUE will prevent capture of corresponding stream unitizer.disable.capt=c(output=FALSE, message=FALSE), # How many lines to display when showing test values, or truncate to if exceeds unitizer.test.out.lines=c(50L, 15L), # How many lines to display when showing test errors, or truncate to if exceeds unitizer.test.msg.lines=c(50L, 15L), # How many lines of context to display when showing failed objects # (note banner means one more line than this displayed) unitizer.test.fail.context.lines=c(10L, 3L), # If unitizer runs in fewer seconds than this and has no reviewed items, `Q` # will quit directly without prompting for review unitizer.prompt.b4.quit.time=10, # Maximum number of characters we allow capture of per test unitizer.max.capture.chars=200000L, unitizer.history.file="", # "" is interpreted as tempfile() # User specified objects to keep on search path; if you modify this make sure # you ajdust `unitizer.opts.asis` accordingly as well (see reproducible state # vignette) unitizer.search.path.keep=character(), # Default objects to keep on search path when initializing unitizer; unitizer.search.path.keep.base=c( .unitizer.base.packages, "tools:rstudio", "package:unitizer" ), unitizer.namespace.keep = character(), # names of namespaces not auto-unload # system namespaces not to auto-unload, no matter what unitizer.namespace.keep.base=c( .unitizer.namespace.keep ), # User default option values when running with options state tracking unitizer.opts.init=list(), # Default option values when running with options state tracking unitizer.opts.init.base=.unitizer.opts.base, # User specified options that should not be changed; these are matched as # regular expressions unitizer.opts.asis=character(0L), # Default options not to change; these are primarily system dependent and # other options; these are matched as regular expressions unitizer.opts.asis.base=.unitizer.opts.asis, # random seed to use by default, "Wichman-Hill" because default seed is large unitizer.seed= list(seed=42L, kind="Wichmann-Hill"), unitizer.max.env.depth=20000L, unitizer.use.diff=TRUE # unitizer.show.progress=TRUE, # can't be install time if we want interactive() ) #' Checks that options meet expectations before anything gets run #' @rdname options_extra #' @keywords internal validate_options <- function(opts.to.validate, test.files=NULL) { stopifnot( is.list(opts.to.validate), all(grep("^unitizer\\.", names(opts.to.validate))) ) # Check all option existence except those that can be NULL; note that we names.def <- setdiff( names(.unitizer.opts.default), c("unitizer.par.env", "unitizer.color", "unitizer.history.file") ) if(any(missing.opts <- !names.def %in% names(opts.to.validate))) stop( "The following options must be set in order for `unitizer` to work: ", deparse(names.def[missing.opts], width.cutoff=500L) ) # Now validate with( opts.to.validate, { if(!is.TF(unitizer.show.output)) stop("Option `unitizer.show.output` must be TRUE or FALSE") if(!is.TF(unitizer.use.diff)) stop("Option `unitizer.use.diff` must be TRUE or FALSE") if( exists("unitizer.color", inherits=FALSE) && !is.TF(unitizer.color) && !is.null(unitizer.color) ) stop("Option `unitizer.color` must be TRUE, FALSE, or NULL") if(!is.valid_capt_setting(unitizer.disable.capt)) stop("Option `unitizer.disable.capt` is invalid (see prior message)") if(!is.screen.out.vec(unitizer.test.out.lines)) stop( "Option `unitizer.test.out.lines` must be integer(2L), strictly ", "positive, not NA, with first value larger than second" ) if(!is.context.out.vec(unitizer.test.fail.context.lines)) stop( "Option `unitizer.test.fail.context.lines` must be integer(2L), ", "positive, not NA, with first value larger than second" ) if(!is.screen.out.vec(unitizer.test.msg.lines)) stop( "Option `unitizer.test.msg` must be integer(2L), strictly ", "positive, not NA, with first value larger than second" ) if( !is.numeric(unitizer.prompt.b4.quit.time) || length(unitizer.prompt.b4.quit.time) != 1L || is.na(unitizer.prompt.b4.quit.time) || unitizer.prompt.b4.quit.time < 0 ) stop( "Option `unitizer.prompt.b4.quit.time` must be numeric(1L), not NA, ", "and strictly positive" ) if( !is.integer(unitizer.max.capture.chars) || length(unitizer.max.capture.chars) != 1L || is.na(unitizer.max.capture.chars) || unitizer.max.capture.chars < 0 ) stop( "Option `unitizer.max.capture.chars` must be integer(1L), not NA, ", "and strictly positive" ) if( !is.character(unitizer.search.path.keep) || any(is.na(unitizer.search.path.keep)) ) stop("Option `unitizer.search.path.keep` must be character and not NA") if( !is.character(unitizer.search.path.keep.base) || any(is.na(unitizer.search.path.keep.base)) ) stop("Option `unitizer.search.path.keep.base` must be character and not NA") if( !is.character(unitizer.namespace.keep) || any(is.na(unitizer.namespace.keep)) ) stop("Option `unitizer.namespace.keep` must be character and not NA") if( !is.character(unitizer.namespace.keep.base) || any(is.na(unitizer.namespace.keep.base)) ) stop("Option `unitizer.namespace.keep.base` must be character and not NA") if(!is.list(unitizer.opts.init)) stop("Option `unitizer.opts.init` must be a list") if(!is.list(unitizer.opts.init.base)) stop("Option `unitizer.opts.init.base` must be a list") if(!is.character(unitizer.opts.asis) || any(is.na(unitizer.opts.asis))) stop("Option `unitizer.opts.asis` must be character and not NA") if( !is.character(unitizer.opts.asis.base) || any(is.na(unitizer.opts.asis.base)) ) stop("Option `unitizer.opts.asis.base` must be character and not NA") # note, more specific validation done in is.valid_rep_state if(!is.list(unitizer.seed)) stop("Option `unitizer.seed` must be a list") } ) if( # needs to be outside b/c var may not be defined in option list !is.null(opts.to.validate[["unitizer.par.env"]]) && !is.environment(opts.to.validate[["unitizer.par.env"]]) ) stop("Option `unitizer.par.env` must be an environment or NULL") if( # needs to be outside b/c var may not be defined in option list !is.null(opts.to.validate[["unitizer.state"]]) && !is( try( as.state(opts.to.validate[["unitizer.state"]], test.files) ), "unitizerState" ) ) stop("Option `unitizer.state` is invalid; see prior errors") if( !is.chr1(opts.to.validate[["unitizer.history.file"]]) && !is.null(opts.to.validate[["unitizer.history.file"]]) ) stop( "Option `unitizer.history.file` must be character(1L) and not NA, ", " or NULL" ) # NULL options that should be changed if(is.null(opts.to.validate[["unitizer.color"]])) { opts.to.validate[["unitizer.color"]] <- isTRUE(try(crayon::has_color(), silent=TRUE)) } opts.to.validate } unitizer/R/unitizer.R0000644000176200001440000006771314766101401014336 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R #' @include item.sub.R #' @include section.R #' @include test.R #' @include change.R #' @include global.R NULL .unitizer.tests.levels <- c("Pass", "Fail", "New", "Deleted", "Error") # Allow us to find a specific test based on deparse call and id # # @param call deparsed call, if NA means just start with first test, the NA case # is used to bookmark the entire unitizer when multiple unitizers are being # reviewed. # @param id used to disambiguate a specific call when multiple ones match in a # single unitizer. # @param parse.mod indicates whether the parse is not the same as it was when # the bookmark was set, which indicates the bookmark may not be correct any # more. This is set by comparing the old parsed expressions for the unitizer # to the new ones after re-load. setClass("unitizerBrowseBookmark", slots=c(call="character", id="integer", parse.mod="logical"), prototype=list(call="", id=0L, parse.mod=FALSE), validity=function(object) { if(!is.character(object@call) || length(object@call) != 1L) return("Slot `@call` must be character(1L)") if(!length(object@id) == 1L || object@id < 0L) return("Slot `@id` must be integer(1L) and positive") if(!is.TF(object@parse.mod)) return("Slot `@parse.mode` must be TRUE or FALSE") } ) setClassUnion( "unitizerBrowseBookmarkOrNULL", c("unitizerBrowseBookmark", "NULL") ) # Contains All The Data for Our Tests! # # Generally is populated through the \code{+} methods, with the exception of # \code{items.ref}, which is added on creation. I guess ideally all would be # done through different \code{+} methods, but that would complicate the # process a bit as that would require being able to distinguish between # reference item lists and new item lists (and the latter should never really # be added as that should happen item by item). Maybe some day this will be # cleaned up. # # One of the challenges when maintaining this is the tension between wanting to # keep all the item/test data in sub-objects, and the difficulty in extracting # summary data across all items/tests in that structure. As a result of this, # a compromise solution has been to extract some of the relevant meta data # into vectors/matrices available at the top level (e.g. the @@tests.* # objects). # # Ultimately, we need far more specialized accessor functions that don't # require understanding what those meta data mean exactly, and how they need # to be used. An example is the \code{ignored} function. # # Things get particularly complicated with the \code{browse} objects, which # basically rehash a lot of this data, but split into groups and sub-groups, # and at this point with meta-data stored in a \code{unitizerBrowseMapping} # object that replicates the role of the aforementioned @@tests.* objects in # \code{unitizer}. # # @keywords internal # @slot id the identifier for the unitizer, typically a file name, but can be # anything # @slot items.new a list of all the tests in the new file # @slot items.ref a list of all the previously saved tests # @slot items.new.map a vector that maps the entries in \code{items.new} to # those in \code{items.ref}, where position in vector is id/position in # slot \code{items.new}, and value is id/position in \code{items.ref} # new items will show up as NA here # @slot items.new.calls.deparse a character vector of the deparsed calls in # \code{items.new} # @slot items.new.calls.deparse.id integer() tracks what instance of a # particular deparse string this is to allow us to disambiguate duplicate tests # (e.g. for bookmarks). Should auto-increment. # @slot items.envs contains the environments for each call # @slot tests.fail vector highlighting which tests failed # @slot tests.new vector highlighting which tests did not exist in reference # @slot test.status a vector that contains the result of the test ("pass", # "fail", "new", "indeterminable") # for every item in \code{items.new} # @slot tests.result a logical matrix with a row for each item in # \code{items.new} where each column represents the result of each sub tests # @slot tests.errorDetails an S4 object with a slot for each sub test, where # the slot contains a \code{\link{unitizerItemTestError-class}} object # either NULL or a character vector describing the test failure reason for # every item in \code{items.new} # @slot items.ref.calls.deparse like \code{items.new.calls.deparse}, but for # the reference items # @slot items.ref.map maps reference items to the new items; deleted items will # show up as NA here, where position in vector is id/position in slot # \code{items.ref}, and value is id/position in \code{items.new} # @slot sections a list of \code{\link{unitizerSection-class}} # @slot section.map a map of every item in \code{items.new} to a section # @slot changes contains summary data on the test results # @slot upgraded.from character(1L) whether the unitizer was upgraded from load # and from what version, "" if it was not upgraded. # @slot best.name character(1L) a friendlier name derived from test and unitizer # locations. # @slot show.progress integer(1L) level of chattiness in progress reporting, # carried here as otherwise no way to feed it through the `+` method when # adding tests. # @slot transcript logical(1L) TRUE or FALSE whether to operate in transcript # mode. setClass( "unitizer", representation( id="ANY", version="character", # should really be 'package_version', but want to avoid setOldClass, so use `as.character(packageVersion())` to populate zero.env="environment", # keep functions and stuff here base.env="environment", test.file.loc="character", # location of test file that produced `unitizer` # internal used during browsing to determine a re-eval instruction by user eval="logical", # eval time for all tests in `unitizer`, computed in # `+.unitizer.unitizerTestsOrExpression` eval.time="numeric", updated="logical", # unitizer has been queued for update # should reflect whether a unitizer was modified at least once so that we # can report this in return values updated.at.least.once="logical", global="unitizerGlobalOrNULL", # Global object used to track state items.new="unitizerItems", # Should all be same length items.new.map="integer", items.new.calls.deparse="character", items.new.calls.deparse.id="integer", items.envs="list", tests.fail="logical", # really need tests.fail? tests.error="logical", # really need tests.error? redundant with tests.result tests.new="logical", tests.status="factor", # pass/fail/error/new tests.result="matrix", tests.errorDetails="unitizerItemsTestsErrors", tests.conditions.new="logical", # Whether the test produced new conditions, used to check whether we need to display conditions on ignored tests items.ref="unitizerItems", # Should all be same length items.ref.calls.deparse="character", items.ref.map="integer", sections="list", section.map="integer", section.parent="integer", # same length as sections, for each section links to parent, where parent is the outermost section a section is nested within # Note, all section references for ref objects are parent sections since # when we browse we don't track nested sections. Usage of @section.ref.map # is a bit overloaded; we first try to re-assign any reference sections to # new sections if possible, and if not assign them NA; subsequently, before # we store the updated `unitizer`, we transfer all the newly generated # section info for the new reference tests here, so need to be careful about # how we interpret this. We should clean this up at some point sections.ref="list", section.ref.map="integer", # "compressed" versions of the tracking data in @global state.new="unitizerGlobalTrackingStore", state.ref="unitizerGlobalTrackingStore", changes="unitizerChanges", # Summary of user changes res.data="data.frameOrNULL", # details of test evaluation and user review bookmark="unitizerBrowseBookmarkOrNULL", # used for re-eval navigation # fields to support >1.4.14 functionality upgraded.from="character", # was upgraded on load best.name="character", show.progress="integer", transcript="logical" ), prototype( version=as.character(packageVersion("unitizer")), tests.status=factor(levels=.unitizer.tests.levels), base.env=baseenv(), zero.env=baseenv(), test.file.loc=NA_character_, eval=FALSE, eval.time=0, updated=FALSE, updated.at.least.once=FALSE, bookmark=NULL, global=unitizerGlobal$new(enable.which=character()), # dummy so tests will run upgraded.from="", show.progress=0L, transcript=FALSE ), validity=function(object) { if(!is.object(object@id) && is.character(object@id)) { # default id format # # No guarantees store id actually exists, so not enforcing this check # if( # !file_test("-d", dirname(object@id)) || # !identical(dirname(object@id), normalize_path(dirname(object@id))) # ) { # return( # paste0( # "slot `id` must be a properly normalized directory when using ", # "default `unitizer` stores." # ) ) # } } if( !identical(length(object@eval.time), 1L) || is.na(object@eval.time) || object@eval.time < 0L ) return("slot `eval.time` must be length 1L, positive, and not NA") if(!is.TF(object@updated.at.least.once)) return("slot `updated.at.least.once` must be TRUE or FALSE") if(!is.TF(object@updated)) return("slot `updated` must be TRUE or FALSE") TRUE } ) setClass( "unitizerSummary", slots=c(data="matrix", dels="integer", totals="integer"), validity=function(object) { if( !is.integer(object@data) || !all(colnames(object@data) %in% .unitizer.tests.levels) ) return( paste0( "Slot `data` must be an integer matrix with colnames %in% ", deparse(val.names) ) ) if(length(object@dels) != 1L) return("Slot `dels` must be integer length one") if(!all(names(object@totals) %in% .unitizer.tests.levels)) return( paste0( "Slot `totals` must be integer with names ", deparse(c(val.names)) ) ) TRUE } ) setClass( "unitizerObjectList", contains="unitizerList", validity=function(object) { if( !all( vapply( object@.items, function(x) is(x, "unitizer") || is(x, "unitizerLoadFail"), logical(1L)) ) ) return( "slot `.items` may only contain \"unitizer\" or \"unitizerLoadFail\" ", "objects." ) TRUE } ) setClass( "unitizerObjectListSummary", contains="unitizerList", slots=c(test.files="character", totals="integer", updated="logical"), validity=function(object) { if(!all(vapply(object@.items, is, logical(1L), "unitizerSummary"))) return("slot `.items` may only contain \"unitizerSummary\" objects") if(length(object@.items) != length(object@test.files)) return("slot `.items` and slot `test.files` must be same length") if(length(object@.items) != length(object@updated)) return("slot `.items` and slot `updated` must be same length") TRUE } ) # - Methods ------------------------------------------------------------------- # Display Unitizer Summary # # Unfortunately no choice but to use \code{getOptions("width")} from within # here. Maybe could pre-compute in one of earlier stages and stuff into # \code{object}? Not a big deal # # @keywords internal # @param object the object to show # @return NULL #' @rdname unitizer_s4method_doc setMethod("show", "unitizerSummary", function(object) { sum.mx <- object@data rownames(sum.mx) <- strtrunc(rownames(sum.mx), 80L) cat( summ_matrix_to_text(sum.mx, show.nums=FALSE), "", sep="\n" ) invisible(NULL) } ) # Determine if a \code{unitizer} Passed Based On Summary # # @keywords internal # @param object object to test for passing # @return logical(1L) setGeneric("passed", function(object, ...) standardGeneric("passed")) setMethod("passed", "unitizerSummary", function(object, ...) !as.logical(sum(object@totals[-1L])) ) #' @rdname unitizer_s4method_doc setMethod("initialize", "unitizer", function(.Object, ...) { .Object <- callNextMethod() .Object@tests.result <- tests_result_mat(0L) # Re-use assigned @base.env if it isn't the baseenv(), since that means # user provided a base env. in theory this should be a base.env that # already has for parent the `zero.env` because we're trying to recreate the # same environment chain of a different unitizer for when we re-use a # unitizer in unitize_dir if(identical(.Object@base.env, baseenv())) .Object@base.env <- new.env() parent.env(.Object@base.env) <- .Object@zero.env parent.env(.Object@items.new@base.env) <- .Object@base.env parent.env(.Object@items.ref@base.env) <- .Object@base.env .Object } ) # Compute Length of a \code{\link{unitizer-class}} Object #' @rdname unitizer_s4method_doc setMethod("length", "unitizer", function(x) { len.vec <- unique( c( length(x@items.new), length(x@items.new.map), length(x@items.new.calls.deparse) ) ) if(length(len.vec) != 1L) stop( "Inconsistent sub-object length; should not happen; contact maintainer." ) len.vec } ) # Summarize Results # # Also prints to screen, but only if \code{level == 1L} # # @param object the object to summarize # @param silent whether to suppress display of summary object # @return a unitizerSummary object # @keywords internal #' @rdname unitizer_s4method_doc setMethod("summary", "unitizer", function(object, silent=FALSE, ...) { if(!isTRUE(silent) && !identical(silent, FALSE)) stop("Argument `silent` must be TRUE or FALSE") ignore <- ignored(object@items.new) deleted <- which(!ignored(object@items.ref) & is.na(object@items.ref.map)) status <- factor( c( as.character(object@tests.status[!ignore]), rep("Deleted", length(deleted)) ), levels=levels(object@tests.status) ) sec.ids <- object@section.parent[ c(object@section.map[!ignore], object@section.ref.map[deleted]) ] sec.unk <- "" sections <- vapply( sec.ids, function(idx) if(is.na(idx)) sec.unk else object@sections[[idx]]@title, character(1L) ) sections.levels <- unique(sections[order(sec.ids)]) sum.mx <- tapply( rep(1L, length(status)), list(factor(sections, levels=sections.levels), status), sum ) # this should be a matrix with the summary data. sum.mx[is.na(sum.mx)] <- 0L total <- apply(sum.mx, 2, sum) # truly empty test file corner case if(!nrow(sum.mx)) { if(!length(status)) { cols <- length(levels(status)) sum.mx <- matrix( integer(cols), nrow=1L, dimnames=list(sec.unk, colnames(sum.mx)) ) } else { # nocov start stop( "Internal Error: should not have statuses reported with no ", "sections; contact maintainer." ) # nocov end } } obj <- new("unitizerSummary", data=sum.mx, dels=length(deleted), totals=total) if(!silent) show(obj) obj } ) # Summary method #' @rdname unitizer_s4method_doc setMethod("summary", "unitizerObjectList", function(object, silent=FALSE, ...) { # Now get summaries and loop through them obj.list <- as.list(object) summaries <- lapply(obj.list, summary, silent=TRUE) test.files <- vapply(obj.list, slot, character(1L), "test.file.loc") updated <- vapply(obj.list, slot, logical(1L), "updated") if(length(summaries)) { # get aggregate results across all summaries totals <- Reduce(`+`, lapply(as.list(summaries), slot, "totals")) } else totals <- integer() res <- new( "unitizerObjectListSummary", .items=summaries, test.files=test.files, totals=totals, updated=updated ) if(!silent) show(res) res } ) # Display method #' @rdname unitizer_s4method_doc setMethod("show", "unitizerObjectListSummary", function(object) { test.len <- length(object) if(!test.len) return(invisible(NULL)) scr.width <- getOption("width") test.files.trim <- col.names <- fmt <- test.nums <- NA_character_ # Adjust paths so we need only show their common part, and then get the # full name of the directory that they correspond to (as much as possible # anyway) test.files.trim <- unique_path(object@test.files) full.dir <- attr(test.files.trim, "common_dir") # Ignore any columns with zero totals other than pass/fail review.req <- !vapply(as.list(object), passed, logical(1L)) # Display; if updated, mark with `NA` as we don't know what the deal is # until we re-run the tests totals <- t(vapply(as.list(object), slot, object[[1L]]@totals, "totals")) rownames(totals) <- test.files.trim totals[object@updated, ] <- NA_integer_ disp <- summ_matrix_to_text(totals, from="left") # Post processing for(j in seq_along(disp)) { i <- j - 1L if(!i) next else if(i > nrow(totals)) break disp[[j]] <- if(object@updated[[i]]) { sub("^(\\s*) (\\d+\\.)", "\\1$\\2", disp[[j]]) } else if(review.req[[i]]) { sub("^(\\s*) (\\d+\\.)", "\\1*\\2", disp[[j]]) } else disp[[j]] } meta_word_cat( "Summary of files in common directory '", relativize_path(full.dir), "':\n\n", sep="", trail.nl=FALSE ) meta_word_cat(disp, "", trail.nl=FALSE) # Legends if(any(review.req | object@updated)) meta_word_cat("Legend:", trail.nl=FALSE) if(any(review.req & !object@updated)) meta_word_cat("* `unitizer` requires review", trail.nl=FALSE) if(any(object@updated)) meta_word_cat( "$ `unitizer` has been modified and needs to be re-run to", "recompute summary", sep=" ", trail.nl=FALSE ) cat("\n") invisible(NULL) } ) setGeneric( "registerItem", function(e1, e2, ...) standardGeneric("registerItem") ) # Helper Methods for Adding Items to \code{\link{unitizer-class}} Object # # @aliases testItem,unitizer,unitizerItem-method # @seealso \code{\link{+,unitizer,unitizerItem-method}} # @keywords internal setMethod("registerItem", c("unitizer", "unitizerItem"), function(e1, e2, ...) { item.new <- e2 if(identical(length(e1@items.new), 0L)) e1@items.new@base.env <- parent.env(item.new@env) item.new@id <- length(e1@items.new) + 1L e1@items.new <- e1@items.new + item.new e1@items.new.calls.deparse <- c(e1@items.new.calls.deparse, call.dep <- item.new@call.dep) e1@items.new.calls.deparse.id <- c( e1@items.new.calls.deparse.id, sum(e1@items.new.calls.deparse == call.dep) ) if(length(e1@items.new.map) > 0L) { idx.vec <- seq_along(e1@items.ref.calls.deparse) items.already.matched <- e1@items.new.map[!is.na(e1@items.new.map)] items.already.matched.vec <- if(!length(items.already.matched)) TRUE else -items.already.matched item.map <- match(call.dep, e1@items.ref.calls.deparse[items.already.matched.vec]) e1@items.new.map <- c( e1@items.new.map, item.map <- idx.vec[items.already.matched.vec][item.map] ) } else { e1@items.new.map <- c( e1@items.new.map, item.map <- match(call.dep, e1@items.ref.calls.deparse) ) } e1 } ) setGeneric("testItem", function(e1, e2, ...) standardGeneric("testItem")) setMethod("testItem", c("unitizer", "unitizerItem"), function(e1, e2, ...) { item.new <- e2 slot.names <- unitizerItemDataSlots test.result.tpl <- tests_result_mat(1L) test.error.tpl <- vector("list", length(slot.names)) names(test.error.tpl) <- slot.names item.map <- tail(e1@items.new.map, 1L) tests.conditions.new <- FALSE if(is.na(item.map)) { test.status <- "New" e1@tests.fail <- c(e1@tests.fail, FALSE) e1@tests.error <- c(e1@tests.error, FALSE) e1@tests.new <- c(e1@tests.new, TRUE) e1@tests.result <- rbind(e1@tests.result, test.result.tpl) # A new test with conditions by definition has new conditions if(length(item.new@data@conditions)) tests.conditions.new <- TRUE } else { e1@items.ref.map[[item.map]] <- length(e1@items.new) item.ref <- e1@items.ref[[item.map]] # this should be initialized properly, and con probably be corrupted # pretty easily section <- e1@sections[[e1@section.map[[length(e1@items.new)]]]] # Test functions and the data to test is organized in objects with # the exact same structure as item.new@data, so cycle through the slots. # Status is always "Error" if something indeterminable happens, # if not and a failure happens, then it is "Fail", and if nothing goes # wrong for any of the slots, it is "Pass" (there is only one status for # all slots) test.status <- "Pass" test.result <- test.result.tpl if(nrow(test.result) != 1L) # nocov start stop("Internal Error: tpl matrix should be one row; contact maintainer.") # nocov end get_dat <- function(x, i) { dat <- if(identical(i, "value")) slot(x, i)[[1L]] else slot(x, i) if(is.call(dat) || is.symbol(dat)) call("quote", dat) else dat } for(i in slot.names) { comp.fun.name <- slot(section@compare, i)@fun.name comp.fun.anon <- isTRUE(is.na(comp.fun.name)) if(comp.fun.anon) comp.fun.name <- "" item.new.dat <- get_dat(item.new@data, i) item.ref.dat <- get_dat(item.ref@data, i) if(comp.fun.anon) { test.call <- list( # pull out and use compare function slot(section@compare, i)@fun, item.ref.dat, item.new.dat ) mode(test.call) <- "call" } else { test.call <- call( # pull out and use compare function comp.fun.name, item.ref.dat, item.new.dat ) } # this is a bit roundabout b/c we added this hack in long after the # code was initially written; note we don't use `global` here b/c # we don't need to track state during comparison (but what happens # if user comparison function changes state??) # # We also don't use eval_with_capture which would be a natural thing to # do because that is slow. We just keep writing to the dump file and # then will get rid of it at the end. One possible issue here is that # we no longer detect sink issues caused by user possibly changing sinks # in the comparison function. sink(file=e1@global$cons@dump.c, append=TRUE) sink(type="message", file=e1@global$cons@dump.c, append=TRUE) on.exit({ # nocov start emergency only sink(type="message") sink() # nocov end }) res.tmp <- eval_user_exp( test.call, e2@env, global=NULL, with.display=FALSE ) on.exit(NULL) sink(type="message") sink() cond <- res.tmp$conditions test.res <- if(length(cond)) { structure( list( msg=conditionMessage(cond[[1L]]), call=conditionCall(cond[[1L]]), cond.class=class(cond[[1L]]) ), class=c("testItemTestFail") ) } else { test.res <- res.tmp$value } if(isTRUE(test.res)) { test.result[1L, i] <- TRUE next } # Comparison failed err.tpl <- new( "unitizerItemTestError", .new=item.new.dat, .ref=item.ref.dat ) err.msg <- paste0("comparison function `", comp.fun.name, "`") if(inherits(test.res, "testItemTestFail")) { test.status <- "Error" test.cond <- test.res$cond.class if(!length(test.cond)) test.cond <- "" err.tpl@value <- paste0( err.msg, " signaled a condition of class `", deparse(test.cond, width.cutoff=500), "`", ", with message \"", test.res$msg, "\" and call `", paste0(deparse(test.res$call), collapse=""), "`." ) err.tpl@compare.err <- TRUE } else if(is.character(test.res)) { if(identical(test.status, "Pass")) test.status <- "Fail" err.tpl@value <- test.res } else if(identical(test.res, FALSE)) { test.status <- "Fail" err.tpl@value <- "" } else { test.status <- "Error" err.tpl@value <- paste0( err.msg, " returned something other than TRUE, FALSE, or character vector ", sprintf("(%s of length %d)", typeof(test.res), length(test.res)) ) err.tpl@compare.err <- TRUE } test.error.tpl[[i]] <- err.tpl if(identical(i, "conditions")) { #only failed/error tests get this far # if a mismatch, and new conditions, we'll want to show these if(length(item.new@data@conditions)) tests.conditions.new <- TRUE } } e1@tests.result <- rbind(e1@tests.result, test.result) e1@tests.new <- c(e1@tests.new, FALSE) if(!all(test.result)) { if(identical(test.status, "Fail")) { e1@tests.fail <- append(e1@tests.fail, TRUE) e1@tests.error <- append(e1@tests.error, FALSE) } else if(identical(test.status, "Error")) { e1@tests.fail <- append(e1@tests.fail, FALSE) e1@tests.error <- append(e1@tests.error, TRUE) } else { # nocov start stop("Internal Error: impossible test status; contact maintainer.") # nocov end } } else { e1@tests.fail <- append(e1@tests.fail, FALSE) e1@tests.error <- append(e1@tests.error, FALSE) } } # so added irrespective of pass/fail e1@tests.conditions.new <- c(e1@tests.conditions.new, tests.conditions.new) if(length(e1@tests.status)) { e1@tests.status <- unlist( list( e1@tests.status, factor(test.status, levels=levels(e1@tests.status)) ) ) } else { e1@tests.status <- factor(test.status, levels=levels(e1@tests.status)) } e1 <- e1 + do.call(new, c(list("unitizerItemTestsErrors"), test.error.tpl)) e1 } ) setGeneric("getTarget", function(object, ...) standardGeneric("getTarget")) setGeneric("getName", function(object, ...) standardGeneric("getName")) # Create A Human Readable Names for a \code{unitizer} # # @keywords internal # @param object a unitizer # @return character(1L) a descriptive name setMethod("getTarget", "unitizer", function(object, ...) { id <- try(object@id, silent=TRUE) if(inherits(id, "try-error")) { return("") } relativize_path(as.store_id_chr(id)) } ) # @rdname getTarget,unitizer-method setMethod("getName", "unitizer", function(object, ...) { f.name <- try(object@test.file.loc, silent=TRUE) if( inherits(f.name, "try-error") || !is.chr1plain(f.name) || is.na(f.name) ) { return(getTarget(object)) } relativize_path(f.name) } ) #' @rdname unitizer_s4method_doc setMethod("as.character", "unitizer", function(x, ...) { name <- try(getName(x)) name.fin <- if(inherits(name, "try-error")) "" else name sprintf("unitizer for '%s'", pretty_path(name)) } ) unitizer/R/misc.R0000644000176200001440000003336614766101401013415 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Retrieves Environment Ancestry # # @keywords internal # @param env the environment to start with # @param stop.env the environment to stop with env_ancestry <- function(env, stop.env=globalenv()) { if(!is.environment(env) || !is.environment(stop.env)) stop("Arguments `env` and `stop.env` must both be environments") out <- character() repeat { out <- c(out, env_name(env)) if(identical(env, stop.env)) break if(identical(env, emptyenv())) stop("Hit empty environment while traveling up environment ancestry") env <- parent.env(env) } out } # Gets Environment Name / Memory Code # # Captures the name that \code{`\link{print.default}`} displays when one # prints and environment # # @keywords internal # @param env an environemnt # @return character 1 length env_name <- function(env) { if(!is.environment(env)) stop("Argument `env` must be an environment") sub("", "\\1", capture.output(print.default(env))[[1]]) } # Functions To Ignore # # DEPRECATED. Now handled by visibility status. # # Ignored functions are not considered tests if they are called from # the top level. # # Also, provide a function to compare functions even when traced. # # @keywords internal # @param x the reference function, if is traced then y must be identical # @param y the current function, if \code{`x`} is not traced and \code{`y`} # is traced, will compare using \code{`y@@original`} instead of \code{`y`} funs.ignore <- list(base::`<-`, base::library, base::`=`, base::set.seed) identical_fun <- function(x, y) { if(!is.function(x) || !is.function(y)) stop("Arguments `x` and `y` must both be functions.") if(is(x, "functionWithTrace")) { return(identical(x, y)) } else if(is(y, "functionWithTrace")) { return(identical(x, y@original)) } identical(x, y) } ## Overrides Default quit() Behavior ## ## Necessary because quit short circuits the \code{on.exit} clean-up functions ## and would leave stuff in a weird state (history not reset, etc.). ## ## This is used in \code{\link{unitize}}. ## ## @keywords internal unitizer_quit <- function( save = "default", status = 0, runLast = TRUE, truly.quit=TRUE ) { meta_word_msg( "You are attempting to quit R from within `unitizer`. If you do so ", "you will lose any unsaved `unitizers`. Use `Q` to quit `unitizer` ", "gracefully. Are you sure you want to exit R?" ) quit.count <- 5 while( !(res <- head(tolower(read_line("Quit R? [y/n]: ")), 1L)) %in% c("y", "n") ) { quit.count <- quit.count - 1L if(quit.count < 0) { meta_word_msg("Sorry, could not understand you, quitting then.") res <- "y" break; } } if(res == "y" && truly.quit) { quit(save=save, status=status, runLast=runLast) # nocov } else if (res == "y") TRUE else FALSE } # Cleans a Path to be In Standard Format # # Uses \code{`\link{dirname}`} to convert paths on windows machines with back # slasshes to forward slash based names, and then removed excess forward # slashes. # # @keywords internal # @param path character the path name to clean up # @return the cleaned up path path_clean <- function(path) { if(!is.character(path)) stop("Argument `path` must be character") path.norm <- paste0(dirname(path), "/", basename(path)) sub("/+", "/", path.norm) } #' Create a Store ID from a Test File Name #' #' @param x character(1L) file name ending in .r or .R #' @return store id name, or NULL if \code{x} doesn't meet expectations #' @export #' @examples #' filename_to_storeid(file.path("tests", "unitizer", "foo.R")) #' filename_to_storeid(file.path("tests", "unitizer", "boo.r")) #' # does not end in [rR] #' filename_to_storeid(file.path("tests", "unitizer", "boo")) filename_to_storeid <- function(x) { if(is.character(x) && length(x) == 1L){ r.regex <- "\\.[rR]$" if((y <- sub(r.regex, ".unitizer", x)) != x) return(y) warning( "Unable to translate file name '", x, "' to `store.id` because ", "it does not match regex '", r.regex, "', please provide explicit ", "`store.id` or rename to end in '.R'. Returning in NULL for ", "`store.id`." ) } else warning( "Unable to generate store id from non `character(1L)` file \"name\"" ) NULL } # History Management Funs # # @keywords internal history_capt <- function(hist.file=NULL, interactive.mode) { # set up local history if(is.null(hist.file)) return(list(con=NULL, file=NULL)) # nocov start if(!interactive()) { if(!interactive.mode) { warning( "Unable to capture history in non-interactive mode.", immediate.=TRUE ) } return(list(con=NULL, file=NULL)) } hist.try <- try(savehistory(), silent=TRUE) if(inherits(hist.try, "try-error")) warning(conditionMessage(attr(hist.try, "condition"))) hist.con <- try(file(hist.file, "at")) if(inherits(hist.con, "try-error")) stop("Unable to open a connection to file provided for history") cat( "## (original history will be restored on exit)\n", file=hist.con ) hist.try <- try( loadhistory(showConnections()[as.character(hist.con), "description"]), silent=TRUE ) if(inherits(hist.try, "try-error")) { warning(conditionMessage(attr(hist.try, "condition"))) attr(hist.con, "no.hist") <- TRUE } list(con=hist.con, file=hist.file) # nocov end } history_release <- function(hist.obj) { if(all(vapply(hist.obj, is.null, logical(1L)))) return(invisible(TRUE)) # nocov start no.hist <- attr(hist.obj$con, "no.hist") close(hist.obj$con) if(isTRUE(attr(hist.obj$file, "hist.tmp"))) file.remove(hist.obj$file) if(!isTRUE(no.hist)) { # covr runs non-interactively; can't have history hist.try <- try(loadhistory(), silent=TRUE) if(inherits(hist.try, "try-error")) warning(conditionMessage(attr(hist.try, "condition"))) } # nocov end } history_write <- function(hist.con, data) { if(is.null(hist.con)) return(invisible(NULL)) # probably in non-interactive # nocov start stopifnot(inherits(hist.con, 'connection'), is.character(data)) if(isOpen(hist.con)) { cat(data, file=hist.con, sep="\n") if(!isTRUE(attr(hist.con, "no.hist"))) { hist.save <- try(loadhistory(summary(hist.con)$description), silent=TRUE) if(inherits(hist.save, "try-error")) warning(attr(hist.save, "condition"), immediate.=TRUE) } } # nocov end } ## Variation on 'normalizePath' with \code{winslash} Pre-Specified, additionally ## will only return the normalized path if the path actually exists, if not it ## just returns the input. ## ## Note, for a file that doesn't exist, normalizePath may (windows?) or not (OS ## X) prepend the working directory. ## ## @param exists check whether the expanded path actually exists, and if it does ## not return the original path. Set to TRUE for consistent behavior across ## platforms. normalize_path <- function(path, mustWork=NA, exists=FALSE) { res <- normalizePath(path, winslash=.Platform$file.sep, mustWork=mustWork) if(isTRUE(mustWork) || exists) { res.exists <- file.exists(res) res[!res.exists] <- path[!res.exists] } res } # Simplify a Path As Much as Possible to Working Directory # # \itemize{ # \item \code{relativize_path} returns a path that can actually be used # to access an actual file from the current working directory # \item \code{pretty_path} returns the most readable path that we can # produce, but may not usable to access an actual file, main difference with # \code{relativize_path} is that it will figure out if a file is in a # package and return a path relative to the package directory if it turns # out that one is shorter than the one produced with relativize path # \item \code{unique_path} is used to separate out a common path from a list # of files, the unique paths are returned as a value, with the common # directory attached as an attribute # } # # There are many types of windows paths that may not be handled correctly. # # https://docs.microsoft.com/en-us/dotnet/standard/io/file-path-formats # # A big problem is if we try to combine a drive letter path "d:/a/b/c" with an # absolute path relative to the drive "/a/b/c". In theory the code isn't # difficult; we could analyze the two paths and per windows rules we know we can # just add the working directory letter to the path, but then the testing of it # becomes annoying (essentially need to reproduce this functions code in the # test proper, which becomes silly). So we're just not testing that scenario. # # @param wd NULL or character(1L) resolving to a directory, if NULL will be # resolved to \code{getwd}; used primarily for testing # @param only.if.shorter logical(1L) whether to relativize only if the # resulting \code{path} is shorter than the input # @keywords internal relativize_path <- function(path, wd=NULL, only.if.shorter=TRUE, exists=FALSE) { if(!is.character(path) || any(is.na(path))) stop("Argument `path` must be character and may not contain NAs") if(!is.TF(only.if.shorter)) stop("Argument `only.if.shorter` must be TRUE or FALSE") if( !is.null(wd) && !is.character(wd) && !identical(length(wd), 1L) && !file_test("-d", wd) ) stop("Argument `wd` must be NULL or a reference of to a directory") if(is.null(wd)) wd <- getwd() wd <- try(normalize_path(wd, mustWork=TRUE, exists=exists), silent=TRUE) res <- if( !inherits(wd, "try-error") && is.character(.Platform$file.sep) && identical(length(.Platform$file.sep), 1L) ) { norm <- normalize_path(path, mustWork=FALSE, exists=exists) to.norm <- TRUE # used to be only for existing files, but can't recall why # Break up into pieces; we re-append "" to make sure the root shows up if # appropriate path.pieces <- lapply( strsplit(norm[to.norm], .Platform$file.sep, fixed=TRUE), function(x) c("", Filter(x, f=nchar)) ) wd.pieces <- c("", Filter( nchar, unlist(strsplit(wd, .Platform$file.sep, fixed=TRUE)) ) ) # /a/b/c/d/e # /a/b/c/F/G reled <- vapply( path.pieces, function(x) { up.to <- min(length(x), length(wd.pieces)) if(!up.to) return(x) first.diff <- min(up.to + 1L, which(x[1:up.to] != wd.pieces[1:up.to])) - 1L path <- if(identical(first.diff, 0L)) { x } else { end <- min(up.to, first.diff) c(rep("..", length(wd.pieces) - end), x[-(1:end)]) } if(length(path)) do.call(file.path, as.list(path)) else "" }, character(1L) ) norm[to.norm] <- reled norm } else path res[!nzchar(res)] <- "." if(only.if.shorter) { ifelse(nchar(res) < nchar(path), res, path) } else res } pretty_path <- function(path, wd=NULL, only.if.shorter=TRUE) { path.norm <- normalize_path(path, mustWork=FALSE, exists=TRUE) rel.path <- relativize_path(path.norm, wd, only.if.shorter, exists=TRUE) pkg.dir <- get_package_dir(path.norm) if( !length(pkg.dir) || !identical(substr(path.norm, 1L, nchar(pkg.dir)), pkg.dir) ) return(rel.path) pkg.name <- try(get_package_name(pkg.dir)) if(inherits(pkg.name, "try-error")) { # nocov start stop("Internal Error: failed getting package name; contact maintainer") # nocov end } pkg.path <- file.path( paste0("package:", pkg.name), substr(path.norm, nchar(pkg.dir) + 2L, nchar(path.norm)) ) if(nchar(rel.path) <= nchar(pkg.path)) rel.path else pkg.path } unique_path <- function(files) { stopifnot(is.character(files), !any(is.na(files))) dirs <- dirname(files) uniq.dir <- str_reduce_unique(dirs) com.dir <- substr(dirs[[1L]], 1L, nchar(dirs[[1L]]) - nchar(uniq.dir[[1L]])) full.dir <- dirs[[1L]] repeat { dir.tmp <- dirname(full.dir) if( nchar(dir.tmp) < nchar(com.dir) || !nchar(dir.tmp) || identical(dir.tmp, ".") ) break full.dir <- dir.tmp } test.files.trim <- if(sum(nchar(uniq.dir))) { file.path(uniq.dir, basename(files)) } else basename(files) structure(test.files.trim, common_dir=full.dir) } # Merge Two Lists # # Values in \code{y} ovewrite existing values in \code{x}. This is similar to # \code{modifyList} but is non-recursive # # @keywords internal # @param x a list # @param y a list merge_lists <- function(x, y, keep.null=TRUE) { stopifnot( is.list(x), is.list(y), !identical(length(names(x)), x), !identical(length(names(y)), y) ) if(!isTRUE(keep.null)) stop("Currently `keep.null` must be TRUE") x[names(y)] <- y x } # Comparison functions that output to stdout/stderr for testing of effect of # doing so (should be captured and ignored, then at end warn about it) comp_stdout <- function(x, y) { cat("I'm outputting to stdout\n") TRUE } comp_stderr <- function(x, y) { cat("I'm outputting to stderr\n", file=stderr()) TRUE } comp_stdboth <- function(x, y) { cat("I'm outputting to both 1\n") cat("I'm outputting to both 2\n", file=stderr()) TRUE } # Cleanup text output that contains "Error|Warning in eval(...)" because of how # that behaves differently between 3.3.2 and 3.4 clean_eval_exp <- function(x) { clean_elem <- function(y) gsub("^(Error|Warning) in eval\\(.*?\\) :", "\\1 in :", y) if(is.list(x)) { x[] <- lapply(x, clean_elem) x } else if(is.character(x)) clean_elem(x) else x } unitizer/R/unitizer-package.R0000644000176200001440000000234014766340624015724 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' unitizer #' #' Simplifies regression tests by comparing objects produced by test #' code with earlier versions of those same objects. If objects are unchanged #' the tests pass. `unitizer` provides an interactive interface to review #' failing tests or new tests. See vignettes for details. #' #' @import methods #' @import stats #' @import diffobj #' @importFrom utils capture.output file_test getParseData installed.packages #' loadhistory modifyList object.size packageVersion remove.packages #' savehistory #' @name unitizer #' @aliases unitizer-package "_PACKAGE" unitizer/R/exec.R0000644000176200001440000004351514766101401013403 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include unitizer.R NULL setGeneric("exec", function(x, ...) standardGeneric("exec")) ## Functions To Manage Evaluation of Tests ## ## Runs test, captures value, stdout, stderr, conditions, etc. ## ## \code{exec} is designed to run tests, capture output, etc, ## \code{eval_user_exp} does the actual evaluation, \code{eval_with_capture}, ## is a wrapper around \code{eval_user_exp} that also captures output, ## \code{user_exp_display} and \code{user_exp_handle} are utility function to ## deal with evaluations that invoke print/show, ## \code{set_trace} and \code{get_trace} are used to set the tracebacks when ## there are failures. ## ## @section \code{eval_user_exp}: ## ## A fair bit of manipulation required to ensure the trace and calls associated ## with conditions are reasonable. This should be mostly correct except for the ## notable exception of top-level conditions, which will be recorded correctly, ## but for which the \code{std.err()} output will show the ## \code{withVisible(...)} call. Doesn't seem to be a straightforward way of ## capturing that short of tossing the \code{stderr} and spoofing the message. ## ## @section \code{set_trace}, \code{get_trace}: ## ## Used for cases where the trace isn't generated because the error was run ## within a handling loop, but we still want the trace so we can emulate command ## line behavior. ## ## This will modify the .Traceback system variable (see \code{\link{traceback}} ## documentation). ## ## Assumption right now is that the outer most call to \code{withCallingHandlers} ## is the baseline level from which we want to repor the traceback. ## ## Only intended for use within \code{eval_user_exp}, will clean up the result ## from two different \code{sys.calls} calls to extract the calls that a ## trace would show on error. ## ## How much of the stack is used is affected by the \code{printed} ## argument because if something didn't pass evaluation, it means the error ## occurred within \code{withVisible} which in this setup means we need to ## remove two additional levels. ## ## Relies on calls being evaluated in a very particular environment. ## ## @rdname exec ## @param trace a list of type generated by sys.calls() ## @param trace.base starting point for what we care about in the trace, as ## produced by \code{sys.calls} ## @param trace.new the trace within the condition handler, as produced by ## \code{sys.calls} ## @param passsed.eval whether the evaluatation succeeded in the first step (see ## details) ## @param print.type character(1L) one of "print", "show", or "" ## @param exp the expression to sub in to the print/show statements if we passed ## eval ## @param test the call to test ## @param test.env the environment to evaluate the \code{test} in ## @param global unitizerGlobal, required by \code{eval_user_exp} to record ## state every time a user expression is evaluated ## @param with.display whether to print/show output if visible ## @param with.state whether to log state after each evaluation setMethod("exec", "ANY", valueClass="unitizerItem", function(x, test.env, global) { if(!is.environment(test.env)) stop("Argument `test.env` must be an environment.") # Check whether we are dealing with a unitizer_sect is_unitizer_sect <- FALSE if(is.call(x)) is_unitizer_sect <- identical(try(eval(x[[1L]], test.env), silent=TRUE), unitizer_sect) # Prep message and std output capture, note this is reset with every test # expressionevaluation x.comments <- character() if(!is_unitizer_sect) { x.extracted <- comm_and_call_extract(x) # need to recover comments from container since we can't attach comments # directly to name x.comments <- x.extracted$comments x <- x.extracted$call # get rid of comment container } x.to.eval <- `attributes<-`(x, NULL) res <- eval_with_capture( x.to.eval, test.env, global=global, with.capture=!global$transcript ) global$cons <- res$cons # Need to recover connections if(res$aborted & is_unitizer_sect) # check to see if `unitizer_sect` failed stop( "Failed instantiating a unitizer section:\n", paste0(res$message, "\n") ) if(!is(res$state, "unitizerGlobalIndices")) { stop("Internal Error: failed recording state; contact maintainer.")# nocov } new( "unitizerItem", call=x.to.eval, value=res$value, conditions=new("conditionList", .items=res$conditions), output=res$output, message=res$message, aborted=res$aborted, env=test.env, comment=x.comments, trace=res$trace, glob.indices=res$state, ignore=identical(res$visible, FALSE) && !length(res$conditions) ) } ) # ## Three places eval_user_exp is called # # ## This is used by unitizer_browse, and also all over the place so a real # ## problem to isolate! # # unitizer_prompt # eval_user_exp # # ## This is used to evaluate the test expression # ## and produce unitizerItems # # unitize_eval # `+`("unitizer", "unitizerTestsOrExpression") # exec # eval_with_capture # eval_user_exp <----- # `+`("unitizer", "unitizerItem") # testItem("unitizer", "unitizerItem") # eval_user_exp <----- # @param warn.sticky TRUE or FALSE whether to let the warning option state # persist past the call. If TRUE, then whatever is invoking this function is # responsible for resetting it. At the moment it is when this is invoked via # the `unitizer_prompt` in browsing test results. eval_user_exp <- function( unitizerUSEREXP, env, global, with.display=TRUE, warn.sticky=FALSE, with.display.unitizer_sect=FALSE ) { if(!is(global, "unitizerGlobal") && !is.null(global)) { # nocov start stop( "Internal Error: `global` argument must be a 'unitizerGlobal' object ", "or NULL, contact maintainer." ) # nocov end } if(getOption('warn') < 1L) { old.opt <- options(warn=1L) if(!warn.sticky) on.exit(options(old.opt)) } exp <- if(is.expression(unitizerUSEREXP)) { call("withVisible", call("eval", unitizerUSEREXP)) } else call("withVisible", unitizerUSEREXP) res <- user_exp_handle(exp, env, "", unitizerUSEREXP) if( !res$aborted && res$value$visible && length(unitizerUSEREXP) && with.display && ( !is(res$value$value, "unitizerSectionExpression") || with.display.unitizer_sect ) ) { res2 <- user_exp_display(res$value$value, env, unitizerUSEREXP) res$conditions <- append(res$conditions, res2$conditions) if(length(res2$trace)) res$trace <- res2$trace res$aborted <- res2$aborted } # convolution required due to possible NULL value so can't assign directly to # elements; also, note that the `state` return value is not used in most # `eval_user_exp` uses; the c( list( value=res$value$value, visible=res$value$visible, state=if(is(global, "unitizerGlobal")) global$state() ), res[-1L] ) } # @param with.display output result of evaluation after evaluation # @param with.capture turns capture on and off for each expression, different # from with.display as this will allow display of e.g. segfaults, etc. Gives # more fine grained control than "unitizer.disable.capt" as that does it for # every use of this function, whereas we might only want it for test # expressions. eval_with_capture <- function( x, test.env=new.env(), global, with.display=TRUE, with.state=TRUE, with.capture=TRUE ) { stopifnot(is(global, "unitizerGlobal")) # These used to be parameters, but now that we have `global` we use that # instead; note that the options come in as NULL quietly in some tests where # we're e.g. directly accessing the unitizers instead of using `unitize`, and # those NULLs ar just dropped implicitly by the way we call `set_capture`. cons <- global$cons disable.capt <- global$unitizer.opts[["unitizer.disable.capt"]] max.capt.chars <- global$unitizer.opts[["unitizer.max.capture.chars"]] if(!is.null(disable.capt)) disable.capt <- disable.capt | !with.capture # Disable error handler; warn gets set to one when we eval the expression err.opt <- getOption("error") # Setup text capture; a bit messy due to funny way we have to pull in # unitize specific options; do.call business is to use default arguments # if options are NULL came.with.capts <- TRUE if(is.null(cons)) { capt.cons <- new("unitizerCaptCons") came.with.capts <- FALSE } else { capt.cons <- cons } # disable.capt and max.capt.chars could be NULL in some cases (see above) set_args <- list() set_args[["capt.disabled"]] <- disable.capt capt.cons <- do.call(set_capture, c(list(capt.cons), set_args)) get_args <- list(capt.cons) get_args[["chrs.max"]] <- max.capt.chars # Manage unexpected outcomes on.exit({ options(error=err.opt) get.try <- try(capt <- do.call(get_capture, get_args)) unsink.try <- try(capt.cons <- unsink_cons(capt.cons)) if(!inherits(get.try, "try-error")) { cat(c(capt$message, "\n"), file=stderr(), sep="\n") cat(c(capt$output, "\n"), sep="\n") } if(inherits(unsink.try, "try-error")) failsafe_con(capt.cons) if(!came.with.capts) close_and_clear(capt.cons) meta_word_msg( "Unexpectedly exited evaluation attempt when executing test ", "expression:\n> ", paste0(deparse(x), collapse=""), "\nMake sure you ", "are not calling `unitize` inside a `tryCatch`/`try` block, invoking a ", "restart defined outside `unitize`, evaluating an expression that ", "calls `quit()`/`q()`, or quitting from a `browser()`/`debug()`/", "`trace()`. If none of these apply yet you are seeing this message ", "please contact package maintainer.", sep="" ) }) # Evaluate expression options(error=NULL) res <- eval_user_exp( x, test.env, global=if(with.state) global, with.display=with.display ) # Revert settings, get captured messages, if any and if user isn't capturing # already; do.call so we can rely on default get_capture settings if those # in `unitizer.opts` are NULL capt <- do.call(get_capture, get_args) capt.cons <- unsink_cons(capt.cons) if(getOption("unitizer.show.output", TRUE)) { cat(c(capt$message, "\n"), file=stderr(), sep="\n") cat(c(capt$output, "\n"), sep="\n") } on.exit(NULL) options(error=err.opt) # Need to make sure we either close the connections or return the updated # values since we might be changing connections depending on sink status, etc if(!came.with.capts) close_and_clear(capt.cons) # Cleanup and res[c("output", "message")] <- lapply( capt[c("output", "message")], function(x) if(!length(x)) "" else x ) res[["cons"]] <- capt.cons clean_message(res) } user_exp_display <- function(value, env, expr, default=FALSE) { if(isS4(value)) { print.type <- "show" disp.expr <- call("show", if(is.language(value)) enquote(value) else value) } else { print.type <- "print" disp.expr <- call( if(default) "print.default" else "print", if(is.language(value)) enquote(value) else value ) } user_exp_handle(disp.expr, env, print.mode=print.type, expr.raw=expr) } # It used to matter what precise value `print.mode`, but now the only thing # that matters is whether it is zero char or not user_exp_handle <- function(expr, env, print.mode, expr.raw) { aborted <- FALSE conditions <- list() trace <- list() printed <- nchar(print.mode) > 1 value <- NULL withRestarts( withCallingHandlers( { trace.base <- sys.calls() value <- eval(expr, env) }, condition=function(cond) { attr(cond, "unitizer.printed") <- printed trace.new <- sys.calls() trace.net <- get_trace( trace.base, trace.new, printed, expr.raw ) if(attr(trace.net, "set.trace")) trace <<- c(trace.net) # manipulate call so it looks like it should cond.call.noattr <- `attributes<-`(cond$call, NULL) if(!printed && identical(cond.call.noattr, trace.net[[1L]])) { cond <- modifyList(cond, list(call=NULL), keep.null=TRUE) } conditions[[length(conditions) + 1L]] <<- cond } ), abort=function() { aborted <<- structure(TRUE, printed=printed) } ) list( value=value, aborted=aborted, conditions=conditions, trace=tail(trace, -1L) ) } ## Trace is undeparsed set_trace <- function(trace) { if(length(trace)) .global$traceback <- rev(trace) TRUE } get_trace <- function(trace.base, trace.new, printed, exp) { # because withCallingHandlers/withRestarts don't register when calling # sys.calls() within them, but do when calling sys.calls() from the handling # function, we need to remove at least 4 calls from trace.new, and possibly # more if we ended up evaluating within withVisible len.new <- length(trace.new) if( len.new > length(trace.base) && all( vapply( seq_along(trace.base), FUN.VALUE=logical(1L), function(x) identical(trace.base[[x]], trace.new[[x]]) ) ) ) { # Filter out calls through signalCondition rather than stop and # `stop+condition` is.stop <- identical(trace.new[[len.new]], quote(h(simpleError(msg, call)))) is.stop.cond <- length(trace.new) > 1L && identical(trace.new[[len.new - 1L]][[1L]], quote(stop)) trace.new[seq_along(trace.base)] <- NULL # remove srcref attributes trace.new.clean <- lapply(trace.new, `attributes<-`, NULL) if( length(trace.new.clean) >= 7L || (printed && length(trace.new.clean) >= 6L) ) { # printing removes expression trace.new.clean[ 1L:(if(printed) 5L else 6L + is.expression(exp) * 2L) ] <- NULL if(printed) { # Find any calls from the beginning that are length 2 and start with # print/show and then replace the part inside the print/show call with # the actual call exp.rep <- if(is.expression(exp)) exp[[length(exp)]] else exp trace.new.clean <- lapply( trace.new.clean, function(x) eval(call("substitute", x, list(unitizerTESTRES=exp.rep))) ) } if(length(trace.new.clean) >= 2L) { trace.drop <- if(is.stop) -2L else if (is.stop.cond) -1L else 0L trace.trim <- trace.new.clean[1L:(length(trace.new.clean) + trace.drop)] } else { stop("Internal Error: unexpected trace length") # nocov } attr(trace.trim, "set.trace") <- is.stop || is.stop.cond # only actually set trace on `stop` calls return(trace.trim) } } stop("Internal Error: couldn't extract trace; contact maintainer.") # nocov } clean_message <- function(res) { # Deal with top level warnings and errors that show up weird in the message # output because they are not truly top level within unitizer; top level # warnings will have the `call` component set to NULL; we compose a regular # expression that contains all the warning / errors and their messages to # match against the output stream to give use the location of the # "Error in .*: " and such stopifnot( is.list(res), is.character(res$message), identical(length(res$message), 1L) ) # this all assumes options(warn>=1) reg.base <- "(%s in .*? :)((?:\\n|\\s)*%%s)\\n.*" if(nchar(res$message)) { pats <- lapply( res$conditions, function(cond) { token <- NULL if( is.null(conditionCall(cond)) && ( (is.warn <- inherits(cond, "simpleWarning")) || inherits(cond, "simpleError") ) ) { type <- if(is.warn) "Warning" else "Error" sprintf( sprintf(reg.base, type), gsub( "([-\\\\^$*+?.()|[\\]{}])", "\\\\\\1", conditionMessage(cond), perl=TRUE ) ) } } ) if(!all(vapply(pats, is.null, logical(1L)))) { # Our pattern has two matching elements per match, and these are going to # show up sequentially in our match, so we turn the capture data into # a matrix where col 1 is the first match, and col 2 the second match pats.fin <- do.call(paste0, c(list("(?s)"), pats)) m <- regexpr(pats.fin, res$message, perl=T) m.st <- t(matrix(attr(m, "capture.start"), nrow=2)) m.len <- t(matrix(attr(m, "capture.length"), nrow=2)) # Loop backwards through string so that modifications don't affect character # locations for subsequent replacements msg <- res$message width <- getOption("width") for(i in rev(seq.int(nrow(m.st)))) { if(m.st[i, 1L] < 1L || m.len[i, 1L] < 1L) next pre <- if(m.st[i, 1L] == 1L) "" else substr(msg, 1L, m.st[i, 1L] - 1L) obj <- sub( "^(\\w+).*", "\\1:", # replace obj with first word substr(msg, m.st[i, 1L], m.st[i, 1L] + m.len[i, 1L] - 1), perl=TRUE ) obj2 <- substr(msg, m.st[i, 2L], m.st[i, 2L] + m.len[i, 2L] - 1) post <- if(m.st[i, 2L] + m.len[i, 2L] > nchar(msg)) "" else substr(msg, m.st[i, 2L] + m.len[i, 2L], nchar(msg)) # Undo line break if shorter call doesn't warrant it anymore obj2.short <- sub("^(?s)\\s*(.*)$", " \\1", obj2, perl=TRUE) msg <- if(nchar(paste0(obj, obj2.short)) <= width) paste0(pre, obj, obj2.short, post) else paste0(pre, obj, obj2, post) } res$message <- msg } } res } unitizer/R/conditions.R0000644000176200001440000002775314766353066014656 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Generates a Dummy Item For Use in Examples #' #' The only purpose of this function is to create a \code{unitizerItem} for use #' by examples. #' #' @export #' @return unitizerItem object mock_item <- function() { new( "unitizerItem", call=quote(fun()), value=42, conditions=new( "conditionList", .items=list( simpleWarning("hello", call=quote(fun())), simpleWarning("goodbye", call=quote(fun())) ) ) ) } #' Contains A List of Conditions #' #' Condition lists are S4 classes that contain \code{\link{condition}} objects #' emitted by \code{unitizer} tests. Condition lists will typically be #' accessible via the \code{.NEW} and \code{.REF} \code{unitizer} test objects. #' You can access individual conditions using \code{[[} (see examples), and for #' the most part you can treat them as you would an S3 list containing #' conditions. #' #' There are \code{show} and \code{all.equal} methods implemented for them, the #' latter of which is used to compare conditions across tests. If you wish to #' implement a custom comparison function via \code{\link{unitizer_sect}}, your #' function will need to compare \code{conditionList} objects. #' #' @note Implemented as an S4 class to avoid \code{setOldClass} and related #' compatibility issues; the \code{conditionList} class contains #' \code{\link{unitizerList}}. #' #' @rdname conditionList #' @name conditionList #' @aliases conditionList-class #' @slot .items list of conditions #' @seealso \code{\link{unitizer_sect}}, \code{\link{unitizerList}}, #' \code{\link{all.equal.conditionList}} #' @export conditionList #' @exportClass conditionList #' @examples #' ## Create a test item as you would find normally at the `unitizer` prompt #' ## for illustrative purposes: #' .NEW <- mock_item() #' ## Access the first condition from the new test evaluation #' .NEW$conditions[[1L]] #' ## loop through all conditions #' for(i in seq_along(.NEW$conditions)) .NEW$conditions[[i]] conditionList <- setClass("conditionList", contains="unitizerList") #' Stub to pacify Roxygen #' #' At some point between 7.2.3 and 7.3.2 2025 roxygen started breaking with #' undocumented methods. In particular, it's a problem for generics that are #' documented in e.g. base as is the case with all.equal. #' #' @noRd all.equal <- NULL #' Compare Conditions #' #' Tests that issue warnings or `stop` produce \code{\link{condition}} objects. #' The functions documented here are specialized versions of #' \code{\link{all.equal}} designed specifically to compare conditions and #' condition lists produced during \code{unitizer} test evaluations. #' \code{\link{conditionList}} objects are lists of conditions that come about #' when test expressions emit multiple conditions (e.g. more than one warning). #' #' \code{\link{condition}} objects produced by tests have one additional #' attributed \dQuote{printed} which disambiguates whether a condition was the #' result of the test expression, or the \code{print} / \code{show} method used #' to display it to screen. #' #' For \code{conditionList} objects, these methods only return TRUE if all #' conditions are pairwise \code{all.equal}. #' #' @export #' @aliases all.equal,condition,ANY-method all.equal,conditionList,ANY-method #' @name all.equal.condition #' @rdname all.equal.condition #' @param target the list of conditions that we are matching against #' @param current the list of conditions we are checking #' @param ... provided for compatibility with generic #' @return TRUE if the (lists of) conditions are equivalent, a character #' vector explaining why they are not otherwise #' @examples #' cond.1 <- simpleWarning('hello world') #' cond.2 <- simpleError('hello world') #' cond.3 <- simpleError('goodbye world') #' all.equal(cond.1, cond.1) #' all.equal(cond.1, cond.2) #' all.equal(cond.2, cond.3) #' ## Normally you would never actually create a `conditionList` yourself; these #' ## are automatically generated by `unitizer` for review at the `unitizer` #' ## prompt #' all.equal( #' conditionList(.items=list(cond.1, cond.2)), #' conditionList(.items=list(cond.1, cond.3)) #' ) setMethod("all.equal", "conditionList", function(target, current, ...) { if( !all(vapply(as.list(target), inherits, FALSE, "condition")) || !all(vapply(as.list(current), inherits, FALSE, "condition")) ) return("`target` or `current` are not both lists of conditions") if(length(target) != length(current)) { return( paste0( "Condition count mismatch; expected ",length(target), " (got ", length(current), ")" ) ) } cond.len <- min(length(target), length(current)) res <- lapply( seq(length.out=cond.len), function(x) all.equal(target[[x]], current[[x]]) ) errs <- which(vapply(res, Negate(isTRUE), logical(1L))) if(!(err.len <- length(errs))) { return(TRUE) } else if (err.len == 1) { err.msg <- paste0( "There is one condition mismatch at index [[", errs, "]]" ) } else { err.msg <- paste0( "There are ", err.len, " condition mismatches, first one at index [[", errs[[1]],"]]" ) } if(err.len) return(err.msg) } ) # So that S3 dispatch works #' @rdname all.equal.condition #' @method all.equal conditionList #' @exportS3Method all.equal conditionList all.equal.conditionList <- function(target, current, ...) all.equal(target, current, ...) #' @method all.equal condition #' @exportS3Method all.equal condition #' @rdname all.equal.condition all.equal.condition <- function(target, current, ...) { if(!inherits(target, "condition") || !inherits(current, "condition")) return("One of `target` or `current` is not a condition") target.printed <- isTRUE(attr(target, "unitizer.printed")) current.printed <- isTRUE(attr(current, "unitizer.printed")) if(!is.null(attr(target, "unitizer.printed"))) attr(target, "unitizer.printed") <- NULL if(!is.null(attr(current, "unitizer.printed"))) attr(current, "unitizer.printed") <- NULL err.msg <- character() if( !identical( type.targ <- get_condition_type(target), type.curr <- get_condition_type(current) ) ) { err.msg <- paste0( "Condition type mismatch, `target` is '", type.targ, "', but `current` is '", type.curr, "'" ) } else if( !isTRUE(all.equal(conditionMessage(target), conditionMessage(current))) ) { err.msg <- paste0(type.targ, " condition messages do not match") } else if(!isTRUE(compare_condition_calls(target, current))) { err.msg <- paste0(type.targ, " condition calls do not match") } if(length(err.msg) && (target.printed || current.printed)) { print.show.err <- paste0( "Condition mismatch may involve print/show methods; carefully review ", "conditions with `.NEW$conditions` and `.REF$conditions` as just ", "typing `.ref` or `.new` at the prompt will invoke print/show methods, ", "which themselves may be the cause of the mismatch" ) err.msg <- c(err.msg, print.show.err) } if(length(err.msg)) return(err.msg) TRUE } ## Compare Two Calls Generously ## ## Designed to minimize false positive errors caused by instability in C level ## errors issued whether the code is byte-compiled or not (e.g. when run under ## `covr`, or iterating at the prompt). compare_condition_calls <- function(target, current) { tar.c <- conditionCall(target) cur.c <- conditionCall(current) if(!is.null(tar.c) && !is.null(cur.c)) { # Only check the things that are present in both tar.l <- as.list(tar.c) cur.l <- as.list(cur.c) if(length(tar.l) && length(cur.l)) { if(!isTRUE(all.equal(tar.l[[1]], cur.l[[1]]))) { # Function different FALSE } else { # compare comon names. We don't compare unnamed arguments, in theory we # should by using some kind of match.call style arrangement. tar.n <- names(tar.l) cur.n <- names(cur.l) common.n <- intersect(tar.n, cur.n) common.n <- common.n[nzchar(common.n)] if(length(common.n)) isTRUE(all.equal(tar.l[common.n], cur.l[common.n])) else TRUE } } else { TRUE } } else { # If one of the calls is NULL, let it match TRUE } } #' Prints A list of Conditions #' #' S4 method for \code{\link{conditionList}} objects. #' #' @name show.conditionList #' @aliases show,conditionList-method #' @export #' @seealso \code{\link{conditionList}} #' @param object a \code{\link{conditionList}} object (list of conditions) #' @return object, invisibly #' @examples #' ## Create a test item as you would find normally at the `unitizer` prompt #' ## for illustrative purposes: #' .NEW <- mock_item() #' ## Show the conditions the test generated (typing `show` here is optional #' ## since auto-printing should dispatch to `show`) #' show(.NEW$conditions) setMethod("show", "conditionList", function(object) { width=getOption("width") cond.len <- length(object) if(!cond.len) { word_cat("Empty condition list") return(invisible(object)) } else { word_cat( "Condition list with", cond.len, paste0("condition", if(cond.len > 1) "s", ":") ) } cond.calls <- vapply( as.list(object), function(x) !is.null(conditionCall(x)), logical(1L) ) nums <- paste0(format(seq_along(object)), ". ") out <- paste0( ifelse( print.show <- vapply( as.list(object), function(y) isTRUE(attr(y, "unitizer.printed")), logical(1L) ), "[print] ", "" ), vapply(as.list(object), get_condition_type, character(1L)), ifelse(cond.calls, " in ", "") ) desc.chars <- max(width - max(nchar(nums)), 20L) cond.detail <- vapply( as.list(object), FUN.VALUE=character(1L), function(y) { if(is.null(conditionCall(y))) { paste0(": ", conditionMessage(y)) } else { paste0(deparse(conditionCall(y))[[1L]], " : ", conditionMessage(y)) } } ) out.w <- word_wrap(paste0(out, cond.detail), width=desc.chars, unlist=FALSE) out.lens <- vapply(out.w, length, integer(1L)) if(!all(out.lens)) { # nocov start stop("Internal Error: empty condition data; contact maintainer.") # nocov end } nums.pad <- Map( function(x, y) c(x, rep(paste0(rep(" ", nchar(x)), collapse=""), y - 1L)), nums, out.lens ) out.fin <- unlist(Map(paste0, nums.pad, out.w)) if(any(print.show)) { out.fin <- c( out.fin, word_wrap( cc( "\n[print] means condition was issued by a print or show method ", "for an auto-printed result." ), width=width ) ) } out.fin <- c(out.fin) cat(out.fin, sep="\n") return(invisible(object)) } ) # Extracts Condition Type From Condition Classes # # Type (e.g. Error, Warning), is taken to be the second to last class. # # @keywords internal # @param x a condition # @return character 1 length the type of condition get_condition_type <- function(x) { if(!inherits(x, "condition")) stop("Argument `x` must be a condition") classes <- class(x) if(length(classes) < 2L || classes[[length(classes)]] != "condition") "Unknown" else if(identical(classes, c("simpleError", "error", "condition"))) "Error" else if(identical(classes, c("simpleWarning", "warning", "condition"))) "Warning" else if(identical(classes, c("simpleMessage", "message", "condition"))) "Message" else classes[[1L]] } unitizer/R/unitize.core.R0000644000176200001440000012317714766101401015100 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Runs The Basic Stuff # # Used by both \code{\link{unitize}} and \code{\link{review}} # to launch the interactive interface for reviewing tests. # # Right now we distinguish in what mode we're running based on whether # \code{test.file} is NULL (review mode) vs. not (unitize mode), which isn't # very elegant, but whatevs. This has implications for the parsing / evaluation # step, as well as how the \code{unitizerBrowse} object is constructed. # Otherwise stuff is mostly the same. # # Cleary there is a trade-off in increased code complexity to handle both types # of code, vs duplication. Not ideal, but tasks are so closely related and # there is so much common overhead, that the central function makes sense. # Also, since unfortunately we're relying on side-effects for some features, and # \code{on.exit} call for safe operation, it is difficult to truly modularize. # # @keywords internal # @inheritParams unitize # @param mode character(1L) one of "review" or "unitize" # @param test.files character location of test files # @param store.ids list of store ids, same length as \code{test.files} unitize_core <- function( test.files, store.ids, state, pre, post, history, interactive.mode, force.update, auto.accept, mode, use.diff, show.progress, transcript ) { # - Validation / Setup ------------------------------------------------------- if(!'package:unitizer' %in% search()) stop( "`unitizer` package must be attached to the search path, ", "e.g. with `library(unitizer)`" ) if(!is.chr1(mode) || !mode %in% c("unitize", "review")) # nocov start stop("Internal Error: incorrect value for `mode`; contact maintainer") # nocov end if(mode == "review") { if(!all(is.na(test.files))) # nocov start stop( "Internal Error: `test.files` must be NA in review; contact maintainer" ) # nocov end if(length(auto.accept)) stop("Internal Error: auto-accepts not allowed in review mode") # nocov if(!identical(state, "off") ) stop("Internal Error: state must be disabled in review mode") # nocov } if(mode == "unitize") { if( !is.character(test.files) || any(is.na(test.files)) || !all(file_test("-f", test.files)) ) # nocov start stop( "Internal Error: `test.files` must all point to valid files in ", "unitize mode; contact maintainer" ) # nocov end test.files <- try(normalize_path(test.files, mustWork=TRUE)) if(inherits(test.files, "try-error")) # nocov start stop("Internal Error: unable to normalize test files; contact maintainer") # nocov end } if(length(test.files) != length(store.ids)) # nocov start stop( "Internal Error: mismatch in test file an store lengths; contact ", "maintainer" ) # nocov end if(!length(test.files)) # nocov start stop("Internal Error: expected at least one test file; contact maintainer.") # nocov end if(!is.TF(interactive.mode)) stop("Argument `interactive.mode` must be TRUE or FALSE") if(!is.TF(force.update)) stop("Argument `force.update` must be TRUE or FALSE") if(!is.TF(use.diff)) stop("Argument `use.diff` must be TRUE or FALSE") if( !is.TF(show.progress) && !isTRUE(show.progress %in% (seq_len(PROGRESS.MAX + 1L) - 1L)) ) stop("Argument `show.progress` must be TRUE or FALSE or in 0:", PROGRESS.MAX) if(is.logical(show.progress)) show.progress <- show.progress * PROGRESS.MAX if(!is.TF(transcript)) stop("Argument `transcript` must be TRUE or FALSE") # Validate state; note that due to legacy code we disassemble state into the # par.env and other components state <- try(as.state(state, test.files)) if(inherits(state, "try-error")) stop("Argument `state` could not be evaluated.") par.env <- state@par.env # NOTE: this could be NULL until later when replaced reproducible.state <- vapply( setdiff(slotNames(state), "par.env"), slot, integer(1L), object=state ) # auto.accept auto.accept.valid <- character() if(is.character(auto.accept)) { if(length(auto.accept)) { auto.accept.valid <- tolower(levels(new("unitizerBrowseMapping")@review.type)) if(any(is.na(auto.accept))) stop("Argument `auto.accept` contains NAs but should not") auto.accept <- unique(tolower(auto.accept)) if(!all(auto.accept %in% auto.accept.valid)) stop( "Argument `auto.accept` must contain only values in ", deparse(tolower(auto.accept.valid)) ) } } else stop("Argument `auto.accept` must be character") if(length(auto.accept) && !length(test.files)) stop("Argument `test.files` must be specified when using `auto.accept`") # validate and convert pre and post load folders to character; this doesn't # check that they point to real stuff test.dir <- if(length(test.files)) dirname(test.files[[1L]]) pre <- validate_pre_post(pre, test.dir) post <- validate_pre_post(post, test.dir) # Make sure history is kosher if(is.character(history)) { if(nchar(history)) { test.con <- try(file(history, "at")) if(inherits(test.con, "try-error")) stop( "Argument `history` must be the name of a file that can be opened in ", "\"at\" mode" ) close(test.con) } else { history <- tempfile() attr(history, "hist.tmp") <- TRUE } } else if (!is.null(history)) { stop( "Argument `history` must be the name of a file that can be opened in ", "\"at\" mode, or \"\", or NULL" ) } # Make sure nothing untoward will happen if a test triggers an error check_call_stack() # - Global Controls ---------------------------------------------------------- # Store a copy of the unitizer options, though make sure to validate them # first (note validation is potentially a bit duplicative since some of the # params would have been pulled from options); we store the opts because they # get nuked by `options_zero` but we still need some of the unitizer ones opts <- options() opts.untz <- opts[grep("^unitizer\\.", names(opts))] opts.untz <- validate_options(opts.untz, test.files) # Initialize new tracking object; this will also record starting state and # store unitizer options; open question of how exposed we want to be to # user manipulation of options global <- unitizerGlobal$new( enable.which=reproducible.state, unitizer.opts=opts.untz, # need to reconcile with normal options set.global=TRUE, transcript=transcript ) set.shim.funs <- FALSE if(is.null(par.env)) { set.shim.funs <- TRUE par.env <- global$par.env } gpar.frame <- par.env # - Directories -------------------------------------------------------------- # Create parent directories for untizer stores if needed, doing now so that # we can later ensure that store ids are being specified on an absolute basis, # and also so we can prompt the user now dir.names <- vapply( store.ids, function(x) { if(is.character(x) && !is.object(x) && !file_test("-d", dirname(x))) { dirname(x) } else NA_character_ }, character(1L) ) dir.names.clean <- Filter(Negate(is.na), unique(dir.names)) if(length(dir.names.clean)) { dir.word <- paste0("director", if(length(dir.names.clean) > 1L) "ies" else "y") meta_word_cat( "In order to proceed unitizer must create the following ", dir.word, ":\n\n", sep="", trail.nl=FALSE ) meta_word_cat( as.character( UL(dir.names.clean), width=getOption("width") - 2L, hyphens=FALSE ), trail.nl=FALSE ) prompt <- paste0("Create ", dir.word) meta_word_cat("\n", prompt, "?", sep="") pick <- unitizer_prompt( prompt, valid.opts=c(Y="[Y]es", N="[N]o"), global=NULL, browse.env=new.env(parent=par.env) ) if(!identical(pick, "Y")) { on.exit(NULL) reset_and_unshim(global) stop("Cannot proceed without creating directories.") } if(!all(dir.created <- dir.create(dir.names.clean, recursive=TRUE))) { # nocov start # no good way to test stop( "Cannot proceed, failed to create the following directories:\n", paste0(" - ", dir.names.clean[!dir.created], collapse="\n") ) # nocov end } } # Ensure directory names are normalized, but only if dealing with char objects norm.attempt <- try( store.ids <- lapply( store.ids, function(x) { if(is.character(x) && !is.object(x)) { file.path(normalize_path(dirname(x), mustWork=TRUE), basename(x)) } else x } ) ) if(inherits(norm.attempt, "try-error")) # nocov start stop( "Internal Error: some `store.ids` could not be normalized; contact ", "maintainer." ) # nocov end # - Set Global State --------------------------------------------------------- on.exit(reset_and_unshim(global), add=TRUE) if(set.shim.funs) global$shimFuns() # Set the zero state if needed; `seach.path` should be done first so that we # can disable options if there is a conflict there; WARNING, there is some # fragility here since it is possible using these functions could modify # global (see `options` example) # get seed before 'options_zero' seed.dat <- global$unitizer.opts[["unitizer.seed"]] if(identical(global$status@search.path, 2L)) search_path_trim( global=global, keep.path=keep_sp_default(global$unitizer.opts) ) if(identical(global$status@namespaces, 2L)) namespace_trim( global=global, keep.ns=keep_ns_default(global$unitizer.opts) ) # indicate conflict happened prior to test eval if(global$ns.opt.conflict@conflict) global$ns.opt.conflict@file <- "" if(identical(global$status@options, 2L)) options_zero() if(identical(global$status@random.seed, 2L)) { if(inherits(try(do.call(set.seed, seed.dat)), "try-error")) { # nocov start shouldn'at ctually be able to get here because # the option should be validated stop( word_wrap(collapse="\n", cc( "Internal Error: Unable to set random seed; somehow ", "`getOption('unitizer.seed')` does not a apper to be valid, ", "which should not happen; contact maintainer." ) ) ) # nocov end } } if(identical(global$status@working.directory, 2L)) { # If likely in a test directory don't change directory. Might be safer to # check for the R_TESTS environment variable. wd <- getwd() test.dir <- if(grepl("-tests$", wd)) { # tools::testInstalledPackage wd } else if (grepl("tests", wd) && grepl("\\.Rcheck", dirname(wd))) { wd } else if(length(unique(dirname(test.files)) == 1L)) { if( length(par.dir <- get_package_dir(test.files[[1L]])) && file_test("-d", file.path(par.dir, "tests")) ) { # Use parent package dir test folder file.path(par.dir, "tests") } else { # File doesn't seem to be in package, so set wd to be the same as # the file dirname(test.files[[1L]]) } } else { # nocov start # currently no way to get here since there is no way to specify multiple # files other than by directory warning( word_wrap(collapse="\n", cc( "Working directory state tracking is in mode 2, but we cannot ", "identify the standard tests directory because test files are not ", "all in same directory, so we are leaving the working directory ", "unchanged." ) ), immediate.=TRUE ) stop( "Internal Error: shouldn't be able to evaluate this code; ", "contact maintainer" ) # nocov end } if(!is.null(test.dir)) { dir.set <- try(setwd(test.dir)) if(inherits(dir.set, 'try-error')) { # nocov start there really shouldn't be a way to trigger this warning test.dir.err <- if(!is.chr1(test.dir)) "" else test.dir warning( word_wrap(collapse="\n", cc( "Working directory state tracking is in mode 2, but we ", "failed setting director to '", test.dir.err, "' so we are ", "leaving the working directory unchanged." ) ), immediate.=TRUE ) # nocov end } } } # - Parse / Load ------------------------------------------------------------- # Handle pre-load data if(show.progress > 0) over_print("Preloads...", overwrite=!transcript) pre.load.frame <- source_files(pre, gpar.frame) if(!is.environment(pre.load.frame)) stop("Argument `pre` could not be interpreted:\n", pre.load.frame) global$state("init") # mark post pre-load state # Masked base functions util.frame <- new.env(parent=pre.load.frame) assign("quit", unitizer_quit, envir=util.frame) assign("q", unitizer_quit, envir=util.frame) if(show.progress > 0) over_print("Loading unitizer data...", overwrite=!transcript) eval.which <- seq_along(store.ids) start.len <- length(eval.which) valid <- rep(TRUE, length(eval.which)) updated <- rep(FALSE, length(eval.which)) # Track which unitizers were updated unitizers <- new("unitizerObjectList") # Set up dummy unitizers; needed for bookmark stuff to work unitizers[valid] <- replicate(start.len, new("unitizer")) tests.parsed <- replicate(start.len, expression()) # - Evaluate / Browse -------------------------------------------------------- # Because of the nature of how we capture errors, we cannot wrap this entire # block in a try-catch. We also must ensure that the reset and unshim business # which we registered on.exit earlier is run if there is an unexpected # failure, and that the user is informed this happened. To handle expected # failure cases, with use restarts, which is a horrible hack but we painted # ourselves into a corner. We could not do it, but then users would get a # confusing message about unexpected failure, when it really was expected. expected.exit.reason <- "" upgrade.warned <- FALSE withRestarts( # Parse, and use `eval.which` to determine which tests to evaluate. This # loops will keep going so long as there are unitizers requiring review. while( (length(eval.which) || mode == identical(mode, "review")) && length(valid) ) { # kind of implied in `eval.which` after first loop active <- intersect(eval.which, which(valid)) # Parse tests tests.parsed.prev <- tests.parsed if(identical(mode, "unitize")) { if(show.progress > 0) over_print("Parsing tests...", overwrite=!transcript) tests.parsed[active] <- lapply( test.files[active], function(x) { if(show.progress > 1) over_print( paste("Parsing", relativize_path(x)), overwrite=!transcript ) parse_tests(x, comments=TRUE) } ) } # Retrieve bookmarks so they are not blown away by re-load; make sure to # mark those that have had changes to the parse data bookmarks <- lapply( seq_along(unitizers), function(i) { utz <- unitizers[[i]] if(is(utz, "unitizer") && is(utz@bookmark, "unitizerBrowseBookmark")) { # compare expressions without attributes if( !isTRUE( all.equal( as.list(tests.parsed.prev[[i]]), as.list(tests.parsed[[i]]), check.attributes=FALSE ) ) ) { utz@bookmark@parse.mod <- TRUE } utz@bookmark } } ) # Load / create all the unitizers; note loading envs with references to # namespace envs can cause state to change so we need to record it here; # also, `global` is attached to the `unitizer` here unitizers[active] <- load_unitizers( store.ids[active], test.files[active], par.frame=util.frame, interactive.mode=interactive.mode, mode=mode, global=global, show.progress=show.progress, transcript=transcript ) global$state() # Reset the bookmarks for(i in seq_along(unitizers)) if(valid[[i]]) unitizers[[i]]@bookmark <- bookmarks[[i]] # Now evaluate, whether a unitizer is evaluated or not is a function of # the slot @eval, set just above as they are loaded if(identical(mode, "unitize")) { if(show.progress > 0) { over_print("Evaluating tests...", overwrite=!transcript) over_print("", overwrite=!transcript) } unitizers[valid] <- unitize_eval( tests.parsed=tests.parsed[valid], unitizers=unitizers[valid], global=global, show.progress=show.progress, transcript=transcript ) } # Check whether any unitizers were upgraded and require review. We used # to ask before upgrade, but now we just upgrade and check before we # review. This is so we can upgrade unitizers without forcing an # interactive session if the class changed so folks don't have to resubmit # to CRAN each time we do this. if(!upgrade.warned && interactive.mode) { # Don't warn about upgrade in non-interactive as we won't save them upgrade.warned <- TRUE upgrade_warn(unitizers[valid], interactive.mode, global) } # Gather user input, and store tests as required. Any unitizers that # the user marked for re-evaluation will be re-evaluated in this loop unitizers[valid] <- unitize_browse( unitizers=unitizers[valid], mode=mode, interactive.mode=interactive.mode, force.update=force.update, auto.accept=auto.accept, history=history, global=global, use.diff=use.diff, show.progress=show.progress, transcript=transcript ) # Track whether updated, valid, etc. updated.new <- vapply(as.list(unitizers[valid]), slot, logical(1L), "updated") updated[valid][updated.new] <- TRUE eval.which.valid <- which( vapply(as.list(unitizers[valid]), slot, logical(1L), "eval") ) eval.which <- which(valid)[eval.which.valid] if(identical(mode, "review")) break }, # Expected Failure restarts unitizerInteractiveFail=function(e) expected.exit.reason <<- "in non-interactive mode", unitizerUserNoUpgrade=function(e) expected.exit.reason <<- "without upgrading unitizers" ) on.exit(NULL) # maybe to avoid inf loop if err in reset? reset_and_unshim(global) if(nzchar(expected.exit.reason)) stop("Cannot proceed ", expected.exit.reason, ".") # since we reload the unitizer, we need to note whether it was updated at # least once since that info is lost for(i in which(updated)) unitizers[[i]]@updated.at.least.once <- TRUE # - Finalize ----------------------------------------------------------------- # return env on success, char on error post.res <- source_files(post, pre.load.frame) if(!is.environment(post.res)) meta_word_msg( "`unitizer` evaluation succeed, but `post` steps had errors:", post.res ) # need to pull out the result data to returns as part of result, and assemble # it into final result object; we're not able to do that earlier in the # process due to issues with how S4 classes deal with S3 classes in their # slots (don't want to use setOldClass, and inheritance not recognized) extractResults(unitizers) } # Evaluate User Tests # # @param tests.parsed a list of expressions # @param unitizers a list of \code{unitizer} objects of same length as # \code{tests.parsed} # @param which integer which of \code{unitizer}s to actually eval, all get # summary status displayed to screen # @return a list of unitizers # @keywords internal unitize_eval <- function( tests.parsed, unitizers, global, show.progress, transcript ) { test.len <- length(tests.parsed) if(!identical(test.len, length(unitizers))) # nocov start stop( "Internal Error: parse data and unitizer length mismatch; contact ", "maintainer." ) # nocov end # Set up display stuff num.digits <- as.integer(ceiling(log10(test.len + 1L))) tpl <- paste0("%", num.digits, "d/", test.len) # Loop through all unitizers, evaluating the ones that have been marked with # the `eval` slot for evaluation, and resetting that slot to FALSE for(i in seq(length.out=test.len)) { test.dat <- tests.parsed[[i]] unitizer <- unitizers[[i]] if(unitizer@eval) { # reset global settings if active to just after pre-loads (DO WE NEED TO # CHECK WHETHER THIS MODE IS ENABLED, OR IS IT HANDLED INERNALLY?) tests <- new("unitizerTests") + test.dat if(test.len > 1L && show.progress > 1L) over_print( paste0(sprintf(tpl, i), " ", basename(unitizer@test.file.loc), ": "), overwrite=!transcript ) unitizers[[i]] <- unitizer + tests global$resetInit() if( global$ns.opt.conflict@conflict && !length(global$ns.opt.conflict@file) ) global$ns.opt.conflict@file <- basename(unitizer@test.file.loc) unitizers[[i]]@eval <- FALSE ## Attach the compressed state for reference; previously we used to do ## this outside of the state, doing it for every test file irrespective of ## whether it was re-evaled or not, but that was expensive. Now only ## doing it for re-evaled ones (hopefully not introducing bugs in process) glob.opts <- Filter(Negate(is.null), lapply(global$tracking@options, names)) glob.opts <- if(!length(glob.opts)) character(0L) else unique(unlist(glob.opts)) no.track <- c( unlist( lapply( union( global$unitizer.opts[["unitizer.opts.asis.base"]], global$unitizer.opts[["unitizer.opts.asis"]] ), grep, glob.opts ) ), match( names( merge_lists( global$unitizer.opts[["unitizer.opts.init.base"]], global$unitizer.opts[["unitizer.opts.init"]], ) ), glob.opts, nomatch=0L, ) ) unitizers[[i]]@state.new <- unitizerCompressTracking( global$tracking, glob.opts[no.track] ) } else { unitizers[[i]] <- unitizer } } unitizers } # Run User Interaction And \code{unitizer} Storage # # @keywords internal # @inheritParams unitize_core # @param unitizers list of \code{unitizer} objects # @param force.update whether to store unitizer unitize_browse <- function( unitizers, mode, interactive.mode, force.update, auto.accept, history, global, use.diff, show.progress, transcript ) { # - Prep --------------------------------------------------------------------- if(!length(unitizers)) { # happens when all unitizers fail to load meta_word_msg("No valid unitizers available to review.") return(unitizers) } if(show.progress > 0) over_print("Prepping Unitizers...", overwrite=!transcript) hist.obj <- history_capt(history, interactive.mode) on.exit(history_release(hist.obj)) # Get summaries test.len <- length(unitizers) summaries <- summary(unitizers, silent=TRUE) to.review <- to_review(summaries) # Determine implied review mode (all tests passed in a particular unitizer, # but user may still pick it to review); we got lazy and tried to leverage # the review mechanism for passed tests, but this is not ideal because then # we're using reference items instead of the newly evaluated versions. Will # switch this, but still have to deal with situations where a new state # doesn't exist (in particular, deleted tests) untz.browsers <- mapply( browsePrep, as.list(unitizers), mode=mode, start.at.browser=(identical(mode, "review") | !to.review) & !force.update, MoreArgs=list( hist.con=hist.obj$con, interactive=interactive.mode, use.diff=use.diff ), SIMPLIFY=FALSE ) # Decide what to keep / override / etc. # Apply auto-accepts, if any (shouldn't be any in "review mode") # NOTE: are there issues with auto-accepts when we run this function more # than once, where previous choices are over-written by the auto-accepts? # maybe auto-accepts only get applied first time around? eval.which <- integer(0L) if(length(auto.accept)) { if(show.progress > 0) over_print("Applying auto-accepts...", overwrite=!transcript) for(i in seq_along(untz.browsers)) { auto.accepted <- 0L for(auto.val in auto.accept) { auto.type <- which( tolower(untz.browsers[[i]]@mapping@review.type) == auto.val ) untz.browsers[[i]]@mapping@review.val[auto.type] <- "Y" untz.browsers[[i]]@mapping@reviewed[auto.type] <- TRUE auto.accepted <- auto.accepted + length(auto.type) # not used? } if(auto.accepted) untz.browsers[[i]]@auto.accept <- TRUE } } # Generate default browse data for all unitizers; the unitizers that are # actually reviewed will get further updated later for(i in seq_along(unitizers)) { unitizers[[i]]@res.data <- as.data.frame(untz.browsers[[i]]) } # Browse, or fail depending on interactive mode reviewed <- int.error <- logical(test.len) if(show.progress > 0) over_print("", overwrite=!transcript) # Re-used message # - Interactive -------------------------------------------------------------- # Check if any unitizer has bookmark set, and if so jump directly to # that unitizer (note we can only bookmark one at a time) bookmarked <- bookmarked(unitizers) if(test.len > 1L && !any(bookmarked)) show(summaries) quit <- FALSE # If any conflicts in state tracking are detected, alert user and give them # a chance to bail out if(global$ns.opt.conflict@conflict) { many <- length(global$ns.opt.conflict@namespaces) meta_word_msg( "`unitizer` was unable to run with `options` state tracking enabled ", "starting with ", if(!nchar(global$ns.opt.conflict@file)) "the first test file" else paste0("test file \"", global$ns.opt.conflict@file, "\""), " because the following namespace", if(many > 1L) "s", " could not be ", "unloaded: ", char_to_eng( sprintf("`%s`", sort(global$ns.opt.conflict@namespaces)), "", "" ), ".", sep="" ) if(interactive.mode) { meta_word_msg( "You may proceed normally but be aware that option state was not ", "managed starting with the file in question, and option state will ", "not be managed during review, or restored to original values after ", "`unitizer` completes evaluation. You may quit `unitizer` now to ", "avoid any changes. See `?unitizerState` for more details.", sep="" ) proceed <- "Do you wish to proceed despite compromised state tracking" meta_word_cat(proceed, "([Y]es, [N]o)?\n") prompt <- unitizer_prompt( "Do you wish to proceed despite compromised state tracking", valid.opts=c(Y="[Y]es", N="[N]o"), exit.condition=exit_fun, valid.vals=seq.int(test.len), hist.con=hist.obj$con, help=help, global=global, browse.env=new.env(parent=unitizers[[1L]]@zero.env) ) if(prompt %in% c("N", "Q") && confirm_quit(unitizers)) quit <- TRUE } else { stop( word_wrap(collapse="\n", cc( "Unable to proceed in non-interactive mode; set options state ", "tracking to a value less than or equal to search path state ", "tracking or see vignette for other workarounds." ) ) ) } } if(!quit) { if(identical(mode, "review") || any(to.review) || force.update) { # We have fairly different treatment for a single test versus multi-test # review, so the logic gets a little convoluted (keep eye out for) # `test.len > 1L`, but this obviates the need for multiple different calls # to `browseUnitizers` # Additional convolution introduced given the need to handle the # possibility of auto.accepts in non-interactive mode, and since for ease # of implementation we chose to do auto.accepts through `browseUnitizer`, # we need to add some hacks to handle that outcome since by design # originally the browse stuff was never meant to handle non-interactive # use... first.time <- TRUE repeat { prompt <- paste0( "Type number of unitizer to review", if(any(to.review)) ", 'A' to review all that require review", if(any(summaries@updated)) ", 'R' to re-run all updated" ) help.opts <- c( paste0(deparse(seq.int(test.len)), ": unitizer number to review"), if(any(to.review)) "A: Review all `unitzers` that require review (*)", "AA: Review all tests", if(any(summaries@updated)) "R: Re-run all updated unitizers ($)", "RR: Re-run all tests", "Q: quit" ) help <- "Available options:" # Show summary if applicable if(!first.time && !any(bookmarked)) { if(!interactive.mode) # nocov start stop( "Internal Error: looping for user input in non-interactive mode, ", "contact maintainer." ) # nocov end show(summaries) } first.time <- FALSE eval.which <- integer(0L) if(any(bookmarked)) { pick.num <- which(bookmarked) } else if(test.len > 1L) { pick.num <- integer() pick <- if(interactive.mode) { meta_word_cat(prompt) unitizer_prompt( "Pick a unitizer or an option", valid.opts=c( A=if(any(to.review)) "[A]ll", R=if(any(summaries@updated)) "[R]erun", AA="", RR="" ), exit.condition=exit_fun, valid.vals=seq.int(test.len), hist.con=hist.obj$con, help=help, help.opts=help.opts, global=global, browse.env=new.env(parent=unitizers[[1L]]@zero.env) ) } else { # in non.interactive mode, review all, this will apply auto.accepts # if successfull "A" } if(identical(pick, "Q")) { if(confirm_quit(unitizers)) break else next } else if(identical(pick, "A")) { pick.num <- which(to.review & !summaries@updated) } else if(identical(pick, "AA")) { pick.num <- seq.int(test.len) } else if(identical(pick, "R")) { eval.which <- which(summaries@updated) } else if(identical(pick, "RR")) { eval.which <- seq.int(test.len) } else { pick.num <- as.integer(pick) if(!pick.num %in% seq.int(test.len)) { # nocov start enforced by valid.vals in `unitizer_prompt` stop( "Internal Error: should not be able to pick a number that ", "does not correspond to a `unitizer`, contact maintainer." ) # we used to do next before we added error here; should still work # if we need to revert next # nocov end } } } else pick.num <- 1L for(i in pick.num) { print( H1( paste0( "unitizer for: ", getName(unitizers[[i]]), collapse="" ) ) ) # summaries don't really work well in review mode if the tests are # not evaluated if(identical(untz.browsers[[i]]@mode, "unitize")) show(summaries[[i]]) # If reviewing multiple unitizers, mark as much so we have a mechanism # to quit the muti-unitizer review process if(length(pick.num) > 1L) untz.browsers[[i]]@multi <- TRUE # annoyingly we need to force update here as well as for the # unreviewed unitizers browse.res <- browseUnitizer( unitizers[[i]], untz.browsers[[i]], force.update=force.update, use.diff=use.diff ) summaries@updated[[i]] <- browse.res@updated unitizers[[i]] <- browse.res@unitizer unitizers[[i]]@res.data <- browse.res@data int.error[[i]] <- browse.res@interactive.error # Check for breakout conditions; re-eval will cause a break-out (i.e. # we stop review and resume later. if(identical(browse.res@re.eval, 1L)) { eval.which <- i # Dummy-bookmark all subsequent unitizers so that they are # re-reviewed if they were scheduled for review via e.g. 'A' to.rebookmark <- pick.num[pick.num > i] for(j in to.rebookmark) unitizers[[j]]@bookmark <- new("unitizerBrowseBookmark", call=NA_character_) break } else if(identical(browse.res@re.eval, 2L)) { # All re-eval clears the bookmarks (there should only be one, but # we're lazy here and clear all) for(j in seq.int(test.len)) unitizers[[j]]@bookmark <- NULL eval.which <- seq.int(test.len) break } else if(browse.res@multi.quit) break } # Update bookmarks (in reality, we're just clearing the bookmark if it # was previously set, as setting the bookmark will break out of this # loop). bookmarked <- bookmarked(unitizers) # - Non-interactive Issues --------------------------------------------- if(any(int.error)) { if(interactive.mode) # nocov start stop( "Internal Error: should not get here in interactive mode; ", "contact maintainer" ) # nocov end # Problems during non-interactive review; we only allow this as a # mechanism for allowing auto-accepts in non-interactive mode for(i in which(int.error)) { untz <- unitizers[[i]] delta.show <- untz@tests.status != "Pass" & !ignored(untz@items.new) rem.show <- which(!ignored(untz@items.ref) & is.na(untz@items.ref.map)) meta_word_msg( paste0( " * ", format( paste0( c( as.character(untz@tests.status[delta.show]), rep_len("Removed", length(rem.show)) ), ": " ) ), c( untz@items.new.calls.deparse[delta.show], untz@items.ref.calls.deparse[rem.show] ), collapse="\n" ), "\nin '", relativize_path(untz@test.file.loc), "'\n", sep="" ) } non.zero <- which(summaries@totals > 0) meta_word_msg(sep="", "Newly evaluated tests do not match unitizer (", paste( names(summaries@totals[non.zero]), summaries@totals[non.zero], sep=": ", collapse=", " ), "); see above for more info, or run in interactive mode." ) if(transcript) { meta_word_msg( paste0( "Running in transcript mode: only ", "stderr text that is also part of a signalled condition is ", "in the test review section (scroll up to the evaluation ", "section for the rest). See `transcript` ", "parameter in `?unitize`." ) ) } invokeRestart("unitizerInteractiveFail") } # - Simple Outcomes / no-review ----------------------------------------- if(identical(test.len, 1L) || length(eval.which) || !interactive.mode) break } } else { pass.num <- summary(unitizers, silent=TRUE)@totals["Pass"] meta_word_msg( pass.num , "/", pass.num, " test", if(pass.num != 1) "s", " passed; ", "nothing to review.", sep="" ) } } else eval.which <- integer(0L) # we quit, so don't want to re-evalute anything # Set eval status before return if(length(eval.which)) { for(i in eval.which) unitizers[[i]]@eval <- TRUE } else { # this one may not be necessary for(i in seq_along(unitizers)) unitizers[[i]]@eval <- FALSE } unitizers } # @param x unitizerList summaries # @return logical same length as `x` with TRUE for each unitizer requiring # review. to_review <- function(x) { totals <- vapply(as.list(x), slot, x[[1L]]@totals, "totals") # First row will be passed colSums(totals[-1L, , drop=FALSE]) > 0L } # Check Not Running in Undesirable Environments # # Make sure not running inside withCallingHandlers / withRestarts / tryCatch # or other potential issues; of course this isn't foolproof if someone is using # a variation on those functions, but also not the end of the world if it isn't # caught # # @keywords internal check_call_stack <- function() { call.stack <- sys.calls() if( any( vapply( call.stack, FUN.VALUE=logical(1L), function(x) is.symbol(x[[1]]) && as.character(x[[1]]) %in% c("withCallingHandlers", "withRestarts", "tryCatch") ) ) ) warning( word_wrap(collapse="\n", cc( "It appears you are running unitizer inside an error handling ", "function such as `withCallingHanlders`, `tryCatch`, or ", "`withRestarts`. This is strongly discouraged as it may cause ", "unpredictable behavior from unitizer in the event tests produce ", "conditions / errors. We strongly recommend you re-run ", "your tests outside of such handling functions." ) ), immediate.=TRUE ) restarts <- computeRestarts() restart.names <- vapply(restarts, "[[", character(1L), 1L) reserved.restarts <- c( "unitizerInteractiveFail", # Need to be interactive to continue "unitizerUserNoUpgrade", # User denied approval to continue "unitizerEarlyExit", # Internally used to Q from a unitizer "unitizerInterrupt" # In faux prompt to catch CTRL+C ) if(any(res.err <- reserved.restarts %in% restart.names)) { many <- sum(res.err) > 1L stop( word_wrap(collapse="\n", cc( deparse(reserved.restarts[res.err], width.cutoff=500L), " restart", if(many) "s are" else " is", " already defined; ", "unitizer relies on ", if(many) "these restarts" else "this restart ", "to manage evaluation so unitizer will not run if ", if(many) "they are" else "it is", " defined outside of `unitize`. ", "If you did not define ", if(many) "these restarts" else "this restart", " contact maintainer." ) ) ) } } #' Helper function for validations #' #' @keywords internal validate_pre_post <- function(what, test.dir) { which <- deparse(substitute(what)) stopifnot( which %in% c("pre", "post"), (is.character(test.dir) && length(test.dir) == 1L) || is.null(test.dir) ) if( !is.null(what) && !identical(what, FALSE) && !is.character(what) ) stop( simpleError( message=paste0( "Argument `", which, "` must be NULL, FALSE, or character" ), call=sys.call(-1L) ) ) if(is.null(what) && !is.null(test.dir)) { tmp <- file.path(test.dir, sprintf("_%s", which)) if(file_test("-d", tmp)) tmp else character(0L) } else if (is.character(what)) { what } else character(0L) } # Helper function for global state stuff # # Maybe this should be a global method? # # @keywords internal reset_and_unshim <- function(global) { stopifnot(is(global, "unitizerGlobal")) glob.clear <- try(global$resetFull()) glob.unshim <- try(global$unshimFuns()) glob.release <- try(global$release()) success.clear <- !inherits(glob.clear, "try-error") success.unshim <- !inherits(glob.unshim, "try-error") success.release <- !inherits(glob.release, "try-error") if(!success.clear) meta_word_msg( "Failed restoring global settings to original state; you may want", "to restart your R session to ensure all global settings are in a", "reasonable state." ) if(!success.unshim) meta_word_msg( "Failed unshimming library/detach/attach; you may want to restart", "your R session to reset them to their original values (or you", "can `untrace` them manually)." ) if(!success.release) meta_word_msg( "Failed releasing global tracking object; you will not be able to", "instantiate another `unitizer` session. This should not happen, ", "please contact the maintainer. In the meantime, restarting your R", "session should restore functionality." ) success.clear && success.unshim } # Prompt to Quit if Enough Time Spent on Evaluation # @keywords internal confirm_quit <- function(unitizers) { stopifnot(is(unitizers, "unitizerList")) if( length(unitizers) && Reduce(`+`, lapply(as.list(unitizers), slot, "eval.time")) > unitizers[[1L]]@global$unitizer.opts[["unitizer.prompt.b4.quit.time"]] ) { meta_word_cat("Are you sure you want to quit?") ui <- unitizer_prompt( "Quit", valid.opts=c(Y="[Y]es", N="[N]o"), global=unitizers[[1L]]@global, browse.env=new.env(parent=unitizers[[1L]]@zero.env) ) return(!identical(ui, "N")) } TRUE } PROGRESS.MAX <- 3L unitizer/R/section.R0000644000176200001440000002520014766360070014123 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R #' @include item.sub.R #' @include class_unions.R NULL #' Contains Representation For a Section of Tests #' #' \code{unitizerSectionExpression-class} contains the actual expressions that #' belong to the section, whereas \code{unitizerSection-class} only contains #' the meta data. The latter objects are used within \code{]unitizer-class}, #' whereas the former is really just a temporary object until we can generate #' the latter. #' #' \code{unitizerSectionNA-class} is a specialized section for tests that actually #' don't have a section (removed tests that are nonetheless chosen to be kept #' by user in interactive environment) #' #' @keywords internal #' @aliases unitizerSectionExpression-class unitizerSectionNA-class #' @slot title 1 lenght character, the name of the section #' @slot details character vector containing additional info on the section #' @slot compare functions to compare the various aspects of a #' \code{unitizerItem-class} @slot length tracks size of the section setClass( "unitizerSection", representation( title="character", details="character", compare="testFuns", length="integer", parent="integer" ), prototype(parent=NA_integer_, length=0L), validity=function(object) { if(length(object@title) != 1L) return("slot `@title` must be length 1") if(length(object@length) != 1L | object@length < 0L) { return("slot `@length` must be length 1 and >= 0") } if(length(object@parent) != 1L) return("slot `@parent` must be a 1 length integer") } ) setMethod("initialize", "unitizerSection", function(.Object, ...) { if(!("title" %in% (dot.names <- names(list(...))))) { return(callNextMethod(.Object, title="", ...)) } else if(is.null(list(...)$title)) { return(do.call(callNextMethod, c(list(.Object, title=""), list(...)[dot.names != "title"]))) } callNextMethod() } ) setClass( "unitizerSectionNA", contains="unitizerSection", prototype=list( title="", details="Dummy section for section-less tests." ) ) setClass("unitizerSectionExpression", contains="unitizerList", representation( title="characterOrNULL", details="character", compare="testFuns" ) ) setClassUnion("unitizerSectionExpressionOrExpression", c("unitizerSectionExpression", "unitizerSection", "expression")) #' Compute Length of a \code{unitizerSection-class} #' #' @keywords internal #' @param x a \code{unitizerSection} object setMethod("length", "unitizerSection", function(x) x@length) #' Define a \code{unitizer} Section #' #' The purpose of \code{unitizer} sections is to allow the user to tag a #' group of test expressions with meta information as well as to modify #' how tests are determined to pass or fail. #' #' @section Tested Data: #' #' \code{unitizer} tracks the following: #' \itemize{ #' \item value: the return value of the test #' \item conditions: any conditions emitted by the test (e.g. warnings or #' errors) #' \item output: screen output #' \item message: stderr output #' \item aborted: whether the test issued an `abort` restart (e.g. by calling #' `stop` directly or indirectly) #' } #' In the future stdout produced by the test expression itself may be captured #' separately from that produced by print/showing of the return value, but at #' this point the two are combined. #' #' Each of the components of the test data can be tested, although by default #' only \code{value} and \code{condition} are checked. Testing \code{output} is #' potentially duplicative of testing \code{value}, since most often #' \code{value} is printed to screen and the screen output of the value closely #' correlates to the actual value. In some cases it is useful to explicitly #' test the \code{output}, such as when testing \code{print} or \code{show} #' methods. #' #' @section Comparison Functions: #' #' The comparison function should accept at least two parameters, and #' require no more than two. For each test component, the comparison function #' will be passed the reference data as the first argument, and the newly #' evaluated data as the second. The function should return TRUE if the #' compared test components are considered equivalent, or FALSE. Instead of #' FALSE, the function may also return a character vector describing the #' mismatch, as \code{\link{all.equal}} does. #' #' \bold{WARNING}: Comparison functions that set and/or unset \code{\link{sink}} #' can potentially cause problems. If for whatever reason you must really sink #' and unsink output streams, please take extreme care to restore the streams to #' the state they were in when the comparison function was called. #' #' Any output to \code{stdout} or \code{stderr} is captured and only checked at #' the end of the \code{unitizer} process with the expectation that there will #' be no such output. #' #' \code{value} and \code{conditions} are compared with \code{\link{all_eq}}, #' which is a wrapper to \code{\link{all.equal}} except that it returns FALSE #' instead of a descriptive string on failure. This is because \code{unitizer} #' will run \code{\link[diffobj]{diffObj}} on the test data components that do #' not match and including the \code{all.equal} output would be redundant. #' #' If a comparison function signals a condition (e.g. throws a warning) the #' test will not be evaluated, so make sure that your function does not signal #' conditions unless it is genuinely failing. #' #' If you wish to provide custom comparison functions you may do so by passing #' an appropriately initialized \code{\link{testFuns}} object as the #' value to the \code{compare} parameter to \code{unitizer_sect} #' (see examples). #' #' Make sure your comparison functions are available to \code{\link{unitize}}. #' Comparisons will be evaluated in the environment of the test. By default #' \code{\link{unitize}} runs tests in environments that are not children to #' the global environment, so functions defined there will not be automatically #' available. You can either specify the function in the test file before the #' section that uses it, or change the base environment tests are evaluated in #' with \code{unitize(..., par.env)}, or make sure that the package that #' contains your function is loaded within the test script. #' #' @section Nested Sections: #' #' It is possible to have nested sections, but titles, etc. are ignored. The #' only effect of nested sections is to allow you to change the comparison #' functions for a portion of the outermost \code{unitizer_sect}. #' #' @note if you want to modify the functions used to compare conditions, #' keep in mind that the conditions are stored in \code{\link{conditionList}} #' objects so your function must loop through the lists and compare conditions #' pairwise. By default \code{unitizer} uses the \code{all.equal} method for S4 #' class \code{conditionList}. #' #' @note \code{untizer} does not account for sections when matching new and #' reference tests. All tests will be displayed as per the section they belong #' to in the newest version of the test file, irrespective of what section they #' were in when the tests were last run. #' #' @note Calls to \code{unitizer_sect} should be at the top level of your test #' script, or nested within other \code{unitizer_sect}s (see "Nested Sections"). #' Do not expect code like \code{(untizer_sect(..., ...))} or #' \code{{unitizer_sect(..., ...)}} or \code{fun(unitizer_sect(..., ...))} to #' work. #' #' @export #' @seealso \code{\link{testFuns}}, \code{\link{all_eq}} #' @param title character 1 length title for the section, can be omitted #' though if you do omit it you will have to refer to the subsequent #' arguments by name (i.e. \code{unitizer_sect(expr=...)}) #' @param expr test expression(s), most commonly a call to \code{{}} with #' several calls inside (see examples) #' @param details character more detailed description of what the purpose #' of the section is; currently this doesn't do anything. #' @param compare a function or a \code{\link{testFuns}} object #' @examples #' unitizer_sect("Switch to `all.equal` instead of `all_eq`", #' { #' fun(6L) #' fun("hello") #' }, #' compare=testFuns(value=all.equal, conditions=all.equal) #' ) #' unitizer_sect("Use identical for ALL test data, including stdout, etc.", #' { #' fun(6L) #' fun("hello") #' }, #' compare=identical #' ) unitizer_sect <- function( title=NULL, expr=expression(), details=character(), compare=new("testFuns") ) { if(!is(compare, "testFuns") && !is.function(compare)) stop("Argument `compare` must be \"testFuns\" or a function") if(!is.character(details)) stop("Argument `details` must be character") if(!is.null(title) && (!is.character(title) || length(title) != 1L)) stop("Argument `title` must be a 1 length character vector.") exp.sub <- substitute(expr) if(is.call(exp.sub) && is.symbol(exp.sub[[1L]])) expr <- exp.sub if(is.call(expr)) { if(identical(expr.sub.eval <- eval(expr[[1L]], parent.frame()), base::"{")) { expr <- do.call(expression, as.list(expr[-1L])) } else if (identical(expr.sub.eval, base::expression)) { expr <- eval(expr, parent.frame()) } } if(!is.expression(expr)) { stop( "Argument `expr` must be an expression, or an unevaluated call that ", "evaluates to an expression or `{`." ) } if(!is(compare, "testFuns")) { fun.name <- deparse_fun(substitute(compare)) if(!isTRUE(err.fun <- is.two_arg_fun(compare))) { stop( "Argument `compare`, if a function, must accept two arguments and ", "require no more than two (", err.fun, ")" ) } compare <- new( "testFuns", value=new("unitizerItemTestFun", fun=compare, fun.name=fun.name) ) } if(length(expr) < 1L) { warning("`unitizer_sect` \"", strtrunc(title, 15), "\" is empty.") return(NULL) } attempt <- try(new("unitizerSectionExpression", title=title, .items=expr, details=details, compare=compare)) if(inherits(attempt, "try-error")) stop("Failed instantiating `unitizerSection`; see previous error for details.") attempt } unitizer/R/is.R0000644000176200001440000000631414766101401013066 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Confirm Object is In \code{package_version} form # @keywords internal is.package_version <- function(x) inherits(x, "package_version") && inherits(x, "numeric_version") && is.list(x) && identical(length(x), 1L) # Test for plain characterness # # Test for common scalar cases that we run into ALL THE TIME!!! # # @rdname is.simpleobj # @keywords internal # @param x object to test is.chr1plain <- function(x) !is.object(x) && is.character(x) && identical(length(x), 1L) # @rdname is.simpleobj # @keywords internal is.chr1 <- function(x) is.character(x) && length(x) == 1L && !is.na(x) # @rdname is.simpleobj # @keywords internal is.TF <- function(x) isTRUE(x) || identical(x, FALSE) # @rdname is.simpleobj # @keywords internal is.lgl.1L <- function(x) is.logical(x) && length(x) == 1L # @rdname is.simpleobj # @keywords internal is.int.pos.2L <- function(x) is.numeric(x) && length(x) == 2L && !any(is.na(x)) && all.equal(x, round(x)) && all(x > 0L) is.int.pos.1L <- function(x) is.numeric(x) && length(x) == 1L && !any(is.na(x)) && all.equal(x, round(x)) && all(x > 0L) is.int.1L <- function(x) is.numeric(x) && length(x) == 1L && !any(is.na(x)) && all.equal(x, round(x)) is.screen.out.vec <- function(x) is.numeric(x) && length(x) == 2L && !any(is.na(x)) && all(x > 1) && x[1] >= x[2] && all.equal(round(x), x) is.context.out.vec <- function(x) is.numeric(x) && length(x) == 2L && !any(is.na(x)) && all(x > 0) && x[1] >= x[2] && all.equal(round(x), x) # Check Whether Provided Store ID Is in Default Form # # @keywords internal is.default_unitizer_id <- function(x) is.chr1plain(x) && !is.na(x) is.valid_capt_setting <- function(x) { if( !is.logical(x) || length(x) != 2L || any(is.na(x)) || !identical(names(x), c("output", "message")) ) { meta_word_msg( "value must be logical(2L) containing TRUE ", "/ FALSE and with names `c(\"output\", \"message\")" ) return(FALSE) } TRUE } is.two_arg_fun <- function(x) { if(!is.function(x)) { "is not a function" } else if( length(formals(x)) < 2L && !identical(head(names(formals(x)), 1L), "...") ) { "does not have at least two arguments" } else { nm.forms <- vapply(formals(x), is.name, logical(1L)) forms.chr <- character(length(nm.forms)) forms.chr[nm.forms] <- as.character(formals(x)[nm.forms]) if( any( tail(!nzchar(forms.chr) & nm.forms & names(nm.forms) != "..." , -2L) ) && !identical(head(names(nm.forms), 1L), "...") ) "cannot have any non-optional arguments other than first two" else TRUE } } unitizer/R/deparse.R0000644000176200001440000001146714766103210014103 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Returns a Character Function Name From A Language Object # # Note this doesn't really try to check too hard whether the \code{`x`} is # indeed a function. # # @param x a call or a symbol # @return character 1 length if a function name, NA if an anonymous function, or # character(0L) if neither deparse_fun <- function(x) { if(is.symbol(x)) { as.character(x) } else if (is.call(x)) { NA_character_ } else { character(0L) } } # Deparse, But Make It Look Like It Would On Prompt # # @return character vector deparse_prompt <- function(item) { prompt <- getOption("prompt") continue <- getOption("continue") pad.len <- max(nchar(c(prompt, continue))) # We don't have the reference all available, and we can't parse/deparse due to # roundtrip issues with e.g. encodings. expr.deparsed <- if(item@reference) { unlist(strsplit(item@call.dep, "\n")) } else { deparse(item@call, width.cutoff=min(60L, (getOption("width") - pad.len))) } if(length(expr.deparsed) < 1L) { # nocov start stop("Internal Error: don't know what to do with zero length expr") # nocov end } prompt.vec <- c(prompt, rep(continue, length(expr.deparsed) - 1L)) paste0(prompt.vec, expr.deparsed) } # Remove any comment attributes # # Used by the internal deparse functions. Really removes all attributes. # Resorting to desperate measures due to the reference like behavior of # expressions and messing with their attributes, most likely due to the # srcref style environment attributes. uncomment <- function(lang) { if(is.expression(lang)) { # should be a call or symbol or constant, not an expression # nocov start stop("Internal Error: unexpected expression; contact maintainer") # nocov end } lang.new <- if(!(missing(lang) || is.null(lang))) `attr<-`(lang, "comment", NULL) else lang if(is.call(lang.new) && length(lang.new) > 1) for(i in seq_along(lang.new)) { lang.tmp <- lang.new[[i]] if(!(missing(lang.tmp) || is.null(lang.tmp))) lang.new[[i]] <- Recall(lang.tmp) } lang.new } # Deparse, but only provide first X characters # # @param expr a language object # @param len int a one length integer noting how many characters we want # @param width passed on to deparse_peek <- function(expr, len, width=500L) { if(!is.integer(len) || length(len) != 1L || len < 4L) stop("Argument `len` must be an integer greater than four") if(!is.integer(width) || length(width) != 1L || width < 1L) stop("Argument `width` must be an integer greater than zero") chr <- paste0(sub("\n", " ", deparse(uncomment(expr), width)), collapse="") if(nchar(chr) > len) { paste0(substr(chr, 1L, len -3L), "...") } else { chr } } # Used to generate character values to store in cached deparse list # # @param expr language to deparse # @return character(1L) deparse_call <- function(expr) paste0(deparse(uncomment(expr)), collapse="\n") # Special Deparse # # Required to deal with language objects that contain non-language objects # that have attributes. # # Not completely fool proof since you can probably created an object that nests # call and non-call stuff repeatedly that would confuse this thing. # # This is just used to generate objects for tests, not actually part of # \code{unitizer} proper deparse_mixed <- function(expr, width.cutoff = 500L, control = "all", ...) { rec_lang <- function(expr) { if(!is.language(expr)) stop("Internal Error: expecting language object") # nocov if(length(expr) > 1L) { for(i in seq_along(expr)) { if(!is.language(expr[[i]])) { expr[[i]] <- parse( text=deparse( expr[[i]], width.cutoff=width.cutoff, control=control, ... ), keep.source=FALSE )[[1L]] } else expr[[i]] <- Recall(expr[[i]]) } } expr } rec_norm <- function(expr) { if(is.recursive(expr) && !is.environment(expr)) { for(i in seq_along(expr)) { if(is.language(expr[[i]])) { expr[[i]] <- rec_lang(expr[[i]]) } else { expr[[i]] <- Recall(expr[[i]]) } } } expr } deparse(rec_norm(expr), width.cutoff=width.cutoff, control=control, ...) } unitizer/R/text.R0000644000176200001440000005421214766101401013437 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. ## Display helper function ## ## @keywords internal screen_out <- function( txt, max.len=getOption("unitizer.test.out.lines"), file=stdout(), width=getOption("width") ) { if(!is.numeric(max.len) || !length(max.len) == 2 || max.len[[1]] < max.len[[2]]) stop( "Argument `max.len` must be a two length numeric vector with first value ", "greater than second" ) stopifnot(is.int.pos.1L(width)) if(length(txt)) { txt.trim <- unlist(strsplit(txt, "\n")) txt.wrap <- word_wrap(txt.trim, width=width) out.len <- length(txt.wrap) txt.proc <- txt.wrap[ 1L:min(out.len, if(out.len > max.len[[1]]) max.len[[2]] else Inf) ] if(sum(nchar(txt.proc))) cat(txt.proc, sep="\n", file=file) if(out.len > max.len[[1]]) { word_cat( "... truncated ", out.len - max.len[[2]], " line", if(out.len - max.len[[2]] > 1) "s", file=file, sep="" ) } } } ## Print Only First X characters ## ## @keywords internal ## @param x string to reduce length ## @param nchar.max how many characters to reduce each string to ## @param ctd 1 length character vector for what to use to indicate string ## truncated ## @param disambig logical 1L whether to disambiguate strings that end up ## the same after truncation (not currently implemented) ## @param from what side to truncate from strtrunc <- function( x, nchar.max=getOption("width"), ctd="...", disambig=FALSE, from="right" ) { if(!identical(disambig, FALSE)) stop("Parameter `disambig` not implemented") if(!is.character(x)) stop("Argument `x` must be character") if(!is.character(ctd) || !identical(length(ctd), 1L)) stop("Argument `ctd` must be 1 length character") if(!is.numeric(nchar.max) || !identical(length(nchar.max), 1L)) stop("Argument `nchar.max` must be 1 length numeric") if( !is.character(from) || length(from) != 1L || is.na(from) || !from %in% c("left", "right") ) stop( "Argument `from` must be character(1L) %in% c(\"left\", \"right\") ", "and not NA" ) if(all(nchar(x) <= nchar.max)) { x } else { len.target <- nchar.max - nchar(ctd) if(len.target < 1L) stop("`nchar.max` too small, make bigger or make `ctd` shorter.") chars <- nchar(x) pre <- post <- "" if(identical(from, "right")) { start <- 1L stop <- len.target post <- ctd } else { start <- chars - len.target + 1L stop <- chars pre <- ctd } ifelse( nchar(x) <= nchar.max, x, paste0(pre, substr(x, start, stop), post) ) } } #' Text Wrapping Utilities #' #' Functions to break up character vector components to a specified width. #' #' \itemize{ #' \item \code{text_wrap} breaks each element to a specified \code{width}, #' where \code{width} can contain different values for each value in #' \code{x} #' \item \code{word_wrap} wraps at whitespace, or crudely hyphenates if #' necessary; note that unlike \code{text_wrap} \code{width} must be scalar #' \item \code{word_cat} is like \code{word_wrap}, except it outputs to screen #' \item \code{word_msg} is like \code{word_cat}, except it ouputs to stderr #' \item \code{meta_word_cat} is like \code{word_cat}, except it wraps output #' in formatting to highlight this is not normal output #' } #' #' Newlines are replaced by empty strings in the output so that each character #' vector in the output represents a line of screen output. #' #' @keywords internal #' @return a list with, for each item in \code{x}, a character vector #' of the item wrapped to length \code{width} #' @param x character vector #' @param width what width to wrap at #' @param tolerance how much earlier than \code{width} we're allowed to wrap #' @param hyphens whether to allow hyphenation #' @param unlist logical(1L) if FALSE each element in \code{x} is returned as #' an element of a list, otherwise one character vector is returned #' @return if \code{unlist} is a parameter, then a character vector, or #' if not or if \code{unlist} is FALSE, a list with each element from \code{x} #' corresponding to an element from the list text_wrap <- function(x, width) { if( !is.character(x) || !is.numeric(width) || any(width < 1L) || !identical(round(width), as.numeric(width)) ) { stop("Arguments `x` and `width` must be character and integer like (all values >= 1) respectively") } if(!identical((length(x) %% length(width)), 0L)) { stop("Argument `x` must be a multiple in length of argument `width`") } mapply( unclass(x), width, SIMPLIFY=FALSE, FUN=function(x.sub, width.sub) { breaks <- ceiling(nchar(x.sub) / width.sub) substr( rep(x.sub, breaks), start=(1:breaks - 1) * width.sub + 1, stop=(1:breaks) * width.sub ) } ) } #' @rdname text_wrap word_wrap <- function( x, width=getOption("width"), tolerance=8L, hyphens=TRUE, unlist=TRUE, collapse=NULL ) { stopifnot( is.character(x), is.int.pos.1L(width), is.integer(tolerance) && length(tolerance) == 1L && !is.na(tolerance) && tolerance >= 0L, is.null(collapse) || is.chr1(collapse) ) if(!(width > 4L && width - tolerance > 2L)) { warning( "Display width too narrow to properly wrap text; setting to 80L" ) width <- 80L tolerance <- 8L } width <- as.integer(width) # Define patterns, should probably be done outside of function let.vows <- c("a", "e", "i", "o", "u", "y") let.vows <- c(let.vows, toupper(let.vows)) let.all <- c(letters, LETTERS) let.cons <- let.all[!let.all %in% let.vows] cons <- paste0("[", paste0(let.cons, collapse=""),"]") cons.no.h <- paste0( "[", paste0(let.cons[!let.cons %in% c("h", "H")], collapse=""),"]" ) vows <- "[aeiouyAEIOUY]" ltrs <- "[a-zA-Z]" base.ptrn <- paste0("(.*%s).{0,", tolerance, "}$") non.alph.ptrn <- paste0("(.*\\W)\\w{0,", max(tolerance - 1L, 0L), "}.$") spc.ptrn <- sprintf(base.ptrn, "\\s") hyph.base <- paste0( "^(.*\\S*%s\\S*%s)%s\\S.{0,", tolerance, "}$" ) # patterns mark places that you can insert a hyphen in, in order of preference # though right now there is no trade-off at all between how many more # characters you need to cut off to get the better match, which perhaps we # should explore hyph.ptrns <- c( sprintf(hyph.base, vows, cons, cons.no.h), sprintf(hyph.base, ltrs, cons, vows), sprintf(hyph.base, ltrs, vows, cons), sprintf(hyph.base, ltrs, vows, vows), sprintf(hyph.base, ".", ".", ".") # catch-all allows hyphen anyplace ) break_char <- function(x) { lines.raw <- ceiling(nchar(x) / (width - tolerance)) # for hyphens res <- character(lines.raw + ceiling(lines.raw / (width - tolerance))) res.idx <- 1 if(!nchar(x)) return(x) while(nchar(x)) { pad <- 0L # account for hyphen if(nchar(x) > width) { x.sub <- substr(x, 1L, width + 1L) x.trim <- sub(spc.ptrn, "\\1", x.sub, perl=TRUE) matched <- grepl(spc.ptrn, x.sub, perl=TRUE) if(!matched) { x.trim <- sub(non.alph.ptrn, "\\1", x.sub, perl=TRUE) matched <- grepl(non.alph.ptrn, x.sub, perl=TRUE) } # Attempt to hyphenate hyph.match <- FALSE if(hyphens) { if(!matched) { for(pat in hyph.ptrns) { x.trim <- sub(pat, "\\1", x.sub, perl=TRUE) matched <- grepl(pat, x.sub, perl=TRUE) if(matched) { x.trim <- paste0(x.trim, "-") pad <- 1L break } } } } if(!matched) x.trim <- substr(x, 1L, width) # Failed, truncate # we allow one extra char for pattern match some cases, remove here x.trim <- substr(x.trim, 1L, width) x <- sub( # remove leading space if any "^\\s(.*)", "\\1", substr(x, min(nchar(x.trim), width) + 1L - pad, nchar(x)), perl=TRUE ) } else { x.trim <- x x <- "" } res[[res.idx]] <- x.trim res.idx <- res.idx + 1L } res[1L:(res.idx - 1L)] } # x.lst workaround required because `strsplit` swallows zero char char items!! x.lst <- as.list(x) # replace new lines with 0 char item; note that leading NLs need special # treatment; used to put in two newlines here; not sure why though x.lst[nchar(x) > 0] <- strsplit(x[nchar(x) > 0], "\n") res <- lapply(x.lst, function(x) unlist(lapply(x, break_char))) res.fin <- if(unlist) unlist(res) else res if(!is.null(collapse)) { res.fin <- if(is.list(res.fin)) lapply(res.fin, paste0, collapse=collapse) else paste0(res.fin, collapse=collapse) } res.fin } # Helper function to concatenate strings together cc <- function(..., c="") paste0(c(...), collapse=c) #' @rdname text_wrap meta_word_cat <- function( ..., sep="\n", width=getOption("width"), tolerance=8L, file=stdout(), trail.nl=TRUE ) { # NOTE: if we change `pre` nchar width there are several calls to # meta_word_wrap involving `UL` that will need to be udpated as well out <- word_wrap_split(..., sep=sep, width=width, tolerance=tolerance, pre="| ") if(!is.null(out)) cat(out, sep="\n", file=file) if(trail.nl) cat("\n") invisible(out) } #' @rdname text_wrap meta_word_msg <- function( ..., sep="\n", width=getOption("width"), tolerance=8L, trail.nl=TRUE ) { out <- paste0( c( word_wrap_split(..., sep=sep, width=width, tolerance=tolerance, pre="| "), if(trail.nl) "" ), collapse="\n" ) if(length(out)) message(paste0(out)) invisible(out) } ## Like word_wrap, but handles some additional duties needed for word_cat word_wrap_split <- function( ..., width=getOption("width"), tolerance=8L, pre="", sep=" " ) { stopifnot(is.chr1(pre)) width <- width - nchar(pre) if(width < 10L) width <- 10L vec <- try( paste0(unlist(list(...)), collapse=sep), silent=TRUE ) if(inherits(vec, "try-error")) stop(conditionMessage(attr(vec, "condition"))) paste0(pre, word_wrap(vec, width=width, tolerance=tolerance)) } #' @rdname text_wrap word_cat <- function( ..., sep=" ", width=getOption("width"), tolerance=8L, file=stdout() ) { out <- word_wrap_split(..., width=width, tolerance=tolerance, sep=sep) if(!is.null(out)) cat(out, file=file, sep="\n") invisible(out) } #' @rdname text_wrap word_msg <- function(...) word_cat(..., file=stderr()) #' @rdname text_wrap word_comment <- function( x, width=getOption("width"), tolerance=8L, hyphens=TRUE, unlist=TRUE, color=crayon::has_color() ) { if(is.null(color)) color <- crayon::has_color() if(!is.character(x)) stop("Argument `x` must be character") if(!all(grep("^#", x))) stop("Argument `x` must be character with all elements starting with '#'") res <- word_wrap( x=sub("^#", "", x), width=width - 1L, tolerance=tolerance, hyphens=hyphens, unlist=FALSE ) res <- lapply( res, function(x) if(color) crayon::silver(paste0("#", x)) else paste0("#", x) ) if(unlist) unlist(res) else res } ## Over-write a Line ## ## @keywords internal ## @param x character(1L) ## @param min.width integer(1L) minimum character width to print to ## @param max.width integer(1L) max width to print to ## @param append to last non-append \code{x} value ## @param overwrite previous line ## @return NULL used only for side effect of cating to screen over_print <- ( function() { prev.val <- "" function( x, append=FALSE, min.width=30L, max.width=getOption("width"), overwrite=interactive() # should be controllable from top level ) { if(!is.character(x) || length(x) != 1L || is.na(x)) stop("Argument `x` must be character(1L) and not NA") if(!is.integer(min.width) || length(min.width) != 1L) stop("Argument `min.width` must be integer(1L)") if(!is.integer(max.width) || length(max.width) != 1L) stop("Argument `max.width` must be integer(1L)") if(!isTRUE(append) && !identical(append, FALSE)) stop("Argument `append` must be TRUE or FALSE") if(!isTRUE(overwrite) && !identical(overwrite, FALSE)) stop("Argument `overwrite` must be TRUE or FALSE") cat( c( if(overwrite) c("\r", rep(" ", max(min.width, max.width)), "\r"), substr(paste0(if(append) prev.val, x), 1L, max(min.width, max.width)), if(!overwrite) "\n" ), sep="" ) prev.val <<- if(append) prev.val else x invisible(NULL) } } ) () class_map <- function(val) { abb <- c( numeric="num", integer="int", character="chr", complex="cpx", factor="fct", matrix="mat", logical="logi" ) if(is.na(mapped <- abb[match(val, names(abb))])) val else mapped } desc_type <- function(val) { class.map <- c( numeric="num", integer="int", character="chr", complex="cpx", factor="fct", logical="logi" ) if(is.matrix(val)) paste(class_map(typeof(val)), "mat") else class_map(head(class(val), 1L)) } desc_size <- function(val) { if(!is.null(dim(val))) { paste0("[", paste0(dim(val), collapse=","), "]") } else if((length(val) != 1L || !is.object(val)) && !is.null(val)) { paste0("[", length(val), "]") } } desc_simple <- function(val) { type <- desc_type(val) paste0(type, desc_size(val)) } #' One Line Description of Object #' #' Objects are described by class, and dimensions. Dimensions is always denoted #' in square brackets. For example, \dQuote{int[10]} means an integer of length #' ten. Typically an object will be identified by \code{head(class(obj), 1L)} #' along with its dimensions. Recursive objects will have the first level shown #' provided that doing so fits within \code{limit}. #' #' Eventually this will be migrated to an S3 generic to allow recursive dispatch #' on object type. #' #' @export #' @param val object to describe #' @param limit max characters to display #' @return character(1L) describing object #' @examples #' desc(list(a=iris, b=lm(dist ~ speed, cars), 1:10, matrix(letters, 2))) desc <- function(val, limit=getOption("width")) { type <- desc_type(val) simple <- desc_simple(val) res <- if(nchar(simple) < limit && is.recursive(val) && length(val)) { descs <- vapply(val, desc_simple, character(1L)) names <- if(is.null(names(val))) character(length(val)) else names(val) rec <- sprintf( "%s(%s)", type, paste0( ifelse(nzchar(names), paste0(names, "=", descs), descs), collapse=", " ) ) if(nchar(rec) < limit) rec else simple } else simple if(nchar(res) > limit - 3L) paste0(substr(res, 1L, limit - 3L), "...") else res } ## Collapse Multi-line Character into one line ## ## @param x character ## @param chars how many characters to display ## @keywords internal one_line <- function(x, chars=0L) { if(!is.character(x) || any(is.na(x))) stop("Argument `x` must be character and may not contain NAs") chars <- as.integer(chars) # not ideal due to NA by coersion if(!is.numeric(chars) || length(chars) != 1L || is.na(chars)) stop("Argument `chars` must be integer(1L) and not NA") one.line <- paste0(sub("^\\s*", "", unlist(strsplit(x, "\n"))), collapse="") if(chars < 1L) return(one.line) if(chars < 10L) substr(one.line, 1L, chars) else if(nchar(one.line) > chars) paste0(substr(one.line, 1L, chars - 3L), "...") else one.line } #' Make Valid Names #' #' If names are invalid, quotes them with backtics #' #' @keywords internal #' @param x character vector #' @return character vector valid_names <- function(x) { ifelse( grepl("^[a-zA-Z.]([_a-zA-Z.][a-zA-Z0-9._]*)?$", x), x, paste0("`", x, "`") ) } #' Captalizes or Decapitalizes First Letter #' #' @keywords internal #' @aliases decap_first #' @param x character #' @return character cap_first <- function(x) change_first(x, toupper) decap_first <- function(x) change_first(x, tolower) change_first <- function(x, fun) { if(!is.character(x)) stop("Argument `x` must be a character vector.") ifelse( nchar(x) > 2L, paste0(substr(fun(x), 1L, 1L), substr(x, 2L, nchar(x))), ifelse(nchar(x) == 1L, fun(x), x) ) } ## Substring To a Length, but end In Consonant ## ## @keywords internal ## @param x character vector to substring ## @param stop integer max number of characters ## @param justify character(1L) passed on to format substr_cons <- function(x, stop, justify="left") { if(!is.character(x)) stop("Argument `x` must be ") y <- substr(x, 1, stop) z <- sub("[^bcdfghjklmnpqrstvwxz]*$", "", y, ignore.case=TRUE) format(z, width=stop, justify=justify) } ## Remove Common Characters From Values in a Vector ## ## Note that one length \code{x} is a degenerate case that returns "". ## ## @keywords internal ## @param x character the vector to make more unique ## @param from the direction to remove common elements from str_reduce_unique <- function(x, from="left") { if( !is.character(from) || length(from) != 1L || is.na(from) || !from %in% c("left", "right") ) stop( "Argument `from` must be character(1L) %in% c(\"left\", \"right\") ", "and not NA" ) if(!is.character(x) || any(is.na(x))) stop("Argument `x` must be character and may not contain NAs") if(identical(length(unique(x)), 1L)) return(rep("", length(x))) # degenerate case char.list <- strsplit(x, "") if(identical(from, "right")) char.list <- lapply(char.list, rev) min.len <- min(vapply(char.list, length, 1L)) char.mx <- vapply(char.list, `[`, character(min.len), 1:min.len) first.diff <- min( which(apply(char.mx, 1, function(x) length(unique(x))) > 1L) ) char.mx.trim <- char.mx[first.diff:nrow(char.mx), ] trim.list <- split(char.mx.trim, col(char.mx.trim)) res <- character(length(x)) for(i in seq_along(x)) { res.tmp <- c(trim.list[[i]], tail(char.list[[i]], -min.len)) if(identical(from, "right")) res.tmp <- rev(res.tmp) res[[i]] <- paste0(res.tmp, collapse="") } res } ## Convert A Matrix of Test Outcomes for Display ## ## Used by \code{show} methods for both \code{unitizerSummary} and ## \code{unitizerSummaryList} ## ## @keywords internal summ_matrix_to_text <- function( mx, from="right", width=getOption("width"), show.nums=TRUE ) { # Ignore any columns with zero totals other than pass/fail if( !is.integer(width) || !identical(length(width), 1L) || is.na(width) || width < 1L ) stop("Argument `width` should be integer(1L) and strictly positive") totals <- colSums(mx) keep.cols <- colSums(mx, na.rm=TRUE) > 0L | seq_along(totals) < 3L mx.keep <- mx[, keep.cols, drop=FALSE] totals.keep <- totals[keep.cols] col.names <- substr_cons(names(totals.keep), 4L, justify="right") col.count <- length(col.names) tot.chr <- as.character(totals.keep) tot.chr[is.na(totals.keep)] <- "?" tot.chr[!is.na(totals.keep) & !totals.keep] <- "-" num.width <- max(nchar(col.names), nchar(tot.chr)) test.len <- nrow(mx.keep) test.nums <- if(show.nums) paste0(" ", format(seq.int(test.len)), ".") else character(test.len) rns <- rownames(mx.keep) scr.width <- width non.file.chars <- (num.width + 1L) * col.count + max(nchar(test.nums)) + 2L max.rns.chars <- min(max(12L, scr.width - non.file.chars), max(nchar(rns))) fmt <- paste0( "%", max(nchar(test.nums)), "s %", max.rns.chars, "s ", paste0(rep(paste0(" %", num.width, "s"), col.count), collapse="") ) rns.trim <- strtrunc(rns, max.rns.chars, from=from) # Display res <- do.call(sprintf, c(list(fmt, "", ""), as.list(col.names))) mx.keep.chr <- mx.keep mx.keep.chr[] <- as.character(mx.keep) mx.keep.chr[is.na(mx.keep)] <- "?" mx.keep.chr[!mx.keep] <- "-" for(i in seq.int(nrow(mx.keep.chr))) { res <- c( res, do.call( sprintf, c(list(fmt, test.nums[[i]], rns.trim[[i]]), as.list(mx.keep.chr[i, ])) ) ) } # totals.keep res <- c(res, paste0(rep(".", nchar(res[[1L]])), collapse="")) res <- c( res, do.call(sprintf, c(list(fmt, "", ""), as.list(tot.chr))) ) res } #' Capture Both StdOut and StdErr #' #' Will sink both "output" and "message" streams without checking whether they #' are already sunk, and will unsink them the same way. #' #' @keywords internal #' @param expr a quoted expression to evaluate #' @param env an environment to evaluate them in #' @return a list with stdout and stderr captured separately, classed as #' "captured_output" capture_output <- function(expr, env=parent.frame()) { std.out <- tempfile() std.err <- tempfile() std.err.con <- file(std.err, "w") old.err.con <- getConnection(sink.number(type="message")) files <- c(output=std.out, message=std.err) success <- FALSE sink(std.out) sink(std.err.con, type="message") on.exit({ sink() sink(old.err.con, type="message") close(std.err.con) if(!success) { # nocov start # can't really test this easily try({ cat(readLines(std.out), sep="\n") cat(readLines(std.err), sep="\n", file=stderr()) }) # nocov end } unlink(files) }) eval(substitute(expr), env) res <- suppressWarnings(lapply(files, readLines)) success <- TRUE invisible(structure(res, class="captured_output")) } #' @export #' @rdname capture_output print.captured_output <- function(x, ...) { cat(as.character(H3("Output"))) cat(x$output, sep="\n") cat(as.character(H3("Message"))) cat(x$message, sep="\n") } ## Convert a Character Vector into a List in English ## ## @param x character elements to list ## @param singular follow on ## @param plural follow on char_to_eng <- function(x, singular="was", plural="were") { stopifnot(is.character(x), is.chr1(singular), is.chr1(plural)) if(length(x) == 1L) { if(nzchar(singular)) paste(x, singular) else x } else if (length(x)) { base <- paste0(paste0(head(x, -1L), collapse=", "), ", and ", tail(x, 1L)) if(nzchar(plural)) paste(base, plural) else base } else "" } unitizer/R/result.R0000644000176200001440000002363314766101401013774 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include unitizer.R NULL #' Return Values and Related Methods for \code{unitize} Functions #' #' \code{unitize} and related functions are run primarily for the interactive #' environment they provide and for their side effects (updating stored #' \code{unitizer} objects), but the return values may be useful under some #' circumstances if you need to retrieve test status, user selections, etc.. #' #' \code{unitize} and \code{review} return a \code{unitizer_result} S3 object. #' This is a data frame that contains details about the status of each test. #' \code{unitize_dir} returns a \code{unitize_results} S3 object, which is a #' list of \code{unitize_result} objects. #' #' Both \code{unitize_results} and \code{unitize_result} have \code{print} #' methods documented here. In addition to the \code{print} methods, both of #' the result objects have \code{\link{get_unitizer}} methods so that you can #' retrieve the stored \code{unitizer} objects. #' #' Please note that with \code{unitize_dir} you can re-review a single #' \code{unitizer} several times during during a single call to #' \code{unitize_dir}. This is to allow you to re-evaluate specific #' \code{unitizers} easily without having to re-run the entire directory again. #' Unfortunately, as a result of this feature, the return values of #' \code{unitize_dir} can be misleading because they only report the result of #' the last review cycle. #' #' Additionally, \code{unitize_dir} will report user selections during the last #' review even if in the end the user chose not to save the modified #' \code{unitizer}. You will be alerted to this by an onscreen message from the #' \code{print} method (this is tracked in the "updated" attribute of the #' \code{unitizer_result} object). Finally, if in the last iteration before #' exit you did not save the \code{unitizer}, but you did save it in previous #' review cycles in the same \code{unitize_dir} call, the displayed selections #' and test outcomes will correspond to the last unsaved iteration, not the #' one that was saved. You will be alerted to this by an on-screen message #' (this is tracked through the "updated.at.least.once" attribute of the #' \code{unitizer_result} object). #' #' @name unitizer_result #' @rdname unitizer_result #' @aliases unitizer_results #' @seealso \code{\link{unitize}}, \code{\link{get_unitizer}} #' @param x the object to print #' @param ... extra arguments for print generic #' @return \code{x}, invisibly NULL #' @export #' @rdname unitizer_result print.unitizer_result <- function(x, ...) { if(!isTRUE(fail <- is.unitizer_result(x))) stop(fail) x$call <- strtrunc(x$call, 30L) x$section <- if(length(unique(x$section)) > 1L) strtrunc(x$section, 15L) x$ignored <- factor(ifelse(x$ignored, "*", ""), levels=c("", "*")) store.char <- if(is.chr1plain(attr(x, "store.id"))) { pretty_path(attr(x, "store.id")) } else { att <- try(as.character(attr(x, "store.id")), silent=TRUE) if(inherits(att, "try-error")) "" else att } word_cat("Test File: ", pretty_path(attr(x, "test.file")), "\n", sep="") word_cat("Store ID: ", store.char, "\n\n", sep="") res <- NextMethod(x, ...) if(!isTRUE(attr(x, "updated"))) word_cat( "\nYou chose NOT to save these changes to the unitizer store\n" ) invisible(res) } #' @export #' @rdname unitizer_result print.unitizer_results <- function(x, ...) { if( !inherits(x, "unitizer_results") || !is.list(x) || !all( vapply( x, function(y) is(y, "unitizerLoadFail") || isTRUE(is.unitizer_result(y)), logical(1L) ) ) ) stop( "Argument `x` must be a \"unitizer_results\" list containing only ", "`unitizerLoadFail` or `unitizer_result` objects" ) if(!length(x)) { meta_word_cat("No unitizers") return(invisible(NULL)) } failed <- vapply(x, is, logical(1L), "unitizerLoadFail") which.fail <- which(failed) which.pass <- which(!failed) files <- # extract both S4 slot and S3 attribute... vapply(x, function(y) pretty_path(attr(y, "test.file")), character(1L)) files.short <- unique_path(files) files.dir <- attr(files.short, "common_dir") updated <- TRUE if(length(which.pass)) { # Looking at non-ignored only, compute counts in each category, and how many # of them the user selected Y for; vals will be a 3D Array vals <- vapply( x[which.pass], function(y) { y2 <- y[!y$ignored, ] counts <- tapply(y2$status, y2$status, length) yesses <- tapply(y2$user == "Y", y2$status, sum) counts[is.na(counts)] <- 0L yesses[is.na(yesses)] <- 0L rbind(yesses=yesses, counts=counts) }, matrix(integer(1L), 2L, length(levels(x[[which.pass[[1L]]]]$status))) ) # Compute which columns to display (always show first column); note we reduce # vals to a matrix by selecting only the "counts" values of the first dim to.show <- unique(which(!!rowSums(vals["counts", , ,drop=TRUE]))) if(!length(to.show)) to.show <- 1L # Now collapse into string form as.frac <- function(y) { setNames( c( paste0(y["yesses", ,drop=F], "/", y["counts", , drop=F]), paste0(rowSums(y), collapse="/") ), c(colnames(y), "Totals") ) } vals.char <- apply(vals[, to.show, ,drop=FALSE], 3L, as.frac) tots.char <- as.frac(apply(vals[, to.show, ,drop=FALSE], 1L:2L, sum)) count.mx <- t( cbind( vals.char, tots.char, deparse.level=0L ) ) # drop totals if superflous if(ncol(count.mx) == 2L) count.mx <- count.mx[, -2L, drop=FALSE] if(nrow(count.mx) == 2L) count.mx <- count.mx[-2L, , drop=FALSE] # pad col names for equal width max.width <- max(c(nchar(count.mx), nchar(dimnames(vals)[[2L]]))) colnames(count.mx) <- sprintf(paste0("%", max.width, "s"), colnames(count.mx)) # Combine with file names and totals fin.mx <- cbind( test.file=c(files.short[which.pass], "Totals"), count.mx ) fin.df <- cbind(id=c(which.pass, 0L), as.data.frame(fin.mx)) fin.out <- capture.output(print(fin.df, row.names=FALSE)) # Mark any non-updated tests updated <- vapply( x[which.pass], function(x) if(isTRUE(attr(x, "updated"))) 3L else if(isTRUE(attr(x, "updated.at.least.once"))) 2L else 1L, integer(1L) ) updated.mark <- c("*", "$", " ") if(any(updated < 3L)) fin.out[-c(1L, length(fin.out))] <- paste(fin.out[-c(1L, length(fin.out))], updated.mark[updated]) word_cat( "Summary of tests (accept/total):\n", head(fin.out, -1L), paste0(rep("-", max(nchar(fin.out))), collapse=""), tail(fin.out, 1L), if(any(updated < 3L)) "\n", sep="\n" ) if(any(updated == 1L)) word_cat("* unitizer was not saved") if(any(updated == 2L)) word_cat("$ unitizer was saved in prior evaluation") cat("\n") } if(length(which.fail)) { if(length(which.pass)) cat("\n") test.files <- vapply(x[which.fail], slot, character(1L), "test.file") fail.reason <- vapply(x[which.fail], slot, character(1L), "reason") file.names.short <- unique_path(test.files) word_cat( "Unitizers for the following files could not be loaded:\n", as.character( UL( paste0( "id: ", which.fail, "; ", files.short[which.fail], ": ", fail.reason ) ), width=getOption("width") - 2L ), sep="\n" ) cat("\n") } word_cat("Test files in common directory '", files.dir, "'", sep="") return(invisible(x)) } # Check whether an object is of type "unitizer_result" # # returns TRUE on success and character string on failure is.unitizer_result <- function(x) { if(!inherits(x, "unitizer_result")) return("does not inherit from \"unitizer_result\"") if(is.null(attr(x, "test.file")) || is.null(attr(x, "store.id"))) return("is missing \"test.file\" and/or \"store.id\" attributes") if(!isTRUE(dat.err <- is.unitizer_result_data(x))) return(paste0("data ", dat.err)) TRUE } # Check whether an object conforms to the data frame structure expected of # the data component of a "unitizer_result" object # # returns TRUE on success and character string on failure is.unitizer_result_data <- function(x) { if(!is.data.frame(x)) return("is not a data.frame") names.valid <- c("id", "call", "section", "ignored", "status", "user", "reviewed") if(!identical(names(x), names.valid)) return(paste0("does not have names expected columns")) if( !identical( unname(vapply(x, class, character(1L))), c( "integer", "character", "character", "logical", "factor", "factor", "logical" ) ) ) return(paste0("does not have the expected column classes")) TRUE } setGeneric("extractResults", function(x, ...) standardGeneric("extractResults")) setMethod( "extractResults", "unitizerObjectList", function(x, ...) structure(lapply(as.list(x), extractResults), class="unitizer_results") ) setMethod( "extractResults", "unitizer", function(x, ...) structure( x@res.data, class=unique(c("unitizer_result", class(x@res.data))), test.file=x@test.file.loc, store.id=x@id, updated=x@updated, updated.at.least.once=x@updated.at.least.once ) ) setMethod("extractResults", "unitizerLoadFail", function(x, ...) x) unitizer/R/class_unions.R0000644000176200001440000000343514766101401015154 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. setClassUnion("listOrExpression", c("list", "expression")) setClassUnion("characterOrNULL", c("character", "NULL")) setClassUnion("environmentOrNULL", c("environment", "NULL")) setClassUnion("languageOrNULL", c("language", "NULL")) setClassUnion("numericOrNULL", c("numeric", "NULL")) setClassUnion("integerOrNULL", c("integer", "NULL")) setClassUnion("characterOrNULL", c("character", "NULL")) setClassUnion("subIndex", c("character", "logical", "numeric", "missing")) setClassUnion("data.frameOrNULL", c("data.frame", "NULL")) setClassUnion("DiffOrNULL", c("Diff", "NULL")) # setOldClass("file") # setOldClass(c('package_version', 'numeric_version')) # setClassUnion("fileOrNULL", c("file", "NULL")) # removed due to conflicts with RJSONIO #' Documentation Block for Internal S4 Methods #' #' R insists these need to be documented as user facing, but they are not really #' so were throwing them all in here. Actual docs are in non roxygen comments #' by fun definitions. #' #' Put in this file because this file is included by almost every other file #' #' @name unitizer_s4method_doc #' @rdname unitizer_s4method_doc #' @keywords internal NULL unitizer/R/test.R0000644000176200001440000000471114766101401013431 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include list.R #' @include class_unions.R #' @include section.R #' @include item.R NULL #' Collections of Calls For Testing #' #' Should probably add an \code{as.unitizerTests} function... #' @keywords internal setClass("unitizerTests", contains="unitizerList") setClassUnion("unitizerTestsOrExpression", c("unitizerTests", "expression")) # Add More Tests to \code{`\link{unitizerTests-class}`} # # Will overwrite the call at the current index with the contents of the # expression passed as the \code{`e2`} argument, unless current index is 0L # in which case will just append the expressions. The intended use for this # is when the evaluation of one of the tests produces a # \code{`\link{unitizerSectionExpression-class}`} that should then replace the # call. # # The index of the \code{`\link{unitizerTests-class}`} object will be set so that # the next call to \code{`\link{nextItem,unitizerList-method}`} will return the first # call that was added. # # @keywords internal # @return unitizerTests-class #' @rdname unitizer_s4method_doc setMethod("+", c("unitizerTests", "unitizerSectionExpressionOrExpression"), valueClass="unitizerTests", function(e1, e2) { if(e1@.pointer > length(e1) | e1@.pointer < 0L) # nocov start stop("Internal Error: invalid internal index value ", e1@.pointer) # nocov end if(e1@.pointer > 0L) { e1@.items[[e1@.pointer]] <- NULL e1@.pointer <- e1@.pointer - 1L } append(e1, e2, after=e1@.pointer) } ) # Create Template Matrix tests_result_mat <- function(rows=0) { if(!is.numeric(rows) || length(rows) != 1L || rows < 0) stop("Argument `rows` must be numeric(1L) >= 0") col.names <- slotNames("unitizerItemData") res <- matrix(logical(0L), ncol=length(col.names), nrow=rows) colnames(res) <- col.names res[] <- FALSE res } unitizer/R/ls.R0000644000176200001440000001435114766101401013071 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R NULL #' An `ls` Like Function #' #' Much like `ls`, except that it is designed to crawl up the \code{`.new`} and #' \code{`.ref`} environments and display all the objects. #' #' This is used in \code{`browseUnitizer,unitizer-unitizerBrowse-method`}, #' and is re-assigned to \code{`ls`} for use in the \code{`unitizer`} prompt #' environment. #' #' @keywords internal #' @return list of object names, or a list with environments containing the #' objects unitizer_ls <- function(name, pos = -1L, envir = parent.frame(), all.names = FALSE, pattern ) { if(!missing(pos) || !missing(name) || !missing(envir)) stop( "You are using an overloaded version of `ls` that does not allow ", "using the `name`, `pos`, or `envir` arguments to `ls`; you can use ", "standard `ls` with `base::ls`." ) new.item <- try(get(".NEW", parent.env(envir)), silent=TRUE) ref.item <- try(get(".REF", parent.env(envir)), silent=TRUE) ls.lst <- list() ls.test <- mods <- character() new.inv <- ref.inv <- FALSE if(inherits(new.item, "try-error") && inherits(ref.item, "try-error")) { # nocov start stop( "Internal error: could not find `unitizerItem` objects to list contents ", "of; contact Maintainer" ) # nocov end } if(!inherits(new.item, "try-error")) { if(nrow(new.item@ls)) ls.lst[["new"]] <- paste0(new.item@ls$names, new.item@ls$status) ls.lst[["tests"]] <- c(ls.lst[["tests"]], c(".new", ".NEW")) mods <- c(mods, Filter(nchar, unique(new.item@ls$status))) new.inv <- isTRUE(attr(new.item@ls, "invalid")) } if(!inherits(ref.item, "try-error")) { if(nrow(ref.item@ls)) ls.lst[["ref"]] <- paste0(ref.item@ls$names, ref.item@ls$status) ls.lst[["tests"]] <- c(ls.lst[["tests"]], c(".ref", ".REF")) mods <- c(mods, Filter(nchar, unique(ref.item@ls$status))) ref.inv <- isTRUE(attr(ref.item@ls, "invalid")) } if(!inherits(ref.item, "try-error") && !inherits(new.item, "try-error")) { ls.lst[["tests"]] <- c(ls.lst[["tests"]], c(".diff", ".DIFF")) } if(new.inv || ref.inv) { warning( "The ls output for ", paste(c("`.new`", "`.ref`")[c(new.inv, ref.inv)], sep=", "), " is invalid. This may be because you had corrupted environment chains ", "that had to be repaired. Re-generating the `unitizer` with ", "`unitize(..., force.update=TRUE)` should fix the problem. If it ", "persists, please contact maintainer." ) } structure(ls.lst[order(names(ls.lst))], class="unitizer_ls", mods=mods) } #' Worker function to actually execute the `ls` work #' #' @param env the environment to start \code{`ls`}ing in #' @param stop.env the environment to stop at #' @param all.names, same as \code{`ls`} #' @param pattern same as \code{`ls`} #' @param store.env NULL or environment, if the latter will populate that #' environment with all the objects found between \code{`env`} and #' \code{`stop.env`} #' @return character or environment depending on \code{`store.env`} #' @keywords internal run_ls <- function(env, stop.env, all.names, pattern, store.env=NULL) { ls.res <- character() env.list <- list() i <- 0L max.envs <- getOption("unitizer.max.env.depth") if(!is.numeric(max.envs) || length(max.envs) != 1L || max.envs < 1) max.envs <- 20000L max.envs <- as.integer(max.envs) attempt <- try( # Get list of environments that are relevant while(!identical(env, stop.env)) { env.list <- c(env.list, env) env <- parent.env(env) if((i <- i + 1L) > max.envs) stop( "Logic error: not finding `stop.env` after ", max.envs, " iterations; contact package maintainer if this is an error." ) } ) if(inherits(attempt, "try-error")) stop("Specified `stop.env` does not appear to be in parent environments.") # Reverse, so when we copy objects the "youngest" overwrite the "eldest" for(i in rev(seq_along(env.list))) { ls.res <- c(ls.res, ls(envir=env.list[[i]], all.names=all.names, pattern=pattern)) if(!is.null(store.env)) { for(j in seq_along(ls.res)) assign(ls.res[[j]], get(ls.res[[j]], envir=env.list[[i]]), store.env) ls.res <- character() } } if(is.null(store.env)) sort(unique(ls.res)) else store.env } #' @export print.unitizer_ls <- function(x, ...) { x.copy <- x x <- unclass(x) attr(x, "mods") <- NULL if(is.list(x)) { name.match <- c( tests="unitizer objects:", new="objects in new test env:", ref="objects in ref test env:" ) names(x) <- name.match[names(x)] } val <- NextMethod() extra <- character() explain <- c( "'"=" ': has changed since test evaluation", "*"=" *: existed during test evaluation, but doesn't anymore", "**"=" **: didn't exist during test evaluation" ) if(all(c("new", "ref") %in% names(x.copy))) extra <- c(extra, "Use `ref(.)` to access objects in ref test env") if(length(attr(x.copy, "mods"))) { extra <- c(extra, explain[attr(x.copy, "mods")]) } if(length(extra)) cat(extra, sep="\n") invisible(val) } #' Clears ls Info and Marks as Invalid #' #' Useful when tests envs are repaired, or if we're looking at an ignored #' test #' #' @keywords internal setGeneric("invalidateLs", function(x, ...) standardGeneric("invalidateLs")) setMethod("invalidateLs", "unitizerItems", valueClass="unitizerItems", function(x, ...) { x@.items <- lapply(as.list(x), invalidateLs) x } ) setMethod("invalidateLs", "unitizerItem", valueClass="unitizerItem", function(x, ...) { x@ls <- x@ls[0,] # ls potentially missleading attr(x@ls, "invalid") <- TRUE x } ) unitizer/R/capture.R0000644000176200001440000003253114766101401014116 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. ## Helper Functions to Capture and Process stdout/err Output ## ## \code{set} functions set sinks, and \code{get} functions retrieve the ## captured output. There are two types of functions here: ## ## \itemize{ ## \item \code{set_text_capture} and \code{get_text_capture} are intended for ## use in situations we know the code to be evaluated will not be setting ## sinks of its own; note that \code{get_text_capture} undoes any sinks set ## by \code{set_text_capture} ## \item \code{set_capture} and \code{get_capture} are meant for use when ## evaluating the tests as both stdout and stderr are handled ## \code{get_capture} does *not* undo the sinks since we need to check after ## getting the text that the sinks are still in a reasonable state ## with \code{unsink_cons} ## } ## All output to \code{stdout} and \code{stderr} is capture in a single file for ## each of those streams. The captures happen sequentially, and are read off ## by \code{\link{readChar}}. It is important to note this method implies that ## the files grow throughout the entire test evaluation process, and are only ## dumped at the very end. This is to avoid overhead from repeatedly creating ## and opening new connections. ## ## \code{set} functions will not actually set the sinks if the connections have ## a "waive" attribute set to TRUE. ## ## \code{get_text_capture} and set companion are kind of half-assed updated to ## use the new version of the \code{cons} argument. The used to just take a ## simple connection, but the need to reset stderr output to the original error ## connection required the change, and it's a bit confusing because \code{cons} ## contains both connections, whereas these functions operate on one connection ## at a time. ## ## @param con either a file name or an open connection; make sure that you use ## a \code{con} created by \code{set_text_capture} for \code{get_text_capture} ## since \code{set_text_capture} detects whether sinking is already in process ## and returns FALSE if it is, which then tells \code{get_text_capture} not to ## undo the sink ## @param type character(1L) in \code{c("output", "message")} ## @param file.name character(1L) file location corresponding to \code{con} ## @param no.unsink logical(1L) for testing purposes so we don't release a sink ## when none was actually set ## @return \itemize{ ## \item \code{set_text_capture}: a connection, with attribute "waive" set to ## TRUE if the sink was already sunk and we did not sink it again ## \item \code{get_text_capture}: character ## } ## @keywords internal set_text_capture <- function( cons, type, capt.disabled= getOption("unitizer.disable.capt", c(output=FALSE, message=FALSE)) ) { stopifnot( is(cons, "unitizerCaptCons"), type %in% c("output", "message"), is.valid_capt_setting(capt.disabled) ) con <- slot(cons, if(type=="message") "err.c" else "out.c") if(!capt.disabled[[type]]) { sink(con, type=type) } else if(type == "output") sink(con, split=TRUE) return(cons) } get_text_capture <- function( cons, type, no.unsink=FALSE, chrs.max=getOption("unitizer.max.capture.chars", 200000L) ) { stopifnot( isTRUE(type %in% c("message", "output")), is(cons, "unitizerCaptCons"), is.TF(no.unsink) ) if( !is.numeric(chrs.max) || length(chrs.max) != 1L || is.na(chrs.max) || chrs.max < 100L ) { stop( "Argument `chrs.max` must be integer(1L) and greater ", "than 100L; using 200000L for now", immediate.=TRUE ) } if(identical(type, "message")) { if(!no.unsink) { sink(cons@stderr.con, type="message") } } else if (identical(type, "output")) { if(!no.unsink) sink() } else { # nocov start stop("Internal Error: unexpected connection type; contact maintainer.") # nocov end } return(get_text(slot(cons, if(type=="message") "err.c" else "out.c"))) } # nocov start # this stuff is all emergency sink release that can't be tested without messing # up whatever test framework sink capture exists release_sinks <- function(silent=FALSE) { release_stdout_sink(FALSE) release_stderr_sink(FALSE) if(!isTRUE(silent)) message("All sinks released, even those established by test expressions.") NULL } release_stdout_sink <- function(silent=FALSE) { replicate(sink.number(), sink()) if(!isTRUE(silent)) message( "All stdout sinks released, even those established by test expressions." ) } release_stderr_sink <- function(silent=FALSE) { if(!identical(sink.number(type="message"), 2L)) sink(type="message") if(!isTRUE(silent)) message("Stderr sink released.") } # nocov end # Wrappers Around Capture functions # # These are intended specifically for calling during test evaluation since in # that case we're trying to capture both streams, as opposed to during setup # etc. where we just want to quickly capture some output like package warnings get_capture <- function( cons, chrs.max=getOption("unitizer.max.capture.chars", 200000L) ) { stopifnot(is(cons, "unitizerCaptCons")) # Do message first, so we can see subsequent errors message <- get_text(cons@err.c, chrs.max=chrs.max) output <- get_text(cons@out.c, chrs.max=chrs.max) list(output=output, message=message) } set_capture <- function( cons, capt.disabled= getOption("unitizer.disable.capt", c(output=FALSE, message=FALSE)) ) { stopifnot(is(cons, "unitizerCaptCons"), is.valid_capt_setting(capt.disabled)) out.level <- sink.number() err.level <- sink.number(type="message") err.con <- try(getConnection(err.level)) if(!identical(out.level, cons@stdout.level)) attr(cons@out.c, "waive") <- TRUE if(!identical(err.con, cons@stderr.con)) attr(cons@err.c, "waive") <- TRUE set_text_capture(cons, "message", capt.disabled=capt.disabled) set_text_capture(cons, "output", capt.disabled=capt.disabled) cons } # Just Pull Text From A Connection # # Need to make more robust... get_text <- function( con, chrs.max=getOption("unitizer.max.capture.chars", 200000L) ) { # Read captured, do so with `readChar` for performance reasons, growing # buffer as needed up to maximum allowable capture chrs.prev <- 0 chrs <- 1e4 chrs.mlt <- 10 res <- "" while(chrs.prev < chrs.max) { chrs <- min(chrs, chrs.max) chrs.extra <- chrs - chrs.prev capture <- readChar(con, chrs.extra) res <- paste0(res, capture) if(!length(capture) || nchar(capture) < chrs.extra) break chrs.prev <- chrs chrs <- chrs * chrs.mlt } if(chrs.prev >= chrs.max) { if((err.con.num <- sink.number(type="message")) != 2) { err.con <- getConnection(err.con.num) sink(type="message") # temporarily clear so we can issue warning } warning( "Reached maximum text capture characters ", chrs.max, "; see `getOption(\"unitizer.max.capture.chars\")`", immediate. = TRUE ) if(err.con.num != 2) sink(err.con, type="message") # Reset writing point to last point read (this might not work on windows, # see ?seek) pos <- seek(con, origin="current", rw="read") seek(con, pos, rw="write") } return(res) } # Unsink / Check That Sinks Still Reasonable # # If we can't account for sink status we need to waive all future capture # attempts. unsink_cons <- function(cons) { on.exit({ # nocov start failsafe_con(cons) # nocov end }) stopifnot(is(cons, "unitizerCaptCons")) out.level <- sink.number() err.level <- sink.number(type="message") err.con <- try(getConnection(err.level)) # Checking stdout complicated because we have to verify the current sink is # actually pointed at the file we are using if( !identical(out.level, cons@stdout.level + 1L) || !(inherits(cons@out.c, "file") && isOpen(cons@out.c)) ) { attr(cons@out.c, "waive") <- TRUE } else { if(!is_stdout_sink(cons@out.f)) { attr(cons@out.c, "waive") <- TRUE } else sink() } # stderr check is pretty simple if(!isTRUE(all.equal(err.con, cons@err.c, check.attributes=FALSE))) { attr(cons@err.c, "waive") <- TRUE } else sink(cons@stderr.con, type="message") # Return possibly modified cons (waived) on.exit(NULL) cons } # Try to Deal With Sinks Gracefully on Failure # nocov start failsafe_con <- function(cons) { capt.try <- try(get_capture(cons)) release_sinks() if(inherits(capt.try, "try-error")) { signalCondition(attr(capt.try, "condition")) } else { if(sum(nchar(capt.try$output))) cat(capt.try$output, "\n", sep="") if(sum(nchar(capt.try$message))) cat(capt.try$message, "\n", sep="", file=stderr()) } meta_word_msg( "Problems managing stdout/stderr streams, so we have reset all sinks, ", "even those that may have been set prior to calling `unitizer`.", sep="" ) invisible(NULL) } # nocov end # Cleanup sink connections if possible # # @return logical(2L) indicating success in normal resetting of sinks close_and_clear <- function(cons) { stopifnot(is(cons, "unitizerCaptCons")) status <- c(output=TRUE, message=TRUE) err.reset <- try(sink(cons@stderr.con, type="message")) if(inherits(err.reset, "try-error")) { status[["message"]] <- FALSE sink(type="message") meta_word_msg( "Unable to restore original message sink, setting back to normal stderr" ) } if(isTRUE(attr(cons@out.c, "waive"))) { # if waived, we have not unsunk our original connection, so need to ensure # it is still around, @stdout.level refers to the level before we sunk it # ourselves, so we need the -1L to test that sink out.level <- sink.number() level.extra <- out.level - cons@stdout.level - 1L if(level.extra > 0) replicate(level.extra, sink()) if(!is_stdout_sink(cons@out.f)){ # nocov start replicate(sink.number(), sink()) meta_word_msg( "Tests corrupted stdout sink stack; all stdout sinks cleared." ) status[["output"]] <- FALSE # nocov end } else if(sink.number()) sink() } close(cons@err.c) close(cons@out.c) close(cons@dump.c) # Check to see if any output was stored in the dump files. These in theory # should contain no output and are used primarily when running the comparisons # between new and reference objects if(length(dump.txt <- readLines(cons@dump.f))) { warning( "Test comparison functions appear to have produced output, which should ", "not happen (see `?unitizer_sect` for more details). If you did not ", "provide custom testing functions, contact maintainer. First 50 lines ", "follow:\n", paste0(head(dump.txt, 50), "\n") ) } file.remove(cons@err.f, cons@out.f, cons@dump.f) invisible(status) } # Check whether provided connection is active stdout capture stream # note this writes to the connection to check, though it shouldn't matter # in our typical use case since `get_text` should advance the pointer by # what we write so when we retrieve the value our junk write should not be # visible is_stdout_sink <- function(desc) { stopifnot(is.chr1(desc)) identical(summary(stdout())[['description']], desc) } # Connection Tracking Objects setClass( "unitizerCaptCons", slots=c( err.f="ANY", err.c="ANY", out.f="ANY", out.c="ANY", stdout.level="integer", stderr.level="integer", # whatever connection was set for sink #2 prior to running stderr.con="ANY", dump.f="ANY", dump.c="ANY" ), validity=function(object) { # Allow NULLs since that is how the con object is stored if(!is.null(object@err.f) && !is.chr1(object@err.f)) return("Slot `err.f` must be character(1L)") if( !is.null(object@err.f) && (!inherits(object@err.c, "file") || !isOpen(object@err.c)) ) return("Slot `err.c` must be an open file connection") if(!is.null(object@out.f) && !is.chr1(object@out.f)) return("Slot `out.f` must be character(1L)") if( !is.null(object@out.f) && (!inherits(object@out.c, "file") || !isOpen(object@out.c)) ) return("Slot `out.c` must be an open file connection") if( !is.null(object@dump.f) && (!inherits(object@dump.c, "file") || !isOpen(object@dump.c)) ) return("Slot `dump.c` must be an open file connection") TRUE TRUE } ) setMethod("initialize", "unitizerCaptCons", function(.Object, ...) { dots <- list(...) .Object@stdout.level <- sink.number() .Object@stderr.level <- sink.number(type="message") err.con <- try(getConnection(.Object@stderr.level)) .Object@stderr.con <- if(!inherits(err.con, "try-error")) err.con if(length(dots)) callNextMethod() else { .Object@err.f <- tempfile() .Object@err.c <- file(.Object@err.f, "w+b") .Object@out.f <- tempfile() .Object@out.c <- file(.Object@out.f, "w+b") .Object@dump.f <- tempfile() .Object@dump.c <- file(.Object@dump.f, "w+b") .Object } } ) setClassUnion("unitizerCaptConsOrNULL", c("unitizerCaptCons", "NULL")) unitizer/R/get.R0000644000176200001440000005560314766101401013237 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Set and Retrieve Store Contents #' #' These functions are not used directly; rather, they are used by #' \code{\link{unitize}} to get and set the \code{unitizer} objects. #' You should only need to understand these functions if you are #' looking to implement a special storage mechanism for the \code{unitizer} #' objects. #' #' By default, only a character method is defined, which will interpret #' its inputs as a filesystem path to the \code{unitizer} folder. RDSes of #' serialization type 2 will be stored and retrieved from there. The #' serialization format may change in the future, but if R maintains #' facilities to read/write type 2, we will provide the option to use #' that format. At this time there is no API to change the serialization #' format. #' #' You may write your own methods for special storage situations ( #' e.g SQL database, ftp server, etc) with the understanding that the #' getting method may only accept one argument, the \code{store.id}, and #' the setting method only two arguments, the \code{store.id} and the #' \code{unitizer}. #' #' S3 dispatch will be on \code{store.id}, and \code{store.id} may #' be any R object that identifies the unitizer. For example, a potential #' SQL implementation where the unitizers get stored in blobs may look #' like so: #' \preformatted{ #' my.sql.store.id <- structure( #' list( #' server="myunitizerserver.mydomain.com:3306", #' database="unitizers", #' table="project1", #' id="cornercasetests" #' ), #' class="sql_unitizer" #' ) #' get_unitizer.sql_unitizer <- function(store.id) { # FUNCTION BODY } #' set_unitizer.sql_unitizer <- function(store.id, unitizer) { # FUNCTION BODY } #' #' unitize("unitizer/cornertestcases.R", my.sql.store.id) #' } #' Make sure you also define an \code{as.character} method for your object to #' produce a human readable identifying string. #' #' For inspirations for the bodies of the _store functions look at the source #' code for \code{unitizer:::get_unitizer.character} and #' \code{unitizer:::set_unitizer.character}. #' Expectations for the functions are as follows. \code{get_unitizer} must: #' \itemize{ #' \item return a \code{unitizer-class} object if \code{store.id} #' exists and contains a valid object #' \item return FALSE if the object doesn't exist (e.g. first time #' run-through, so reference copy doesn't exist yet) #' \item \code{\link{stop}} on error #' } #' \code{set_unitizer} must: #' \itemize{ #' \item return TRUE on success #' \item \code{\link{stop}} on error #' } #' #' @aliases get_unitizer #' @seealso \code{\link{saveRDS}} #' @export #' @param store.id a filesystem path to the store (an .rds file) #' @param unitizer a \code{unitizer-class} object containing the store #' data #' @return #' \itemize{ #' \item set_unitizer TRUE if unitizer storing worked, error otherwise #' \item get_unitizer a \code{unitizer-class} object, FALSE #' if \code{store.id} doesn't exist yet, or error otherwise; note that #' the \code{unitizer_results} method returns a list #' } set_unitizer <- function(store.id, unitizer) { UseMethod("set_unitizer") } #' @export set_unitizer.default <- function(store.id, unitizer) { stop( "No method defined for object of class \"", class(store.id)[[1]], "\"; ", "make sure that the specified `store.id` is a reference to a valid ", "unitizer store and had defined `get_unitizer` and `set_unitizer` methods." ) } #' @export set_unitizer.character <- function(store.id, unitizer) { if(!is.character(store.id) || length(store.id) != 1L) { stop("Argument `store.id` must be a 1 length character vector") } if(is.object(store.id) || !is.null(attributes(store.id))) stop("Argument `store.id` must be a bare character vector") if(!is(unitizer, "unitizer")) stop("Argument `unitizer` must be a unitizer") new.file <- FALSE if(!file.exists(store.id)) { if(!isTRUE(dir.create(store.id))) stop( "Could not create `store.id`; make sure it is a valid file name; see ", "warning for details" ) } else if (!file_test("-d", store.id)) { stop("'", store.id, "' is not a directory.") } if( inherits( try( saveRDS(unitizer, paste0(store.id, "/data.rds"), version=2)), "try-error" ) ) { stop("Failed setting unitizer; see prior error messages for details.") } TRUE } #' @rdname set_unitizer #' @export get_unitizer <- function(store.id) { UseMethod("get_unitizer") } #' @rdname set_unitizer #' @export get_unitizer.character <- function(store.id) { if(!is.character(store.id) || length(store.id) != 1L ) { stop("Argument `store.id` must be a 1 length character vector") } if(is.object(store.id) || !is.null(attributes(store.id))) stop("Argument `store.id` must be a bare character vector") if(!file.exists(store.id)) return(FALSE) if(!is_unitizer_dir(store.id)) { stop( "Argument `store.id` does not appear to refer to a unitizer directory" ) } if(inherits(try(unitizer <- readRDS(paste0(store.id, "/data.rds"))), "try-error")) { stop("Failed loading unitizer; see prior error messages for details") } if(!is(unitizer, "unitizer")) stop("Retrieved object is not a unitizer store") # if(!identical(path_clean(store.id), path_clean(unitizer@id))) { # stop( # "This check needs to be modified to not make any assumptions about ", # "unitizer structure since we don't know it is conforming yet" # ) # if(is.character(unitizer@id) & length(unitizer@id) == 1L) { # # The following warning occurred more often than not as a result of changes # # in working directory, so just quashing for now; could use `normalizePath` # # instead... # # warning( # # "ID in retrieved unitizer (", unitizer@id, ") doesn't match `store.id`; this may ", # # "be happening because you moved the store relative to the script that created it", # # immediate. = TRUE # # ) # } else { # stop( # "Internal Error: ID in retrieved unitizer is not a 1 length character vector as expected ", # "(typeof: ", typeof(unitizer@id), ", length: ", length(unitizer@id),"); contact maintainer." # ) # } } unitizer } #' @rdname set_unitizer #' @export get_unitizer.default <- function(store.id) { stop( "No method defined for object of class \"", class(store.id)[[1]], "\"; ", "make sure that the specified `store.id` is a reference to a valid ", "unitizer store and had defined `get_unitizer` and `set_unitizer` methods." ) } #' @rdname set_unitizer #' @export get_unitizer.unitizer_result <- function(store.id) { store.id <- attr(store.id, "store.id") get_unitizer(store.id) } # used purely for testing, but has to be exported #' @export get_unitizer.unitizer_error_store <- function(store.id) structure("error", class="unitizer_store_error") #' @rdname set_unitizer #' @export get_unitizer.unitizer_results <- function(store.id) { lapply(store.id, get_unitizer) } #' Infers Possible Unitizer Path From Context #' #' Used by most \code{unitizer} functions that operate on \code{unitizer}s to #' make it easy in interactive use to specify the most likely intended #' \code{unitizer} in a package or a directory. For `R CMD check` and similar #' testing should not rely on this functionality. #' #' This is implemented as an S3 generic to allow third parties to define #' inference methods for other types of \code{store.id}, but the documentation #' here is for the \code{"character"} method which is what \code{unitizer} uses #' by default. #' #' If \code{store.id} is a directory that appears to be an R package (contains #' DESCRIPTION, an R folder, a tests folder), will look for candidate files in #' \code{file.path(store.id, "tests", "unitizer")}, starting with files with the #' same name as the package (ending in ".R" or ".unitizer" if \code{type} is #' \code{"f"} or \code{"u"} respectively), or if there is only one file, that #' file, or if there are multiple candidate files and in interactive mode #' prompting user for a selection. If \code{type} is \code{"d"}, then will #' just provide the \code{"tests/unitizer"} directory. #' #' If \code{name} is not a directory, will try to find a file by that name, and #' if that fails, will try to partially match a file by that name. Partial #' matching requires the front portion of the name to be fully specified and #' no extension be provided (e.g. for \code{"mytests.R"}, \code{"myt"} is valid, #' but \code{"tests"} and \code{"myt.R"} are both invalid). Partially specified #' files may be specified in subdirectories (e.g. \code{"tests/myt"}). #' #' Inference assumes your files end in \code{".R"} for code files and #' \code{".unitizer"} for \code{unitizer} data directories. #' #' If \code{store.id} is NULL, the default \code{infer_unitizer_location} method #' will attempt to find the top level package directory and then call the #' character method with that directory as \code{store.id}. If the parent #' package directory cannot be found, then the character method is called with #' the current directory as the argument. #' #' @export #' @seealso \code{\link{get_unitizer}} for discussion of alternate #' \code{store.id} objects #' @param store.id character(1L) file or directory name, the file name portion #' (i.e after the last slash) may be partially specified #' @param type character(1L) in \code{c("f", "u", "d")}, \code{"f"} for test #' file, \code{"d"} for a directory, \code{"u"} for a \code{unitizer} #' directory #' @param interactive.mode logical(1L) whether to allow user input to resolve #' ambiguities #' @param ... arguments to pass on to other methods #' @return character(1L) an inferred path, or \code{store.id} with a warning if #' path cannot be inferred infer_unitizer_location <- function(store.id, ...) UseMethod("infer_unitizer_location") #' @rdname infer_unitizer_location #' @export infer_unitizer_location.default <- function(store.id, ...) { if(is.null(store.id)) { def.dir <- if( length(pkg.dir <- get_package_dir(".")) && file_test("-d", file.path(pkg.dir, "tests", "unitizer")) ) { file.path(pkg.dir, "tests", "unitizer") } else "." return(infer_unitizer_location.character(def.dir, ...)) } store.id } #' @rdname infer_unitizer_location #' @export infer_unitizer_location.character <- function( store.id, type="f", interactive.mode=interactive(), ... ) { if(!is.character(store.id) || length(store.id) != 1L || is.na(store.id)) stop("Argument `store.id` must be character(1L) and not NA") if( !is.character(type) || length(type) != 1L || !isTRUE(type %in% c("f", "u", "d")) ) stop("Argument `type` must be one of `c(\"f\", \"u\", \"d\")`") if(!isTRUE(interactive.mode) && !identical(interactive.mode, FALSE)) stop("Argument `interactive.mode` must be TRUE or FALSE") # BEWARE, you can't just change `text.ext` here without reviewing how it is # used if(type == "f") { test.fun <- function(x) file_test("-f", x) test.ext <- ".R" list.fun <- list.files type.name <- "test file" } else if(type == "u") { test.fun <- is_unitizer_dir test.ext <- ".unitizer" list.fun <- list.dirs type.name <- "unitizer" } else if(type == "d") { test.fun <- function(x) file_test("-d", x) test.ext <- NULL list.fun <- list.dirs type.name <- "test directory" } inf_msg <- function(name) meta_word_msg( "Inferred", type.name, "location:", relativize_path(name), sep=" " ) # Is a directory, check if a package and pick tests/unitizer as the directory if(!file_test("-d", store.id)) { dir.store.id <- dirname(store.id) file.store.id <- basename(store.id) } else { dir.store.id <- store.id file.store.id <- NULL } dir.store.id <- normalize_path(dir.store.id) at.package.dir <- file_test("-d", dir.store.id) && isTRUE(is_package_dir(dir.store.id)) # Check for exact match first and return that if found, unless we are in dir # mode and the directory is a package directory if(!(identical(type, "d") && at.package.dir) && test.fun(store.id)) return(store.id) # If we're not at the package directory, check to see if we are in a package # directory and change directory to that, but only do that if we're not # already matching an actual directory if( !at.package.dir && !is.null(file.store.id) && length(pkg.dir.tmp <- get_package_dir(dir.store.id)) ) { at.package.dir <- TRUE dir.store.id <- pkg.dir.tmp } if(at.package.dir) { test.base <- file.path(dir.store.id, "tests", "unitizer") if(!file_test("-d", test.base)) stop("Unable to infer path since \"tests/unitizer\" directory is missing") found.file <- test.fun( fp <- do.call( file.path, as.list( c(test.base, paste0(file.store.id, basename(dir.store.id), test.ext)) ) ) ) if(found.file) { inf_msg(fp) return(fp) } # use tests/unitizer as starting point for any package dir.store.id.proc <- test.base } else { dir.store.id.proc <- dir.store.id } # Check request is coherent already and if so return f.path <- do.call(file.path, as.list(c(dir.store.id.proc, file.store.id))) if(test.fun(f.path)) { inf_msg(f.path) return(f.path) } # Resolve potential ambiguities by trying to find file / directory candidate.files <- grep( paste0("^", file.store.id, if(!is.null(test.ext)) ".*\\", test.ext, "$"), basename(list.fun(dir.store.id.proc, recursive=FALSE)), value=TRUE ) cand.len <- length(candidate.files) selection <- if(cand.len > 1L) { if(!interactive.mode || cand.len > 100L) { warning( cand.len, " possible targets; ", if(interactive.mode) "cannot" else "too many to", " unambiguously infer desired file", immediate.=TRUE ) return(store.id) } dir.disp <- if(!identical(dir.store.id, dir.store.id.proc)) { paste0( " from \"", sub( paste0("^", normalize_path(dir.store.id), "/?"), "", normalize_path(dir.store.id.proc) ), "\"" ) } else "" # Select one: valid <- seq_along(candidate.files) cat(paste0("Possible matching files", dir.disp, ":\n")) cat(paste0(" ", format(valid), ": ", candidate.files), sep="\n") pick <- unitizer_prompt( "Pick a matching file", valid.opts=c("Type a number"), exit.condition=exit_fun, valid.vals=valid, hist.con=NULL, global=NULL, browse.env=.GlobalEnv ) if(identical(pick, "Q")) { message("No file selected") 0L } else { pick <- as.integer(pick) message("Selected file: ", candidate.files[[pick]]) pick } } else if (cand.len == 1L) { 1L } else if (cand.len == 0L) { warning("No possible matching files for '", store.id, "'", immediate.=TRUE) return(store.id) } if(!selection && interactive.mode) { warning("Invalid user selection", immediate.=TRUE) return(store.id) } else if(!selection) { # nocov start stop( "Internal Error: should never have non.interactive zero selection; ", " contact maintainer." ) # nocov end } # Return file.final <- file.path(dir.store.id.proc, candidate.files[[selection]]) if(cand.len == 1L) inf_msg(file.final) file.final } # Check Whether Directories Are Likely R Package Source Directories # # Heuristic check to see whether a directory contains what likely could be # built into an R package. This is based on the DESCRIPTION file and directory # structure. # # \code{is_package_dir} checks whether a directory is the top level directory # of a package. # # \code{get_package_dir} checks whether a directory or any of its parents is the # top level directory of a package, and returns the top level package directory # or character(0L) if not # # @keywords internal # @param name a directory to check for package-ness # @param has.tests whether to require that the package have tests to qualify # @param DESCRIPTION the DESCRIPTION file path # @return TRUE if criteria met, character vector explaining first failure # otherwise is_package_dir <- function(name, has.tests=FALSE) { stopifnot(is.character(name), is.TF(has.tests)) if(!is.character(name)) return("not character so cannot be a directory") if(!file_test("-d", name)) return("not an existing directory") pkg.name <- try(get_package_name(name), silent=TRUE) if(inherits(pkg.name, "try-error")) return(conditionMessage(attr(pkg.name, "condition"))) # Has requisite directories? if(!file_test("-d", file.path(name, "R"))) return("missing 'R' directory") if(has.tests && !file_test("-d", file.path(name, "tests"))) return("missing 'tests' directory") # Woohoo TRUE } get_package_dir <- function(name=getwd(), has.tests=FALSE, exists=FALSE) { stopifnot( is.character(name), !any(is.na(name)), is.TF(has.tests), as.logical(length(name)) ) name <- normalize_path(name, mustWork=FALSE, exists=exists) if(length(name) > 1L) name <- attr(unique_path(name), "common_dir") is.package <- FALSE prev.dir <- par.dir <- name repeat { if(isTRUE(is_package_dir(par.dir, has.tests))) { return(par.dir) } else if (isTRUE(is_rcmdcheck_dir(par.dir, has.tests))) { return(get_rcmdcheck_dir(par.dir, has.tests)) } else if (isTRUE(is_testinstpkg_dir(par.dir, has.tests))) { return(get_testinstpkg_dir(par.dir, has.tests)) } if(nchar(par.dir <- dirname(prev.dir)) >= nchar(prev.dir)) break prev.dir <- par.dir } character(0L) } # Checks Whether a Directory Could be of the Type Used by R CMD check is_rcmdcheck_dir <- function(name, has.tests=FALSE) { stopifnot(is.chr1(name), is.TF(has.tests)) dir <- basename(name) if(grepl(".*\\.Rcheck$", dir)) { pkg.name <- sub("(.*)\\.Rcheck", "\\1", dir) if(identical(pkg.name, dir)) stop( "Logic error; failed extracting package name from Rcheck dir; ", "contact maintianer" ) if(isTRUE(is.pd <- is_package_dir(file.path(name, pkg.name), has.tests))) { return(TRUE) } else return(is.pd) } else return("not a .Rcheck directory") } # Checks Whether a Directory could be of the type generated by # tools::testInstalledPackages is_testinstpkg_dir <- function(name, has.tests=FALSE) { stopifnot(is.chr1(name), is.TF(has.tests)) dir <- basename(name) if(grepl(".*-tests$", dir)) { pkg.name <- sub("(.*)-tests$", "\\1", dir) if(identical(pkg.name, dir)) stop( "Internal error; failed extracting package name from ", "testInstalledPackages dir; contact maintainer." ) if( isTRUE( is.pd <- is_package_dir(file.path(dirname(name), pkg.name), has.tests) ) ) { return(TRUE) } else return(is.pd) } else "No *-tests directories" } # Extracts the Source Directory from an R CMD check directory get_rcmdcheck_dir <- function(name, has.tests=FALSE) { stopifnot(is.chr1(name), is.TF(has.tests)) if(isTRUE(chk.dir <- is_rcmdcheck_dir(name, has.tests))) { pkg.name <- sub("(.*)\\.Rcheck", "\\1", basename(name)) return(file.path(name, pkg.name)) } else stop("Internal Error: not an R CMD check dir") # nocov } # Extracts the Source Directory from an testInstalledPackage directory, looks # like this will be a bit of a bear to test, see the code in covr that uses # tools::testInstalledPackage for some potential things to worry about get_testinstpkg_dir <- function(name, has.tests=FALSE) { stopifnot(is.chr1(name), is.TF(has.tests)) if(isTRUE(chk.dir <- is_testinstpkg_dir(name, has.tests))) { pkg.name <- sub("(.*)-tests$", "\\1", basename(name)) return(file.path(dirname(name), pkg.name)) } else stop("Internal Error: not an testInstalledPackage dir") # nocov } # Pulls Out Package Name from DESCRIPTION File # # Dir must be a package directory, check with is_package_dir first get_package_name <- function(pkg.dir) { stopifnot(is.chr1(pkg.dir)) DESCRIPTION <- file.path(pkg.dir, "DESCRIPTION") if(!file_test("-f", DESCRIPTION)) stop("No DESCRIPTION file") desc <- try(readLines(DESCRIPTION)) if(inherits(desc, "try-error")) stop("Unable to read DESCRIPTION file") pkg.pat <- "^\\s*package:\\s+(\\S+)\\s*$" desc.pkg <- grep(pkg.pat, desc, value=T, perl=T, ignore.case=TRUE) if(length(desc.pkg) != 1L) stop( "DESCRIPTION file ", if(length(desc.pkg)) "had more than one" else "did not have a", " package name entry" ) desc.pkg.name <- sub(pkg.pat, "\\1", desc.pkg, perl=T, ignore.case=TRUE) return(desc.pkg.name) } # Check Whether a Directory as a Unitizer Data Directory # # Just checks that it \emph{could} be a data directory, the test ultimately is # to attempt a \code{\link{get_unitizer}} call and see if we actually resurrect # a working \code{unitizer} # # @keywords internal # @param dir character(1L) directory to check # @return logical(1L) is_unitizer_dir <- function(dir) is.character(dir) && length(dir) == 1L && !is.na(dir) && file_test("-d", dir) && file_test("-f", file.path(dir, "data.rds")) # Run \code{sys.source} On All Provided Files # # Sorts them before sourcing on the paths as specified in \code{files}, returns # an environment containing any objects created by the code in the source # files. If a file is a directory, the files in that directory are sourced, # though only top level files in that directory are sourced. # # @keywords internal # @param files character() pointing to files or directories # @param env an environment # @return environment, or a character message explaining why it failed source_files <- function(files, env.par, pattern="\\.[rR]$") { stopifnot( is.character(files), is.chr1(pattern), !inherits(try(grepl(pattern, "a"), silent=TRUE), "try-error"), is.environment(env.par) ) file.norm <- try(normalize_path(files, mustWork=TRUE)) if(inherits(file.norm, "try-error")) return("Unable to normalize file paths; see previous error") env <- new.env(parent=env.par) for(i in sort(file.norm)) { sub.files <- if(file_test("-d", i)) { dir.cont <- try( list.files( i, pattern=pattern, all.files=TRUE, full.names=TRUE, no..=TRUE ) ) if(inherits(dir.cont, "try-error")) return("Unable to list file contents of directory; see previous error") dir.cont } else i for(j in sub.files) { fail <- inherits(try(sys.source(j, env)), "try-error") if(fail) return(paste0("Error sourcing file `", j, "`, see above for details")) } } env } unitizer/R/rename.R0000644000176200001440000000760614766101401013727 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Edit Calls In Unitizer #' #' Used if you want to change language in test expression in a unitizer when #' the actual results of running the expressions is unchanged. This is useful #' if you decided to rename functions, etc., without having to re-run the entire #' \code{unitize} process since \code{unitize} matches tests based on #' expressions. #' #' @note this is a somewhat experimental function, so make sure you backup any #' unitizers before you try to use it. #' #' @export #' @rdname editCalls #' @param x a unitizer object #' @param lang.old the name of the function replace #' @param lang.new the new name of the function #' @param ... unused #' @return a untizer object with function names modifies setGeneric("editCalls", function(x, lang.old, lang.new, ...) standardGeneric("editCalls") ) #' @export #' @rdname editCalls #' @inheritParams unitize #' @param interactive.only logical(1L) set to FALSE if you want to allow this to #' run in non-interactive mode, but warnings will be suppressed and will #' proceed without prompting, obviously... #' @examples #' \dontrun{ #' untz <- get_unitizer("tests/unitizer/mytests.unitizer") #' untz.edited <- editCalls(untz, quote(myFun), quote(my_fun)) #' set_unitizer("tests/unitizer/mytests.unitizer", untz.edited) #' } setMethod("editCalls", c("unitizer", "language", "language"), function( x, lang.old, lang.new, interactive.mode=interactive(), interactive.only=TRUE, ... ) { warning( "This is an experimental function; make sure you backup any unitizers ", "before you edit them", immediate.=TRUE ) if(!interactive.mode && interactive.only) stop("Set interactive.only to FALSE to run in non-interactive mode") i <- 0L if(interactive.only) { u.inp <- simple_prompt( "Do you wish to proceed ([Y]es/[N]o)? " ) if(!identical(u.inp, "Y")){ message("Exiting without edits") return(x) } } call_sub <- function(call, old.name, new.name) { if(is.language(call)) { if(identical(call, old.name)) return(new.name) if(length(call) > 1) for(j in 1:length(call)) if(is.language(call[[j]])) call[[j]] <- Recall(call[[j]], old.name, new.name) } call } for(i in seq_along(x@items.ref)) { # complexity here driven by a change from storing the actual call to # only keeping the deparsed version, but not wanting to re-write all the # code for the renaming call.is.null <- FALSE if(is.null(x@items.ref[[i]]@call)) { call.parsed <- parse(text=x@items.ref[[i]]@call.dep) if(!is.expression(call.parsed) || length(call.parsed) != 1L) # nocov start stop( "Internal Error: call `", x@items.ref[[i]]@call.dep, "` did not produce a length one expression when parsed" ) # nocov end x@items.ref[[i]]@call <- call.parsed[[1L]] call.is.null <- TRUE } x@items.ref[[i]]@call <- call_sub(x@items.ref[[i]]@call, lang.old, lang.new) x@items.ref[[i]]@call.dep <- deparse_call(x@items.ref[[i]]@call) x@items.ref.calls.deparse[[i]] <- x@items.ref[[i]]@call.dep if(call.is.null) x@items.ref[[i]]@call <- NULL } x } ) unitizer/R/shims.R0000644000176200001440000002571014766101401013577 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include class_unions.R #' @include global.R NULL # Return List With Return Call Locations # # List is in same format as the \code{at} parameter for trace # # NOTE: deprecated by trace_at_end find_returns <- function(fun) { stopifnot(is.function(fun)) ret.lang <- as.name("return") rec_fn <- function(x) { if(is.call(x) && is.name(x[[1L]]) && x[[1L]] == ret.lang) { list(NULL) } else if (is.call(x) && length(x) > 1L) { index.res <- list() for(i in tail(seq_along(x), -1L)) { res <- Recall(x[[i]]) if(is.list(res)) index.res <- c(index.res, lapply(res, function(x) c(i, x))) } index.res } } rec_fn(body(fun)) } # Given a function and find_returns value, pull out the referenced statements # # NOTE: deprecated by trace_at_end get_returns <- function(fun, ret.loc) { bod <- as.list(body(fun)) lapply( ret.loc, function(x) {val <- bod; for(i in x) val <- val[[i]]; val} ) } ## Add a tracing expression at end of a function ## ## This works generically for all functions, even when they themselves use ## `on.exit`. Total hack, but it works. ## ## Note that one trade-off on this one is that we squelch any errors produced ## by the original function, and then re-issue them as part of the trace code. ## This is so that the error message itself shows the function name. The ## drawback of this is that the original trace is overwritten so some ## information is lost there which could be a problem. ## ## The tracing code will be run irrespective of whether the function succeeds ## or not. The tracing code may not run if the code issues a condition other ## than a 'simpleError' that is handled by an earlier handler than the one ## generated by `trace_at_end` that does not return control. Make sure that ## if the tracing code uses the result of evaluating the function (available as ## `.res`), it is robust and has its own error handling. ## ## @param fun must be character(1L), name of a function ## @param tracer an expression to insert in fun ## @param print TRUE or FALSE ## @param where a namespace trace_at_end <- function(fun, tracer, print, where) { stopifnot(is.character(fun) && length(fun) == 1L) # `trace_editor` returns a modifed version of the `name` input function # that calls the `name` function but adds some additional tracing code after # evaluating. Substantial convolution required to make sure that the final # tracing code is run (e.g. if a function actually calls `return`), and also # that the body of the original function can run transparently (e.g. # calls to `missing`, etc). trace_editor <- function(name, file, title) { # `name` will be a function f.copy <- function() NULL formals(f.copy) <- formals(name) body(f.copy) <- body(name) # Now generate the wrapping function f.fin <- function() NULL formals(f.fin) <- formals(name) body(f.fin) <- bquote({ m.c <- match.call() m.c[[1L]] <- .(f.copy) .res <- try(withVisible(eval(m.c, parent.frame())), silent=TRUE) .doTrace(.(tracer)) if(inherits(.res, "try-error")) { cond <- attr(.res, "condition") stop(simpleError(message=conditionMessage(cond), call=sys.call())) } with(.res, if(visible) value else invisible(value)) }) parent.env(environment(f.fin)) <- parent.env(environment(name)) f.fin } old.edit <- options(editor=trace_editor) on.exit(options(old.edit)) trace(fun, edit=TRUE, where=where) invisible(fun) } ## Internal wrapper around untrace so that we can test unexpected behavior untrace_utz <- function( what, signature = NULL, where = topenv(parent.frame()) ) base::untrace(what=what, signature=signature, where=where) # Function for testing tracing stuff trace_test_fun <- function(x=0) { on.exit(NULL) x <- x + 1 x <- 2 } .unitizer.base.funs <- list( library=base::library, attach=base::attach, detach=base::detach ) .unitizer.base.funs.to.shim <- c( "library", "attach", "detach" ) .unitizer.tracer <- quote( { .par.env <- asNamespace("unitizer")$.global$global$par.env parent.env(.par.env) <- as.environment(2L) } ) # Used to have both exit and at slots, but we removed it with the development # of trace_at_end setClass( "unitizerShimDat", slots=c( at="integer", tracer="languageOrNULL" ), prototype=list(at=0L) ) .unitizer.shim.dat <- list( library=new("unitizerShimDat", tracer=.unitizer.tracer), attach=new("unitizerShimDat", tracer=.unitizer.tracer), detach=new("unitizerShimDat", tracer=.unitizer.tracer) ) unitizerGlobal$methods( shimFuns=function(funs=.unitizer.base.funs.to.shim) { ' Shimming is solely to ensure that the parent environment tracks position 2 in the search path ' parent.env(par.env) <<- as.environment(2L) err.base <- paste( "Unable to shim required functions to run with `par.env=NULL` because", "%s. Setting `par.env=.GlobalEnv`." ) stopifnot(is.character(funs), all(!is.na(funs))) funs.to.shim <- mget( funs, ifnotfound=vector("list", length(funs)), mode="function", envir=.BaseNamespaceEnv ) err.extra <- "" # 0 char means no error if(!tracingState()) { err.extra <- "tracing state is FALSE" } else if(!all(vapply(funs.to.shim, is.function, logical(1L)))) { err.extra <- "some cannot be found" } else if( any(vapply(funs.to.shim, inherits, logical(1L), "functionWithTrace")) ) { err.extra <- "they are already traced" } if(nchar(err.extra)) { warning(sprintf(err.base, err.extra), immediate.=TRUE) parent.env(par.env) <<- .GlobalEnv return(FALSE) } # apply shims if(shim.fail <- !all(vapply(funs, .self$shimFun, logical(1L)))) { unshimFuns() # This also resets par.env parent return(FALSE) } return(TRUE) }, shimFun=function(name) { fun <- getFun(name) stopifnot(is.function(fun)) if(is(fun, "functionWithTrace")) stop("Function `", name, "` already traced; cannot proceed.") # Now shim if(!is(.unitizer.shim.dat[[name]], "unitizerShimDat")) stop("Internal Error: missing shim data") shimmed <- try( # Use to have the option to use the @at portion of the shim data so # not forced to do a trace_at_end, see commit c3b8676ef903409a60e0b withCallingHandlers( trace_at_end( name, tracer=.unitizer.shim.dat[[name]]@tracer, where=.BaseNamespaceEnv, print=FALSE ), # Re-emit any unexpected messages message=function(e) { if( !identical( sprintf( "Tracing function \"%s\" in package \"namespace:base\" ", name ), gsub("\n", " ", conditionMessage(e)) ) ) { signalCondition(e) } else { invokeRestart("muffleMessage") } } ) ) if(inherits(shimmed, "try-error")) { warning("Failed attempting to trace `", name, "`; see prior errors") return(FALSE) } if(!is(getFun(name), "functionWithTrace")) { # Shouldn't be possible to get to this branch so can't test # nocov start warning( "Function `", name, "` was not traced even though tracing attempt did ", "not produce errors." ) return(FALSE) # nocov end } # Store shimmed functions so we can check whether they have been # un/reshimmed shim.funs[[name]] <<- getFun(name) TRUE }, unshimFuns=function() { parent.env(par.env) <<- .GlobalEnv msg.extra <- cc( "you should consider manually untracing the function, or restarting ", "your R session to restore function to original value." ) untraced <- not.equal <- character() shimmed.funs <- length(shim.funs) shim.funs.names <- names(shim.funs) for(i in shim.funs.names) { # if not identical, then someone else shimmed / unshimmed if(identical(getFun(i), shim.funs[[i]])) { withCallingHandlers( untrace_utz(i, where=.BaseNamespaceEnv), # suppress the expected unshimming message, but not others message=function(e) { if( !identical( sprintf( "Untracing function \"%s\" in package \"namespace:base\" ", i ), gsub("\n", " ", conditionMessage(e)) ) ) { signalCondition(e) } else { invokeRestart("muffleMessage") } } ) untraced <- c(untraced, i) } else if(is(getFun(i), "functionWithTrace")) { not.equal <- c(not.equal, i) } # Note we remove shim funs from list even if we did not untrace them since # from this point forward we basically declare we have nothing to do with # the tracing shim.funs[[i]] <<- NULL } # Get list of functions that were not unshimmed still.traced <- vapply( shim.funs.names, function(x) is(getFun(x), "functionWithTrace"), logical(1L) ) if(any(still.traced)) { err.1 <- err.2 <- "" if(length(not.equal)) { err.1 <- cc( char_to_eng(sprintf("`%s`", not.equal)), " not untraced because they were modified by something other ", "than unitizer.\n" ) } if(any(still.traced.other <- !still.traced %in% not.equal)) { err.2 <- cc( char_to_eng(sprintf("`%s`", still.traced[still.traced.other])), " not untraced for unknown reasons; please report to ", "maintainer.\n" ) } warning(err.1, err.2, "\n", msg.extra) } TRUE }, checkShims=function() { fail <- FALSE if(!tracingState()) { warning( "Tracing state off, so disabling clean parent env", immediate.=TRUE ) fail <- TRUE } shim.status <- vapply( names(shim.funs), function(i) identical(getFun(i), shim.funs[[i]]), logical(1L) ) if(!all(shim.status)) { warning( "Traced functions unexpectedly changed, disabling clean parent env", immediate.=TRUE ) fail <- TRUE } if(fail) { unshimFuns() FALSE } else TRUE } ) #' Utility Function #' #' @keywords internal getFun <- function(name) { fun <- try( get(name, envir=.BaseNamespaceEnv, inherits=FALSE, mode="function"), silent=TRUE ) if(inherits(fun, "try-error")) NULL else fun } unitizer/R/heal.R0000644000176200001440000004557014766101401013373 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include item.R #' @include item.sub.R #' @include unitizer.R NULL setGeneric("healEnvs", function(x, y,...) standardGeneric("healEnvs")) #' Fix Environment Ancestries #' #' This is an internal method and exposed so that this aspect of \code{unitizer} #' is documented for package users (see Details). #' #' Environment healing is necessary because when we let the user pick and chose #' which tests to store and which ones to reject, there may no longer be a clear #' ancestry chain within the remaining tests. #' #' The healing process is somewhat complex and full of compromises. We #' are attempting to create a self consistent set of nested parent environments #' for each test, but at the same time, we don't want to store all the #' combinations of reference and new objects. #' #' We only store new objects in \code{unitizer}, with the lone exception of #' objects associated to a test environment. These will include any assignments #' that occur just prior to a test, as well as any objects created by the #' actual test. #' #' There are two ways in which we modify the environment ancestry. If #' the user decides to not store some new tests, then the objects created #' in between the previous new stored test and the next new stored test are #' all moved to the next new stored test, and the previous new stored test #' becomes the parent of the next new stored test. #' #' The second way relates to when the user decides to keep a reference #' test over a matching new test. This is a lot more complicated because #' we do not preserve the reference test environment ancestry. Effectively, #' we need to graft the reference test to the new environment ancestry. #' #' If a reference test that is being kept matches directly to a new test, #' then the parent of that new test becomes the parent of the reference #' test. #' #' If there is no direct match, but there are child reference tests that #' match to a new item, then the parent is the youngest new test that #' is older than the new test that was matched and is kept. If no new #' tests meet this criterion, then base.env is the parent. #' #' If there is no direct match, and there are no child reference tests #' that are being kept that do match to a kept new item, then the parent #' will be the last new test that is kept. #' #' The main takeaway from all this is that reference tests don't really #' keep their evaluation environment. Often this environment is similar #' to the new environment. When there are difference between the two, #' the output of \code{ls} is customized to highlight #' which objects were actually available/unmodified at the time of the #' reference test evaluation. Object names will have the following #' symbols appended to explain the object status: #' \itemize{ #' \item ': object exists in browsing environment, but not the same as #' it was when test was evalaluated #' \item *: object was present during test evaluation but is not #' available in unitizer anymore #' \item **: object was not present during test evaluation, but exists #' in current environment #' } #' @note Could be more robust by ensuring that items in \code{x} actually do #' come from \code{y}. This is particularly important since when #' we re-assemble the final list, we don't actually use x at all. Signature #' for this should probably ultimately change to be something like #' \code{c("unitizer", "x")} where x is just a data frame with column 1 #' the item index, and column 2 whether it originated from "new" or "ref" #' #' @aliases healEnvs,unitizerItems,unitizer-method #' @seealso \code{updateLs,unitizerItem-method} #' @param x \code{unitizerItems} object #' @param y \code{unitizer} object \code{x} was generated from #' @param ... unused, here for inheriting methods #' @return \code{unitizerItems} #' @export #' @name healEnvs #' @rdname healEnvs setMethod("healEnvs", c("unitizerItems", "unitizer"), valueClass="unitizerItems", function(x, y, ...) { # Now need to reconstruct all the parenthood relationships between items, # start by figuring out the indices of all the new and reference items if(!is.environment(x@base.env)) stop("Slot `@base.env` must be defined for Argument `x`") items.new.select <- itemsType(x) == "new" & !ignored(x) items.ref.select <- itemsType(x) == "reference" & !ignored(x) items.idx <- vapply(as.list(x), function(x) x@id, integer(1L)) items.new.idx <- items.idx[items.new.select] items.ref.idx <- items.idx[items.ref.select] # Make sure that our items have a reasonable base environment, though keep # in mind we ultimately use the items pulled from `y`, and are relying on # the fact that environments are reference objects so that changing their # parents from `x` also affects the parents in `y`. See note in fun docs. # IMPORTANT COROLLARY: the only thing that should be changed in `x` is the # environment parents; any other changes will be lost since we don't # use `x` for anything other than that. parent.env(x@base.env) <- y@base.env # Reconstitute environment chain for new tests. Find gaps and assign to # items prior to gap. If missing first value, then go to first env. Note # we're cycling in the opposite order the environments are going in. Also, # ignored tests are considered gaps as they don't have their own environment gap.order <- order(items.new.idx, decreasing=TRUE) # note gaps are -ve and there is a gap if gap < -1 gaps <- diff(c(items.new.idx[gap.order], 0L)) for(i in seq_along(gaps)) { i.org <- gap.order[[i]] if(gaps[[i]] < -1L) { if(items.new.idx[[i.org]] + gaps[[i]] == 0L) { item.env <- x@base.env } else if (items.new.idx[[i.org]] + gaps[[i]] < 0) { # nocov start stop("Internal Error, gap too low, contact maintainer.") # nocov end } else { item.env <- y@items.new[[items.new.idx[[i.org]] + gaps[[i]]]]@env } # Any objects defined in gaps should be assigned to the new parent env, # though in theory there should be none unless user specifically # assigned objects during a test, which is not default behavior for(j in (gaps[[i]] + 1L):-1L) { # assumes continuous ids in items.new interim.env <- y@items.new[[items.new.idx[[i.org]] + j]]@env interim.names <- ls(envir=interim.env, all.names=T) lapply( interim.names, function(z) assign(z, get(z, interim.env), x[items.new.select][[i.org]]@env) ) } # no need to run updateLs() as that is done on addition to unitizer if(identical(x[items.new.select][[i.org]]@env, item.env)) { # This should only happen when an ignored test just before an actual # and just after another ignored test is removed from the item list; # since both the ignored tests where assigned to the environment of # the subsequent test, the normal logic here would cause the test to # have it's parent env assigned to itself. Here we had a unit test # that relied on this so we don't want to outright forbid it out of # lazyness... # nocov start warning( "Logic Problem: would have assigned circular environment ", "reference but over-rode that; this message should only show up ", "in `unitizer` development tests, if you see it please contact ", " maintainer." ) # nocov end } else { parent.env(x[items.new.select][[i.org]]@env) <- item.env } } # Any items that have for parent env the base env of the new items needs # to be re-assigned to the base env of the the item list we're processing if( identical( parent.env(x[items.new.select][[i.org]]@env), y@items.new@base.env ) ) { parent.env(x[items.new.select][[i.org]]@env) <- x@base.env } } # Now need to map reference item environment parents. See function docs # for details on the logic here ref.order <- order(items.ref.idx) tail.env <- if(length(items.new.idx)) { y@items.new[[max(items.new.idx)]]@env } else x@base.env env.list <- list() # Note that `slot.in` values can be repeated slot.in <- integer(length(items.ref.idx)) repair <- FALSE for(i in ref.order) { # First find the youngest new test that is verifiably older than # our current reference if( !length( matching.new.younger <- Filter(Negate(is.na), tail(y@items.ref.map, -items.ref.idx[[i]])) ) ) { # Nothing younger, so put at end and set up so that next one goes behind # this one need to look for non-kept items as well as otherwise could # slot something in too far down the ancestry. item.env <- tail.env slot.in[[i]] <- max(slot.in, items.new.idx) + 1L } else if ( # Nothing younger or older, note that diretly matching env doesn't count !length( matching.new.older <- ( m.n.older.tmp <- sort( Filter( Negate(is.na), head(y@items.ref.map, items.ref.idx[[i]] - 1L) ) ) )[m.n.older.tmp %in% items.new.idx] ) ) { # also, in this case must look at kept envs only since parent has to be # a kept env item.env <- y@items.new@base.env slot.in[[i]] <- min(slot.in) } else { # Something younger, and older # in this case, we must find the closest older kept new env, and use # that as a parent. Old approach used to use the a kept ref env that is # between this new env and the ref env we are working with, but this # became unmanageable in term of computing the ls diffs. item.env <- y@items.new[[tail(matching.new.older, 1L)]]@env slot.in[[i]] <- tail(matching.new.older, 1L) } # once we need to repair, stop doing this otherwise get spammed with # errors if(!repair) { item.ref.updated <- try( updateLs( x[items.ref.select][[i]], y@base.env, item.env ) ) } if(inherits(item.ref.updated, "try-error")) { # nocov start stop( "Internal Error: item environment history corrupted in unknown way; ", "contact maintainer. You can attempt to recover your `unitizer` by ", "using `repair_envs`." ) # nocov end } else if (identical(item.ref.updated, FALSE)) { # Corrupted env history, will have to repair repair <- TRUE item.ref.updated <- x[items.ref.select][[i]] } # Update object and record environment y@items.ref[[items.ref.idx[[i]]]] <- item.ref.updated env.list[[i]] <- item.env } # Now re-assign the environments; this has to be done after we run all the # lses as otherwise the ls diffs won't work since the whole point is they # compare the environment from before the re-assignment to the one after # # Remember, this modifies parent envs for y@items.ref as well! for(i in ref.order) parent.env(x[items.ref.select][[i]]@env) <- env.list[[i]] # Now re-introduce ignored tests; first figure out what actual test the # ignored tests map to. Note that the logic below means that any ignored # tests that don't have any subsequent real tests just get dropped ig_assign <- function(items) { if(!length(items)) return(integer()) ave( # for each ignored, get id of first non-ignored 1:length(items), c(0L, head(cumsum(!ignored(items)), -1L)), FUN=max ) } # for each ignored, get id of first non-ignored new.ig.assign <- ig_assign(y@items.new) ref.ig.assign <- ig_assign(y@items.ref) # nocov start if( any(!items.new.idx %in% new.ig.assign) || any(!items.ref.idx %in% ref.ig.assign) ) stop( "Internal Error: error re-assigning ignored items to actual tests; ", "contact maintainer" ) # nocov end # For each selected test, add back the ignored ones; for new ones this is # easy because we know they are all in the right order already in # y@items.new items.new.final <- y@items.new[new.ig.assign %in% items.new.idx] # For reference items, need to assign the ignored tests to the correct # section since the ignored ones are not pulled from the processed item # list, but rather from the original unitizer that hasn't had reference # items with meaningless section ids quashed in `processInput` ref.sects <- vapply( as.list(y@items.ref[ref.ig.assign]), slot, 1L, "section.id" ) for(i in seq_along(ref.ig.assign)) y@items.ref[[i]]@section.id <- ref.sects[[i]] # Refs a bit more complicated since we need to find the correct slot-in # spot; slot.in has the correct slot for each item in items.ref.idx, in the # order of items.ref.idx items.ref.final <- y@items.ref[ref.ig.assign %in% items.ref.idx] # Now need everything order as in y@items.new, and then for the `ref` values # as per `slot.in` items.final <- append(items.new.final, items.ref.final)[ order( c( new.ig.assign[new.ig.assign %in% items.new.idx], slot.in[Filter(Negate(is.na), match(ref.ig.assign, items.ref.idx))] ) ) ] # The LSes for reference items are not meaningful so should be invalidated items.final[ignored(items.final)] <- invalidateLs(items.final[ignored(items.final)]) # If environments need repairing, do so now (note this means ignored items # will get their own env?? Need to check / fix) if(repair) { items.final <- try(repairEnvs(items.final)) # nocov start if(inherits(x, "try-error")) { stop( "Internal Error: unable to repair reference test environments; ", "contact maintainer." ) } # nocov end } items.final } ) setGeneric("updateLs", function(x, ...) standardGeneric("updateLs")) # Compare The Objects In Environment for Ref vs. New Item # # Makes sure that when we call \code{ls} when browsing its environment # the information reflecting any limitations on what objects are actually # available to browse is properly reflected. # # The status of environment objects is tracked in \code{x@@ls$status}, # where objects of different status are marked like so: # \itemize{ # \item ': object exists in browsing environment, but not the same as # it was when test was evalaluated # \item *: object was present during test evaluation but is not # available in unitizer anymore # \item **: object was not present during test evaluation, but exists # in current environment # } # # This could definitely be optimized for new items. It actually represents # a substantial portion of total evaluation time and does a lot of repetitive # stuff that could easily be avoided if we put some work into it. # # @keywords internal # @param x the \code{\link{unitizerItem-class}} # @param base.env the last environment to search through for objects # @return \code{\link{unitizerItem-class}} object with updated # \code{ls} field and environment reference parent, or FALSE if the item # has a corrupted environment history setMethod("updateLs", "unitizerItem", function(x, base.env, new.par.env=NULL, ...) { if(!is.null(new.par.env) && !is.environment(new.par.env)) stop("Argument `new.par.env` should be an environment or NULL.") if(!is.environment(base.env)) stop("Argument `base.env` should be an environment.") if(!x@reference) { # should only happen with new items new.ls <- sort(run_ls(env=x@env, stop.env=base.env, all.names=TRUE)) fin.ls <- if(length(new.ls)) cbind(names=new.ls, status="") else matrix(character(), ncol=2, dimnames=list(NULL, c("names", "status"))) } else { if(!is.environment(new.par.env)) stop( "Argument `new.par.env` should be an environment when in ", "reference mode." ) ref.env.store <- new.env(parent=emptyenv()) new.env.store <- new.env(parent=emptyenv()) item.ls <- try( run_ls( env=x@env, stop.env=base.env, all.names=TRUE, store.env=ref.env.store ) ) if(inherits(item.ls, "try-error")) return(FALSE) run_ls( env=new.par.env, stop.env=base.env, all.names=TRUE, store.env=new.env.store ) # Since reference test keeps any objects defined in its own environment, # we can cheat for comparison purposes by putting those objects in the # "new" environment so they look like they exist there lapply( ls(envir=x@env, all.names=TRUE), function(y) assign(y, get(y, x@env), new.env.store) ) ref.ls <- ls(envir=ref.env.store, all.names=TRUE) if(nrow(x@ls)) { org.ls <- x@ls$names org.ref <- x@ls$status == "" } else { org.ls <- ref.ls org.ref <- rep(TRUE, length(ref.ls)) } names(org.ref) <- org.ls new.ls <- ls(envir=new.env.store, all.names=TRUE) ref.new <- vapply( ref.ls[ref.ls %in% new.ls], function(x) identical(ref.env.store[[x]], new.env.store[[x]]), logical(1L) ) # Equal b/w original, reference, and new fin.ls <- matrix(character(), ncol=2) if( length( ls.match <- names(org.ref)[ !is.na( org.ref & ( ref.new.match <- ref.new[match(names(org.ref), names(ref.new))] ) ) & ref.new.match ] ) ) fin.ls <- cbind(ls.match, "") # Exist but modified org.new.ls <- intersect(org.ls, new.ls) if(length(ls.match <- org.new.ls[!(org.new.ls %in% fin.ls[, 1])])) { fin.ls <- rbind(fin.ls, cbind(ls.match, "'")) } # Disappeared objects, and new objects if(length(setdiff(org.ls, new.ls))) fin.ls <- rbind(fin.ls, cbind(setdiff(org.ls, new.ls), "*")) if(length(setdiff(new.ls, org.ls))) fin.ls <- rbind(fin.ls, cbind(setdiff(new.ls, org.ls), "**")) } # Update item and return fin.ls <- as.data.frame(fin.ls, stringsAsFactors=FALSE) names(fin.ls) <- names(x@ls) attr(fin.ls, "reference") <- x@reference x@ls <- fin.ls[order(fin.ls$names), ] x } ) unitizer/R/browse.R0000644000176200001440000012146314766101401013757 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include unitizer.R #' @include conditions.R #' @include browse.struct.R #' @include prompt.R setGeneric( "browseUnitizer", function(x, y, ...) standardGeneric("browseUnitizer") ) ## Browse unitizer ## ## Here we are reviewing all the tests in the unitizer under three different ## lenses ## \enumerate{ ## \item tests that don't match the stored reference tests ## \item tests that don't exist in the reference tests ## \item tests that exist in the reference tests but no the new file ## \item tests that passed (these are omitted ) ## } ## Because a lot of the logic for browsing these three types of situations is ## shared, that logic has been split off into ## \code{\link{reviewNext,unitizerBrowse-method}}. The key is that that function ## will return the items that are supposed to be stored in the unitizer. These ## items will either be new or reference ones based on user decisions. ## ## Unfortunately, in order to be able to use the same logic for tasks that are ## not quite the same, a bit of contortion was needed. In particular, the ## user is always asked to input either Y, N, or Q, but the corresponding output ## from \code{\link{reviewNext,unitizerBrowse-method}} is very different ## depending on what situation we're dealing with. ## ## One important point is that by default the user input is defined as N. In ## all cases N means no change to the store, though again the interpretation is ## different depending on the situation. For example, if we add a test to the ## test script, N means don't add it to the store. If we remove a test, N means ## keep it in the store. ## ## @keywords internal ## @param x the object to browse ## @param y the derivative unitizerBrowse object of x; this needs to be passed ## in as an argument because the logic for generating it is different ## depending on whether we are using `unitize` or `review`. ## @return a unitizer if the unitizer was modified, FALSE otherwise setMethod("browseUnitizer", c("unitizer", "unitizerBrowse"), function(x, y, force.update, ...) { if(identical(y@mode, "review") && (!isTRUE(y@interactive) || force.update)) { # nocov start stop( "Internal Error: attempt to enter unitizer in review mode in ", "non-interactive state or in force.update mode, which should not be ", "possible, contact maintainer." ) # nocov end } browse.res <- browseUnitizerInternal(x, y, force.update=force.update) x@global$resetInit() # reset state # Need to store our `unitizer` if(browse.res@updated) { attempt <- try(store_unitizer(browse.res@unitizer)) if(inherits(attempt, "try-error")) meta_word_msg( "Unable to store '", getTarget(browse.res@unitizer, "'"), trail.nl=FALSE ) } else { meta_word_cat("unitizer unchanged.") } # Note how we don't actually return the result unitizer, but rather the # original one since that one will be re-used in `unitize_browse` if it # isn't re-evaled, and the one stored here isn't in correct format for that # anymore. Also note that `x` is actually modified since we mess with the # environments in `browseUnitizerInternal` x@updated <- browse.res@updated x@bookmark <- browse.res@bookmark browse.res@unitizer <- x browse.res } ) setGeneric( "browseUnitizerInternal", function(x, y, ...) standardGeneric("browseUnitizerInternal") ) setMethod( "browseUnitizerInternal", c("unitizer", "unitizerBrowse"), valueClass="unitizerBrowseResult", function(x, y, force.update, ...) { # Browse through tests that require user input, repeat so we give the user # an opportunity to adjust decisions before committing old.warn <- getOption('warn') on.exit(options(warn=old.warn)) quit.time <- getOption("unitizer.prompt.b4.quit.time") if(is.null(quit.time)) quit.time <- 10 update <- FALSE update.reeval <- FALSE slow.run <- x@eval.time > quit.time something.happened <- any( y@mapping@review.type != "Passed" & !y@mapping@ignored ) || ( any(!y@mapping@ignored) && ( identical(y@mode, "review") || y@start.at.browser ) ) if(!length(y)) { meta_word_cat("Empty unitizer; no tests to review.", trail.nl=FALSE) } else if(!something.happened && !force.update) { # nocov start shouldn't be possible to get here as this gets filtered out # by the review requirement in `unitize_browse` stop( "Internal error: All tests passed, unitizer store unchanged, you ", "should not be able to reach this point; contact maintainer." ) # note we could just issue a message here and continue and everything # would be fine, which is what we did before we made this an internal # error # nocov end } else { # Check we if we requested a re-eval and if so set the id where we were # before re-eval if(!is.null(x@bookmark)) { # NA bookmark just means start from beginning (don't set jumping.to). # Used to have a subset of all the unitizes in a directory re-reviewed if(!is.na(x@bookmark@call)) { cand.match <- which(x@bookmark@call == x@items.new.calls.deparse) cand.match.len <- length(cand.match) if(!cand.match.len || x@bookmark@id > cand.match.len) { meta_word_msg( cc( "Unable to find test you toggled re-eval from; starting ", "from beginning." ) ) } else { match.id <- cand.match[x@bookmark@id] id.map <- which(y@mapping@item.id.orig == match.id & !y@mapping@item.ref) if(!length(id.map) == 1L) { # nocov start stop( "Internal Error: unable to find bookmarked test; contact ", "maintainer." ) # nocov end } ign.adj <- find_lead_offset(id.map, y@mapping) y@last.id <- y@mapping@item.id[id.map] - (1L + ign.adj) y@jumping.to <- id.map } } } # `repeat` loop allows us to keep going if at the last minute we decide # we are not ready to exit the unitizer first.time <- TRUE repeat { user.quit <- FALSE if(!user.quit) { # Now review each test, special handling required to ensure that the # test selection menu shows up as appropriate (i.e. starting off in # review mode, or we just reviewed a typically non-reviewed test) withRestarts( { if(!done(y)) { if( first.time && (identical(y@mode, "review") || y@start.at.browser) ) { # for passed tests, start by showing the list of tests first.time <- FALSE y@review <- 0L } else { # we use y@review as delayed counter so that if user choses # to review a normally unreviewed test, we can force the # browse menu _after_ the first review by setting y@review # to -1L y <- reviewNext(y, x) if(y@review) { y@review <- y@review + 1L next } } if(identical(y@review, 0L)) { y.tmp <- review_prompt(y, new.env(parent=x@base.env)) if(identical(y.tmp, "Q")) { invokeRestart("unitizerEarlyExit") } else if(!is(y.tmp, "unitizerBrowse")) { # nocov start stop( "Internal Error: review should return `unitizerBrowse`; ", "contact maintainer." ) # nocov end } else y <- y.tmp } # Automatically increment review counter since `review_prompt` # is called directly instead of within `reviewNext` y@review <- y@review + 1L next } }, # a bit lazy to use a restart here, but this simplifies the logic # of being able to effectively have quit pathways from functions # called by this function, as well as functions called by functions # called by this function. unitizerEarlyExit=function(mode="quit", extra=NULL) { if(identical(mode, "quit")) { user.quit <<- TRUE if(is(extra, "unitizerBrowse")) y <<- extra } else stop( # nocov start "Internal Error: unexpected early exit restart value; contact ", "maintainer" ) # nocov end } ) } # Get summary of changes keep <- !y@mapping@ignored changes <- split( y@mapping@review.val[keep] != y@mapping@review.def[keep], y@mapping@review.type[keep] ) change.sum <- lapply( changes, function(x) c(sum(x), length(x)) ) for(i in names(change.sum)) slot(x@changes, tolower(i)) <- change.sum[[i]] # Finalize depending on situation if(y@interactive.error) { meta_word_msg( "User input required to proceed, but we are in non-interactive ", "mode.", sep="" ) break } else if(!y@human && !user.quit && y@auto.accept) { # quitting user doesn't allow us to register humanity... if(y@navigating || y@re.eval) stop( # nocov start "Internal Error: should only get here in `auto.accept` mode, ", "contact maintainer" ) # nocov end meta_word_msg("Auto-accepting changes...", trail.nl=FALSE) update <- TRUE break } else if( length(x@changes) > 0L || ( something.happened && (slow.run || !user.quit) ) || y@re.eval || force.update || y@force.up ) { print(H2("Finalize Unitizer")) # default update status; this can be modified if we cancel on exit # reeval update required to store last.id and must be tracked # separately so we can toggle it on or off without modifying overall # update decision; also, need to know if we started off in re.eval # mode since that tells us we activated re-eval while viewing tests # and not at the end # # Note, this is a nested repeat; there is an outer repeat that handles # individual test review, and this repeat handles the final prompt # to exit re.eval.started <- !!y@re.eval # Were we already in re-eval mode? repeat { update <- length(x@changes) || force.update || y@force.up # Make sure we did not skip anything we were supposed to review unrevavail <- 0L if(identical(y@mode, "unitize")) { unreviewed <- unreviewed(y) unrevavail <- length(unreviewed) if(unrevavail) { meta_word_cat( "You have ", unrevavail, " unreviewed tests; press ", "`B` to browse tests, `U` to go to first unreviewed test.\n", sep="" ) } } valid.opts <- c( Y="[Y]es", N=if(update) "[N]o", P="[P]rev", B="[B]rowse", U=if(unrevavail) "[U]nreviewed", R="[R]erun", RR="", O=if(!length(x@changes) || (force.update || y@force.up)) "f[O]rce" else "", QQ=if(y@multi) "[QQ]uit All" ) if(!length(x@changes) && (force.update || y@force.up)) meta_word_msg( "Running in `force.update` mode so `unitizer` will be re-saved", "even though there are no changes to record (see `?unitize`", "for details).", sep=" " ) if(update) { tar <- getTarget(x) wd <- if(file.exists(tar)) get_package_dir(tar) else if(file.exists(dirname(tar))) get_package_dir(dirname(tar)) else "" tar.final <- if(length(wd)) relativize_path(tar, wd=wd) else relativize_path(tar) if(!length(x@changes)) { meta_word_msg( "You are about to update '", tar.final, "' with re-evaluated ", "but otherwise unchanged tests.", sep="" ) } else { meta_word_msg( "You will IRREVERSIBLY modify '", tar.final, "'", if(length(x@changes)) " by", ":", sep="", trail.nl=FALSE ) } } else { meta_word_cat( "You made no changes to the unitizer so there is no need to", "update it. While unnecessary, you can force an update by", "typing O at the prompt.", sep=" " ) } if(length(x@changes) > 0) { meta_word_msg( as.character(x@changes, width=getOption("width") - 2L) ) } # Can this be rationalized with the logic in `reviewNext`? actions <- character() if(update) { actions <- c(actions, "update unitizer") nav.hlp <- paste0( "Pressing Y will replace the previous unitizer with a new ", "one, pressing P or B will allow you to re-review your ", "choices. Pressing N or Q both quit without saving changes to ", "the unitizer." ) } else if(!length(x@changes)) { nav.hlp <- paste0( "Pressing Y will exit without saving the unitizer since you ", "did not make any changes. Pressing P or B will allow you to ", "review any of the decisions you made previously, provided you ", "actually had any to make." ) } if(y@re.eval) { if(identical(y@re.eval, 1L)) { actions <- c(actions, "re-run unitizer") } else if(identical(y@re.eval, 2L)) { actions <- c(actions, "re-run all loaded unitizers") } else stop("Internal Error: unexpected re-run value") # nocov nav.hlp <- paste0( nav.hlp, "\n\nAdditionally, pressing Y will cause re-running of ", "unitizers as per your input" ) } if(!length(actions)) actions <- "exit unitizer" nav.msg <- cap_first(paste0(actions, collapse= " and ")) meta_word_cat( nav.msg, paste0("(", paste0(valid.opts[nchar(valid.opts) > 0L], collapse=", "), ")?" ), sep=" " ) user.input <- navigate_prompt( y, curr.id=max(y@mapping@item.id) + 1L, text=nav.msg, browse.env1=x@zero.env, help=nav.hlp, valid.opts=valid.opts ) if(is(user.input, "unitizerBrowse")) { y <- user.input y@review <- y@review + 1L loop.status <- "n" break } else if (isTRUE(grepl("^RR?$", user.input))) { # Re-eval y <- toggleReeval(y, user.input) next } else if (isTRUE(grepl("^O$", user.input))) { # Force update y <- toggleForceUp(y) next } else if ( grepl("^[QN]$", user.input) || identical(user.input, "QQ") ) { update <- FALSE meta_word_msg("Changes discarded.", trail.nl=FALSE) if(y@re.eval) meta_word_msg("Re-evaluation disabled.", trail.nl=FALSE) y@re.eval <- 0L loop.status <- "b" if(identical(user.input, "QQ")) y@multi.quit <- TRUE break } else if (identical(user.input, "Y")) { loop.status <- "b" break } stop("Internal Error: unhandled user action") # nocov } switch( # needed to handle multi level break loop.status, b=break, n=next, stop("Internal Error: invalid loop status, contact maintainer.")# nocov ) } else { meta_word_msg("No changes recorded.", trail.nl=FALSE) break } } } # Create the new unitizer; note we re-use the same zero and base envs as # the original `unitizer` as otherwise we end up with incosistencies when # we try to re-use the original `unitizer` without reloading in the context # of `unitize_dir` items.ref <- processInput(y) items.ref <- healEnvs(items.ref, x) # repair the environment ancestry # Need to reconcile state.new / state.ref with items.ref here state.merged <- mergeStates(items.ref, x@state.new, x@state.ref) # Instantiate new unitizer and add selected items as reference items unitizer <- new( "unitizer", id=x@id, changes=x@changes, zero.env=x@zero.env, base.env=x@base.env, test.file.loc=x@test.file.loc, state.ref=state.merged$states, global=x@global ) unitizer <- unitizer + state.merged$items # Extract and re-map sections of tests we're saving as reference if(!length(x@sections)) { if(!identical(y@mode, "review")) stop("Internal Error: should only get here in review mode") # nocov # Need to re-use our reference sections so `refSections` works since we # will not have created any sections by parsing/evaluating tests. This # is super hacky as we're partly using the stuff related to `items.new`, # and could cause problems further down the road if we're not careful x@sections <- x@sections.ref x@section.map <- x@section.ref.map } unitizer <- refSections(unitizer, x) # If `re.eval.started` set, means we asked for re-eval while browsing tests # so we want to restart there; translate a browse id to a bookmark so we can # look it up later id.cur <- y@last.id bookmark <- if( y@re.eval && re.eval.started && !y@mapping@item.ref[[id.cur]] ) { id.map <- y@mapping@item.id.orig[[id.cur]] call.dep <- x@items.new.calls.deparse[id.map] call.dep.id <- x@items.new.calls.deparse.id[id.map] new("unitizerBrowseBookmark", call=call.dep, id=call.dep.id) } # Return structure new( "unitizerBrowseResult", unitizer=unitizer, re.eval=y@re.eval, updated=update, interactive.error=y@interactive.error, data=as.data.frame(y), bookmark=bookmark, multi.quit=y@multi.quit ) } ) setGeneric("reviewNext", function(x, ...) standardGeneric("reviewNext")) # Find offset the first ignored test contiguous to our test find_lead_offset <- function(id, mapping) { if(!is.int.1L(id) || id < 0) stop("Internal Error: bad id.") # nocov if(!is(mapping, "unitizerBrowseMapping")) stop("Internal Error: bad mapping object.") # nocov if(id > length(mapping@item.id)) { # No unreviewed tests returns one more than end 0L } else { cur.sect.eligible <- mapping@sec.id[id] == mapping@sec.id & mapping@item.id.ord < mapping@item.id.ord[id] sum(cumsum(rev(!mapping@ignored[cur.sect.eligible])) == 0) } } # Bring up Review of Next test # # Generally we will go from one test to the next, where the next test is # determined by the value of \code{x@@last.id}. This means it is possible # to affect the browsing order by modifying \code{x@@last.id}. # # This method is in charge of displaying all the output for review. # # @keywords internal setMethod("reviewNext", c("unitizerBrowse"), function(x, unitizer, ...) { browsed <- x@browsing jumping <- x@jumping.to x@browsing <- x@jumping.to <- 0L last.id <- x@last.id curr.id <- x@last.id + 1L x@last.id <- curr.id if(x@last.reviewed) { last.reviewed.sec <- x@mapping@sec.id[[which(x@mapping@item.id == x@last.reviewed)]] last.reviewed.sub.sec <- x@mapping@sub.sec.id[[which(x@mapping@item.id == x@last.reviewed)]] furthest.reviewed <- if(length(which(x@mapping@reviewed))) max(which(x@mapping@reviewed)) else 0L last.id.rel <- x@mapping@item.id.rel[[which(x@mapping@item.id == x@last.reviewed)]] } else { last.reviewed.sec <- last.reviewed.sub.sec <- furthest.reviewed <- last.id.rel <- 0L } x@last.reviewed <- curr.id curr.sec <- x@mapping@sec.id[[which(x@mapping@item.id == curr.id)]] curr.sub.sec <- x@mapping@sub.sec.id[[which(x@mapping@item.id == curr.id)]] cur.sub.sec.items <- x@mapping@sub.sec.id == curr.sub.sec & x@mapping@sec.id == curr.sec curr.sub.sec.obj <- x[[curr.sec]][[curr.sub.sec]] if(last.id.rel) last.sub.sec.obj <- x[[last.reviewed.sec]][[last.reviewed.sub.sec]] id.rel <- x@mapping@item.id.rel[[which(x@mapping@item.id == curr.id)]] # Display Section Headers as Necessary valid.opts <- c( Y="[Y]es", N="[N]o", P="[P]rev", B="[B]rowse", YY="", YYY="", YYYY="", NN="", NNN="", NNNN="", O="", if(identical(x@mode, "unitize")) c(R="[R]erun", RR=""), if(x@multi) c(QQ="[QQ]uit All") ) # Pre compute whether sections are effectively ignored or not; these will # control whether stuff gets shown to screen or not ignore.passed <- !identical(x@mode, "review") && is(curr.sub.sec.obj, "unitizerBrowseSubSectionPassed") && !x@inspect.all && !x@start.at.browser ignore.sec <- all( ( # ignored and no errors x@mapping@ignored[x@mapping@sec.id == curr.sec] & !x@mapping@new.conditions[x@mapping@sec.id == curr.sec] ) | ( # passed and not in review mode x@mapping@review.type[x@mapping@sec.id == curr.sec] == "Passed" & (!identical(x@mode, "review") || !x@start.at.browser) ) | ( # auto.accept x@mapping@reviewed[x@mapping@sec.id == curr.sec] & !x@navigating ) ) && !x@inspect.all ignore.sub.sec <- ( all( ( x@mapping@ignored[cur.sub.sec.items] & !x@mapping@new.conditions[cur.sub.sec.items] ) | ( x@mapping@reviewed[cur.sub.sec.items] & !x@navigating ) ) || ignore.passed ) && !x@inspect.all multi.sect <- length( unique(x@mapping@sec.id[!(x@mapping@ignored & !x@mapping@new.conditions)]) ) > 1L # Used to track whether the previous thing displayed is an expression or # meta info prev.is.expr <- TRUE # Will the test actually require user review # Need to add ignored tests as default action is N, though note that ignored # tests are treated specially in `healEnvs` and are either included or # removed based on what happens to the subsequent non-ignored test. # reviewed items are skipped unless we're actively navigating to support # `auto.accept` will.review <- x@inspect.all || !( x@mapping@ignored[[curr.id]] || ignore.passed || (x@mapping@reviewed[[curr.id]] && !x@navigating) ) # Print Section title if appropriate, basically if not all the items are # ignored, or alternatively if one of the ignored items produced new # conditions, or if we just got here via a browse statement if( ( (!identical(last.reviewed.sec, curr.sec) && !ignore.sec) || browsed || jumping ) && multi.sect ) { prev.is.expr <- FALSE print(H2(x[[curr.sec]]@section.title)) } if( # Print sub-section title if appropriate ( !identical(last.reviewed.sub.sec, curr.sub.sec) || !identical(last.reviewed.sec, curr.sec) ) && !ignore.sub.sec || browsed || jumping ) { prev.is.expr <- FALSE print(H3(curr.sub.sec.obj@title)) rev.count <- sum(!x@mapping@ignored[cur.sub.sec.items]) prompt.txt <- paste( if(rev.count > 1L) { sprintf(curr.sub.sec.obj@detail.p, rev.count) } else curr.sub.sec.obj@detail.s, if(rev.count || x@inspect.all) paste0( sprintf(curr.sub.sec.obj@prompt, if(rev.count > 1L) "s" else ""), " ", "(", paste0( c(valid.opts[nchar(valid.opts) > 0], Q="[Q]uit", H="[H]elp"), collapse=", " ), ")?\n" ) ) meta_word_cat(prompt.txt) } # Retrieve actual tests objects item.new <- if(!is.null(curr.sub.sec.obj@items.new)) curr.sub.sec.obj@items.new[[id.rel]] item.ref <- if(!is.null(curr.sub.sec.obj@items.ref)) curr.sub.sec.obj@items.ref[[id.rel]] # Assign main object (always new if present), and set up global setting # indices; always use indices.init if don't have new items. if(is.null(item.new)) { item.main <- item.ref base.env.pri <- parent.env(curr.sub.sec.obj@items.ref@base.env) new.glob.indices <- x@global$indices.init } else { item.main <- item.new base.env.pri <- parent.env(curr.sub.sec.obj@items.new@base.env) new.glob.indices <- item.new@glob.indices } # PROBLEM HERE: in "pass mode" we want the reference state, not the new # state, but the default behavior appears to be to bind to the new state if(!identical(x@global$indices.last, new.glob.indices)) x@global$reset(new.glob.indices) # Show test to screen, but only if the entire section is not ignored, and # not passed tests, and requesting that those not be shown, and not elected # to review a test that isn't usually reviewed (x@review) diffs <- NULL if(!ignore.sub.sec || x@review == 0L) { if( x@mapping@reviewed[[curr.id]] && !identical(x@mode, "review") && will.review ) { prev.is.expr <- FALSE meta_word_msg( "You are re-reviewing a test; previous selection was: \"", x@mapping@review.val[[curr.id]], "\"", sep="" ) } if(jumping) { prev.is.expr <- FALSE meta_word_msg( sep="", "Jumping to test #", x@mapping@item.id.ord[[jumping]], " because ", "that was the test under review when test re-run was requested.", if(!is.null(unitizer@bookmark) && unitizer@bookmark@parse.mod) cc( " Note that since the test file was modified we cannot guarantee ", "the jump is to the correct test." ) ) } if(length(item.main@comment)) { if(prev.is.expr && x@mapping@ignored[last.id]) cat("\n") cat( word_comment( item.main@comment, color=unitizer@global$unitizer.opts[["unitizer.color"]] ), sep="\n" ) cat("\n") } cat(deparse_prompt(item.main), sep="\n") history_write(x@hist.con, item.main@call.dep) # show the message, and set the trace if relevant; options need to be # retrieved from unitizer object since they get reset out.std <- out.err <- FALSE if( (curr.sub.sec.obj@show.out || x@review == 0L) && sum(nchar(item.main@data@output)) ) { screen_out( item.main@data@output, max.len=unitizer@global$unitizer.opts[["unitizer.test.out.lines"]] ) out.std <- TRUE } if( !is.null(item.new) && !is.null(item.ref) && x@mapping@new.conditions[[curr.id]] || curr.sub.sec.obj@show.msg || x@review == 0L ) { if(length(item.main@data@message) && nchar(item.main@data@message)) { screen_out( item.main@data@message, max.len=unitizer@global$unitizer.opts[["unitizer.test.msg.lines"]], stderr() ) out.err <- TRUE } if(length(item.main@trace)) set_trace(item.main@trace) } # If test failed, show details of failure; note this should mean there # must be a `.new` and a `.ref` state.comp <- FALSE if( is(curr.sub.sec.obj@show.fail, "unitizerItemsTestsErrors") && !item.main@ignore ) { cat("\n") err.obj <- curr.sub.sec.obj@show.fail[[id.rel]] err.obj@.fail.context <- unitizer@global$unitizer.opts[["unitizer.test.fail.context.lines"]] diffs <- as.Diffs(err.obj) # Extract specific state based on indices and attach the to the objects; # these objects will be discarded so we don't need to worry about # nulling them out item.new@state <- unitizerGlobalStateExtract( unitizer@state.new, item.new@glob.indices ) item.ref@state <- unitizerGlobalStateExtract( unitizer@state.ref, item.ref@glob.indices ) state.comp <- all.equal(item.ref@state, item.new@state, verbose=FALSE) if(!isTRUE(state.comp)) { txt.alt <- sprintf( "State mismatch; see %s.", if(x@use.diff) "`.DIFF$state` for details" else "`.NEW$state` and `.REF$state`" ) diffs@state <- new( "unitizerItemTestsErrorsDiff", err=FALSE, txt="State mismatch:", txt.alt=txt.alt, show.diff=FALSE, use.diff=x@use.diff, diff=if(x@use.diff) diffPrint( item.ref@state, item.new@state, tar.banner=quote(.REF$state), cur.banner=quote(.NEW$state) ), diff.alt=if(!x@use.diff) as.character(all.equal(item.ref@state, item.new@state)) else character() ) } # must eval to make sure that correct methods are available when # outputing failures to screen eval( call("show", diffs), if(is.environment(item.main@env)) item.main@env else base.env.pri ) # Reset the diff to show state details in future if(!is.null(diffs@state)) diffs@state@show.diff <- TRUE } else if (out.std || out.err) cat("\n") else if (!item.main@ignore && length(item.main@data@conditions)) { # No visible output, but conditions issued. Say something as otherwise # confusing why unitizer prompt appears. cat("\n") meta_word_cat( paste0( "Test ", if(!unitizer@transcript) "silently ", "signalled conditions (use ", "e.g. .", if(item.main@reference) "REF" else "NEW", "$conditions[[1]] to inspect):\n" ) ) screen_out( capture.output(show(item.main@data@conditions)), max.len=unitizer@global$unitizer.opts[["unitizer.test.out.lines"]] ) cat("\n") } } if(!will.review) return(x) # If we get past this point, then we will need some sort of human input, so # we mark the browse object if(!x@interactive) { # can't proceed in non-interactive x@interactive.error <- TRUE x@mapping@reviewed[curr.id] <- TRUE x@mapping@review.val[curr.id] <- 'N' return(x) } x@human <- TRUE # Create evaluation environment; these are really two nested environments, # with the parent environment containing the unitizerItem values and the # child environment containing the actual unitizer items. This is so that # when user evaluates `.new` or `.ref` they see the value, but then we can # easily retrieve the full object with the `get*` functions. var.list <- c( if(!is.null(item.new)) list(.NEW=item.new, .new=item.new@data@value[[1L]]), if(!is.null(item.ref)) list(.REF=item.ref, .ref=item.ref@data@value[[1L]]), if(!is.null(diffs)) { c( list(.DIFF=diffs), if(!is.null(diffs@value)) list(.diff=diffs@value@diff) ) } ) browse.env <- list2env(var.list, parent=item.main@env) browse.eval.env <- new.env(parent=browse.env) # Functions to override env.sec <- if(!is.null(item.new) && !is.null(item.ref)) item.ref@env else NULL assign("ls", unitizer_ls, base.env.pri) assign(".traceback", unitizer_dottraceback, base.env.pri) assign("traceback", unitizer_traceback, base.env.pri) if(!is.null(env.sec)) { assign("ref", function(x) eval(substitute(x), env.sec), base.env.pri) } else { assign( "ref", function(x) { message( "`ref` is only active when there is an active secondary environment" ) }, base.env.pri ) } # More details for help in failure case help.extra.1 <- help.extra.2 <- "" if(identical(tolower(curr.sub.sec.obj@title), "failed")) { fails <- x@mapping@tests.result[curr.id, ] fail.name <- names(fails)[!fails] help.extra.1 <- if(length(fail.name) > 1L) { paste0( "mismatches in test ", paste0(head(fail.name, -1L), collapse=", "), ", and ", tail(fail.name, 1L) ) } else if(length(fail.name) == 1L) { sprintf("mismatch in test %s", fail.name) } else { # nocov start stop( "Internal Error: test failures must have populated @tests.results ", "values; contact maintainer." ) # nocov end } if("conditions" %in% fail.name) { help.extra.2 <- cc( "\n\nYou can retrieve individual conditions from the `conditionList` ", "objects inside the test objects; for example, use ", "`.NEW$conditions[[1L]]` to get first condition from new evaluation." ) } } # Options to navigate; when navigating the name of the game is set `@last.id` # to the non-ignored test just previous to the one you want to navigate to, # the loop will then advance you to that test help.prompt <- paste0( "Reviewing test #", curr.id, " (type: ", tolower(curr.sub.sec.obj@title), "). ", sprintf(curr.sub.sec.obj@help, help.extra.1, help.extra.2), "\n\nIn addition to any valid R expression, you may type the following ", "at the prompt (without backticks):\n\n" ) help.opts <- c( "`P` to go to the previous test", "`B` to see a listing of all tests", "`ls()` to see what objects are available to inspect", if(!is.null(item.new)) "`.new` for the current value, or `.NEW` for the full test object", if(!is.null(item.ref)) paste0( "`.ref` for the reference value, or `.REF` for the full reference ", "object" ), if(!is.null(item.new) && !is.null(item.ref)) paste0( "`.diff` for a diff between `.new` and `.ref`, and `.DIFF` for the ", "differences between all components in `.NEW` and `.REF`." ), paste0( "`YY`/`NN`, `YYY`/`NNN`, `YYYY`/`NNNN` to apply same choice to all ", "remaining unreviewed items in, respectively, the sub-section, ", "section, or unitizer" ), if(identical(x@mode, "unitize")) { c( paste0( "`R` to re-run the unitizer or `RR` to re-run all loaded ", "unitizers; used typically after you re-`install` the package you ", "are testing via the unitizer prompt" ), paste0( "`O` to f[O]rce update of store even when there are no accepted ", "changes" ) ) }, if(x@multi) paste0( "`QQ` to quit this unitizer and interrupt review of other queued ", "unitizers" ) ) # navigate_prompt handles the P and B cases internally and modifies the # unitizerBrowse to be at the appropriate location; this is done as a # function because same logic is re-used elsewhere repeat { # repeat needed just for re-eval toggle if( is( x.mod <- navigate_prompt( x=x, curr.id=curr.id, text=sprintf(curr.sub.sec.obj@prompt, ""), browse.env1=browse.eval.env, browse.env2=new.env(parent=parent.env(base.env.pri)), valid.opts=valid.opts, help=help.prompt, help.opts=help.opts, warn.sticky=TRUE ), "unitizerBrowse" ) ) { return(x.mod) } else if (isTRUE(grepl("^RR?$", x.mod))) { # Re-eval x <- toggleReeval(x, x.mod) Sys.sleep(0.3) # so people can see the toggle message invokeRestart("unitizerEarlyExit", extra=x) } else if (isTRUE(grepl("^O$", x.mod))) { # Force update x <- toggleForceUp(x) next } else if (isTRUE(grepl("^(Y|N)\\1{0,3}$", x.mod))) { # Yes No handling act <- substr(x.mod, 1L, 1L) act.times <- nchar(x.mod) rev.ind <- if(act.times == 1L) { curr.id } else { rev.ind.tmp <- if (act.times == 2L) { cur.sub.sec.items # all items in sub section } else if (act.times == 3L) { x@mapping@sec.id == curr.sec # all items in sub-section } else if (act.times == 4L) { TRUE # all items } else { # nocov start stop("Internal Error: unexpected number of Y/N; contact maintainer.") # nocov end } # exclude already reviewed items as well as ignored items as well as # passed items (unless in review mode for last one) indices <- which( rev.ind.tmp & !x@mapping@reviewed & !x@mapping@ignored & (x@mapping@review.type != "Passed" & !identical(x@mode, "review")) ) if(length(indices)) { show(x[indices]) help.mx <- rbind( c("Add New", "Keep New", "Drop Ref", "Drop New", "Keep New"), c("Drop New", "Keep Ref", "Keep Ref", "Keep New", "Keep Ref") ) rownames(help.mx) <- c("[Y]es", "[N]o") colnames(help.mx) <- c( "*New*", "*Failed*", "*Removed*", "*Passed*", "*Corrupted*" ) help.txt <- capture.output(print(as.data.frame(help.mx), quote=TRUE)) help <- paste0( paste0( "The effect of 'Y' or 'N' depends on what type of test you ", "are reviewing. Consult the following table for details:\n" ), paste0(help.txt, collapse="\n") ) prompt <- paste0( "Choose '", act, "' for the ", length(indices), " test", if(length(indices) > 1L) "s", " shown above" ) cat(prompt, " ([Y]es, [N]o)?\n", sep="") act.conf <- unitizer_prompt( prompt, new.env(parent=parent.env(base.env.pri)), help, valid.opts=c(Y="[Y]es", N="[N]o"), global=x@global, browse.env=new.env(parent=parent.env(base.env.pri)) ) if(identical(act.conf, "Q")) invokeRestart("unitizerEarlyExit", extra=x) if(identical(act.conf, "N")) { x@last.id <- x@last.id - 1L # Otherwise we advance to next test return(x) } } indices } if(!any(rev.ind)) { stop("Internal Error: no tests to accept/reject") # nocov } x@mapping@reviewed[rev.ind] <- TRUE x@mapping@review.val[rev.ind] <- act x@last.id <- max(rev.ind) } else if (identical(x.mod, "Q")) { invokeRestart("unitizerEarlyExit", extra=x) } else if (identical(x.mod, "QQ")) { x@multi.quit <- TRUE invokeRestart("unitizerEarlyExit", extra=x) } else { # nocov start stop( "Internal Error: `unitizer_prompt` returned unexpected value; ", "contact maintainer" ) # nocov end } break } x } ) # Re-eval toggling, only b/c we need to do it in a couple of places' # @keywords internal setGeneric("toggleReeval", function(x, ...) standardGeneric("toggleReeval")) setMethod("toggleReeval", "unitizerBrowse", function(x, y, ...) { re.status <- if(x@re.eval) "OFF" else "ON" re.mode <- switch( nchar(y), "this unitizer", "all loaded unitizers" ) meta_word_msg("Toggling re-run mode", re.status, "for", re.mode, sep=" ") x@re.eval <- if(x@re.eval) 0L else nchar(y) x }) setGeneric("toggleForceUp", function(x, ...) standardGeneric("toggleForceUp")) setMethod("toggleForceUp", "unitizerBrowse", function(x, ...) { re.status <- if(x@force.up) "OFF" else "ON" meta_word_msg("Toggling force update mode", re.status, sep=" ") x@force.up <- !x@force.up x }) unitizer/R/search.R0000644000176200001440000005707614766101401013733 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include class_unions.R NULL # Class To Track History Changes setClass( "unitizerNsListData", contains="unitizerList", validity=function(object) { if(!all(vapply(object@.items, is, logical(1L), "unitizerNamespaceData"))) return("Object may only contain environments") TRUE } ) # # Deprecated b/c way too slow # setClass( # "unitizerSearchData", contains="unitizerList", # slots=c(ns.dat="unitizerNsListData"), # prototype=list(data=NULL), # validity=function(object) { # if(!all(vapply(object@.items, is.environment, logical(1L)))) # return("Object may only contain environments") # TRUE # } # ) # setGeneric( # # nocov start # "unitizerGetPaths", function(x, ...) StandardGeneric("unitizerGetPaths") # # nocov end # ) # setMethod( # "unitizerGetPaths", "unitizerSearchData", # function(x, ...) lapply(as.list(x), attr, "path") # ) # setGeneric( # # nocov start # "unitizerGetVersions", function(x, ...) StandardGeneric("unitizerGetVersions") # # nocov end # ) #' @importFrom utils sessionInfo get_package_versions <- function(x) { ns.loaded <- names(x$ns.dat) ns.version <- vapply(x$ns.dat, "[[", character(1L), "version") pkg.names <- names(x$search.path) are.pkg <- grepl("^package:.+", pkg.names) pkg.names <- sub("^package:(.*)", "\\1", pkg.names) # base packages should not show version (issue203) base.pkg <- sessionInfo()$basePkgs pkg.sub <- match(pkg.names, ns.loaded) pkg.ver <- ns.version[pkg.sub] pkg.ver[!are.pkg | pkg.names %in% base.pkg] <- NA_character_ pkg.ver[pkg.names == "base"] <- as.character(getRversion()) pkg.ver } # Used to be an S4 method for the search data objects # # Checks whether the search data objects are equivalent, note we check names b/c # environments will usually not be equal search_dat_equal <- function(target, current) { res <- character() tar <- target$search.path cur <- current$search.path if(!isTRUE(name.comp <- all.equal(names(tar), names(cur)))) res <- c("Search Path Name Mismatch:", name.comp) if( !isTRUE( path.comp <- all.equal( lapply(tar, attr, "path"), lapply(cur, attr, "path") ) ) ) res <- c("Search Path Object Path Mismatch:", path.comp) if(length(res)) res else TRUE } # setClass( # "unitizerNamespaceData", # slots=c( # name="character", lib.loc="characterOrNULL", version="characterOrNULL" # ) ) # setClass( # "unitizerPackageData", # slots=c( # name="character", lib.loc="characterOrNULL", version="characterOrNULL" # ) ) # Reduce search path info to pkg name and version compress_search_data <- function(x) { res <- names(x$search.path) res.pkg <- grepl("^package:.+", res) ver <- get_package_versions(x) res[!is.na(ver)] <- paste0(res[!is.na(ver)], " (v", ver[!is.na(ver)], ")") res } compress_ns_data <- function(x) { vapply(x, function(y) sprintf("%s (v%s", y$names, y$version), character(1L)) } # Search Path Management Functions # # Set of functions used to manage search path state. Strategy is to # keep track of every different search path state encountered which is done # with \code{.global}, and then allow restoring to previous states with these # functions. # # While we believe the strategy used here is mostly robust, users can defeat # by changing search paths multiple times withing a single test, which we will # not journal properly, though this is not likely to be a major issue. # # \code{search_path_trim} attempts to recreate a clean environment by # unloading all packages and objects that are not loaded by default in the # default R configuration. # # This function is intended to be called after journaling has been enabled. # # \code{tools:rstudio} is kept in search path as the default argument because # it is not possible to cleanly unload and reload it because \code{attach} # actually attaches a copy of it's argument, not the actual object, and that # causes problems for that search path item. # # @keywords internal # @rdname search_path # @param keep character names of packages/objects to keep in search path; # note that base packages (see .unitizer.base.packages) that come typically # pre attached are always kept. The \code{keep} packages are an addition # to those. # @param id integer(1L) what recorded state to revert to # @param global reference object of class "unitizerGlobal" that holds the # global settings search_path_update <- function(id, global) { stopifnot(is(global, "unitizerGlobal"), is.int.pos.1L(id)) if(!id %in% seq_along(global$tracking@search.path)) { stop( # nocov start "Internal Error: attempt to reset state to unknown index; contact ", "maintainer" ) # nocov end } search.target <- global$tracking@search.path[[id]] search.curr <- global$tracking@search.path[[global$indices.last@search.path]] curr.env.check <- search_as_envs() if(!isTRUE(search_dat_equal(curr.env.check, search.curr))) { # not entirely sure this check is needed, or might be too stringent # new version of comparing entire object not tested # nocov start stop("Internal Error: mismatch between actual search path and tracked path") # nocov end } # If we exit pre-maturely we'll be in a weird state so we need to mark this # state so that next time we get here during the overall `on.exit` we can # proceed on.exit(global$state()) # Get uniquely identified objects on search path; this isn't completely # perfect because some objects that are genuinely the same might be identified # as different because R copied them during attach / detach st.id <- unitizerUniqueNames(search.target) sc.id <- sc.id.tmp <- unitizerUniqueNames(search.curr) # Drop the stuff that definitely needs to be dropped, from back so that # numbering doesn't get messed up to.detach <- which(is.na(match(sc.id, st.id))) for(i in sort(to.detach, decreasing=TRUE)) detach(pos=i) if(length(to.detach)) sc.id.tmp <- sc.id.tmp[-to.detach] # Add the stuff that definitely needs to get added, but this time from the # front so the positions make sense for(i in sort(which(is.na(match(st.id, sc.id.tmp))))) { obj.name <- names(search.target$search.path)[[i]] if(is.null(obj.name)) obj.name <- "" obj.type <- if(grepl("^package:.+", obj.name)) "package" else "object" obj.name.clean <- sub("^package:", "", obj.name) extra <- if(!is.null(attr(search.target$search.path[[i]], "path"))) dirname(attr(search.target$search.path[[i]], "path")) reattach( i, name=obj.name.clean, type=obj.type, data=search.target$search.path[[i]], extra=extra, global=global ) sc.id.tmp <- append(sc.id.tmp, st.id[[i]], i - 1L) } # Now see what needs to be swapped; make sure not to detach environments that # are not package environments that should be kept on the search path as doing # so leads to them getting copied search.keep <- keep_sp_default(global$unitizer.opts) j <- 0 repeat { reord <- match(sc.id.tmp, st.id) if(any(is.na(reord)) || !identical(length(reord), length(st.id))) # nocov start stop("Internal Error: incorrect path remapping; contact maintainer.") # nocov end if(!any(mismatch <- reord != seq_along(reord))) break if((j <- j + 1) > length(st.id) || length(which(mismatch)) < 2L) # nocov start stop("Internal Error: unable to reorder search path; contact maintainer.") # nocov end swap.valid <- mismatch & ( grepl("package:.+", sc.id.tmp) | !sc.id.tmp %in% search.keep ) if(!any(swap.valid)) # nocov start stop( "Internal Error: unable to reorder search path because of ", "'unitizer.search.path.keep' limitations. If you added objects ", "to that option, make sure you're not also attaching/detaching ", "them in your tests. If you are not doing those things, contact ", "maintainer." ) # nocov end swap.id <- min(reord[swap.valid]) swap.pos <- which(reord == swap.id) move_on_path(new.pos=swap.id, old.pos=swap.pos, global=global) sc.id.tmp <- unitizerUniqueNames(search_as_envs()) } search.new <- search() sp.check <- match(search.new, names(search.target$search.path)) if(any(is.na(sp.check)) || any(diff(sp.check) < 1L)) # nocov start stop("Internal Error: path reorder failed; contact maintainer.") # nocov end search.target$search.path <- search.target$search.path[search.new] # Replace all non packages with those in the target list since those may have # been changed (note, using search.new as it is possible we failed to fully # restore path (e.g. if a package is removed but not dettached/unloaded)) tar.objs <- vapply(search.new, is.loaded_package, logical(1L)) cur.objs <- vapply( names(search_as_envs()$search.path), is.loaded_package, logical(1L) ) if(!identical(tar.objs, cur.objs)) # nocov start stop("Internal Error: search path object type mismatch; contact maintainer.") # nocov end if(!all(tar.objs)) { for( i in which(!tar.objs & !(search.new %in% search.keep)) ) { # Don't replace identical elements; this is meant to avoid re-attaching # environments since doing so actually leads to a copy of the # environment being made if(identical(as.environment(i), search.target$search.path[[i]])) next detach(pos=i, character.only=TRUE) reattach( i, names(search.target$search.path)[[i]], type="object", data=search.target$search.path[[i]], global=global ) } } # Updated comparison method (might be too stringent) if(!isTRUE(search_dat_equal(search_as_envs(), search.target))) # nocov start stop("Internal Error: path reorder failed at last step; contact maintainer.") # nocov end on.exit(NULL) invisible(TRUE) } # This also unloads namespaces so that packages can # be reloaded with all corresponding hooks evaluating as with a normal load. # As documented in \code{?detach}, it is likely there may be some issues with # some packages with this approach. # # This function is intended to be called after journaling has been enabled. # # @param id integer(1L) what recorded state to revert to # @param global reference object of class "unitizerGlobal" that holds the # global settings namespace_update <- function(id, global) { stopifnot(is(global, "unitizerGlobal"), is.int.pos.1L(id)) if(!id %in% seq_along(global$tracking@namespaces)) # nocov start stop( "Internal Error: attempt to reset namespaces to unknown index; contact ", "maintainer" ) # nocov end ns.target <- global$tracking@namespaces[[id]] # should this be get_namespace_data()? ns.curr <- global$tracking@namespaces[[global$indices.last@namespaces]] ns.in.common <- intersect(names(ns.target), names(ns.curr)) ns.extra <- setdiff(names(ns.curr), ns.in.common) # Line up the namespaces cur.lns <- loadedNamespaces() # may contain nulls tar.lns.loc <- sapply(as.list(ns.target), "[[", "lib.loc", simplify=FALSE) tar.lns <- names(ns.target) to.unload <- setdiff(cur.lns, tar.lns) unload_namespaces( to.unload, global=global, keep.ns=global$unitizer.opts[["unitizer.namespace.keep"]] ) to.load <- setdiff(tar.lns, loadedNamespaces()) for(i in to.load) { try.ln <- try(loadNamespace(i, lib.loc=dirname(tar.lns.loc[[i]]))) if(inherits(try.ln, "try-error")) warning( "Unable to fully restore previously loaded namespaces.", immediate.=TRUE ) } invisible(TRUE) } search_path_trim <- function( keep.path=keep_sp_default(options()), global ) { stopifnot( is.character(keep.path) && !any(is.na(keep.path)), is(global, "unitizerGlobal") ) on.exit(global$state()) # detach each object, but make sure we do so in an order that doesn't cause # issues with namespace dependencies search.path.pre <- search() to.detach <- setdiff(search.path.pre, c(keep.path, .unitizer.base.packages)) to.detach.pkg <- vapply(to.detach, is.loaded_package, logical(1L)) to.detach.pkg.names <- sub("^package:", "", to.detach[to.detach.pkg]) to.keep <- intersect(c(keep.path, .unitizer.base.packages), search.path.pre) to.keep.pkg <- vapply(to.keep, is.loaded_package, logical(1L)) to.keep.pkg.names <- sub("^package:", "", to.keep[to.keep.pkg]) # start by detaching without unloading for(pack in to.detach) { if(!is.chr1(pack)) # nocov start stop("Internal Error: invalid search path token; contact maintainer.") # nocov end detach(pack, character.only=TRUE) } invisible(TRUE) } namespace_trim <- function( keep.ns=keep_ns_default(options()), global ) { stopifnot( is.character(keep.ns) && !any(is.na(keep.ns)), is(global, "unitizerGlobal") ) on.exit(global$state()) unload_namespaces(loadedNamespaces(), global=global, keep.ns=keep.ns) invisible(TRUE) } # Unload Namespaces # # Attempts to unload namespaces in an order that avoids dependency issues # based on data from \code{getNamespaceImports} # # Needs to be thought through a bit more in terms of how integrated it should # be with the functions that use it. unload_namespaces <- function( unload=loadedNamespaces(), global, keep.ns=union( getOption("unitizer.namespace.keep.base"), getOption("unitizer.namespace.keep") ) ) { stopifnot( is.character(unload), all(!is.na(unload)), is.character(keep.ns) && !any(is.na(keep.ns)), is(global, "unitizerGlobal") ) # We can't unload any namespaces associated with packages; packages must be # unloaded first search.path.pre <- search() search.path.pkg <- vapply(search.path.pre, is.loaded_package, logical(1L)) search.path.pkg.names <- sub("^package:", "", search.path.pre[search.path.pkg]) sp.depends <- unique( c( search.path.pkg.names, unlist( lapply(search.path.pkg.names, function(x) names(getNamespaceImports(x))) ) ) ) unload <- setdiff(unload, sp.depends) # Check that none of the keep namespaces reference namespaces other than the # keep namespaces, and warn otherwise since we won't be able to unload / # re-load that one to.keep.depends <- unlist( lapply( keep.ns[keep.ns %in% loadedNamespaces()], function(x) names(getNamespaceImports(x)) ) ) # Since `getNamespaceImports` is supposed to be a bit experimental, make sure # that all namespaces we got are actually loaded, which they really should be if(!all(union(sp.depends, to.keep.depends) %in% loadedNamespaces())) # nocov start stop( "Internal Error: loaded namespace dependency calculation produced ", "non-loaded namespaces; this should not happen; contact maintainer." ) # nocov end # Stuff left to unload unload.net <- setdiff(unload, c(keep.ns, to.keep.depends)) # Now unload namespaces lns.raw <- loadedNamespaces() if(!all(unload.net %in% lns.raw)) # nocov start stop( "Internal Error: attempting to unload namespaces that are not loaded; ", "contact maintainer." ) # nocov end lns.tmp <- sapply( unload.net, function(x) unique(names(getNamespaceImports(x))), simplify=FALSE ) # Get lib locations to unload DLLs later (if applicable) lib.locs <- vapply( unload.net, function(x) { if(inherits(loc <- try(find.package(x), silent=TRUE), "try-error")) { # nocov start warning( "Internal Warning: Unloading namespace \"", x, "\", but it does ", "not appear to have a corresponding installed package; if this", "warning persists please contact maintainer about it.", immediate.=TRUE ) "" # nocov end } else loc }, character(1L) ) # Cycle through path attempting to unload namespaces until we cannot unload # any more. This is not a particularly efficient algorithm, but should make # do for our purposes. Really should create a dependency matrix, decrementing # dependencies as we unload them, and look for rows (or cols) with zero values # to find namespaces to unload lns.orig <- lns <- lns.tmp safety <- 0 unloaded.success <- character(0L) repeat { if(safety <- safety + 1L > 1000) # nocov start stop( "Internal Error: namespace unloading not complete after 1000 iterations" ) # nocov end lns.names <- names(lns) unloaded.try <- integer(0L) for(i in seq_along(lns)) { tar.ns <- names(lns)[[i]] if(!tar.ns %in% unlist(lns[-i])) { # No dependencies, so attempt to unload unloaded.try <- c(unloaded.try, i) attempt <- try(unloadNamespace(tar.ns)) if(inherits(attempt, "try-error")) { # nocov start # no good way to test this warning( "Error while attempting to unload namespace `", tar.ns, "`", immediate.=TRUE ) # nocov end } else { unloaded.success <- c(unloaded.success, tar.ns) } } } # Keep looping until length of remaining namespaces doesn't decrease anymore lns <- lns[-unloaded.try] if(!length(unloaded.try)) break } # Unload any dynamic libraries associated with the stuff we detached by # matching paths to what's in dynlibs dyn.lib.fnames <- vapply(.dynLibs(), "[[", character(1L), "path") dls <- sub("/libs/[^/].*$", "", dyn.lib.fnames) lib.locs.ul <- lib.locs[unloaded.success] dls.to.ul <- lib.locs.ul[lib.locs.ul %in% dls] for(i in names(dls.to.ul)) library.dynam.unload(i, dls.to.ul[i]) if(length(lns)) { # nocov start # no good way to test this warning( "Unable to unload the following namespaces: ", char_to_eng(sort(names(lns)), "", ""), immediate.=TRUE ) # nocov end } # Warn if some namespaces could not be unloaded (likely due to dependency), # and register the conflict if we're tracking options if( ( length(unload.conf <- which(unload %in% keep.ns)) || length(lns) ) && global$status@options ) { global$ns.opt.conflict@conflict <- TRUE global$ns.opt.conflict@namespaces <- c(unload[unload.conf], names(lns)) global$status@options <- 0L global$disabled@options <- TRUE global$state() # mark state if we're not able to completely clean it up } NULL } # Check Whether a Package Is Loaded # # A package is considered loaded if it is in the search path and there is a # namespace loaded with the same name as the package # # @keywords internal # @param pkg.name character(1L) must be in format "package:pkgname" # @return TRUE if it is a loaded package is.loaded_package <- function(pkg.name) { if(!is.character(pkg.name) || length(pkg.name) != 1L) stop("Argument `pkg.name` must be character 1L") if(!isTRUE(grepl("^package:", pkg.name))) return(FALSE) just.name <- sub("^package:(.*)", "\\1", pkg.name) pkg.name %in% search() && just.name %in% loadedNamespaces() } # Path manipulation functions # # Reattaches a previously detached package to the search path reattach <- function(pos, name, type, data, extra=NULL, global) { stopifnot( is.integer(pos), identical(length(pos), 1L), !is.na(pos), pos > 0L, is.chr1plain(name), !is.na(name), is.chr1plain(type), !is.na(type), type %in% c("package", "object"), is.environment(data), is(global, "unitizerGlobal") ) if(identical(type, "package")) { suppressPackageStartupMessages( lib.try <- try(library( name, pos=pos, quietly=TRUE, character.only=TRUE, lib.loc=extra, warn.conflicts=FALSE ) ) ) if(inherits(lib.try, "try-error")) { # nocov start warning( "Warning: unable to fully restore search path; see prior ", "error, and consult `?unitizerState`, searching for \"Caveats\". ", "Contact maintainer if your problem is not covered by documentation.", immediate.=TRUE ) global$state() # nocov end } } else { base::attach(data, pos=pos, name=name, warn.conflicts=FALSE) } } # @keywords internal # @rdname reattach move_on_path <- function(new.pos, old.pos, global) { stopifnot( is.integer(new.pos), length(new.pos) == 1L, !is.na(new.pos), is.integer(old.pos), length(old.pos) == 1L, !is.na(old.pos), old.pos > new.pos, # otherwise detaching old.pos would mess path up new.pos > 1L, # can't attach at 1L is(global, "unitizerGlobal") ) sp <- search() stopifnot(new.pos <= length(sp), old.pos <= length(sp)) name <- sp[[old.pos]] obj <- as.environment(old.pos) if(is.loaded_package(name)) { type <- "package" extra <- dirname(attr(obj, "path")) } else { type <- "object" extra <- NULL } name.clean <- sub("package:", "", name) detach(pos=old.pos) reattach( pos=new.pos, name=name.clean, type=type, data=obj, extra=extra, global=global ) } # Make Unique IDs For Search Path Object # # adds ".1", ".2" etc if there are non-unique values, but first occurence is # not modified so we can match between a list with duplicates and one without. # # This use to be for unitizerSearchData objects but that was way too slow to use # in general search path tracking so had to switch to list. setGeneric( # nocov start "unitizerUniqueNames", function(x, ...) StandardGeneric("unitizerUniqueNames") # nocov end ) setMethod( "unitizerUniqueNames", "list", function(x, ...) { sp.id.base <- names(x$search.path) ave( sp.id.base, sp.id.base, FUN=function(x) { if(length(x) == 1L) return(x) c(head(x, 1L), paste0(tail(x, -1L), ".", 1:(length(x) - 1L))) } ) } ) ## Generate An Identifier out of SP objects ## ## If this needs to be optimized look at `get_namespace_data` that is very ## similar but runs on `loadedNamespaces`. ## ## Not perfect, by any means, but necessary because we can't directly compare ## the search path environments as they change on detach / re-attach get_package_data <- function() { sapply( search(), function(x) { loc <- if(grepl("^package:.+", x)) try(path.package(sub("^package:(.*)", "\\1", x))) else "" ver <- try(getNamespaceVersion(x), silent=TRUE) list( names=x, lib.loc=if(!inherits(loc, "try-error")) loc else "", version=if(!inherits(ver, "try-error")) ver else "" ) }, simplify=FALSE ) } # Helper function for loading options # # @param opts a list of options to look in for the relevant options keep_ns_default <- function(opts=options()) { ns.opts <- c("unitizer.namespace.keep.base", "unitizer.namespace.keep") valid_sp_np_default(opts, ns.opts) keep.sp <- keep_sp_default(opts) keep.sp.ns <- sub("^package:", "", grep("^package:.+", keep.sp, value=TRUE)) unique(c(unlist(opts[ns.opts]), keep.sp.ns)) } keep_sp_default <- function(opts=options()) { sp.opts <- c("unitizer.search.path.keep.base", "unitizer.search.path.keep") valid_sp_np_default(opts, sp.opts) unique(unlist(opts[sp.opts])) } # Validation function shared by ns and sp funs valid_sp_np_default <- function(opts, valid.names) { stopifnot( is.list(opts), is.character(valid.names) && !any(is.na(valid.names)), all(valid.names %in% names(opts)), all( vapply( opts[valid.names], function(x) is.character(x) && !any(is.na(x)), logical(1L) ) ) ) invisible(TRUE) } unitizer/R/global.R0000644000176200001440000004343014766101401013713 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include is.R #' @include capture.R NULL .loaded <- FALSE # gets set by .onLoad .unitizer.global.settings.names <- c("search.path", "options", "working.directory", "random.seed", "namespaces") #' Structures For Tracking Global Options #' #' Immplemented as S4 classes just so we can ensure everything is guaranteed #' to have the right slots. This is done by defining a virtual class that has #' a validity function that checks the required slots exist. #' #' Not we don't use "ANY" slots here because that would allow partially #' specified sub classes (i.e. classes with slots that are "ANY"), which we #' do not want to allow. #' #' \code{unitizerGlobalTrackingStore} is used to keep "compressed" versions of #' \code{unitizerGlobal$tracking}. The compressed versions obviously lose some #' information. In particular, environments or things that have environments #' as parents, or large objects, are not stored and instead a reference to #' a \code{unitizerDummy} object is stored. This object unambiguously #' identifies a non-stored object since no user or system code should #' normally creating a \code{unitizerDummy} object. #' #' \code{unitizerGlobalState} tracks a single state which is just one value from #' each of the slots of \code{unitizerGlobalTrackingStore} #' #' When comparing state between new and reference tests, only explicitly stored #' items are compared (though any extra or missing items may be brought up as #' possible mismatches). #' #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalBase", contains="VIRTUAL", validity=function(object) if(!identical(slotNames(object), .unitizer.global.settings.names)) { paste0( "Invalid global object, slots must be ", deparse(.unitizer.global.settings.names, width.cutoff=500L) ) TRUE } ) #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalStatus", contains="unitizerGlobalBase", slots=c( search.path="integer", options="integer", working.directory="integer", random.seed="integer", namespaces="integer" ), prototype=list( search.path=0L, working.directory=0L, options=0L, random.seed=0L, namespaces=0L ), validity=function(object) { for(i in slotNames(object)) if(!is.int.1L(slot(object, i)) || !slot(object, i) %in% 0L:2L) return(paste0("slot `", i, "` must be integer(1L) and in 0:2")) TRUE } ) #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalDisabled", contains="unitizerGlobalBase", slots=c( search.path="logical", options="logical", working.directory="logical", random.seed="logical", namespaces="logical" ), prototype=list( search.path=FALSE, working.directory=FALSE, options=FALSE, random.seed=FALSE, namespaces=FALSE ), validity=function(object) { for(i in slotNames(object)) if(!is.TF(slot(object, i))) return(paste0("slot `", i, "` must be TRUE or FALSE")) TRUE } ) #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalTracking", contains="unitizerGlobalBase", slots=c( search.path="list", options="list", working.directory="list", random.seed="list", namespaces="list" ) ) #' @rdname global_structures #' @keywords internal setClass("unitizerDummy", slots=c(.="NULL")) #' @rdname unitizer_s4method_doc setMethod( "show", "unitizerDummy", function(object) cat("\n") ) setClassUnion("listOrNULLOrDummy", c("list", "NULL", "unitizerDummy")) setClassUnion("characterOrNULLOrDummy", c("character", "NULL", "unitizerDummy")) setClassUnion("integerOrNULLOrDummy", c("integer", "NULL", "unitizerDummy")) #' @rdname global_structures #' @keywords internal setClass("unitizerGlobalTrackingStore", contains="unitizerGlobalTracking") #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalState", contains="unitizerGlobalBase", slots=c( search.path="characterOrNULLOrDummy", options="listOrNULLOrDummy", working.directory="characterOrNULLOrDummy", random.seed="integerOrNULLOrDummy", namespaces="characterOrNULLOrDummy" ) ) #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalIndices", slots=c( search.path="integer", options="integer", working.directory="integer", random.seed="integer", namespaces="integer" ), prototype=list( search.path=0L, options=0L, working.directory=0L, random.seed=0L, namespaces=0L ), validity=function(object){ for(i in slotNames(object)) if(length(slot(object, i)) != 1L || slot(object, i) < 0L) return(paste0("slot `", i, "` must be integer(1L) and positive")) TRUE } ) #' @rdname unitizer_s4method_doc setMethod( "as.integer", "unitizerGlobalIndices", function(x, ...) { s.n <- slotNames(x) res <- setNames(unlist(lapply(s.n, slot, object=x)), s.n) if(!is.integer(res)) { # nocov start stop( "Internal Error: unable to convert `unitizerGlobalIndices` object to ", "integer; contact maintainer." ) # nocov end } res } ) # Create a `unitizerGlobalIndices` object that points to the last stored states; # used primarily so we can then add more states to the ends and can compute what # the indices for the added states should be; used by `mergeStates` setGeneric( "unitizerStateMaxIndices", function(x, ...) standardGeneric("unitizerStateMaxIndices") ) setMethod("unitizerStateMaxIndices", c("unitizerGlobalTrackingStore"), function(x, ...) { last.ids <- Map(function(y) length(slot(x, y)), slotNames(x)) do.call("new", c(list("unitizerGlobalIndices"), last.ids)) } ) # Pull out a single state from a tracking object setGeneric( "unitizerGlobalStateExtract", function(x, y, ...) standardGeneric("unitizerGlobalStateExtract") ) setMethod( "unitizerGlobalStateExtract", c("unitizerGlobalTrackingStore", "unitizerGlobalIndices"), function(x, y, ...) { vals <- Map( function(x, y) unlist(x[y], recursive=FALSE), sapply(.unitizer.global.settings.names, slot, object=x, simplify=FALSE), lapply(.unitizer.global.settings.names, slot, object=y) ) do.call("new", c("unitizerGlobalState", vals)) } ) # Reduce size of a tracking object for storage purposes setGeneric( "unitizerCompressTracking", function(x, ...) standardGeneric("unitizerCompressTracking") ) setMethod( "unitizerCompressTracking", "unitizerGlobalTracking", function(x, opts.ignore, ...) { stopifnot(is.character(opts.ignore)) res <- new("unitizerGlobalTrackingStore") res@search.path <- lapply(x@search.path, compress_search_data) res@namespaces <- lapply(x@namespaces, compress_ns_data) # Don't store stuff with environments or stuff that is too big # (size cut-off should be an option?), or stuff that is part of the base or # as.is options res@options <- Map( x@options, f=function(i) { Map( setdiff(names(i), opts.ignore), f=function(j) if( !is.null(environment(i[[j]])) || is.environment(i[[j]]) || object.size(i[[j]]) > 1000 ) new("unitizerDummy") else i[[j]] ) } ) res@working.directory <- x@working.directory # not sure whether this is something that we want to be comparing res@random.seed <- lapply( # this could be big!!! x@random.seed, function(y) if(length(y) > 10L) new("unitizerDummy") else y ) res } ) # Get Current Search Path And Namespace Data # # These have to be in this file, and not in R/search.R for the setClass for the # state funs object. Note there are some weird dependency circularities, # and we're relying on this function not being called until once the full # package is loaded. # # Also, while we track namespaces separately, we need to store them here as well # as they contain the the package version info we ultimately want to retain; # this could possibly be improved by just attaching package version, but too # much work to retrofit existing behavior that blended namespaces and # search path search_as_envs <- function() { sp <- search() res <- setNames(lapply(seq_along(sp), as.environment), sp) list(search.path=res, ns.dat=get_namespace_data()) } # Accessing namespace info in not really documented manner, but muuuch faster # than using getNamespaceInfo get_namespace_data <- function() { sapply( loadedNamespaces(), function(x) { ns <- getNamespace(x) loc <- ns[[".__NAMESPACE__."]][["path"]] ver <- ns[[".__NAMESPACE__."]][["spec"]]["version"] if(is.null(ver)) ver <- "" if(is.null(loc)) loc <- "" list(names=x, lib.loc=loc, version=ver) }, simplify=FALSE ) } #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalStateFuns", contains="unitizerGlobalBase", slots=c( search.path="function", options="function", working.directory="function", random.seed="function", namespaces="function" ), prototype=list( search.path=search_as_envs, options=options, working.directory=getwd, random.seed=function() mget( ".Random.seed", envir=.GlobalEnv, inherits=FALSE, ifnotfound=list(NULL) )[[1L]], namespaces=get_namespace_data ) ) #' @rdname global_structures #' @keywords internal setClass( "unitizerGlobalNsOptConflict", slots=c(conflict="logical", namespaces="character", file="character"), prototype=list(conflict=FALSE), validity=function(object) { if(!is.TF(conflict)) return("Slot `conflict` must be TRUE or FALSE") if(!is.chr1(file)) return("Slot `file` must be character(1L) and not NA") if(any(is.na(namespaces))) return("Slot `namespaces` may not contain NAs") TRUE } ) # Objects / Methods used to Track Global Settings and the Like # # Implemented as Reference Class unitizerGlobal <- setRefClass( "unitizerGlobal", fields=list( par.env="environment", status="unitizerGlobalStatus", disabled="unitizerGlobalDisabled", tracking="unitizerGlobalTracking", # Implement global object as locked so that it doesn't get overwritten locked="logical", set.global="logical", # Allow us to remember if an error happened on state reset ns.opt.conflict="unitizerGlobalNsOptConflict", cons="unitizerCaptConsOrNULL", # Connections for stdout and stderr capture # store original unitizer options before they get zeroed out unitizer.opts="list", state.funs="unitizerGlobalStateFuns", shim.funs="list", indices.init="unitizerGlobalIndices", indices.last="unitizerGlobalIndices", transcript="logical" ), methods=list( initialize=function( ..., disabled=FALSE, enable.which=integer(0L), par.env=new.env(parent=baseenv()), unitizer.opts=options()[grep("^unitizer\\.", names(options()))], set.global=FALSE, transcript=FALSE ) { obj <- callSuper( ..., par.env=par.env, unitizer.opts=unitizer.opts, locked=FALSE, transcript=transcript ) enable(enable.which) state() ns.opt.conflict@conflict <<- FALSE # top level copy for access from other namespaces if(isTRUE(.global$global$locked)) { # nocov start stop( "Internal Error: global tracking object already exists; this should ", "never happen; contact maintainer" ) # nocov end } else if(set.global) { # no longer 100% sure, but I believe the .global is used solely so that # we can have access to the special unitizer parent environment from the # traced functions (i.e. so we can change the parent when the search # path changes) .global$global <- .self locked <<- TRUE } else if(.loaded) { warning( "Instantiated global object without global namespace registry; ", "you should only see this warning you are using ", "`repair_environments`.", immediate.=TRUE ) } obj }, enable=function( which=setNames( rep(2L, length(.unitizer.global.settings.names)), .unitizer.global.settings.names ) ) { ' Turn on global environment tracking, shouldnt be needed since usually called during initialization ' if(!length(which)) return(status) stopifnot( is.integer(which), !any(is.na(which)), !is.null(names(which)) && !any(is.na(names(which))), all(names(which) %in% .unitizer.global.settings.names), length(which) == length(unique(names(which))) ) for(i in names(which)) { if(slot(disabled, i)) { warning( "State setting for `", i, "` has already been disabled and ", "cannot be re-enabled", immediate.=TRUE ) next } slot(status, i) <<- which[[i]] } status }, disable=function(which=.unitizer.global.settings.names) { ' Turn off global settings; for `par.env` also unshims the functions used to enable tracking of topmost environment. Currently not truly needed but left in for future use since the enable/ disable paradigm is not as important now that `par.env` is being handled separately ' stopifnot( is.character(which), all(!is.na(which)), all(which %in% .unitizer.global.settings.names) ) for(i in which) { slot(status, i) <<- 0L slot(disabled, i) <<- TRUE } status }, state=function(mode="normal") { ' Record state for each of the globals we are tracking; one question here is whether we want more sophisticated checking against existing settings to avoid repeatedly storing the same thing. For now we just check against the last one ' stopifnot(is.chr1(mode), mode %in% c("normal", "init")) for(i in slotNames(tracking)) { # Don't record statuses that aren't being tracked if(!slot(status, i)) next # Get state with pre-defined function new.obj <- slot(state.funs, i)() ref.obj <- if(slot(indices.last, i)) { slot(tracking, i)[[slot(indices.last, i)]] } else { new.env() # guaranteed unique } if(!identical(new.obj, ref.obj)) { slot(tracking, i) <<- append(slot(tracking, i), list(new.obj)) slot(indices.last, i) <<- length(slot(tracking, i)) } if(identical(mode, "init")) { slot(indices.init, i) <<- length(slot(tracking, i)) slot(indices.last, i) <<- length(slot(tracking, i)) } } indices.last }, reset=function(to) { ' Reset global settings to a prior State ' stopifnot(is(to, "unitizerGlobalIndices")) success <- TRUE if(status@search.path && to@search.path){ fail <- inherits(try(search_path_update(to@search.path, .self)), "try-error") success <- success && !fail } if(status@namespaces && to@namespaces) { fail <- inherits(try(namespace_update(to@namespaces, .self)), "try-error") success <- success && !fail } if(status@options && to@options) { fail <- inherits( try(options_update(tracking@options[[to@options]])), "try-error" ) success <- success && !fail } if(status@working.directory && to@working.directory) { fail <- inherits( try(setwd(tracking@working.directory[[to@working.directory]])), "try-error" ) success <- success && !fail } if(status@random.seed && to@random.seed) { if(is.null(tracking@random.seed[[to@random.seed]])) { if(exists(".Random.seed", .GlobalEnv, inherits=FALSE)) rm(".Random.seed", envir=.GlobalEnv) } else { assign( ".Random.seed", tracking@random.seed[[to@random.seed]], .GlobalEnv ) } } if(!success) stop("Global state reset failed, see prior error.") indices.last <<- to indices.last }, resetInit=function() { ' Reset global settings to what they were right after initialization scripts ' reset(indices.init) }, resetFull=function() { ' Reset global settings to what they were on first load; par.env doesnt matter since only meaningful in context of unitizer ' reset( new( "unitizerGlobalIndices", search.path=1L, options=1L, working.directory=1L, random.seed=1L, namespaces=1L ) ) }, release=function() { ' Blow away the global tracking object so that we can re-use for other sessions ' locked <<- FALSE } ) ) # used purely for traced functions that need access to global object; in most # cases should be just our traced functions, note that we just create this # object here for test; any time a `unitizer` is instantiated. UPDATE: seems # this is just used to get access to the special `unitizer` parent env, and to # implement the non-interactive prompt responses for testing. .global <- new.env() # not necessary since any use of `shimFuns` can only occur if a unitizerGlobal # object is instantiated, so $global will have been created by initialize method # .global$global <- unitizerGlobal$new() setClassUnion("unitizerGlobalOrNULL", c("unitizerGlobal", "NULL")) unitizer/R/repairenvs.R0000644000176200001440000000614014766101401014626 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include unitizer.R NULL #' Repair Environment Chains #' #' In theory should never be needed, but use in case you get errors about #' corrupted environments. You should only use this if you get an error #' telling you to use it. #' #' If you pass a store id this will re-save the repaired \code{unitizer} to #' the location specified by the store id. #' #' @seealso \code{\link{unitize}} #' @inheritParams unitize #' @export #' @param x either a unitizer, or a store id (see \code{\link{unitize}}) #' @return a \code{unitizer} object repair_environments <- function(x, interactive.mode=interactive()) { save <- FALSE if(!is(x, "unitizer")) { unitizer <- try( load_unitizers( list(x), test.files=NA_character_, par.frame=baseenv(), interactive.mode=interactive.mode, mode="unitize", show.progress=0L, transcript=!interactive.mode )[[1L]] ) if(inherits(unitizer, "try-error")) stop("Unable to load `unitizer`; see prior errors.") save <- TRUE } else { unitizer <- x } unitizer <- repairEnvs(unitizer) if(save) { if(inherits(try(store_unitizer(unitizer)), "try-error")) warning( "Unable to store repaired unitizer, though we are still returning the ", "repaired unitizer." ) } unitizer } setGeneric("repairEnvs", function(x, ...) standardGeneric("repairEnvs")) setMethod("repairEnvs", "unitizer", function(x, ...) { parent.env(x@zero.env) <- baseenv() parent.env(x@base.env) <- x@zero.env parent.env(x@items.ref@base.env) <- x@base.env x@items.ref <- repairEnvs(x@items.ref) x } ) setMethod("repairEnvs", "unitizerItems", function(x, ...) { warning( "Detected corrupted environment history; we will attempt to repair, ", "but keep in mind that even when repaired the test environments may ", "be missleading. For example, the objects other than `.new` or `.ref` ", "when reviewing tests at the `unitzer` prompt may not be those you ", "expect or those reported by `ls`. To fully restore environments ", "re-unitize with `unitize(..., force.update=TRUE)`. If errors persist ", "after an attempt to repair, please contact maintainer.", immediate. = TRUE ) if(!length(x)) x prev.par <- x@base.env for(i in 1:length(x)) { if(!identical(x[[i]]@env, prev.par)) parent.env(x[[i]]@env) <- prev.par # can happen with ignored tests prev.par <- x[[i]]@env } invalidateLs(x) } ) unitizer/R/load.R0000644000176200001440000003212214766340624013402 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. ## Store Retrieve Unitizer ## ## If this errors, calling function should abort ## ## @keywords internal ## @param unitizer a \code{\link{unitizer-class}} object ## @param store.id anything for which there is a defined \code{\link{get_unitizer}} ## method; by default should be the path to a unitizer; if ## \code{`\link{get_unitizer}`} returns \code{`FALSE`} then this will create ## a new unitizer ## @param par.frame the environment to use as the parent frame for the \code{unitizer} ## @param test.file the R file associated with the store id ## @param force.upgrade whether to allow upgrades in non-interactive mode, for ## testing purposes ## @param global the global tracking object ## @return a \code{unitizer} object, or anything, in which case the calling ## code should exit load_unitizers <- function( store.ids, test.files, par.frame, interactive.mode, mode, force.upgrade=FALSE, global=unitizerGlobal$new(), show.progress, transcript ) { if(!is.character(test.files)) stop("Argument `test.files` must be character") if(!is.environment(par.frame)) stop("Argument `par.frame` must be an environment") if(!is.list(store.ids) || !identical(length(store.ids), length(test.files))) stop( "Argument `store.ids` must be a list of the same length as `test.files`" ) if(any(vapply(store.ids, is.null, TRUE))) stop("Argument `store.ids` may not contain NULL values.") if(!isTRUE(show.progress %in% c(0L, seq_len(PROGRESS.MAX)))) stop("Argument `show.progress` must be in 0:", PROGRESS.MAX) if(!is.TF(transcript)) stop("Argument `transcript` must be TRUE or FALSE") stopifnot(isTRUE(interactive.mode) || identical(interactive.mode, FALSE)) stopifnot(is.chr1plain(mode), !is.na(mode), mode %in% c("unitize", "review")) # Get names for display chr.ids <- vapply( seq(store.ids), function(x) best_store_name(store.ids[[x]], test.files[[x]]), character(1L) ) chr.files <- vapply( seq(store.ids), function(x) best_file_name(store.ids[[x]], test.files[[x]]), character(1L) ) # Get RDSs and run basic checks; `valid` will contain character strings # describing failures, or 0 length string if succeeded unitizers <- lapply( seq(store.ids), function(x) { if(is(store.ids[[x]], "unitizer")) { return(store.ids[[x]]) } store.ids[[x]] <- try(get_unitizer(store.ids[[x]]), silent=TRUE) if(inherits(store.ids[[x]], "try-error")) return( paste0( c( "`get_unitizer` error: ", conditionMessage(attr(store.ids[[x]], "condition")) ), collapse="" ) ) if(is(store.ids[[x]], "unitizer")) return(store.ids[[x]]) if(identical(store.ids[[x]], FALSE)) { return( new( "unitizer", id=norm_store_id(store.ids[[x]]), zero.env=new.env(parent=par.frame), test.file.loc=norm_file(test.files[[x]]) ) ) } return( "`get_unitizer` returned something other than a `unitizer` or FALSE" ) } ) null.version <- package_version("0.0.0") curr.version <- packageVersion("unitizer") valid <- vapply( unitizers, unitizer_valid, character(1L), curr.version=curr.version ) # unitizers without a `version` slot or slot in incorrect form not eligible # for upgrade versions <- lapply( unitizers, function(x) if( !is(x, "unitizer") || inherits( x.ver <- try(package_version(x@version), silent=TRUE), "try-error" ) || !is.package_version(x.ver) ) null.version else x.ver ) version.out.of.date <- vapply( versions, function(x) !identical(x, null.version) && curr.version > x, logical(1L) ) valid.idx <- which(!nchar(valid)) invalid.idx <- which(nchar(valid) & !version.out.of.date) toup.idx <- which(version.out.of.date & nchar(valid)) toup.fail.idx <- integer(0L) # Attempt to resolve failures by upgrading if relevant if(length(toup.idx)) { upgraded <- lapply(unitizers[toup.idx], upgrade) upgrade.success <- vapply(upgraded, is, logical(1L), "unitizer") for(i in which(upgrade.success)) { # Actually same unitizer may be run against multiple test files # so this check is useless if( !identical( basename(upgraded[[i]]@test.file.loc), basename(test.files[toup.idx][[i]]) ) ) warning( "Upgraded test file does not match original test file ", "('", basename(upgraded[[i]]@test.file.loc), "' vs '", basename(test.files[toup.idx][[i]]), "').", immediate.=TRUE ) } unitizers[toup.idx[upgrade.success]] <- upgraded[upgrade.success] valid.idx <- c(valid.idx, toup.idx[upgrade.success]) toup.fail.idx <- toup.idx[!upgrade.success] valid[toup.fail.idx] <- upgraded[!upgrade.success] } # Cleanup the unitizers for(i in valid.idx) { unitizers[[i]]@id <- norm_store_id(store.ids[[i]]) unitizers[[i]]@test.file.loc <- norm_file(test.files[[i]]) unitizers[[i]]@best.name <- chr.ids[i] unitizers[[i]]@show.progress <- show.progress unitizers[[i]]@transcript <- transcript parent.env(unitizers[[i]]@zero.env) <- par.frame unitizers[[i]]@global <- global # awkward, shouldn't be done this way unitizers[[i]]@eval <- identical(mode, "unitize") } # Issue errors as required if(length(invalid.idx)) { meta_word_msg( paste0( "\nThe following unitizer", if(length(invalid.idx) > 1L) "s", " could not be loaded:" ), as.character( UL(paste0(chr.ids[invalid.idx], ": ", valid[invalid.idx])), width=getOption("width") - 2L ) ) } if(length(toup.fail.idx)) { meta_word_msg( paste0( "\nThe following unitizer", if(length(toup.fail.idx) > 1L) "s", " could not be upgraded to version '", as.character(curr.version), "':\n" ), as.character( UL( paste0( chr.files[toup.fail.idx], " at '", vapply(versions[toup.fail.idx], as.character, character(1L)), "': ", valid[toup.fail.idx] ) ), width=getOption("width") - 2L ) ) } # Cannot proceed with invalid unitizers if(length(invalid.idx)) { stop( "Cannot proceed with invalid or out of date unitizers. You must either ", "fix or remove them." ) } new("unitizerObjectList", .items=unitizers) } # Need to make sure we do not unintentionally store a bunch of references to # objects or namespaces we do not want: # # \itemize{ # \item reset parent env to be base # \item remove all contents of base.env (otherwise we get functions with # environments that reference namespaces) # } store_unitizer <- function(unitizer) { if(!is(unitizer, "unitizer")) return(invisible(TRUE)) old.par.env <- parent.env(unitizer@zero.env) on.exit(parent.env(unitizer@zero.env) <- old.par.env) parent.env(unitizer@zero.env) <- baseenv() global.par.env <- unitizer@global$par.env old.global.par.env.par <- parent.env(global.par.env) on.exit(parent.env(global.par.env) <- old.global.par.env.par, add=TRUE) parent.env(global.par.env) <- baseenv() # zero out connections we'v been using if(!is.null(unitizer@global$cons)) close_and_clear(unitizer@global$cons) # to avoid taking up a bunch of storage on large object unitizer@global <- NULL rm(list=ls(unitizer@base.env, all.names=TRUE), envir=unitizer@base.env) # Reset other fields that are only meaningful during a unitizer run. unitizer@res.data <- NULL unitizer@updated.at.least.once <- FALSE unitizer@bookmark <- NULL unitizer@best.name <- "" unitizer@show.progress <- 0L # blow away calls; these should be memorialized as deparsed versions and the # original ones take up a lot of room to store for(i in seq_along(unitizer@items.ref)) unitizer@items.ref[[i]]@call <- NULL # shouldn't really be anything here for(i in seq_along(unitizer@items.new)) unitizer@items.new[[i]]@call <- NULL success <- try(set_unitizer(unitizer@id, unitizer)) if(!inherits(success, "try-error")) { meta_word_msg("unitizer updated.") } else { stop("Error attempting to save unitizer, see previous messages.") } return(invisible(TRUE)) } unitizer_valid <- function(x, curr.version=packageVersion("unitizer")) { if(!is(x, "unitizer")) { if(!is.chr1plain(x) || nchar(x) < 1L) return("unknown unitizer load failure") return(x) } null.version <- package_version("0.0.0") version <- try(x@version, silent=TRUE) if(inherits(version, "try-error")) { msg <- conditionMessage(attr(version, "condition")) paste0( "could not retrieve version from `unitizer`: ", if(nchar(msg)) sprintf(": %s", msg) ) } else { # Make sure not using any `unitizer`s with version older than what we're at attempt <- try(validObject(x, complete=TRUE), silent=TRUE) if(inherits(attempt, "try-error")) { err.extra <- if( !identical(version, null.version) && curr.version < version ) { paste0( " (NB: unitizer generated by v", version, ", *later* than current v", curr.version, ")" ) } else "" msg <- conditionMessage(attr(attempt, "condition")) paste0( "unitizer object is invalid", err.extra, if(nchar(msg)) sprintf(": %s", msg) ) } else "" } } setClass( "unitizerLoadFail", slots=c( test.file="character", store.id="list", reason="character" ), validity=function(object) { if(!is.character(object@test.file) || length(object@test.file) != 1L) return("Slot `test.file` must be character(1L)") if(!is.chr1(object@reason)) return("Slot `reason` must be character(1L)") TRUE } ) #' @rdname unitizer_s4method_doc setMethod( "show", "unitizerLoadFail", function(object) { meta_word_cat(sep="\n", "Failed Loading Unitizer:", as.character( UL( c( paste0( "Test file: ", best_file_name(object@store.id, object@test.file) ), paste0( "Store: ", best_store_name(object@store.id[[1L]], object@test.file) ), paste0("Reason: ", object@reason) ) ), width=getOption("width") - 2L ) ) invisible(NULL) } ) # Manipulate \code{unitizer} Store and File Names # # Used to provide display friendly or absolute versions of \code{unitizer} # test file or store identifiers. # # @section \code{norm_store_id}, \code{norm_file}: # # Loosely related to \code{getTarget,unitizer-method} and # \code{getName,unitizer-method} although these are not trying to convert to # character or check anything, just trying to normalize if possible. # # @section \code{best_store_name}, \code{best_file_name}: # # Generate the most intuitive names possible for either the store or the test # file. # # @section \code{as.store_id_chr}: # # Converts as store ID to character # # @param store.id a \code{unitizer} store id # @param test.file the location of the R test file # @return character(1L), except for \code{as.store_id_chr}, which returns FALSE # on failure norm_store_id <- function(x) if(is.default_unitizer_id(x)) norm_file(x) else x norm_file <- function(x) { if( !inherits( # maybe this should just throw an error normed <- try(normalize_path(x, mustWork=TRUE), silent=TRUE), "try-error" ) ) normed else x } as.store_id_chr <- function(x) { if(is.chr1plain(x)){ return(relativize_path(x)) } target <- try(as.character(x), silent=TRUE) if(inherits(target, "try-error")) stop( "Unable to convert store id to character; if you are using custom ", "store IDs be sure to define an `as.character` method for them" ) target } # for testing only; needs to be in namespace #' Can't have undocumented methods anymore. #' @noRd as.character.untz_stochrerr <- function(x, ...) stop("I am an error") best_store_name <- function(store.id, test.file) { stopifnot(is.chr1plain(test.file)) chr.store <- try(as.store_id_chr(store.id), silent=TRUE) if(!is.chr1plain(chr.store)) { if(is.na(test.file)) return("") return( paste0("unitizer for test file '", relativize_path(test.file), "'") ) } chr.store } best_file_name <- function(store.id, test.file) { stopifnot(is.chr1plain(test.file)) if(!is.na(test.file)) return(relativize_path(test.file)) if(!is.chr1plain(chr.store <- as.store_id_chr(store.id))) { return("") } paste0("Test file for unitizer '", chr.store, "'") } unitizer/R/state.R0000644000176200001440000007700114766101401013574 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' @include global.R NULL .unitizer.valid.state.abbr <- c("pristine", "recommended", "suggested", "basic", "off", "safe") #' Tests and Session State #' #' While R generally adheres to a "functional" programming style, there are #' several aspects of session state that can affect the results of code #' evaluation (e.g. global environment, search path). \code{unitizer} provides #' functionality to increase test reproducibility by controlling session state #' so that it is the same every time a test is run. This functionality is #' turned off by default to comply with CRAN requirements, and also because #' there are inherent limitations in R that may prevent it from fully working in #' some circumstances. You can permanently enable the suggested state tracking #' level by adding \code{options(unitizer.state='suggested')} in your #' \code{.Rprofile}, although if you intend to do this be sure to read the #' \dQuote{CRAN non-compliance} section. #' #' @section CRAN Non-Compliance and Other Caveats: #' #' In the default state management mode, this package fully complies with CRAN #' policies. In order to implement advanced state management features we must #' lightly trace some \code{base} functions to alert \code{unitizer} each time #' the search path is changed by a test expression. The traced function #' behavior is completely unchanged other than for the side effect of notifying #' \code{unitizer} each time they are called. Additionally, the functions are #' only traced during \code{unitize} evaluation and are untraced on exit. #' Unfortunately this tracing is against CRAN policies, which is why it is #' disabled by default. #' #' Arguably other aspects of state management employed outside of #' \code{state="default"} _could_ be considered CRAN non-compliant, but none of #' these are deployed unless you explicitly chose to do so. Additionally, #' \code{unitizer} limits state manipulation to the evaluation of its processes #' and restores state on exit. Some exceptional failures may prevent restoring #' state fully. #' #' If state management were to fail fail in an unhandled form, the simplest #' work-around is to turn off state management altogether with #' \code{state="default"}. If it is a particular aspect of state management #' (e.g. search paths with packages attached with \code{devtools::load_all}), #' you can disable just that aspect of state (see "Custom Control" section). #' #' For more details see the reproducible tests vignette with: #' \code{vignette(package='unitizer', 'u4_reproducible-tests')} #' #' @section Overview: #' #' You can control how \code{unitizer} manages state via #' the state argument to \code{unitize} or by setting the #' \dQuote{unitizer.state} option. This help file discusses state #' management with \code{unitizer}, and also documents two functions that, in #' conjunction with \code{\link{unitize}} or \code{\link{unitize_dir}} allow you #' to control state management. #' #' \bold{Note}: most of what is written in this page about \code{unitize} #' applies equally to \code{unitize_dir}. #' #' \code{unitizer} provides functionality to insulate test code from variability #' in the following. Note the \dQuote{can be} wording because by default #' these elements of state are not managed: #' #' \itemize{ #' \item Workspace / Parent Environment: all tests can be #' evaluated in environments that are children of a special environment #' that does not inherit from \code{.GlobalEnv}. This prevents objects #' that are lying around in your workspace from interfering with your #' tests. #' \item Random Seed: can be set to a specific value at the #' beginning of each test file so that tests using random values get the #' same value at every test iteration. This only sets the seed at the #' beginning of each test file, so changes in order or number of functions #' that generate random numbers in your test file will affect subsequent #' tests. The advantage of doing this over just setting the seed directly #' in the test files is that \code{unitizer} tracks the value of the seed #' and will tell you the seed changed for any given test (e.g. because you #' added a test in the middle of the file that uses the random seed). #' \item Working Directory: can be set to the tests directory #' inside the package directory if the test files appear to be inside the #' folder structure of a package, and the test file does not appear to be #' run as part of a check run (e.g. R CMD check, #' `tools::testInstalledPakage`). If test files are not inside a package #' directory structure then can be set to the test files' directory. #' \item Search Path: can be set to what you would #' typically find in a freshly loaded vanilla R session. This means any non #' default packages that are loaded when you run your tests are unloaded #' prior to running your tests. If you want to use the same libraries #' across multiple tests you can load them with the \code{pre} argument to #' \code{\link{unitize}} or \code{\link{unitize_dir}}. Due to limitations #' of R this is only an approximation to actually restarting R into a fresh #' session. #' \item Options: same as search path, but see "Namespaces" next. #' \item Namespaces: same as search path; this #' option is only made available to support options since many namespaces #' set options \code{onLoad}, and as such it is necessary to unload and #' re-load them to ensure default options are set. See the "Namespaces and #' Options" section. #' } #' #' In the \dQuote{suggested} state tracking mode (previously known as #' \dQuote{recommended}), parent environment, random seed, working directory, #' and search path are all managed to level 2, which approximates what you would #' find in a fresh session (see "Custom Control" section below). For example, #' with the search path managed, each test file will start evaluation with the #' search path set to the tests folder of your package. All these settings are #' returned to their original values when \code{unitizer} exits. #' #' To manage the search path \code{unitizer} detaches #' and re-attaches packages. This is not always the same as loading a package #' into a fresh R session as detaching a package does not necessarily undo every #' action that a package takes when it is loaded. See \code{\link{detach}} for #' potential pitfalls of enabling this setting. Additionally, packages attached #' in non-standard ways (e.g. \code{devtools::load_all}) may not re-attach #' properly. #' #' You can modify what aspects of state are managed by using the \code{state} #' parameter to \code{\link{unitize}}. If you are satisfied with basic default #' settings you can just use the presets described in the next section. If you #' want more control you can use the return values of the \code{state} and #' \code{in_pkg} functions as the values for the \code{state} parameter for #' \code{unitize}. #' #' State is reset after running each test file when running multiple test #' files with \code{unitize_dir}, which means state changes in one test file #' will not affect the next one. #' #' @section State Presets: #' #' For convenience \code{unitizer} provides several state management presets #' that you can specify via the \code{state} parameter to \code{\link{unitize}}. #' The simplest method is to specify the preset name as a character value: #' #' \itemize{ #' \item "suggested": \itemize{ #' \item Use special (non \code{.GlobalEnv}) parent environemnt #' \item Manage search path #' \item Manage random seed (and set it to be of type "Wichmann-Hill" #' for space considerations). #' \item Manage workign directory #' \item Leave namespace and options untouched #' } #' \item "safe" like suggested, but turns off tracking for search path in #' addition to namespaces and options. These settings, particularly the #' last two, are the most likely to cause compatibility problems. #' \item "pristine" implements the highest level of state tracking and control #' \item "basic" keeps all tracking, but at a less aggressive level; state is #' reset between each test file to the state before you started #' \code{unitize}ing so that no single test file affects another, but the #' state of your workspace, search path, etc. when you launch #' \code{unitizer} will affect all the tests (see the Custom Control) #' section. #' \item "off" (default) state tracking is turned off #' } #' #' @section Custom Control: #' #' If you want to customize each aspect of state control you can pass a #' \code{unitizerState} object as the \code{state} argument. The simplest way #' to do this is by using the \code{\link{state}} constructor function. Look #' at the examples for how to do this. #' #' For convenience \code{unitize} allows you to directly specify a parent #' environment if all you want to change is the parent evaluation environment #' but are otherwise satisfied with the defaults. You can even use the #' \code{\link{in_pkg}} function to tell \code{unitizer} to use the namespace #' associated with your current project, assuming it is an R package. See #' examples for details. #' #' If you do chose to modify specific aspects of state control here is a guide #' to what the various parameter values for \code{state} do: #' \itemize{ #' \item For \code{par.env}: any of the following: #' \itemize{ #' \item \code{NULL} to use the special \code{unitizer} parent #' environment as the parent environment; this environment has for #' parent the parent of \code{.GlobalEnv}, so any tests evaluated #' therein will not be affected by objects in \code{.GlobalEnv} #' see (\code{vignette("unitizer_reproducible_state")}). #' \item an environment to use as the parent evaluation environment #' \item the name of a package to use that package's namespace #' environment as the parent environment #' \item the return value of \code{in_pkg}; used primarily to autodetect #' what package namespace to use based on package directory structure #' } #' \item For all other slots, the settings are in \code{0:2} and mean: #' \itemize{ #' \item 0 turn off state tracking #' \item 1 track, but start with state as it was when \code{unitize} was #' called. #' \item 2 track and set state to what you would typically find in a clean #' R session, with the exception of \code{random.seed}, which is #' set to \code{getOption("unitizer.seed")} (of kind "Wichmann-Hill" #' as that seed is substantially smaller than the R default seed). #' } } #' #' If you chose to use level \code{1} for the random seed you should consider #' picking a random seed type before you start unitizer that is small like #' "Wichman-Hill" as the seed will be recorded each time it changes. #' #' @section Permanently Setting State Tracking: #' #' You can permanently change the default state by setting the #' \dQuote{unitizer.state} option to the name of the state presets above or to a #' or to a state settings option object generated with \code{state} as described #' in the previous section. #' #' @section Avoiding \code{.GlobalEnv}: #' #' For the most part avoiding \code{.GlobalEnv} leads to more robust and #' reproducible tests since the tests are not influenced by objects in the #' workspace that may well be changing from test to test. There are some #' potential issues when dealing with functions that expect \code{.GlobalEnv} to #' be on the search path. For example, \code{setClass} uses \code{topenv} to #' find a default environment to assign S4 classes to. Typically this will be #' the package environment, or \code{.GlobalEnv}. However, when you are in #' \code{unitizer} this becomes the next environment on the search path, which #' is typically locked, which will cause \code{setClass} to fail. For those #' types of functions you should specify them with an environment directly, e.g. #' \code{setClass("test", slots=c(a="integer"), where=environment())}. #' #' @section Namespaces and Options: #' #' Options and namespace state management require the ability to fully unload #' any non-default packages and namespaces, and there are some packages that #' cannot be unloaded, or should not be unloaded (e.g. #' \href{https://github.com/Rdatatable/data.table/issues/990}{data.table}). I #' some systems it may even be impossible to fully unload any compiled code #' packages (see \code{\link{detach}}. If you know the packages you typically #' load in your sessions can be unloaded, you can turn this functionality on by #' setting \code{options(unitizer.state="pristine")} either in your session, in #' your \code{.Rprofile} file, or using \code{state="prisitine"} in each call to #' \code{unitize} or \code{unitize_dir}. If you have packages that cannot be #' unloaded, but you still want to enable these features, see the "Search Path #' and Namespace State Options" section of \code{\link{unitizer.opts}} docs. #' #' If you run \code{unitizer} with options and namespace tracking and you run #' into a namespace that cannot be unloaded, or should not be unloaded because #' it is listed in \code{getOption("unitizer.namespace.keep")}, \code{unitizer} #' will turn off \code{options} state tracking from that point onwards. #' #' Additionally, note that \code{warn} and \code{error} options are always set #' to \code{1} and \code{NULL} respectively during test evaluation, irrespective #' of what option state tracking level you select. #' #' @section Known Untracked State Elements: #' #' \itemize{ #' \item system time: tests involving functions such as \code{\link{date}} #' will inevitably fail #' \item locale: is not tracked because it so specific to the system and so #' unlikely be be changed by user action; if you have tests that depend on #' locale be sure to set the locale via the \code{pre} argument to #' \code{\link{unitize}}, and also to reset it to the original value in #' \code{post}. #' } #' @param search.path one of \code{0:2}, uses the default value corresponding to #' \code{getOption(unitizer.state)}, which is 0 in the default unitizer state #' of \dQuote{off}. See "Custom Control" section for details. #' @param options same as \code{search.path} #' @param working.directory same as \code{search.path} #' @param random.seed same as \code{search.path} #' @param namespaces same as \code{search.path} #' @param par.env \code{NULL} to use the special \code{unitizer} parent #' environment, or an environment to use as the parent environment, or #' the name of a package as a character string to use that packages' #' namespace as the parent environment, or a \code{unitizerInPkg} object #' as produced by \code{\link{in_pkg}}, assumes .GlobalEnv if unspecified #' @param package character(1L) or NULL; if NULL will tell \code{unitize} #' to attempt to identify if the test file is inside an R package folder #' structure and if so run tests in that package's namespace. This should #' work with R CMD check tests as well as in normal usage. If character will #' take the value to be the name of the package to use the namespace of as #' the parent environment. Note that \code{in_pkg} does not retrieve the #' environment, it just tells \code{unitize} to do so. #' @return for \code{state} a \code{unitizerStateRaw} object, for \code{in_pkg} #' a \code{unitizerInPkg} object, both of which are suitable as values for #' the \code{state} parameter for \code{\link{unitize}} or as values for the #' \dQuote{unitizer.state} global option. #' #' @aliases state, in_pkg #' @rdname unitizerState #' @export state #' @name unitizerState #' @seealso \code{\link{unitize}}, \code{\link{unitizer.opts}} #' @examples #' \dontrun{ #' ## In this examples we use `...` to denote other arguments to `unitize` that #' ## you should specify. All examples here apply equally to `unitize_dir` #' #' ## Run with suggested state tracking settings #' unitize(..., state="suggested") #' ## Manage as much of state as possible #' unitize(..., state="pristine") #' #' ## No state management, but evaluate with custom env as parent env #' my.env <- new.env() #' unitize(..., state=my.env) #' ## use custom environment, and turn on search.path tracking #' ## here we must use the `state` function to construct a state object #' unitize(..., state=state(par.env=my.env, search.path=2)) #' #' ## Specify a namespace to run in by name #' unitize(..., state="stats") #' unitize(..., state=state(par.env="stats")) # equivalent to previous #' #' ## Let `unitizer` figure out the namespace from the test file location; #' ## assumes test file is inside package folder structure #' unitize("mytests.R", state=in_pkg()) # assuming mytests.R is part of a pkg #' unitize("mytests.R", state=in_pkg("mypkg")) # also works #' } state <- function( par.env, search.path, options, working.directory, random.seed, namespaces ) { if(!identical(c("par.env", .unitizer.global.settings.names), names(formals()))) stop( "Internal error: state element mismatch; this should not happen, ", "contact maintainer." ) supplied.args <- tail(names(match.call()), -1L) state.def <- try(as.state_raw(getOption('unitizer.state'))) if(inherits(state.def, "try-error")) stop( "Unable to generate state object from `getOption('unitizer.state')`, ", "see prior error messages." ) for(i in supplied.args) { i.val <- get(i, inherits=FALSE) if(i != 'par.env') { if(!is.int.1L(i.val) || !i.val %in% 0:2) stop("Argument `", i, "` must be integer(1L) in 0:2") i.val <- as.integer(i.val) } slot(state.def, i) <- i.val } if(!isTRUE(val.err <- validObject(state.def, test=TRUE))) { stop( "Unable to create valid `unitizerStateRaw` object: ", val.err ) } state.def } unitizerInPkg <- setClass( "unitizerInPkg", slots=c(package="character"), validity=function(object) { if(!is.chr1(object@package)) return("Slot `package` must be character(1L) and not NA") }, prototype=list(package="") ) #' @rdname unitizer_s4method_doc setMethod("as.character", "unitizerInPkg", function(x, ...) { sprintf( "", if(nchar(x@package)) sprintf("package:%s", x@package) else "auto-detect-pkg" ) } ) #' @rdname unitizer_s4method_doc setMethod( "show", "unitizerInPkg", function(object) word_cat(as.character(object), sep="\n") ) setClassUnion( "environmentOrNULLOrCharacterUnitizerInPkg", c("environment", "NULL", "character", "unitizerInPkg") ) # unitizerState is an abstract class and is not meant to be instantiated. It # defines basic structure for unitizerStateRaw and unitizerStateProcessed. # `as.state` will process a unitizerStateRaw class into a unitizerStateProcessed` # objects. Note that `unitizerState` does not have a `par.env` slot as that is # added by the child classes unitizerState <- setClass( "unitizerState", slots=c( search.path="integer", options="integer", working.directory="integer", random.seed="integer", namespaces="integer" ), prototype=list( search.path=0L, options=0L, working.directory=0L, random.seed=0L, namespaces=0L ), contains="VIRTUAL", validity=function(object) { # seemingly superflous used to make sure this object is in concordance with # the various others that are similar if( !identical( setdiff(slotNames(object), 'par.env'), .unitizer.global.settings.names ) ) { return( paste0( "Invalid state object, slots must be ", deparse(.unitizer.global.settings.names, width.cutoff=500L) ) ) } for(i in .unitizer.global.settings.names) { slot.val <- slot(object, i) if( !is.integer(slot.val) || !length(slot.val) == 1L || is.na(slot.val) || !slot.val %in% 0L:2L ) return(paste0("Slot `", i, "` must be integer(1L) and in 0:2")) } if( identical(object@options, 2L) && ( !identical(object@namespaces, 2L) || !identical(object@search.path, 2L) ) ) return( paste0( "Argument `state` is an invalid state: 'options' is set ", "to 2, but 'search.path' and 'namespaces' are not" ) ) if( identical(object@namespaces, 2L) && !identical(object@search.path, 2L) ) return( paste0( "Argument `state` is an invalid state: 'namespaces' is set ", "to 2, but 'search.path' is not" ) ) if(identical(object@random.seed, 2L)) { prev.seed <- mget( ".Random.seed", envir=.GlobalEnv, ifnotfound=list(NULL) )[[1L]] seed.dat <- getOption("unitizer.seed") msg <- "" if(inherits(try(do.call(set.seed, seed.dat)), "try-error")) { msg <- paste0( "Unable to set random seed; make sure `getOption('unitizer.seed')` ", "is a list of possible arguments to `set.seed`, or set `seed` slot ", "to be less than 2L." ) } if(is.null(prev.seed) && exists(".Random.seed", envir=.GlobalEnv)) rm(".Random.seed", envir=.GlobalEnv) else assign(".Random.seed", prev.seed, envir=.GlobalEnv) if(nchar(msg)) return(msg) } TRUE } ) # The main advantage of unitizerStateRaw is that it allow us to store some # parent environments in the form of "promises", specifically, if we use an # "unitizerInPkg" object without specifying a package, we can let unitizer try # to infer the package from the test directory under the presumption that the # test directory is contained inside a package directory). So we can set the # "promise" at a time independent of unitizer evaluation, and the environment # gets resolved at evaluation time. This is helpful if we want to store this as # an option, etc. unitizerStateRaw <- setClass( "unitizerStateRaw", slots=c(par.env="environmentOrNULLOrCharacterUnitizerInPkg"), contains="unitizerState", prototype=list(par.env=.GlobalEnv), validity=function(object){ if(is.character(object@par.env) && !is.chr1(object@par.env)) return("Slot `par.env` must be 1 long and not NA if it is character") TRUE } ) # Note that an instantiation of `unitizerStateProcessed` basically should be the # default state object unitizerStateProcessed <- setClass( "unitizerStateProcessed", slots=c(par.env="environmentOrNULL"), contains="unitizerState", prototype=list(par.env=.GlobalEnv) ) setMethod("initialize", "unitizerState", function(.Object, ...) { dots <- list(...) for(i in names(dots)) if(is.numeric(dots[[i]])) dots[[i]] <- as.integer(dots[[i]]) do.call(callNextMethod, c(.Object, dots)) } ) unitizerStateSuggested <- setClass( "unitizerStateSuggested", contains="unitizerStateRaw", prototype=list( search.path=2L, options=0L, working.directory=2L, random.seed=2L, namespaces=0L, par.env=NULL ) ) unitizerStatePristine <- setClass( "unitizerStatePristine", contains="unitizerStateRaw", prototype=list( search.path=2L, options=2L, working.directory=2L, random.seed=2L, namespaces=2L, par.env=NULL ) ) unitizerStateSafe <- setClass( "unitizerStateSafe", contains="unitizerStateRaw", prototype=list( search.path=0L, options=0L, working.directory=2L, random.seed=2L, namespaces=0L, par.env=NULL ) ) unitizerStateBasic <- setClass( "unitizerStateBasic", contains="unitizerStateRaw", prototype=list( search.path=1L, options=1L, working.directory=1L, random.seed=1L, par.env=NULL ) ) unitizerStateOff <- setClass( "unitizerStateOff", contains="unitizerStateRaw", prototype=list( search.path=0L, options=0L, working.directory=0L, random.seed=0L, namespaces=0L, par.env=.GlobalEnv ) ) #' @rdname unitizerState #' @export in_pkg <- function(package=NULL) { if(!is.null(package) && !is.chr1(package)) stop("Argument `package` must be character(1L) and not NA, or NULL") if(is.character(package) && !nchar(package)) stop("Argument `package` may not be an empty string") unitizerInPkg(package=if(is.null(package)) "" else package) } in_pkg_to_env <- function(inPkg, test.files) { stopifnot( is(inPkg, "unitizerInPkg"), is.character(test.files) || is.null(test.files) ) pkg <- if(nchar(inPkg@package)) { inPkg@package } else { if(is.null(test.files) || !length(pkg.tmp <- get_package_dir(test.files))){ stop( word_wrap(collapse="\n", cc( "Unable to detect package to use namespace of as parent ", "environment; see `?unitizerState` for how to specify ", "a package namespace explicitly as a parent environment." ) ) ) } pkg.name <- try(get_package_name(pkg.tmp)) if(inherits(pkg.name, "try-error")) stop("Unable to extract package name from DESCRIPTION.") pkg.name } pkg.env <- try(getNamespace(pkg)) if(inherits(pkg.env, "try-error")) stop( word_wrap(collapse="\n", cc( "Unable to load \"", pkg, "\" namespace to use as parent ", "environment; see `?unitizerState` for instructions on how to ", "specify a package namespace as a parent environment for tests." ) ) ) pkg.env } # This method is a bit odd because it has logic for dealing with slots that are # not actually defined in the class but are in the child classes that are # expected to kick of the method #' @rdname unitizer_s4method_doc setMethod( "show", "unitizerState", function(object) { sn <- slotNames(object) sv <- sapply(sn, slot, object=object, simplify=FALSE) sv.env <- sv$par.env sv.extra <- "" sv[["par.env"]] <- if(is.null(sv.env)) { sv.extra <- ": use special unitizer environment as 'par.env'" "" } else if (is(sv.env, "unitizerInPkg")) { sv.extra <- ": run with specified package namespace as parent" as.character(sv.env) } else if (is.environment(sv.env)) { env_name(sv.env) } else # nocov start stop("Internal Error: unexpected `par.env` slot type; contact maintainer") # nocov end res <- data.frame(Settings=sn, Values=unlist(sv)) rownames(res) <- NULL print(res) word_cat( "-----", "0: off", "1: track starting with initial state", "2: track starting with clean state", if(nchar(sv.extra)) sv.extra, "See `?unitizerState` for more details.", sep="\n" ) } ) setGeneric( "as.unitizerStateProcessed", function(x, ...) standardGeneric("as.unitizerStateProcessed") ) setMethod("as.unitizerStateProcessed", "unitizerStateRaw", function(x, ...) { x.proc <- new("unitizerStateProcessed") for(i in slotNames(x)) slot(x.proc, i) <- slot(x, i) x.proc } ) # Valid State Settings # # @keywords internal # @param x objet to test # @return a \code{unitizerState} object as.state <- function(x, test.files=NULL) { stopifnot(is.character(test.files) || is.null(test.files)) x.raw <- as.state_raw(x) x.fin <- if(is(x.raw, "unitizerStateRaw")) { par.env <- if(is.character(x.raw@par.env)) { try(getNamespace(x.raw@par.env)) } else if(is(x.raw@par.env, "unitizerInPkg")) { try(in_pkg_to_env(x.raw@par.env, test.files)) } else x.raw@par.env if(inherits(par.env, "try-error")) stop("Unable to convert `par.env` value to a namespace environment") x.raw@par.env <- par.env as.unitizerStateProcessed(x.raw) } else x.raw # Final sanity checks if(x.fin@options > x.fin@namespaces) { stop( word_wrap(collapse="\n", cc( "Options state tracking (", x.fin@options, ") must be less than ", "namespace state tracking (", x.fin@namespaces, ")." ) ) ) } if(x.fin@namespaces > x.fin@search.path) { stop( word_wrap(collapse="\n", cc( "Namespace state tracking (", x.fin@namespaces, ") must be less ", "than or equal to search path state tracking (", x.fin@search.path, ")." ) ) ) } # Last ditch check if(!isTRUE(test <- validObject(x.fin, test=TRUE))) stop( "Internal Error: failed processing raw state object, contact ", "maintainer. (", test, ")" ) return(x.fin) } char_or_null_as_state <- function(x) { if(is.null(x)) x <- "off" # default state if(!is.character(x) || !x %in% .unitizer.valid.state.abbr) stop( "Internal error, `x` must be char and match a known unitizer state ", "setting to convert to state, contact maintainer." ) # note these are all raw objects switch( x, recommended=,suggested=new("unitizerStateSuggested"), pristine=new("unitizerStatePristine"), basic=new("unitizerStateBasic"), off=new("unitizerStateOff"), safe=new("unitizerStateSafe") ) } setGeneric( "as.unitizerStateRaw", function(x, ...) standardGeneric("as.unitizerStateRaw") ) # Raw states can contain pretty much everything processed ones can setMethod("as.unitizerStateRaw", "unitizerState", function(x, ...) { state <- new("unitizerStateRaw") for(i in slotNames(state)) slot(state, i) <- slot(x, i) validObject(state) state } ) ## Generate a state raw object ## ## "unitizerStateProcessed" objects are returned as is. The `x` argument is one ## of the things that can be converted to a state object. This function is a ## little misleading because it will return "unitizerStateProcessed" objects if ## it can, and only if not "unitizerStateRaw" objects (e.g. if we're dealing ## with "in_pkg") as.state_raw <- function(x) { err.msg <- cc( "%s must be character(1L) %%in%% ", deparse(.unitizer.valid.state.abbr), ", NULL, an environment, or ", "must inherit from S4 classes `unitizerStateRaw`, ", "`unitizerStateProcessed` or `unitizerInPkg` ", "in order to be interpreted as a unitizer state object." ) if( !is(x, "unitizerState") && !(is.chr1(x) && x %in% .unitizer.valid.state.abbr) && !is.environment(x) && !is(x, "unitizerInPkg") && !is.null(x) ) stop(word_wrap(collapse="\n", sprintf(err.msg, "Argument `x`"))) x.raw <- if(!is(x, "unitizerState")) { if(is.null(x) || is.character(x)) { char_or_null_as_state(x) } else { # x is either an environment or inPkg, so need to create a state object to # inject that in state.opt <- getOption("unitizer.state") state.tpl <- if(is(state.opt, "unitizerState")) { as.unitizerStateRaw(state.opt) } else if (is(state.opt, "unitizerStateRaw")) { state.opt } else if (is.null(state.opt) || is.character(state.opt)) { char_or_null_as_state(state.opt) } else if (is.environment(state.opt) || is(state.opt, "unitizerInPkg")) { stop( "Value for `getOption('unitizer.state')` is incompatible with ", "using an environment or an 'unitizerInPkg' object as the value ", "for the `state` argument because it also is an environment ", "or a 'unitizerInPkg' object; you must change the option ", "or the `state` argument to be compatible." ) } else { stop( word_wrap( collapse="\n", sprintf(err.msg, "`getOption('unitizer.state')`") ) ) } state.tpl@par.env <- x state.tpl } } else x x.raw } unitizer/R/faux_prompt.R0000644000176200001440000000520514766101401015015 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Emulate the R Console Prompt # # @keywords internal # @param prompt what character to use as the prompt character # @param continue what character to use as the second and onward prompt line character # @return the expression typed in by the user faux_prompt <- function( prompt=getOption("prompt"), continue=getOption("continue") ) { prompt.start <- prompt res <- "" res.parse <- NULL reset <- FALSE old.opt <- options(warn=1L) on.exit(options(old.opt)) lang <- Sys.getenv("LANGUAGE", unset=NA) Sys.setenv("LANGUAGE"="en") # needed for "unexpected end of input" on.exit( if(is.na(lang)) Sys.unsetenv("LANGUAGE") else Sys.setenv("LANGUAGE"=lang) ) repeat { withRestarts( withCallingHandlers( res.parse <- tryCatch({ new <- read_line(prompt) if( nzchar(new) && charToRaw(substr(new, nchar(new), nchar(new))) == 3 ) { # Fake interrupt on receiving 0x03 (CTRL+C, we assume no encodings # out there use this internally...). Can figure out how to # programatically send a CTRL+C to the console. invokeRestart("unitizerInterrupt") } res <- paste0(res, new, if(nzchar(res)) '\n' else "") parsed <- parse(text=res) }, error=function(e) { if(!isTRUE(grepl(" unexpected end of input\n", conditionMessage(e)))) { e$call <- if(nzchar(res)) res else NULL stop(e) } } ), interrupt=function(e) { invokeRestart("unitizerInterrupt") } ), unitizerInterrupt=function(e) { reset <<- TRUE } ) if(reset) { cat("\n") if(!nzchar(res)) { cat("\n") meta_word_cat("Type \"Q\" at the prompt to quit unitizer.") } prompt <- prompt.start res <- "" reset <- FALSE } else prompt <- `continue` if(is.expression(res.parse)) { return(res.parse) } } NULL } unitizer/R/translate.R0000644000176200001440000006420414766101401014452 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Convert a \code{testthat} Test File to a \code{unitizer} #' #' Converts a \bold{copy} of an existing \code{testthat} test file to a #' \code{unitizer} test file and test store, or a directory of such files to #' a corresponding \code{unitizer} directory. See examples. #' #' @section Disclaimers: #' #' If you already have an extensive test suite in \code{testthat} and you do not #' intend to modify your tests or code very much there is little benefit (and #' likely some drawbacks) to migrating your tests to \code{unitizer}. Please #' see the introduction vignette for a (biased) view of the pros and cons of #' \code{unitizer} relative to \code{testthat}. #' #' These translation functions are provided for your convenience. The #' \code{unitizer} author does not use them very much since he seldom needs to #' migrate \code{testthat} tests. As a result, they have not been tested as #' thoroughly as the rest of \code{unitizer}. Translation is designed to work #' for the most common \code{testthat} use cases, but may not for yours. Make #' sure you \code{\link{review}} the resulting \code{unitizer}s to make sure #' they contain what you expect before you start relying on them. This is #' particularly important if your \code{testthat} test files are not meant to #' be run stand-alone with just \code{test_file} (see "Differences That May #' Cause Problems"). #' #' Note you can also \code{unitize} your \code{testthat} files \bold{without} #' translating them (see notes). #' #' @section Workflow: #' #' \enumerate{ #' \item Start a fresh R session #' \item Run your \code{testthat} tests with \code{test_dir} to #' ensure they are still passing. If your tests are are runnable only #' via \code{test_check} because they directly access the namespace of your #' package, see "Differences That May Cause Problems" below #' \item Run \code{testthat_dir_translate} #' \item [optional] use \code{\link{review}} to review the resulting #' unitizer(s) #' } #' We recommend using \code{testthat_translate_dir} over #' \code{testthat_translate_file} because the former also copies and loads any #' helper files that may be defined. Since libraries used by multiple test #' files are commonly loaded in these helper files, it is likely that just #' translating a single file without also copying the helper files will not #' work properly. #' #' @section How the Conversion Works: #' #' For a subset of the \code{expect_*} functions we extract the \code{object} #' parameter and discard the rest of the expectation. For example #' \preformatted{expect_equal(my_fun(25), 1:10)} becomes #' \preformatted{my_fun(25)}. The idea is that on unitizing the expression the #' result will be output to screen and can be reviewed and accepted. #' Not all \code{expect_*} functions are substituted. For example, #' \code{expect_is} and \code{expect_that} are left unchanged because the tests #' for those functions do not or might not actually test the values of #' \code{object}. \code{expect_gt} and similar are also left unchanged as that #' would require more work than simply extracting the \code{object} parameter. #' #' It is perfectly fine to \code{unitize} an \code{expect_*} call unsubstituted. #' \code{unitizer} captures conditions, values, etc., so if an \code{expect_*} #' test starts failing, it will be detected. #' #' \code{unitizer} will then evaluate and store the results of such expressions. #' Since in theory we just checked our \code{testthat} tests were working, #' presumably the re-evaluated expressions will produce the same values. Please #' note that the translation process does not actually check this is true (see #' "Differences That May Cause Problems") so \code{review}ing the results is a #' good idea. #' #' \code{test_that} calls are converted to \code{\link{unitizer_sect}} calls, #' and the contents thereof are processed as described above. Calls to #' \code{context} are commented out since there currently is no \code{unitizer} #' equivalent. Other \code{testthat} calls are left unchanged and their return #' values used as part of the \code{unitizer} tests. #' #' Only top level calls are converted. For example, code like #' \code{for(i in 1:10) expect_equal(my_fun(i), seq(i))} or even #' \code{(expect_equal(my_fun(10), 1:10))} will not be converted since #' \code{expect_equal} is nested inside a \code{for} and \code{(} respectively. #' You will need to manually edit these calls (or just let them remain as is, #' which is not an issue). #' #' We identify calls to extract based purely on the function symbols (i.e. we #' do not check whether \code{expect_equal} actually resolves to #' \code{testthat::expect_equal} in the context of the test file). #' #' The \code{unitizer} files will be created in a sibling folder to the folder #' containing the \code{testthat} files. The names of the new files will be #' based on the old files. See params \code{target.dir}, \code{name.new}, #' \code{name.pattern}, and \code{name.replace} for more details. We encourage #' you to try the default settings first as those should work well in most #' cases. #' #' When using \code{testthat_translate_dir}, any files that match #' \code{"^helper.*[rR]$"} are copied over to a '/_pre' subdirectory #' in \code{"target.dir"}, and are pre-loaded by default before the tests are #' \code{unitize}d. #' #' @section \code{unitizer} Differences That May Cause Problems: #' #' If you run your tests during development with \code{test_dir} odds #' are the translation will work just fine. On the other hand, if you rely #' exclusively on \code{test_check} you may need to use #' \code{state=unitizerStateNoOpt(par.env="pkgName")} when you translate to #' make sure your tests have access to the internal namespace functions. #' See \code{\link{unitizerState}} for details on how to modify state tracking. #' #' If your tests were translated with the \code{state} parameter changed from #' its default value, you will have to use the same value for that parameter in #' future \code{unitize} or \code{unitize_dir} runs. #' #' @section Alternate Use Cases: #' #' If you wish to process \code{testthat} files for use with the standard R #' \dQuote{.Rout} / \dQuote{.Rout.save process} you can set the \code{unitize} #' and \code{use.sects} parameters to FALSE. #' #' @export #' @seealso \code{\link{unitize}}, \code{\link{unitizerState}} #' @aliases testthat_translate_name testthat_translate_dir #' @param file.name a path to the \code{testthat} test file to convert #' @param dir.name a path to the \code{testthat} directory to convert #' @param target.dir the directory to create the \code{unitizer} test file and #' test store in; for \code{testthat_translate_file} only: if NULL will return #' as a character vector what the contents of the translated file would have #' been instead of writing the file #' @param keep.testthat.call whether to preserve the \code{testthat} call that #' was converted, as a comment #' @param filter regular expression to select what files in a director are #' translated #' @param ... params to pass on to \code{testthat_translate_name} #' @param name.new character(1L) the base name for the \code{unitizer} files; #' do not include an extension as we will add it (".R" for the testfile, #' ".unitizer" for the data directory); set to NULL to generate the name #' from the \code{testthat} file name #' @param name.pattern character(1L) a regular expression intended to match #' the \code{testthat} test file name (see \code{name.replace}) if #' \code{name.pattern} matches, then the new file name will be #' constructed with this (used as \code{replace} parameter to #' \code{\link{sub}}); in addition we will add ".R" and ".unitizer" as the #' extensions for the new files so do not include extensions in your #' \code{name.replace} parameter #' @param name.replace character(1L) the replacement token, typically would #' include a \code{"\\1"} token that is filled in by the match group from #' \code{name.pattern} #' @param prompt character(1L): \itemize{ #' \item "always" to always prompt before writing new files #' \item "overwrite" only prompt if existing file is about to be overwritten #' \item "never" never prompt #' } #' @param force logical(1L) whether to allow writing to a \code{target.dir} that #' contains files (implies \code{prompt="never"} when #' \code{testthat_translate_dir} runs \code{testthat_translate_file}) #' @param state what state control to use (see same argument for #' \code{\link{unitize}}) #' @param interactive.mode logical(1L) primarily for testing purposes, allows #' us to force prompting in non-interactive mode; note that \code{unitize} #' and \code{unitize_dir} are always called in non-interactive mode by these #' functions, this parameter only controls prompts generated directly by these #' functions. #' @param use.sects TRUE (default) or FALSE whether to translate #' \code{test_that} sections to \code{unitizer_sect} or simply to turn them #' into comment banners. #' @param unitize TRUE (default) or FALSE whether to run \code{unitize} after #' the files are translated. #' @return a file path or a character vector (see \code{target.dir}) #' @examples #' \dontrun{ #' library(testthat) # required #' testthat_translate_file("tests/testthat/test-random.R") #' #' # Translate `dplyr` tests (assumes `dplyr` source is in './dplyr') #' # Normally we would use default `state` value but we cannot in this case #' # due to conflicting packages and setup #' #' testthat_translate_dir( #' "dplyr/tests/testthat", state=unitizerStateSafe(par.env="dplyr") #' ) #' # Make sure translation worked (checking one file here) #' # *NOTE*: folder we are looking at has changed #' #' review("dplyr/tests/unitizer/summarise.unitizer") #' #' # Now we can unitize any time we change our code #' #' unitize_dir( #' "dplyr/tests/unitizer", state=unitizerStateSafe(par.env="dplyr") #' ) #' } testthat_translate_file <- function( file.name, target.dir=file.path(dirname(file.name), "..", "unitizer"), state=getOption("unitizer.state"), keep.testthat.call=TRUE, prompt="always", interactive.mode=interactive(), use.sects=TRUE, unitize=TRUE, ... ) { untz.file <- testthat_transcribe_file( file.name, target.dir, keep.testthat.call, prompt, interactive.mode=interactive.mode, use.sects=use.sects, ... ) if(!is.null(target.dir) && unitize) { unitize( test.file=untz.file, auto.accept="new", state=state, interactive.mode=FALSE ) } return(untz.file) } #' Transcribes a \code{testtaht} File Into \code{unitizer} Format #' #' Internal use only, required so we can ensure the parse succeeded because of #' possible parse-deparse issues independent of running \code{unitize}, since #' \code{unitize} cannot be run inside a \code{tryCatch} block. #' #' @keywords internal #' @inheritParams testthat_translate_file testthat_transcribe_file <- function( file.name, target.dir=file.path(dirname(file.name), "..", "unitizer"), keep.testthat.call=TRUE, prompt="always", interactive.mode, use.sects=TRUE, ... ) { if(!is.character(file.name) || length(file.name) != 1L) stop("Argument `file.name` must be character(1L)") if(!file_test("-f", file.name)) stop("Argument `file.name` does not point to a readable file") if(isTRUE(!use.sects %in% c(TRUE, FALSE))) stop("Argument `use.sects` must be TRUE or FALSE.") valid.prompt <- c("always", "overwrite", "never") if( !is.character(prompt) || length(prompt) != 1L || is.na(prompt) || !prompt %in% valid.prompt ) stop( "Argument prompt must be character(1L), not NA, and in ", deparse(valid.prompt) ) funs.to.extract <- tt_trans_funs # These should probably be defined at top level in package... cln.dbl <- quote(`::`) cln.trp <- quote(`:::`) tt.symb <- quote(testthat) t_t.symb <- quote(test_that) cont.symb <- quote(context) # convert the calls back to character, done as an in-body function since only # ever called here, and a bunch of variables are useful to share testthat_extract_all <- function(expr, mode="all", use.sects=TRUE) { stopifnot(mode %in% c("all", "sub")) result.final <- character() for(i in seq_along(expr)) { success <- FALSE result <- character() if(is.call(expr[[i]])) { # pull out function symbol for idendification sub.call <- expr[[i]][[1L]] if( is.call(sub.call) && length(sub.call) == 3L && ( identical(sub.call[[1L]], cln.dbl) || identical(sub.call[[1L]], cln.trp) ) && identical(sub.call[[2L]], tt.symb) ) { sub.call <- sub.call[[3L]] } if( is.symbol(sub.call) && identical(sub.call, t_t.symb) ) { # test_that call requires special handling, if(!identical(mode, "all")) { # check we don't have nested `test_that` result <- c( result, paste0( "# [ERROR: testthat -> unitizer] cannot extract nested ", "`test_that` calls" ) ) result <- c(result, deparse(expr[[i]])) } else { # First extract params res.extract <- testthat_match_call( expr[[i]], tt_fun, c("code", "desc") ) if(any(nchar(res.extract$msg))) { # failed result <- c(result, res.extract$msg) result <- c(result, deparse(expr[[i]])) } else { result <- c( result, attr(expr[[i]], "comment"), if(keep.testthat.call) paste0("# ", deparse(comm_and_call_extract(expr[[i]])$call)) ) } # Now parse the `code` param looking for code <- res.extract$call$code code.block <- FALSE if( code.block <- is.language(code) && length(code) > 1L && identical(code[[1L]], as.name("{")) ) { sub.expr <- code[-1L] } else sub.expr <- code sub.res <- Recall(sub.expr, mode="sub") if(code.block && use.sects) { sub.res <- paste0( c("{", paste0(" ", sub.res, collapse="\n"), "}"), collapse="\n" ) } else sub.res <- paste0(sub.res, collapse="\n") # Put it all together new <- if(use.sects) { paste0( "unitizer_sect(", paste0(deparse(res.extract$call$desc), sep=""), ", ", sub.res, ")" ) } else { c( paste0( "# ", as.character( H3(paste0(deparse(res.extract$call$desc), sep="")), width=getOption('width') - 2 ) ), sub.res ) } result <- c(result, new) } } else if ( is.symbol(sub.call) && identical(sub.call, cont.symb) ) { res.pre <- comm_and_call_extract(expr[[i]]) result <- c( result, res.pre$comments, paste0("# ", paste0(deparse(res.pre$call), collapse="\n")) ) } else { # pull out comments for all of these if relevant res.pre <- comm_and_call_extract(expr[[i]]) result <- c(result, res.pre$comments) # expect_* or other similar test that calls require extraction if( is.symbol(sub.call) && ( fun.id <- match( as.character(sub.call), names(tt_trans_funs), nomatch=0L ) ) ) { res.extract <- testthat_match_call( res.pre$call, tt_trans_funs[[fun.id]], c("object") # should probably also check for `expected` or `regexp`, but current logic doesn't allow... ) result <- c( result, if(any(nchar(res.extract$msg))) res.extract$msg, if(keep.testthat.call) paste0("# ", deparse(comm_and_call_extract(expr[[i]])$call)), deparse(res.extract$call[["object"]]) ) } else { # normal calls or anything result <- c(result, deparse(res.pre$call)) } } } else { # Not a call; not sure whether we can actually ever get here due to # parse_with_comments wrapping, but just in case res <- comm_and_call_extract(expr[[i]]) result <- c(result, res$comments, deparse(res$call)) } result.final <- c(result.final, result) } result.final } # Parse and translate parsed <- parse_tests(file.name) translated <- testthat_extract_all(parsed, use.sects=use.sects) if(!is.null(target.dir)) { # Create unitizer untz.base <- testthat_translate_name(file.name, target.dir, ...) untz.test <- paste0(untz.base, ".R") # prompt if needed to create directories if(file.exists(target.dir) && ! file_test("-d", target.dir)) { stop("Argument `target.dir` must be a directory") } if(!file.exists(target.dir)) { if(!identical(prompt, "never") && !identical(prompt, "overwrite")) { u.inp <- if(interactive.mode) { simple_prompt( paste0("Create directory ", target.dir," for unitizer tests?") ) } else "N" if(!identical(u.inp, "Y")) stop("Unable to proceed without creating target directory") } if( inherits( try(dir.create(target.dir, recursive=TRUE)), "try-error" ) ) stop( "Unable to create test directory `", normalize_path(target.dir), "`; see prior errors." ) } # prompt if file already exists if(!identical(prompt, "never") && file.exists(untz.test)) { u.inp <- if(interactive.mode) { simple_prompt( paste0("Overwrite file '", normalize_path(untz.test), "'?") ) } else "N" if(!identical(u.inp, "Y")) stop( "Unable to proceed without user approval as `", untz.test, "` already exists." ) } # Create files, run tests ... if(inherits(try(file.create(untz.test)), "try-error")) stop("Unable to create test file '", untz.test, "'; see prior errors.") try(cat(translated, file=untz.test, sep="\n")) return(untz.test) } return(translated) } #' @rdname testthat_translate_file #' @export testthat_translate_dir <- function( dir.name, target.dir=file.path(dir.name, "..", "unitizer"), filter="^test.*\\.[rR]", state=getOption("unitizer.state"), keep.testthat.call=TRUE, force=FALSE, interactive.mode=interactive(), use.sects=TRUE, unitize=TRUE, ... ) { # Validate chr.1.args <- list( dir.name=dir.name, target.dir=target.dir, filter=filter ) for(i in names(chr.1.args)) if( !is.character(chr.1.args[[i]]) || length(chr.1.args[[i]]) != 1L || is.na(chr.1.args[[i]]) ) stop("Argument `", i, "` must be character(1L) and not NA") if(!isTRUE(force) && !identical(force, FALSE)) stop("Argument `prompt` must be TRUE or FALSE") if(!file_test("-d", dir.name)) stop("Argument `", dir.name, "` is not a directory name") # Get file names file.list <- sort(dir(dir.name)) files.helper <- normalize_path( file.path(dir.name, grep("^helper.*[rR]$", file.list, value=TRUE)) ) files.test <- normalize_path( file.path(dir.name, grep(filter, file.list, value=TRUE)) ) res <- character(length(files.test)) unparseable <- unparseable.src <- character() if(length(files.test)) { # Checks if(file.exists(target.dir) && !file_test("-d", target.dir)) stop("`target.dir` (", target.dir, ") exists but is not a directory") if( file.exists(target.dir) && !force && length(dir(all.files=TRUE, include.dirs=TRUE, no..=TRUE)) ) stop( "`target.dir` '", normalize_path(target.dir) ,"' contains files so we ", "cannot proceed; manually clear or set `force` to TRUE. This is a ", "safety feature to ensure files are not accidentally overwritten." ) dir.create(target.dir, recursive=TRUE) # Load helper files and copy them to new location if(length(files.helper)) { dir.create(help.dir <- file.path(target.dir, "_pre")) file.copy(files.helper, help.dir) } # Translate files, need to unitize one by one mostly because we wrote the # `testthat_translate_file` function first, but would probably be better # if we separate the file translation and unitizing for(i in seq_along(files.test)) { # Attempt to parse to make sure parse -> deparse translation didn't go # awry untz.file <- testthat_transcribe_file( files.test[[i]], target.dir, keep.testthat.call, prompt="never", interactive.mode=interactive.mode, use.sects=use.sects, ... ) res[[i]] <- untz.file if(inherits(try(parse(untz.file)), "try-error")) { unparseable[[length(unparseable) + 1L]] <- untz.file unparseable.src[[length(unparseable.src) + 1L]] <- files.test[[i]] } } # Exclude failing files so we can just unitize the directory unlink(unparseable) # Unitize all files in directory if(unitize) { unitize_dir( test.dir=target.dir, auto.accept="new", state=state, interactive.mode=FALSE ) } } if(length(unparseable)) warning( "Unable to parse the translated versions of the following file(s), ", "so they are not unitized:\n", paste0(" * ", basename(unparseable.src), collapse="\n"), "\nThis likely happed because they contain language constructs that do ", " not survive the parse - deparse cycle. You can re-run the translation ", "with `testthat_translate_file` and look at the resulting translated ", "file. Additionally, the parse error should be part of the output above." ) invisible(res) } #' @rdname testthat_translate_file #' @export testthat_translate_name <- function( file.name, target.dir=file.path(dirname(file.name), "..", "unitizer"), name.new=NULL, name.pattern="^(?:test\\W*)?(.*)(?:\\.[rR])$", name.replace="\\1" ) { # Check args args <- as.list(environment()) for(i in names(args)) { if(identical(i, "name.new")) next arg <- args[[i]] if(!is.character(arg) || length(arg) != 1L || is.na(arg)) stop("Argument `", i, "` must be character(1L) and not NA") } if( !is.null(name.new) && !( is.character(name.new) || length(name.new) != 1L || is.na(name.new) ) ) stop("Argument `name.new` must be NULL, or character(1L) and not NA") # Special cases if(is.null(target.dir)) return(NULL) if(!is.null(name.new)) { if(basename(name.new) != name.new) stop( "Argument `name.new` should be a file name without any directories ", "specified; you may specify those with `target.dir`" ) return(file.path(target.dir, name.new)) } # Transform name base.new <- sub(name.pattern, name.replace, basename(file.name)) if(!nchar(base.new)) stop( "Produced zero char name when attempting to make unitizer file name ", "from `testthat` file name, please review `file.name`, `name.pattern`, ", "and `name.replace`" ) if(basename(base.new) != base.new) stop( "File name creating process produced sub-directories; make sure ", "`name.pattern` and `name.replace` are such that the resulting file ", "names do not contain sub-directories" ) file.path(target.dir, base.new) } # Pull out parameter from call # # @param target.params parameters required in the matched call testthat_match_call <- function(call, fun, target.params) { call.matched <- try(match.call(definition=fun, call), silent=TRUE) fail.msg <- "" if(inherits(call.matched, "try-error")) { fail.msg <- conditionMessage(attr(call.matched, "condition")) if(!any(nchar(fail.msg))) fail.msg <- "Failed matching call" } else if (!all(param.matched <- target.params %in% names(call.matched))) { fail.msg <- paste0( "`", paste0(deparse(target.params[!param.matched]), sep=""), "` parameter", if(length(which(!param.matched)) > 1L) "s", " missing" ) } if(any(nchar(fail.msg))) { fail.msg <- paste0( "# ", word_wrap( paste0( "[ERROR: testthat -> unitizer] ", paste0(fail.msg, collapse="\n") ), width=78L ) ) } list(call=call.matched, msg=fail.msg) } # Signature of translatable funs tt_trans_funs <- list( expect_condition = function (object, regexp = NULL, class = NULL, ..., info = NULL, label = NULL) NULL, expect_equal = function (object, expected, ..., tolerance = if (edition_get() >= 3) testthat_tolerance(), info = NULL, label = NULL, expected.label = NULL) NULL, expect_equivalent = function (object, expected, ..., info = NULL, label = NULL, expected.label = NULL) NULL, expect_error = function (object, regexp = NULL, class = NULL, ..., info = NULL, label = NULL) NULL, expect_false = function (object, info = NULL, label = NULL) NULL, expect_identical = function (object, expected, info = NULL, label = NULL, expected.label = NULL, ...) NULL, expect_message = function (object, regexp = NULL, class = NULL, ..., all = FALSE, info = NULL, label = NULL) NULL, expect_null = function (object, info = NULL, label = NULL) NULL, expect_output = function (object, regexp = NULL, ..., info = NULL, label = NULL, width = 80) NULL, expect_silent = function (object) NULL, expect_true = function (object, info = NULL, label = NULL) NULL, expect_warning = function (object, regexp = NULL, class = NULL, ..., all = FALSE, info = NULL, label = NULL) NULL ) # test_that signature tt_fun <- function (desc, code) NULL unitizer/R/diff.R0000644000176200001440000000167714766101401013372 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. setMethod( "diffObj", c("conditionList", "conditionList"), function(target, current, ...) { dots <- match.call(expand.dots=FALSE)[["..."]] if("mode" %in% names(dots)) callNextMethod() else callNextMethod(target=target, current=current, ..., mode="unified") } ) unitizer/R/upgrade.R0000644000176200001440000002470614766101401014107 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Alter Older unitizer Versions So They Pass Validation in Latest Version # # Sequentially applies all applicable patches # # @param object an unitizer object # @param ... other arguments # @return an upgraded unitizer object setMethod("upgrade", "unitizer", valueClass="unitizer", function(object, ...) { # - Do We Need To Upgrade -------------------------------------------------- if( inherits(object <- try(upgrade_internal(object)), "try-error") ) { return( paste0( "Upgrade failed: ", paste0(conditionMessage(attr(object, "condition")), collapse="") ) ) } if(inherits(try(validObject(object, complete=TRUE)), "try-error")){ # nocov start return( "Internal Error: Upgrade produced invalid object; contact maintainer." ) # nocov end } object } ) # Helper function to actually do upgrade upgrade_internal <- function(object) { ver <- object@version if(is.character(ver)) { ver <- package_version(ver) } else { object@version <- as.character(ver) } if(!is.package_version(ver)) stop("Cannot determine unitizer version.") # nocov # - 0.4.3 -------------------------------------------------------------------- # Need to add tests.conditions.new slot if(ver < "0.4.3") { object <- addSlot( object, "tests.conditions.new", logical(length(object@items.new)) ) } # - 0.5.2 -------------------------------------------------------------------- # Need to add sections.ref and section.map.ref, and add a section id slot # to all the unitizerItem objects if(ver < "0.5.2") { # This adds the reference test section data # Add the requisite reference section fields ref.len <- length(object@items.ref) object <- addSlot( object, "sections.ref", list(new("unitizerSectionNA", length=ref.len)) ) object <- addSlot(object, "section.ref.map", rep(1L, ref.len)) # Updated changes sub-object object@changes <- addSlot(object@changes, "passed", integer(2L)) # Now add the new section.id field to every item object@items.ref@.items <- lapply( object@items.ref@.items, function(x) addSlot(x, "section.id", NA_integer_) ) } # - 0.5.3 -------------------------------------------------------------------- # Make sure ref item ids are reasonable if(ver < "0.5.3") { for(i in seq(length.out=length(object@items.ref))) object@items.ref[[i]]@id <- i } # - 0.9.0 -------------------------------------------------------------------- # Add new slots if(ver < "0.9.0") { object <- addSlot(object, "test.file.loc", NA_character_) # not sure this is completely necessary since we're just using the prototype value object <- addSlot(object, "eval", FALSE) # not sure this is completely necessary since we're just using the prototype value object <- addSlot(object, "eval.time", 0) # not sure this is completely necessary since we're just using the prototype value object <- addSlot(object, "updated", FALSE) # not sure this is completely necessary since we're just using the prototype value for(i in seq_along(object@items.ref)) object@items.ref[[i]] <- addSlot(object@items.ref[[i]], "section.name", "") } # - 1.0.0 -------------------------------------------------------------------- # adding some slots, and version now stored as character instead of # `package_version` in an 'ANY' slot if(ver < "1.0.0") { for(i in seq_along(object@items.ref)) object@items.ref[[i]] <- addSlot( object@items.ref[[i]], "glob.indices", new("unitizerGlobalIndices") ) object@version <- as.character(object@version) object <- addSlot(object, "state.ref", new("unitizerGlobalTrackingStore")) object <- addSlot(object, "global", NULL) } if(ver < "1.0.1") { object@state.ref <- removeSlots(object@state.ref, c("dummy", ".dummy")) object <- addSlot(object, "state.new", new("unitizerGlobalTrackingStore")) } if(ver < "1.0.2") { statObj <- new("unitizerGlobalState") object@items.ref@.items <- lapply( object@items.ref@.items, function(x) addSlot(x, "state", statObj) ) } if(ver < "1.0.3") { object@items.ref@.items <- lapply( object@items.ref@.items, function(x) { x <- addSlot(x, "call.dep", deparse_call(x@call)) x@call <- NULL x } ) object@items.ref.calls.deparse <- vapply( object@items.ref@.items, slot, character(1L), "call.dep" ) } if(ver < "1.0.4") { object <- addSlot(object, "cons", NULL) } if(ver < "1.0.6") { object <- addSlot(object, "res.data", NULL) } if(ver < "1.0.7") { object <- addSlot(object, "updated.at.least.once", FALSE) } if(ver < "1.0.8") { object <- removeSlots(object, "cons") } if(ver < "1.0.9") { object@state.new <- addSlot(object@state.new, "namespaces", list()) object@state.ref <- addSlot(object@state.ref, "namespaces", list()) } if(ver < "1.0.10") { object@items.ref@.items <- lapply( object@items.ref@.items, function(x) { x@glob.indices <- addSlot(x@glob.indices, "namespaces", 0L) x@state <- addSlot(x@state, "namespaces", NULL) x } ) } if(ver < "1.0.11") { # need to make sure we wrap values in list to avoid issues with recursive # validObject attempting to validate S3 objects for(i in seq_along(object@items.ref@.items)) object@items.ref@.items[[i]]@data@value <- list( object@items.ref@.items[[i]]@data@value ) } # - 1.1.0 -------------------------------------------------------------------- if(ver < "1.1.0") { object <- addSlot(object, "jump.to.test", 0L) } if(ver < "1.1.1") { object <- addSlot(object, "items.new.calls.deparse.id", integer()) object <- addSlot(object, "bookmark", NULL) object <- removeSlots(object, "jump.to.test") } # - 1.4.x -------------------------------------------------------------------- if(ver < "1.4.15") { object <- addSlot(object, "upgraded.from", "") object <- addSlot(object, "best.name", "") object <- addSlot(object, "show.progress", PROGRESS.MAX) } if(ver < "1.4.17.9006") { object <- addSlot(object, "transcript", FALSE) } # - Keep at End--------------------------------------------------------------- # Always make sure that any added upgrades require a version bump as we always # set version to current version, not the last version that required upgrades object@version <- as.character(packageVersion("unitizer")) object@upgraded.from <- as.character(ver) # - Done --------------------------------------------------------------------- object } # Helper Function To Add A Slot to An Out-of-date S4 Object # # @keywords internal addSlot <- function(object, slot.name, slot.value) { if(!isS4(object)) stop("Internal Error: Argument `object` must be an S4 object") # nocov slot.names <- slotNames(getClassDef(class(object))) if(!slot.name %in% slot.names) { warning( "Slot `", slot.name, "` does not exist in current version of `", class(object), "` so not added to object.", immediate. = TRUE ) return(object) } slots <- slotNames(object) slot.vals <- list() for(i in slots) { if(identical(i, slot.name)) next tmp <- try(slot(object, i), silent=TRUE) if(!inherits(tmp, "try-error")) { slot.vals <- c(slot.vals, setNames(list(tmp), i)) # growing list, but shouldn't be massive } } slot.vals <- c(slot.vals, setNames(list(slot.value), slot.name)) new.object <- new(class(object)) for(slot.name in names(slot.vals)) { slot(new.object, slot.name) <- slot.vals[[slot.name]] } new.object } # Rename a slot # # Basically assumes old name exists in object, but not in new class definition renameSlot <- function(object, old.name, new.name) { stopifnot(isS4(object), is.chr1(old.name), is.chr1(new.name)) slots <- slotNames(object) stopifnot(!old.name %in% slots, new.name %in% slots) old.slot <- try(slot(object, old.name)) if(inherits(old.slot, "try-error")) stop("Old slot `", old.name, "` doesn't exist in object") slot.vals <- sapply(slots[slots != new.name], slot, object=object, simplify=FALSE) args.final <- c( class(object), slot.vals, setNames(list(slot(object, old.name)), new.name) ) do.call("new", args.final) } # Removes Slots # # Ignores slots that are already missing removeSlots <- function(object, slots.to.remove) { stopifnot(isS4(object)) slots <- slotNames(object) slot.vals <- sapply( slots[!slots %in% slots.to.remove], slot, object=object, simplify=FALSE ) do.call("new", c(class(object), slot.vals)) } # Intended for use only within unitize_core loop upgrade_warn <- function(unitizers, interactive.mode, global) { review <- to_review(summary(unitizers, silent=TRUE)) upgraded <- vapply(as.list(unitizers), slot, '', 'upgraded.from') up.rev <- which(review & nzchar(upgraded)) if(length(up.rev)) { many <- length(up.rev) > 1L to.up.ids <- vapply(as.list(unitizers)[up.rev], slot, '', 'best.name') meta_word_cat( paste0( "\nThe following unitizer", if(many) "s", " will be upgraded to ", "version '", as.character(packageVersion('unitizer')), "':\n" ), as.character(UL(paste0(to.up.ids, " (at '", upgraded[up.rev], "')"))), width=getOption("width") - 2L ) if(!interactive.mode) invokeRestart("unitizerInteractiveFail") else { meta_word_msg( "unitizer upgrades are IRREVERSIBLE and not backwards compatible. ", "Proceed?" ) pick <- unitizer_prompt( "Upgrade unitizer stores?", hist.con=NULL, valid.opts=c(Y="[Y]es", N="[N]o"), global=global, browse.env= # missing? ) if(!identical(pick, 'Y')) invokeRestart("unitizerUserNoUpgrade") } } invisible(NULL) } unitizer/R/asciiml.R0000644000176200001440000002164314766101401014076 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. # Text Representations of HTML Objects # # Functions defined here should ultimately be extended into a more # comprehensive stand alone library for ASCII structured objects (banners, # tables, etc.). # # Blah b # # @keywords internal # @include list.R NULL ## Print a Header ## ## @aliases print.H2 print.H3 print.header ## @param x a 1 length character vector ## @param margin one of "both", "top", "bottom", "none", whether to add newlines ## at top or bottom ## @param ... passed on to \code{as.character} ## @return 1 length character vector #' @export print.header <- function(x, margin="bottom", ...) { y <- as.character(x, margin, ...) cat(y) invisible(y) } #' @export as.character.header <- function(x, margin="bottom", ...) { if(!is.character(x)) stop("Argument `x` must be a character vector") margin.legal <- c("both", "none", "top", "bottom") if(!is.character(margin) || !isTRUE(margin %in% margin.legal)) stop("Argument `margin` must be in ", deparse(margin.legal)) if(isTRUE(margin %in% c("both", "top"))) x <- paste0(c("", x), collapse="\n") if(isTRUE(margin %in% c("both", "bottom"))) x <- paste0(c(x, ""), collapse="\n") paste0(c(x, ""), collapse="\n") } #' @export as.character.H3 <- function(x, margin="bottom", width=getOption("width"), ...) { x <- header_help(x, width=width,..., pad.char="-") NextMethod() } #' @export as.character.H2 <- function(x, margin="bottom", width=getOption("width"), ...) { x <- header_help(x, width=width,..., pad.char="=") NextMethod() } #' @export as.character.H1 <- function(x, margin="bottom", width=getOption("width"), ...) { if(width < 5L) return(x) x <- c( paste0(c("+", rep("-", width - 2L), "+"), collapse=""), paste0( "| ", paste0( text.wrapped <- unlist(word_wrap(unclass(x), width - 4L), use.names=FALSE), vapply( (width - 4L) - nchar(text.wrapped), function(x) paste0(rep(" ", x), collapse=""), character(1L) ) ), " |" ), paste0(c("+", rep("-", width - 2L), "+"), collapse="") ) NextMethod() } # Helper function for single line headers # # @param x the contents of the header # @param width how wide we want the header to display # @param ... unused, for compatibility with print generic # @param pad.char which character to use to form the header structure header_help <- function(x, width, ..., pad.char="-") { par.call <- sys.call(-1L) stop2 <- function(msg) stop(simpleCondition(msg, par.call)) if(!is.character(x) || length(x) != 1L) stop2("Argument `x` must be a 1 length character vector") if(!is.character(pad.char) || length(pad.char) != 1L || nchar(pad.char) != 1L) stop2("Argument `pad.char` must be a 1 length 1 character character vector.") if(!is.numeric(width) || length(width) != 1L) stop2("Argument `width` must be a 1 length numeric vector.") if(width < 8L) return(x) if(isTRUE(nchar(x) > width - 4L)) x <- paste0(substr(x, 1, width - 7L), "...") paste0( pad.char, " ", x, " ", paste0(rep_len(pad.char, width - 3L - nchar(x)), collapse=""), collapse="" ) } # Create Header Objects # # Header objects are 1 length character vectors that are printed with text # formatting that highlight their "headerness". # # @seealso \code{\link{print.header}} # @aliases H1, H2, H3 # @param x 1 length character vector to turn into a header # @param level 1 length integer, what level to make a header # @return header object header <- function(x, level) { if(!is.character(x) || length(x) != 1L) stop("Argument `x` must be a one length character vector") levels.valid <- 1:3 if( !is.numeric(level) || !identical(round(level), as.numeric(level)) || !isTRUE(level %in% levels.valid) ) { stop("Argument `level` must be 1 length integer-like and in ", deparse(levels.valid)) } structure(x, class=c(paste0("H", level), "header")) } H1 <- function(x) header(x, 1L) H2 <- function(x) header(x, 2L) H3 <- function(x) header(x, 3L) # Create List Objects # # Similar to UL and OL objects from HTML. These can be nested. \code{OL} # supports \code{c("numbers", "letters", "LETTERS")} as bullet types. # # Ultimately should implement this as S4 classes as assembly of lists is # annoying since the UL object is itself a list. # # @aliases OL # @param x character vector of items to make a list out of # @return OL/UL object UL <- function(x, style="-", offset=0L) { stopifnot(is.chr1(style) && nchar(style) == 1L) bullet_obj(x, style=style, type="unordered", offset=offset) } OL <- function(x, style="numbers", offset=0L) { stopifnot(is.chr1(style) && style %in% c("numbers", "letters", "LETTERS")) bullet_obj(x, style=style, type="ordered", offset=offset) } make_let_combn_fun <- function(dat) { function(x) { let.count <- ceiling(log(x, base=length(dat))) let.list <- rev( c( list(dat), replicate(let.count - 1L, c(" ", dat), simplify=FALSE) ) ) raw.vals <- paste0(do.call(paste0, do.call(expand.grid, let.list)), ".") # try to get a consistent sort across locales head(raw.vals[order(nchar(trimws(raw.vals)), raw.vals)], x) } } .bullet.funs <- list( numbers=function(x) paste0(seq.int(x), "."), letters=make_let_combn_fun(letters), LETTERS=make_let_combn_fun(LETTERS) ) bullet_obj <- function(x, type, style, offset) { if(!is.int.1L(offset) || offset < 0L) stop("Argument `offset` must be integer(1L) and GTE 0") stopifnot(is.chr1(type), type %in% c("ordered", "unordered")) if(is.character(x)) x <- as.list(x) if(!is.list(x)) stop("Argument `x` must be a list") for(i in seq_along(x)) if(!validate_bullet(x[[i]])) stop("Argument `x` contains invalid bullet item at position ", i) bulleter <- if(identical(type, "ordered")) { f <- .bullet.funs[[style]] if(!is.function(f)) { # nocov start stop("Internal Error; could not find ordered function; contact maintainer") # nocov end } f } else function(x) rep(style, x) structure( x, class=c(type, "bullet"), style=style, offset=offset, bulleter=bulleter ) } validate_bullet <- function(x) (is.character(x) && length(x) == 1L) || inherits(x, "bullet") #' Print Methods for \code{UL} and \code{OL} objects #' #' @keywords internal #' @export #' @param x object to print #' @param width integer how many characters to wrap at, if set to 0 will auto #' detect width with \code{getOptions("width")} #' @return invisibly a character vector with one element per line printed print.bullet <- function(x, width=0L, ...) { cat(rendered <- as.character(x, width), sep="\n") invisible(rendered) } #' Produce Character Vector Representation of Bullet Lists #' #' @export #' @param x object to render #' @param width how many characters to wrap at #' @param ... dots, other arguments to pass to \code{word_wrap} #' @return character vector containing rendered object, where each element #' corresponds to a line #' @keywords internal as.character.bullet <- function(x, width=0L, ...) { if(!is.numeric(width) || length(width) != 1L || width < 0) { stop("Argument `width` must be a one length positive numeric.") } mc <- match.call() if("unlist" %in% names(mc)) stop( "You may not specify `unlist` as part of `...` as that argument is ", "used internally" ) width <- as.integer(width) if(width == 0) width <- getOption("width") bullet_with_offset(x, width, ...) } bullet_with_offset <- function(x, width, pad=0L, ...) { stopifnot(is.int.1L(pad), pad >= 0L) stopifnot(is.int.1L(width), width >= 0L) pad.num <- pad + attr(x, "offset") pad <- paste0(rep(" ", pad.num), collapse="") char.vals <- vapply(x, is.character, logical(1L)) char.pad <- paste0( pad, format(attr(x, "bulleter")(sum(char.vals)), justify="right"), " " ) char.pad.size <- nchar(char.pad[[1L]]) text.width <- max(width - char.pad.size, 8L) char.wrapped <- word_wrap( unlist(x[which(char.vals)]), width=text.width, unlist=FALSE, ... ) pad.extra <- paste0(rep(" ", char.pad.size), collapse="") char.padded <- Map( char.wrapped, char.pad, f=function(x, y) if(!length(x)) x else paste0(c(y, rep(pad.extra, length(x) - 1L)), x) ) final <- vector("list", length(x)) final[which(char.vals)] <- char.padded final[which(!char.vals)] <- lapply( x[which(!char.vals)], bullet_with_offset, width=width, pad=pad.num + 2L ) unlist(final) } unitizer/R/change.R0000644000176200001440000000570314766101401013701 0ustar liggesusers# Copyright (C) Brodie Gaslam # # This file is part of "unitizer - Interactive R Unit Tests" # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Go to for a copy of the license. #' Summary of Changes #' #' Changes arise any time a user, through the interactive unitizer mode, #' requests the storing of a change (accept new version of failed test, #' add new test, remove old test). #' #' @keywords internal setClass("unitizerChanges", representation(failed="integer", new="integer", removed="integer", corrupted="integer", passed="integer"), prototype(failed=integer(2L), new=integer(2L), removed=integer(2L), corrupted=integer(2L), passed=integer(2L)), validity=function(object) { for(i in slotNames(object)) { if((len <- length(slot(object, i))) > 0L && len != 2L) { return(paste0("slot `@`", i, " must be of length 2")) } else if (slot(object, i)[[1L]] > slot(object, i)[[2L]]) { return(paste0("slot `@`", i, " must be length 2 with the first value less than the second")) } } TRUE } ) #' Print Out A Summary Of the Changes #' @keywords internal setMethod("show", "unitizerChanges", function(object) { cat(as.character(object), sep="\n") invisible(NULL) } ) #' Print Out A Summary Of the Changes #' @keywords internal setMethod("as.character", "unitizerChanges", function(x, width=getOption("width"), ...) { bullets <- character() if(sum(x@failed)) bullets <- c( bullets, paste( "Replacing", x@failed[[1L]], "out of", x@failed[[2L]], "failed tests" ) ) if(sum(x@new)) bullets <- c( bullets, paste( "Adding", x@new[[1L]], "out of", x@new[[2L]], "new tests\n" ) ) if(sum(x@removed)) bullets <- c( bullets, paste( "Removing", x@removed[[1L]], "out of", x@removed[[2L]], "removed tests\n" ) ) if(sum(x@corrupted)) bullets <- c( bullets, paste( "Replacing", x@corrupted[[1L]], "out of", x@corrupted[[2L]], "tests with errors\n" ) ) if(x@passed[[1L]]) bullets <- c( bullets, paste( "Dropping", x@passed[[1L]], "out of", x@passed[[2L]], "passed tests\n" ) ) as.character(UL(bullets), width=width) } ) #' Return Sum of Total Changes #' @keywords internal setMethod( "length", "unitizerChanges", function(x) { sum(vapply(slotNames(x), function(y) slot(x, y)[[1L]], 1L)) } ) unitizer/demo/0000755000176200001440000000000014766101222013050 5ustar liggesusersunitizer/demo/unitizer.R0000644000176200001440000000570114766101222015047 0ustar liggesuserslibrary(unitizer) unitizer_check_demo_state() # In this script we demonstrate the `unitizer` workflow by installing and # testing three versions of `unitizer.fastlm`, a package that implements faster # computations of slope, intercept and R^2 for a single variable regression. # # The package versions are: # # 1. v0.1.0: a slow version that is known to produce the correct results # 2. v0.1.1: initial (flawed) attempt at optimizing our functions # 3. v0.1.2: fixes to regressions introduced in v0.1.1 # # See Also: `?unitizer::demo`, `?unitize`, `vignette("unitizer")` `[Press ENTER to Continue]`() # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SETUP ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (.unitizer.fastlm <- copy_fastlm_to_tmpdir()) # package directory list.files(.unitizer.fastlm) # contains our sources dir.create((lib.dir <- tempfile())) options(unitizer.tmp.lib.loc=lib.dir) install.packages( .unitizer.fastlm, repos=NULL, type="src", quiet=TRUE, lib=lib.dir ) # And in our sources is the test file, which we will `unitize`: .unitizer.test.file <- file.path(.unitizer.fastlm, "tests", "unitizer", "fastlm1.R") show_file(.unitizer.test.file) # Here we copied `untizer.fastlm` sources to a temporary "package directory" # and installed it. The test file contained therein is shown for reference. # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ END SETUP ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # After you press ENTER at the prompt, `unitize` will launch. You should accept # the tests since we know the first package version is correct, though slow. `[Press ENTER to Continue]`() unitize(.unitizer.test.file) # If all went well you added four tests to `unitizer`. # # We will now update `unitizer.fastlm` package to use the fast computations. We # do this with `update_fastlm`; in real life you would be updating your source # code at this point. After the update/re-install, we re-run `unitize`: `[Press ENTER to Continue]`() update_fastlm(.unitizer.fastlm, version="0.1.1") install.packages( .unitizer.fastlm, repos=NULL, type="src", quiet=TRUE, lib=lib.dir ) unitize(.unitizer.test.file) # Let's fix the regressions we introduced and re-run `unitize`: `[Press ENTER to Continue]`() update_fastlm(.unitizer.fastlm, version="0.1.2") install.packages( .unitizer.fastlm, repos=NULL, type="src", quiet=TRUE, lib=lib.dir ) unitize(.unitizer.test.file) # If you followed instructions all tests should have passed, which tells us that # `unitizer.fastlm` is now producing the same values as it originally was when # it was just a wrapper around `base::lm`. `[Press ENTER to Continue]`() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DEMO OVER ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Show `unitizer.fastlm` is actually faster for this simple task: local({ DF <- data.frame(x=1:1e5, y=(1:1e5) ^ 2) rbind( fastlm=system.time(with(DF, utzflm::fastlm(x, y))), lm=system.time(c((lm.res <- lm(y ~ x, DF))$coefficients, summary(lm.res)$r.squared)) )[, 1:3] }) unitizer_cleanup_demo() unitizer/demo/00Index0000644000176200001440000000010614766101222014177 0ustar liggesusersunitizer Interactively step through a `unitizer` development cycle unitizer/COPYING0000644000176200001440000000121314766101401013153 0ustar liggesusersCopyright (C) 2014-2023 Brodie Gaslam This file is part of "unitizer - Interactive R Unit Tests" This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. Go to for a copy of the license. unitizer/vignettes/0000755000176200001440000000000014766360132014143 5ustar liggesusersunitizer/vignettes/u3_interactive-env.Rmd0000644000176200001440000005141314766101222020316 0ustar liggesusers--- title: "unitizeR - The Interactive Environment" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{3 - Interactive Environment} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Overview ### `unitize` vs `review` `unitizer` offers three functions to access the interactive review environment: `unitize`, `unitize_dir`, and `review`. `unitize` is used when you either want to generate a `unitizer` from a test file, or when you want to compare the re-evaluation of a test file to an existing `unitizer`. `untize_dir` does what `unitize` does, except for a whole directory at a time. `review` is a helper function used when you want to review the contents of an existing `unitizer`. This is useful if you grow uncertain about tests that you previously approved and want to ensure they actually do what you want them to. You can review and potentially remove items from a `unitizer` with `review`. Both these functions use the same interactive environment, though rules therein are slightly different. For example, in `review`, all the tests are considered passed since there is nothing to compare them to, and the interactive environment will step you through all the passed tests. `unitize` will normally omit passed tests from the review process. We will focus on `unitize` for the rest of this vignette since most of the commentary about it applies equally to `unitize_dir` and `review`. ### Example Set-up To examine the interactive environment more thoroughly we will go back to the demo (you can run it with `demo(unitizer)`). This is the `unitizer` prompt right after our first failed test when our `unitizer.fastlm` implementation was returning the wrong values: ``` > get_slope(res) unitizer test fails on value mismatch: *value* mismatch: Mean relative difference: 6943055624 @@ .ref @@ - [1] 101 @@ .new @@ + [1] 701248618125 ``` ## `unitizer` Commands Much like the `browser()` prompt, the `unitizer` prompt accepts several special expressions that allow you to control `unitizer` behavior. What the expressions are and what they do depends on context. We will review them in the context of the failed test described above. Look at what the `unitizer` prompt stated before we started reviewing our failed tests: ``` - Failed ----------------------------------------------------------------------- The 2 tests in this section failed because the new evaluations do not match the reference values from the store. Overwrite with new results ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? ``` This clearly lays out all the special commands available to us: * `Y` will accept the new value as the correct reference value to use for a test. * `N` will keep the previous reference value as the reference value for future tests. * `P` takes us back to the previously reviewed test (see "Test Navigation" next). * `B` allows us to navigate to any previously reviewed test (see "Test Navigation" next). * `R` toggles re-run mode; when you complete review or exit, `unitizer` will re-run the tests, which is useful if you made changes to your source code and re-installed your package from the `unitizer` prompt. * `Q` quits `unitizer` (see "Quitting `unitizer`"). * `H` provides contextual help. If you type any of those letters into the `unitizer` prompt you will cause `unitizer` to respond as described above instead of evaluating the expression as it would be at the normal R console prompt. If you have a variable assigned to one of those letters and you wish to access it, you can do so with any of `get`, `(`, `print`, etc. For example, suppose we stored something in `Y`, then to access it all these commands would work: * `(Y)` * `get("Y")` * `print(Y)` `unitizer` checks for an exact match of a user expression to the special command letters, so something like `(Y)` does not match `Y` which allows you to reach the value stored in `Y`. If at any time you forget what `unitizer` options are available to you you can just hit the "ENTER" key and `unitizer` will re-print the options to screen. You can accept all unreviewed tests in a sub-section, section, or unitizer with `YY`, `YYY`, and `YYYY` respectively. You can also reject them with `NN`, `NNN`, and `NNNN`. Please note that accepting multiple tests without reviewing them is **a really bad idea**, and you should only resort to these shortcuts when you are absolutely certain of what you are doing. The most common use case for these shortcuts is to drop multiple removed tests from a `unitizer`. ## Test Navigation ### Selecting A Test to Review `unitize` will present to you all the tests that require review, but if you wish to review a specific test you can use the `P` (for Previous) and `B` (for Browse) commands. These commands can come in handy if you realize that you incorrectly accepted or rejected an earlier test, but do not wish to quit `unitizer` completely and lose all the other properly reviewed tests. `P` just steps you back to the previous test. `B` gives you the option to go back to any previously reviewed test. `P` is trivially straightforward, so we will not discuss it further. We will type `B` at the prompt of our second failed test to examine what it does: ``` unitizer> B *1. library(unitizer.fastlm) . . . . . . . . . . . . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . Failed:N 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:- 6. get_rsq(res) . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- What test do you wish to review (input a test number, [U]nreviewed)? unitizer> ``` The `[B]rowse` option produces a list of all the tests in the order in which they appear in the test file. You can type the number of a test to review it, or U to go to the first test that hasn't been reviewed (more on this in a minute). We will examine the line for test #5 in more detail: ``` 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:- ^ ^ ^ ^ | | | | | +-- Deparsed test expression Test status ----+ | | | +- Test ID User Input -+ ``` The value and order of the test IDs shouldn't mean anything to you other than being the number to type in if you wish to review that test. Tests that have a `*` to the left of the test id are expessions that are not reviewed or checked by `unitizer` (we call these [ignored tests](u2_tests.html#what-constitutes-a-test)). The test status (see [tests outcomes](u2_tests.html#test-outcomes)) indicates the outcome of comparison of the reference test in the `unitizer` store to the newly evaluated ones. The first four tests are ignored tests, so they do not have a status. The User Input column marks which tests have been reviewed and what the user decision was. In this case we had reviewed test #2 and decided not to keep it (hence the "N"). Typically neither ignored tests nor passed tests require user input so they will typically have a "-" as the user input, as will tests that would be reviewed, but haven't been yet. Typing `U` at the review prompt will take you to the first unreviewed test. Since ignored tests and passed tests are not typically reviewed, `U` will take you to the first unreviewed test that is neither passed nor ignored. If we type 4 at the prompt, we get: ``` You are re-reviewing a test; previous selection was: "N" # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res unitizer test fails on value mismatch: *value* mismatch: mean relative difference: 19854602162 @@ .ref @@ - intercept slope rsq - -1717.000000 101.000000 0.938679 attr(,"class") [1] "fastlm" @@ .new @@ + intercept slope rsq + -3.541306e+13 7.012486e+11 9.386790e-01 attr(,"class") [1] "fastlm" unitizer> ``` `unitizer` tells us we are re-reviewing this test and that previously we had chosen not to keep the new version. At this point we could re-examine the test, and potentially change our previous selection. `unitizer` also re-displays any comments that were in the source file either ahead of the test or on the same line as the test. We used this feature to document the demo. You can jump ahead to any test from the review menu, even tests that are typically not reviewed (i.e. ignored or passed, though if you go to those you will be brought back to the review menu once you complete the review because those tests are not part of the normal review flow). If you skip ahead some tests and then get to the end of the review cycle `unitizer` will warn you about unreviewed tests. ### Finalizing `unitizer` Let's accept the 5th test, which brings us to this prompt: ``` unitizer> Y = Finalize Unitizer ============================================================ You will IRREVERSIBLY modify 'tests/unitizer/fastlm1.unitizer' by: - Replacing 1 out of 2 failed tests Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> ``` In this case we were reviewing a `unitizer` with two failed tests, one of which we chose to update with the newer value. `unitizer` will summarize for you all the changes that it is about to make to the `unitizer` store. If you type `Y` at the prompt, the existing `unitizer` store will be overwritten with the new version you just reviewed. If you are unsure about the changes you just approved for the `unitizer`, you can re-review them with `R` or `B`. You can also quit without saving your changes by typing `N`, but once you do so you will no longer be able to recover your changes. ### Quitting `unitizer` At any point you may quit `unitizer` by typing `Q` at the `unitizer` prompt. If you have already reviewed tests, you will be given the opportunity to save what you have done so far as you would when finalizing the `unitizer`. Note that if you chose to quit `unitizer` may exit without giving you the opportunity to review the tests. This will happen if: * You did not make any changes to the `unitizer` (e.g. if you chose `N` at failed tests, you are keeping the reference value, so the `unitizer` is not actually changing). * And test evaluation took less than `getOption("unitizer.prompt.b4.quit.time")` seconds (currently 10 seconds). If you end up in the R debugger from a `unitizer` (e.g. via `debug` or `recover`), quitting the debugger with "Q" will force-exit you from the session without a chance to save any changes. ### Differences in `review` Mode `review` works exactly like `unitize`, except that passed tests are automatically queued up for review, and that the only test statuses you should see are "Passed" or "-", the latter for ignored tests. ## Evaluating Expressions at the `unitizer` Prompt ### As Compared To The Standard R Prompt The `unitizer` prompt is designed to emulate the standard R prompt. For the most part you can type any expression that you would type at the R prompt and get the same result as you would there. This means you can examine the objects created by your test script, run R computations, etc. There are, however, some subtle differences created by the structure of the evaluation environments `unitizer` uses: * Even though you can see objects produced by tests, you can not actually remove them with `rm`. * Any objects you create at the interactive prompt are only available for the test you are currently reviewing, so do not expect them to still be there at subsequent prompts. * All expressions are evaluated with `options(warn=1)` or greater. * Other subtle issues discussed at length in the [Reproducible Tests Vignette](u4_reproducible-tests.html#test-environments). * There are special `unitizer` objects `.new`, `.NEW`, `.ref`, and `.REF` that let you review the results of tests (we will discuss these next). * `ls` and `traceback`/`.traceback` are masked by special `unitizer` versions (we will also discuss this next); you can use `base::ls`/`base::traceback` if you need the originals. * You will have access to any objects created through the `pre` argument to `unitize`, though they will not show up in a call to `ls`. ### `.new` and `.ref` As we saw in the demo there are special objects available at the prompt: `.new` (except for removed/deleted tests), and for all but new tests, `.ref`. These objects contain the values produced by the newly evaluated test (`.new`) and by the test when it was previously run and accepted (`.ref`). `.new` might seem a bit superfluous since the user can always re-evaluate the test expression at the `unitizer` prompt to review the value, but if that evaluation is slow you can save a little time by using `.new`. `.ref` is the only option you have to see what the test used to produce back when it was first accepted into the `unitizer` store. `.new` and `.ref` contain the values produced by the tests, but sometimes it is useful to access other aspects of the test evaluation. To do so you can use `.NEW` and `.REF`: * `.NEW` prints general information about the test. * `.NEW$value` returns the test value; equivalent to typing `.new` at the prompt. * `.NEW$conditions` returns the list of conditions produced by the test. * `.NEW$messsage` returns the stderr captured during test evaluation. * `.NEW$output` returns the screen output captured during test evaluation (note often this will be similar to what you get from `.new` or `.NEW$value` since typing those expressions at the prompt leads to the value being printed). * `.NEW$call` returns the test expression. * `.NEW$aborted` returns whether the test expression invoked an "abort" restart (e.g. called `stop` at some point). You can substitute `.REF` for `.NEW` in any of the above, provided that `.REF` is defined (i.e. that will not work when you are reviewing new tests since there is no corresponding reference test for those by definition). If both `.NEW` and `.REF` are defined, then `.DIFF` will be defined too. `.DIFF` has the same structure as `.NEW` and it contains the result of evaluating `diffobj::diffObj` between each component of `.NEW` and `.REF`. `.diff` is shorthand for `.DIFF$value`. If there are state differences (e.g. search path) you will be able to view those with `.DIFF$state`. ### `ls` Using `ls` at the `unitizer` prompt calls an `unitizer` version of the function (you can call the original with `base::ls()`). This is what happens when we type `ls()` at the first failed test in the `unitizer` we've been reviewing in this vignette: ``` $`objects in new test env:` [1] "res" "x" "y" $`objects in ref test env:` [1] "res" "x" "y" $`unitizer objects:` [1] ".new" ".NEW" ".ref" ".REF" Use `ref(.)` to access objects in ref test env `.new` / `.ref` for test value, `.NEW` / `.REF` for details. unitizer> ``` This special version of `ls` highlights that our environment is more complex than that at the typical R prompt. This is necessary to allow us to review both the newly evaluated objects as well as the objects from the reference `unitizer` store to compare them for differences. For instance, in this example, we can see that there are both new and reference copies of the `res`, `x`, and `y` objects. The reference copies are from the previous time we ran `unitizer`. `ls` also notes what `unitizer` special objects are available. When you type at the prompt the name of one of the objects `ls` lists, you will see the newly evaluated version of that variable. If you wish to see the reference value, then use the `ref` function: ``` unitizer> res intercept slope rsq -3.541306e+13 7.012486e+11 9.386790e-01 attr(,"class") [1] "fastlm" unitizer> ref(res) intercept slope rsq -1717.000000 101.000000 0.938679 attr(,"class") [1] "fastlm" ``` Note that at times when you use `ls` at the `unitizer` promopt you may see something along the lines of: ``` $`objects in ref test env:` [1] "res" "x*" "y'" ``` where object names have symbols such as `*` or `'` appended to them. This happens because `unitizer` does not store the entire environment structure of the reference tests. Here is a description of the possible situations you can run into: * `*` Object existed during reference test evaluation, but is no longer available * `'` Object existed during reference test evaluation, and still does, but it has a different value than it did during reference test evaluation * `**` Object exists now, but did not exist during reference test evaluation For more discussion see `?"healEnvs,unitizerItems,unitizer-method"` and the discussion of [Patchwork Reference Environments](u4_reproducible-tests.html#patchwork-reference-environments). Objects assigned right before a test are part of that test's environment so will always be available. ## `traceback` / `.traceback` Errors that occur during test evaluation are handled, so they do not register in the normal R traceback mechanism. `unitizer` stores the traces from the test evaluation and makes them available via internal versions of `traceback`/`.traceback` that mask the base ones at the interactive `unitizer` prompt. They behave similarly but not identically to the `base` counterparts. In particular, parameter `x` must be NULL. You can access the `base` versions with e.g. `base::traceback`, but those will not display any tracebacks generated by `unitizer`-evaluated code. ## `unitize_dir` `unitize_dir` adds a layer of navigation. Here is what you see after running it on the demo package directory test directory: ``` > (.unitizer.fastlm <- copy_fastlm_to_tmpdir()) # package directory > unitize_dir(.unitizer.fastlm) Inferred test directory location: private/var/folders/56/qcx6p6f94695mh7yw- q9m6z_80000gq/T/RtmpJO7kjd/file43ac57df6164/unitizer.fastlm/tests/unitizer Summary of files in common directory 'tests/unitizer': Pass Fail New *1. fastlm1.R - - 4 *2. fastlm2.R - - 1 *3. unitizer.fastlm.R - - 3 ..................................... - - 8 Legend: * `unitizer` requires review Type number of unitizer to review, 'A' to review all that require review unitizer> ``` Each listing corresponds to a test file. If you were to type `1` at the prompt then you would see the equivalent of the `unitize` process in the demo, since "fastlm1.R" is the file we `unitize` in the demo. The `*` ahead of each file indicates that the file has tests that require review. In this case, all the files have new tests. After we type `1` and go through the `unitize` process for "fastlm1.R" we are returned to the `unitize_dir` prompt: ``` unitizer updated Summary of files in common directory 'tests/unitizer': Pass Fail New $1. fastlm1.R ? ? ? *2. fastlm2.R - - 1 *3. unitizer.fastlm.R - - 3 ..................................... ? ? ? Legend: * `unitizer` requires review $ `unitizer` has been updated and needs to be re-evaluted to recompute summary Type number of unitizer to review, 'A' to review all that require review, 'R' to re-run all updated unitizer> ``` Because we updated "fastlm.R", the statistics `unitize_dir` collected when it first ran all the tests are out of date, which is why they show up as question marks. The `$` also indicates that "fastlm1.R" stats are out of date. There is nothing wrong with this, and you do not need to do anything about it, but if you want you can re-run any unitizers that need to be updated by typing "R" at the prompt. This is what happens if we do so: ``` unitizer> R Summary of files in common directory 'tests/unitizer': Pass Fail New 1. fastlm1.R 4 - - *2. fastlm2.R - - 1 *3. unitizer.fastlm.R - - 3 ..................................... 4 - 4 * `unitizer` requires review Type number of unitizer to review, 'A' to review all that require review unitizer> ``` You can now see that we added all the tests, and upon re-running, they all passed since the source code for `unitizer.fastlm` has not changed. Notice how there is no `*` ahead of the first test anymore. Another option for reviewing tests is to type "A" at the prompt, which would cause `unitize_dir` to put you through each test file that requires review in sequence. unitizer/vignettes/u0_unitizer_index.Rmd0000644000176200001440000000257314766101222020253 0ustar liggesusers--- title: "unitizeR - Summary of Vignettes" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{0 - Contents} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- * [Introduction](u1_intro.html) * Quickstart * Comparison to `testthat` * Things to know about `unitizer` * [Test details](u2_tests.html) * What expressions are considered tests * Modify how new tests are compared (default: `all.equal`) * Organize your tests into sections * Track other aspects of test evaluation beyond just value * [Interactive Environment](u3_interactive-env.html) * `unitizer` commands * Navigating `unitizer`s * A guide to test objects * `unitize_dir` * [Reproducible Tests](u4_reproducible-tests.html) * Reviews how `unitizer` tracks and manages different aspects of session state to insulate tests from variability in a user session * Details on evaluation environments, and potential pitfalls * [Miscellaneous](u5_miscellaneous.html) * How unitizers are stored, and possible alternatives * Version control and `unitizer` * How to modify an existing `unitizer` * Troubleshooting * Other issues * Why you cannot run `unitizer` inside `try`/`tryCatch` blocks * Functions that are overriden at the `unitizer` prompt unitizer/vignettes/rmdhunks/0000755000176200001440000000000014766101222015767 5ustar liggesusersunitizer/vignettes/rmdhunks/usage.Rmd0000644000176200001440000000151114766101222017535 0ustar liggesusers## Usage `unitizer` stores R expressions and the result of evaluating them so that it can detect code regressions. This is akin to saving test output to a `.Rout.save` file as documented in [Writing R Extensions](https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Package-subdirectories), except that we're storing the actual R objects and it is much easier to review them. To use `unitizer`: * Write test expressions as you would when informally testing code on the command line, and save them to a file (e.g. "my_file_name.R"). * Run `unitize("my_file_name.R")` and follow the prompts. * Continue developing your package. * Re-run `unitize("my_file_name.R")`; if any tests fail you will be able to review and debug them in an interactive prompt. `unitizer` can run in a non-interactive mode for use with `R CMD check`. unitizer/vignettes/rmdhunks/intro.Rmd0000644000176200001440000000442014766101222017566 0ustar liggesusers## TL;DR `unitizer` simplifies creation, review, and debugging of tests in R. It automatically stores R expressions and the values they produce, so explicit expectations are unnecessary. Every test is easy to write with `unitizer` because testing and using a function are the same. This encourages non-trivial tests that better represent actual usage. Tests fail when the value associated with an expression changes. In interactive mode you are dropped directly into the failing test environment so you may debug it. `unitizer` is on CRAN: ```{r eval=FALSE} install.packages('unitizer') ``` It bakes in a lot of contextual help so you can get started without reading all the documentation. Try the demo to get an idea: ```{r eval=FALSE} library(unitizer) demo(unitizer) ``` Or check out the [screencast](http://htmlpreview.github.io/?https://github.com/brodieG/unitizer/blob/rc/extra/gifshow.html) to see `unitizer` in action. ## Why Another Testing Framework? ### Automated Test Formalization Are you tired of the `deparse`/`dput` then copy-paste R objects into test file dance, or do you use `testthat::expect_equal_to_reference` or other snapshot testing a lot? With `unitizer` you interactively review your code as you would when typing it at the R prompt. Then, with a single keystroke, you tell `unitizer` to store the code, and any values, warnings, or errors it produced, thereby creating a formal regression test. ### Streamlined Debugging Do you wish the nature of a test failure was more immediately obvious? When tests fail, you are shown a proper [diff](https://github.com/brodieG/diffobj) so you can clearly identify _how_ the test failed: ![diff example](https://github.com/brodieG/unitizer/raw/rc/extra/gif/review1.png) Do you wish that you could start debugging your failed tests without additional set-up work? `unitizer` drops you in the test environment so you can debug _why_ the test failed without further ado: ![review example](https://github.com/brodieG/unitizer/raw/rc/extra/gif/review2.png) ### Fast Test Updates Do you avoid improvements to your functions because that would require painstakingly updating many tests? The diffs for the failed tests let you immediately confirm only what you intended changed. Then you can update each test with a single keystroke. unitizer/vignettes/styles.css0000644000176200001440000000776414766101222016207 0ustar liggesusers/* Styles primarily borrowed from rmarkdown/templates/html_vignette/resources/vignette.css at a time 12/2/2014 when rmarkdown was (and probably still is) under the GPL-3 license */ body { background-color: #fff; margin: 1em auto; max-width: 700px; overflow: visible; padding-left: 2em; padding-right: 2em; font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; font-size: 14px; line-height: 1.5; } #header { text-align: center; } #TOC { clear: both; /*margin: 0 0 10px 10px;*/ padding: 4px; width: 100%; border: 1px solid #CCCCCC; border-radius: 5px; background-color: #f6f6f6; font-size: 13px; line-height: 1.3; } #TOC .toctitle { font-weight: bold; font-size: 15px; margin-left: 5px; } #TOC ul { padding-left: 40px; margin-left: -1.5em; margin-top: 5px; margin-bottom: 5px; } #TOC ul ul { margin-left: -2em; } #TOC li { line-height: 16px; } table { margin: 1em auto; border-width: 1px; border-color: #DDDDDD; border-style: outset; border-collapse: collapse; } table th { border-width: 2px; padding: 5px; border-style: inset; } table td { border-width: 1px; border-style: inset; line-height: 18px; padding: 5px 5px; } table, table th, table td { border-left-style: none; border-right-style: none; } table thead, table tr.even { background-color: #f7f7f7; } p { margin: 1em 0; } blockquote { background-color: #f6f6f6; padding: 0.25em 0.75em; } hr { border-style: solid; border: none; border-top: 1px solid #777; margin: 28px 0; } dl { margin-left: 0; } dl dd { margin-bottom: 13px; margin-left: 13px; } dl dt { font-weight: bold; } ul { margin-top: 0; } ul li { list-style: circle outside; } ul ul { margin-bottom: 0; } pre, code { background-color: #eee; border-radius: 3px; color: #333; } pre { white-space: pre-wrap; /* Wrap long lines */ border-radius: 3px; margin: 5px 0px; padding: 10px; font-size: 85%; } pre:not([class]) { background-color: #eee; } code { font-family: Consolas, Monaco, 'Courier New', monospace; } p > code, li > code, h1 > code, h2 > code, h3 > code, h4 > code, h5 > code, h6 > code { padding: 2px 0px; line-height: 1; font-weight: bold; } div.figure { text-align: center; } img { background-color: #FFFFFF; padding: 2px; border: 1px solid #DDDDDD; border-radius: 3px; border: 1px solid #CCCCCC; margin: 0 5px; } h1 { margin-top: 0; padding-bottom: 3px; font-size: 35px; line-height: 40px; border-bottom: 1px solid #999; } h2 { border-bottom: 1px solid #999; padding-top: 5px; padding-bottom: 2px; font-size: 145%; } h3 { padding-top: 5px; font-size: 120%; } h4 { /*border-bottom: 1px solid #f7f7f7;*/ color: #777; font-size: 105%; } h4.author, h4.date {display: none;} h5, h6 { /*border-bottom: 1px solid #ccc;*/ font-size: 105%; } a { color: #2255dd; font-weight: bold; text-decoration: none; } a:hover { color: #6666ff; } a:visited { color: #800080; } a:visited:hover { color: #BB00BB; } a[href^="http:"] { text-decoration: underline; } a[href^="https:"] { text-decoration: underline; } /* Class described in https://benjeffrey.com/posts/pandoc-syntax-highlighting-css Colours from https://gist.github.com/robsimmons/1172277 */ code > span.kw { color: #555; font-weight: bold; } /* Keyword */ code > span.dt { color: #902000; } /* DataType */ code > span.dv { color: #40a070; } /* DecVal (decimal values) */ code > span.bn { color: #d14; } /* BaseN */ code > span.fl { color: #d14; } /* Float */ code > span.ch { color: #d14; } /* Char */ code > span.st { color: #d14; } /* String */ code > span.co { color: #888888; font-style: italic; } /* Comment */ code > span.ot { color: #007020; } /* OtherToken */ code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ code > span.fu { color: #900; font-weight: bold; } /* Function calls */ code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */ unitizer/vignettes/.install_extras0000644000176200001440000000003014766101222017162 0ustar liggesusersrmdhunks/?$ styles\.css unitizer/vignettes/u4_reproducible-tests.Rmd0000644000176200001440000003750114766101222021035 0ustar liggesusers--- title: "unitizeR - Reproducible Tests" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{4 - Reproducible Tests} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Managing State ### Reproducibility R's emphasis on avoiding side effects generally means that if you run the same R code more than once you can be relatively certain that you will get the same result each time. While this is generally true, there are some exceptions. If you evaluate: ``` x <- x + 5 ``` on the command line, the result will depend on what the value of `x` was in the workspace prior to evaluation. Since workspaces are littered with objects from day to day R use tests are better run elsewhere to avoid conflicts with those objects. There are even more subtle factors that can affect test evaluation. For example, if `x` is an S3 object, the packages loaded on the search path could affect the result of the command. Global options could also affect the outcome. Here is a non-exhaustive list of aspects of state that might affect test outcomes: 1. Workspace / Evaluation Environment. 1. Random seed. 1. Working directory. 1. Search path. 1. Global options. 1. Loaded namespaces. 1. System time. 1. System variables. 1. Locale. 1. etc. Ideally a unit testing framework would nullify these environmental factors such that the only changes in test evaluation are caused by changes in the code that is being tested. `unitizer` provides functionality that sets session state to known "clean" values ahead of the evaluation of each test. Currently `unitizer` attempts to manage the first six aspects of state listed above. **In order to comply with CRAN policies state management is turned off by default.** ### Batch Evaluation and Deferred Review `unitizer` batch processes all the tests when it is first run before it breaks into interactive mode. It does this to: 1. Display useful summary data (how many tests passed/failed in which sections), which is often helpful to know before beginning to debug. 2. Allow time consuming process to run unattended so that the interactive test review process is not interrupted by slow tests. The batch-evaluate-and-review-later creates the need for a mechanism to recreate state for when we review the tests. Imagine trying to figure out why a test failed when all the variables may have been changed by subsequent tests. `unitizer` will always recreate the state of the variables defined by the test scripts, and can optionally recreate other aspects of state provided that is enabled. ### Enabling State Management You can turn on the "suggested" state management level to manage the first four elements of state listed in the previous section. To do so, use `unitize(..., state='suggested')` or `options(unitizer.state='suggested')`. Be sure to read `?unitizerState` before you enable this setting as there are cases when state management may not work. ## Workspace And Evaluation Environments ### Test Environments In order to allow review of each test in its original evaluation environment, each test is evaluated in a separate environment. Each of these environments has for parent the environment of the previous test. This means that a test has access to all the objects created/used by earlier tests, but not objects created/used by subsequent tests. When a later test "modifies" an existing object, the existing object is not really modified; rather, the test creates a new object of the same name in the child environment which masks the object in the earlier test. This is functionally equivalent to overwriting the object as far as the later test is concerned. For the most part this environment trickery should be transparent to the user. An exception is the masking of `ls` and `traceback` with versions that account for the special nature of the `unitizer` REPL. Another is that you can not remove an object created in an earlier test with `rm` (well, it is possible, but the how isn't documented and you are advised not to attempt it). Here is a more complex exception: a <- function() b() NULL # Prevent `a` and `b` being part of the same test b <- function() TRUE a() In this case, when we evaluate `a()` we must step back two environments to find `a`, but that's okay. The problem is that once inside `a`, we must now evaluate `b()`, but `b` is defined in a child environment, not a parent environment so R's object lookup fails. If we remove the NULL this would work, but only because neither the `a` or `b` assignments are tests, so both `a` and `b` would be assigned to the environment of the `a()` call (see [details on tests vignette](u2_tests.html)). If you are getting weird "object not found" errors when you run your tests, but the same code does not generate those errors when run directly in the command line, this illusion could be failing you. In those situations, make sure that you assign all the variables necessary right ahead of the test so they will all get stored in the same environment. ### The Parent Environment In the "suggested" state tracking mode `unitize` will run tests in an environment that has the same parent as `.GlobalEnv` (`UnitizerEnv` below): ``` .GlobalEnv \ +--> package:x --> ... --> Base / TestEnv --> UnitizerEnv ``` This means that objects in the global environment / workspace will not affect your tests. Unfortunately implementing this structure is not trivial because we need to ensure `UnitizerEnv` stays pointed at the environment just below `.GlobalEnv` even as tests modify the search path by calling `library`/`attach`/`detach`, etc. To achieve this `unitizer` traces `base::library`, `base::attach`, and `base::detach` **when state tracking is enabled** and **only when `unitizer` is running**. Any time any of those functions is called, `unitizer` updates the parent of `UnitizerEnv` to be the second environment on the search path (i.e. the parent of `.GlobalEnv`). So, for example, if a test calls `library(z)`, the new search path would look like so: ``` .GlobalEnv \ +--> package:y --> package:x --> ... --> Base / TestEnv --> UnitizerEnv ``` Clearly overriding such fundamental functions such as `library` / `attach` / `detach` is not good form. We recognize this, and try to do the overriding in as lightweight a manner as possible by tracing them only to record the search path while `unitizer` is evaluating. This should be completely transparent to the user. The untracing is registered to the `on.exit` of `unitize` so the functions should get untraced even if `unitize` fails. Aside from the issues raised above, this method is not completely robust. Any tests that turn tracing off using `tracingState`, or themselves `trace`/`untrace` any of `library` / `attach` / `detach` will interfere with `unitizer`. If you must do any of the above you should consider specifying a parent environment for your tests through the `state` parameter to `unitize` (see `?unitize`). Some functions that expect to find `.GlobalEnv` on the search path may not work as expected. For example, `setClass` uses `topenv` by default to find an environment to define classes in. When `setClass` is called at the top level, this normally results in the class being defined in `.GlobalEnv`, but if `.GlobalEnv` is not available `setClass` will attempt to define the class in the first environment on the search path, which will likely be a locked namespace. You can work around this by specifying an environment in calls to `setClass`. ### Package Namespace as Parent Environment Sometimes it is convenient to use the namespace of a package as the parent environment. This allows you to write tests that use internal package functions without having to resort to `:::`. You can set the parent evaluation environment with the `state` argument to `unitize` / `unitize_dir`. See `?unitize` and `?unitizeState`. If you do use this feature keep in mind that your tests will be directly exposed to the global environment as well since R looks through the search path starting at the global environment after looking in the package namespace and imports (your package code is always exposed to this). ### Issues With Reference Objects For the most part R is a copy-on-modify language, which allows us to employ the trickery described above. There are however "reference" objects that are not copied when they are modified. Notable examples include environments, reference classes, and `data.table`. Since our trickery requires us to keep copies of each object in different environments as they are modified, it does not work with reference objects since they are not automatically duplicated. The main consequence of this is that when you are reviewing a test that involves a reference object, the value of that reference object during review will be the value after the last reference modification, which may have been made after the test you are reviewing. The tests will still work as they should, passing if you did not introduce regressions, and failing otherwise. However if you review a failed test you may have a hard time making sense of what happened since the objects you review will may not have the values they had when the test was actually run. ### Patchwork Reference Environments When we review `unitizer` tests, it is possible to end up in a situation where we wish to update our store by keeping a mix of the new tests as well as some of the old ones. This leads to some complications because in order to faithfully reproduce the environments associated with both the reference and the new tests we would potentially have to store the entire set of environments produced by the test script for both the new and reference tests. Even worse, if we re-run `unitizer` again, we run the risk of having to store yet another set of environments (the old reference environments, what were new environments but became reference ones on this additional run, and the new environments created by this third run). The problem continues to grow with as each incremental run of the `unitizer` script potentially creates the need to store yet another set of environments. As a work-around to this problem `unitizer` only keeps the environment associated with the actual reference tests you chose to keep (e.g. when you type `N` at the `unitizer` prompt when reviewing a failed test). `unitizer` then grafts that test and its environment to the environment chain from the newly evaluated tests (note that for all tests that pass, we keep the new version of the tests, not the reference one). This means that in future `unitizer` runs where you examine this same reference test, the other "reference" objects available for inspection may not be from the same evaluation that produced the test. The `ls` command will highlight which objects are from the same evaluation vs which ones are not (see the [discussion on `ls`](u3_interactive-env.html#ls)). This is not an ideal outcome, but the compromise was necessary to avoid the possibility of ever increasing `unitizer` stores. For more details see `?"healEnvs,unitizerItems,unitizer-method"`. ## Clean Search Paths ### Description / Implementation One other way tests can change behavior unexpectedly is if the packages / objects attached to the search path change. A simple example is a test script that relies on package "X", and the user attached that package at some point during interactive use, but forgot to add the requisite `library` call to the test script itself. During testing, the scripts will work fine, but at some future date if the test scripts are run again they are likely to fail due to the dependency on the package that is not explicitly loaded in the test scripts. In the "suggested" state tracking mode `unitizer` runs on a "trimmed" search path that contains only the packages loaded by in a freshly loaded R session (i.e. the packages between `package:base` and `package:stats`; see `?unitizerState`). You will need to explicitly load packages that your tests depend on in your test file (e.g. by using `library()`). `unitize` will restore the search path to its original state once you complete review. `unitizer` also relies on tracing `library`/`attach`/`detach` to implement this feature, so the caveats described [above](#The-Parent-Environment) apply equally here. `unitizer` **does not modify the search path itself** other than by using `library`, `attach`, and `detach`. When search path tracking is enabled, `unitizer` tracks the versions of the packages on the search path. If tests fails and package versions on the search path have changes since the reference test was stored, you will be alerted. ### Potential Issues When `unitizer` manipulates the search path it restores the original one by using `library`/`attach` on any previously detached objects or packages. This generally works fine, but detaching and re-attaching packages is not and cannot be the same as loading a package or attaching an environment for the first time. For example, S3 method registration is not undone when detaching a package, or even unloading its namespace. See discussion in `?detach` and in `?unitizerState`. One known problem is the use of `devtools::load_all` and similar which place a pretend package environment on the search path. Such packages cannot be re-loaded with `library` so the re-attach process will fail (see [#252](https://github.com/brodieG/unitizer/issues/252)). Another issue is attached environments that contain references to themselves, as the `tools:rstudio` environment attached by `Rstudio` does. It contains functions that have for environment the `tools:rstudio` environment. The problem is that once that environment is detached from the search path, those functions no longer have access to the search path. Re-attaching the environment to the search path does not solve the problem because `attach` attaches a _copy_ of the environment, not the environment itself. This new environment will contain the same objects as the original environment, but all the functions therein will have for environment the original detached environment, not the copy that is attached to the search path. For the specific `tools::rstudio` problem we work around the issue by keeping it on the search path even search path tracking is enabled (you can over-ride this by changing `search.path.keep`, or, if you have environments on your search path with similar properties, add their names to `search.path.keep`). Other options include re-attaching with `parent.env<-` instead of `attach`, but messing with the search path in that way seems to be exactly what R core warns about in `?parent.env`: > The replacement function parent.env<- is extremely dangerous as it can be used to destructively change environments in ways that violate assumptions made by the internal C code. It may be removed in the near future. ## Global Options `unitizer` can track and reset global options. Because many packages set options when their namespaces are attached, implementation of this feature must be coordinated with a careful management of loaded namespaces. For example, we can reasonably easily set options to be what you would expect in a freshly loaded vanilla R session, but if some namespaces as otherwise they would be in a compromised set with their options wiped out. `unitizer` can manage search paths and namespaces, but unfortunately some package namespaces cannot be unloaded so options management can be problematic when such packages are involved (one example is `data.table`). Because of this options management is not enabled in the "suggested" state management mode. Note that no matter what tests are always run with `options(warn=1)` and `options(error=NULL)`. See `?unitizer.opts` for more details. ## Random Seed See `?unitizerState`. ## Working Directory See `?unitizerState`. unitizer/vignettes/u2_tests.Rmd0000644000176200001440000003221414766101222016352 0ustar liggesusers--- title: "unitizeR - Test Details" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{2 - Test Details} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Understanding Tests ### Test Outcomes When `unitize` is run with a test file against an existing `unitizer` store, each test in the file is matched and compared to the corresponding test in the store. Here is a comprehensive list of possible outcomes: * **New**: a test present in the file is not in the store and needs to be reviewed to confirm it is correct. * **Passed**: the test matched the reference test in the store and need not be reviewed. * **Failed**: the evaluation of the test from the file differs from the one produced by same expression in the store. * **Deleted/Removed**: a test present in the `unitizer` store no longer exists in the test file so you will be prompted to remove it from the store. * **Corrupted/Error**: an error occurred while attempting to compare the file and store tests; this should occur very rarely and is likely the result of using a custom comparison function to compare the tests (see [`unitizer_sect`](#controlling-test-comparison) for more details on custom comparison functions). Because the comparison function itself failed, `unitizer` has no way of knowing whether the test passed or failed; you can think of it as an `NA` outcome. When reviewing tests, `unitizer` will group tests by test type, so you will review all new tests in one go, then the failed tests, and so on. As a result, the order that you review tests may not be the same as the order they appear in in the test file. ### What Constitutes a Test? As noted previously simple assignments are not considered tests. They are stored in the `unitizer` store, but you are not asked to review them, and their values are not compared to existing reference values prior to storage. The implicit assumption is that if there is an assignment the intent is to use the resulting object in some later test at which point any issues will crop up. Skipping assignment review saves some unnecessary user interaction. You can force assignments to become tests by wrapping them in parentheses: ``` a <- my_fun(25) # this is not a test (a <- my_fun(42)) # this is a test ``` The actual rule `unitizer` uses to decide whether an expression is a test or not is whether it returns invisibly without signalling conditions. Wrapping parentheses around an expression that returns invisibly makes it visible, which is why assignments in parentheses become tests. Conversely, you can wrap an expression in `invisible(...)` to prevent it from being treated as a test so long as it does not signal conditions. Recall that newly evaluated tests are matched to reference tests by deparsing the test expression. Some expressions such as strings with non-ASCII bytes (even in their escaped form) or numbers with long decimal tails will deparse differently on different systems, and thus may cause tests to fail to match. You can still use these by storing them in a variable, as the assignment step is not a test: ``` chr <- "hello\u044F" # this is not a test fun_to_test(chr) # this is a test ``` ### `unitizer` Test Components The following aspects of a unitizer tests are recorded for future comparison: * Value. * Conditions. * Screen (stdout) output. * Message (stderr) output. * Whether the expression issued an "abort" `invokeRestart` (e.g. was `stop` called in the expression). Currently only the first two elements are actually compared when determining whether a test passes or fails. These two should capture almost all you would care about from a unit test perspective. Screen output is omitted from comparison because it can be caused to vary substantially by factors unrelated to source code changes (e.g. console display width). Screen output will also seem identical to the value as most of the time screen output is just the result of printing the return value of an expression. This will not be the case if the expression itself prints to `stdout` explicitly, or if the function returns invisibly. Message output is omitted because all typical mechanisms for producing `stderr` output also produce conditions with messages embedded, so it is usually superfluous to compare them. One exception would be if an expression `cat`ed to `stderr` directly. The "abort" `invokeRestart` is omitted because it generally is implied by the presence of an error condition and actively monitoring it clutters the diagnostic messaging produced by `unitizer`. It exists because it is possible to signal a "stop" condition without actually triggering the "abort" restart so in some cases it could come in handy. While we omit the last three components from comparison, this is just default behavior. You can change this by using the `compare` argument for [`unitizer_sect`](#controlling-test-comparison). ## Sections ### `untizer_sect` Often it is useful to group tests in sections for the sake of documentation and clarity. Here is a slghtly modified version of the original demo file with sections: ``` unitizer_sect("Basic Tests", { library(unitizer.fastlm) x <- 1:10 y <- x ^ 3 res <- fastlm(x, y) get_slope(res) }) unitizer_sect("Advanced Tests", { 2 * get_slope(res) + get_intercept(res) get_rsq(res) }) ``` Now re-running `unitizer` segments everything by section (note, first few lines are set-up): ``` (.unitizer.fastlm <- copy_fastlm_to_tmpdir()) update_fastlm(.unitizer.fastlm, version="0.1.2") install.packages(.unitizer.fastlm, repos=NULL, type='src', quiet=TRUE) unitize(file.path(.unitizer.fastlm, "tests", "unitizer", "unitizer.fastlm.R")) +------------------------------------------------------------------------------+ | unitizer for: tests/unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New 1. Basic Tests - - 1 2. Advanced Tests - - 2 .................................. - - 3 ``` If there are tests that require reviewing, each section will be reviewed in turn. Note that `unitizer_sect` does not create separate evaluation environments for each section. Any created object will be available to all lexically subsequent tests, regardless of whether they are in the same section or not. Additionally `on.exit` expressions in `unitizer_sect` are evaluated immediately, not on exit. It is possible to have nested sections, though at this point in time `unitizer` only explicitly reports information at the outermost section level. ### Controlling Test Comparison By default tested components (values and conditions) are compared with `all.eq`, a wrapper around `all.equal` that returns FALSE on inequality instead of a character description of the inequality. If you want to override the function used for value comparisons it is as simple as creating a new section for the tests you want to compare differently and use the `compare` argument: ``` unitizer_sect("Accessor Functions", compare=identical, { get_slope(res) get_rsq(res) get_intercept(res) } ) ``` The values produced by these three tests will be compared using `identical` instead of `all.eq`. If you want to modify how other components of the test are compared, then you can pass a `unitizerItemTestsFuns` object as the value to the `compare` argument instead of a function: ``` unitizer_sect("Accessor Functions", compare=unitizerItemTestsFuns( value=identical, output=all.equal, message=identical ), { get_slope(res) get_rsq(res) get_intercept(res) } ) ``` This will cause the value of tests to be compared with `identical`, the screen output with `all.equal`, and messages (stderr) with `identical`. If you want to change the comparison function for conditions, keep in mind that what you are comparing are `conditionList` objects so this is not straightforward (see `getMethod("all.equal", "conditionList")`). In the future we might expose a better interface for custom comparison functions for conditions (see issue #32). If you need to have different comparison functions within a section, use nested sections. While `unitizer` will only report the outermost section metrics in top-level summaries, the specified comparison functions will be used for each nested section. ## Special Semantics ### Almost Like `source` When `unitizer` runs the test expressions in a test file it does more than just evaluating each in sequence. As a result there are some slight differences in semantics relative to using `source`. We discuss the most obvious ones here. ### `on.exit` Each top-level statement statement, or top-level statement within a `unitizer_sect` (e.g. anything considered a test), is evaluated directly with `eval` in its own environment. This means any `on.exit` expressions will be executed when the top-level expression that defines them is done executing. For example, it is not possible to set an `on.exit(...)` for an entire `unitizer_sect()` block, although it is possible to set it for a single sub-expression: ``` unitizer_sect('on.exit example', { d <- c <- b <- 1 on.exit(b <- 2) b # == 2! { on.exit(d <- c <- 3) c # Still 1 } d # == 3 } ``` ### Evaluation Environments Each test is evaluated in its own environment, which has for enclosure the environment of the prior test. This means that a test has access to all the objects created/used by earlier tests, but not objects created/used by subsequent tests. See the [Reproducible Tests Vignette](u4_reproducible-tests.html#workspace-and-evaluation-environments) for more details. ### Options and Streams In order to properly capture output, `unitizer` will modify streams and options. In particular, it will do the following: * Temporarily set `options(warn=1L)` during expression evaluation. * Temporarily set `options(error=NULL)` during expression evaluation. * Use `sink()` to capture any output to `stdout`. * Use `sink(type="message")` to capture output to `stderr`. This should all be transparent to the user, unless the user is also attempting to modify these settings in the test expressions. The problematic interaction are around the `options` function. If the user sets `options(warn=1)` with the hopes that setting will persist beyond the execution of the test scripts, that will not happen. If the user sets `options(error=recover)` or some such in a test expression, and that expression throws an error, you will be thrown into recovery mode with no visibility of `stderr` or `stdout`, which will make for pretty challenging debugging. Similarly, `unitize`ing `debug`ged functions, or interactive functions, is unlikely to work well. You should be able to use `options(warn=2)` and `options(error=recover)` from the interactive `unitizer` prompt. If `unitize` is run with `sdtderr` or `stdout` sunk, then it will subvert the sink during test evaluation and reset it to the same sinks on exit. If a test expression sinks either stream, `unitizer` will stop capturing output from that point on until the end of the test file. At that point, it will attempt to reset the sinks to what they were when `unitizer` started. Sometimes this is not actually possible. If such a situation occurs, `unitizer` will release all sinks to try to avoid a situation where control is returned to the user with output streams still captured. To reduce the odds of storing massive and mostly useless `stdout`, `unitize` limits how much output is stored by default. If you exceed the limit you will be warned. You may modify this setting with `options("unitizer.max.capture.chars")`. ## Other Details ### Matching Tests Whenever you re-run `unitize` on a file that has already been `unitize`d, `unitizer` matches the expressions in that file to those stored in the corresponding `unitizer` store. `unitizer` matches only on the deparsed expression, and does not care at all where in the file the expression occurs. If multiple identical expressions exist in a file they will be matched in the order they show up. The `unitizer_sect` in which a test was when it was first `unitize`d has no bearing whatsoever on matching a new test to a reference test. For example, if a particular test was in "Section A" when it was first `unitize`d, but in the current version of the test file it is in "Section X", that test will be matched to the current one in "Section X". Some expressions may deparse differently on different systems or with different settings (e.g. numbers with decimal places, non-ASCII characters) so tests containing them may not match correctly across them. See the [Introductory Vignette](u1_intro.html#test-expressions-are-stored-deparsed) for how to avoid problems with this. ### Commenting Tests `unitizer` parses the comments in the test files and attaches them to the test that they document. Comments are attached to tests if they are on the same line as the test, or in the lines between a test and the previous test. Comments are displayed with the test expression during the interactive review mode. Comment parsing is done on a "best-efforts" basis; it may miss some comments, or even fail to work entirely. unitizer/vignettes/u5_miscellaneous.Rmd0000644000176200001440000002341014766101222020054 0ustar liggesusers--- title: "unitizeR - Miscellanea" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{5 - Miscellaneous Topics} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Storing `unitize`d Tests ### Default Mode is to Store Tests in `rds` Files `unitizer` stores unit tests and their results. By default, it stores them in `rds` files in your filesystem. You will be prompted before a file is saved to your filesystem. The `rds` file is placed in a directory with the same name as your test file, but with "unitizer" appended. For example, if your tests are in "my_file_name.R", then `unitizer` will create a folder called "my_file_name.unitizer/" and put an `rds` file in it. See `?get_unitizer` for potential alternatives to saving to your file system. ### File Space Considerations If your tests produce massive objects, the `unitizer` `rds` file will be massive. Try designing your tests so they will produce the smallest representative data structures needed for your tests to be useful. Additionally, note that the `rds` files are binary, which needs to be accounted for when using them in [version controlled projects](#version-control-and-unitizer). ### Backup Your `unitizer` Stores `unitizer` does not backup the `rds` beyond the single copy in the aforementioned folder. Unit tests are valuable, and without the `rds` file `unitizer` tests become a lot less useful. To the extent you backup your R test files, you should also backup the corresponding ".unitizer/" folder. You could lose / corrupt your `unitizer` store in many ways. Some non-exhaustive examples: - Standard file system SNAFU - Careless updates to existing `unitizer` - `unitizer` developer accidentally introduces a bug that destroys your `unitizer` Backup your `unitizer` stores! ### Alternate Store Locations `unitize` stores and loads `unitizer`s using the `set_unitizer` and `get_unitizer` S3 generics . This means you can implement your own S3 methods for those generics to store the `unitizer` object off-filesystem (e.g. MySQL databse, etc). See `?get_unitizer` for more details, though note this feature is untested. If you only wish to save your `unitizer` to a different location in your filesystem than the default, you do not need to resort to these methods as you can provide the target directory with `unitize(..., store.id=)`. ## Version Control and Unitizer ### Committing Binary Files The main issue with using `unitizer` with a version controlled package is that you have to decide whether you want to include the binary `rds` files in the version control history. Some options: * Do not track the binary files at all (but they are valuable and now not backed up). * Do not track the binary files at all, but implement a secondary back-up system (this sounds really annoying). * Use a backed-up, non-file system store (see "Alternate Store Locations" above). * Track the binary files, but manage how often they are committed. We recommend splitting tests for different functionality into different files. This should mitigate the number of rds files that change with any given source code update, and is good practice anyway. Additionally, we typically only commit the rds files when a feature branch or issue resolution is fully complete. Additionally a useful `git` shortcut to add to your `.gitconfig` file that mitigates how often you commit rds files is: ``` [alias] ad = !git add -u && git reset -- *.rds ``` This makes it easy to add all the files you are working on except for the rdses. Once you have stabilized a set of tests you can commit the rds. All this aside, remember that the rdses are ultimately just as important as the test files, and you **should** commit them occasionally to ensure you do not use valuable test information. ### Collaborating with Unitizer If you merge in a pull request from a third party you do not fully trust, we recommend that you do not accept any commits to the rdses. You can accept and review changes to test expressions, and then `unitize` against your existing rdses and review the corresponding values. ## Modifying an Existing Unitizer ### `review` `review` allows you to review all tests in a unitizer rds with the option of dropping tests from it. See `?review`. ### `editCalls` *Warning*: this is experimental; make sure your test store is backed up before you use it. `editCalls` allows you to modify the calls calls stored in a `unitizer`. This is useful when you decide to change the call (e.g. a function name), but otherwise leave the behavior of the call unchanged. You can then upate your test script and the renamed calls will be matched against the correct values in the `unitizer` store. Without this you would have to re-review and re-store every test since `unitizer` identifies tests by the deparsed call. ### `split` There is currently no direct way to split a `unitizer` into pieces (see [issue #44](https://github.com/brodieG/unitizer/issues/44)), but the current work around is to: 1. Copy the test file and the corresponding `unitizer` to a new location. 2. Edit the original test file to remove the tests we want to split off. 3. Run unitizer and agree to drop all removed tests (hint: this is a good time to use `YY`). 4. Edit the new test file and remove the tests that are still in the old test file. 5. Run unitizer and agree to drop all removed tests. The net result will be two new `unitizer`, each with a portion of the tests from the original `unitizer`. Clearly less than ideal, but will work in a pinch. ## Troubleshooting ### After Running `unitizer` Output No Longer Shows on Screen `unitizer` sinks `stdout` and `stderr` during test evaluation, so it is possible that in some corner cases `unitizer` exits without releasing sinks. We have put substantial effort in trying to avoid this eventuality, but should it occur, here are some things you can do: * Run: `while(sink.number()) sink()` and `sink(type="message")` to reset the output stream sinks. * Or, restart the R session (type `q()` followed by ENTER, then "y" or "n" (without quotes) depending on whether you want to save your workspace or not). Either way, please contact the maintainer as this should not happen. ### `unitizer` Freezes and Pops up "Selection:" This is almost certainly a result of an R crash. Unfortunately the normal mechanisms to restore `stderr` don't seem to work completely with full R crashes, so when you see things like: ``` +------------------------------------------------------------------------------+ | unitizer for: tests/unitizer/alike.R | +------------------------------------------------------------------------------+ Running: alike(data.frame(a = integer(), b = factor()), data.frame(a = 1:3, Selection: ``` what you are not seeing is: ``` *** caught segfault *** address 0x7fdc20000010, cause 'memory not mapped' Traceback: 1: .Call(ALIKEC_alike, target, current, int.mode, int.tol, attr.mode) 2: alike(data.frame(a = factor(), b = factor()), data.frame(a = 1:3, b = letters[1:3])) Possible actions: 1: abort (with core dump, if enabled) 2: normal R exit 3: exit R without saving workspace 4: exit R saving workspace ``` The "Selection:" bit is prompting you to type 1-4 as per above. We will investigate to see if there is a way to address this problem, but the solution likely is not simple since the R crash circumvents the `on.exit` handlers used to reset the stream redirects. Also, note that in this case the crash is caused by `alike`, not `unitizer` (see below). ### Running `unitizer` Crashes R Every R crash we have discovered while using `unitizer` was eventually traced to a third party package. Some of the crashes were linked to issues attaching/detaching packages. If you think you might be having an issue with this you can always turn this feature off via the `state` parameter (not the feature is off by default). ### Different Outcomes in Interactive vs. Non Interactive Watch out for functions that have default arguments of the type: ``` fun <- function(x, y=getOption('blahblah')) ``` as those options may be different depending on whether you are running whether you are running R interactively or not. One prime example is `parse(..., keep.source = getOption("keep.source"))`. ## Other Topics ### Running `unitize` Within Error Handling Blocks Because `unitize` evaluates test expressions within a call to `withCallingHandlers`, there are some limitations on successfully running `unitize` inside your own error handling calls. In particular, `unitize` will not work properly if run inside a `tryCatch` or `try` statement. If test expressions throw conditions, the internal `withCallingHandlers` will automatically hand over control to your `tryCatch`/`try` statement without an opportunity to complete `unitize` computations. Unfortunately there does not seem to be a way around this since we have to use `withCallingHandlers` so that test statements after non-aborting conditions are run. See this [SO Q/A](https://stackoverflow.com/questions/20572288/capture-arbitrary-conditions-with-withcallinghandlers) for more details on the problem. ### Overridden Functions In order to perpetuate the R console prompt illusion, `unitizer` needs to override some buit-in functionality, including: * `ls` is replaced by a special version that can explore the `unitizerItem` environments * `quit` and `q` are wrappers around the base functions that allow `unitizer` to quit gracefully * `traceback` and `.traceback` are replaced to read the internally stored traces of the `unitizer`-handled errors in tests. * History is replaced during `unitizer` prompt evaluations with a temporary version of the history file containing only commands evaluated at the `unitizer` prompt. The normal history file is restored on exit. unitizer/vignettes/u1_intro.Rmd0000644000176200001440000002275714766101222016355 0ustar liggesusers--- title: "unitizer - Interactive R Unit Tests" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{1 - Introduction} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r child='./rmdhunks/intro.Rmd'} ``` ## How Does `unitizer` Differ from `testthat`? ### Testing Style `unitizer` requires you to review test outputs and confirm they are as expected. `testthat` requires you to assert what the test outputs should be beforehand. There are trade-offs between these strategies that we illustrate here, first with `testthat`: ``` vec <- c(10, -10, 0, .1, Inf, NA) expect_error( log10(letters), "Error in log10\\(letters\\) : non-numeric argument to mathematical function\n" ) expect_equal(log10(vec), c(1, NaN, -Inf, -1, Inf, NA)) expect_warning(log10(vec), "NaNs produced") ``` And with `unitizer`: ``` vec <- c(10, -10, 0, .1, Inf, NA) log10(letters) # input error log10(vec) # succeed with warnings ``` These two unit test implementations are functionally equivalent. There are benefits to both approaches. In favor of `unitizer`: * Tests are easy to write. * Tests with non-trivial outputs are easy to write, which encourages more realistic testing of functionality. * Conditions are captured automatically, with no need for special handling. * You can immediately review failing tests in an interactive environment. * Updating tests when function output legitimately changes is easy. In favor of `testthat`: * The tests are self documenting; expected results are obvious. * Once you write the test you are done; with `unitizer` you still need to `unitize` and review the tests. * Tests are usually all-plain text, whereas `unitizer` stores reference values in binary RDSes (see [Collaborating with Unitizer](u5_miscellaneous.html#collaborating-with-unitizer)). `unitizer` is particularly convenient when the tests return complex objects (e.g as `lm` does) and/or produce conditions. There is no need for complicated assertions involving deparsed objects, or different workflows for snapshots. ### Converting `testthat` tests to `unitizer` If you have a stable set of tests it is probably not worth trying to convert them to `unitizer` unless you expect the code those tests cover to change substantially. If you do decide to convert tests you can use the provided `testthat_translate*` functions (see `?testthat_translate_file`). ## `unitizer` and Packages The simplest way to use `unitizer` as part of your package development process is to create a `tests/unitizer` folder for all your `unitizer` test scripts. Here is a sample test structure from the demo package: ``` unitizer.fastlm/ # top level package directory R/ tests/ run.R # <- calls `unitize` or `unitize_dir` unitizer/ fastlm.R cornerCases.R ``` And this is what the `tests/run.R` file would look like ``` library(unitizer) unitize("unitizer/fastlm.R") unitize("unitizer/cornerCases.R") ``` or equivalently ``` library(unitizer) unitize_dir("unitizer") ``` The path specification for test files should be relative to the `tests` directory as that is what `R CMD check` uses. When `unitize` is run by `R CMD check` it will run in a non-interactive mode that will succeed only if all tests pass. You can use any folder name for your tests, but if you use "tests/unitizer" `unitize` will look for files automatically, so the following work assuming your working directory is a folder within the package: ``` unitize_dir() # same as `unitize_dir("unitizer")` unitize("fast") # same as `unitize("fastlm.R")` unitize() # Will prompt for a file to `unitize` ``` Remember to include `unitizer` as a "suggests" package in your DESCRIPTION file. ## Things You Should Know About `unitizer` ### `unitizer` Writes To Your Filesystem The `unitize`d tests need to be saved someplace, and the default action is to save to the same directory as the test file. You will always be prompted by `unitizer` before it writes to your file system. See [storing `unitized` tests](u5_miscellaneous.html#storing-unitized-tests) for implications and alternatives. ### Tests Pass If They `all.equal` Stored Reference Values Once you have created your first `unitizer` with `unitize`, subsequent calls to `unitize` will compare the old stored value to the new one using `all.equal`. You can change the comparison function by using `unitizer_sect` (see [tests vignette](u2_tests.html)). ### Test Expressions Are Stored Deparsed This means you need to be careful with expressions that may deparse differently on different machines or with different settings. Unstable deparsing will prevent tests [from matching](u2_tests.html#matching-tests) their previously stored evaluations. For example, in order to avoid round issues with numerics, it is better to use: ```{r, eval=FALSE} num.var <- 14523.2342520 # assignments are not considered tests test_me(num.var) # safe ``` Instead of: ```{r, eval=FALSE} test_me(14523.2342520) # could be deparsed differently ``` Similarly issues may arise with non-ASCII characters, so use: ```{r eval=FALSE} chr <- "hello\u044F" # assignments are not considered tests fun_to_test(chr) # safe ``` Instead of: ```{r eval=FALSE} fun_to_test("hello\u044F") # could be deparsed differently ``` This issue does not affect the result of running the test as that is never deparsed. ### Increase Reproducibility with Advanced State Management `unitizer` can track and manage many aspects of state to make your tests more reproducible. For example, `unitizer` can reset your R package search path to what is is found in a fresh R session prior to running tests to avoid conflicts with whatever libraries you happen to have loaded at the time. Your session state is restored when `unitizer` exits. The following aspects of state can be actively tracked and managed: * Search path (including removing the global environment from search path) * Random seed * Working directory * Options * Loaded namespaces State management is turned off by default because it requires tracing some base functions which is against CRAN policy, and generally affects session state in uncommon ways. If you wish to enable this feature use `unitize(..., state='suggested')` or `options(unitizer.state='suggested')`. For more details including potential pitfalls see `?unitizerState` and the [reproducible tests vignette](u4_reproducible-tests.html). ### Beware of `browser`/`debug`/`recover` If you enter the interactive browser as e.g. invoked by `debug` you should exit it by allowing evaluation to complete (e.g. by hitting "c" until control returns to the `unitizer` prompt). If you instead hit "Q" while in browser mode you will completely exit the `unitizer` session losing any modifications you made to the tests under review. ### Reference Objects Tests that modify objects by reference are not perfectly suited for use with `unitizer`. The tests will work fine, but `unitizer` will only be able to show you the most recent version of the reference object when you review a test, not what it was like when the test was evaluated. This is only an issue with reference objects that are modified (e.g. environments, RC objects, `data.table` modified with `:=` or `set*`). ### `unitizer` Is Complex In order to re-create the feel of the R prompt within `unitizer` we resorted to a fair bit of trickery. For the most part this should be transparent to the user, but you should be aware it exists in the event something unexpected happens that exposes it. Here is a non-exhaustive list of some of the tricky things we do: * Each tests is evaluated in its own environment, a child of the previous test's environment; because R looks up objects in parent environments it appears that all tests are evaluated in one environment (see [interactive environment vignette](u3_interactive-env.html)) * We [mask some base functions](#masked-functions). * `.Last.value` will not work * We sink `stdout` and `stderr` during test evaluation to capture those streams (see [details on tests vignette](u2_tests.html)), though we take care to do so responsibly * We parse the test file and extract comments so that they can be attached to the correct test for review * The history file is temporary replaced so that your `unitizer` interactions do not pollute it ### Avoid Tests That Require User Input In particular, you should avoid evaluating tests that invoke `debug`ged functions, or introducing interactivity by using something like `options(error=recover)`, or `readline`, or some such. Tests will work, but the interaction will be challenging because you will have to do it with `stderr` and `stdout` captured... ### Avoid running `unitize` within `try` / `tryCatch` Blocks Doing so will cause `unitize` to quit if any test expressions throw conditions. See discussion in [error handling](u5_miscellaneous.html#running-unitize-within-error-handling-blocks). ### Masked Functions Some base functions are masked at the `unitizer` prompt: * `q` and `quit` are masked to give the user an opportunity to cancel the quit action in case they meant to quit from `unitizer` instead of R. Use Q to quit from `unitizer`, as you would from `browser`. * `ls` is masked with a specialized version for use in `unitizer`. * `traceback` is masked to report the most recent error in the order presented by the `unitizer` prompt. See [miscellaneous topics vignette](u5_miscellaneous.html#overriden-functions). unitizer/NAMESPACE0000644000176200001440000000402714766340624013361 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(all.equal,condition) S3method(all.equal,conditionList) S3method(all.equal,unitizerDummy) S3method(all.equal,unitizerStateRaw) S3method(all.equal,unitizer_glob_state_test) S3method(as.character,H1) S3method(as.character,H2) S3method(as.character,H3) S3method(as.character,bullet) S3method(as.character,header) S3method(as.list,unitizerList) S3method(get_unitizer,character) S3method(get_unitizer,default) S3method(get_unitizer,unitizer_error_store) S3method(get_unitizer,unitizer_result) S3method(get_unitizer,unitizer_results) S3method(infer_unitizer_location,character) S3method(infer_unitizer_location,default) S3method(print,bullet) S3method(print,captured_output) S3method(print,header) S3method(print,unitizer_ls) S3method(print,unitizer_result) S3method(print,unitizer_results) S3method(set_unitizer,character) S3method(set_unitizer,default) export("[Press ENTER to Continue]") export(all_eq) export(append) export(conditionList) export(copy_fastlm_to_tmpdir) export(desc) export(editCalls) export(filename_to_storeid) export(get_unitizer) export(in_pkg) export(infer_unitizer_location) export(mock_item) export(repair_environments) export(review) export(set_unitizer) export(show_file) export(state) export(testFuns) export(testthat_translate_dir) export(testthat_translate_file) export(testthat_translate_name) export(unitize) export(unitize_dir) export(unitizer_check_demo_state) export(unitizer_cleanup_demo) export(unitizer_sect) export(update_fastlm) exportClasses(conditionList) exportMethods("$") exportMethods("[[") exportMethods(all.equal) exportMethods(editCalls) exportMethods(healEnvs) exportMethods(show) import(diffobj) import(methods) import(stats) importFrom(utils,capture.output) importFrom(utils,file_test) importFrom(utils,getParseData) importFrom(utils,installed.packages) importFrom(utils,loadhistory) importFrom(utils,modifyList) importFrom(utils,object.size) importFrom(utils,packageVersion) importFrom(utils,remove.packages) importFrom(utils,savehistory) importFrom(utils,sessionInfo) unitizer/NEWS.md0000644000176200001440000004534114766350436013246 0ustar liggesusers# `unitizer` NEWS ## v1.4.22 * Fix unnamed arguments error in a call to `deparse` that manifested with improvements changes in r-devel. * Fix bad `all.equal` method NAMESPACE entries (h/t @MichaelChirico), see [source issue](https://github.com/r-lib/roxygen2/issues/1587) for details. ## v1.4.21 * Suppress test caused to fail by checks added to `parent.env<-` in r-devel r86545. ## v1.4.20 * Add explicit alias for `fansi-package` now that it is no longer auto-generated by roxgen2 from the [`@docType package` directive](https://github.com/r-lib/roxygen2/issues/1491). ## v1.4.19 * [#293](https://github.com/brodieG/unitizer/issues/293): Output all failed tests in non-interactive mode, instead of just the first one. * [#292](https://github.com/brodieG/unitizer/issues/292): Clarify warnings about stderr in transcript mode. * Fully unhook the evaluation environment chain prior to storing unitizers. Previously only the portions of the chain part of the unitizer was unhooked, but with some tests it becomes possible to capture environments created during the `pre` expression evaluations. This could cause warnings about package environments being unavailable on reload of RDSes. ## v1.4.18 * [#289](https://github.com/brodieG/unitizer/issues/289): Better document pitfalls of non-ASCII in e.g. literals in tests. Related: we no longer attempt to do a parse/deparse round trip when displaying recorded test expressions as the round trip could fail in some cases. * [#288](https://github.com/brodieG/unitizer/issues/288): Prevent upgrade prompt in non-interactive mode interrupting result display (regression introduced in 1.4.15). * [#286](https://github.com/brodieG/unitizer/issues/286): Add a "transcript" mode where test output can better be interpreted as a log, intended non-interactive mode. * [#272](https://github.com/brodieG/unitizer/issues/272): Highlight silently emitted conditions in tests that have otherwise no other output. * [#252](https://github.com/brodieG/unitizer/issues/252), [#253](https://github.com/brodieG/unitizer/issues/252): Better documentation of feature incompatibility with `devtools::load_all`, and more graceful recovery from failures caused by the incompatibility. This only affects `unitizer` sessions run with package search path management enabled (h/t @blset). * [#247](https://github.com/brodieG/unitizer/issues/247): Disallow running `unitizer` without first attaching it to the search path. * [#245](https://github.com/brodieG/unitizer/issues/245): Fix re-run bookmarking when reviewing multiple unitizers with `unitize_dir`. ## v1.4.16-17 * [#285](https://github.com/brodieG/unitizer/issues/285): Relax condition call * [#284](https://github.com/brodieG/unitizer/issues/284): Handle CTRL+C interrupts while multi-line editing. * [#283](https://github.com/brodieG/unitizer/issues/283): Multi-unitizer upgrade regression introduced in 1.4.15. * Address CRAN failures due to path inconsistencies on Windows machines. * [#279](https://github.com/brodieG/unitizer/issues/279): Multi-line input parsing works in non-English locales. ## v1.4.15.9000 Non-CRAN release to fix test issues under `covr` and on older R versions. ## v1.4.15 * Test suite switched to `aammrtf`, removing suggests dependency to `testthat`. * Upgrade process modified so that old `unitizer` that pass tests are not required to be upgraded. * `show.progress` parameter added to control chattiness of progress updates. * Invalid `unitizers` now prevent review of valid `unitizers`. Fix the invalid `unitizers`, or remove them from the review list (e.g. by moving them out of the primary `unitizer` directory). * `review` exposes `use.diff` and `show.progress` parameters. * [#278](https://github.com/brodieG/unitizer/issues/278): Show more context when returning to a test via browser or on re-evaluation. * [#277](https://github.com/brodieG/unitizer/issues/277): Handle CTRL+C interrupts so they do not kill the `unitizer` session (h/t [@milesmcbain](https://milesmcbain.micro.blog/2021/06/10/debugging-cantrip-from.html)). ## v1.4.13-14 * `unitizer` no longer directly accesses `.Traceback` to set traces in interactive sessions. Instead, `traceback()` and `.traceback()` are masked at the interactive prompt. ## v1.4.11-12 * [#248](https://github.com/brodieG/unitizer/issues/248): Ensure vignettes can be tested with `tools::testInstalledPackage`. * [#250](https://github.com/brodieG/unitizer/issues/250), [#251](https://github.com/brodieG/unitizer/issues/251), [#254](https://github.com/brodieG/unitizer/issues/254): Comment parsing improvements (h/t [@blset](https://github.com/brodieG/unitizer/issues/created_by/blset), [@kalibera](https://github.com/kalibera/)) * [#263](https://github.com/brodieG/unitizer/issues/263): Clarify documentation about potential state management issuess. This includes renaming "recommended" state management mode (see `?unitizerState`) to "suggested" ("recommended" still works). * [#268](https://github.com/brodieG/unitizer/issues/268): `options(warn=2)` now works at the `unitizer` prompt in interactive mode. * [#265](https://github.com/brodieG/unitizer/issues/265): Bad vignette links in README (h/t [@moodymudskipper](https://github.com/moodymudskipper)). * [#260](https://github.com/brodieG/unitizer/issues/260): Remove old test error display code. * [#246](https://github.com/brodieG/unitizer/issues/246), [#243](https://github.com/brodieG/unitizer/issues/243): Assorted documentation updates. [#254](https://github.com/brodieG/unitizer/issues/254): Comment parsing. * Fix `sprintf` unused argument errors in new versions of r-devel (h/t [@kalibera](https://github.com/kalibera/)). * `stringsAsFactors` rose from the grave; we put it back. ## v1.4.10 * Banish ghosts of `stringsAsFactors`. ## v1.4.9 * [#262](https://github.com/brodieG/unitizer/issues/262) Interactive prompt slowness caused by recent R changes to `showConnections()`. * [#261](https://github.com/brodieG/unitizer/issues/261) RDS files are explicitly saved in serialization version 2 for backwards compatibility. * [#244](https://github.com/brodieG/unitizer/issues/244) Squash all partial match warnings that `unitizer` emitted under `options(warnPartialMatch*)`. * Tests explicitly set `stringsAsFactors=TRUE` so they don't fail with the anticipated changed for R4.0. * Adds the 'unitizer.restarts.ok' option to suppress warnings about being run within `withRestart` blocks. ## v1.4.8 * `install.packages` calls in tests now use a temporary folder for library. ## v1.4.7 * Set `RNGversion()` in internal tests due to changes to R sampling mechanism. ## v1.4.6 * [#258](https://github.com/brodieG/unitizer/issues/258) Remove `devtools` as a suggests dependency (reported by @jimhester). * [#257](https://github.com/brodieG/unitizer/issues/257) Ensure all slots in S4 prototypes exist in the class definition (reported by B. Ripley). ## v1.4.5 * Colors in test browser working again. * [#220](https://github.com/brodieG/unitizer/issues/220) Fix vignette ordering on CRAN. * [#225](https://github.com/brodieG/unitizer/issues/225) Inferring file locations when not in pkg top level. * [#237](https://github.com/brodieG/unitizer/issues/237) Option to turn off diffs. * [#239](https://github.com/brodieG/unitizer/issues/239) Document issues with deparsing doubles in tests. * [#242](https://github.com/brodieG/unitizer/issues/242) Correctly parse newlines in prompt input. * [#241](https://github.com/brodieG/unitizer/issues/241) `q()` actually works now. * [#231](https://github.com/brodieG/unitizer/issues/231) Report parse warnings at prompt. * [#234](https://github.com/brodieG/unitizer/issues/234) Random seed issues. * [#220](https://github.com/brodieG/unitizer/issues/220) Re-order vignettes. * Wrap `diffObj` call in `try` to avoid killing `unitizer` section when `diffObj` errors. * Modify `test_dir` calls to use `wrap` on `testthat` versions greater than 0.1.2. ## v1.4.4 * Fix tests broken by R-devel 3.4.1 improvements to S4 deparsing * [#232](https://github.com/brodieG/unitizer/issues/232) document that `.Last.value` does not work * [#228](https://github.com/brodieG/unitizer/issues/228) more docs on handling RDS files * README typos (@eddelbuettel) * Improve vignette index ## v1.4.3 * [#221](https://github.com/brodieG/unitizer/issues/221) Crash on Re-Run due to poor comparison of parsed test file sources * [#222](https://github.com/brodieG/unitizer/issues/222) Allow loading of `unitizers` generated by later versions of the package in earlier version of the packages provided the object validates * [#224](https://github.com/brodieG/unitizer/issues/224) Slow re-eval in recommended state mode with lots of files ## v1.4.1-2 Fixing CRAN submission errors. ## v1.4.0 First Release to CRAN. * [#213](https://github.com/brodieG/unitizer/issues/213): Disable advanced state management by default to comply with CRAN * [#203](https://github.com/brodieG/unitizer/issues/203): Better reporting of search path state differences * Assorted bugfixes and enhancements: [#214](https://github.com/brodieG/unitizer/issues/214), [#215](https://github.com/brodieG/unitizer/issues/215), [#208](https://github.com/brodieG/unitizer/issues/208), [#201](https://github.com/brodieG/unitizer/issues/201), [#208](https://github.com/brodieG/unitizer/issues/208), [#199](https://github.com/brodieG/unitizer/issues/199), [#197](https://github.com/brodieG/unitizer/issues/197) ## v1.2.0 - v1.3.0 Interim release to get changes over past year out on the master branch. ### Improvement / Changes: * [#194](https://github.com/brodieG/unitizer/issues/194): Performance improvements * [#102](https://github.com/brodieG/unitizer/issues/102): Ability to break out of multi file review with `QQ` * [#186](https://github.com/brodieG/unitizer/issues/186): If you type `q()` or `quit()` by mistake you can now cancel that action before `unitizer` terminates unceremoniously * [#142](https://github.com/brodieG/unitizer/issues/142): Ability to run `unitize` and `unitize_dir` without specifying any arguments (infer from working directory) * [#168](https://github.com/brodieG/unitizer/issues/168): Failing tests now will display all output and conditions * [#171](https://github.com/brodieG/unitizer/issues/171): Flush warnings in `unitizer` REPL * Improved integration of object diffs via `.DIFF` and `.diff` * Display improvements, including: * Cleaner separation of `unitizer` meta-output vs. test or command line * [#164](https://github.com/brodieG/unitizer/issues/164), [#176](https://github.com/brodieG/unitizer/issues/176): Streamline state difference display * Several other [enhancements](https://github.com/brodieG/unitizer/issues?utf8=%E2%9C%93&q=is%3Aissue%20is%3Aopen%20label%3A%22fixed%20in%20dev%22%20milestone%3A1.2.0%20-label%3Aenhancement%20) ### Bugfixes: * [#188](https://github.com/brodieG/unitizer/issues/188): Search path issues in r-devel @[richierocks](https://github.com/richierocks) * Fix unintended detaching of `tools:rstudio`, and [many](https://github.com/brodieG/unitizer/issues?utf8=%E2%9C%93&q=is%3Aissue%20milestone%3A1.2.0%20label%3Abug%20) [others](https://github.com/brodieG/unitizer/issues?utf8=%E2%9C%93&q=is%3Aissue%20milestone%3A1.3.0%20label%3Abug%20) * `base.env` now unique for each `unitizer` ## v1.1.0 ### Improvement / Changes: * [#161](https://github.com/brodieG/unitizer/issues/161): Compare objects with `diffobj::diffObj` * [#166](https://github.com/brodieG/unitizer/issues/166): More systematic handling of `library`/`attach`/`detach` ### Bugfixes: * Several unitizer prompt issues: * No longer capture prompt evals so `debug` is usable again * Parse errors reported correctly * [#165](https://github.com/brodieG/unitizer/issues/165): Confusing Help Prompt * Reference state properly preserved (previously would incorrectly use new state for reference tests kept in store) * Internal shimming of library/detach/attach more robust * Updated tests for changes in testthat, R ## v1.0.0-1.0.9 ### Improvement / Changes: * More comprehensive state tracking and resetting: * options, random.seed, and wd are tracked in addition to search path * state is reset when reviewing tests as well as when executing them * you are alerted off state differences between new and reference tests on error * State control parameters are streamlined; API breaking * Whether an expression is ignored or not is now a function of whether the expression returns visibly or not * Pre and post test scripts * 'helper' directory renamed '_pre' * Can now use a '_post' directory to run cleanup * Interactive environment cleanup * Display tweaks * Contextual help tweaks * Vignette updates * Demo update * Added `Rdiff_obj` to run a `tools::Rdiff` directly on two R objects ### Internal: * Reduced storage requirements for the `unitizer` stores * No longer storing assignments both as test value and object in environment * Calls recorded deparsed instead of as call objects * Shimming used for search path tracking is more lightweight * Text capture much more robust ### Issues Fixed: 107, 106, 104, 103, 101, 99, 98, 94, 93, 90, 85, 84, 77, 74, 71, 67, 127, 115, 132, 134 ## v0.9.0 ### Improvements / Changes: * Complete restructure of internal test management to allow for much more robust `unitize_dir` behavior (#51) * Added `testthat` -> `unitizer` translation utilities (see `?testthat_translate_file`) * Can now pre-load objects before unitizing; `unitize_dir` and `unitize` by default auto-preload files in subdir 'helper' * Renamed arg `env.clean` to `par.env` (technically API breaking, but since no one is using this package yet...) * Many usability fixes (#48, #68, #82, #83), and improved text display * Improved path inference to better guess desired unitizer based on partiallly specified file names (#72) ### Other * `unitize_dir` works with empty dirs (#78) * Better management of file locations and names (#35, #75) ## v0.8.1 ### Bugfixes * `review` now properly infers unitizer locations ## v0.8.0 ### Improvements: * Added ability to accept multiple tests at once (Issue #45, use wisely...) * `unitize` can now infer partially specified test file names (in particular, will know to look in `pkgname/tests/unitizer`; see `?infer_unitizer_location`) * `parse_with_comments` no longer run in non-interactive mode (#63) * Test call now part of output of test object `show` method (#54) ### Bugfixes: * Comments inside `unitizer_sect` preserved (#64) * Ignored tests assigned to first non-ignored test section (#57) * Prompt display issues (#65, #66) ### Internal: * `search_path_cleanup` more robust (#59) * `get_text_capture` tests added (#60) ## v0.7.1 ### Improvements: * Reduced test execution and parsing overhead * Better handling of call recording for traceback and condition calls * `editFunNames` becomes `editCalls` and provides more comprehensive editing of calls (Issue #52) ### Bufixes: * Comment handling in calls (Issues #56, #58) * Comment deparsing (Issues #39, #47, #52) ## v0.7.0 ### Improvements: * Failed tests now automatically output a snippet of new and reference objects (Issue #34) * Text handling generally improved (better wrapping, etc. Issue #38) * Parsing speed improved (Issue #15) * Got rid of `get*` functions, instead, access test details with `.NEW`/`.REF` (Issue #29) * Implemented `editFunNames` to allow user to modify stored calls in `unitizer` so that tests can be re-used even if function names are changed ## v0.6.5 Doc updates; should have been part of 0.6.4, but was too rushed to push... ## v0.6.4 ### Improvements: * Comment parsing faster (issue #15) ### Bugfixes: * Reference section logic improved (assume fixes #36 until there is evidence against) * Several parse errors fixed ### Other: * Now depends on R 3.1.2 (not really, but that's what we are developing on and don't have bandwidth to test against multiple R versions) ## v0.6.3 ### Bugfixes: * stderr now show in `review` mode (issue #43) * package startup messages suppressed (issue #23) * small demo bug ## v0.6.2 ### Bugfixes: * Better whitespace wrapping in terminal mode (partially addresses #38) * Can now drop all items in review mode (issue #37) * Workaround an R parse bug (issue #41) * `traceback()` now works for `stop(simpleError(...))` type stops Behavior changes: * History is only subbed out if you need to type input (issue #40) #### v0.6.1 Minor release, no substantive changes. ### Bugfixes: * Loading a `unitizer` no longer automatically modifies it through `upgrade` * `upgrade` cleaned up and has tests now * calling functions in form `pkg::fun` or `pkg:::fun` no longer causes problems when checking for ignoredness ### Behavior changes: * `get` no longer warns if `unitizer` ids don't match ## v0.6.0 ### New Features: * Added a demo (`demo(unitizer)`) * Broke up and updated vignettes * `unitize_dir` allows you to run all tests in a directory (issue #24) * `review` allows you to review and drop tests from an existing `unitizer` store (issue #21) * Test navigation mechanism improved (issue #26) * Typing R at the unitizer prompt now allows you to review all tests * You can skip ahead too * `unitize(..., force.update=TRUE)` will overwrite unitizer even if there were no changes recorded (issue #19) ### Behavior changes: * `unitize` now runs with `search.path.clean=TRUE` by default ### Bugfixes: * Comparison function warnings not captured (issue #14) * Search path restoration error messages fixed (issue #22) * Navigation regressions fixed (issue #30) ### Other: Summary titles cleaned up, interative prompts made clearer, package reload warn conflicts quieted (d2fe594c747, #23) ## v0.5.0 ### New Features: * Can now run tests in clean environment (i.e. objects from .GlobalEnv will not be visible) (issue #13) * Can now run tests with clean search path (i.e. only the basic R libraries are loaded) (also issue #13), use `unitize(..., search.path.clean=TRUE)` * New vignette "Reproducible Tests" discusses the above features ### Bugfixes: * Expressions printed as tests evaluated now truncated corretly (issue #4) * Incorrect displaying/hiding of ignored tests in some circumstances fixed ### Other Improvements: * Summary no longer includes "removed" tests in matrix, since those are section- less * Other minor clean-up of the interactive environment prompting ## v0.4.3 ### Many interactive use bug fixes: * LBB now parsed properly (issue #5) * Non interactive parse (issue #11) * Review and Back behavior consistent now in interactive use (issue #3) * Other interactive use cleanup (issues #6, 12, 10, 9) * Vignette now done properly ## v0.4.2 * Fixed setOldClass conflicts with RJSONIO (issue #1) * Fixed run_ls not finding base env under certain circumstances (issue #2) * Fixed conditionLists looping issue introduced when fixing issue #1 unitizer/inst/0000755000176200001440000000000014766360132013110 5ustar liggesusersunitizer/inst/expkg/0000755000176200001440000000000014766101222014217 5ustar liggesusersunitizer/inst/expkg/rcw/0000755000176200001440000000000014766101222015012 5ustar liggesusersunitizer/inst/expkg/rcw/rcw-test.R0000644000176200001440000000047014766101222016706 0ustar liggesusers# load function source('rcw-code.R', local=TRUE) # create matrix to test rotation mx <- matrix(c(1:3, rep(0, 6)), 3) rcw(mx) # full rotation should get us to original identical(mx, rcw(rcw(rcw(rcw(mx))))) # non-square matrix mx2 <- matrix(c(1:3, rep(0, 3)), ncol=2) rcw(mx2) # Invalid input rcw(1:10) unitizer/inst/expkg/rcw/rcw-code.R0000644000176200001440000000141514766101222016641 0ustar liggesusers# Fun to Rotate Matrix Clockwise rcw <- function(mx) { if(!is.matrix(mx)) stop("Argument `mx` is not matrix.") nr <- dim(mx)[1] nc <- dim(mx)[2] res <- matrix(mx[0], nrow=nr, ncol=nc) for(i in seq_len(nrow(mx))) for(j in seq_len(ncol(mx))) res[j, nr - i + 1] <- mx[i, j] res } # Changes and modifications to code above: # 1. Fix nrow=nr to swith cols and rows # 2. Switch to t.mx <- t(mx) approch, but forget stopifnot # 3. Add the proper re-ordering if(FALSE) { " rm -r ~/repos/rcw/* cp -r ~/repos/unitizer/inst/expkg/rcw/* ~/repos/rcw " rcw2 <- function(mx) { if(!is.matrix(mx)) stop("Argument `mx` is not matrix.") t.mx <- t(mx) t.mx[] <- t.mx[order(-col(t.mx))] # preserves dims t.mx } } unitizer/inst/expkg/flm0/0000755000176200001440000000000014766101222015055 5ustar liggesusersunitizer/inst/expkg/flm0/tests/0000755000176200001440000000000014766101222016217 5ustar liggesusersunitizer/inst/expkg/flm0/tests/unitizer/0000755000176200001440000000000014766101222020070 5ustar liggesusersunitizer/inst/expkg/flm0/tests/unitizer/fastlm1.R0000644000176200001440000000137214766101222021565 0ustar liggesusers# Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) dat <- data.frame(x=1:100, y=(1:100) ^ 2) res <- fastlm(dat$x, dat$y) # The `unitizer>` prompt is like the standard R prompt. You may # enter expressions such as `lm(y ~ x, dat)$coefficients`, or # `str(res)`. # # Once you are done reviewing, you need to tell `unitizer` you # accept the test by typing 'Y' at the prompt. Enter 'H' for help. res # There are three more tests to review; accept them with 'Y' get_slope(res) get_rsq(res) # This last test is expected to cause an error; press 'Y' to # accept it so future checks can confirm the same error persists fastlm(1:100, 1:10) unitizer/inst/expkg/flm0/tests/unitizer/unitizer.fastlm.R0000644000176200001440000000031014766101222023343 0ustar liggesusers# Extra test file for internal tests; not for DEMO library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) x <- 1:10 y <- x ^ 3 res <- fastlm(x, y) get_slope(res) get_rsq(res) get_intercept(res) unitizer/inst/expkg/flm0/tests/unitizer/fastlm2.R0000644000176200001440000000042414766101222021563 0ustar liggesusers# For internal tests only; not for demo x <- 1:10 y <- 1:10 ^ 3 res <- summary(lm(y ~ x, data.frame(x=x, y=y))) intercept <- res$coefficients[1, 1] slope <- res$coefficients[2, 1] rsq <- res$r.squared structure(c(intercept=intercept, slope=slope, rsq=rsq), class="fastlm") unitizer/inst/expkg/flm0/tests/extra/0000755000176200001440000000000014766101222017342 5ustar liggesusersunitizer/inst/expkg/flm0/tests/extra/del2.R0000644000176200001440000000015114766101222020310 0ustar liggesusers# Tests to check see if deleted tests work as expected unitizer_sect("basic tests", { 1 + 1 TRUE }) unitizer/inst/expkg/flm0/tests/extra/inpkg.R0000644000176200001440000000020114766101222020566 0ustar liggesusers# should fail normally, but return TRUE if run in fastlm library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) hidden_fun() unitizer/inst/expkg/flm0/tests/extra/del1.R0000644000176200001440000000024614766101222020314 0ustar liggesusers# Tests to check see if deleted tests work as expected unitizer_sect("basic tests", { 1 + 1 TRUE "hello" }) unitizer_sect("more tests", { 3 645 9 / 0 }) unitizer/inst/expkg/flm0/tests/tests.R0000644000176200001440000000014114766101222017500 0ustar liggesusers# not really meant to run tests, just force the .Rcheck folder to have a tests # subfolder TRUE unitizer/inst/expkg/flm0/R/0000755000176200001440000000000014766101222015256 5ustar liggesusersunitizer/inst/expkg/flm0/R/fastlm-package.r0000644000176200001440000000006614766101222020322 0ustar liggesusers#' fastlm #' #' @name fastlm #' @docType package NULL unitizer/inst/expkg/flm0/R/fastlm.R0000644000176200001440000000233214766101222016667 0ustar liggesusers#' Calculate Slope, Intercept and Rsq #' #' @import stats #' @export #' @param x numeric the independent variable #' @param y numeric the dependent variable #' @return list with three parameters: slope, intercept, and RSql fastlm <- function(x, y) { if(!is.numeric(x) || !is.numeric(y)) stop("Arguments `x` and `y` must be numeric.") if(length(x) != length(y)) stop("Arguments `x` and `y` must be the same length.") res <- summary(lm(y ~ x, data.frame(x=x, y=y))) intercept <- res$coefficients[1, 1] slope <- res$coefficients[2, 1] rsq <- res$r.squared structure(c(intercept=intercept, slope=slope, rsq=rsq), class="fastlm") } #' Retrieve Slope, Intercept, and R Squared #' #' @export #' @aliases get_intercept get_rsq #' @param x fastlm object #' @return numeric(1L) get_slope <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["slope"]] } #' @export get_intercept <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["intercept"]] } #' @export get_rsq <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["rsq"]] } # non-exported to test the in_pkg business hidden_fun <- function() TRUE unitizer/inst/expkg/flm0/utzflm_Rcheck/0000755000176200001440000000000014766101222017655 5ustar liggesusersunitizer/inst/expkg/flm0/utzflm_Rcheck/tests/0000755000176200001440000000000014766101222021017 5ustar liggesusersunitizer/inst/expkg/flm0/utzflm_Rcheck/tests/tests.R0000644000176200001440000000014114766101222022300 0ustar liggesusers# not really meant to run tests, just force the .Rcheck folder to have a tests # subfolder TRUE unitizer/inst/expkg/flm0/utzflm_Rcheck/utzflm/0000755000176200001440000000000014766101222021176 5ustar liggesusersunitizer/inst/expkg/flm0/utzflm_Rcheck/utzflm/_R/0000755000176200001440000000000014766101222021536 5ustar liggesusersunitizer/inst/expkg/flm0/utzflm_Rcheck/utzflm/_R/readme.txt0000644000176200001440000000012314766101222023530 0ustar liggesusersStand-in file to make sure directory is copied. Normally would be something else. unitizer/inst/expkg/flm0/utzflm_Rcheck/utzflm/_INDEX0000644000176200001440000000014014766101222022122 0ustar liggesusersfastlm fastlm get_slope Retrieve Slope, Intercept, and R Squared unitizer/inst/expkg/flm0/utzflm_Rcheck/utzflm/_NAMESPACE0000644000176200001440000000020314766101222022547 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(fastlm) export(get_intercept) export(get_rsq) export(get_slope) import(stats) unitizer/inst/expkg/flm0/utzflm_Rcheck/utzflm/_DESCRIPTION0000644000176200001440000000074014766101222023044 0ustar liggesusersPackage: utzflm Title: Quickly Compute Simple Linear Regressions Description: This is a demo package used to illustrate usage of the `unitizer` package. Version: 0.1.0 Author: Brodie Gaslam Maintainer: Brodie Gaslam Depends: R (>= 3.0.2) Imports: stats Suggests: unitizer License: GPL-2 LazyData: true RoxygenNote: 5.0.1 NeedsCompilation: no Packaged: 2016-10-27 15:16:21 UTC; milberg Built: R 3.3.1; ; 2016-10-27 15:16:30 UTC; unix unitizer/inst/expkg/flm0/NAMESPACE0000644000176200001440000000020314766101222016267 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(fastlm) export(get_intercept) export(get_rsq) export(get_slope) import(stats) unitizer/inst/expkg/flm0/man/0000755000176200001440000000000014766101222015630 5ustar liggesusersunitizer/inst/expkg/flm0/man/fastlm.Rd0000644000176200001440000000066714766101222017416 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastlm-package.r, R/fastlm.R \docType{package} \name{fastlm} \alias{fastlm} \alias{fastlm-package} \title{fastlm} \usage{ fastlm(x, y) } \arguments{ \item{x}{numeric the independent variable} \item{y}{numeric the dependent variable} } \value{ list with three parameters: slope, intercept, and RSql } \description{ fastlm Calculate Slope, Intercept and Rsq } unitizer/inst/expkg/flm0/man/get_slope.Rd0000644000176200001440000000053614766101222020104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastlm.R \name{get_slope} \alias{get_intercept} \alias{get_rsq} \alias{get_slope} \title{Retrieve Slope, Intercept, and R Squared} \usage{ get_slope(x) } \arguments{ \item{x}{fastlm object} } \value{ numeric(1L) } \description{ Retrieve Slope, Intercept, and R Squared } unitizer/inst/expkg/flm0/DESCRIPTION0000644000176200001440000000057414766101222016571 0ustar liggesusersPackage: utzflm Title: Quickly Compute Simple Linear Regressions Description: This is a demo package used to illustrate usage of the `unitizer` package. Version: 0.1.0 Author: Brodie Gaslam Maintainer: Brodie Gaslam Depends: R (>= 3.0.2) Imports: stats Suggests: unitizer License: GPL-2 LazyData: true RoxygenNote: 5.0.1 unitizer/inst/expkg/baddescription0/0000755000176200001440000000000014766101222017271 5ustar liggesusersunitizer/inst/expkg/baddescription0/R/0000755000176200001440000000000014766101222017472 5ustar liggesusersunitizer/inst/expkg/baddescription0/R/dummy.R0000644000176200001440000000011714766101222020747 0ustar liggesusers#' Dummy Function #' #' @return NULL #' @export dummy_fun2 <- function() NULL unitizer/inst/expkg/baddescription0/NAMESPACE0000644000176200001440000000011114766101222020501 0ustar liggesusers# Generated by roxygen2 (4.0.2): do not edit by hand export(dummy_fun2) unitizer/inst/expkg/baddescription0/man/0000755000176200001440000000000014766101222020044 5ustar liggesusersunitizer/inst/expkg/baddescription0/man/dummy_fun2.Rd0000644000176200001440000000025014766101222022415 0ustar liggesusers% Generated by roxygen2 (4.0.2): do not edit by hand \name{dummy_fun2} \alias{dummy_fun2} \title{Dummy Function} \usage{ dummy_fun2() } \description{ Dummy Function } unitizer/inst/expkg/baddescription0/DESCRIPTION0000644000176200001440000000047014766101222021000 0ustar liggesusersPackage: unitizerdummypkg2 Title: Dummy Package 2 For `unitizer` Testing Version: 0.1 Author: Brodie Gaslam Maintainer: Brodie Gaslam Description: Allows testing of search path manipulation functionality built into `unitizer` Depends: R (>= 3.1.1) License: GPL-2 LazyData: true unitizer/inst/expkg/baddescription1/0000755000176200001440000000000014766101222017272 5ustar liggesusersunitizer/inst/expkg/baddescription1/R/0000755000176200001440000000000014766101222017473 5ustar liggesusersunitizer/inst/expkg/baddescription1/R/dummy.R0000644000176200001440000000011714766101222020750 0ustar liggesusers#' Dummy Function #' #' @return NULL #' @export dummy_fun2 <- function() NULL unitizer/inst/expkg/baddescription1/NAMESPACE0000644000176200001440000000011114766101222020502 0ustar liggesusers# Generated by roxygen2 (4.0.2): do not edit by hand export(dummy_fun2) unitizer/inst/expkg/baddescription1/man/0000755000176200001440000000000014766101222020045 5ustar liggesusersunitizer/inst/expkg/baddescription1/man/dummy_fun2.Rd0000644000176200001440000000025014766101222022416 0ustar liggesusers% Generated by roxygen2 (4.0.2): do not edit by hand \name{dummy_fun2} \alias{dummy_fun2} \title{Dummy Function} \usage{ dummy_fun2() } \description{ Dummy Function } unitizer/inst/expkg/baddescription1/DESCRIPTION0000644000176200001440000000037014766101222021000 0ustar liggesusersPackaage: nopackagenam e Title: Dummy Package 3 For `unitizer` Testing Version: 0.1 Author: Brodie Gaslam Maintainer: Brodie Gaslam Description: package tag is wrong Depends: R (>= 3.1.1) License: GPL-2 LazyData: true unitizer/inst/expkg/unitizerdummypkg1/0000755000176200001440000000000014766101222017727 5ustar liggesusersunitizer/inst/expkg/unitizerdummypkg1/R/0000755000176200001440000000000014766101222020130 5ustar liggesusersunitizer/inst/expkg/unitizerdummypkg1/R/dummy.R0000644000176200001440000000005214766101222021403 0ustar liggesusers#' @export dummy_fun1 <- function() NULL unitizer/inst/expkg/unitizerdummypkg1/NAMESPACE0000644000176200001440000000010114766101222021136 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(dummy_fun1) unitizer/inst/expkg/unitizerdummypkg1/DESCRIPTION0000644000176200001440000000051314766101222021434 0ustar liggesusersPackage: unitizerdummypkg1 Title: Dummy Package 1 For `unitizer` Testing Version: 0.1 Author: Brodie Gaslam Maintainer: Brodie Gaslam Description: Allows testing of search path manipulation functionality built into `unitizer` Depends: R (>= 3.1.1) License: GPL-2 LazyData: true RoxygenNote: 5.0.1 unitizer/inst/expkg/flm1/0000755000176200001440000000000014766101222015056 5ustar liggesusersunitizer/inst/expkg/flm1/tests/0000755000176200001440000000000014766101222016220 5ustar liggesusersunitizer/inst/expkg/flm1/tests/unitizer/0000755000176200001440000000000014766101222020071 5ustar liggesusersunitizer/inst/expkg/flm1/tests/unitizer/fastlm1.R0000644000176200001440000000110314766101222021556 0ustar liggesuserslibrary(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) dat <- data.frame(x=1:100, y=(1:100) ^ 2) res <- fastlm(dat$x, dat$y) # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. res # This one is also incorrect; reject with 'N' get_slope(res) # Still correct get_rsq(res) # Still causes the same error (hence test passes) fastlm(1:100, 1:10) unitizer/inst/expkg/flm1/tests/unitizer/unitizer.fastlm.R0000644000176200001440000000031014766101222023344 0ustar liggesusers# Extra test file for internal tests; not for DEMO library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) x <- 1:10 y <- x ^ 3 res <- fastlm(x, y) get_slope(res) get_rsq(res) get_intercept(res) unitizer/inst/expkg/flm1/tests/unitizer/fastlm2.R0000644000176200001440000000042414766101222021564 0ustar liggesusers# For internal tests only; not for demo x <- 1:10 y <- 1:10 ^ 3 res <- summary(lm(y ~ x, data.frame(x=x, y=y))) intercept <- res$coefficients[1, 1] slope <- res$coefficients[2, 1] rsq <- res$r.squared structure(c(intercept=intercept, slope=slope, rsq=rsq), class="fastlm") unitizer/inst/expkg/flm1/tests/tests.R0000644000176200001440000000005214766101222017502 0ustar liggesuserslibrary(unitizer) unitize_dir("unitizer") unitizer/inst/expkg/flm1/R/0000755000176200001440000000000014766101222015257 5ustar liggesusersunitizer/inst/expkg/flm1/R/fastlm-package.r0000644000176200001440000000006614766101222020323 0ustar liggesusers#' fastlm #' #' @name fastlm #' @docType package NULL unitizer/inst/expkg/flm1/R/fastlm.R0000644000176200001440000000223514766101222016672 0ustar liggesusers#' Calculate Slope, Intercept and Rsq #' #' @export #' @import stats #' @param x numeric the independent variable #' @param y numeric the dependent variable #' @return list with three parameters: slope, intercept, and RSql fastlm <- function(x, y) { if(!is.numeric(x) || !is.numeric(y)) stop("Arguments `x` and `y` must be numeric.") if(length(x) != length(y)) stop("Arguments `x` and `y` must be the same length.") # Incorrect values slope <- sum((x - mean(x)) * (y - mean(y))) * sum((x - mean(x)) ^ 2) intercept <- mean(y) - slope * mean(x) rsq <- cor(x, y) ^ 2 structure(c(intercept=intercept, slope=slope, rsq=rsq), class="fastlm") } #' Retrieve Slope, Intercept, and R Squared #' #' @export #' @aliases get_intercept get_rsq #' @param x fastlm object #' @return numeric(1L) get_slope <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["slope"]] } #' @export get_intercept <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["intercept"]] } #' @export get_rsq <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["rsq"]] } unitizer/inst/expkg/flm1/NAMESPACE0000644000176200001440000000020314766101222016270 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(fastlm) export(get_intercept) export(get_rsq) export(get_slope) import(stats) unitizer/inst/expkg/flm1/man/0000755000176200001440000000000014766101222015631 5ustar liggesusersunitizer/inst/expkg/flm1/man/fastlm.Rd0000644000176200001440000000066714766101222017417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastlm-package.r, R/fastlm.R \docType{package} \name{fastlm} \alias{fastlm} \alias{fastlm-package} \title{fastlm} \usage{ fastlm(x, y) } \arguments{ \item{x}{numeric the independent variable} \item{y}{numeric the dependent variable} } \value{ list with three parameters: slope, intercept, and RSql } \description{ fastlm Calculate Slope, Intercept and Rsq } unitizer/inst/expkg/flm1/man/get_slope.Rd0000644000176200001440000000053614766101222020105 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastlm.R \name{get_slope} \alias{get_intercept} \alias{get_rsq} \alias{get_slope} \title{Retrieve Slope, Intercept, and R Squared} \usage{ get_slope(x) } \arguments{ \item{x}{fastlm object} } \value{ numeric(1L) } \description{ Retrieve Slope, Intercept, and R Squared } unitizer/inst/expkg/flm1/DESCRIPTION0000644000176200001440000000057414766101222016572 0ustar liggesusersPackage: utzflm Title: Quickly Compute Simple Linear Regressions Description: This is a demo package used to illustrate usage of the `unitizer` package. Version: 0.1.1 Author: Brodie Gaslam Maintainer: Brodie Gaslam Depends: R (>= 3.0.2) Imports: stats Suggests: unitizer License: GPL-2 LazyData: true RoxygenNote: 5.0.1 unitizer/inst/expkg/infer/0000755000176200001440000000000014766101222015322 5ustar liggesusersunitizer/inst/expkg/infer/tests/0000755000176200001440000000000014766101222016464 5ustar liggesusersunitizer/inst/expkg/infer/tests/unitizer/0000755000176200001440000000000014766101222020335 5ustar liggesusersunitizer/inst/expkg/infer/tests/unitizer/inf.unitizer/0000755000176200001440000000000014766101222022761 5ustar liggesusersunitizer/inst/expkg/infer/tests/unitizer/inf.unitizer/data.rds0000644000176200001440000000417614766101222024414 0ustar liggesusers[s6] )03 _PZ/^ZRt>7>|m?vW%[{$zO^]]Y毄P}_''4%93xZ(X!-Q߆嵯F} Qw(>BWXj&Mov} KⰬ(h&Fhl=o0JqM5Ϛ|i1:-^5D`63aVFۛF7>|m?vW%[{$zO^]]Y毄P}_''4%93xZ(X!-/md!Fyj_wBG|.ʄOU3Idӛ]B8,+ 1[Oa\0}|3Y5 X KpTa>ف]&,ьȂ&dFBN@WfF6Z4e PȨ Xr !Fo:&J#!`qe4f%e>t{kg^Xx /L]žm?3[;VXA!1`|TB4j.'aE9D |>@|$%+W'P< ̂Ա=?) 5^,,\Y%UT6${?*J"(?59?! ф!4[!U8E o%L ƁIL5tJY8nwkP( #FfaPc^n-1?DSqɳP~V}즱~޵l\ń%ŒhVRo<^퉣iS-MfG/s, _Z̻}Wl )p;L;&-TՎxL8P1;.%B m{<;F|W*$xAiF?WV)}* 6ir`"sI MUz+EVlݵ({^x-< f(6N2Sl+ANld[nx~hla۠&Æ2&֭Hvb6z.R]OM NzWikp(4;~KK&-qpVuIӄDvUM 2@lyF.|,#Z$Z8^Q *1Uݲ@1z"7cKdZ.bhդg K\i/XocC0HZK<1V⟂fPl4XJ!Hb]uprҠԿc yb$Ĩh(G4,N Yf,[)[QD=N$Z'Inʲ[) D 3bmn щHXHuZ!.§0V pWM[G}Ϧ崽|(x3orUf)⧈}+C7+Xs,m4މ%{amZ-/L ݝ_)𼟽r<>x[(ObgGb>[|wPXk[~{nJ2 Nl^V'ܖ\cC{iv4 M؞zKR3zױpM*P\/vgQ|0IC3z;zlZrp !p Aw@yN˾_GtqnU(f2po%hUmU%+(iKs݂Kԛ%7K#2KLxyYx.!/KW3e1lg#LOw@ғ$5C9-?zp(!˨mzi7I}Qc=unitizer/inst/expkg/infer/tests/unitizer/infer.unitizer/0000755000176200001440000000000014766101222023310 5ustar liggesusersunitizer/inst/expkg/infer/tests/unitizer/infer.unitizer/data.rds0000644000176200001440000000417714766101222024744 0ustar liggesusers[s6%wy)03 _P}jCKRJBR OsهKҖۏmgp%[eYGpM|jjAMF*`m`Џ̑ܔI˅w2xgFO9?6u(pt8ap璕s4Um#9F'P9 \A싾v+E!j$̵KiB+$"ND6]Y毄P}_''4$.:.lw\dvx(X!-&&.1_FP66=Q&tmL* RāYQL3C_gD 嚈9[ɪlXBt s60Ie)OdDt]l6P%r2ԓѤ-S$(NjZBB!&`)@Ė*ᴙZ(ɏămĕј)@&E\;S\n]Exa*nA yG pQ޺sQhz7 dĎٶ%RgV#j~&(*`LC,T2 R@`2Lgid JOrl,A&/tQQA!H,zlT:F52'h,03,F^(Ygζ]BQvX14A  rkA!:rpKj.<66޻^T^$XX 5P͊wO(О8f=eAMHݢ.tjV+2͒@Y Is"\e*YP˳u5E%2<;l5:+~㍫26hS7MTLӑBp@eJgȣ qw[ %@Q>N'qnZZ;I$5(uFd+6!BmWtQ}iaI('Y'l BAN#j Đ*hqAp+W'^BCJ7M3 ={ z>q:*uPe@F\t $E?3zcT3 _F F\7_ KM4$ (i 7yeTm~7ɤ|j^0?=7b;m^k5D`n63aVۛF‰iʙ<]XF Iz1vTxc$-+Vec\oߗDɴ"]ЪIS+ K\i/X#iMiDX &@AN˱Z `]C6 ĺAێj/erSD<8 ~qZW3[\ao-Oيj%HqpHrPLap58ΠqpPD(%kT"|h:cu Y~%޴(pT9O> l^W^iO){0_e#~ׇ2t\rU܊coN\-kjm?3tw.Nxe=unitizer/inst/expkg/infer/tests/unitizer/zzz.R0000644000176200001440000000002514766101222021312 0ustar liggesusers# trivial test TRUE unitizer/inst/expkg/infer/tests/unitizer/inf.R0000644000176200001440000000002514766101222021231 0ustar liggesusers# trivial test TRUE unitizer/inst/expkg/infer/tests/unitizer/abc.R0000644000176200001440000000002514766101222021202 0ustar liggesusers# trivial test TRUE unitizer/inst/expkg/infer/tests/unitizer/aaa.unitizer/0000755000176200001440000000000014766101222022727 5ustar liggesusersunitizer/inst/expkg/infer/tests/unitizer/aaa.unitizer/data.rds0000644000176200001440000000417714766101222024363 0ustar liggesusers[s6] )03 _PZ/^ZRt>7>|m?vW%[{$zO^]]Y毄P}_''4%93xZ(X!-/CMM~b׾Mu'Dlz)L$ ]5cT@6/.ò*57UŰ JSeR͈,l. 0_K&o$tei$iE>[8P8I %[haZkk$?vWFc\Y6Cv5}' U+8`s,<FyGE-D#qf[s0LNά0G,HRu2 ȳPQ,HP%hҹʕhXYEeL^$BS"PMBRYf\RT~ < g7nw]ki*O/[LH_ Z,fz,E {O(؞8f=eAMHݢ.tjV+2ǒ@Y >Dy_$D$TTBq/ȤS sl脮lƅ7/lN4}P2aOD V.϶G# uP=A3tK}^o;{O6tUhd:&EԠשj$.؂t U_E +kKGD=:ao@z= r8IU-!DTAM>j$~\WIOBz[!+4d8r)ĉĨf@M6.O|oVDG7ј\.LE(xM4o2`o[IY l^NW^9ƞO)0_e"~ׇ2tü{9M%?F8;.qZ'֖],Rݹ8 +w}Al$K| w =jɞ_[.Vk sq⡜ +w#}A{l,]t3N7"pcMV*_G Vگ}/i`B}Tϕv r0#?&7Kܳoe~18]d8Bw_gbjAFXuޣ'G'xIkT v¾: .*2t.Σkzfc=unitizer/inst/expkg/infer/R/0000755000176200001440000000000014766101222015523 5ustar liggesusersunitizer/inst/expkg/infer/R/infer.R0000644000176200001440000000002614766101222016747 0ustar liggesusers# needed a file NULL unitizer/inst/expkg/infer/NAMESPACE0000644000176200001440000000003114766101222016533 0ustar liggesusersexportPattern("^[^\\.]") unitizer/inst/expkg/infer/DESCRIPTION0000644000176200001440000000040014766101222017022 0ustar liggesusersPackage: infer Title: Faux package for testing `infer_unitizer_location` Version: 0.1 Description: Nothing Depends: R (>= 3.1.2) License: GPL-3 LazyData: true Author: Brodie Gaslam Maintainer: Brodie Gaslam Suggests: unitizer unitizer/inst/expkg/flm2/0000755000176200001440000000000014766101222015057 5ustar liggesusersunitizer/inst/expkg/flm2/tests/0000755000176200001440000000000014766101222016221 5ustar liggesusersunitizer/inst/expkg/flm2/tests/unitizer/0000755000176200001440000000000014766101222020072 5ustar liggesusersunitizer/inst/expkg/flm2/tests/unitizer/fastlm1.R0000644000176200001440000000110314766101222021557 0ustar liggesusers# Assignments and calls to `library` are not considered tests by # `unitizer` so you will not need to review them library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) res <- fastlm(1:100, (1:100) ^ 2) # Our new implementation of slope and intercept calculations is not correct, # which is why we are seeing these tests as failed. Type 'N' at the prompts # since we do not want to overwrite our previously correct tests with these # incorrect ones res get_slope(res) # Still correct get_rsq(res) # Still causes the same error (hence test passes) fastlm(1:100, 1:10) unitizer/inst/expkg/flm2/tests/unitizer/unitizer.fastlm.R0000644000176200001440000000061314766101222023353 0ustar liggesusers# Extra test file for internal tests; not for DEMO # This one gives us the opportunity of removing a couple of tests and using # sections unitizer_sect("Basic Tests", { library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) x <- 1:10 y <- x ^ 3 res <- fastlm(x, y) get_slope(res) }) unitizer_sect("Advanced Tests", { 2 * get_slope(res) + get_intercept(res) get_rsq(res) }) unitizer/inst/expkg/flm2/tests/unitizer/fastlm2.R0000644000176200001440000000042414766101222021565 0ustar liggesusers# For internal tests only; not for demo x <- 1:10 y <- 1:10 ^ 3 res <- summary(lm(y ~ x, data.frame(x=x, y=y))) intercept <- res$coefficients[1, 1] slope <- res$coefficients[2, 1] rsq <- res$r.squared structure(c(intercept=intercept, slope=slope, rsq=rsq), class="fastlm") unitizer/inst/expkg/flm2/tests/unitizer/unitizer.fastlm2.R0000644000176200001440000000055514766101222023442 0ustar liggesusers# Extra test file for internal tests; not for DEMO # This one gives us the opportunity of removing a couple of tests and using # sections unitizer_sect("Basic Tests", { library(utzflm, lib.loc=getOption('unitizer.tmp.lib.loc')) x <- 1:10 y <- x ^ 2 # modified res <- fastlm(x, y) get_slope(res) }) unitizer_sect("Advanced Tests", { get_rsq(res) }) unitizer/inst/expkg/flm2/R/0000755000176200001440000000000014766101222015260 5ustar liggesusersunitizer/inst/expkg/flm2/R/fastlm-package.r0000644000176200001440000000006614766101222020324 0ustar liggesusers#' fastlm #' #' @name fastlm #' @docType package NULL unitizer/inst/expkg/flm2/R/fastlm.R0000644000176200001440000000223014766101222016666 0ustar liggesusers#' Calculate Slope, Intercept and Rsq #' #' @export #' @import stats #' @param x numeric the independent variable #' @param y numeric the dependent variable #' @return list with three parameters: slope, intercept, and RSql fastlm <- function(x, y) { if(!is.numeric(x) || !is.numeric(y)) stop("Arguments `x` and `y` must be numeric.") if(length(x) != length(y)) stop("Arguments `x` and `y` must be the same length.") # Correct values slope <- sum((x - mean(x)) * (y - mean(y))) / sum((x - mean(x)) ^ 2) intercept <- mean(y) - slope * mean(x) rsq <- cor(x, y) ^ 2 structure(c(intercept=intercept, slope=slope, rsq=rsq), class="fastlm") } #' Retrieve Slope, Intercept, and R Squared #' #' @export #' @aliases get_intercept get_rsq #' @param x fastlm object #' @return numeric(1L) get_slope <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["slope"]] } #' @export get_intercept <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["intercept"]] } #' @export get_rsq <- function(x) { if(!inherits(x, "fastlm")) stop("Argument `x` must be a fastlm object") x[["rsq"]] } unitizer/inst/expkg/flm2/NAMESPACE0000644000176200001440000000020314766101222016271 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(fastlm) export(get_intercept) export(get_rsq) export(get_slope) import(stats) unitizer/inst/expkg/flm2/man/0000755000176200001440000000000014766101222015632 5ustar liggesusersunitizer/inst/expkg/flm2/man/fastlm.Rd0000644000176200001440000000066714766101222017420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastlm-package.r, R/fastlm.R \docType{package} \name{fastlm} \alias{fastlm} \alias{fastlm-package} \title{fastlm} \usage{ fastlm(x, y) } \arguments{ \item{x}{numeric the independent variable} \item{y}{numeric the dependent variable} } \value{ list with three parameters: slope, intercept, and RSql } \description{ fastlm Calculate Slope, Intercept and Rsq } unitizer/inst/expkg/flm2/man/get_slope.Rd0000644000176200001440000000053614766101222020106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastlm.R \name{get_slope} \alias{get_intercept} \alias{get_rsq} \alias{get_slope} \title{Retrieve Slope, Intercept, and R Squared} \usage{ get_slope(x) } \arguments{ \item{x}{fastlm object} } \value{ numeric(1L) } \description{ Retrieve Slope, Intercept, and R Squared } unitizer/inst/expkg/flm2/DESCRIPTION0000644000176200001440000000057414766101222016573 0ustar liggesusersPackage: utzflm Title: Quickly Compute Simple Linear Regressions Description: This is a demo package used to illustrate usage of the `unitizer` package. Version: 0.1.2 Author: Brodie Gaslam Maintainer: Brodie Gaslam Depends: R (>= 3.0.2) Imports: stats Suggests: unitizer License: GPL-2 LazyData: true RoxygenNote: 5.0.1 unitizer/inst/expkg/unitizerdummypkg2/0000755000176200001440000000000014766101222017730 5ustar liggesusersunitizer/inst/expkg/unitizerdummypkg2/R/0000755000176200001440000000000014766101222020131 5ustar liggesusersunitizer/inst/expkg/unitizerdummypkg2/R/dummy.R0000644000176200001440000000005214766101222021404 0ustar liggesusers#' @export dummy_fun2 <- function() NULL unitizer/inst/expkg/unitizerdummypkg2/NAMESPACE0000644000176200001440000000010114766101222021137 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(dummy_fun2) unitizer/inst/expkg/unitizerdummypkg2/DESCRIPTION0000644000176200001440000000051314766101222021435 0ustar liggesusersPackage: unitizerdummypkg2 Title: Dummy Package 2 For `unitizer` Testing Version: 0.1 Author: Brodie Gaslam Maintainer: Brodie Gaslam Description: Allows testing of search path manipulation functionality built into `unitizer` Depends: R (>= 3.1.1) License: GPL-2 LazyData: true RoxygenNote: 5.0.1 unitizer/inst/doc/0000755000176200001440000000000014766360132013655 5ustar liggesusersunitizer/inst/doc/u2_tests.html0000644000176200001440000005311714766360131016321 0ustar liggesusers unitizeR - Test Details

unitizeR - Test Details

Brodie Gaslam

Understanding Tests

Test Outcomes

When unitize is run with a test file against an existing unitizer store, each test in the file is matched and compared to the corresponding test in the store. Here is a comprehensive list of possible outcomes:

  • New: a test present in the file is not in the store and needs to be reviewed to confirm it is correct.
  • Passed: the test matched the reference test in the store and need not be reviewed.
  • Failed: the evaluation of the test from the file differs from the one produced by same expression in the store.
  • Deleted/Removed: a test present in the unitizer store no longer exists in the test file so you will be prompted to remove it from the store.
  • Corrupted/Error: an error occurred while attempting to compare the file and store tests; this should occur very rarely and is likely the result of using a custom comparison function to compare the tests (see unitizer_sect for more details on custom comparison functions). Because the comparison function itself failed, unitizer has no way of knowing whether the test passed or failed; you can think of it as an NA outcome.

When reviewing tests, unitizer will group tests by test type, so you will review all new tests in one go, then the failed tests, and so on. As a result, the order that you review tests may not be the same as the order they appear in in the test file.

What Constitutes a Test?

As noted previously simple assignments are not considered tests. They are stored in the unitizer store, but you are not asked to review them, and their values are not compared to existing reference values prior to storage. The implicit assumption is that if there is an assignment the intent is to use the resulting object in some later test at which point any issues will crop up. Skipping assignment review saves some unnecessary user interaction.

You can force assignments to become tests by wrapping them in parentheses:

a <- my_fun(25)     # this is not a test
(a <- my_fun(42))   # this is a test

The actual rule unitizer uses to decide whether an expression is a test or not is whether it returns invisibly without signalling conditions. Wrapping parentheses around an expression that returns invisibly makes it visible, which is why assignments in parentheses become tests. Conversely, you can wrap an expression in invisible(...) to prevent it from being treated as a test so long as it does not signal conditions.

Recall that newly evaluated tests are matched to reference tests by deparsing the test expression. Some expressions such as strings with non-ASCII bytes (even in their escaped form) or numbers with long decimal tails will deparse differently on different systems, and thus may cause tests to fail to match. You can still use these by storing them in a variable, as the assignment step is not a test:

chr <- "hello\u044F" # this is not a test
fun_to_test(chr)     # this is a test

unitizer Test Components

The following aspects of a unitizer tests are recorded for future comparison:

  • Value.
  • Conditions.
  • Screen (stdout) output.
  • Message (stderr) output.
  • Whether the expression issued an “abort” invokeRestart (e.g. was stop called in the expression).

Currently only the first two elements are actually compared when determining whether a test passes or fails. These two should capture almost all you would care about from a unit test perspective.

Screen output is omitted from comparison because it can be caused to vary substantially by factors unrelated to source code changes (e.g. console display width). Screen output will also seem identical to the value as most of the time screen output is just the result of printing the return value of an expression. This will not be the case if the expression itself prints to stdout explicitly, or if the function returns invisibly.

Message output is omitted because all typical mechanisms for producing stderr output also produce conditions with messages embedded, so it is usually superfluous to compare them. One exception would be if an expression cated to stderr directly.

The “abort” invokeRestart is omitted because it generally is implied by the presence of an error condition and actively monitoring it clutters the diagnostic messaging produced by unitizer. It exists because it is possible to signal a “stop” condition without actually triggering the “abort” restart so in some cases it could come in handy.

While we omit the last three components from comparison, this is just default behavior. You can change this by using the compare argument for unitizer_sect.

Sections

untizer_sect

Often it is useful to group tests in sections for the sake of documentation and clarity. Here is a slghtly modified version of the original demo file with sections:

unitizer_sect("Basic Tests", {
  library(unitizer.fastlm)
  x <- 1:10
  y <- x ^ 3
  res <- fastlm(x, y)

  get_slope(res)
})

unitizer_sect("Advanced Tests", {
  2 * get_slope(res) + get_intercept(res)
  get_rsq(res)
})

Now re-running unitizer segments everything by section (note, first few lines are set-up):

(.unitizer.fastlm <- copy_fastlm_to_tmpdir())
update_fastlm(.unitizer.fastlm, version="0.1.2")
install.packages(.unitizer.fastlm, repos=NULL, type='src', quiet=TRUE)
unitize(file.path(.unitizer.fastlm, "tests", "unitizer", "unitizer.fastlm.R"))

+------------------------------------------------------------------------------+
| unitizer for: tests/unitizer/unitizer.fastlm.R                               |
+------------------------------------------------------------------------------+

                    Pass Fail  New
 1.    Basic Tests     -    -    1
 2. Advanced Tests     -    -    2
..................................
                       -    -    3

If there are tests that require reviewing, each section will be reviewed in turn.

Note that unitizer_sect does not create separate evaluation environments for each section. Any created object will be available to all lexically subsequent tests, regardless of whether they are in the same section or not. Additionally on.exit expressions in unitizer_sect are evaluated immediately, not on exit.

It is possible to have nested sections, though at this point in time unitizer only explicitly reports information at the outermost section level.

Controlling Test Comparison

By default tested components (values and conditions) are compared with all.eq, a wrapper around all.equal that returns FALSE on inequality instead of a character description of the inequality. If you want to override the function used for value comparisons it is as simple as creating a new section for the tests you want to compare differently and use the compare argument:

unitizer_sect("Accessor Functions", compare=identical,
  {
    get_slope(res)
    get_rsq(res)
    get_intercept(res)
} )

The values produced by these three tests will be compared using identical instead of all.eq. If you want to modify how other components of the test are compared, then you can pass a unitizerItemTestsFuns object as the value to the compare argument instead of a function:

unitizer_sect("Accessor Functions",
  compare=unitizerItemTestsFuns(
    value=identical,
    output=all.equal,
    message=identical
  ),
  {
    get_slope(res)
    get_rsq(res)
    get_intercept(res)
} )

This will cause the value of tests to be compared with identical, the screen output with all.equal, and messages (stderr) with identical.

If you want to change the comparison function for conditions, keep in mind that what you are comparing are conditionList objects so this is not straightforward (see getMethod("all.equal", "conditionList")). In the future we might expose a better interface for custom comparison functions for conditions (see issue #32).

If you need to have different comparison functions within a section, use nested sections. While unitizer will only report the outermost section metrics in top-level summaries, the specified comparison functions will be used for each nested section.

Special Semantics

Almost Like source

When unitizer runs the test expressions in a test file it does more than just evaluating each in sequence. As a result there are some slight differences in semantics relative to using source. We discuss the most obvious ones here.

on.exit

Each top-level statement statement, or top-level statement within a unitizer_sect (e.g. anything considered a test), is evaluated directly with eval in its own environment. This means any on.exit expressions will be executed when the top-level expression that defines them is done executing. For example, it is not possible to set an on.exit(...) for an entire unitizer_sect() block, although it is possible to set it for a single sub-expression:

unitizer_sect('on.exit example', {
  d <- c <- b <- 1
  on.exit(b <- 2)
  b                  # == 2!
  {
    on.exit(d <- c <- 3)
    c                # Still 1
  }
  d                  # == 3
}

Evaluation Environments

Each test is evaluated in its own environment, which has for enclosure the environment of the prior test. This means that a test has access to all the objects created/used by earlier tests, but not objects created/used by subsequent tests. See the Reproducible Tests Vignette for more details.

Options and Streams

In order to properly capture output, unitizer will modify streams and options. In particular, it will do the following:

  • Temporarily set options(warn=1L) during expression evaluation.
  • Temporarily set options(error=NULL) during expression evaluation.
  • Use sink() to capture any output to stdout.
  • Use sink(type="message") to capture output to stderr.

This should all be transparent to the user, unless the user is also attempting to modify these settings in the test expressions. The problematic interaction are around the options function. If the user sets options(warn=1) with the hopes that setting will persist beyond the execution of the test scripts, that will not happen. If the user sets options(error=recover) or some such in a test expression, and that expression throws an error, you will be thrown into recovery mode with no visibility of stderr or stdout, which will make for pretty challenging debugging. Similarly, unitizeing debugged functions, or interactive functions, is unlikely to work well.

You should be able to use options(warn=2) and options(error=recover) from the interactive unitizer prompt.

If unitize is run with sdtderr or stdout sunk, then it will subvert the sink during test evaluation and reset it to the same sinks on exit. If a test expression sinks either stream, unitizer will stop capturing output from that point on until the end of the test file. At that point, it will attempt to reset the sinks to what they were when unitizer started. Sometimes this is not actually possible. If such a situation occurs, unitizer will release all sinks to try to avoid a situation where control is returned to the user with output streams still captured.

To reduce the odds of storing massive and mostly useless stdout, unitize limits how much output is stored by default. If you exceed the limit you will be warned. You may modify this setting with options("unitizer.max.capture.chars").

Other Details

Matching Tests

Whenever you re-run unitize on a file that has already been unitized, unitizer matches the expressions in that file to those stored in the corresponding unitizer store. unitizer matches only on the deparsed expression, and does not care at all where in the file the expression occurs. If multiple identical expressions exist in a file they will be matched in the order they show up.

The unitizer_sect in which a test was when it was first unitized has no bearing whatsoever on matching a new test to a reference test. For example, if a particular test was in “Section A” when it was first unitized, but in the current version of the test file it is in “Section X”, that test will be matched to the current one in “Section X”.

Some expressions may deparse differently on different systems or with different settings (e.g. numbers with decimal places, non-ASCII characters) so tests containing them may not match correctly across them. See the Introductory Vignette for how to avoid problems with this.

Commenting Tests

unitizer parses the comments in the test files and attaches them to the test that they document. Comments are attached to tests if they are on the same line as the test, or in the lines between a test and the previous test. Comments are displayed with the test expression during the interactive review mode. Comment parsing is done on a “best-efforts” basis; it may miss some comments, or even fail to work entirely.

unitizer/inst/doc/u3_interactive-env.Rmd0000644000176200001440000005141314766101222020030 0ustar liggesusers--- title: "unitizeR - The Interactive Environment" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{3 - Interactive Environment} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Overview ### `unitize` vs `review` `unitizer` offers three functions to access the interactive review environment: `unitize`, `unitize_dir`, and `review`. `unitize` is used when you either want to generate a `unitizer` from a test file, or when you want to compare the re-evaluation of a test file to an existing `unitizer`. `untize_dir` does what `unitize` does, except for a whole directory at a time. `review` is a helper function used when you want to review the contents of an existing `unitizer`. This is useful if you grow uncertain about tests that you previously approved and want to ensure they actually do what you want them to. You can review and potentially remove items from a `unitizer` with `review`. Both these functions use the same interactive environment, though rules therein are slightly different. For example, in `review`, all the tests are considered passed since there is nothing to compare them to, and the interactive environment will step you through all the passed tests. `unitize` will normally omit passed tests from the review process. We will focus on `unitize` for the rest of this vignette since most of the commentary about it applies equally to `unitize_dir` and `review`. ### Example Set-up To examine the interactive environment more thoroughly we will go back to the demo (you can run it with `demo(unitizer)`). This is the `unitizer` prompt right after our first failed test when our `unitizer.fastlm` implementation was returning the wrong values: ``` > get_slope(res) unitizer test fails on value mismatch: *value* mismatch: Mean relative difference: 6943055624 @@ .ref @@ - [1] 101 @@ .new @@ + [1] 701248618125 ``` ## `unitizer` Commands Much like the `browser()` prompt, the `unitizer` prompt accepts several special expressions that allow you to control `unitizer` behavior. What the expressions are and what they do depends on context. We will review them in the context of the failed test described above. Look at what the `unitizer` prompt stated before we started reviewing our failed tests: ``` - Failed ----------------------------------------------------------------------- The 2 tests in this section failed because the new evaluations do not match the reference values from the store. Overwrite with new results ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)? ``` This clearly lays out all the special commands available to us: * `Y` will accept the new value as the correct reference value to use for a test. * `N` will keep the previous reference value as the reference value for future tests. * `P` takes us back to the previously reviewed test (see "Test Navigation" next). * `B` allows us to navigate to any previously reviewed test (see "Test Navigation" next). * `R` toggles re-run mode; when you complete review or exit, `unitizer` will re-run the tests, which is useful if you made changes to your source code and re-installed your package from the `unitizer` prompt. * `Q` quits `unitizer` (see "Quitting `unitizer`"). * `H` provides contextual help. If you type any of those letters into the `unitizer` prompt you will cause `unitizer` to respond as described above instead of evaluating the expression as it would be at the normal R console prompt. If you have a variable assigned to one of those letters and you wish to access it, you can do so with any of `get`, `(`, `print`, etc. For example, suppose we stored something in `Y`, then to access it all these commands would work: * `(Y)` * `get("Y")` * `print(Y)` `unitizer` checks for an exact match of a user expression to the special command letters, so something like `(Y)` does not match `Y` which allows you to reach the value stored in `Y`. If at any time you forget what `unitizer` options are available to you you can just hit the "ENTER" key and `unitizer` will re-print the options to screen. You can accept all unreviewed tests in a sub-section, section, or unitizer with `YY`, `YYY`, and `YYYY` respectively. You can also reject them with `NN`, `NNN`, and `NNNN`. Please note that accepting multiple tests without reviewing them is **a really bad idea**, and you should only resort to these shortcuts when you are absolutely certain of what you are doing. The most common use case for these shortcuts is to drop multiple removed tests from a `unitizer`. ## Test Navigation ### Selecting A Test to Review `unitize` will present to you all the tests that require review, but if you wish to review a specific test you can use the `P` (for Previous) and `B` (for Browse) commands. These commands can come in handy if you realize that you incorrectly accepted or rejected an earlier test, but do not wish to quit `unitizer` completely and lose all the other properly reviewed tests. `P` just steps you back to the previous test. `B` gives you the option to go back to any previously reviewed test. `P` is trivially straightforward, so we will not discuss it further. We will type `B` at the prompt of our second failed test to examine what it does: ``` unitizer> B *1. library(unitizer.fastlm) . . . . . . . . . . . . -:- *2. dat <- data.frame(x = 1:100, y = (1:100)^2) . . . . . . -:- *3. res <- fastlm(dat$x, dat$y) . . . . . . . . . . . -:- 4. res . . . . . . . . . . . . . . . . . . . Failed:N 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:- 6. get_rsq(res) . . . . . . . . . . . . . . . . Passed:- 7. fastlm(1:100, 1:10) . . . . . . . . . . . . . . Passed:- What test do you wish to review (input a test number, [U]nreviewed)? unitizer> ``` The `[B]rowse` option produces a list of all the tests in the order in which they appear in the test file. You can type the number of a test to review it, or U to go to the first test that hasn't been reviewed (more on this in a minute). We will examine the line for test #5 in more detail: ``` 5. get_slope(res) . . . . . . . . . . . . . . . . Failed:- ^ ^ ^ ^ | | | | | +-- Deparsed test expression Test status ----+ | | | +- Test ID User Input -+ ``` The value and order of the test IDs shouldn't mean anything to you other than being the number to type in if you wish to review that test. Tests that have a `*` to the left of the test id are expessions that are not reviewed or checked by `unitizer` (we call these [ignored tests](u2_tests.html#what-constitutes-a-test)). The test status (see [tests outcomes](u2_tests.html#test-outcomes)) indicates the outcome of comparison of the reference test in the `unitizer` store to the newly evaluated ones. The first four tests are ignored tests, so they do not have a status. The User Input column marks which tests have been reviewed and what the user decision was. In this case we had reviewed test #2 and decided not to keep it (hence the "N"). Typically neither ignored tests nor passed tests require user input so they will typically have a "-" as the user input, as will tests that would be reviewed, but haven't been yet. Typing `U` at the review prompt will take you to the first unreviewed test. Since ignored tests and passed tests are not typically reviewed, `U` will take you to the first unreviewed test that is neither passed nor ignored. If we type 4 at the prompt, we get: ``` You are re-reviewing a test; previous selection was: "N" # Our fast computations do not produce the same results as our # original tests so they fail. If you need more detail than the # provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`. # # You should reject these tests by typing 'N' at the prompt since # they are incorrect. > res unitizer test fails on value mismatch: *value* mismatch: mean relative difference: 19854602162 @@ .ref @@ - intercept slope rsq - -1717.000000 101.000000 0.938679 attr(,"class") [1] "fastlm" @@ .new @@ + intercept slope rsq + -3.541306e+13 7.012486e+11 9.386790e-01 attr(,"class") [1] "fastlm" unitizer> ``` `unitizer` tells us we are re-reviewing this test and that previously we had chosen not to keep the new version. At this point we could re-examine the test, and potentially change our previous selection. `unitizer` also re-displays any comments that were in the source file either ahead of the test or on the same line as the test. We used this feature to document the demo. You can jump ahead to any test from the review menu, even tests that are typically not reviewed (i.e. ignored or passed, though if you go to those you will be brought back to the review menu once you complete the review because those tests are not part of the normal review flow). If you skip ahead some tests and then get to the end of the review cycle `unitizer` will warn you about unreviewed tests. ### Finalizing `unitizer` Let's accept the 5th test, which brings us to this prompt: ``` unitizer> Y = Finalize Unitizer ============================================================ You will IRREVERSIBLY modify 'tests/unitizer/fastlm1.unitizer' by: - Replacing 1 out of 2 failed tests Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)? unitizer> ``` In this case we were reviewing a `unitizer` with two failed tests, one of which we chose to update with the newer value. `unitizer` will summarize for you all the changes that it is about to make to the `unitizer` store. If you type `Y` at the prompt, the existing `unitizer` store will be overwritten with the new version you just reviewed. If you are unsure about the changes you just approved for the `unitizer`, you can re-review them with `R` or `B`. You can also quit without saving your changes by typing `N`, but once you do so you will no longer be able to recover your changes. ### Quitting `unitizer` At any point you may quit `unitizer` by typing `Q` at the `unitizer` prompt. If you have already reviewed tests, you will be given the opportunity to save what you have done so far as you would when finalizing the `unitizer`. Note that if you chose to quit `unitizer` may exit without giving you the opportunity to review the tests. This will happen if: * You did not make any changes to the `unitizer` (e.g. if you chose `N` at failed tests, you are keeping the reference value, so the `unitizer` is not actually changing). * And test evaluation took less than `getOption("unitizer.prompt.b4.quit.time")` seconds (currently 10 seconds). If you end up in the R debugger from a `unitizer` (e.g. via `debug` or `recover`), quitting the debugger with "Q" will force-exit you from the session without a chance to save any changes. ### Differences in `review` Mode `review` works exactly like `unitize`, except that passed tests are automatically queued up for review, and that the only test statuses you should see are "Passed" or "-", the latter for ignored tests. ## Evaluating Expressions at the `unitizer` Prompt ### As Compared To The Standard R Prompt The `unitizer` prompt is designed to emulate the standard R prompt. For the most part you can type any expression that you would type at the R prompt and get the same result as you would there. This means you can examine the objects created by your test script, run R computations, etc. There are, however, some subtle differences created by the structure of the evaluation environments `unitizer` uses: * Even though you can see objects produced by tests, you can not actually remove them with `rm`. * Any objects you create at the interactive prompt are only available for the test you are currently reviewing, so do not expect them to still be there at subsequent prompts. * All expressions are evaluated with `options(warn=1)` or greater. * Other subtle issues discussed at length in the [Reproducible Tests Vignette](u4_reproducible-tests.html#test-environments). * There are special `unitizer` objects `.new`, `.NEW`, `.ref`, and `.REF` that let you review the results of tests (we will discuss these next). * `ls` and `traceback`/`.traceback` are masked by special `unitizer` versions (we will also discuss this next); you can use `base::ls`/`base::traceback` if you need the originals. * You will have access to any objects created through the `pre` argument to `unitize`, though they will not show up in a call to `ls`. ### `.new` and `.ref` As we saw in the demo there are special objects available at the prompt: `.new` (except for removed/deleted tests), and for all but new tests, `.ref`. These objects contain the values produced by the newly evaluated test (`.new`) and by the test when it was previously run and accepted (`.ref`). `.new` might seem a bit superfluous since the user can always re-evaluate the test expression at the `unitizer` prompt to review the value, but if that evaluation is slow you can save a little time by using `.new`. `.ref` is the only option you have to see what the test used to produce back when it was first accepted into the `unitizer` store. `.new` and `.ref` contain the values produced by the tests, but sometimes it is useful to access other aspects of the test evaluation. To do so you can use `.NEW` and `.REF`: * `.NEW` prints general information about the test. * `.NEW$value` returns the test value; equivalent to typing `.new` at the prompt. * `.NEW$conditions` returns the list of conditions produced by the test. * `.NEW$messsage` returns the stderr captured during test evaluation. * `.NEW$output` returns the screen output captured during test evaluation (note often this will be similar to what you get from `.new` or `.NEW$value` since typing those expressions at the prompt leads to the value being printed). * `.NEW$call` returns the test expression. * `.NEW$aborted` returns whether the test expression invoked an "abort" restart (e.g. called `stop` at some point). You can substitute `.REF` for `.NEW` in any of the above, provided that `.REF` is defined (i.e. that will not work when you are reviewing new tests since there is no corresponding reference test for those by definition). If both `.NEW` and `.REF` are defined, then `.DIFF` will be defined too. `.DIFF` has the same structure as `.NEW` and it contains the result of evaluating `diffobj::diffObj` between each component of `.NEW` and `.REF`. `.diff` is shorthand for `.DIFF$value`. If there are state differences (e.g. search path) you will be able to view those with `.DIFF$state`. ### `ls` Using `ls` at the `unitizer` prompt calls an `unitizer` version of the function (you can call the original with `base::ls()`). This is what happens when we type `ls()` at the first failed test in the `unitizer` we've been reviewing in this vignette: ``` $`objects in new test env:` [1] "res" "x" "y" $`objects in ref test env:` [1] "res" "x" "y" $`unitizer objects:` [1] ".new" ".NEW" ".ref" ".REF" Use `ref(.)` to access objects in ref test env `.new` / `.ref` for test value, `.NEW` / `.REF` for details. unitizer> ``` This special version of `ls` highlights that our environment is more complex than that at the typical R prompt. This is necessary to allow us to review both the newly evaluated objects as well as the objects from the reference `unitizer` store to compare them for differences. For instance, in this example, we can see that there are both new and reference copies of the `res`, `x`, and `y` objects. The reference copies are from the previous time we ran `unitizer`. `ls` also notes what `unitizer` special objects are available. When you type at the prompt the name of one of the objects `ls` lists, you will see the newly evaluated version of that variable. If you wish to see the reference value, then use the `ref` function: ``` unitizer> res intercept slope rsq -3.541306e+13 7.012486e+11 9.386790e-01 attr(,"class") [1] "fastlm" unitizer> ref(res) intercept slope rsq -1717.000000 101.000000 0.938679 attr(,"class") [1] "fastlm" ``` Note that at times when you use `ls` at the `unitizer` promopt you may see something along the lines of: ``` $`objects in ref test env:` [1] "res" "x*" "y'" ``` where object names have symbols such as `*` or `'` appended to them. This happens because `unitizer` does not store the entire environment structure of the reference tests. Here is a description of the possible situations you can run into: * `*` Object existed during reference test evaluation, but is no longer available * `'` Object existed during reference test evaluation, and still does, but it has a different value than it did during reference test evaluation * `**` Object exists now, but did not exist during reference test evaluation For more discussion see `?"healEnvs,unitizerItems,unitizer-method"` and the discussion of [Patchwork Reference Environments](u4_reproducible-tests.html#patchwork-reference-environments). Objects assigned right before a test are part of that test's environment so will always be available. ## `traceback` / `.traceback` Errors that occur during test evaluation are handled, so they do not register in the normal R traceback mechanism. `unitizer` stores the traces from the test evaluation and makes them available via internal versions of `traceback`/`.traceback` that mask the base ones at the interactive `unitizer` prompt. They behave similarly but not identically to the `base` counterparts. In particular, parameter `x` must be NULL. You can access the `base` versions with e.g. `base::traceback`, but those will not display any tracebacks generated by `unitizer`-evaluated code. ## `unitize_dir` `unitize_dir` adds a layer of navigation. Here is what you see after running it on the demo package directory test directory: ``` > (.unitizer.fastlm <- copy_fastlm_to_tmpdir()) # package directory > unitize_dir(.unitizer.fastlm) Inferred test directory location: private/var/folders/56/qcx6p6f94695mh7yw- q9m6z_80000gq/T/RtmpJO7kjd/file43ac57df6164/unitizer.fastlm/tests/unitizer Summary of files in common directory 'tests/unitizer': Pass Fail New *1. fastlm1.R - - 4 *2. fastlm2.R - - 1 *3. unitizer.fastlm.R - - 3 ..................................... - - 8 Legend: * `unitizer` requires review Type number of unitizer to review, 'A' to review all that require review unitizer> ``` Each listing corresponds to a test file. If you were to type `1` at the prompt then you would see the equivalent of the `unitize` process in the demo, since "fastlm1.R" is the file we `unitize` in the demo. The `*` ahead of each file indicates that the file has tests that require review. In this case, all the files have new tests. After we type `1` and go through the `unitize` process for "fastlm1.R" we are returned to the `unitize_dir` prompt: ``` unitizer updated Summary of files in common directory 'tests/unitizer': Pass Fail New $1. fastlm1.R ? ? ? *2. fastlm2.R - - 1 *3. unitizer.fastlm.R - - 3 ..................................... ? ? ? Legend: * `unitizer` requires review $ `unitizer` has been updated and needs to be re-evaluted to recompute summary Type number of unitizer to review, 'A' to review all that require review, 'R' to re-run all updated unitizer> ``` Because we updated "fastlm.R", the statistics `unitize_dir` collected when it first ran all the tests are out of date, which is why they show up as question marks. The `$` also indicates that "fastlm1.R" stats are out of date. There is nothing wrong with this, and you do not need to do anything about it, but if you want you can re-run any unitizers that need to be updated by typing "R" at the prompt. This is what happens if we do so: ``` unitizer> R Summary of files in common directory 'tests/unitizer': Pass Fail New 1. fastlm1.R 4 - - *2. fastlm2.R - - 1 *3. unitizer.fastlm.R - - 3 ..................................... 4 - 4 * `unitizer` requires review Type number of unitizer to review, 'A' to review all that require review unitizer> ``` You can now see that we added all the tests, and upon re-running, they all passed since the source code for `unitizer.fastlm` has not changed. Notice how there is no `*` ahead of the first test anymore. Another option for reviewing tests is to type "A" at the prompt, which would cause `unitize_dir` to put you through each test file that requires review in sequence. unitizer/inst/doc/u5_miscellaneous.html0000644000176200001440000004721514766360132020030 0ustar liggesusers unitizeR - Miscellanea

unitizeR - Miscellanea

Brodie Gaslam

Storing unitized Tests

Default Mode is to Store Tests in rds Files

unitizer stores unit tests and their results. By default, it stores them in rds files in your filesystem. You will be prompted before a file is saved to your filesystem.

The rds file is placed in a directory with the same name as your test file, but with “unitizer” appended. For example, if your tests are in “my_file_name.R”, then unitizer will create a folder called “my_file_name.unitizer/” and put an rds file in it.

See ?get_unitizer for potential alternatives to saving to your file system.

File Space Considerations

If your tests produce massive objects, the unitizer rds file will be massive. Try designing your tests so they will produce the smallest representative data structures needed for your tests to be useful.

Additionally, note that the rds files are binary, which needs to be accounted for when using them in version controlled projects.

Backup Your unitizer Stores

unitizer does not backup the rds beyond the single copy in the aforementioned folder. Unit tests are valuable, and without the rds file unitizer tests become a lot less useful. To the extent you backup your R test files, you should also backup the corresponding “.unitizer/” folder. You could lose / corrupt your unitizer store in many ways. Some non-exhaustive examples:

  • Standard file system SNAFU
  • Careless updates to existing unitizer
  • unitizer developer accidentally introduces a bug that destroys your unitizer

Backup your unitizer stores!

Alternate Store Locations

unitize stores and loads unitizers using the set_unitizer and get_unitizer S3 generics . This means you can implement your own S3 methods for those generics to store the unitizer object off-filesystem (e.g. MySQL databse, etc). See ?get_unitizer for more details, though note this feature is untested.

If you only wish to save your unitizer to a different location in your filesystem than the default, you do not need to resort to these methods as you can provide the target directory with unitize(..., store.id=).

Version Control and Unitizer

Committing Binary Files

The main issue with using unitizer with a version controlled package is that you have to decide whether you want to include the binary rds files in the version control history. Some options:

  • Do not track the binary files at all (but they are valuable and now not backed up).
  • Do not track the binary files at all, but implement a secondary back-up system (this sounds really annoying).
  • Use a backed-up, non-file system store (see “Alternate Store Locations” above).
  • Track the binary files, but manage how often they are committed.

We recommend splitting tests for different functionality into different files. This should mitigate the number of rds files that change with any given source code update, and is good practice anyway. Additionally, we typically only commit the rds files when a feature branch or issue resolution is fully complete.

Additionally a useful git shortcut to add to your .gitconfig file that mitigates how often you commit rds files is:

[alias]
        ad = !git add -u && git reset -- *.rds

This makes it easy to add all the files you are working on except for the rdses. Once you have stabilized a set of tests you can commit the rds.

All this aside, remember that the rdses are ultimately just as important as the test files, and you should commit them occasionally to ensure you do not use valuable test information.

Collaborating with Unitizer

If you merge in a pull request from a third party you do not fully trust, we recommend that you do not accept any commits to the rdses. You can accept and review changes to test expressions, and then unitize against your existing rdses and review the corresponding values.

Modifying an Existing Unitizer

review

review allows you to review all tests in a unitizer rds with the option of dropping tests from it. See ?review.

editCalls

Warning: this is experimental; make sure your test store is backed up before you use it.

editCalls allows you to modify the calls calls stored in a unitizer. This is useful when you decide to change the call (e.g. a function name), but otherwise leave the behavior of the call unchanged. You can then upate your test script and the renamed calls will be matched against the correct values in the unitizer store. Without this you would have to re-review and re-store every test since unitizer identifies tests by the deparsed call.

split

There is currently no direct way to split a unitizer into pieces (see issue #44), but the current work around is to:

  1. Copy the test file and the corresponding unitizer to a new location.
  2. Edit the original test file to remove the tests we want to split off.
  3. Run unitizer and agree to drop all removed tests (hint: this is a good time to use YY).
  4. Edit the new test file and remove the tests that are still in the old test file.
  5. Run unitizer and agree to drop all removed tests.

The net result will be two new unitizer, each with a portion of the tests from the original unitizer. Clearly less than ideal, but will work in a pinch.

Troubleshooting

After Running unitizer Output No Longer Shows on Screen

unitizer sinks stdout and stderr during test evaluation, so it is possible that in some corner cases unitizer exits without releasing sinks. We have put substantial effort in trying to avoid this eventuality, but should it occur, here are some things you can do:

  • Run: while(sink.number()) sink() and sink(type="message") to reset the output stream sinks.
  • Or, restart the R session (type q() followed by ENTER, then “y” or “n” (without quotes) depending on whether you want to save your workspace or not).

Either way, please contact the maintainer as this should not happen.

unitizer Freezes and Pops up “Selection:”

This is almost certainly a result of an R crash. Unfortunately the normal mechanisms to restore stderr don’t seem to work completely with full R crashes, so when you see things like:

+------------------------------------------------------------------------------+
| unitizer for: tests/unitizer/alike.R                                         |
+------------------------------------------------------------------------------+

Running: alike(data.frame(a = integer(), b = factor()), data.frame(a = 1:3, Selection:

what you are not seeing is:

 *** caught segfault ***
address 0x7fdc20000010, cause 'memory not mapped'

Traceback:
 1: .Call(ALIKEC_alike, target, current, int.mode, int.tol, attr.mode)
 2: alike(data.frame(a = factor(), b = factor()), data.frame(a = 1:3,     b = letters[1:3]))

Possible actions:
1: abort (with core dump, if enabled)
2: normal R exit
3: exit R without saving workspace
4: exit R saving workspace

The “Selection:” bit is prompting you to type 1-4 as per above. We will investigate to see if there is a way to address this problem, but the solution likely is not simple since the R crash circumvents the on.exit handlers used to reset the stream redirects. Also, note that in this case the crash is caused by alike, not unitizer (see below).

Running unitizer Crashes R

Every R crash we have discovered while using unitizer was eventually traced to a third party package. Some of the crashes were linked to issues attaching/detaching packages. If you think you might be having an issue with this you can always turn this feature off via the state parameter (not the feature is off by default).

Different Outcomes in Interactive vs. Non Interactive

Watch out for functions that have default arguments of the type:

fun <- function(x, y=getOption('blahblah'))

as those options may be different depending on whether you are running whether you are running R interactively or not. One prime example is parse(..., keep.source = getOption("keep.source")).

Other Topics

Running unitize Within Error Handling Blocks

Because unitize evaluates test expressions within a call to withCallingHandlers, there are some limitations on successfully running unitize inside your own error handling calls. In particular, unitize will not work properly if run inside a tryCatch or try statement. If test expressions throw conditions, the internal withCallingHandlers will automatically hand over control to your tryCatch/try statement without an opportunity to complete unitize computations. Unfortunately there does not seem to be a way around this since we have to use withCallingHandlers so that test statements after non-aborting conditions are run.

See this SO Q/A for more details on the problem.

Overridden Functions

In order to perpetuate the R console prompt illusion, unitizer needs to override some buit-in functionality, including:

  • ls is replaced by a special version that can explore the unitizerItem environments
  • quit and q are wrappers around the base functions that allow unitizer to quit gracefully
  • traceback and .traceback are replaced to read the internally stored traces of the unitizer-handled errors in tests.
  • History is replaced during unitizer prompt evaluations with a temporary version of the history file containing only commands evaluated at the unitizer prompt. The normal history file is restored on exit.
unitizer/inst/doc/u0_unitizer_index.Rmd0000644000176200001440000000257314766101222017765 0ustar liggesusers--- title: "unitizeR - Summary of Vignettes" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{0 - Contents} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- * [Introduction](u1_intro.html) * Quickstart * Comparison to `testthat` * Things to know about `unitizer` * [Test details](u2_tests.html) * What expressions are considered tests * Modify how new tests are compared (default: `all.equal`) * Organize your tests into sections * Track other aspects of test evaluation beyond just value * [Interactive Environment](u3_interactive-env.html) * `unitizer` commands * Navigating `unitizer`s * A guide to test objects * `unitize_dir` * [Reproducible Tests](u4_reproducible-tests.html) * Reviews how `unitizer` tracks and manages different aspects of session state to insulate tests from variability in a user session * Details on evaluation environments, and potential pitfalls * [Miscellaneous](u5_miscellaneous.html) * How unitizers are stored, and possible alternatives * Version control and `unitizer` * How to modify an existing `unitizer` * Troubleshooting * Other issues * Why you cannot run `unitizer` inside `try`/`tryCatch` blocks * Functions that are overriden at the `unitizer` prompt unitizer/inst/doc/rmdhunks/0000755000176200001440000000000014766101222015501 5ustar liggesusersunitizer/inst/doc/rmdhunks/usage.Rmd0000644000176200001440000000151114766101222017247 0ustar liggesusers## Usage `unitizer` stores R expressions and the result of evaluating them so that it can detect code regressions. This is akin to saving test output to a `.Rout.save` file as documented in [Writing R Extensions](https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Package-subdirectories), except that we're storing the actual R objects and it is much easier to review them. To use `unitizer`: * Write test expressions as you would when informally testing code on the command line, and save them to a file (e.g. "my_file_name.R"). * Run `unitize("my_file_name.R")` and follow the prompts. * Continue developing your package. * Re-run `unitize("my_file_name.R")`; if any tests fail you will be able to review and debug them in an interactive prompt. `unitizer` can run in a non-interactive mode for use with `R CMD check`. unitizer/inst/doc/rmdhunks/intro.Rmd0000644000176200001440000000442014766101222017300 0ustar liggesusers## TL;DR `unitizer` simplifies creation, review, and debugging of tests in R. It automatically stores R expressions and the values they produce, so explicit expectations are unnecessary. Every test is easy to write with `unitizer` because testing and using a function are the same. This encourages non-trivial tests that better represent actual usage. Tests fail when the value associated with an expression changes. In interactive mode you are dropped directly into the failing test environment so you may debug it. `unitizer` is on CRAN: ```{r eval=FALSE} install.packages('unitizer') ``` It bakes in a lot of contextual help so you can get started without reading all the documentation. Try the demo to get an idea: ```{r eval=FALSE} library(unitizer) demo(unitizer) ``` Or check out the [screencast](http://htmlpreview.github.io/?https://github.com/brodieG/unitizer/blob/rc/extra/gifshow.html) to see `unitizer` in action. ## Why Another Testing Framework? ### Automated Test Formalization Are you tired of the `deparse`/`dput` then copy-paste R objects into test file dance, or do you use `testthat::expect_equal_to_reference` or other snapshot testing a lot? With `unitizer` you interactively review your code as you would when typing it at the R prompt. Then, with a single keystroke, you tell `unitizer` to store the code, and any values, warnings, or errors it produced, thereby creating a formal regression test. ### Streamlined Debugging Do you wish the nature of a test failure was more immediately obvious? When tests fail, you are shown a proper [diff](https://github.com/brodieG/diffobj) so you can clearly identify _how_ the test failed: ![diff example](https://github.com/brodieG/unitizer/raw/rc/extra/gif/review1.png) Do you wish that you could start debugging your failed tests without additional set-up work? `unitizer` drops you in the test environment so you can debug _why_ the test failed without further ado: ![review example](https://github.com/brodieG/unitizer/raw/rc/extra/gif/review2.png) ### Fast Test Updates Do you avoid improvements to your functions because that would require painstakingly updating many tests? The diffs for the failed tests let you immediately confirm only what you intended changed. Then you can update each test with a single keystroke. unitizer/inst/doc/u3_interactive-env.html0000644000176200001440000007642214766360131020267 0ustar liggesusers unitizeR - The Interactive Environment

unitizeR - The Interactive Environment

Brodie Gaslam

Overview

unitize vs review

unitizer offers three functions to access the interactive review environment: unitize, unitize_dir, and review. unitize is used when you either want to generate a unitizer from a test file, or when you want to compare the re-evaluation of a test file to an existing unitizer. untize_dir does what unitize does, except for a whole directory at a time.

review is a helper function used when you want to review the contents of an existing unitizer. This is useful if you grow uncertain about tests that you previously approved and want to ensure they actually do what you want them to. You can review and potentially remove items from a unitizer with review.

Both these functions use the same interactive environment, though rules therein are slightly different. For example, in review, all the tests are considered passed since there is nothing to compare them to, and the interactive environment will step you through all the passed tests. unitize will normally omit passed tests from the review process.

We will focus on unitize for the rest of this vignette since most of the commentary about it applies equally to unitize_dir and review.

Example Set-up

To examine the interactive environment more thoroughly we will go back to the demo (you can run it with demo(unitizer)). This is the unitizer prompt right after our first failed test when our unitizer.fastlm implementation was returning the wrong values:

> get_slope(res)
unitizer test fails on value mismatch:
*value* mismatch: Mean relative difference: 6943055624
@@ .ref @@
-    [1] 101
@@ .new @@
+    [1] 701248618125

unitizer Commands

Much like the browser() prompt, the unitizer prompt accepts several special expressions that allow you to control unitizer behavior. What the expressions are and what they do depends on context. We will review them in the context of the failed test described above. Look at what the unitizer prompt stated before we started reviewing our failed tests:

- Failed -----------------------------------------------------------------------

The 2 tests in this section failed because the new evaluations do not match the
reference values from the store. Overwrite with new results ([Y]es, [N]o,
[P]rev, [B]rowse, [R]erun, [Q]uit, [H]elp)?

This clearly lays out all the special commands available to us:

  • Y will accept the new value as the correct reference value to use for a test.
  • N will keep the previous reference value as the reference value for future tests.
  • P takes us back to the previously reviewed test (see “Test Navigation” next).
  • B allows us to navigate to any previously reviewed test (see “Test Navigation” next).
  • R toggles re-run mode; when you complete review or exit, unitizer will re-run the tests, which is useful if you made changes to your source code and re-installed your package from the unitizer prompt.
  • Q quits unitizer (see “Quitting unitizer”).
  • H provides contextual help.

If you type any of those letters into the unitizer prompt you will cause unitizer to respond as described above instead of evaluating the expression as it would be at the normal R console prompt. If you have a variable assigned to one of those letters and you wish to access it, you can do so with any of get, (, print, etc. For example, suppose we stored something in Y, then to access it all these commands would work:

  • (Y)
  • get("Y")
  • print(Y)

unitizer checks for an exact match of a user expression to the special command letters, so something like (Y) does not match Y which allows you to reach the value stored in Y.

If at any time you forget what unitizer options are available to you you can just hit the “ENTER” key and unitizer will re-print the options to screen.

You can accept all unreviewed tests in a sub-section, section, or unitizer with YY, YYY, and YYYY respectively. You can also reject them with NN, NNN, and NNNN. Please note that accepting multiple tests without reviewing them is a really bad idea, and you should only resort to these shortcuts when you are absolutely certain of what you are doing. The most common use case for these shortcuts is to drop multiple removed tests from a unitizer.

Test Navigation

Selecting A Test to Review

unitize will present to you all the tests that require review, but if you wish to review a specific test you can use the P (for Previous) and B (for Browse) commands. These commands can come in handy if you realize that you incorrectly accepted or rejected an earlier test, but do not wish to quit unitizer completely and lose all the other properly reviewed tests. P just steps you back to the previous test. B gives you the option to go back to any previously reviewed test.

P is trivially straightforward, so we will not discuss it further. We will type B at the prompt of our second failed test to examine what it does:

unitizer> B
    *1. library(unitizer.fastlm)   .  .  .  .  .  .  .  .  .  .  .  .        -:-
    *2. dat <- data.frame(x = 1:100, y = (1:100)^2)  .  .  .  .  .  .        -:-
    *3. res <- fastlm(dat$x, dat$y)   .  .  .  .  .  .  .  .  .  .  .        -:-
     4. res   .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .   Failed:N
     5. get_slope(res) .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .   Failed:-
     6. get_rsq(res)   .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .   Passed:-
     7. fastlm(1:100, 1:10)  .  .  .  .  .  .  .  .  .  .  .  .  .  .   Passed:-

What test do you wish to review (input a test number, [U]nreviewed)?
unitizer>

The [B]rowse option produces a list of all the tests in the order in which they appear in the test file. You can type the number of a test to review it, or U to go to the first test that hasn’t been reviewed (more on this in a minute). We will examine the line for test #5 in more detail:

     5. get_slope(res) .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .   Failed:-
     ^   ^                                                                ^    ^
     |   |                                                                |    |
     |   +--  Deparsed test expression                    Test status ----+    |
     |                                                                         |
     +- Test ID                                                    User Input -+

The value and order of the test IDs shouldn’t mean anything to you other than being the number to type in if you wish to review that test. Tests that have a * to the left of the test id are expessions that are not reviewed or checked by unitizer (we call these ignored tests).

The test status (see tests outcomes) indicates the outcome of comparison of the reference test in the unitizer store to the newly evaluated ones. The first four tests are ignored tests, so they do not have a status. The User Input column marks which tests have been reviewed and what the user decision was. In this case we had reviewed test #2 and decided not to keep it (hence the “N”). Typically neither ignored tests nor passed tests require user input so they will typically have a “-” as the user input, as will tests that would be reviewed, but haven’t been yet.

Typing U at the review prompt will take you to the first unreviewed test. Since ignored tests and passed tests are not typically reviewed, U will take you to the first unreviewed test that is neither passed nor ignored.

If we type 4 at the prompt, we get:

You are re-reviewing a test; previous selection was: "N"

# Our fast computations do not produce the same results as our
# original tests so they fail.  If you need more detail than the
# provided diff you may use `.new`/`.NEW` or `.ref`/`.REF`.
#
# You should reject these tests by typing 'N' at the prompt since
# they are incorrect.

> res
unitizer test fails on value mismatch:
*value* mismatch: mean relative difference: 19854602162
@@ .ref @@
-     intercept        slope          rsq
-  -1717.000000   101.000000     0.938679
   attr(,"class")
   [1] "fastlm"
@@ .new @@
+      intercept         slope           rsq
+  -3.541306e+13  7.012486e+11  9.386790e-01
   attr(,"class")
   [1] "fastlm"
unitizer>

unitizer tells us we are re-reviewing this test and that previously we had chosen not to keep the new version. At this point we could re-examine the test, and potentially change our previous selection. unitizer also re-displays any comments that were in the source file either ahead of the test or on the same line as the test. We used this feature to document the demo.

You can jump ahead to any test from the review menu, even tests that are typically not reviewed (i.e. ignored or passed, though if you go to those you will be brought back to the review menu once you complete the review because those tests are not part of the normal review flow).

If you skip ahead some tests and then get to the end of the review cycle unitizer will warn you about unreviewed tests.

Finalizing unitizer

Let’s accept the 5th test, which brings us to this prompt:

unitizer> Y

= Finalize Unitizer ============================================================

You will IRREVERSIBLY modify 'tests/unitizer/fastlm1.unitizer' by:
- Replacing 1 out of 2 failed tests

Update unitizer ([Y]es, [N]o, [P]rev, [B]rowse, [R]erun)?
unitizer>

In this case we were reviewing a unitizer with two failed tests, one of which we chose to update with the newer value. unitizer will summarize for you all the changes that it is about to make to the unitizer store. If you type Y at the prompt, the existing unitizer store will be overwritten with the new version you just reviewed.

If you are unsure about the changes you just approved for the unitizer, you can re-review them with R or B. You can also quit without saving your changes by typing N, but once you do so you will no longer be able to recover your changes.

Quitting unitizer

At any point you may quit unitizer by typing Q at the unitizer prompt. If you have already reviewed tests, you will be given the opportunity to save what you have done so far as you would when finalizing the unitizer. Note that if you chose to quit unitizer may exit without giving you the opportunity to review the tests. This will happen if:

  • You did not make any changes to the unitizer (e.g. if you chose N at failed tests, you are keeping the reference value, so the unitizer is not actually changing).
  • And test evaluation took less than getOption("unitizer.prompt.b4.quit.time") seconds (currently 10 seconds).

If you end up in the R debugger from a unitizer (e.g. via debug or recover), quitting the debugger with “Q” will force-exit you from the session without a chance to save any changes.

Differences in review Mode

review works exactly like unitize, except that passed tests are automatically queued up for review, and that the only test statuses you should see are “Passed” or “-”, the latter for ignored tests.

Evaluating Expressions at the unitizer Prompt

As Compared To The Standard R Prompt

The unitizer prompt is designed to emulate the standard R prompt. For the most part you can type any expression that you would type at the R prompt and get the same result as you would there. This means you can examine the objects created by your test script, run R computations, etc.

There are, however, some subtle differences created by the structure of the evaluation environments unitizer uses:

  • Even though you can see objects produced by tests, you can not actually remove them with rm.
  • Any objects you create at the interactive prompt are only available for the test you are currently reviewing, so do not expect them to still be there at subsequent prompts.
  • All expressions are evaluated with options(warn=1) or greater.
  • Other subtle issues discussed at length in the Reproducible Tests Vignette.
  • There are special unitizer objects .new, .NEW, .ref, and .REF that let you review the results of tests (we will discuss these next).
  • ls and traceback/.traceback are masked by special unitizer versions (we will also discuss this next); you can use base::ls/base::traceback if you need the originals.
  • You will have access to any objects created through the pre argument to unitize, though they will not show up in a call to ls.

.new and .ref

As we saw in the demo there are special objects available at the prompt: .new (except for removed/deleted tests), and for all but new tests, .ref. These objects contain the values produced by the newly evaluated test (.new) and by the test when it was previously run and accepted (.ref). .new might seem a bit superfluous since the user can always re-evaluate the test expression at the unitizer prompt to review the value, but if that evaluation is slow you can save a little time by using .new. .ref is the only option you have to see what the test used to produce back when it was first accepted into the unitizer store.

.new and .ref contain the values produced by the tests, but sometimes it is useful to access other aspects of the test evaluation. To do so you can use .NEW and .REF:

  • .NEW prints general information about the test.
  • .NEW$value returns the test value; equivalent to typing .new at the prompt.
  • .NEW$conditions returns the list of conditions produced by the test.
  • .NEW$messsage returns the stderr captured during test evaluation.
  • .NEW$output returns the screen output captured during test evaluation (note often this will be similar to what you get from .new or .NEW$value since typing those expressions at the prompt leads to the value being printed).
  • .NEW$call returns the test expression.
  • .NEW$aborted returns whether the test expression invoked an “abort” restart (e.g. called stop at some point).

You can substitute .REF for .NEW in any of the above, provided that .REF is defined (i.e. that will not work when you are reviewing new tests since there is no corresponding reference test for those by definition).

If both .NEW and .REF are defined, then .DIFF will be defined too. .DIFF has the same structure as .NEW and it contains the result of evaluating diffobj::diffObj between each component of .NEW and .REF. .diff is shorthand for .DIFF$value. If there are state differences (e.g. search path) you will be able to view those with .DIFF$state.

ls

Using ls at the unitizer prompt calls an unitizer version of the function (you can call the original with base::ls()). This is what happens when we type ls() at the first failed test in the unitizer we’ve been reviewing in this vignette:

$`objects in new test env:`
[1] "res" "x"   "y"

$`objects in ref test env:`
[1] "res" "x"   "y"

$`unitizer objects:`
[1] ".new" ".NEW" ".ref" ".REF"

Use `ref(.)` to access objects in ref test env
`.new` / `.ref` for test value, `.NEW` / `.REF` for details.
unitizer>

This special version of ls highlights that our environment is more complex than that at the typical R prompt. This is necessary to allow us to review both the newly evaluated objects as well as the objects from the reference unitizer store to compare them for differences. For instance, in this example, we can see that there are both new and reference copies of the res, x, and y objects. The reference copies are from the previous time we ran unitizer. ls also notes what unitizer special objects are available.

When you type at the prompt the name of one of the objects ls lists, you will see the newly evaluated version of that variable. If you wish to see the reference value, then use the ref function:

unitizer> res
    intercept         slope           rsq
-3.541306e+13  7.012486e+11  9.386790e-01
attr(,"class")
[1] "fastlm"
unitizer> ref(res)
   intercept        slope          rsq
-1717.000000   101.000000     0.938679
attr(,"class")
[1] "fastlm"

Note that at times when you use ls at the unitizer promopt you may see something along the lines of:

$`objects in ref test env:`
[1] "res" "x*"   "y'"

where object names have symbols such as * or ' appended to them. This happens because unitizer does not store the entire environment structure of the reference tests. Here is a description of the possible situations you can run into:

  • * Object existed during reference test evaluation, but is no longer available
  • ' Object existed during reference test evaluation, and still does, but it has a different value than it did during reference test evaluation
  • ** Object exists now, but did not exist during reference test evaluation

For more discussion see ?"healEnvs,unitizerItems,unitizer-method" and the discussion of Patchwork Reference Environments.

Objects assigned right before a test are part of that test’s environment so will always be available.

traceback / .traceback

Errors that occur during test evaluation are handled, so they do not register in the normal R traceback mechanism. unitizer stores the traces from the test evaluation and makes them available via internal versions of traceback/.traceback that mask the base ones at the interactive unitizer prompt. They behave similarly but not identically to the base counterparts. In particular, parameter x must be NULL. You can access the base versions with e.g. base::traceback, but those will not display any tracebacks generated by unitizer-evaluated code.

unitize_dir

unitize_dir adds a layer of navigation. Here is what you see after running it on the demo package directory test directory:

> (.unitizer.fastlm <- copy_fastlm_to_tmpdir())    # package directory
> unitize_dir(.unitizer.fastlm)
Inferred test directory location: private/var/folders/56/qcx6p6f94695mh7yw-
q9m6z_80000gq/T/RtmpJO7kjd/file43ac57df6164/unitizer.fastlm/tests/unitizer

Summary of files in common directory 'tests/unitizer':
                       Pass Fail  New
*1.         fastlm1.R     -    -    4
*2.         fastlm2.R     -    -    1
*3. unitizer.fastlm.R     -    -    3
.....................................
                          -    -    8
Legend:
* `unitizer` requires review

Type number of unitizer to review, 'A' to review all that require review
unitizer>

Each listing corresponds to a test file. If you were to type 1 at the prompt then you would see the equivalent of the unitize process in the demo, since “fastlm1.R” is the file we unitize in the demo. The * ahead of each file indicates that the file has tests that require review. In this case, all the files have new tests. After we type 1 and go through the unitize process for “fastlm1.R” we are returned to the unitize_dir prompt:

unitizer updated

Summary of files in common directory 'tests/unitizer':
                       Pass Fail  New
$1.         fastlm1.R     ?    ?    ?
*2.         fastlm2.R     -    -    1
*3. unitizer.fastlm.R     -    -    3
.....................................
                          ?    ?    ?
Legend:
* `unitizer` requires review
$ `unitizer` has been updated and needs to be re-evaluted to recompute summary

Type number of unitizer to review, 'A' to review all that require review, 'R' to
re-run all updated
unitizer>

Because we updated “fastlm.R”, the statistics unitize_dir collected when it first ran all the tests are out of date, which is why they show up as question marks. The $ also indicates that “fastlm1.R” stats are out of date. There is nothing wrong with this, and you do not need to do anything about it, but if you want you can re-run any unitizers that need to be updated by typing “R” at the prompt. This is what happens if we do so:

unitizer> R

Summary of files in common directory 'tests/unitizer':
                       Pass Fail  New
 1.         fastlm1.R     4    -    -
*2.         fastlm2.R     -    -    1
*3. unitizer.fastlm.R     -    -    3
.....................................
                          4    -    4
* `unitizer` requires review

Type number of unitizer to review, 'A' to review all that require review
unitizer>

You can now see that we added all the tests, and upon re-running, they all passed since the source code for unitizer.fastlm has not changed. Notice how there is no * ahead of the first test anymore.

Another option for reviewing tests is to type “A” at the prompt, which would cause unitize_dir to put you through each test file that requires review in sequence.

unitizer/inst/doc/styles.css0000644000176200001440000000776414766101222015721 0ustar liggesusers/* Styles primarily borrowed from rmarkdown/templates/html_vignette/resources/vignette.css at a time 12/2/2014 when rmarkdown was (and probably still is) under the GPL-3 license */ body { background-color: #fff; margin: 1em auto; max-width: 700px; overflow: visible; padding-left: 2em; padding-right: 2em; font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; font-size: 14px; line-height: 1.5; } #header { text-align: center; } #TOC { clear: both; /*margin: 0 0 10px 10px;*/ padding: 4px; width: 100%; border: 1px solid #CCCCCC; border-radius: 5px; background-color: #f6f6f6; font-size: 13px; line-height: 1.3; } #TOC .toctitle { font-weight: bold; font-size: 15px; margin-left: 5px; } #TOC ul { padding-left: 40px; margin-left: -1.5em; margin-top: 5px; margin-bottom: 5px; } #TOC ul ul { margin-left: -2em; } #TOC li { line-height: 16px; } table { margin: 1em auto; border-width: 1px; border-color: #DDDDDD; border-style: outset; border-collapse: collapse; } table th { border-width: 2px; padding: 5px; border-style: inset; } table td { border-width: 1px; border-style: inset; line-height: 18px; padding: 5px 5px; } table, table th, table td { border-left-style: none; border-right-style: none; } table thead, table tr.even { background-color: #f7f7f7; } p { margin: 1em 0; } blockquote { background-color: #f6f6f6; padding: 0.25em 0.75em; } hr { border-style: solid; border: none; border-top: 1px solid #777; margin: 28px 0; } dl { margin-left: 0; } dl dd { margin-bottom: 13px; margin-left: 13px; } dl dt { font-weight: bold; } ul { margin-top: 0; } ul li { list-style: circle outside; } ul ul { margin-bottom: 0; } pre, code { background-color: #eee; border-radius: 3px; color: #333; } pre { white-space: pre-wrap; /* Wrap long lines */ border-radius: 3px; margin: 5px 0px; padding: 10px; font-size: 85%; } pre:not([class]) { background-color: #eee; } code { font-family: Consolas, Monaco, 'Courier New', monospace; } p > code, li > code, h1 > code, h2 > code, h3 > code, h4 > code, h5 > code, h6 > code { padding: 2px 0px; line-height: 1; font-weight: bold; } div.figure { text-align: center; } img { background-color: #FFFFFF; padding: 2px; border: 1px solid #DDDDDD; border-radius: 3px; border: 1px solid #CCCCCC; margin: 0 5px; } h1 { margin-top: 0; padding-bottom: 3px; font-size: 35px; line-height: 40px; border-bottom: 1px solid #999; } h2 { border-bottom: 1px solid #999; padding-top: 5px; padding-bottom: 2px; font-size: 145%; } h3 { padding-top: 5px; font-size: 120%; } h4 { /*border-bottom: 1px solid #f7f7f7;*/ color: #777; font-size: 105%; } h4.author, h4.date {display: none;} h5, h6 { /*border-bottom: 1px solid #ccc;*/ font-size: 105%; } a { color: #2255dd; font-weight: bold; text-decoration: none; } a:hover { color: #6666ff; } a:visited { color: #800080; } a:visited:hover { color: #BB00BB; } a[href^="http:"] { text-decoration: underline; } a[href^="https:"] { text-decoration: underline; } /* Class described in https://benjeffrey.com/posts/pandoc-syntax-highlighting-css Colours from https://gist.github.com/robsimmons/1172277 */ code > span.kw { color: #555; font-weight: bold; } /* Keyword */ code > span.dt { color: #902000; } /* DataType */ code > span.dv { color: #40a070; } /* DecVal (decimal values) */ code > span.bn { color: #d14; } /* BaseN */ code > span.fl { color: #d14; } /* Float */ code > span.ch { color: #d14; } /* Char */ code > span.st { color: #d14; } /* String */ code > span.co { color: #888888; font-style: italic; } /* Comment */ code > span.ot { color: #007020; } /* OtherToken */ code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ code > span.fu { color: #900; font-weight: bold; } /* Function calls */ code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */ unitizer/inst/doc/u1_intro.R0000644000176200001440000000156514766360127015553 0ustar liggesusers## ----eval=FALSE--------------------------------------------------------------- # install.packages('unitizer') ## ----eval=FALSE--------------------------------------------------------------- # library(unitizer) # demo(unitizer) ## ----eval=FALSE--------------------------------------------------------------- # num.var <- 14523.2342520 # assignments are not considered tests # test_me(num.var) # safe ## ----eval=FALSE--------------------------------------------------------------- # test_me(14523.2342520) # could be deparsed differently ## ----eval=FALSE--------------------------------------------------------------- # chr <- "hello\u044F" # assignments are not considered tests # fun_to_test(chr) # safe ## ----eval=FALSE--------------------------------------------------------------- # fun_to_test("hello\u044F") # could be deparsed differently unitizer/inst/doc/u0_unitizer_index.html0000644000176200001440000001436214766360127020221 0ustar liggesusers unitizeR - Summary of Vignettes

unitizeR - Summary of Vignettes

Brodie Gaslam

  • Introduction
    • Quickstart
    • Comparison to testthat
    • Things to know about unitizer
  • Test details
    • What expressions are considered tests
    • Modify how new tests are compared (default: all.equal)
    • Organize your tests into sections
    • Track other aspects of test evaluation beyond just value
  • Interactive Environment
    • unitizer commands
    • Navigating unitizers
    • A guide to test objects
    • unitize_dir
  • Reproducible Tests
    • Reviews how unitizer tracks and manages different aspects of session state to insulate tests from variability in a user session
    • Details on evaluation environments, and potential pitfalls
  • Miscellaneous
    • How unitizers are stored, and possible alternatives
    • Version control and unitizer
    • How to modify an existing unitizer
    • Troubleshooting
    • Other issues
      • Why you cannot run unitizer inside try/tryCatch blocks
      • Functions that are overriden at the unitizer prompt
unitizer/inst/doc/u4_reproducible-tests.Rmd0000644000176200001440000003750114766101222020547 0ustar liggesusers--- title: "unitizeR - Reproducible Tests" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{4 - Reproducible Tests} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Managing State ### Reproducibility R's emphasis on avoiding side effects generally means that if you run the same R code more than once you can be relatively certain that you will get the same result each time. While this is generally true, there are some exceptions. If you evaluate: ``` x <- x + 5 ``` on the command line, the result will depend on what the value of `x` was in the workspace prior to evaluation. Since workspaces are littered with objects from day to day R use tests are better run elsewhere to avoid conflicts with those objects. There are even more subtle factors that can affect test evaluation. For example, if `x` is an S3 object, the packages loaded on the search path could affect the result of the command. Global options could also affect the outcome. Here is a non-exhaustive list of aspects of state that might affect test outcomes: 1. Workspace / Evaluation Environment. 1. Random seed. 1. Working directory. 1. Search path. 1. Global options. 1. Loaded namespaces. 1. System time. 1. System variables. 1. Locale. 1. etc. Ideally a unit testing framework would nullify these environmental factors such that the only changes in test evaluation are caused by changes in the code that is being tested. `unitizer` provides functionality that sets session state to known "clean" values ahead of the evaluation of each test. Currently `unitizer` attempts to manage the first six aspects of state listed above. **In order to comply with CRAN policies state management is turned off by default.** ### Batch Evaluation and Deferred Review `unitizer` batch processes all the tests when it is first run before it breaks into interactive mode. It does this to: 1. Display useful summary data (how many tests passed/failed in which sections), which is often helpful to know before beginning to debug. 2. Allow time consuming process to run unattended so that the interactive test review process is not interrupted by slow tests. The batch-evaluate-and-review-later creates the need for a mechanism to recreate state for when we review the tests. Imagine trying to figure out why a test failed when all the variables may have been changed by subsequent tests. `unitizer` will always recreate the state of the variables defined by the test scripts, and can optionally recreate other aspects of state provided that is enabled. ### Enabling State Management You can turn on the "suggested" state management level to manage the first four elements of state listed in the previous section. To do so, use `unitize(..., state='suggested')` or `options(unitizer.state='suggested')`. Be sure to read `?unitizerState` before you enable this setting as there are cases when state management may not work. ## Workspace And Evaluation Environments ### Test Environments In order to allow review of each test in its original evaluation environment, each test is evaluated in a separate environment. Each of these environments has for parent the environment of the previous test. This means that a test has access to all the objects created/used by earlier tests, but not objects created/used by subsequent tests. When a later test "modifies" an existing object, the existing object is not really modified; rather, the test creates a new object of the same name in the child environment which masks the object in the earlier test. This is functionally equivalent to overwriting the object as far as the later test is concerned. For the most part this environment trickery should be transparent to the user. An exception is the masking of `ls` and `traceback` with versions that account for the special nature of the `unitizer` REPL. Another is that you can not remove an object created in an earlier test with `rm` (well, it is possible, but the how isn't documented and you are advised not to attempt it). Here is a more complex exception: a <- function() b() NULL # Prevent `a` and `b` being part of the same test b <- function() TRUE a() In this case, when we evaluate `a()` we must step back two environments to find `a`, but that's okay. The problem is that once inside `a`, we must now evaluate `b()`, but `b` is defined in a child environment, not a parent environment so R's object lookup fails. If we remove the NULL this would work, but only because neither the `a` or `b` assignments are tests, so both `a` and `b` would be assigned to the environment of the `a()` call (see [details on tests vignette](u2_tests.html)). If you are getting weird "object not found" errors when you run your tests, but the same code does not generate those errors when run directly in the command line, this illusion could be failing you. In those situations, make sure that you assign all the variables necessary right ahead of the test so they will all get stored in the same environment. ### The Parent Environment In the "suggested" state tracking mode `unitize` will run tests in an environment that has the same parent as `.GlobalEnv` (`UnitizerEnv` below): ``` .GlobalEnv \ +--> package:x --> ... --> Base / TestEnv --> UnitizerEnv ``` This means that objects in the global environment / workspace will not affect your tests. Unfortunately implementing this structure is not trivial because we need to ensure `UnitizerEnv` stays pointed at the environment just below `.GlobalEnv` even as tests modify the search path by calling `library`/`attach`/`detach`, etc. To achieve this `unitizer` traces `base::library`, `base::attach`, and `base::detach` **when state tracking is enabled** and **only when `unitizer` is running**. Any time any of those functions is called, `unitizer` updates the parent of `UnitizerEnv` to be the second environment on the search path (i.e. the parent of `.GlobalEnv`). So, for example, if a test calls `library(z)`, the new search path would look like so: ``` .GlobalEnv \ +--> package:y --> package:x --> ... --> Base / TestEnv --> UnitizerEnv ``` Clearly overriding such fundamental functions such as `library` / `attach` / `detach` is not good form. We recognize this, and try to do the overriding in as lightweight a manner as possible by tracing them only to record the search path while `unitizer` is evaluating. This should be completely transparent to the user. The untracing is registered to the `on.exit` of `unitize` so the functions should get untraced even if `unitize` fails. Aside from the issues raised above, this method is not completely robust. Any tests that turn tracing off using `tracingState`, or themselves `trace`/`untrace` any of `library` / `attach` / `detach` will interfere with `unitizer`. If you must do any of the above you should consider specifying a parent environment for your tests through the `state` parameter to `unitize` (see `?unitize`). Some functions that expect to find `.GlobalEnv` on the search path may not work as expected. For example, `setClass` uses `topenv` by default to find an environment to define classes in. When `setClass` is called at the top level, this normally results in the class being defined in `.GlobalEnv`, but if `.GlobalEnv` is not available `setClass` will attempt to define the class in the first environment on the search path, which will likely be a locked namespace. You can work around this by specifying an environment in calls to `setClass`. ### Package Namespace as Parent Environment Sometimes it is convenient to use the namespace of a package as the parent environment. This allows you to write tests that use internal package functions without having to resort to `:::`. You can set the parent evaluation environment with the `state` argument to `unitize` / `unitize_dir`. See `?unitize` and `?unitizeState`. If you do use this feature keep in mind that your tests will be directly exposed to the global environment as well since R looks through the search path starting at the global environment after looking in the package namespace and imports (your package code is always exposed to this). ### Issues With Reference Objects For the most part R is a copy-on-modify language, which allows us to employ the trickery described above. There are however "reference" objects that are not copied when they are modified. Notable examples include environments, reference classes, and `data.table`. Since our trickery requires us to keep copies of each object in different environments as they are modified, it does not work with reference objects since they are not automatically duplicated. The main consequence of this is that when you are reviewing a test that involves a reference object, the value of that reference object during review will be the value after the last reference modification, which may have been made after the test you are reviewing. The tests will still work as they should, passing if you did not introduce regressions, and failing otherwise. However if you review a failed test you may have a hard time making sense of what happened since the objects you review will may not have the values they had when the test was actually run. ### Patchwork Reference Environments When we review `unitizer` tests, it is possible to end up in a situation where we wish to update our store by keeping a mix of the new tests as well as some of the old ones. This leads to some complications because in order to faithfully reproduce the environments associated with both the reference and the new tests we would potentially have to store the entire set of environments produced by the test script for both the new and reference tests. Even worse, if we re-run `unitizer` again, we run the risk of having to store yet another set of environments (the old reference environments, what were new environments but became reference ones on this additional run, and the new environments created by this third run). The problem continues to grow with as each incremental run of the `unitizer` script potentially creates the need to store yet another set of environments. As a work-around to this problem `unitizer` only keeps the environment associated with the actual reference tests you chose to keep (e.g. when you type `N` at the `unitizer` prompt when reviewing a failed test). `unitizer` then grafts that test and its environment to the environment chain from the newly evaluated tests (note that for all tests that pass, we keep the new version of the tests, not the reference one). This means that in future `unitizer` runs where you examine this same reference test, the other "reference" objects available for inspection may not be from the same evaluation that produced the test. The `ls` command will highlight which objects are from the same evaluation vs which ones are not (see the [discussion on `ls`](u3_interactive-env.html#ls)). This is not an ideal outcome, but the compromise was necessary to avoid the possibility of ever increasing `unitizer` stores. For more details see `?"healEnvs,unitizerItems,unitizer-method"`. ## Clean Search Paths ### Description / Implementation One other way tests can change behavior unexpectedly is if the packages / objects attached to the search path change. A simple example is a test script that relies on package "X", and the user attached that package at some point during interactive use, but forgot to add the requisite `library` call to the test script itself. During testing, the scripts will work fine, but at some future date if the test scripts are run again they are likely to fail due to the dependency on the package that is not explicitly loaded in the test scripts. In the "suggested" state tracking mode `unitizer` runs on a "trimmed" search path that contains only the packages loaded by in a freshly loaded R session (i.e. the packages between `package:base` and `package:stats`; see `?unitizerState`). You will need to explicitly load packages that your tests depend on in your test file (e.g. by using `library()`). `unitize` will restore the search path to its original state once you complete review. `unitizer` also relies on tracing `library`/`attach`/`detach` to implement this feature, so the caveats described [above](#The-Parent-Environment) apply equally here. `unitizer` **does not modify the search path itself** other than by using `library`, `attach`, and `detach`. When search path tracking is enabled, `unitizer` tracks the versions of the packages on the search path. If tests fails and package versions on the search path have changes since the reference test was stored, you will be alerted. ### Potential Issues When `unitizer` manipulates the search path it restores the original one by using `library`/`attach` on any previously detached objects or packages. This generally works fine, but detaching and re-attaching packages is not and cannot be the same as loading a package or attaching an environment for the first time. For example, S3 method registration is not undone when detaching a package, or even unloading its namespace. See discussion in `?detach` and in `?unitizerState`. One known problem is the use of `devtools::load_all` and similar which place a pretend package environment on the search path. Such packages cannot be re-loaded with `library` so the re-attach process will fail (see [#252](https://github.com/brodieG/unitizer/issues/252)). Another issue is attached environments that contain references to themselves, as the `tools:rstudio` environment attached by `Rstudio` does. It contains functions that have for environment the `tools:rstudio` environment. The problem is that once that environment is detached from the search path, those functions no longer have access to the search path. Re-attaching the environment to the search path does not solve the problem because `attach` attaches a _copy_ of the environment, not the environment itself. This new environment will contain the same objects as the original environment, but all the functions therein will have for environment the original detached environment, not the copy that is attached to the search path. For the specific `tools::rstudio` problem we work around the issue by keeping it on the search path even search path tracking is enabled (you can over-ride this by changing `search.path.keep`, or, if you have environments on your search path with similar properties, add their names to `search.path.keep`). Other options include re-attaching with `parent.env<-` instead of `attach`, but messing with the search path in that way seems to be exactly what R core warns about in `?parent.env`: > The replacement function parent.env<- is extremely dangerous as it can be used to destructively change environments in ways that violate assumptions made by the internal C code. It may be removed in the near future. ## Global Options `unitizer` can track and reset global options. Because many packages set options when their namespaces are attached, implementation of this feature must be coordinated with a careful management of loaded namespaces. For example, we can reasonably easily set options to be what you would expect in a freshly loaded vanilla R session, but if some namespaces as otherwise they would be in a compromised set with their options wiped out. `unitizer` can manage search paths and namespaces, but unfortunately some package namespaces cannot be unloaded so options management can be problematic when such packages are involved (one example is `data.table`). Because of this options management is not enabled in the "suggested" state management mode. Note that no matter what tests are always run with `options(warn=1)` and `options(error=NULL)`. See `?unitizer.opts` for more details. ## Random Seed See `?unitizerState`. ## Working Directory See `?unitizerState`. unitizer/inst/doc/u4_reproducible-tests.html0000644000176200001440000006212614766360131021000 0ustar liggesusers unitizeR - Reproducible Tests

unitizeR - Reproducible Tests

Brodie Gaslam

Managing State

Reproducibility

R’s emphasis on avoiding side effects generally means that if you run the same R code more than once you can be relatively certain that you will get the same result each time. While this is generally true, there are some exceptions. If you evaluate:

x <- x + 5

on the command line, the result will depend on what the value of x was in the workspace prior to evaluation. Since workspaces are littered with objects from day to day R use tests are better run elsewhere to avoid conflicts with those objects.

There are even more subtle factors that can affect test evaluation. For example, if x is an S3 object, the packages loaded on the search path could affect the result of the command. Global options could also affect the outcome.

Here is a non-exhaustive list of aspects of state that might affect test outcomes:

  1. Workspace / Evaluation Environment.
  2. Random seed.
  3. Working directory.
  4. Search path.
  5. Global options.
  6. Loaded namespaces.
  7. System time.
  8. System variables.
  9. Locale.
  10. etc.

Ideally a unit testing framework would nullify these environmental factors such that the only changes in test evaluation are caused by changes in the code that is being tested. unitizer provides functionality that sets session state to known “clean” values ahead of the evaluation of each test. Currently unitizer attempts to manage the first six aspects of state listed above.

In order to comply with CRAN policies state management is turned off by default.

Batch Evaluation and Deferred Review

unitizer batch processes all the tests when it is first run before it breaks into interactive mode. It does this to:

  1. Display useful summary data (how many tests passed/failed in which sections), which is often helpful to know before beginning to debug.
  2. Allow time consuming process to run unattended so that the interactive test review process is not interrupted by slow tests.

The batch-evaluate-and-review-later creates the need for a mechanism to recreate state for when we review the tests. Imagine trying to figure out why a test failed when all the variables may have been changed by subsequent tests. unitizer will always recreate the state of the variables defined by the test scripts, and can optionally recreate other aspects of state provided that is enabled.

Enabling State Management

You can turn on the “suggested” state management level to manage the first four elements of state listed in the previous section. To do so, use unitize(..., state='suggested') or options(unitizer.state='suggested'). Be sure to read ?unitizerState before you enable this setting as there are cases when state management may not work.

Workspace And Evaluation Environments

Test Environments

In order to allow review of each test in its original evaluation environment, each test is evaluated in a separate environment. Each of these environments has for parent the environment of the previous test. This means that a test has access to all the objects created/used by earlier tests, but not objects created/used by subsequent tests. When a later test “modifies” an existing object, the existing object is not really modified; rather, the test creates a new object of the same name in the child environment which masks the object in the earlier test. This is functionally equivalent to overwriting the object as far as the later test is concerned.

For the most part this environment trickery should be transparent to the user. An exception is the masking of ls and traceback with versions that account for the special nature of the unitizer REPL. Another is that you can not remove an object created in an earlier test with rm (well, it is possible, but the how isn’t documented and you are advised not to attempt it). Here is a more complex exception:

a <- function() b()
NULL                 # Prevent `a` and `b` being part of the same test
b <- function() TRUE
a()

In this case, when we evaluate a() we must step back two environments to find a, but that’s okay. The problem is that once inside a, we must now evaluate b(), but b is defined in a child environment, not a parent environment so R’s object lookup fails. If we remove the NULL this would work, but only because neither the a or b assignments are tests, so both a and b would be assigned to the environment of the a() call (see details on tests vignette).

If you are getting weird “object not found” errors when you run your tests, but the same code does not generate those errors when run directly in the command line, this illusion could be failing you. In those situations, make sure that you assign all the variables necessary right ahead of the test so they will all get stored in the same environment.

The Parent Environment

In the “suggested” state tracking mode unitize will run tests in an environment that has the same parent as .GlobalEnv (UnitizerEnv below):

             .GlobalEnv
                       \
                        +--> package:x --> ... --> Base
                       /
TestEnv --> UnitizerEnv

This means that objects in the global environment / workspace will not affect your tests.

Unfortunately implementing this structure is not trivial because we need to ensure UnitizerEnv stays pointed at the environment just below .GlobalEnv even as tests modify the search path by calling library/attach/detach, etc. To achieve this unitizer traces base::library, base::attach, and base::detach when state tracking is enabled and only when unitizer is running. Any time any of those functions is called, unitizer updates the parent of UnitizerEnv to be the second environment on the search path (i.e. the parent of .GlobalEnv). So, for example, if a test calls library(z), the new search path would look like so:

             .GlobalEnv
                       \
                        +--> package:y --> package:x --> ... --> Base
                       /
TestEnv --> UnitizerEnv

Clearly overriding such fundamental functions such as library / attach / detach is not good form. We recognize this, and try to do the overriding in as lightweight a manner as possible by tracing them only to record the search path while unitizer is evaluating. This should be completely transparent to the user. The untracing is registered to the on.exit of unitize so the functions should get untraced even if unitize fails.

Aside from the issues raised above, this method is not completely robust. Any tests that turn tracing off using tracingState, or themselves trace/untrace any of library / attach / detach will interfere with unitizer. If you must do any of the above you should consider specifying a parent environment for your tests through the state parameter to unitize (see ?unitize).

Some functions that expect to find .GlobalEnv on the search path may not work as expected. For example, setClass uses topenv by default to find an environment to define classes in. When setClass is called at the top level, this normally results in the class being defined in .GlobalEnv, but if .GlobalEnv is not available setClass will attempt to define the class in the first environment on the search path, which will likely be a locked namespace. You can work around this by specifying an environment in calls to setClass.

Package Namespace as Parent Environment

Sometimes it is convenient to use the namespace of a package as the parent environment. This allows you to write tests that use internal package functions without having to resort to :::. You can set the parent evaluation environment with the state argument to unitize / unitize_dir. See ?unitize and ?unitizeState.

If you do use this feature keep in mind that your tests will be directly exposed to the global environment as well since R looks through the search path starting at the global environment after looking in the package namespace and imports (your package code is always exposed to this).

Issues With Reference Objects

For the most part R is a copy-on-modify language, which allows us to employ the trickery described above. There are however “reference” objects that are not copied when they are modified. Notable examples include environments, reference classes, and data.table. Since our trickery requires us to keep copies of each object in different environments as they are modified, it does not work with reference objects since they are not automatically duplicated.

The main consequence of this is that when you are reviewing a test that involves a reference object, the value of that reference object during review will be the value after the last reference modification, which may have been made after the test you are reviewing. The tests will still work as they should, passing if you did not introduce regressions, and failing otherwise. However if you review a failed test you may have a hard time making sense of what happened since the objects you review will may not have the values they had when the test was actually run.

Patchwork Reference Environments

When we review unitizer tests, it is possible to end up in a situation where we wish to update our store by keeping a mix of the new tests as well as some of the old ones. This leads to some complications because in order to faithfully reproduce the environments associated with both the reference and the new tests we would potentially have to store the entire set of environments produced by the test script for both the new and reference tests. Even worse, if we re-run unitizer again, we run the risk of having to store yet another set of environments (the old reference environments, what were new environments but became reference ones on this additional run, and the new environments created by this third run). The problem continues to grow with as each incremental run of the unitizer script potentially creates the need to store yet another set of environments.

As a work-around to this problem unitizer only keeps the environment associated with the actual reference tests you chose to keep (e.g. when you type N at the unitizer prompt when reviewing a failed test). unitizer then grafts that test and its environment to the environment chain from the newly evaluated tests (note that for all tests that pass, we keep the new version of the tests, not the reference one). This means that in future unitizer runs where you examine this same reference test, the other “reference” objects available for inspection may not be from the same evaluation that produced the test. The ls command will highlight which objects are from the same evaluation vs which ones are not (see the discussion on ls).

This is not an ideal outcome, but the compromise was necessary to avoid the possibility of ever increasing unitizer stores. For more details see ?"healEnvs,unitizerItems,unitizer-method".

Clean Search Paths

Description / Implementation

One other way tests can change behavior unexpectedly is if the packages / objects attached to the search path change. A simple example is a test script that relies on package “X”, and the user attached that package at some point during interactive use, but forgot to add the requisite library call to the test script itself. During testing, the scripts will work fine, but at some future date if the test scripts are run again they are likely to fail due to the dependency on the package that is not explicitly loaded in the test scripts.

In the “suggested” state tracking mode unitizer runs on a “trimmed” search path that contains only the packages loaded by in a freshly loaded R session (i.e. the packages between package:base and package:stats; see ?unitizerState). You will need to explicitly load packages that your tests depend on in your test file (e.g. by using library()). unitize will restore the search path to its original state once you complete review.

unitizer also relies on tracing library/attach/detach to implement this feature, so the caveats described above apply equally here. unitizer does not modify the search path itself other than by using library, attach, and detach.

When search path tracking is enabled, unitizer tracks the versions of the packages on the search path. If tests fails and package versions on the search path have changes since the reference test was stored, you will be alerted.

Potential Issues

When unitizer manipulates the search path it restores the original one by using library/attach on any previously detached objects or packages. This generally works fine, but detaching and re-attaching packages is not and cannot be the same as loading a package or attaching an environment for the first time. For example, S3 method registration is not undone when detaching a package, or even unloading its namespace. See discussion in ?detach and in ?unitizerState.

One known problem is the use of devtools::load_all and similar which place a pretend package environment on the search path. Such packages cannot be re-loaded with library so the re-attach process will fail (see #252).

Another issue is attached environments that contain references to themselves, as the tools:rstudio environment attached by Rstudio does. It contains functions that have for environment the tools:rstudio environment. The problem is that once that environment is detached from the search path, those functions no longer have access to the search path. Re-attaching the environment to the search path does not solve the problem because attach attaches a copy of the environment, not the environment itself. This new environment will contain the same objects as the original environment, but all the functions therein will have for environment the original detached environment, not the copy that is attached to the search path.

For the specific tools::rstudio problem we work around the issue by keeping it on the search path even search path tracking is enabled (you can over-ride this by changing search.path.keep, or, if you have environments on your search path with similar properties, add their names to search.path.keep). Other options include re-attaching with parent.env<- instead of attach, but messing with the search path in that way seems to be exactly what R core warns about in ?parent.env:

The replacement function parent.env<- is extremely dangerous as it can be used to destructively change environments in ways that violate assumptions made by the internal C code. It may be removed in the near future.

Global Options

unitizer can track and reset global options. Because many packages set options when their namespaces are attached, implementation of this feature must be coordinated with a careful management of loaded namespaces. For example, we can reasonably easily set options to be what you would expect in a freshly loaded vanilla R session, but if some namespaces as otherwise they would be in a compromised set with their options wiped out.

unitizer can manage search paths and namespaces, but unfortunately some package namespaces cannot be unloaded so options management can be problematic when such packages are involved (one example is data.table). Because of this options management is not enabled in the “suggested” state management mode.

Note that no matter what tests are always run with options(warn=1) and options(error=NULL).

See ?unitizer.opts for more details.

Random Seed

See ?unitizerState.

Working Directory

See ?unitizerState.

unitizer/inst/doc/u1_intro.html0000644000176200001440000046311214766360131016311 0ustar liggesusers unitizer - Interactive R Unit Tests

unitizer - Interactive R Unit Tests

Brodie Gaslam

TL;DR

unitizer simplifies creation, review, and debugging of tests in R. It automatically stores R expressions and the values they produce, so explicit expectations are unnecessary. Every test is easy to write with unitizer because testing and using a function are the same. This encourages non-trivial tests that better represent actual usage.

Tests fail when the value associated with an expression changes. In interactive mode you are dropped directly into the failing test environment so you may debug it.

unitizer is on CRAN:

install.packages('unitizer')

It bakes in a lot of contextual help so you can get started without reading all the documentation. Try the demo to get an idea:

library(unitizer)
demo(unitizer)

Or check out the screencast to see unitizer in action.

Why Another Testing Framework?

Automated Test Formalization

Are you tired of the deparse/dput then copy-paste R objects into test file dance, or do you use testthat::expect_equal_to_reference or other snapshot testing a lot?

With unitizer you interactively review your code as you would when typing it at the R prompt. Then, with a single keystroke, you tell unitizer to store the code, and any values, warnings, or errors it produced, thereby creating a formal regression test.

Streamlined Debugging

Do you wish the nature of a test failure was more immediately obvious?

When tests fail, you are shown a proper diff so you can clearly identify how the test failed:

diff example
diff example

Do you wish that you could start debugging your failed tests without additional set-up work?

unitizer drops you in the test environment so you can debug why the test failed without further ado:

review example
review example

Fast Test Updates

Do you avoid improvements to your functions because that would require painstakingly updating many tests?

The diffs for the failed tests let you immediately confirm only what you intended changed. Then you can update each test with a single keystroke.

How Does unitizer Differ from testthat?

Testing Style

unitizer requires you to review test outputs and confirm they are as expected. testthat requires you to assert what the test outputs should be beforehand. There are trade-offs between these strategies that we illustrate here, first with testthat:

vec <- c(10, -10, 0, .1, Inf, NA)
expect_error(
  log10(letters),
  "Error in log10\\(letters\\) : non-numeric argument to mathematical function\n"
)
expect_equal(log10(vec), c(1, NaN, -Inf, -1, Inf, NA))
expect_warning(log10(vec), "NaNs produced")

And with unitizer:

vec <- c(10, -10, 0, .1, Inf, NA)
log10(letters)                            # input error
log10(vec)                                # succeed with warnings

These two unit test implementations are functionally equivalent. There are benefits to both approaches. In favor of unitizer:

  • Tests are easy to write.
  • Tests with non-trivial outputs are easy to write, which encourages more realistic testing of functionality.
  • Conditions are captured automatically, with no need for special handling.
  • You can immediately review failing tests in an interactive environment.
  • Updating tests when function output legitimately changes is easy.

In favor of testthat:

  • The tests are self documenting; expected results are obvious.
  • Once you write the test you are done; with unitizer you still need to unitize and review the tests.
  • Tests are usually all-plain text, whereas unitizer stores reference values in binary RDSes (see Collaborating with Unitizer).

unitizer is particularly convenient when the tests return complex objects (e.g as lm does) and/or produce conditions. There is no need for complicated assertions involving deparsed objects, or different workflows for snapshots.

Converting testthat tests to unitizer

If you have a stable set of tests it is probably not worth trying to convert them to unitizer unless you expect the code those tests cover to change substantially. If you do decide to convert tests you can use the provided testthat_translate* functions (see ?testthat_translate_file).

unitizer and Packages

The simplest way to use unitizer as part of your package development process is to create a tests/unitizer folder for all your unitizer test scripts. Here is a sample test structure from the demo package:

unitizer.fastlm/         # top level package directory
    R/
    tests/
        run.R            # <- calls `unitize` or `unitize_dir`
        unitizer/
            fastlm.R
            cornerCases.R

And this is what the tests/run.R file would look like

library(unitizer)
unitize("unitizer/fastlm.R")
unitize("unitizer/cornerCases.R")

or equivalently

library(unitizer)
unitize_dir("unitizer")

The path specification for test files should be relative to the tests directory as that is what R CMD check uses. When unitize is run by R CMD check it will run in a non-interactive mode that will succeed only if all tests pass.

You can use any folder name for your tests, but if you use “tests/unitizer” unitize will look for files automatically, so the following work assuming your working directory is a folder within the package:

unitize_dir()          # same as `unitize_dir("unitizer")`
unitize("fast")        # same as `unitize("fastlm.R")`
unitize()              # Will prompt for a file to `unitize`

Remember to include unitizer as a “suggests” package in your DESCRIPTION file.

Things You Should Know About unitizer

unitizer Writes To Your Filesystem

The unitized tests need to be saved someplace, and the default action is to save to the same directory as the test file. You will always be prompted by unitizer before it writes to your file system. See storing unitized tests for implications and alternatives.

Tests Pass If They all.equal Stored Reference Values

Once you have created your first unitizer with unitize, subsequent calls to unitize will compare the old stored value to the new one using all.equal. You can change the comparison function by using unitizer_sect (see tests vignette).

Test Expressions Are Stored Deparsed

This means you need to be careful with expressions that may deparse differently on different machines or with different settings. Unstable deparsing will prevent tests from matching their previously stored evaluations.

For example, in order to avoid round issues with numerics, it is better to use:

num.var <- 14523.2342520  # assignments are not considered tests
test_me(num.var)          # safe

Instead of:

test_me(14523.2342520)    # could be deparsed differently

Similarly issues may arise with non-ASCII characters, so use:

chr <- "hello\u044F"      # assignments are not considered tests
fun_to_test(chr)          # safe

Instead of:

fun_to_test("hello\u044F") # could be deparsed differently

This issue does not affect the result of running the test as that is never deparsed.

Increase Reproducibility with Advanced State Management

unitizer can track and manage many aspects of state to make your tests more reproducible. For example, unitizer can reset your R package search path to what is is found in a fresh R session prior to running tests to avoid conflicts with whatever libraries you happen to have loaded at the time. Your session state is restored when unitizer exits. The following aspects of state can be actively tracked and managed:

  • Search path (including removing the global environment from search path)
  • Random seed
  • Working directory
  • Options
  • Loaded namespaces

State management is turned off by default because it requires tracing some base functions which is against CRAN policy, and generally affects session state in uncommon ways. If you wish to enable this feature use unitize(..., state='suggested') or options(unitizer.state='suggested'). For more details including potential pitfalls see ?unitizerState and the reproducible tests vignette.

Beware of browser/debug/recover

If you enter the interactive browser as e.g. invoked by debug you should exit it by allowing evaluation to complete (e.g. by hitting “c” until control returns to the unitizer prompt). If you instead hit “Q” while in browser mode you will completely exit the unitizer session losing any modifications you made to the tests under review.

Reference Objects

Tests that modify objects by reference are not perfectly suited for use with unitizer. The tests will work fine, but unitizer will only be able to show you the most recent version of the reference object when you review a test, not what it was like when the test was evaluated. This is only an issue with reference objects that are modified (e.g. environments, RC objects, data.table modified with := or set*).

unitizer Is Complex

In order to re-create the feel of the R prompt within unitizer we resorted to a fair bit of trickery. For the most part this should be transparent to the user, but you should be aware it exists in the event something unexpected happens that exposes it. Here is a non-exhaustive list of some of the tricky things we do:

  • Each tests is evaluated in its own environment, a child of the previous test’s environment; because R looks up objects in parent environments it appears that all tests are evaluated in one environment (see interactive environment vignette)
  • We mask some base functions.
  • .Last.value will not work
  • We sink stdout and stderr during test evaluation to capture those streams (see details on tests vignette), though we take care to do so responsibly
  • We parse the test file and extract comments so that they can be attached to the correct test for review
  • The history file is temporary replaced so that your unitizer interactions do not pollute it

Avoid Tests That Require User Input

In particular, you should avoid evaluating tests that invoke debugged functions, or introducing interactivity by using something like options(error=recover), or readline, or some such. Tests will work, but the interaction will be challenging because you will have to do it with stderr and stdout captured…

Avoid running unitize within try / tryCatch Blocks

Doing so will cause unitize to quit if any test expressions throw conditions. See discussion in error handling.

Masked Functions

Some base functions are masked at the unitizer prompt:

  • q and quit are masked to give the user an opportunity to cancel the quit action in case they meant to quit from unitizer instead of R. Use Q to quit from unitizer, as you would from browser.
  • ls is masked with a specialized version for use in unitizer.
  • traceback is masked to report the most recent error in the order presented by the unitizer prompt.

See miscellaneous topics vignette.

unitizer/inst/doc/u2_tests.Rmd0000644000176200001440000003221414766101222016064 0ustar liggesusers--- title: "unitizeR - Test Details" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{2 - Test Details} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Understanding Tests ### Test Outcomes When `unitize` is run with a test file against an existing `unitizer` store, each test in the file is matched and compared to the corresponding test in the store. Here is a comprehensive list of possible outcomes: * **New**: a test present in the file is not in the store and needs to be reviewed to confirm it is correct. * **Passed**: the test matched the reference test in the store and need not be reviewed. * **Failed**: the evaluation of the test from the file differs from the one produced by same expression in the store. * **Deleted/Removed**: a test present in the `unitizer` store no longer exists in the test file so you will be prompted to remove it from the store. * **Corrupted/Error**: an error occurred while attempting to compare the file and store tests; this should occur very rarely and is likely the result of using a custom comparison function to compare the tests (see [`unitizer_sect`](#controlling-test-comparison) for more details on custom comparison functions). Because the comparison function itself failed, `unitizer` has no way of knowing whether the test passed or failed; you can think of it as an `NA` outcome. When reviewing tests, `unitizer` will group tests by test type, so you will review all new tests in one go, then the failed tests, and so on. As a result, the order that you review tests may not be the same as the order they appear in in the test file. ### What Constitutes a Test? As noted previously simple assignments are not considered tests. They are stored in the `unitizer` store, but you are not asked to review them, and their values are not compared to existing reference values prior to storage. The implicit assumption is that if there is an assignment the intent is to use the resulting object in some later test at which point any issues will crop up. Skipping assignment review saves some unnecessary user interaction. You can force assignments to become tests by wrapping them in parentheses: ``` a <- my_fun(25) # this is not a test (a <- my_fun(42)) # this is a test ``` The actual rule `unitizer` uses to decide whether an expression is a test or not is whether it returns invisibly without signalling conditions. Wrapping parentheses around an expression that returns invisibly makes it visible, which is why assignments in parentheses become tests. Conversely, you can wrap an expression in `invisible(...)` to prevent it from being treated as a test so long as it does not signal conditions. Recall that newly evaluated tests are matched to reference tests by deparsing the test expression. Some expressions such as strings with non-ASCII bytes (even in their escaped form) or numbers with long decimal tails will deparse differently on different systems, and thus may cause tests to fail to match. You can still use these by storing them in a variable, as the assignment step is not a test: ``` chr <- "hello\u044F" # this is not a test fun_to_test(chr) # this is a test ``` ### `unitizer` Test Components The following aspects of a unitizer tests are recorded for future comparison: * Value. * Conditions. * Screen (stdout) output. * Message (stderr) output. * Whether the expression issued an "abort" `invokeRestart` (e.g. was `stop` called in the expression). Currently only the first two elements are actually compared when determining whether a test passes or fails. These two should capture almost all you would care about from a unit test perspective. Screen output is omitted from comparison because it can be caused to vary substantially by factors unrelated to source code changes (e.g. console display width). Screen output will also seem identical to the value as most of the time screen output is just the result of printing the return value of an expression. This will not be the case if the expression itself prints to `stdout` explicitly, or if the function returns invisibly. Message output is omitted because all typical mechanisms for producing `stderr` output also produce conditions with messages embedded, so it is usually superfluous to compare them. One exception would be if an expression `cat`ed to `stderr` directly. The "abort" `invokeRestart` is omitted because it generally is implied by the presence of an error condition and actively monitoring it clutters the diagnostic messaging produced by `unitizer`. It exists because it is possible to signal a "stop" condition without actually triggering the "abort" restart so in some cases it could come in handy. While we omit the last three components from comparison, this is just default behavior. You can change this by using the `compare` argument for [`unitizer_sect`](#controlling-test-comparison). ## Sections ### `untizer_sect` Often it is useful to group tests in sections for the sake of documentation and clarity. Here is a slghtly modified version of the original demo file with sections: ``` unitizer_sect("Basic Tests", { library(unitizer.fastlm) x <- 1:10 y <- x ^ 3 res <- fastlm(x, y) get_slope(res) }) unitizer_sect("Advanced Tests", { 2 * get_slope(res) + get_intercept(res) get_rsq(res) }) ``` Now re-running `unitizer` segments everything by section (note, first few lines are set-up): ``` (.unitizer.fastlm <- copy_fastlm_to_tmpdir()) update_fastlm(.unitizer.fastlm, version="0.1.2") install.packages(.unitizer.fastlm, repos=NULL, type='src', quiet=TRUE) unitize(file.path(.unitizer.fastlm, "tests", "unitizer", "unitizer.fastlm.R")) +------------------------------------------------------------------------------+ | unitizer for: tests/unitizer/unitizer.fastlm.R | +------------------------------------------------------------------------------+ Pass Fail New 1. Basic Tests - - 1 2. Advanced Tests - - 2 .................................. - - 3 ``` If there are tests that require reviewing, each section will be reviewed in turn. Note that `unitizer_sect` does not create separate evaluation environments for each section. Any created object will be available to all lexically subsequent tests, regardless of whether they are in the same section or not. Additionally `on.exit` expressions in `unitizer_sect` are evaluated immediately, not on exit. It is possible to have nested sections, though at this point in time `unitizer` only explicitly reports information at the outermost section level. ### Controlling Test Comparison By default tested components (values and conditions) are compared with `all.eq`, a wrapper around `all.equal` that returns FALSE on inequality instead of a character description of the inequality. If you want to override the function used for value comparisons it is as simple as creating a new section for the tests you want to compare differently and use the `compare` argument: ``` unitizer_sect("Accessor Functions", compare=identical, { get_slope(res) get_rsq(res) get_intercept(res) } ) ``` The values produced by these three tests will be compared using `identical` instead of `all.eq`. If you want to modify how other components of the test are compared, then you can pass a `unitizerItemTestsFuns` object as the value to the `compare` argument instead of a function: ``` unitizer_sect("Accessor Functions", compare=unitizerItemTestsFuns( value=identical, output=all.equal, message=identical ), { get_slope(res) get_rsq(res) get_intercept(res) } ) ``` This will cause the value of tests to be compared with `identical`, the screen output with `all.equal`, and messages (stderr) with `identical`. If you want to change the comparison function for conditions, keep in mind that what you are comparing are `conditionList` objects so this is not straightforward (see `getMethod("all.equal", "conditionList")`). In the future we might expose a better interface for custom comparison functions for conditions (see issue #32). If you need to have different comparison functions within a section, use nested sections. While `unitizer` will only report the outermost section metrics in top-level summaries, the specified comparison functions will be used for each nested section. ## Special Semantics ### Almost Like `source` When `unitizer` runs the test expressions in a test file it does more than just evaluating each in sequence. As a result there are some slight differences in semantics relative to using `source`. We discuss the most obvious ones here. ### `on.exit` Each top-level statement statement, or top-level statement within a `unitizer_sect` (e.g. anything considered a test), is evaluated directly with `eval` in its own environment. This means any `on.exit` expressions will be executed when the top-level expression that defines them is done executing. For example, it is not possible to set an `on.exit(...)` for an entire `unitizer_sect()` block, although it is possible to set it for a single sub-expression: ``` unitizer_sect('on.exit example', { d <- c <- b <- 1 on.exit(b <- 2) b # == 2! { on.exit(d <- c <- 3) c # Still 1 } d # == 3 } ``` ### Evaluation Environments Each test is evaluated in its own environment, which has for enclosure the environment of the prior test. This means that a test has access to all the objects created/used by earlier tests, but not objects created/used by subsequent tests. See the [Reproducible Tests Vignette](u4_reproducible-tests.html#workspace-and-evaluation-environments) for more details. ### Options and Streams In order to properly capture output, `unitizer` will modify streams and options. In particular, it will do the following: * Temporarily set `options(warn=1L)` during expression evaluation. * Temporarily set `options(error=NULL)` during expression evaluation. * Use `sink()` to capture any output to `stdout`. * Use `sink(type="message")` to capture output to `stderr`. This should all be transparent to the user, unless the user is also attempting to modify these settings in the test expressions. The problematic interaction are around the `options` function. If the user sets `options(warn=1)` with the hopes that setting will persist beyond the execution of the test scripts, that will not happen. If the user sets `options(error=recover)` or some such in a test expression, and that expression throws an error, you will be thrown into recovery mode with no visibility of `stderr` or `stdout`, which will make for pretty challenging debugging. Similarly, `unitize`ing `debug`ged functions, or interactive functions, is unlikely to work well. You should be able to use `options(warn=2)` and `options(error=recover)` from the interactive `unitizer` prompt. If `unitize` is run with `sdtderr` or `stdout` sunk, then it will subvert the sink during test evaluation and reset it to the same sinks on exit. If a test expression sinks either stream, `unitizer` will stop capturing output from that point on until the end of the test file. At that point, it will attempt to reset the sinks to what they were when `unitizer` started. Sometimes this is not actually possible. If such a situation occurs, `unitizer` will release all sinks to try to avoid a situation where control is returned to the user with output streams still captured. To reduce the odds of storing massive and mostly useless `stdout`, `unitize` limits how much output is stored by default. If you exceed the limit you will be warned. You may modify this setting with `options("unitizer.max.capture.chars")`. ## Other Details ### Matching Tests Whenever you re-run `unitize` on a file that has already been `unitize`d, `unitizer` matches the expressions in that file to those stored in the corresponding `unitizer` store. `unitizer` matches only on the deparsed expression, and does not care at all where in the file the expression occurs. If multiple identical expressions exist in a file they will be matched in the order they show up. The `unitizer_sect` in which a test was when it was first `unitize`d has no bearing whatsoever on matching a new test to a reference test. For example, if a particular test was in "Section A" when it was first `unitize`d, but in the current version of the test file it is in "Section X", that test will be matched to the current one in "Section X". Some expressions may deparse differently on different systems or with different settings (e.g. numbers with decimal places, non-ASCII characters) so tests containing them may not match correctly across them. See the [Introductory Vignette](u1_intro.html#test-expressions-are-stored-deparsed) for how to avoid problems with this. ### Commenting Tests `unitizer` parses the comments in the test files and attaches them to the test that they document. Comments are attached to tests if they are on the same line as the test, or in the lines between a test and the previous test. Comments are displayed with the test expression during the interactive review mode. Comment parsing is done on a "best-efforts" basis; it may miss some comments, or even fail to work entirely. unitizer/inst/doc/u5_miscellaneous.Rmd0000644000176200001440000002341014766101222017566 0ustar liggesusers--- title: "unitizeR - Miscellanea" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{5 - Miscellaneous Topics} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ## Storing `unitize`d Tests ### Default Mode is to Store Tests in `rds` Files `unitizer` stores unit tests and their results. By default, it stores them in `rds` files in your filesystem. You will be prompted before a file is saved to your filesystem. The `rds` file is placed in a directory with the same name as your test file, but with "unitizer" appended. For example, if your tests are in "my_file_name.R", then `unitizer` will create a folder called "my_file_name.unitizer/" and put an `rds` file in it. See `?get_unitizer` for potential alternatives to saving to your file system. ### File Space Considerations If your tests produce massive objects, the `unitizer` `rds` file will be massive. Try designing your tests so they will produce the smallest representative data structures needed for your tests to be useful. Additionally, note that the `rds` files are binary, which needs to be accounted for when using them in [version controlled projects](#version-control-and-unitizer). ### Backup Your `unitizer` Stores `unitizer` does not backup the `rds` beyond the single copy in the aforementioned folder. Unit tests are valuable, and without the `rds` file `unitizer` tests become a lot less useful. To the extent you backup your R test files, you should also backup the corresponding ".unitizer/" folder. You could lose / corrupt your `unitizer` store in many ways. Some non-exhaustive examples: - Standard file system SNAFU - Careless updates to existing `unitizer` - `unitizer` developer accidentally introduces a bug that destroys your `unitizer` Backup your `unitizer` stores! ### Alternate Store Locations `unitize` stores and loads `unitizer`s using the `set_unitizer` and `get_unitizer` S3 generics . This means you can implement your own S3 methods for those generics to store the `unitizer` object off-filesystem (e.g. MySQL databse, etc). See `?get_unitizer` for more details, though note this feature is untested. If you only wish to save your `unitizer` to a different location in your filesystem than the default, you do not need to resort to these methods as you can provide the target directory with `unitize(..., store.id=)`. ## Version Control and Unitizer ### Committing Binary Files The main issue with using `unitizer` with a version controlled package is that you have to decide whether you want to include the binary `rds` files in the version control history. Some options: * Do not track the binary files at all (but they are valuable and now not backed up). * Do not track the binary files at all, but implement a secondary back-up system (this sounds really annoying). * Use a backed-up, non-file system store (see "Alternate Store Locations" above). * Track the binary files, but manage how often they are committed. We recommend splitting tests for different functionality into different files. This should mitigate the number of rds files that change with any given source code update, and is good practice anyway. Additionally, we typically only commit the rds files when a feature branch or issue resolution is fully complete. Additionally a useful `git` shortcut to add to your `.gitconfig` file that mitigates how often you commit rds files is: ``` [alias] ad = !git add -u && git reset -- *.rds ``` This makes it easy to add all the files you are working on except for the rdses. Once you have stabilized a set of tests you can commit the rds. All this aside, remember that the rdses are ultimately just as important as the test files, and you **should** commit them occasionally to ensure you do not use valuable test information. ### Collaborating with Unitizer If you merge in a pull request from a third party you do not fully trust, we recommend that you do not accept any commits to the rdses. You can accept and review changes to test expressions, and then `unitize` against your existing rdses and review the corresponding values. ## Modifying an Existing Unitizer ### `review` `review` allows you to review all tests in a unitizer rds with the option of dropping tests from it. See `?review`. ### `editCalls` *Warning*: this is experimental; make sure your test store is backed up before you use it. `editCalls` allows you to modify the calls calls stored in a `unitizer`. This is useful when you decide to change the call (e.g. a function name), but otherwise leave the behavior of the call unchanged. You can then upate your test script and the renamed calls will be matched against the correct values in the `unitizer` store. Without this you would have to re-review and re-store every test since `unitizer` identifies tests by the deparsed call. ### `split` There is currently no direct way to split a `unitizer` into pieces (see [issue #44](https://github.com/brodieG/unitizer/issues/44)), but the current work around is to: 1. Copy the test file and the corresponding `unitizer` to a new location. 2. Edit the original test file to remove the tests we want to split off. 3. Run unitizer and agree to drop all removed tests (hint: this is a good time to use `YY`). 4. Edit the new test file and remove the tests that are still in the old test file. 5. Run unitizer and agree to drop all removed tests. The net result will be two new `unitizer`, each with a portion of the tests from the original `unitizer`. Clearly less than ideal, but will work in a pinch. ## Troubleshooting ### After Running `unitizer` Output No Longer Shows on Screen `unitizer` sinks `stdout` and `stderr` during test evaluation, so it is possible that in some corner cases `unitizer` exits without releasing sinks. We have put substantial effort in trying to avoid this eventuality, but should it occur, here are some things you can do: * Run: `while(sink.number()) sink()` and `sink(type="message")` to reset the output stream sinks. * Or, restart the R session (type `q()` followed by ENTER, then "y" or "n" (without quotes) depending on whether you want to save your workspace or not). Either way, please contact the maintainer as this should not happen. ### `unitizer` Freezes and Pops up "Selection:" This is almost certainly a result of an R crash. Unfortunately the normal mechanisms to restore `stderr` don't seem to work completely with full R crashes, so when you see things like: ``` +------------------------------------------------------------------------------+ | unitizer for: tests/unitizer/alike.R | +------------------------------------------------------------------------------+ Running: alike(data.frame(a = integer(), b = factor()), data.frame(a = 1:3, Selection: ``` what you are not seeing is: ``` *** caught segfault *** address 0x7fdc20000010, cause 'memory not mapped' Traceback: 1: .Call(ALIKEC_alike, target, current, int.mode, int.tol, attr.mode) 2: alike(data.frame(a = factor(), b = factor()), data.frame(a = 1:3, b = letters[1:3])) Possible actions: 1: abort (with core dump, if enabled) 2: normal R exit 3: exit R without saving workspace 4: exit R saving workspace ``` The "Selection:" bit is prompting you to type 1-4 as per above. We will investigate to see if there is a way to address this problem, but the solution likely is not simple since the R crash circumvents the `on.exit` handlers used to reset the stream redirects. Also, note that in this case the crash is caused by `alike`, not `unitizer` (see below). ### Running `unitizer` Crashes R Every R crash we have discovered while using `unitizer` was eventually traced to a third party package. Some of the crashes were linked to issues attaching/detaching packages. If you think you might be having an issue with this you can always turn this feature off via the `state` parameter (not the feature is off by default). ### Different Outcomes in Interactive vs. Non Interactive Watch out for functions that have default arguments of the type: ``` fun <- function(x, y=getOption('blahblah')) ``` as those options may be different depending on whether you are running whether you are running R interactively or not. One prime example is `parse(..., keep.source = getOption("keep.source"))`. ## Other Topics ### Running `unitize` Within Error Handling Blocks Because `unitize` evaluates test expressions within a call to `withCallingHandlers`, there are some limitations on successfully running `unitize` inside your own error handling calls. In particular, `unitize` will not work properly if run inside a `tryCatch` or `try` statement. If test expressions throw conditions, the internal `withCallingHandlers` will automatically hand over control to your `tryCatch`/`try` statement without an opportunity to complete `unitize` computations. Unfortunately there does not seem to be a way around this since we have to use `withCallingHandlers` so that test statements after non-aborting conditions are run. See this [SO Q/A](https://stackoverflow.com/questions/20572288/capture-arbitrary-conditions-with-withcallinghandlers) for more details on the problem. ### Overridden Functions In order to perpetuate the R console prompt illusion, `unitizer` needs to override some buit-in functionality, including: * `ls` is replaced by a special version that can explore the `unitizerItem` environments * `quit` and `q` are wrappers around the base functions that allow `unitizer` to quit gracefully * `traceback` and `.traceback` are replaced to read the internally stored traces of the `unitizer`-handled errors in tests. * History is replaced during `unitizer` prompt evaluations with a temporary version of the history file containing only commands evaluated at the `unitizer` prompt. The normal history file is restored on exit. unitizer/inst/doc/u1_intro.Rmd0000644000176200001440000002275714766101222016067 0ustar liggesusers--- title: "unitizer - Interactive R Unit Tests" author: "Brodie Gaslam" output: rmarkdown::html_vignette: toc: true css: styles.css vignette: > %\VignetteIndexEntry{1 - Introduction} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r child='./rmdhunks/intro.Rmd'} ``` ## How Does `unitizer` Differ from `testthat`? ### Testing Style `unitizer` requires you to review test outputs and confirm they are as expected. `testthat` requires you to assert what the test outputs should be beforehand. There are trade-offs between these strategies that we illustrate here, first with `testthat`: ``` vec <- c(10, -10, 0, .1, Inf, NA) expect_error( log10(letters), "Error in log10\\(letters\\) : non-numeric argument to mathematical function\n" ) expect_equal(log10(vec), c(1, NaN, -Inf, -1, Inf, NA)) expect_warning(log10(vec), "NaNs produced") ``` And with `unitizer`: ``` vec <- c(10, -10, 0, .1, Inf, NA) log10(letters) # input error log10(vec) # succeed with warnings ``` These two unit test implementations are functionally equivalent. There are benefits to both approaches. In favor of `unitizer`: * Tests are easy to write. * Tests with non-trivial outputs are easy to write, which encourages more realistic testing of functionality. * Conditions are captured automatically, with no need for special handling. * You can immediately review failing tests in an interactive environment. * Updating tests when function output legitimately changes is easy. In favor of `testthat`: * The tests are self documenting; expected results are obvious. * Once you write the test you are done; with `unitizer` you still need to `unitize` and review the tests. * Tests are usually all-plain text, whereas `unitizer` stores reference values in binary RDSes (see [Collaborating with Unitizer](u5_miscellaneous.html#collaborating-with-unitizer)). `unitizer` is particularly convenient when the tests return complex objects (e.g as `lm` does) and/or produce conditions. There is no need for complicated assertions involving deparsed objects, or different workflows for snapshots. ### Converting `testthat` tests to `unitizer` If you have a stable set of tests it is probably not worth trying to convert them to `unitizer` unless you expect the code those tests cover to change substantially. If you do decide to convert tests you can use the provided `testthat_translate*` functions (see `?testthat_translate_file`). ## `unitizer` and Packages The simplest way to use `unitizer` as part of your package development process is to create a `tests/unitizer` folder for all your `unitizer` test scripts. Here is a sample test structure from the demo package: ``` unitizer.fastlm/ # top level package directory R/ tests/ run.R # <- calls `unitize` or `unitize_dir` unitizer/ fastlm.R cornerCases.R ``` And this is what the `tests/run.R` file would look like ``` library(unitizer) unitize("unitizer/fastlm.R") unitize("unitizer/cornerCases.R") ``` or equivalently ``` library(unitizer) unitize_dir("unitizer") ``` The path specification for test files should be relative to the `tests` directory as that is what `R CMD check` uses. When `unitize` is run by `R CMD check` it will run in a non-interactive mode that will succeed only if all tests pass. You can use any folder name for your tests, but if you use "tests/unitizer" `unitize` will look for files automatically, so the following work assuming your working directory is a folder within the package: ``` unitize_dir() # same as `unitize_dir("unitizer")` unitize("fast") # same as `unitize("fastlm.R")` unitize() # Will prompt for a file to `unitize` ``` Remember to include `unitizer` as a "suggests" package in your DESCRIPTION file. ## Things You Should Know About `unitizer` ### `unitizer` Writes To Your Filesystem The `unitize`d tests need to be saved someplace, and the default action is to save to the same directory as the test file. You will always be prompted by `unitizer` before it writes to your file system. See [storing `unitized` tests](u5_miscellaneous.html#storing-unitized-tests) for implications and alternatives. ### Tests Pass If They `all.equal` Stored Reference Values Once you have created your first `unitizer` with `unitize`, subsequent calls to `unitize` will compare the old stored value to the new one using `all.equal`. You can change the comparison function by using `unitizer_sect` (see [tests vignette](u2_tests.html)). ### Test Expressions Are Stored Deparsed This means you need to be careful with expressions that may deparse differently on different machines or with different settings. Unstable deparsing will prevent tests [from matching](u2_tests.html#matching-tests) their previously stored evaluations. For example, in order to avoid round issues with numerics, it is better to use: ```{r, eval=FALSE} num.var <- 14523.2342520 # assignments are not considered tests test_me(num.var) # safe ``` Instead of: ```{r, eval=FALSE} test_me(14523.2342520) # could be deparsed differently ``` Similarly issues may arise with non-ASCII characters, so use: ```{r eval=FALSE} chr <- "hello\u044F" # assignments are not considered tests fun_to_test(chr) # safe ``` Instead of: ```{r eval=FALSE} fun_to_test("hello\u044F") # could be deparsed differently ``` This issue does not affect the result of running the test as that is never deparsed. ### Increase Reproducibility with Advanced State Management `unitizer` can track and manage many aspects of state to make your tests more reproducible. For example, `unitizer` can reset your R package search path to what is is found in a fresh R session prior to running tests to avoid conflicts with whatever libraries you happen to have loaded at the time. Your session state is restored when `unitizer` exits. The following aspects of state can be actively tracked and managed: * Search path (including removing the global environment from search path) * Random seed * Working directory * Options * Loaded namespaces State management is turned off by default because it requires tracing some base functions which is against CRAN policy, and generally affects session state in uncommon ways. If you wish to enable this feature use `unitize(..., state='suggested')` or `options(unitizer.state='suggested')`. For more details including potential pitfalls see `?unitizerState` and the [reproducible tests vignette](u4_reproducible-tests.html). ### Beware of `browser`/`debug`/`recover` If you enter the interactive browser as e.g. invoked by `debug` you should exit it by allowing evaluation to complete (e.g. by hitting "c" until control returns to the `unitizer` prompt). If you instead hit "Q" while in browser mode you will completely exit the `unitizer` session losing any modifications you made to the tests under review. ### Reference Objects Tests that modify objects by reference are not perfectly suited for use with `unitizer`. The tests will work fine, but `unitizer` will only be able to show you the most recent version of the reference object when you review a test, not what it was like when the test was evaluated. This is only an issue with reference objects that are modified (e.g. environments, RC objects, `data.table` modified with `:=` or `set*`). ### `unitizer` Is Complex In order to re-create the feel of the R prompt within `unitizer` we resorted to a fair bit of trickery. For the most part this should be transparent to the user, but you should be aware it exists in the event something unexpected happens that exposes it. Here is a non-exhaustive list of some of the tricky things we do: * Each tests is evaluated in its own environment, a child of the previous test's environment; because R looks up objects in parent environments it appears that all tests are evaluated in one environment (see [interactive environment vignette](u3_interactive-env.html)) * We [mask some base functions](#masked-functions). * `.Last.value` will not work * We sink `stdout` and `stderr` during test evaluation to capture those streams (see [details on tests vignette](u2_tests.html)), though we take care to do so responsibly * We parse the test file and extract comments so that they can be attached to the correct test for review * The history file is temporary replaced so that your `unitizer` interactions do not pollute it ### Avoid Tests That Require User Input In particular, you should avoid evaluating tests that invoke `debug`ged functions, or introducing interactivity by using something like `options(error=recover)`, or `readline`, or some such. Tests will work, but the interaction will be challenging because you will have to do it with `stderr` and `stdout` captured... ### Avoid running `unitize` within `try` / `tryCatch` Blocks Doing so will cause `unitize` to quit if any test expressions throw conditions. See discussion in [error handling](u5_miscellaneous.html#running-unitize-within-error-handling-blocks). ### Masked Functions Some base functions are masked at the `unitizer` prompt: * `q` and `quit` are masked to give the user an opportunity to cancel the quit action in case they meant to quit from `unitizer` instead of R. Use Q to quit from `unitizer`, as you would from `browser`. * `ls` is masked with a specialized version for use in `unitizer`. * `traceback` is masked to report the most recent error in the order presented by the `unitizer` prompt. See [miscellaneous topics vignette](u5_miscellaneous.html#overriden-functions). unitizer/README.md0000644000176200001440000001576614766101222013422 0ustar liggesusers # unitizeR - Interactive R Unit Tests [![R build status](https://github.com/brodieG/unitizer/workflows/R-CMD-check/badge.svg)](https://github.com/brodieG/unitizer/actions) [![](https://codecov.io/github/brodieG/unitizer/coverage.svg?branch=rc)](https://app.codecov.io/gh/brodieG/unitizer?branch=rc) [![](http://www.r-pkg.org/badges/version/unitizer)](https://cran.r-project.org/package=unitizer) [![Dependencies direct/recursive](https://tinyverse.netlify.app/badge/unitizer)](https://tinyverse.netlify.app/) [![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) ## TL;DR `unitizer` simplifies creation, review, and debugging of tests in R. It automatically stores R expressions and the values they produce, so explicit expectations are unnecessary. Every test is easy to write with `unitizer` because testing and using a function are the same. This encourages non-trivial tests that better represent actual usage. Tests fail when the value associated with an expression changes. In interactive mode you are dropped directly into the failing test environment so you may debug it. `unitizer` is on CRAN: install.packages('unitizer') It bakes in a lot of contextual help so you can get started without reading all the documentation. Try the demo to get an idea: library(unitizer) demo(unitizer) Or check out the [screencast](http://htmlpreview.github.io/?https://github.com/brodieG/unitizer/blob/rc/extra/gifshow.html) to see `unitizer` in action. ## Why Another Testing Framework? ### Automated Test Formalization Are you tired of the `deparse`/`dput` then copy-paste R objects into test file dance, or do you use `testthat::expect_equal_to_reference` or other snapshot testing a lot? With `unitizer` you interactively review your code as you would when typing it at the R prompt. Then, with a single keystroke, you tell `unitizer` to store the code, and any values, warnings, or errors it produced, thereby creating a formal regression test. ### Streamlined Debugging Do you wish the nature of a test failure was more immediately obvious? When tests fail, you are shown a proper [diff](https://github.com/brodieG/diffobj) so you can clearly identify *how* the test failed: ![diff example](https://github.com/brodieG/unitizer/raw/rc/extra/gif/review1.png) Do you wish that you could start debugging your failed tests without additional set-up work? `unitizer` drops you in the test environment so you can debug *why* the test failed without further ado: ![review example](https://github.com/brodieG/unitizer/raw/rc/extra/gif/review2.png) ### Fast Test Updates Do you avoid improvements to your functions because that would require painstakingly updating many tests? The diffs for the failed tests let you immediately confirm only what you intended changed. Then you can update each test with a single keystroke. ## Usage `unitizer` stores R expressions and the result of evaluating them so that it can detect code regressions. This is akin to saving test output to a `.Rout.save` file as documented in [Writing R Extensions](https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Package-subdirectories), except that we’re storing the actual R objects and it is much easier to review them. To use `unitizer`: - Write test expressions as you would when informally testing code on the command line, and save them to a file (e.g. “my\_file\_name.R”). - Run `unitize("my_file_name.R")` and follow the prompts. - Continue developing your package. - Re-run `unitize("my_file_name.R")`; if any tests fail you will be able to review and debug them in an interactive prompt. `unitizer` can run in a non-interactive mode for use with `R CMD check`. ## Documentation - `help(package="unitizer")`, in particular `?unitize` - `demo(package="unitizer")` - [`browseVignettes("unitizer")`](https://cran.r-project.org/package=unitizer/vignettes/u0_unitizer_index.html) for a list of vignettes, or skip straight to the [Introduction vignette](https://cran.r-project.org/package=unitizer/vignettes/u1_intro.html) ## Related Packages - [`aammrtf`](https://github.com/brodieG/aammrtf), a minimal version of `unitizer`, used by `unitizer` for its own tests. - [`testthat`](https://cran.r-project.org/package=testthat). - [`tinytest`](https://cran.r-project.org/package=tinytest), which is extended by [`ttdo`](https://cran.r-project.org/package=ttdo) for [`diffobj`](https://cran.r-project.org/package=diffobj) diffs. - [`RUnit`](https://cran.r-project.org/package=RUnit). ## Acknowledgments Thank you to: - R Core for developing and maintaining such a wonderfully language. - CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository, and Uwe Ligges in particular for maintaining [Winbuilder](https://win-builder.r-project.org/). - [Gábor Csárdi](https://github.com/gaborcsardi) for [crayon](https://cran.r-project.org/package=crayon) through which we can add a new dimension to the R experience. - [Jim Hester](https://github.com/jimhester) because [covr](https://cran.r-project.org/package=covr) rocks. - [Hadley Wickham](https://github.com/hadley) for [testthat](https://cran.r-project.org/package=testthat) from which we borrow many concepts, and for his many other packages. - [Dirk Eddelbuettel](https://github.com/eddelbuettel) and [Carl Boettiger](https://github.com/cboettig) for the [rocker](https://github.com/rocker-org/rocker) project, and [Gábor Csárdi](https://github.com/gaborcsardi) and the R-consortium for [Rhub](https://github.com/r-hub/rhub), without which testing bugs on R-devel and other platforms would be a nightmare. - [Yihui Xie](https://github.com/yihui) for [knitr](https://cran.r-project.org/package=knitr) and [J.J. Allaire](https://github.com/jjallaire) et al. for [rmarkdown](https://cran.r-project.org/package=rmarkdown), and by extension John MacFarlane for [pandoc](https://pandoc.org/). - @kohler for [gifsicle](https://github.com/kohler/gifsicle) and the [ffmpeg team](http://ffmpeg.org/about.html) for ffmpeg. - All open source developers out there that make their work freely available for others to use. - [Github](https://github.com/), [Codecov](https://about.codecov.io/), [Vagrant](https://www.vagrantup.com/), [Docker](https://www.docker.com/), [Ubuntu](https://ubuntu.com/), [Brew](https://brew.sh/) for providing infrastructure that greatly simplifies open source development. - [Free Software Foundation](https://www.fsf.org/) for developing the GPL license and promotion of the free software movement. ## About the Author Brodie Gaslam is a hobbyist programmer based in the US East Coast. unitizer/build/0000755000176200001440000000000014766360132013232 5ustar liggesusersunitizer/build/vignette.rds0000644000176200001440000000056414766360132015576 0ustar liggesusersRn04IB_"UU q-rj)cC1u`=\!8\⸸tp:QD16t'М)2`BHXMjUT45 XWq|~unitizer/man/0000755000176200001440000000000014766340624012712 5ustar liggesusersunitizer/man/run_ls.Rd0000644000176200001440000000134314766101222014471 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ls.R \name{run_ls} \alias{run_ls} \title{Worker function to actually execute the `ls` work} \usage{ run_ls(env, stop.env, all.names, pattern, store.env = NULL) } \arguments{ \item{env}{the environment to start \code{`ls`}ing in} \item{stop.env}{the environment to stop at} \item{all.names, }{same as \code{`ls`}} \item{pattern}{same as \code{`ls`}} \item{store.env}{NULL or environment, if the latter will populate that environment with all the objects found between \code{`env`} and \code{`stop.env`}} } \value{ character or environment depending on \code{`store.env`} } \description{ Worker function to actually execute the `ls` work } \keyword{internal} unitizer/man/unitizerSection-class.Rd0000644000176200001440000000220514766101222017466 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/section.R \docType{class} \name{unitizerSection-class} \alias{unitizerSection-class} \alias{unitizerSectionExpression-class} \alias{unitizerSectionNA-class} \title{Contains Representation For a Section of Tests} \description{ \code{unitizerSectionExpression-class} contains the actual expressions that belong to the section, whereas \code{unitizerSection-class} only contains the meta data. The latter objects are used within \code{]unitizer-class}, whereas the former is really just a temporary object until we can generate the latter. } \details{ \code{unitizerSectionNA-class} is a specialized section for tests that actually don't have a section (removed tests that are nonetheless chosen to be kept by user in interactive environment) } \section{Slots}{ \describe{ \item{\code{title}}{1 lenght character, the name of the section} \item{\code{details}}{character vector containing additional info on the section} \item{\code{compare}}{functions to compare the various aspects of a \code{unitizerItem-class} @slot length tracks size of the section} }} \keyword{internal} unitizer/man/show-unitizerItemTestsErrorsDiff-method.Rd0000644000176200001440000000061214766101222023122 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/item.sub.R \name{show,unitizerItemTestsErrorsDiff-method} \alias{show,unitizerItemTestsErrorsDiff-method} \title{Show Method for unitizerItemTestsErrorsDiff objects} \usage{ \S4method{show}{unitizerItemTestsErrorsDiff}(object) } \description{ Show Method for unitizerItemTestsErrorsDiff objects } \keyword{internal} unitizer/man/testFuns.Rd0000644000176200001440000000224114766101222015000 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/item.sub.R \docType{class} \name{testFuns} \alias{testFuns} \title{Store Functions for New vs. Reference Test Comparisons} \description{ \code{testFuns} contains the functions used to compare the results and side effects of running test expressions. \dQuote{testFuns} objects can be used as the \code{compare} argument for \code{\link{unitizer_sect}}, thereby allowing you to specify different comparison functions for different aspects of test evaluation. } \details{ The default comparison functions are as follows: \itemize{ \item value: \code{\link{all_eq}} \item conditions: \code{\link{all_eq}} \item output: \code{function(x, y) TRUE}, i.e. not compared \item message: \code{function(x, y) TRUE}, i.e. not compared as conditions should be capturing warnings/errors \item aborted: \code{function(x, y) TRUE}, i.e. not compared as conditions should also be capturing this implicitly } } \examples{ # use `identical` instead of `all.equal` to compare values testFuns(value=identical) } \seealso{ \code{\link{unitizer_sect}} for more relevant usage examples, \code{\link{all_eq}} } unitizer/man/text_wrap.Rd0000644000176200001440000000453514766101222015212 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/text.R \name{text_wrap} \alias{text_wrap} \alias{word_wrap} \alias{meta_word_cat} \alias{meta_word_msg} \alias{word_cat} \alias{word_msg} \alias{word_comment} \title{Text Wrapping Utilities} \usage{ text_wrap(x, width) word_wrap( x, width = getOption("width"), tolerance = 8L, hyphens = TRUE, unlist = TRUE, collapse = NULL ) meta_word_cat( ..., sep = "\\n", width = getOption("width"), tolerance = 8L, file = stdout(), trail.nl = TRUE ) meta_word_msg( ..., sep = "\\n", width = getOption("width"), tolerance = 8L, trail.nl = TRUE ) word_cat( ..., sep = " ", width = getOption("width"), tolerance = 8L, file = stdout() ) word_msg(...) word_comment( x, width = getOption("width"), tolerance = 8L, hyphens = TRUE, unlist = TRUE, color = crayon::has_color() ) } \arguments{ \item{x}{character vector} \item{width}{what width to wrap at} \item{tolerance}{how much earlier than \code{width} we're allowed to wrap} \item{hyphens}{whether to allow hyphenation} \item{unlist}{logical(1L) if FALSE each element in \code{x} is returned as an element of a list, otherwise one character vector is returned} } \value{ a list with, for each item in \code{x}, a character vector of the item wrapped to length \code{width} if \code{unlist} is a parameter, then a character vector, or if not or if \code{unlist} is FALSE, a list with each element from \code{x} corresponding to an element from the list } \description{ Functions to break up character vector components to a specified width. } \details{ \itemize{ \item \code{text_wrap} breaks each element to a specified \code{width}, where \code{width} can contain different values for each value in \code{x} \item \code{word_wrap} wraps at whitespace, or crudely hyphenates if necessary; note that unlike \code{text_wrap} \code{width} must be scalar \item \code{word_cat} is like \code{word_wrap}, except it outputs to screen \item \code{word_msg} is like \code{word_cat}, except it ouputs to stderr \item \code{meta_word_cat} is like \code{word_cat}, except it wraps output in formatting to highlight this is not normal output } Newlines are replaced by empty strings in the output so that each character vector in the output represents a line of screen output. } \keyword{internal} unitizer/man/extract-unitizerItemTestsErrorsDiffs-method.Rd0000644000176200001440000000102514766101222023776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/item.sub.R \name{$,unitizerItemTestsErrorsDiffs-method} \alias{$,unitizerItemTestsErrorsDiffs-method} \alias{[[,unitizerItemTestsErrorsDiffs,ANY-method} \title{Subsetting Methods for unitizerItemTestsErrorsDiffs objects} \usage{ \S4method{$}{unitizerItemTestsErrorsDiffs}(x, name) \S4method{[[}{unitizerItemTestsErrorsDiffs,ANY}(x, i, j, ..., exact = TRUE) } \description{ Subsetting Methods for unitizerItemTestsErrorsDiffs objects } \keyword{internal} unitizer/man/desc.Rd0000644000176200001440000000157214766101222014111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/text.R \name{desc} \alias{desc} \title{One Line Description of Object} \usage{ desc(val, limit = getOption("width")) } \arguments{ \item{val}{object to describe} \item{limit}{max characters to display} } \value{ character(1L) describing object } \description{ Objects are described by class, and dimensions. Dimensions is always denoted in square brackets. For example, \dQuote{int[10]} means an integer of length ten. Typically an object will be identified by \code{head(class(obj), 1L)} along with its dimensions. Recursive objects will have the first level shown provided that doing so fits within \code{limit}. } \details{ Eventually this will be migrated to an S3 generic to allow recursive dispatch on object type. } \examples{ desc(list(a=iris, b=lm(dist ~ speed, cars), 1:10, matrix(letters, 2))) } unitizer/man/flattenUntz.Rd0000644000176200001440000000071314766101222015505 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{flattenUntz} \alias{flattenUntz} \title{Reduce S4 objects Into Lists} \usage{ flattenUntz(x, ...) } \description{ This is particularly useful with "list" type S4 objects, and relates loosely to the subsetting functions defined for \code{unitizerBrowse} objects. } \details{ Currently we only define a method for \code{unitizerItems-class} objects } \keyword{internal} unitizer/man/unitize.Rd0000644000176200001440000002644414766101222014667 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unitize.R \name{unitize} \alias{unitize} \alias{review} \alias{unitize_dir} \title{Unitize an R Test Script} \usage{ unitize( test.file = NULL, store.id = NULL, state = getOption("unitizer.state"), pre = NULL, post = NULL, history = getOption("unitizer.history.file"), interactive.mode = interactive(), force.update = FALSE, auto.accept = character(0L), use.diff = getOption("unitizer.use.diff"), show.progress = getOption("unitizer.show.progress", TRUE), transcript = getOption("unitizer.transcript", !interactive.mode) ) review( store.id = NULL, use.diff = getOption("unitizer.use.diff"), show.progress = getOption("unitizer.show.progress", TRUE) ) unitize_dir( test.dir = NULL, store.ids = filename_to_storeid, pattern = "^[^.].*\\\\.[Rr]$", state = getOption("unitizer.state"), pre = NULL, post = NULL, history = getOption("unitizer.history.file"), interactive.mode = interactive(), force.update = FALSE, auto.accept = character(0L), use.diff = getOption("unitizer.use.diff"), show.progress = getOption("unitizer.show.progress", TRUE), transcript = getOption("unitizer.transcript", !interactive.mode) ) } \arguments{ \item{test.file}{path to the file containing tests, if supplied path does not match an actual system path, \code{unitizer} will try to infer a possible path. If NULL, will look for a file in the \dQuote{tests/unitizer} package folder if it exists, or in \dQuote{.} if it does not. See \code{\link{infer_unitizer_location}}) for details.} \item{store.id}{if NULL (default), \code{unitizer} will select a directory based on the \code{test.file} name by replacing \code{.[rR]} with \code{.unitizer}. You can also specify a directory name, or pass any object that has a defined \code{\link{get_unitizer}} method which allows you to specify non-standard \code{unitizer} storage mechanisms (see \code{\link{get_unitizer}}). Finally, you can pass an actual \code{unitizer} object if you are using \code{review}; see \code{store.ids} for \code{unitize_dir}} \item{state}{character(1L) one of \code{c("prisitine", "suggested", "basic", "off", "safe")}, an environment, or a state object produced by \code{\link{state}} or \code{\link{in_pkg}}; modifies how \code{unitizer} manages aspects of session state that could affect test evaluation, including the parent evaluation environment. For more details see \code{\link{unitizerState}} documentation and \code{vignette("unitizer_reproducible_tests")}} \item{pre}{NULL, or a character vector pointing to files and/or directories. If a character vector, then any files referenced therein will be sourced, and any directories referenced therein will be scanned non-recursively for visible files ending in ".r" or ".R", which are then also sourced. If NULL, then \code{unitizer} will look for a directory named "_pre" in the directory containing the first test file and will treat it as if you had specified it in \code{pre}. Any objects created by those scripts will be put into a parent environment for all tests. This provides a mechanism for creating objects that are shared across different test files, as well as loading shared packages. Unlike objects created during test evaluation, any objects created here will not be stored in the \code{unitizer} so you will have not direct way to check whether these objects changed across \code{unitizer} runs. Additionally, typing \code{ls} from the review prompt will not list these objects.} \item{post}{NULL, or a character vector pointing to files and/or directories. See \code{pre}. If NULL will look for a directory named "_post" in the directory containing the first test file. Scripts are run just prior to exiting \code{unitizer}. \code{post} code will be run in an environment with the environment used to run \code{pre} as the parent. This means that any objects created in \code{pre} will be available to \code{post}, which you can use to your advantage if there are some things you do in \code{pre} you wish to undo in \code{post}. Keep in mind that \code{unitizer} can manage most aspects of global state, so you should not need to use this parameter to unload packages, remove objects, etc. See details.} \item{history}{character(1L) path to file to use to store history generated during interactive unitizer session; the default is an empty string, which leads to \code{unitizer} using a temporary file, set to NULL to disable history capture.} \item{interactive.mode}{logical(1L) whether to run in interactive mode ( request user input when needed) or not (error if user input is required, e.g. if all tests do not pass).} \item{force.update}{logical(1L) if TRUE will give the option to re-store a unitizer after re-evaluating all the tests even if all tests passed. You can also toggle this option from the unitizer prompt by typing \code{O} (capital letter "o"), though \code{force.update=TRUE} will force update irrespective of whether you type \code{O} at the prompt} \item{auto.accept}{character(X) ADVANCED USE ONLY: YOU CAN EASILY DESTROY YOUR \code{unitizer} WITH THIS; whether to auto-accept tests without prompting, use values in \code{c("new", "failed", "deleted", "error")} to specify which type(s) of test you wish to auto accept (i.e. same as typing \code{"Y"} at the \code{unitizer} prompt) or empty character vector to turn off (default)} \item{use.diff}{TRUE or FALSE, whether to use diffs when there is an error, if FALSE uses \code{\link{all.equal}} instead.} \item{show.progress}{TRUE or FALSE or integer(1L) in 0:3, whether to show progress updates for each part of the process (TRUE or > 0), for each file processed (TRUE or > 1), and for each test processed (TRUE or > 2).} \item{transcript}{TRUE (default in non-interactive mode) or FALSE (default in interactive mode) causes immediate output of stdout/stderr during test evaluation instead of deferred display during test review. This also causes progress updates to display on new lines instead of overlaying on the same line. One limitation of running in this mode is that stderr is no longer captured at all so is unavailable in the review stage. stderr text that is also part of a signalled condition (e.g. "boom" in `stop("boom")`) is still shown with the conditions in the review step. To see direct stderr output in transcript mode scroll up to the test evaluation point.} \item{test.dir}{the directory to run the tests on; if NULL will use the \dQuote{tests/unitizer} package folder if it exists, or \dQuote{.} if it does not. See \code{\link{infer_unitizer_location}}) for details.} \item{store.ids}{one of \itemize{ \item a function that converts test file names to \code{unitizer} ids; if \code{unitize}ing multiple files will be \code{lapply}ed over each file \item a character vector with \code{unitizer} ids, must be the same length as the number of test files being reviewed (see \code{store.id}) \item a list of unitizer ids, must be the same length as the number of test files being reviewed; useful when you implement special storage mechanisms for the \code{unitizers} (see \code{\link{get_unitizer}}) }} \item{pattern}{a regular expression used to match what subset of files in \code{test.dir} to \code{unitize}} } \value{ \code{unitize} and company are intended to be used primarily for the interactive environment and side effects. The functions do return summary data about test outcomes and user input as \code{unitizer_result} objects, or for \code{unitize_dir} as \code{unitizer_results} objects, invisibly. See \code{\link{unitizer_result}}. } \description{ Turn standard R scripts into unit tests by storing the expressions therein along with the results of their evaluation, and provides an interactive prompt to review tests. } \details{ \code{unitize} creates unit tests from a single R file, and \code{unitize_dir} creates tests from all the R files in the specified directory (analogous to \code{testthat::test_dir}). \code{unitizer} stores are identified by \code{unitizer} ids, which by default are character strings containing the location of the folder the \code{unitizer} RDS files are kept in. \code{unitize} and friends will create a \code{unitizer} id for you based on the test file name and location, but you can specify your own location as an id, or even use a completely different mechanism to store the \code{unitizer} data by implementing S3 methods for \code{\link{get_unitizer}} and \code{\link{set_unitizer}}. For more details about storage see those functions. \code{review} allows you to review existing \code{unitizer}s and modify them by dropping tests from them. Tests are not evaluated in this mode; you are just allowed to review the results of previous evaluations of the tests Because of this, no effort is made to create reproducible state in the browsing environments, unlike with \code{unitize} or \code{unitize_dir} (see \code{state} parameter). You are strongly encouraged to read through the vignettes for details and examples (\code{browseVignettes("unitizer")}). The demo (\code{demo("unitizer")}) is also a good introduction to these functions. } \section{Note}{ \code{unitizer} approximates the semantics of sourcing an R file when running tests, and those of the interactive prompt when reviewing them. The semantics are not identical, and in some cases you may notice differences. For example, when running tests: \itemize{ \item All expressions are run with \code{options(warn=1)}, irrespective of what the user sets that option to. \item \code{on.exit(...)} expressions will be evaluated immediately for top-level statements (either in the test file or in an \code{\link{unitizer_sect}}, thereby defeating their purpose). \item Each test expression is run in its own environment, which is enclosed by that of previous tests. \item Output and Message streams are sunk so any attempt to debug directly will be near-impossible as you won't see anything. \item For portable tests it is best to use ASCII only string literals (avoiding even escaped bytes or Unicode characters), round numbers, etc., because \code{unitizer} uses deparsed test expressions as indices to retrieve reference values. See \code{vignette('u1_intro', package='unitizer')} for details and work-arounds. } When reviewing them: \itemize{ \item \code{ls()} and \code{q()} are over-ridden by \code{unitizer} utility functions. \item Expressions are evaluated with \code{options(warn=1)} or greater, although unlike in test running it is possible to set and keep \code{options(warn=2)}. \item Some single upper case letters will be interpreted as \code{unitizer} meta-commands. } For a more complete discussion of these differences see the introductory vignette (\code{vignette('u1_intro')}), the "Special Semantics" section of the tests vignette (\code{vignette('u2_tests')}), and the "Evaluating Expressions at the \code{unitizer} Prompt" section of the interactive environment vignette (\code{vignette('u3_interactive-env')}). } \section{Default Settings}{ Many of the default settings are specified in the form \code{getOption("...")} to allow the user to "permanently" set them to their preferred modes by setting options in their \code{.Rprofile} file. } \seealso{ \code{\link{unitizerState}}, \code{\link{unitizer.opts}}, \code{\link{get_unitizer}}, \code{\link{infer_unitizer_location}}, \code{\link{unitizer_result}} } unitizer/man/print.bullet.Rd0000644000176200001440000000106014766101222015605 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/asciiml.R \name{print.bullet} \alias{print.bullet} \title{Print Methods for \code{UL} and \code{OL} objects} \usage{ \method{print}{bullet}(x, width = 0L, ...) } \arguments{ \item{x}{object to print} \item{width}{integer how many characters to wrap at, if set to 0 will auto detect width with \code{getOptions("width")}} } \value{ invisibly a character vector with one element per line printed } \description{ Print Methods for \code{UL} and \code{OL} objects } \keyword{internal} unitizer/man/show-unitizerItemTestsErrorsDiffs-method.Rd0000644000176200001440000000061714766101222023312 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/item.sub.R \name{show,unitizerItemTestsErrorsDiffs-method} \alias{show,unitizerItemTestsErrorsDiffs-method} \title{Show Method for unitizerItemTestsErrorsDiffs objects} \usage{ \S4method{show}{unitizerItemTestsErrorsDiffs}(object) } \description{ Show Method for unitizerItemTestsErrorsDiffs objects } \keyword{internal} unitizer/man/cap_first.Rd0000644000176200001440000000052614766101222015143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/text.R \name{cap_first} \alias{cap_first} \alias{decap_first} \title{Captalizes or Decapitalizes First Letter} \usage{ cap_first(x) } \arguments{ \item{x}{character} } \value{ character } \description{ Captalizes or Decapitalizes First Letter } \keyword{internal} unitizer/man/sizeRDS.Rd0000644000176200001440000000036514766101222014515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{sizeRDS} \alias{sizeRDS} \title{Measure object size as an RDS} \usage{ sizeRDS(object) } \description{ Measure object size as an RDS } \keyword{internal} unitizer/man/extract-unitizerItem-method.Rd0000644000176200001440000000436614766101222020615 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/item.R \name{$.unitizerItem} \alias{$.unitizerItem} \alias{$,unitizerItem-method} \alias{[[,unitizerItem,ANY-method} \title{Retrieve Test Contents From Test Item} \usage{ \S4method{$}{unitizerItem}(x, name) \S4method{[[}{unitizerItem,ANY}(x, i, j, ..., exact = TRUE) } \arguments{ \item{x}{a \code{unitizerItem} object, typically \code{.NEW} or \code{.REF} at the \code{unitizer} interactive prompt} \item{name}{a valid test sub-component} \item{i}{a valid test sub-component as a character string, or a sub-component index} \item{j}{missing for compatibility with generic} \item{...}{missing for compatibility with generic} \item{exact}{unused, always matches exact} } \value{ the test component requested } \description{ Intended for use within the \code{unitizer} interactive environment, allows user to retrieve whatever portions of tests are stored by \code{unitizer}. } \details{ Currently the following elements are available: \itemize{ \item \code{call} the call that was tested as an unevaluated call, but keep in mind that if you intend to evaluate this for a reference item the environment may not be the same so you could get different results (\code{ls} will provide more details) \item \code{value} the value that results from evaluating the test, note this is equivalent to using \code{.new} or \code{.ref}; note that the value is displayed using \code{\link{desc}} when viewing all of \code{.NEW} or \code{.REF} \item \code{output} the screen output (i.e. anything produced by cat/print, or any visible evaluation output) as a character vector \item \code{message} anything that was output to \code{stderr}, mostly this is all contained in the conditions as well, though there could be other output here, as a character vector \item \code{conditions} a \code{\link{conditionList}} containing all the conditions produced during test evaluation \item \code{aborted} whether the test call issues a restart call to the `abort` restart, as `stop` does. } } \examples{ ## From the unitizer> prompt: .NEW <- mock_item() # .NEW is normally available at unitizer prompt .NEW$call .NEW$conditions .NEW$value # equivalent to `.new` } unitizer/man/unitizer_s4method_doc.Rd0000644000176200001440000001174614766101222017504 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/global.R, R/class_unions.R, R/list.R, % R/item.R, R/test.R, R/unitizer.R, R/browse.struct.R, R/load.R, R/state.R, % R/state.compare.R, R/unitizer.add.R \name{show,unitizerDummy-method} \alias{show,unitizerDummy-method} \alias{as.integer,unitizerGlobalIndices-method} \alias{unitizer_s4method_doc} \alias{length,unitizerList-method} \alias{[,unitizerList,subIndex,missing,missing-method} \alias{[[,unitizerList,subIndex-method} \alias{[<-,unitizerList,subIndex-method} \alias{[[<-,unitizerList,subIndex-method} \alias{as.list,unitizerList-method} \alias{append,unitizerList,ANY-method} \alias{c,unitizerList-method} \alias{append,factor,factor-method} \alias{names,unitizerList-method} \alias{names<-,unitizerList-method} \alias{initialize,unitizerItem-method} \alias{show,unitizerItem-method} \alias{+,unitizerItems,unitizerItemOrNULL-method} \alias{+,unitizerItems,unitizerItems-method} \alias{+,unitizerTests,unitizerSectionExpressionOrExpression-method} \alias{show,unitizerSummary-method} \alias{initialize,unitizer-method} \alias{length,unitizer-method} \alias{summary,unitizer-method} \alias{summary,unitizerObjectList-method} \alias{show,unitizerObjectListSummary-method} \alias{as.character,unitizer-method} \alias{show,unitizerBrowse-method} \alias{as.character,unitizerBrowse-method} \alias{as.data.frame,unitizerBrowse-method} \alias{+,unitizerBrowse,unitizerBrowseSection-method} \alias{length,unitizerBrowseSubSection-method} \alias{[,unitizerBrowse,subIndex,missing,missing-method} \alias{[,unitizerBrowseSubSection,subIndex,missing,missing-method} \alias{+,unitizerBrowseSection,unitizerBrowseSubSection-method} \alias{show,unitizerLoadFail-method} \alias{as.character,unitizerInPkg-method} \alias{show,unitizerInPkg-method} \alias{show,unitizerState-method} \alias{all.equal,unitizerDummy,unitizerDummy-method} \alias{all.equal,unitizerDummy,ANY-method} \alias{all.equal,ANY,unitizerDummy-method} \alias{all.equal,unitizerStateRaw,unitizerStateRaw-method} \alias{+,unitizer,unitizerSection-method} \alias{+,unitizer,unitizerTestsOrExpression-method} \alias{+,unitizer,unitizerItems-method} \alias{+,unitizer,unitizerItem-method} \alias{+,unitizer,unitizerItemTestsErrors-method} \title{Documentation Block for Internal S4 Methods} \usage{ \S4method{show}{unitizerDummy}(object) \S4method{as.integer}{unitizerGlobalIndices}(x, ...) \S4method{length}{unitizerList}(x) \S4method{[}{unitizerList,subIndex,missing,missing}(x, i) \S4method{[[}{unitizerList,subIndex}(x, i) \S4method{[}{unitizerList,subIndex}(x, i) <- value \S4method{[[}{unitizerList,subIndex}(x, i) <- value \S4method{as.list}{unitizerList}(x, ...) \S4method{append}{unitizerList,ANY}(x, values, after = length(x)) \S4method{c}{unitizerList}(x, ..., recursive = FALSE) \S4method{append}{factor,factor}(x, values, after = length(x)) \S4method{names}{unitizerList}(x) \S4method{names}{unitizerList}(x) <- value \S4method{initialize}{unitizerItem}(.Object, ...) \S4method{show}{unitizerItem}(object) \S4method{+}{unitizerItems,unitizerItemOrNULL}(e1, e2) \S4method{+}{unitizerItems,unitizerItems}(e1, e2) \S4method{+}{unitizerTests,unitizerSectionExpressionOrExpression}(e1, e2) \S4method{show}{unitizerSummary}(object) \S4method{initialize}{unitizer}(.Object, ...) \S4method{length}{unitizer}(x) \S4method{summary}{unitizer}(object, silent = FALSE, ...) \S4method{summary}{unitizerObjectList}(object, silent = FALSE, ...) \S4method{show}{unitizerObjectListSummary}(object) \S4method{as.character}{unitizer}(x, ...) \S4method{show}{unitizerBrowse}(object) \S4method{as.character}{unitizerBrowse}(x, width = 0L, ...) \S4method{as.data.frame}{unitizerBrowse}(x, row.names = NULL, optional = FALSE, ...) \S4method{+}{unitizerBrowse,unitizerBrowseSection}(e1, e2) \S4method{length}{unitizerBrowseSubSection}(x) \S4method{[}{unitizerBrowse,subIndex,missing,missing}(x, i) \S4method{[}{unitizerBrowseSubSection,subIndex,missing,missing}(x, i) \S4method{+}{unitizerBrowseSection,unitizerBrowseSubSection}(e1, e2) \S4method{show}{unitizerLoadFail}(object) \S4method{as.character}{unitizerInPkg}(x, ...) \S4method{show}{unitizerInPkg}(object) \S4method{show}{unitizerState}(object) \S4method{all.equal}{unitizerDummy,unitizerDummy}(target, current, ...) \S4method{all.equal}{unitizerDummy,ANY}(target, current, ...) \S4method{all.equal}{ANY,unitizerDummy}(target, current, ...) \S4method{all.equal}{unitizerStateRaw,unitizerStateRaw}(target, current, ...) \S4method{+}{unitizer,unitizerSection}(e1, e2) \S4method{+}{unitizer,unitizerTestsOrExpression}(e1, e2) \S4method{+}{unitizer,unitizerItems}(e1, e2) \S4method{+}{unitizer,unitizerItem}(e1, e2) \S4method{+}{unitizer,unitizerItemTestsErrors}(e1, e2) } \description{ R insists these need to be documented as user facing, but they are not really so were throwing them all in here. Actual docs are in non roxygen comments by fun definitions. } \details{ Put in this file because this file is included by almost every other file } \keyword{internal} unitizer/man/unitizerState.Rd0000644000176200001440000003770314766101222016052 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/state.R \name{unitizerState} \alias{unitizerState} \alias{state} \alias{state,} \alias{in_pkg} \title{Tests and Session State} \usage{ state( par.env, search.path, options, working.directory, random.seed, namespaces ) in_pkg(package = NULL) } \arguments{ \item{par.env}{\code{NULL} to use the special \code{unitizer} parent environment, or an environment to use as the parent environment, or the name of a package as a character string to use that packages' namespace as the parent environment, or a \code{unitizerInPkg} object as produced by \code{\link{in_pkg}}, assumes .GlobalEnv if unspecified} \item{search.path}{one of \code{0:2}, uses the default value corresponding to \code{getOption(unitizer.state)}, which is 0 in the default unitizer state of \dQuote{off}. See "Custom Control" section for details.} \item{options}{same as \code{search.path}} \item{working.directory}{same as \code{search.path}} \item{random.seed}{same as \code{search.path}} \item{namespaces}{same as \code{search.path}} \item{package}{character(1L) or NULL; if NULL will tell \code{unitize} to attempt to identify if the test file is inside an R package folder structure and if so run tests in that package's namespace. This should work with R CMD check tests as well as in normal usage. If character will take the value to be the name of the package to use the namespace of as the parent environment. Note that \code{in_pkg} does not retrieve the environment, it just tells \code{unitize} to do so.} } \value{ for \code{state} a \code{unitizerStateRaw} object, for \code{in_pkg} a \code{unitizerInPkg} object, both of which are suitable as values for the \code{state} parameter for \code{\link{unitize}} or as values for the \dQuote{unitizer.state} global option. } \description{ While R generally adheres to a "functional" programming style, there are several aspects of session state that can affect the results of code evaluation (e.g. global environment, search path). \code{unitizer} provides functionality to increase test reproducibility by controlling session state so that it is the same every time a test is run. This functionality is turned off by default to comply with CRAN requirements, and also because there are inherent limitations in R that may prevent it from fully working in some circumstances. You can permanently enable the suggested state tracking level by adding \code{options(unitizer.state='suggested')} in your \code{.Rprofile}, although if you intend to do this be sure to read the \dQuote{CRAN non-compliance} section. } \section{CRAN Non-Compliance and Other Caveats}{ In the default state management mode, this package fully complies with CRAN policies. In order to implement advanced state management features we must lightly trace some \code{base} functions to alert \code{unitizer} each time the search path is changed by a test expression. The traced function behavior is completely unchanged other than for the side effect of notifying \code{unitizer} each time they are called. Additionally, the functions are only traced during \code{unitize} evaluation and are untraced on exit. Unfortunately this tracing is against CRAN policies, which is why it is disabled by default. Arguably other aspects of state management employed outside of \code{state="default"} _could_ be considered CRAN non-compliant, but none of these are deployed unless you explicitly chose to do so. Additionally, \code{unitizer} limits state manipulation to the evaluation of its processes and restores state on exit. Some exceptional failures may prevent restoring state fully. If state management were to fail fail in an unhandled form, the simplest work-around is to turn off state management altogether with \code{state="default"}. If it is a particular aspect of state management (e.g. search paths with packages attached with \code{devtools::load_all}), you can disable just that aspect of state (see "Custom Control" section). For more details see the reproducible tests vignette with: \code{vignette(package='unitizer', 'u4_reproducible-tests')} } \section{Overview}{ You can control how \code{unitizer} manages state via the state argument to \code{unitize} or by setting the \dQuote{unitizer.state} option. This help file discusses state management with \code{unitizer}, and also documents two functions that, in conjunction with \code{\link{unitize}} or \code{\link{unitize_dir}} allow you to control state management. \bold{Note}: most of what is written in this page about \code{unitize} applies equally to \code{unitize_dir}. \code{unitizer} provides functionality to insulate test code from variability in the following. Note the \dQuote{can be} wording because by default these elements of state are not managed: \itemize{ \item Workspace / Parent Environment: all tests can be evaluated in environments that are children of a special environment that does not inherit from \code{.GlobalEnv}. This prevents objects that are lying around in your workspace from interfering with your tests. \item Random Seed: can be set to a specific value at the beginning of each test file so that tests using random values get the same value at every test iteration. This only sets the seed at the beginning of each test file, so changes in order or number of functions that generate random numbers in your test file will affect subsequent tests. The advantage of doing this over just setting the seed directly in the test files is that \code{unitizer} tracks the value of the seed and will tell you the seed changed for any given test (e.g. because you added a test in the middle of the file that uses the random seed). \item Working Directory: can be set to the tests directory inside the package directory if the test files appear to be inside the folder structure of a package, and the test file does not appear to be run as part of a check run (e.g. R CMD check, `tools::testInstalledPakage`). If test files are not inside a package directory structure then can be set to the test files' directory. \item Search Path: can be set to what you would typically find in a freshly loaded vanilla R session. This means any non default packages that are loaded when you run your tests are unloaded prior to running your tests. If you want to use the same libraries across multiple tests you can load them with the \code{pre} argument to \code{\link{unitize}} or \code{\link{unitize_dir}}. Due to limitations of R this is only an approximation to actually restarting R into a fresh session. \item Options: same as search path, but see "Namespaces" next. \item Namespaces: same as search path; this option is only made available to support options since many namespaces set options \code{onLoad}, and as such it is necessary to unload and re-load them to ensure default options are set. See the "Namespaces and Options" section. } In the \dQuote{suggested} state tracking mode (previously known as \dQuote{recommended}), parent environment, random seed, working directory, and search path are all managed to level 2, which approximates what you would find in a fresh session (see "Custom Control" section below). For example, with the search path managed, each test file will start evaluation with the search path set to the tests folder of your package. All these settings are returned to their original values when \code{unitizer} exits. To manage the search path \code{unitizer} detaches and re-attaches packages. This is not always the same as loading a package into a fresh R session as detaching a package does not necessarily undo every action that a package takes when it is loaded. See \code{\link{detach}} for potential pitfalls of enabling this setting. Additionally, packages attached in non-standard ways (e.g. \code{devtools::load_all}) may not re-attach properly. You can modify what aspects of state are managed by using the \code{state} parameter to \code{\link{unitize}}. If you are satisfied with basic default settings you can just use the presets described in the next section. If you want more control you can use the return values of the \code{state} and \code{in_pkg} functions as the values for the \code{state} parameter for \code{unitize}. State is reset after running each test file when running multiple test files with \code{unitize_dir}, which means state changes in one test file will not affect the next one. } \section{State Presets}{ For convenience \code{unitizer} provides several state management presets that you can specify via the \code{state} parameter to \code{\link{unitize}}. The simplest method is to specify the preset name as a character value: \itemize{ \item "suggested": \itemize{ \item Use special (non \code{.GlobalEnv}) parent environemnt \item Manage search path \item Manage random seed (and set it to be of type "Wichmann-Hill" for space considerations). \item Manage workign directory \item Leave namespace and options untouched } \item "safe" like suggested, but turns off tracking for search path in addition to namespaces and options. These settings, particularly the last two, are the most likely to cause compatibility problems. \item "pristine" implements the highest level of state tracking and control \item "basic" keeps all tracking, but at a less aggressive level; state is reset between each test file to the state before you started \code{unitize}ing so that no single test file affects another, but the state of your workspace, search path, etc. when you launch \code{unitizer} will affect all the tests (see the Custom Control) section. \item "off" (default) state tracking is turned off } } \section{Custom Control}{ If you want to customize each aspect of state control you can pass a \code{unitizerState} object as the \code{state} argument. The simplest way to do this is by using the \code{\link{state}} constructor function. Look at the examples for how to do this. For convenience \code{unitize} allows you to directly specify a parent environment if all you want to change is the parent evaluation environment but are otherwise satisfied with the defaults. You can even use the \code{\link{in_pkg}} function to tell \code{unitizer} to use the namespace associated with your current project, assuming it is an R package. See examples for details. If you do chose to modify specific aspects of state control here is a guide to what the various parameter values for \code{state} do: \itemize{ \item For \code{par.env}: any of the following: \itemize{ \item \code{NULL} to use the special \code{unitizer} parent environment as the parent environment; this environment has for parent the parent of \code{.GlobalEnv}, so any tests evaluated therein will not be affected by objects in \code{.GlobalEnv} see (\code{vignette("unitizer_reproducible_state")}). \item an environment to use as the parent evaluation environment \item the name of a package to use that package's namespace environment as the parent environment \item the return value of \code{in_pkg}; used primarily to autodetect what package namespace to use based on package directory structure } \item For all other slots, the settings are in \code{0:2} and mean: \itemize{ \item 0 turn off state tracking \item 1 track, but start with state as it was when \code{unitize} was called. \item 2 track and set state to what you would typically find in a clean R session, with the exception of \code{random.seed}, which is set to \code{getOption("unitizer.seed")} (of kind "Wichmann-Hill" as that seed is substantially smaller than the R default seed). } } If you chose to use level \code{1} for the random seed you should consider picking a random seed type before you start unitizer that is small like "Wichman-Hill" as the seed will be recorded each time it changes. } \section{Permanently Setting State Tracking}{ You can permanently change the default state by setting the \dQuote{unitizer.state} option to the name of the state presets above or to a or to a state settings option object generated with \code{state} as described in the previous section. } \section{Avoiding \code{.GlobalEnv}}{ For the most part avoiding \code{.GlobalEnv} leads to more robust and reproducible tests since the tests are not influenced by objects in the workspace that may well be changing from test to test. There are some potential issues when dealing with functions that expect \code{.GlobalEnv} to be on the search path. For example, \code{setClass} uses \code{topenv} to find a default environment to assign S4 classes to. Typically this will be the package environment, or \code{.GlobalEnv}. However, when you are in \code{unitizer} this becomes the next environment on the search path, which is typically locked, which will cause \code{setClass} to fail. For those types of functions you should specify them with an environment directly, e.g. \code{setClass("test", slots=c(a="integer"), where=environment())}. } \section{Namespaces and Options}{ Options and namespace state management require the ability to fully unload any non-default packages and namespaces, and there are some packages that cannot be unloaded, or should not be unloaded (e.g. \href{https://github.com/Rdatatable/data.table/issues/990}{data.table}). I some systems it may even be impossible to fully unload any compiled code packages (see \code{\link{detach}}. If you know the packages you typically load in your sessions can be unloaded, you can turn this functionality on by setting \code{options(unitizer.state="pristine")} either in your session, in your \code{.Rprofile} file, or using \code{state="prisitine"} in each call to \code{unitize} or \code{unitize_dir}. If you have packages that cannot be unloaded, but you still want to enable these features, see the "Search Path and Namespace State Options" section of \code{\link{unitizer.opts}} docs. If you run \code{unitizer} with options and namespace tracking and you run into a namespace that cannot be unloaded, or should not be unloaded because it is listed in \code{getOption("unitizer.namespace.keep")}, \code{unitizer} will turn off \code{options} state tracking from that point onwards. Additionally, note that \code{warn} and \code{error} options are always set to \code{1} and \code{NULL} respectively during test evaluation, irrespective of what option state tracking level you select. } \section{Known Untracked State Elements}{ \itemize{ \item system time: tests involving functions such as \code{\link{date}} will inevitably fail \item locale: is not tracked because it so specific to the system and so unlikely be be changed by user action; if you have tests that depend on locale be sure to set the locale via the \code{pre} argument to \code{\link{unitize}}, and also to reset it to the original value in \code{post}. } } \examples{ \dontrun{ ## In this examples we use `...` to denote other arguments to `unitize` that ## you should specify. All examples here apply equally to `unitize_dir` ## Run with suggested state tracking settings unitize(..., state="suggested") ## Manage as much of state as possible unitize(..., state="pristine") ## No state management, but evaluate with custom env as parent env my.env <- new.env() unitize(..., state=my.env) ## use custom environment, and turn on search.path tracking ## here we must use the `state` function to construct a state object unitize(..., state=state(par.env=my.env, search.path=2)) ## Specify a namespace to run in by name unitize(..., state="stats") unitize(..., state=state(par.env="stats")) # equivalent to previous ## Let `unitizer` figure out the namespace from the test file location; ## assumes test file is inside package folder structure unitize("mytests.R", state=in_pkg()) # assuming mytests.R is part of a pkg unitize("mytests.R", state=in_pkg("mypkg")) # also works } } \seealso{ \code{\link{unitize}}, \code{\link{unitizer.opts}} } unitizer/man/validate_pre_post.Rd0000644000176200001440000000044714766101222016677 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unitize.core.R \name{validate_pre_post} \alias{validate_pre_post} \title{Helper function for validations} \usage{ validate_pre_post(what, test.dir) } \description{ Helper function for validations } \keyword{internal} unitizer/man/invalidateLs.Rd0000644000176200001440000000046614766101222015613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ls.R \name{invalidateLs} \alias{invalidateLs} \title{Clears ls Info and Marks as Invalid} \usage{ invalidateLs(x, ...) } \description{ Useful when tests envs are repaired, or if we're looking at an ignored test } \keyword{internal} unitizer/man/set_unitizer.Rd0000644000176200001440000000654014766101222015717 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get.R \name{set_unitizer} \alias{set_unitizer} \alias{get_unitizer} \alias{get_unitizer.character} \alias{get_unitizer.default} \alias{get_unitizer.unitizer_result} \alias{get_unitizer.unitizer_results} \title{Set and Retrieve Store Contents} \usage{ set_unitizer(store.id, unitizer) get_unitizer(store.id) \method{get_unitizer}{character}(store.id) \method{get_unitizer}{default}(store.id) \method{get_unitizer}{unitizer_result}(store.id) \method{get_unitizer}{unitizer_results}(store.id) } \arguments{ \item{store.id}{a filesystem path to the store (an .rds file)} \item{unitizer}{a \code{unitizer-class} object containing the store data} } \value{ \itemize{ \item set_unitizer TRUE if unitizer storing worked, error otherwise \item get_unitizer a \code{unitizer-class} object, FALSE if \code{store.id} doesn't exist yet, or error otherwise; note that the \code{unitizer_results} method returns a list } } \description{ These functions are not used directly; rather, they are used by \code{\link{unitize}} to get and set the \code{unitizer} objects. You should only need to understand these functions if you are looking to implement a special storage mechanism for the \code{unitizer} objects. } \details{ By default, only a character method is defined, which will interpret its inputs as a filesystem path to the \code{unitizer} folder. RDSes of serialization type 2 will be stored and retrieved from there. The serialization format may change in the future, but if R maintains facilities to read/write type 2, we will provide the option to use that format. At this time there is no API to change the serialization format. You may write your own methods for special storage situations ( e.g SQL database, ftp server, etc) with the understanding that the getting method may only accept one argument, the \code{store.id}, and the setting method only two arguments, the \code{store.id} and the \code{unitizer}. S3 dispatch will be on \code{store.id}, and \code{store.id} may be any R object that identifies the unitizer. For example, a potential SQL implementation where the unitizers get stored in blobs may look like so: \preformatted{ my.sql.store.id <- structure( list( server="myunitizerserver.mydomain.com:3306", database="unitizers", table="project1", id="cornercasetests" ), class="sql_unitizer" ) get_unitizer.sql_unitizer <- function(store.id) { # FUNCTION BODY } set_unitizer.sql_unitizer <- function(store.id, unitizer) { # FUNCTION BODY } unitize("unitizer/cornertestcases.R", my.sql.store.id) } Make sure you also define an \code{as.character} method for your object to produce a human readable identifying string. For inspirations for the bodies of the _store functions look at the source code for \code{unitizer:::get_unitizer.character} and \code{unitizer:::set_unitizer.character}. Expectations for the functions are as follows. \code{get_unitizer} must: \itemize{ \item return a \code{unitizer-class} object if \code{store.id} exists and contains a valid object \item return FALSE if the object doesn't exist (e.g. first time run-through, so reference copy doesn't exist yet) \item \code{\link{stop}} on error } \code{set_unitizer} must: \itemize{ \item return TRUE on success \item \code{\link{stop}} on error } } \seealso{ \code{\link{saveRDS}} } unitizer/man/demo.Rd0000644000176200001440000000447114766101222014120 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/demo.R \name{unitizer_demo} \alias{unitizer_demo} \alias{[Press ENTER to Continue]} \alias{show_file} \alias{copy_fastlm_to_tmpdir} \alias{update_fastlm} \alias{unitizer_check_demo_state} \alias{unitizer_cleanup_demo} \title{Demo Details and Helper Functions} \usage{ `[Press ENTER to Continue]`() show_file(f, width = getOption("width", 80L)) copy_fastlm_to_tmpdir() update_fastlm(dir, version) unitizer_check_demo_state() unitizer_cleanup_demo() } \arguments{ \item{f}{path to a file} \item{width}{display width in characters} \item{dir}{path to the temporary package} \item{version}{one of "0.1.0", "0.1.1", "0.1.2"} } \value{ character(1L) } \description{ \code{unitizer} provides an interactive demo you can run with \code{demo("unitizer")}. } \section{Demo Details}{ The demo centers around simulated development of the \code{utzflm} package. \code{unitizer} includes in its sources three copies of the source code for the \code{utzflm} package, each at a different stage of development. This allows us to create reference \code{unitizer} tests under one version, move to a new version and check for regressions, and finally fix the regressions with the last version. The version switching is intended to represent the package development process. The demo manages the \code{utzflm} code changes, but between each update allows the user to interact with \code{unitizer}. The demo operates under the assumption that the user will accept the first set of tests and reject the failing tests after the first update. If the user does anything different then the demo commentary may not apply anymore. } \section{\code{utzflm}}{ \code{utzflm} is a "dummy" package that implements a faster computation of slope, intercept, and R^2 for single variable linear regressions than is available via \code{summary(lm()...)}. } \section{Helper Functions}{ \code{copy_fastlm_to_tmpdir} copies the initial version of the \code{utzflm} sources to a temporary directory, \code{show_file} displays the contents of a source code file, \code{update_fastlm} changes the source code of \code{utzflm}, and \code{unitizer_check_demo_state} and \code{unitizer_cleanup_demo} perform janitorial functions. None of these functions are intended for use outside of the unitizer demo. } unitizer/man/show.conditionList.Rd0000644000176200001440000000140014766101222016762 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditions.R \name{show.conditionList} \alias{show.conditionList} \alias{show,conditionList-method} \title{Prints A list of Conditions} \usage{ \S4method{show}{conditionList}(object) } \arguments{ \item{object}{a \code{\link{conditionList}} object (list of conditions)} } \value{ object, invisibly } \description{ S4 method for \code{\link{conditionList}} objects. } \examples{ ## Create a test item as you would find normally at the `unitizer` prompt ## for illustrative purposes: .NEW <- mock_item() ## Show the conditions the test generated (typing `show` here is optional ## since auto-printing should dispatch to `show`) show(.NEW$conditions) } \seealso{ \code{\link{conditionList}} } unitizer/man/nextItem-unitizerList-method.Rd0000644000176200001440000000214114766101222020742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/list.R \name{nextItem,unitizerList-method} \alias{nextItem,unitizerList-method} \alias{prevItem,unitizerList-method} \alias{getItem,unitizerList-method} \alias{reset,unitizerList-method,} \alias{done,unitizerList-method} \title{Iterate through items of a \code{\link{unitizerList}} ObjectJK} \usage{ \S4method{nextItem}{unitizerList}(x) } \arguments{ \item{x}{a \code{\link{unitizerList}} object} } \value{ \code{\link{unitizerList}} for \code{getItem}, an item from the list, which could be anything } \description{ Extraction process is a combination of steps: \enumerate{ \item Move Internal pointer with \code{nextItem} or \code{prevItem} \item Retrieve item \code{getItem} \item Check whether we're done iterating with \code{done} } \code{done} will return TRUE if the pointer is on either the first or last entry depending on what direction you are iterating. If you wish to iterate from the last item forward, you should either \code{reset} with parameter \code{reverse} set to TRUE, or re-order the items. } \keyword{internal} unitizer/man/as.character.bullet.Rd0000644000176200001440000000113614766101401017012 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/asciiml.R \name{as.character.bullet} \alias{as.character.bullet} \title{Produce Character Vector Representation of Bullet Lists} \usage{ \method{as.character}{bullet}(x, width = 0L, ...) } \arguments{ \item{x}{object to render} \item{width}{how many characters to wrap at} \item{...}{dots, other arguments to pass to \code{word_wrap}} } \value{ character vector containing rendered object, where each element corresponds to a line } \description{ Produce Character Vector Representation of Bullet Lists } \keyword{internal} unitizer/man/as.character-unitizerChanges-method.Rd0000644000176200001440000000056614766101222022151 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/change.R \name{as.character,unitizerChanges-method} \alias{as.character,unitizerChanges-method} \title{Print Out A Summary Of the Changes} \usage{ \S4method{as.character}{unitizerChanges}(x, width = getOption("width"), ...) } \description{ Print Out A Summary Of the Changes } \keyword{internal} unitizer/man/unitizer.Rd0000644000176200001440000000166214766351173015060 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unitizer-package.R \docType{package} \name{unitizer} \alias{unitizer} \alias{unitizer-package} \title{unitizer} \description{ Simplifies regression tests by comparing objects produced by test code with earlier versions of those same objects. If objects are unchanged the tests pass. `unitizer` provides an interactive interface to review failing tests or new tests. See vignettes for details. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/brodieG/unitizer} \item Report bugs at \url{https://github.com/brodieG/unitizer/issues} } } \author{ \strong{Maintainer}: Brodie Gaslam \email{brodie.gaslam@yahoo.com} Other contributors: \itemize{ \item Michael https://github.com/MichaelChirico \email{michaelchirico4@gmail.com} [contributor] \item R Core Team \email{R-core@r-project.org} (Traceback function sources.) [copyright holder] } } unitizer/man/as.expression-unitizerList-method.Rd0000644000176200001440000000077514766101222021761 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/list.R \name{as.expression,unitizerList-method} \alias{as.expression,unitizerList-method} \title{Coerce to expression by returning items coerced to expressions} \usage{ \S4method{as.expression}{unitizerList}(x, ...) } \description{ Really only meaningful for classes that implement the \code{.items} slot as an expression, but works for others to the extent \code{.items} contents are coercible to expressions } \keyword{internal} unitizer/man/unitizer_sect.Rd0000644000176200001440000001332414766360077016077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/section.R \name{unitizer_sect} \alias{unitizer_sect} \title{Define a \code{unitizer} Section} \usage{ unitizer_sect( title = NULL, expr = expression(), details = character(), compare = new("testFuns") ) } \arguments{ \item{title}{character 1 length title for the section, can be omitted though if you do omit it you will have to refer to the subsequent arguments by name (i.e. \code{unitizer_sect(expr=...)})} \item{expr}{test expression(s), most commonly a call to \code{{}} with several calls inside (see examples)} \item{details}{character more detailed description of what the purpose of the section is; currently this doesn't do anything.} \item{compare}{a function or a \code{\link{testFuns}} object} } \description{ The purpose of \code{unitizer} sections is to allow the user to tag a group of test expressions with meta information as well as to modify how tests are determined to pass or fail. } \note{ if you want to modify the functions used to compare conditions, keep in mind that the conditions are stored in \code{\link{conditionList}} objects so your function must loop through the lists and compare conditions pairwise. By default \code{unitizer} uses the \code{all.equal} method for S4 class \code{conditionList}. \code{untizer} does not account for sections when matching new and reference tests. All tests will be displayed as per the section they belong to in the newest version of the test file, irrespective of what section they were in when the tests were last run. Calls to \code{unitizer_sect} should be at the top level of your test script, or nested within other \code{unitizer_sect}s (see "Nested Sections"). Do not expect code like \code{(untizer_sect(..., ...))} or \code{{unitizer_sect(..., ...)}} or \code{fun(unitizer_sect(..., ...))} to work. } \section{Tested Data}{ \code{unitizer} tracks the following: \itemize{ \item value: the return value of the test \item conditions: any conditions emitted by the test (e.g. warnings or errors) \item output: screen output \item message: stderr output \item aborted: whether the test issued an `abort` restart (e.g. by calling `stop` directly or indirectly) } In the future stdout produced by the test expression itself may be captured separately from that produced by print/showing of the return value, but at this point the two are combined. Each of the components of the test data can be tested, although by default only \code{value} and \code{condition} are checked. Testing \code{output} is potentially duplicative of testing \code{value}, since most often \code{value} is printed to screen and the screen output of the value closely correlates to the actual value. In some cases it is useful to explicitly test the \code{output}, such as when testing \code{print} or \code{show} methods. } \section{Comparison Functions}{ The comparison function should accept at least two parameters, and require no more than two. For each test component, the comparison function will be passed the reference data as the first argument, and the newly evaluated data as the second. The function should return TRUE if the compared test components are considered equivalent, or FALSE. Instead of FALSE, the function may also return a character vector describing the mismatch, as \code{\link{all.equal}} does. \bold{WARNING}: Comparison functions that set and/or unset \code{\link{sink}} can potentially cause problems. If for whatever reason you must really sink and unsink output streams, please take extreme care to restore the streams to the state they were in when the comparison function was called. Any output to \code{stdout} or \code{stderr} is captured and only checked at the end of the \code{unitizer} process with the expectation that there will be no such output. \code{value} and \code{conditions} are compared with \code{\link{all_eq}}, which is a wrapper to \code{\link{all.equal}} except that it returns FALSE instead of a descriptive string on failure. This is because \code{unitizer} will run \code{\link[diffobj]{diffObj}} on the test data components that do not match and including the \code{all.equal} output would be redundant. If a comparison function signals a condition (e.g. throws a warning) the test will not be evaluated, so make sure that your function does not signal conditions unless it is genuinely failing. If you wish to provide custom comparison functions you may do so by passing an appropriately initialized \code{\link{testFuns}} object as the value to the \code{compare} parameter to \code{unitizer_sect} (see examples). Make sure your comparison functions are available to \code{\link{unitize}}. Comparisons will be evaluated in the environment of the test. By default \code{\link{unitize}} runs tests in environments that are not children to the global environment, so functions defined there will not be automatically available. You can either specify the function in the test file before the section that uses it, or change the base environment tests are evaluated in with \code{unitize(..., par.env)}, or make sure that the package that contains your function is loaded within the test script. } \section{Nested Sections}{ It is possible to have nested sections, but titles, etc. are ignored. The only effect of nested sections is to allow you to change the comparison functions for a portion of the outermost \code{unitizer_sect}. } \examples{ unitizer_sect("Switch to `all.equal` instead of `all_eq`", { fun(6L) fun("hello") }, compare=testFuns(value=all.equal, conditions=all.equal) ) unitizer_sect("Use identical for ALL test data, including stdout, etc.", { fun(6L) fun("hello") }, compare=identical ) } \seealso{ \code{\link{testFuns}}, \code{\link{all_eq}} } unitizer/man/unitizerTests-class.Rd0000644000176200001440000000044314766101222017166 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/test.R \docType{class} \name{unitizerTests-class} \alias{unitizerTests-class} \title{Collections of Calls For Testing} \description{ Should probably add an \code{as.unitizerTests} function... } \keyword{internal} unitizer/man/all.equal.condition.Rd0000644000176200001440000000402314766340624017043 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditions.R \name{all.equal.condition} \alias{all.equal.condition} \alias{all.equal,condition,ANY-method} \alias{all.equal,conditionList,ANY-method} \alias{all.equal.conditionList} \title{Compare Conditions} \usage{ \S4method{all.equal}{conditionList,ANY}(target, current, ...) \method{all.equal}{conditionList}(target, current, ...) \method{all.equal}{condition}(target, current, ...) } \arguments{ \item{target}{the list of conditions that we are matching against} \item{current}{the list of conditions we are checking} \item{...}{provided for compatibility with generic} } \value{ TRUE if the (lists of) conditions are equivalent, a character vector explaining why they are not otherwise } \description{ Tests that issue warnings or `stop` produce \code{\link{condition}} objects. The functions documented here are specialized versions of \code{\link{all.equal}} designed specifically to compare conditions and condition lists produced during \code{unitizer} test evaluations. \code{\link{conditionList}} objects are lists of conditions that come about when test expressions emit multiple conditions (e.g. more than one warning). } \details{ \code{\link{condition}} objects produced by tests have one additional attributed \dQuote{printed} which disambiguates whether a condition was the result of the test expression, or the \code{print} / \code{show} method used to display it to screen. For \code{conditionList} objects, these methods only return TRUE if all conditions are pairwise \code{all.equal}. } \examples{ cond.1 <- simpleWarning('hello world') cond.2 <- simpleError('hello world') cond.3 <- simpleError('goodbye world') all.equal(cond.1, cond.1) all.equal(cond.1, cond.2) all.equal(cond.2, cond.3) ## Normally you would never actually create a `conditionList` yourself; these ## are automatically generated by `unitizer` for review at the `unitizer` ## prompt all.equal( conditionList(.items=list(cond.1, cond.2)), conditionList(.items=list(cond.1, cond.3)) ) } unitizer/man/unitizer_ls.Rd0000644000176200001440000000124714766101222015541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ls.R \name{unitizer_ls} \alias{unitizer_ls} \title{An `ls` Like Function} \usage{ unitizer_ls( name, pos = -1L, envir = parent.frame(), all.names = FALSE, pattern ) } \value{ list of object names, or a list with environments containing the objects } \description{ Much like `ls`, except that it is designed to crawl up the \code{`.new`} and \code{`.ref`} environments and display all the objects. } \details{ This is used in \code{`browseUnitizer,unitizer-unitizerBrowse-method`}, and is re-assigned to \code{`ls`} for use in the \code{`unitizer`} prompt environment. } \keyword{internal} unitizer/man/editCalls.Rd0000644000176200001440000000314114766101222015071 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename.R \name{editCalls} \alias{editCalls} \alias{editCalls,unitizer,language,language-method} \title{Edit Calls In Unitizer} \usage{ editCalls(x, lang.old, lang.new, ...) \S4method{editCalls}{unitizer,language,language}( x, lang.old, lang.new, interactive.mode = interactive(), interactive.only = TRUE, ... ) } \arguments{ \item{x}{a unitizer object} \item{lang.old}{the name of the function replace} \item{lang.new}{the new name of the function} \item{...}{unused} \item{interactive.mode}{logical(1L) whether to run in interactive mode ( request user input when needed) or not (error if user input is required, e.g. if all tests do not pass).} \item{interactive.only}{logical(1L) set to FALSE if you want to allow this to run in non-interactive mode, but warnings will be suppressed and will proceed without prompting, obviously...} } \value{ a untizer object with function names modifies } \description{ Used if you want to change language in test expression in a unitizer when the actual results of running the expressions is unchanged. This is useful if you decided to rename functions, etc., without having to re-run the entire \code{unitize} process since \code{unitize} matches tests based on expressions. } \note{ this is a somewhat experimental function, so make sure you backup any unitizers before you try to use it. } \examples{ \dontrun{ untz <- get_unitizer("tests/unitizer/mytests.unitizer") untz.edited <- editCalls(untz, quote(myFun), quote(my_fun)) set_unitizer("tests/unitizer/mytests.unitizer", untz.edited) } } unitizer/man/conditionList.Rd0000644000176200001440000000304114766101222016006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditions.R \docType{class} \name{conditionList} \alias{conditionList} \alias{conditionList-class} \title{Contains A List of Conditions} \description{ Condition lists are S4 classes that contain \code{\link{condition}} objects emitted by \code{unitizer} tests. Condition lists will typically be accessible via the \code{.NEW} and \code{.REF} \code{unitizer} test objects. You can access individual conditions using \code{[[} (see examples), and for the most part you can treat them as you would an S3 list containing conditions. } \details{ There are \code{show} and \code{all.equal} methods implemented for them, the latter of which is used to compare conditions across tests. If you wish to implement a custom comparison function via \code{\link{unitizer_sect}}, your function will need to compare \code{conditionList} objects. } \section{Slots}{ \describe{ \item{\code{.items}}{list of conditions} }} \note{ Implemented as an S4 class to avoid \code{setOldClass} and related compatibility issues; the \code{conditionList} class contains \code{\link{unitizerList}}. } \examples{ ## Create a test item as you would find normally at the `unitizer` prompt ## for illustrative purposes: .NEW <- mock_item() ## Access the first condition from the new test evaluation .NEW$conditions[[1L]] ## loop through all conditions for(i in seq_along(.NEW$conditions)) .NEW$conditions[[i]] } \seealso{ \code{\link{unitizer_sect}}, \code{\link{unitizerList}}, \code{\link{all.equal.conditionList}} } unitizer/man/testthat_transcribe_file.Rd0000644000176200001440000000352314766101222020244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/translate.R \name{testthat_transcribe_file} \alias{testthat_transcribe_file} \title{Transcribes a \code{testtaht} File Into \code{unitizer} Format} \usage{ testthat_transcribe_file( file.name, target.dir = file.path(dirname(file.name), "..", "unitizer"), keep.testthat.call = TRUE, prompt = "always", interactive.mode, use.sects = TRUE, ... ) } \arguments{ \item{file.name}{a path to the \code{testthat} test file to convert} \item{target.dir}{the directory to create the \code{unitizer} test file and test store in; for \code{testthat_translate_file} only: if NULL will return as a character vector what the contents of the translated file would have been instead of writing the file} \item{keep.testthat.call}{whether to preserve the \code{testthat} call that was converted, as a comment} \item{prompt}{character(1L): \itemize{ \item "always" to always prompt before writing new files \item "overwrite" only prompt if existing file is about to be overwritten \item "never" never prompt }} \item{interactive.mode}{logical(1L) primarily for testing purposes, allows us to force prompting in non-interactive mode; note that \code{unitize} and \code{unitize_dir} are always called in non-interactive mode by these functions, this parameter only controls prompts generated directly by these functions.} \item{use.sects}{TRUE (default) or FALSE whether to translate \code{test_that} sections to \code{unitizer_sect} or simply to turn them into comment banners.} \item{...}{params to pass on to \code{testthat_translate_name}} } \description{ Internal use only, required so we can ensure the parse succeeded because of possible parse-deparse issues independent of running \code{unitize}, since \code{unitize} cannot be run inside a \code{tryCatch} block. } \keyword{internal} unitizer/man/capture_output.Rd0000644000176200001440000000122014766101401016243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/text.R \name{capture_output} \alias{capture_output} \alias{print.captured_output} \title{Capture Both StdOut and StdErr} \usage{ capture_output(expr, env = parent.frame()) \method{print}{captured_output}(x, ...) } \arguments{ \item{expr}{a quoted expression to evaluate} \item{env}{an environment to evaluate them in} } \value{ a list with stdout and stderr captured separately, classed as "captured_output" } \description{ Will sink both "output" and "message" streams without checking whether they are already sunk, and will unsink them the same way. } \keyword{internal} unitizer/man/unitizer_prompt.Rd0000644000176200001440000001171714766101222016447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/prompt.R \name{unitizer_prompt} \alias{unitizer_prompt} \alias{navigate_prompt} \alias{review_prompt} \alias{simple_prompt} \alias{exit_fun} \alias{read_line} \alias{read_line_set_vals} \title{Interactively Retrieve User Input} \usage{ unitizer_prompt( text, browse.env = baseenv(), help = character(), help.opts = character(), valid.opts, hist.con = NULL, exit.condition = function(exp, env) FALSE, global, warn.sticky = FALSE, ... ) navigate_prompt( x, curr.id, text, browse.env1 = globalenv(), browse.env2 = globalenv(), help = character(), help.opts = character(), valid.opts, warn.sticky = FALSE ) review_prompt(x, nav.env) simple_prompt( message, values = c("Y", "N"), prompt = "unitizer> ", attempts = 5L, case.sensitive = FALSE ) exit_fun(y, env, valid.vals) read_line(prompt = "") read_line_set_vals(vals) } \arguments{ \item{text}{the prompt text to display} \item{browse.env}{the environment to evaluate user expressions in; typically this will contain interesting objects (use \code{ls()} to review)} \item{help}{a character vector with help suggestions: the first value in the vector is \code{\link{word_cat}} output, the rest normal \code{cat}} \item{help.opts}{a character vector of help options} \item{valid.opts}{the special letters user can type to get a special action, typically a character vector where the names are one letter (though they don't actually have to be) and are looked for as user typed input; note that the quit and help options will always be appended to this} \item{hist.con}{connection to save history to} \item{exit.condition}{function used to evaluate whether user input should cause the prompt loop to exit; this function should accept two parameters: \itemize{ \item expression typed in by the user \item environment the environment user expressions get evaluated in } The function can then decide to exit or not based on either the literal expression or evaluate the expression and decide based on the result. This is implemented this way because \code{eval_user_exp} will print to screen which may not be desirable. Function should return a value which will then be returned by \code{unitizer_prompt}, unless this value is \code{FALSE} in which case \code{unitizer_prompt} will continue with normal evaluation.} \item{global}{unitizerGlobal or NULL, if the global state tracking object; will be used to record state after evaluating user expressions} \item{warn.sticky}{TRUE or FALSE (default) whether any changes to the "warn" global option made by the evaluation of an R expression under the prompt should be allowed to stick after the evaluation. Normally that option value is reset after each evaluation.} \item{...}{additional arguments for \code{exit.condition}} \item{x}{a unitizerBrowse object} \item{curr.id}{which id we are currently browsing} \item{browse.env1}{environment to have user review tests, run commands, etc} \item{browse.env2}{navigation environment} \item{nav.env}{an environment} \item{message}{character ask the user a question} \item{values}{character valid responses} \item{prompt}{see \code{\link{readline}}} \item{attempts}{how many times to try before erroring} \item{case.sensitive}{whether to care about case sensitivity when matching user input} } \value{ \itemize{ \item \code{unitizer_prompt}: mixed allowable user input \item \code{navigate_prompt}: a \code{unitizerBrowse} object, or allowable user input \item \code{review_prompt}: a \code{unitizerBrowse} object, or "Q" if the user chose to quit \item \code{simple_prompt}: one of \code{values} as selected by user } } \description{ Different functions used in different contexts to capture user input. \code{unitizer_prompt}, \code{navigate_prompt}, and \code{review_prompt} are more advanced and allow evaluation of arbitrary expressions, in addition to searching for specific commands such as "Y", "N", etc. \code{simple_prompt} only matches along specified values. } \details{ The set-up is intended to replicate something similar to what happens when code hits a \code{browse()} statement. User expressions are evaluated and output to screen, and special expressions as described above cause the evaluation loop to terminate. \code{navigate_prompt} is just a wrapper around \code{unitizer_prompt} that provides the special shortcuts to navigate to other tests in the \code{unitizer}. \code{review_prompt} is also a wrapper, but used only when at the menu that presents available test items to navigate to. \code{simple_prompt} simpler prompting function used to allow user to select from pre-specified values. \code{exit_fun} is used as a generic function to pass to the \code{exit.condition} argument of \code{unitizer_prompt}. \code{read_line} and \code{read_line_set_vals} are utility functions that are used to implement a version of \code{\link{readline}} that can be automated for testing. } \seealso{ browse_unitizer_items } \keyword{internal} unitizer/man/options_extra.Rd0000644000176200001440000000113114766101222016060 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{options_zero} \alias{options_zero} \alias{options_update} \alias{validate_options} \title{Set Options to Initial Zero State} \usage{ options_zero( base = merge_lists(getOption("unitizer.opts.init.base"), getOption("unitizer.opts.init")), as.is = union(getOption("unitizer.opts.asis.base"), getOption("unitizer.opts.asis")) ) options_update(tar.opts) validate_options(opts.to.validate, test.files = NULL) } \description{ This makes sure to unset options not present in target. } \keyword{internal} unitizer/man/sizeUntz.Rd0000644000176200001440000000046314766101222015024 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{sizeUntz} \alias{sizeUntz} \title{Utility To Examine Object Size} \usage{ sizeUntz(x, ...) } \description{ Funny name is just to avoid conflicts with functions with same names in other packages. } \keyword{internal} unitizer/man/filename_to_storeid.Rd0000644000176200001440000000117014766101222017200 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.R \name{filename_to_storeid} \alias{filename_to_storeid} \title{Create a Store ID from a Test File Name} \usage{ filename_to_storeid(x) } \arguments{ \item{x}{character(1L) file name ending in .r or .R} } \value{ store id name, or NULL if \code{x} doesn't meet expectations } \description{ Create a Store ID from a Test File Name } \examples{ filename_to_storeid(file.path("tests", "unitizer", "foo.R")) filename_to_storeid(file.path("tests", "unitizer", "boo.r")) # does not end in [rR] filename_to_storeid(file.path("tests", "unitizer", "boo")) } unitizer/man/infer_unitizer_location.Rd0000644000176200001440000000612314766101222020114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get.R \name{infer_unitizer_location} \alias{infer_unitizer_location} \alias{infer_unitizer_location.default} \alias{infer_unitizer_location.character} \title{Infers Possible Unitizer Path From Context} \usage{ infer_unitizer_location(store.id, ...) \method{infer_unitizer_location}{default}(store.id, ...) \method{infer_unitizer_location}{character}( store.id, type = "f", interactive.mode = interactive(), ... ) } \arguments{ \item{store.id}{character(1L) file or directory name, the file name portion (i.e after the last slash) may be partially specified} \item{...}{arguments to pass on to other methods} \item{type}{character(1L) in \code{c("f", "u", "d")}, \code{"f"} for test file, \code{"d"} for a directory, \code{"u"} for a \code{unitizer} directory} \item{interactive.mode}{logical(1L) whether to allow user input to resolve ambiguities} } \value{ character(1L) an inferred path, or \code{store.id} with a warning if path cannot be inferred } \description{ Used by most \code{unitizer} functions that operate on \code{unitizer}s to make it easy in interactive use to specify the most likely intended \code{unitizer} in a package or a directory. For `R CMD check` and similar testing should not rely on this functionality. } \details{ This is implemented as an S3 generic to allow third parties to define inference methods for other types of \code{store.id}, but the documentation here is for the \code{"character"} method which is what \code{unitizer} uses by default. If \code{store.id} is a directory that appears to be an R package (contains DESCRIPTION, an R folder, a tests folder), will look for candidate files in \code{file.path(store.id, "tests", "unitizer")}, starting with files with the same name as the package (ending in ".R" or ".unitizer" if \code{type} is \code{"f"} or \code{"u"} respectively), or if there is only one file, that file, or if there are multiple candidate files and in interactive mode prompting user for a selection. If \code{type} is \code{"d"}, then will just provide the \code{"tests/unitizer"} directory. If \code{name} is not a directory, will try to find a file by that name, and if that fails, will try to partially match a file by that name. Partial matching requires the front portion of the name to be fully specified and no extension be provided (e.g. for \code{"mytests.R"}, \code{"myt"} is valid, but \code{"tests"} and \code{"myt.R"} are both invalid). Partially specified files may be specified in subdirectories (e.g. \code{"tests/myt"}). Inference assumes your files end in \code{".R"} for code files and \code{".unitizer"} for \code{unitizer} data directories. If \code{store.id} is NULL, the default \code{infer_unitizer_location} method will attempt to find the top level package directory and then call the character method with that directory as \code{store.id}. If the parent package directory cannot be found, then the character method is called with the current directory as the argument. } \seealso{ \code{\link{get_unitizer}} for discussion of alternate \code{store.id} objects } unitizer/man/healEnvs.Rd0000644000176200001440000000723214766101222014737 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/heal.R \name{healEnvs} \alias{healEnvs} \alias{healEnvs,unitizerItems,unitizer-method} \title{Fix Environment Ancestries} \usage{ \S4method{healEnvs}{unitizerItems,unitizer}(x, y, ...) } \arguments{ \item{x}{\code{unitizerItems} object} \item{y}{\code{unitizer} object \code{x} was generated from} \item{...}{unused, here for inheriting methods} } \value{ \code{unitizerItems} } \description{ This is an internal method and exposed so that this aspect of \code{unitizer} is documented for package users (see Details). } \details{ Environment healing is necessary because when we let the user pick and chose which tests to store and which ones to reject, there may no longer be a clear ancestry chain within the remaining tests. The healing process is somewhat complex and full of compromises. We are attempting to create a self consistent set of nested parent environments for each test, but at the same time, we don't want to store all the combinations of reference and new objects. We only store new objects in \code{unitizer}, with the lone exception of objects associated to a test environment. These will include any assignments that occur just prior to a test, as well as any objects created by the actual test. There are two ways in which we modify the environment ancestry. If the user decides to not store some new tests, then the objects created in between the previous new stored test and the next new stored test are all moved to the next new stored test, and the previous new stored test becomes the parent of the next new stored test. The second way relates to when the user decides to keep a reference test over a matching new test. This is a lot more complicated because we do not preserve the reference test environment ancestry. Effectively, we need to graft the reference test to the new environment ancestry. If a reference test that is being kept matches directly to a new test, then the parent of that new test becomes the parent of the reference test. If there is no direct match, but there are child reference tests that match to a new item, then the parent is the youngest new test that is older than the new test that was matched and is kept. If no new tests meet this criterion, then base.env is the parent. If there is no direct match, and there are no child reference tests that are being kept that do match to a kept new item, then the parent will be the last new test that is kept. The main takeaway from all this is that reference tests don't really keep their evaluation environment. Often this environment is similar to the new environment. When there are difference between the two, the output of \code{ls} is customized to highlight which objects were actually available/unmodified at the time of the reference test evaluation. Object names will have the following symbols appended to explain the object status: \itemize{ \item ': object exists in browsing environment, but not the same as it was when test was evalaluated \item *: object was present during test evaluation but is not available in unitizer anymore \item **: object was not present during test evaluation, but exists in current environment } } \note{ Could be more robust by ensuring that items in \code{x} actually do come from \code{y}. This is particularly important since when we re-assemble the final list, we don't actually use x at all. Signature for this should probably ultimately change to be something like \code{c("unitizer", "x")} where x is just a data frame with column 1 the item index, and column 2 whether it originated from "new" or "ref" } \seealso{ \code{updateLs,unitizerItem-method} } unitizer/man/show-unitizerChanges-method.Rd0000644000176200001440000000050214766101222020561 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/change.R \name{show,unitizerChanges-method} \alias{show,unitizerChanges-method} \title{Print Out A Summary Of the Changes} \usage{ \S4method{show}{unitizerChanges}(object) } \description{ Print Out A Summary Of the Changes } \keyword{internal} unitizer/man/unitizer_result.Rd0000644000176200001440000000507414766101222016443 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/result.R \name{unitizer_result} \alias{unitizer_result} \alias{unitizer_results} \alias{print.unitizer_result} \alias{print.unitizer_results} \title{Return Values and Related Methods for \code{unitize} Functions} \usage{ \method{print}{unitizer_result}(x, ...) \method{print}{unitizer_results}(x, ...) } \arguments{ \item{x}{the object to print} \item{...}{extra arguments for print generic} } \value{ \code{x}, invisibly } \description{ \code{unitize} and related functions are run primarily for the interactive environment they provide and for their side effects (updating stored \code{unitizer} objects), but the return values may be useful under some circumstances if you need to retrieve test status, user selections, etc.. } \details{ \code{unitize} and \code{review} return a \code{unitizer_result} S3 object. This is a data frame that contains details about the status of each test. \code{unitize_dir} returns a \code{unitize_results} S3 object, which is a list of \code{unitize_result} objects. Both \code{unitize_results} and \code{unitize_result} have \code{print} methods documented here. In addition to the \code{print} methods, both of the result objects have \code{\link{get_unitizer}} methods so that you can retrieve the stored \code{unitizer} objects. Please note that with \code{unitize_dir} you can re-review a single \code{unitizer} several times during during a single call to \code{unitize_dir}. This is to allow you to re-evaluate specific \code{unitizers} easily without having to re-run the entire directory again. Unfortunately, as a result of this feature, the return values of \code{unitize_dir} can be misleading because they only report the result of the last review cycle. Additionally, \code{unitize_dir} will report user selections during the last review even if in the end the user chose not to save the modified \code{unitizer}. You will be alerted to this by an onscreen message from the \code{print} method (this is tracked in the "updated" attribute of the \code{unitizer_result} object). Finally, if in the last iteration before exit you did not save the \code{unitizer}, but you did save it in previous review cycles in the same \code{unitize_dir} call, the displayed selections and test outcomes will correspond to the last unsaved iteration, not the one that was saved. You will be alerted to this by an on-screen message (this is tracked through the "updated.at.least.once" attribute of the \code{unitizer_result} object). } \seealso{ \code{\link{unitize}}, \code{\link{get_unitizer}} } unitizer/man/unitizerChanges-class.Rd0000644000176200001440000000061314766101222017433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/change.R \docType{class} \name{unitizerChanges-class} \alias{unitizerChanges-class} \title{Summary of Changes} \description{ Changes arise any time a user, through the interactive unitizer mode, requests the storing of a change (accept new version of failed test, add new test, remove old test). } \keyword{internal} unitizer/man/getFun.Rd0000644000176200001440000000032714766101222014420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shims.R \name{getFun} \alias{getFun} \title{Utility Function} \usage{ getFun(name) } \description{ Utility Function } \keyword{internal} unitizer/man/unitizer.opts.Rd0000644000176200001440000001533014766101222016025 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{unitizer.opts} \alias{unitizer.opts} \title{Unitizer Options} \description{ Description of major \code{unitizer} option settings. Once \code{unitizer} is loaded, you can see a full list of \code{unitizer} options with \code{grep("^unitizer", options(), value=TRUE)}. } \section{Basic State Options}{ Basic state options: \itemize{ \item \code{unitizer.state}: default state tracking setting (see \code{unitizerState}) \item \code{unitizer.seed}: default seed to use when random seed tracking is enabled; this is of type "Wichman-Hill" because it is a lot more compact than the default R random seed, and should be adequate for most unit testing purposes. } } \section{Options State Options}{ Additionally, when tracking option state we set options to what you would find in a freshly loaded vanilla R session, except for systems specific options which we leave unchanged (e.g. \code{getOption("papersize")}). If you want to add default option values or options to leave unchanged, you can use: \itemize{ \item \code{unitizer.opts.init}: named list, where names are options, and the associated value is the value to use as the default value for that option when a \code{unitizer} is launched with options tracking enabled. \item \code{unitizer.opts.asis}: character, containing regular expressions to match options to leave unchanged (e.g \code{"^unitizer\\."}) } } \section{Search Path and Namespace State Options}{ We also provide options to limit what elements can be removed from the search path and/or have their namespaces unloaded when \code{unitizer} tracks the search path state. For example, we use this mechanism to prevent removal of the \code{unitizer} package itself as well as the default R vanilla session packages. \itemize{ \item \code{unitizer.namespace.keep}: character, names of namespaces to keep loaded (e.g. \code{"utils"}); note that any imported namespaces imported by namespaces listed here will also remain loaded \item \code{unitizer.search.path.keep}: character, names of objects to keep on search path (e.g. \code{"package:utils"}, note the \code{"package:"}); associated namespaces will also be kept loaded } \bold{IMPORTANT}: There is a dependency between options tracking and search path / namespace exceptions that stems from most packages setting their default options when they are loaded. As a result, if you add any packages or namespaces to these options and options state tracking is enabled, then you must also add their options to \code{unitizer.opts.init} or \code{unitizer.opts.asis} to ensure those options remain loaded or at least set to reasonable values. If you do not do this the packages risk having their options unset. Some packages cannot be easily loaded and unloaded. For example \code{data.table} (<= 1.9.5) cannot be unloaded without causing a segfault (see issue \href{https://github.com/Rdatatable/data.table/issues/990}{#990}). For this reason \code{data.table} is included in \code{getOption("unitizer.namespace.keep")} by default. } \section{Sytem Default State Options}{ The following options hold the default system values for the search path / namespace and options state tracking options: \itemize{ \item \code{unitizer.namespace.keep.base}: namespaces that are known to cause problems when unloaded (as of this writing includes \code{data.table}) \item \code{unitizer.search.path.keep.base}: vanilla R session packages, plus \code{"package:unitizer"} and \code{"tools:rstudio"}, the latter because its implementation prevents re-attaching it if it is detached. \item \code{unitizer.opts.asis.base}: system specific options that should not affect test evaluation (e.g. \code{getOption("editor")}). \item \code{unitizer.opts.init.base}: base options (e.g. \code{getOption("width")} that will be set to what we believe are the factory settings for them. } These are kept separate from the user specified ones to limit the possibility of inadvertent modification. They are exposed as options to allow the user to unset single values if required, though this is intended to be rare. \code{unitizer} runs with the union of user options and the system versions described here. For \code{unitizer.opts.init}, any options set that are also present in \code{unitizer.opts.init.base} will overrule the base version. } \section{Display / Text Capture Options}{ These options control how \code{unitizer} displays data such as diffs, test results, etc. \itemize{ \item \code{unitizer.test.out.lines}: integer(2L), where first values is maximum number of lines of screen output to show for each test, and second value is the number of lines to show if there are more lines than allowed by the first value \item \code{unitizer.test.msg.lines}: like \code{unitizer.test.out.lines}, but for \code{stderr output} \item \code{unitizer.test.fail.context.lines}: integer(2L), used exclusively when comparing new to references tests when test faile; first values is maximum number of lines of context to show around a test, centered on differences if there are any, and second value is the number of context lines to show if using the first value is not sufficient to fully display the test results \item \code{unitizer.show.output}: TRUE or FALSE, whether to display test \code{stdout} and \code{stderr} output as it is evaluated. \item \code{unitizer.disable.capt}: logical(2L), not NA, with names \code{c("output", "message")} where each value indicates whether the corresponding stream should be captured or not. For \code{stdout} the stream is still captured but setting the value to FALSE tees it. \item \code{unitizer.max.capture.chars}: integer(1L) maximum number of characters to allow capture of per test \item \code{unitizer.color} whether to use ANSI color escape sequences, set to TRUE to force, FALSE to force off, or NULL to attempt to auto detect (based on code from package:crayon, thanks Gabor Csardi) \item \code{unitizer.use.diff} TRUE or FALSE, whether to use a diff of test errors (defaults to TRUE) } } \section{Misc Options}{ \itemize{ \item \code{unitizer.history.file} character(1L) location of file to use to store history of command entered by user in in interactive \code{unitizer} prompt; \code{""} is interpreted as tempfile() \item \code{unitizer.prompt.b4.quit.time} integer(1L) \code{unitizers} that take more seconds than this to evaluate will post a confirmation prompt before quitting; this is to avoid accidentally quitting after running a \code{unitizer} with many slow running tests and having to re-run them again. } } \seealso{ \code{\link{unitizerState}} } unitizer/man/global_structures.Rd0000644000176200001440000000333614766101222016736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/global.R \docType{class} \name{unitizerGlobalBase-class} \alias{unitizerGlobalBase-class} \alias{unitizerGlobalStatus-class} \alias{unitizerGlobalDisabled-class} \alias{unitizerGlobalTracking-class} \alias{unitizerDummy-class} \alias{unitizerGlobalTrackingStore-class} \alias{unitizerGlobalState-class} \alias{unitizerGlobalIndices-class} \alias{unitizerGlobalStateFuns-class} \alias{unitizerGlobalNsOptConflict-class} \title{Structures For Tracking Global Options} \description{ Immplemented as S4 classes just so we can ensure everything is guaranteed to have the right slots. This is done by defining a virtual class that has a validity function that checks the required slots exist. } \details{ Not we don't use "ANY" slots here because that would allow partially specified sub classes (i.e. classes with slots that are "ANY"), which we do not want to allow. \code{unitizerGlobalTrackingStore} is used to keep "compressed" versions of \code{unitizerGlobal$tracking}. The compressed versions obviously lose some information. In particular, environments or things that have environments as parents, or large objects, are not stored and instead a reference to a \code{unitizerDummy} object is stored. This object unambiguously identifies a non-stored object since no user or system code should normally creating a \code{unitizerDummy} object. \code{unitizerGlobalState} tracks a single state which is just one value from each of the slots of \code{unitizerGlobalTrackingStore} When comparing state between new and reference tests, only explicitly stored items are compared (though any extra or missing items may be brought up as possible mismatches). } \keyword{internal} unitizer/man/valid_names.Rd0000644000176200001440000000050514766101222015450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/text.R \name{valid_names} \alias{valid_names} \title{Make Valid Names} \usage{ valid_names(x) } \arguments{ \item{x}{character vector} } \value{ character vector } \description{ If names are invalid, quotes them with backtics } \keyword{internal} unitizer/man/length-unitizerChanges-method.Rd0000644000176200001440000000046514766101222021072 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/change.R \name{length,unitizerChanges-method} \alias{length,unitizerChanges-method} \title{Return Sum of Total Changes} \usage{ \S4method{length}{unitizerChanges}(x) } \description{ Return Sum of Total Changes } \keyword{internal} unitizer/man/unitizerList.Rd0000644000176200001440000000322514766101222015675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/list.R \docType{class} \name{unitizerList} \alias{unitizerList} \title{S4 Object To Implement Base List Methods} \description{ Internal \code{unitizer} objects used to manage lists of objects. The only user facing instance of these objects are \code{\link{conditionList}} objects. For the most part these objects behave like normal S3 lists. The list contents are kept in the \code{.items} slot, and the following methods are implemented to make the object mostly behave like a standard R list: \code{[}, \code{[[}, \code{[<-}, \code{[[<-}, \code{as.list}, \code{append}, \code{length}, \code{names}, and \code{names<-}. } \details{ The underlying assumption is that the `.items` slot is a list (or an expression), and that slot is the only slot for which it's order and length are meaningful (i.e. there is no other list or vector of same length as `.items` in a different slot that is supposed to map to `.items`). This last assumption allows us to implement the subsetting operators in a meaningful manner. The validity method will run \code{validObject} on the first, last, and middle items (if an even number of items, then the middle closer to the first) assuming they are S4 objects. We don't run on every object to avoid potentially expensive computation on all objects. } \section{Slots}{ \describe{ \item{\code{.items}}{a list or expression} \item{\code{.pointer}}{integer, used for implementing iterators} \item{\code{.seek.fwd}}{logical used to track what direction iterators are going} }} \examples{ new('unitizerList', .items=list(1, 2, 3)) } \seealso{ \code{\link{conditionList}} } unitizer/man/testthat_translate_file.Rd0000644000176200001440000002425414766101222020111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/translate.R \name{testthat_translate_file} \alias{testthat_translate_file} \alias{testthat_translate_name} \alias{testthat_translate_dir} \title{Convert a \code{testthat} Test File to a \code{unitizer}} \usage{ testthat_translate_file( file.name, target.dir = file.path(dirname(file.name), "..", "unitizer"), state = getOption("unitizer.state"), keep.testthat.call = TRUE, prompt = "always", interactive.mode = interactive(), use.sects = TRUE, unitize = TRUE, ... ) testthat_translate_dir( dir.name, target.dir = file.path(dir.name, "..", "unitizer"), filter = "^test.*\\\\.[rR]", state = getOption("unitizer.state"), keep.testthat.call = TRUE, force = FALSE, interactive.mode = interactive(), use.sects = TRUE, unitize = TRUE, ... ) testthat_translate_name( file.name, target.dir = file.path(dirname(file.name), "..", "unitizer"), name.new = NULL, name.pattern = "^(?:test\\\\W*)?(.*)(?:\\\\.[rR])$", name.replace = "\\\\1" ) } \arguments{ \item{file.name}{a path to the \code{testthat} test file to convert} \item{target.dir}{the directory to create the \code{unitizer} test file and test store in; for \code{testthat_translate_file} only: if NULL will return as a character vector what the contents of the translated file would have been instead of writing the file} \item{state}{what state control to use (see same argument for \code{\link{unitize}})} \item{keep.testthat.call}{whether to preserve the \code{testthat} call that was converted, as a comment} \item{prompt}{character(1L): \itemize{ \item "always" to always prompt before writing new files \item "overwrite" only prompt if existing file is about to be overwritten \item "never" never prompt }} \item{interactive.mode}{logical(1L) primarily for testing purposes, allows us to force prompting in non-interactive mode; note that \code{unitize} and \code{unitize_dir} are always called in non-interactive mode by these functions, this parameter only controls prompts generated directly by these functions.} \item{use.sects}{TRUE (default) or FALSE whether to translate \code{test_that} sections to \code{unitizer_sect} or simply to turn them into comment banners.} \item{unitize}{TRUE (default) or FALSE whether to run \code{unitize} after the files are translated.} \item{...}{params to pass on to \code{testthat_translate_name}} \item{dir.name}{a path to the \code{testthat} directory to convert} \item{filter}{regular expression to select what files in a director are translated} \item{force}{logical(1L) whether to allow writing to a \code{target.dir} that contains files (implies \code{prompt="never"} when \code{testthat_translate_dir} runs \code{testthat_translate_file})} \item{name.new}{character(1L) the base name for the \code{unitizer} files; do not include an extension as we will add it (".R" for the testfile, ".unitizer" for the data directory); set to NULL to generate the name from the \code{testthat} file name} \item{name.pattern}{character(1L) a regular expression intended to match the \code{testthat} test file name (see \code{name.replace}) if \code{name.pattern} matches, then the new file name will be constructed with this (used as \code{replace} parameter to \code{\link{sub}}); in addition we will add ".R" and ".unitizer" as the extensions for the new files so do not include extensions in your \code{name.replace} parameter} \item{name.replace}{character(1L) the replacement token, typically would include a \code{"\\1"} token that is filled in by the match group from \code{name.pattern}} } \value{ a file path or a character vector (see \code{target.dir}) } \description{ Converts a \bold{copy} of an existing \code{testthat} test file to a \code{unitizer} test file and test store, or a directory of such files to a corresponding \code{unitizer} directory. See examples. } \section{Disclaimers}{ If you already have an extensive test suite in \code{testthat} and you do not intend to modify your tests or code very much there is little benefit (and likely some drawbacks) to migrating your tests to \code{unitizer}. Please see the introduction vignette for a (biased) view of the pros and cons of \code{unitizer} relative to \code{testthat}. These translation functions are provided for your convenience. The \code{unitizer} author does not use them very much since he seldom needs to migrate \code{testthat} tests. As a result, they have not been tested as thoroughly as the rest of \code{unitizer}. Translation is designed to work for the most common \code{testthat} use cases, but may not for yours. Make sure you \code{\link{review}} the resulting \code{unitizer}s to make sure they contain what you expect before you start relying on them. This is particularly important if your \code{testthat} test files are not meant to be run stand-alone with just \code{test_file} (see "Differences That May Cause Problems"). Note you can also \code{unitize} your \code{testthat} files \bold{without} translating them (see notes). } \section{Workflow}{ \enumerate{ \item Start a fresh R session \item Run your \code{testthat} tests with \code{test_dir} to ensure they are still passing. If your tests are are runnable only via \code{test_check} because they directly access the namespace of your package, see "Differences That May Cause Problems" below \item Run \code{testthat_dir_translate} \item [optional] use \code{\link{review}} to review the resulting unitizer(s) } We recommend using \code{testthat_translate_dir} over \code{testthat_translate_file} because the former also copies and loads any helper files that may be defined. Since libraries used by multiple test files are commonly loaded in these helper files, it is likely that just translating a single file without also copying the helper files will not work properly. } \section{How the Conversion Works}{ For a subset of the \code{expect_*} functions we extract the \code{object} parameter and discard the rest of the expectation. For example \preformatted{expect_equal(my_fun(25), 1:10)} becomes \preformatted{my_fun(25)}. The idea is that on unitizing the expression the result will be output to screen and can be reviewed and accepted. Not all \code{expect_*} functions are substituted. For example, \code{expect_is} and \code{expect_that} are left unchanged because the tests for those functions do not or might not actually test the values of \code{object}. \code{expect_gt} and similar are also left unchanged as that would require more work than simply extracting the \code{object} parameter. It is perfectly fine to \code{unitize} an \code{expect_*} call unsubstituted. \code{unitizer} captures conditions, values, etc., so if an \code{expect_*} test starts failing, it will be detected. \code{unitizer} will then evaluate and store the results of such expressions. Since in theory we just checked our \code{testthat} tests were working, presumably the re-evaluated expressions will produce the same values. Please note that the translation process does not actually check this is true (see "Differences That May Cause Problems") so \code{review}ing the results is a good idea. \code{test_that} calls are converted to \code{\link{unitizer_sect}} calls, and the contents thereof are processed as described above. Calls to \code{context} are commented out since there currently is no \code{unitizer} equivalent. Other \code{testthat} calls are left unchanged and their return values used as part of the \code{unitizer} tests. Only top level calls are converted. For example, code like \code{for(i in 1:10) expect_equal(my_fun(i), seq(i))} or even \code{(expect_equal(my_fun(10), 1:10))} will not be converted since \code{expect_equal} is nested inside a \code{for} and \code{(} respectively. You will need to manually edit these calls (or just let them remain as is, which is not an issue). We identify calls to extract based purely on the function symbols (i.e. we do not check whether \code{expect_equal} actually resolves to \code{testthat::expect_equal} in the context of the test file). The \code{unitizer} files will be created in a sibling folder to the folder containing the \code{testthat} files. The names of the new files will be based on the old files. See params \code{target.dir}, \code{name.new}, \code{name.pattern}, and \code{name.replace} for more details. We encourage you to try the default settings first as those should work well in most cases. When using \code{testthat_translate_dir}, any files that match \code{"^helper.*[rR]$"} are copied over to a '/_pre' subdirectory in \code{"target.dir"}, and are pre-loaded by default before the tests are \code{unitize}d. } \section{\code{unitizer} Differences That May Cause Problems}{ If you run your tests during development with \code{test_dir} odds are the translation will work just fine. On the other hand, if you rely exclusively on \code{test_check} you may need to use \code{state=unitizerStateNoOpt(par.env="pkgName")} when you translate to make sure your tests have access to the internal namespace functions. See \code{\link{unitizerState}} for details on how to modify state tracking. If your tests were translated with the \code{state} parameter changed from its default value, you will have to use the same value for that parameter in future \code{unitize} or \code{unitize_dir} runs. } \section{Alternate Use Cases}{ If you wish to process \code{testthat} files for use with the standard R \dQuote{.Rout} / \dQuote{.Rout.save process} you can set the \code{unitize} and \code{use.sects} parameters to FALSE. } \examples{ \dontrun{ library(testthat) # required testthat_translate_file("tests/testthat/test-random.R") # Translate `dplyr` tests (assumes `dplyr` source is in './dplyr') # Normally we would use default `state` value but we cannot in this case # due to conflicting packages and setup testthat_translate_dir( "dplyr/tests/testthat", state=unitizerStateSafe(par.env="dplyr") ) # Make sure translation worked (checking one file here) # *NOTE*: folder we are looking at has changed review("dplyr/tests/unitizer/summarise.unitizer") # Now we can unitize any time we change our code unitize_dir( "dplyr/tests/unitizer", state=unitizerStateSafe(par.env="dplyr") ) } } \seealso{ \code{\link{unitize}}, \code{\link{unitizerState}} } unitizer/man/length-unitizerSection-method.Rd0000644000176200001440000000063014766101222021120 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/section.R \name{length,unitizerSection-method} \alias{length,unitizerSection-method} \title{Compute Length of a \code{unitizerSection-class}} \usage{ \S4method{length}{unitizerSection}(x) } \arguments{ \item{x}{a \code{unitizerSection} object} } \description{ Compute Length of a \code{unitizerSection-class} } \keyword{internal} unitizer/man/mock_item.Rd0000644000176200001440000000051714766101222015140 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditions.R \name{mock_item} \alias{mock_item} \title{Generates a Dummy Item For Use in Examples} \usage{ mock_item() } \value{ unitizerItem object } \description{ The only purpose of this function is to create a \code{unitizerItem} for use by examples. } unitizer/man/repair_environments.Rd0000644000176200001440000000156614766101222017267 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/repairenvs.R \name{repair_environments} \alias{repair_environments} \title{Repair Environment Chains} \usage{ repair_environments(x, interactive.mode = interactive()) } \arguments{ \item{x}{either a unitizer, or a store id (see \code{\link{unitize}})} \item{interactive.mode}{logical(1L) whether to run in interactive mode ( request user input when needed) or not (error if user input is required, e.g. if all tests do not pass).} } \value{ a \code{unitizer} object } \description{ In theory should never be needed, but use in case you get errors about corrupted environments. You should only use this if you get an error telling you to use it. } \details{ If you pass a store id this will re-save the repaired \code{unitizer} to the location specified by the store id. } \seealso{ \code{\link{unitize}} } unitizer/man/all_eq.Rd0000644000176200001440000000127514766360077014447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/item.sub.R \name{all_eq} \alias{all_eq} \title{Like all.equal but Returns Empty String If Not all.equal} \usage{ all_eq(target, current, ...) } \arguments{ \item{target}{R object} \item{current}{other R object to be compared to \code{target}} \item{...}{arguments to pass to \code{\link{all.equal}}} } \value{ TRUE if \code{all.equal} returns TRUE, "" otherwise all_eq(1, 1L) all_eq(1, 2) isTRUE(all_eq(1, 2)) } \description{ Used as the default value comparison function since when values mismatch we use \code{\link[diffobj]{diffObj}} which would make the text output from \code{\link{all.equal}} somewhat redundant. } unitizer/DESCRIPTION0000644000176200001440000000365614766411142013651 0ustar liggesusersPackage: unitizer Title: Interactive R Unit Tests Description: Simplifies regression tests by comparing objects produced by test code with earlier versions of those same objects. If objects are unchanged the tests pass, otherwise execution stops with error details. If in interactive mode, tests can be reviewed through the provided interactive environment. Version: 1.4.22 Authors@R: c( person( "Brodie", "Gaslam", email="brodie.gaslam@yahoo.com", role=c("aut", "cre")), person( "Michael", "https://github.com/MichaelChirico", email="michaelchirico4@gmail.com", role=c("ctb")), person(family="R Core Team", email="R-core@r-project.org", role="cph", comment="Traceback function sources." ) ) Depends: methods Imports: stats, utils, crayon (>= 1.3.2), diffobj (>= 0.1.5.9000) VignetteBuilder: knitr Suggests: knitr, rmarkdown License: GPL-2 | GPL-3 URL: https://github.com/brodieG/unitizer BugReports: https://github.com/brodieG/unitizer/issues Collate: 'asciiml.R' 'capture.R' 'is.R' 'global.R' 'change.R' 'class_unions.R' 'list.R' 'conditions.R' 'item.R' 'deparse.R' 'text.R' 'item.sub.R' 'section.R' 'test.R' 'unitizer.R' 'exec.R' 'prompt.R' 'browse.struct.R' 'browse.R' 'demo.R' 'diff.R' 'faux_prompt.R' 'get.R' 'heal.R' 'load.R' 'ls.R' 'misc.R' 'search.R' 'options.R' 'onload.R' 'parse.R' 'rename.R' 'repairenvs.R' 'result.R' 'shims.R' 'size.R' 'state.R' 'state.compare.R' 'traceback.R' 'translate.R' 'unitize.R' 'unitize.core.R' 'unitizer-package.R' 'unitizer.add.R' 'upgrade.R' RoxygenNote: 7.3.2 Encoding: UTF-8 NeedsCompilation: no Packaged: 2025-03-18 21:06:34 UTC; brodie Author: Brodie Gaslam [aut, cre], Michael https://github.com/MichaelChirico [ctb], R Core Team [cph] (Traceback function sources.) Maintainer: Brodie Gaslam Repository: CRAN Date/Publication: 2025-03-19 00:40:02 UTC