lobstr/0000755000176200001440000000000014254721642011566 5ustar liggesuserslobstr/NAMESPACE0000644000176200001440000000116114254621577013012 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[",lobstr_bytes) S3method(c,lobstr_bytes) S3method(format,lobstr_bytes) S3method(format,lobstr_inspector) S3method(print,lobstr_bytes) S3method(print,lobstr_inspector) S3method(print,lobstr_raw) S3method(tree_label,"NULL") S3method(tree_label,"function") S3method(tree_label,character) S3method(tree_label,default) S3method(tree_label,environment) export(ast) export(cst) export(mem_used) export(obj_addr) export(obj_addrs) export(obj_size) export(obj_sizes) export(ref) export(sxp) export(tree) export(tree_label) import(rlang) useDynLib(lobstr, .registration = TRUE) lobstr/LICENSE0000644000176200001440000000005414032635514012566 0ustar liggesusersYEAR: 2020 COPYRIGHT HOLDER: lobstr authors lobstr/README.md0000644000176200001440000000437414254675357013070 0ustar liggesusers # lobstr [![CRAN status](https://www.r-pkg.org/badges/version/lobstr)](https://cran.r-project.org/package=lobstr) [![R-CMD-check](https://github.com/r-lib/lobstr/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/lobstr/actions/workflows/R-CMD-check.yaml) [![Codecov test coverage](https://codecov.io/gh/r-lib/lobstr/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/lobstr?branch=main) lobstr provides tools in the same vein as `str()`, which allow you to dig into the detail of an object. ## Installation Install the released version of lobstr from CRAN: ``` r install.packages("lobstr") ``` You can install the development version with: ``` r # install.packages("devtools") devtools::install_github("r-lib/lobstr") ``` ## Example ### Abstract syntax trees `ast()` draws the abstract syntax tree of R expressions: ``` r ast(a + b + c) #> █─`+` #> ├─█─`+` #> │ ├─a #> │ └─b #> └─c ast(function(x = 1) { if (x > 0) print("Hi!") }) #> █─`function` #> ├─█─x = 1 #> ├─█─`{` #> │ └─█─`if` #> │ ├─█─`>` #> │ │ ├─x #> │ │ └─0 #> │ └─█─print #> │ └─"Hi!" #> └─ ``` ### References `ref()` shows hows objects can be shared across data structures by digging into the underlying \_\_ref\_\_erences: ``` r x <- 1:1e6 y <- list(x, x, x) ref(y) #> █ [1:0x7fed114eaea8] #> ├─[2:0x7fed21f373b8] #> ├─[2:0x7fed21f373b8] #> └─[2:0x7fed21f373b8] e <- rlang::env() e$self <- e ref(e) #> █ [1:0x7fecf1856f00] #> └─self = [1:0x7fecf1856f00] ``` A related tool is `obj_size()`, which computes the size of an object taking these shared references into account: ``` r obj_size(x) #> 680 B obj_size(y) #> 760 B ``` ### Call stack trees `cst()` shows how frames on the call stack are connected: ``` r f <- function(x) g(x) g <- function(x) h(x) h <- function(x) x f(cst()) #> ▆ #> 1. ├─global f(cst()) #> 2. │ └─global g(x) #> 3. │ └─global h(x) #> 4. └─lobstr::cst() ``` lobstr/man/0000755000176200001440000000000014254716056012344 5ustar liggesuserslobstr/man/obj_size.Rd0000644000176200001440000000513313477777720014454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{obj_size} \alias{obj_size} \alias{obj_sizes} \title{Calculate the size of an object.} \usage{ obj_size(..., env = parent.frame()) obj_sizes(..., env = parent.frame()) } \arguments{ \item{...}{Set of objects to compute size.} \item{env}{Environment in which to terminate search. This defaults to the current environment so that you don't include the size of objects that are already stored elsewhere. Regardless of the value here, \code{obj_size()} never looks past the global or base environments.} } \value{ An estimate of the size of the object, in bytes. } \description{ \code{obj_size()} computes the size of an object or set of objects; \code{obj_sizes()} breaks down the individual contribution of multiple objects to the total size. } \section{Compared to \code{object.size()}}{ Compared to \code{\link[=object.size]{object.size()}}, \code{obj_size()}: \itemize{ \item Accounts for all types of shared values, not just strings in the global string pool. \item Includes the size of environments (up to \code{env}) \item Accurately measures the size of ALTREP objects. } } \section{Environments}{ \code{obj_size()} attempts to take into account the size of the environments associated with an object. This is particularly important for closures and formulas, since otherwise you may not realise that you've accidentally captured a large object. However, it's easy to over count: you don't want to include the size of every object in every environment leading back to the \code{\link[=emptyenv]{emptyenv()}}. \code{obj_size()} takes a heuristic approach: it never counts the size of the global environment, the base environment, the empty environment, or any namespace. Additionally, the \code{env} argument allows you to specify another environment at which to stop. This defaults to the environment from which \code{obj_size()} is called to prevent double-counting of objects created elsewhere. } \examples{ # obj_size correctly accounts for shared references x <- runif(1e4) obj_size(x) z <- list(a = x, b = x, c = x) obj_size(z) # this means that object size is not transitive obj_size(x) obj_size(z) obj_size(x, z) # use obj_size() to see the unique contribution of each component obj_sizes(x, z) obj_sizes(z, x) obj_sizes(!!!z) # obj_size() also includes the size of environments f <- function() { x <- 1:1e4 a ~ b } obj_size(f()) #' # In R 3.5 and greater, `:` creates a special "ALTREP" object that only # stores the first and last elements. This will make some vectors much # smaller than you'd otherwise expect obj_size(1:1e6) } lobstr/man/sxp.Rd0000644000176200001440000000375713762501764013462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sxp.R \name{sxp} \alias{sxp} \title{Inspect an object} \usage{ sxp(x, expand = character(), max_depth = 5L) } \arguments{ \item{x}{Object to inspect} \item{expand}{Optionally, expand components of the true that are usually suppressed. Use: \itemize{ \item "character" to show underlying entries in the global string pool. \item "environment" to show the underlying hashtables. \item "altrep" to show the underlying data. \item "call" to show the full AST (but \code{\link[=ast]{ast()}} is usually superior) \item "bytecode" to show generated bytecode. }} \item{max_depth}{Maximum depth to recurse. Use \code{max_depth = Inf} (with care!) to recurse as deeply as possible. Skipped elements will be shown as \code{...}.`} } \description{ \code{sxp(x)} is similar to \code{.Internal(inspect(x))}, recursing into the C data structures underlying any R object. The main difference is the output is a little more compact, it recurses fully, and avoids getting stuck in infinite loops by using a depth-first search. It also returns a list that you can compute with, and carefully uses colour to highlight the most important details. } \details{ The name \code{sxp} comes from \code{SEXP}, the name of the C data structure that underlies all R objects. } \examples{ x <- list( TRUE, 1L, runif(100), "3" ) sxp(x) # Expand "character" to see underlying CHARSXP entries in the global # string pool x <- c("banana", "banana", "apple", "banana") sxp(x) sxp(x, expand = "character") # Expand altrep to see underlying data x <- 1:10 sxp(x) sxp(x, expand = "altrep") # Expand environmnets to see the underlying implementation details e1 <- new.env(hash = FALSE, parent = emptyenv(), size = 3L) e2 <- new.env(hash = TRUE, parent = emptyenv(), size = 3L) e1$x <- e2$x <- 1:10 sxp(e1) sxp(e1, expand = "environment") sxp(e2, expand = "environment") } \seealso{ Other object inspectors: \code{\link{ast}()}, \code{\link{ref}()} } \concept{object inspectors} lobstr/man/cst.Rd0000644000176200001440000000212713304255332013414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cst.R \name{cst} \alias{cst} \title{Call stack tree} \usage{ cst() } \description{ Shows the relationship between calls on the stack. This function combines the results of \code{\link[=sys.calls]{sys.calls()}} and \code{\link[=sys.parents]{sys.parents()}} yielding a display that shows how frames on the call stack are related. } \examples{ # If all evaluation is eager, you get a single tree f <- function() g() g <- function() h() h <- function() cst() f() # You get multiple trees with delayed evaluation try(f()) # Pay attention to the first element of each subtree: each # evaluates the outermost call f <- function(x) g(x) g <- function(x) h(x) h <- function(x) x try(f(cst())) # With a little ingenuity you can use it to see how NSE # functions work in base R with(mtcars, {cst(); invisible()}) invisible(subset(mtcars, {cst(); cyl == 0})) # You can also get unusual trees by evaluating in frames # higher up the call stack f <- function() g() g <- function() h() h <- function() eval(quote(cst()), parent.frame(2)) f() } lobstr/man/tree.Rd0000644000176200001440000000563414253140421013564 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tree.R \name{tree} \alias{tree} \title{Pretty tree-like object printing} \usage{ tree( x, ..., index_unnamed = FALSE, max_depth = 10L, max_length = 1000L, show_environments = TRUE, hide_scalar_types = TRUE, val_printer = crayon::blue, class_printer = crayon::silver, show_attributes = FALSE, remove_newlines = TRUE, tree_chars = box_chars() ) } \arguments{ \item{x}{A tree like object (list, etc.)} \item{...}{Ignored (used to force use of names)} \item{index_unnamed}{Should children of containers without names have indices used as stand-in?} \item{max_depth}{How far down the tree structure should be printed. E.g. \code{1} means only direct children of the root element will be shown. Useful for very deep lists.} \item{max_length}{How many elements should be printed? This is useful in case you try and print an object with 100,000 items in it.} \item{show_environments}{Should environments be treated like normal lists and recursed into?} \item{hide_scalar_types}{Should atomic scalars be printed with type and length like vectors? E.g. \code{x <- "a"} would be shown as \verb{x: "a"} instead of \code{x: "a"}.} \item{val_printer}{Function that values get passed to before being drawn to screen. Can be used to color or generally style output.} \item{class_printer}{Same as \code{val_printer} but for the the class types of non-atomic tree elements.} \item{show_attributes}{Should attributes be printed as a child of the list or avoided?} \item{remove_newlines}{Should character strings with newlines in them have the newlines removed? Not doing so will mess up the vertical flow of the tree but may be desired for some use-cases if newline structure is important to understanding object state.} \item{tree_chars}{List of box characters used to construct tree. Needs elements \verb{$h} for horizontal bar, \verb{$hd} for dotted horizontal bar, \verb{$v} for vertical bar, \verb{$vd} for dotted vertical bar, \verb{$l} for l-bend, and \verb{$j} for junction (or middle child).} } \value{ console output of structure } \description{ A cleaner and easier to read replacement for \code{str} for nested list-like objects } \examples{ x <- list( list(id = "a", val = 2), list( id = "b", val = 1, children = list( list(id = "b1", val = 2.5), list( id = "b2", val = 8, children = list( list(id = "b21", val = 4) ) ) ) ), list( id = "c", val = 8, children = list( list(id = "c1"), list(id = "c2", val = 1) ) ) ) # Basic usage tree(x) # Even cleaner output can be achieved by not printing indices tree(x, index_unnamed = FALSE) # Limit depth if object is potentially very large tree(x, max_depth = 2) # You can customize how the values and classes are printed if desired tree(x, val_printer = function(x) { paste0("_", x, "_") }) } lobstr/man/mem_used.Rd0000644000176200001440000000123713251236036014423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mem.R \name{mem_used} \alias{mem_used} \title{How much memory is currently used by R?} \usage{ mem_used() } \description{ \code{mem_used()} wraps around \code{gc()} and returns the exact number of bytes currently used by R. Note that changes will not match up exactly to \code{\link[=obj_size]{obj_size()}} as session specific state (e.g. \link{.Last.value}) adds minor variations. } \examples{ prev_m <- 0; m <- mem_used(); m - prev_m x <- 1:1e6 prev_m <- m; m <- mem_used(); m - prev_m obj_size(x) rm(x) prev_m <- m; m <- mem_used(); m - prev_m prev_m <- m; m <- mem_used(); m - prev_m } lobstr/man/figures/0000755000176200001440000000000013406770053014003 5ustar liggesuserslobstr/man/figures/logo.png0000644000176200001440000006747713406770053015476 0ustar liggesusersPNG  IHDRX?gAMA a cHRMz&u0`:pQ<bKGD pHYs!7!73XztIME Nn.IDATxw|y~:L `搜5f%˒`$ZٽpvϽ{w:QV%I0&p"s&A @:`?PC6Oe~Ѐ/5zb+'P`qUaW`/ P fA "ilSG/\>X Fӈ[ | VO1Q $:/bϋVD@⍈7&Wǰ%2M&"o$0]n~,PB/1R)p+`>2o^C+p)&ŎsU~i;H(80]>kJ'  WuK=!1 9p'`Ŗ XEL" 'R)uc8trHu ]^Kwߣ`ObǹK=$Cgۮ-8ք.έ;$I<w# ^Ls3˟zL)%P]WزM,4lɫtwarq?.e,yQ bq+~ضcf }pHKNyPXkm\:|"ر2P Z@5$zcwQSZŮ.E~@"Ϸ* qM/".׭YZ@BIUGSZhh&*kBB>wg vT"\"'ƿCAf(xp2ECJʚ2ofˋPT;p}]XֲaNlq P c29aVIϾv{v^ג;B"qn\͕͌ۏ/ȷ{ UD+i2_d~3 -`m?Ҡ""Kֱq.˭"*@*Ri*uj8t-(ĝ!e5ȅSWM:^. UBjqnYe 7m bb!A*3;e +[.@@%be~$_;s߽ĝ"(͗Zrc!@<s;U-.#ށ>2d~Ғ8\;4pJ+ŗVY;<83ʹ\k#M,׭.W/~(ːI)QUJKmC% q#wkt`rlq(xOPZ^āc{رXwwy O|3?qvK)4GGsLiI<~7M{x'iB#\µ 7 GV-l8H< d~O`ǹ+&;xʒ{jWdPO_ [\S< k)ĝ!DA(ĭ~e&oQiGhܻuVfPX[W۸tfEe=ڧ [~$򺱇.6zL hn[{{6d7*eA4&FCƞZnXlKx( q:VIvT@#dC6>kd+!tRq{4cqfסu%7$VY4Y/ ] >4U)K)y9D.&] ŕ}O9#TESVZAQfNJ"ضo :5elV(H%!q1ǀxS[Րm1.7@5g=WJ{y੽.Hb-3dIVDmOdpx<(bxlJ [\6 =Men\24M#RZ\\nhl߷g \UNGC$ ![`Wމmnl!3?`6vjYVWQ|^%x=Y sѰ*- Au]u[lb,dOY5. <bf"wWCvrLsRJJ*<B,Ӣ [\Z ,!0 wVJ8~4}8:kd+M%[ܐwjlPU?@iqɒdiQRs2K?v[Q7ն EIq=`eu!z.3m 'q8x..aTNٯ@F#pgoɂ,N'A]ي_eʪ7xL8񽷈I&SOVVxe^@uE1 S˖K01h!R$]_v4t:iǶ4ĞT+e%4GX1秤ˍC,ϴ 3?nx|s!t(REQ. UUX*;`żsWSv 8 Bs,ibQV[Ďˊ n=4-^[5; zUT|޶\6l1oH&wt'u;3Q%got: r_nEaw|eeabQۃG׳W&"N6 =XiS#\9;HKrxp8L(Ʋtm[\OŮ~.>?Ns=ڒ!%y`K!H뷹qPCsvr12@<g"4A4[75%j v{PU^,fxr7H&tu|Trxp.L$2 L)lqni2a/Mz<>TuC%CJp{"2%KbV.;=mgx"ϚWFgX!~ܮtt;Y¾- ǒǣ„ƢD&" qԹߙKZDQBTr%N++[s#JyE nx^4ug##;;: Vx LN)%I"$<ao"Q,k-4 EB#aL\Ym+Bw^?q48HtcOieQ /T2Ӿ^Y+--Isky/D^FyY%?G6wvy>H)) X#%884J+x{m{k'B @UTTƇtud ˴ R I$ 1.t]4f5`7hVIi-^22?Uq_ C; @@._jP6+X&C(vb@Q&@%N2;BOGC#)˙#eZD"Qtm{SfrP؍=dՔn_n.Cή![wPZUYu ˔8Nan(/d.!^BhJ)Hir,-Rn á(J.c=40ʹL O0LLT7'hp"%s7m O͚B9d~˻ӉkqF\su ҒUuO A }MԷuRZDwN&DU%~(.wjS폔qZN4x>tՑ,[2714 BQֲ]nlSL-fRߡβwE6qUUCaǾzH!}\8u s;&EזnQ#l]țKPecT2EoW?N_tJƬnuhیd*H)lASntkP0-s_-Ƕ@nw|ul/B`hٔ~eJ1OJIi:g ˲u6xh yaڛi:}B^AJ/ѻrV$#v(T]5155e4NQY gŧ>*Kpz ̨4Y#kTd:Z,s -iݿ^ݡ`CuζiDStt՘CՖR+4H$i GwAFI&R(Bh>i(`Kc{؎ZK)q]Upz/fDqx14d,mpհ]* Swah L~v$ҰM!D#1|P@<`w vsuFGFbXDUUtՁESuh iw.]iT*MDz$%4쪙$m)04ߓPi:mBBaN8KxsζnwԱi'Uue8"EvQVYo@yճ?Qfnw`YHa2yN^f,Sq(* .Hb! OL%0PQXIyE`Kn:h]s2f A ]wz5aY^좪lʍ"ot?AYU7d&?~xt.p$voAUfYbuRHAx"g}N ^*Ӵy6xsm!KbuQqG>BJIuC902~D5Oݙ/VÏٙaڮwxaBpj+7BUE-Y[ %!HSjFP]thNIEÏ!Xs8uT*EOG.ޤ3mbN7NZܼNķجPUŨ c D&b=ڈ/0w˿e1z***<NUUDU,Ӛ1C l{m| d?}Gb!q!w ~{wwKtyU)}nqК߼'0Y 5xʪf$vr  Eb>`o)%Ã4_Ivb8 ޝ!sp+{1@8A;tC_cC9JCQE~G4vZ.!LDy%Vmɳ~:FW+k8 Ӵ4rҲs<$˲n#E4޾QCꤛ0=]\U4C4pxn*JR6eÞ%6MDiVS'qm1|h}NE^%>E<>7NݡD^6-]A8kǴ,yWE٠ Tp wnw/b8jp70yu eu?EQ(nh&FC}qwܨz4]wzp:\SZQLIeEe~7swu-#'#Jsܸ| C3U-PVQnl|^\8u ';(P]W=qTfv=be=|irf FƆD546m^~d-nSW@S[_KqY-ZUYM$)&B 'iܻ=%is n\xEeg=_a>BqYm;&)%`0 ME,,K"XKk,a|$LJ#M:N3HJR'{) #Ã#?ݐCcn^l{?(* R&/!(-/Ld&WYnD (eqXӴ0Mt*(xh$F$% G⤒iLB P M~QQSO҆z3rx14,aR47\|Ɨ' |%)ϖMO,%1-{ !wzplt:E:mbMi˴,Q)䛊4eJVuC9ۃ7rciξy8tNC61{RRVȖǛp ܴY,$W,n écF,@%CZٵx,A$%N "4@d TaW5ٍkE[.hκ"jKGhb#nD>/)%t9Ŧ6恴d Zf4<8t7DW%Ъe7;mM3+so]Denl`tx:CyuofXYqY&8,y?k&;gEvJgLwVs=8ݶ<OpY[:p<?Wlv+`U( aXdK-,sBPU J8ypnӓV5q~[˲x m-8 'ct@n+w(x]bȼ`I*r>I\pU~wSveiz=v."T\˔4Md"Z @ɯ$  rUΒyXW#gգ:ۺ9%)pJR)7l`wn!|,dCh7/ݱ3*,z֗\k5]l`#EeY;?›/&rx6?]Ws8Kg 2ӆIn_뤿k`'au?#f#OJ6R}!#xmFqn ՙ=U4c;P̒paʧ_;oW*tkw fL$YZJwY`CX޷ oCQN`ldW&=}vF&Fvڊ#-3׹y62|> _Ѓ7s冽EB1(BH89~جch[h ^AL_*[/fh4>clm>:q99ûй8$K8y$PqpꨚiZDBQ2@_ tg(%_!l<{tE襄T2};W pг=UJjUPP>?8`0݅k:Su6jWNCrc8]zQ()QUѹ~63x_ֆ,xMR4-}l5De),D"uky8;vlȍۜgM5挻@p;sӮDϰLW[IĒx] 9Z(F).^ڵH&Ru? ^G!(. Jsue˲0&dD& xqn3-eI.YAgInlRrC&a~.p86mc BcaFƗt,btxYTUés+#7zȟKgq͋ LArOMb8WO"X-{+yA2O#Kdn@ȽwB 5sld<_ًX pCJ[[Y_:%]}N8 Nذg{ vk,^3$aFE ƴ Qҩ=|'"+8J'RJJ}<0vݧt:q3eqslWe|6Ks!i116A4gb$ /L, 4!I5B024F"M_* S(C x'B'^|o_FZ*2QuhJ a]^é/YA"$4dH).=UF !:U/ ît~'opva\x"h Gl"N[6D!TE]a!TUeǾ-vdfٵ7?LwG/݅@]l>BFljhȜ*%x}NiR.:%`|48J@K22f$}] tW  K@.،YiO65}7aolywΙkMotCcW7Gjn;_!KSUu7Ғ{lt$f7L;sf|huUU{| Nʊ ,tA"QTe-RJJ+J6Οh&_AiqL+Aʪv8Wrc\ob^):&OqSHRp\lib|8̹7/ai<%6#D&b1\fDkt7g(]Q`0XsV3"歏J)iܷ꼲PKo6hBnJbZ멨+Wfڢv? > A"F/q;^یM5HCJa8獃%`8 \M:e %ck+w s̭):\)%?wmMu}.tCuuO-"/. L3e/c!coi[d"E<$sy~2<8 eZ̙V55o)I.cΞf!#tƚ\|dl<|]  ;xnvl=a|E| (xLwj+kZn^jÒPQى4fK%AǸx ](Bc,fW&ԡ( n51>wfJͫEbxrWTMEʆJ)x",p/H-.ud2ŶZ<^7Bd' E)!R[Ҋb!L`I@Ǿc;WiF<ǡ9qhEve]CJ3.r;M`UUsdhh, 'Hpyxf Doݠz TU, r9QCK~H& tqM;6Tc8tT%DZ|IN9s Av )Aw9+x~M #,&Ix,]KY &O`ߚؙ $hj[.;\8]N id"I,'<\8}UpjnrNK QRF뺖g%o)sβt=c}o^mEUGG–S;>z; OD8q TMlK EXzg( $fd<egSZHi9Knc[]b:rnrh4C[#:/%XJ*\욙Y.@ØRrbKԳ@<qot@L yۉv*HJL"I0?FWk}Cģů>]whde6f[t|?%Ōts?E$civʹW&vhpMx W]AQyzy5~h2 3$Rf݇$~{L/0cߑ*xnA7u+ZwZzl"kzhP3Xs]gNAzvB`)CJ*yr/jVd]OeZqj'`o `H I签)I4Ui$wwUc^@y!lK:D[s-X!CΖהsN 7 !sbHuD1ǨQGqQޙ: ݝeYgDK(.p9rx4΅SWH&Ruf CH)q8 a)5ص&HiIEsr,`d`h(PVQBIe`J^t͑jƎ}[0CYb.ûY(8/`7U%UBÎ:m]ba { [d!vkáSs ɬyWRyS k2^P p@ӵLgbÞᣢ\ԂEhvpSEi5ٖ 8ڒYi*^䅯[3Ӱ_(8O*JUsRUl^h`HĒ2{\n'{̜xV>*a,Z.v$Ïٔ{AQy)%eU8<% L_5{ɤ̸D 9@Ie`yn߻<͹.<e-2\=Jʊ+vSPuq{9U(kY633=USmg'bJ= _;6(̴\c%)zP Uh @UTبW2:8HK,PUּGւY\h;;s_JDZ {GIwsN+4 4U#2\83WZsc7sde@Q잃`~M.+BaAw[?#amqmz&BBcƇC l!PZ6еBEfmjI,U4&BikhfTWkߢi4R@, ݪ89')GrS$AZ'˒XS2p{8"Lk٭`Op{];KRJB@3.G\W74K.zH΅!׮oRaC! = %QT?)b:T1Zur :Z{ʽL˲8p|5RY[j+S 1>&\Z/h$f˞=D E) yK dj9"H%$\vy!cCƣp{ܨ%-T: ˲(.=Gu{]G^_~KɡG}7g%{-/^R,,$O,BϚL SR71DJ '6I&e-ǒ R\r%l>\I, o}9ɛEQ| ~2懔q_?C]][ùwҒSERK^˲HēpuHl?xhY9rB,;"p3m:C_׫,Oe{Uh8Ƶs\Cd"F˞Cup+zq_=wzx ɶu@Ҋ"߳E$-˶諩UBs"\;ʩW.s|+#cCf"U'p8:Qk ƾ}O!one0nGuO|=hY'~wĢYɣ  /k=ei*5%<f*,[4R姻ΊgEB\.'N.!9 iq&ɧ4`Gy>@o jfdxHҘ}4cK} spc=+\@UT;?I"c@vcM{rp1LQU"|7p.wdi? EP閅(ң#)%NҊ"Jʂ=NI:i n;^do˲7,IEM ? z^/Mv[%*IҌW32P3m5L*tCsk3'``O_[NGYgmvS;ΩW/feI6)݇N|K/co=[k2Pآ9+A]}%;(~ܿ}I95N|4:풛2l*}aI GlS79F?#cBNǢ\ @7 ;ص+ڤZx"Փq9<i: qyp*CZc!>wEQt&CH)y}w-̇.XiBteilX VAӑeEtCUv/vp&<>{i6+?iaol/Eܸpv26Nh$;d/T*@Hf $]FiPYv]E܉X^ڲvDJhэxNjS\aﱧS,!thL2WdI(UU֕;n݇Kl];& =.IEm IJ+x['ysģ QJ a{+ʹ }M` =)xt֡s} 7 /$6j˨.Y|~X)%2l߽8FμVvxޣAN4X4Nؗ̇D wgZ!{ {`MYq|k=ϓ3ͩTn ,B. jJcS=NcߒR<Dgph8>}~\h`_(Clos8] winDNkNhwCW9+@YKGA)WӴ5r2 ]A~IyʢElFiE($x,AGkϼ^74>qHɍKm4_9{ydfO|=W/xa\o|-;(KZ])!H&npy8E'-%/M#(9WSAO  P) JRM-R?#'s񑐭/nmz;dOp O0o_qg w~ObM*Z*20;V\\nb#=TU:MrL.[zx3=!nԐqeXiI/zqyDN@W[_Bu}9&-cM<',%Ist 8ujVp&n\j'Ik~?&0B&nq_AnY!N]rRғ[2"+[R z$bCt~ hx%bn`(=4ca-Sin^n.)é324΍8sHGir/_$2i=-4 ˒הϽ_üʷOگ-l춏جՠ%>wb۔{< f|-bKc5;3EubG5:>%ٹcw!-ɵ3Jg>WZTlN}?ػs|}`/7Nk=ݔUv/)áN7* pJ;? LO 5Jp󕄖Bma4-j(I.6܄|6=9 2j?4 hgϭH-9`/vͲÿC?jV =hI.=E9/]=lo2k6G>c<ù$/}dFnczF4Ͻmk3Ƕ,*<'8݄8obNh |_RJ/ 2MCc$02BXm֭<􎃹bS߇Ŷݵϼ9 L|o_yc[:p|_9hn+3#oUE?+vˤeYsu,@0e}}A;=PT:;>{ݹyS|OL@:~e6#Ȳ"vo`l8$BU|J)WOƋfcCwQ Em7:ؽMGvH8Ɲ֞n #i.߸`])wM /ɗ.?.Tz/{kE˧orKt_g3iz`;nn XXH OI Esg |"o]˯g9u/&SRC3MqL J~7Sz^>ghYïpJ-$)@)1ŷo𝯝RNDo6 )9NZR*J8x|)ωS?T}[|fYnhx|)>8GiZw?Hl^Mq} ~X4py=Gv07ʵ{*5P p"8e.O(. xx<љ¶6޼_dwtFsrp<_zR| N}wqz`l84던f~k<ø}$u]||ܱ_xs<ܹ7&/⟾}fֲU*"4}XšGޟxjQ,k:o-z -;?7'?ʣ:BOo֕5Vo 6%,IM}~/ 0 qGB sx,A<ɛ RYW:;osge >_2R7˗O~}ph6Bu}9j}ڹ5.v\p%jӢ]=w4ΡwSX/EQq0Ϸrv "MR|so\ȵM {r? ;kl⌏iWrt\ (n\^'Y5:~㽟xR~ =:oQvQ'I;),o( >Kʙ1MsDR})?&)'PU]³$c"QR|_\|Gf\("qΜׯt8\BCфi=ܲ$gN\ˮiS&jҩ8]OĒcp{'%ܸІe֩Ȗ~OOg}*4I&Si1iC6Q^S2wĚeY䂿cY ^Us]|h7u+XR27ʩ/O1>ڰ$o(=̈́tYRMboY< @m B] e-l042gCz M;vucO<ET&L {8~|0.x3M ?}]$TԔ~ׂ*T2?y۰O~+y |gc~`V׿,@zvƟĆ$}CeAR<JF3Ұ&&-I͖*jucUՈz;s&>RP5 iY"qGܺk;å7H%ӹ2w.SL79/e$aǧ}Tח/xq[%Xcg!*jJg„}bW_z@B$N\C-s$V5dktL}4\9BG{/5[9YTD1 LOit o_unk_>xrJ\/$X&HT>S{X J*̭$}CH @Qg*Lz~"Fa οy} y-w_~?{>Dyz>qLē|˯?Ͽ0M 5sRZ 1NzZ(/Z)g4hFqݠb:n~d+='2#ahcC˲gwzxό./7'1u*}'s7x/3+l?ag͂1?6W?$H !NK7>ljeYv-yh+ey?dd<ŅכI&R9 MӨd\yb3L)qh.E|"޿Gr]lY ҘPR973uYϾ#|x4ۼ7l!<7ybnc-S;qV—_#?5>f,fX2B*iO<[Cs]~@0o~K㾅[1o^nw_33FRJ8T|Q#!2eD$N݉mΙ ~τ ڷ`)nTĴ@S7=[G0YE 2-YH)q >EޡQweQ]_HT(wyVhW38uZ(+,ɼq` dZ#KaIss*V/VT>&| 7,yVx2F*\ߺNN@wS/_o[A~ޒ6rDn3_VgfXx'-B+B)d X$}}*O63>s xP]o1e&&"SNu{@ &&T8*s/2B aЖϦe!@;oҩ&ۮ^~x%0N=G%RE(8t'ݹiLR"-k3{zn*ծ 8 - wŬ$~ع3R *) $i&'ca^?>8@4"&Id誁p/X@isS%Wd !p-lbQfpUlw׀%A)]2 ؘ0-x*qnx;=A;q'?v= _Nx-.l4X"JOǗ s`q➉7ͭ> u9DS[mI*̴?.;p/eXiD 2qh9ȵe\Zn#8uF{%n6uOa_E?nu!>.`=DlH/cǹ?"AX*qX1_u^) X?,S7=0'n+lNs뀟]q5U/ X#/^/?ڳyaFM#a_L=QQ-XA_.3dD+I,V՜M";>~ẹV; X1rMu8{ U!nkN"rv3K8tW&>.;2x*q &ya YOsv-yUBז.>D*ӷZ~;-vrK&nkn k%[+9./P-JXkZa]inu) V%[+=ld. W,N]OZ!/EAXt( -wVXwGZ!,/ǖsxcAJ<>'olDZ!/MRe22S챷vvHf7|*<GL< 06ee~d$#:X'nXj!/ 6'9}1|;vaId:%n24S}.n7wѸ/]$Hr&ߞB6xrq&_nN ` vaZ&)3%[] Rk`e,{."εETxn?l;nF1$keZҲj,y+[=^v7(QZUDyu ]~2=ùX2\q} {ͯa\G,6Fnl{[Wpg2ؾڭ5w{rǟO"k9qx=1,w\V.1J,6-D4p~܇.Y1m)3P?*(?[=:+x|."qku7.aYTh"b&ob8'Ν]W-,V q{Wxl/?{|U=*-3e~kMo'c[=-{ bKcɩe !PUt$PCQN})oth##8:[wpm.݌Rqn{c'aƹᾲ1MA\G}[W;( z^=Kgk/Gmbx`W}ѡՐ>op_Y&[=lee-SJfhx>gL7~pGuqzyr{g9%n\l#[]ako´xꏱmC7EӴ)w8]֝<[׹uD<"&BY< mSa8tv4m`K'o03"PW E,@0\m~`Ym~ ρY-krQ-f]]á0[wϳ6o_bGJXR.b`+`ͷm6,=`eb e+n(Z%A*kK iΎܸƭkQf?bv7oPKĴ6@E^BQGvk`th m7BQx׏=ʕ-CֵG()pR;dp(JLd~ I{)Ǖi e(#@,/|"/7{vOL)Z!JRRvYh]T#_b{! DPZ \UĴmb9W}ۢb}aNtg?0锉?xK >~PIYw@h%}Vzޱ>B$E~= 3.2) Imports: crayon, methods, prettyunits, rlang (>= 1.0.0) Suggests: covr, pillar, pkgdown, testthat (>= 3.0.0) LinkingTo: cpp11 (>= 0.4.2) Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 Encoding: UTF-8 RoxygenNote: 7.2.0 SystemRequirements: C++11 NeedsCompilation: yes Packaged: 2022-06-22 22:48:14 UTC; hadleywickham Author: Hadley Wickham [aut, cre], RStudio [cph] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2022-06-22 23:20:02 UTC lobstr/tests/0000755000176200001440000000000014254716056012733 5ustar liggesuserslobstr/tests/testthat/0000755000176200001440000000000014254721642014570 5ustar liggesuserslobstr/tests/testthat/test-sxp.R0000644000176200001440000000451014253140421016467 0ustar liggesuserstest_that("retrieves truelength", { skip_if_not(getRversion() >= "3.4") # true length is only updated after assignment x <- runif(100) x[101] <- 1 obj <- sxp(x) # weak test because R doesn't make any guarantees about what the object # will be expect_true(attr(obj, "truelength") > length(obj)) }) test_that("computes spanning tree", { x <- 1:10 y <- list(x, x, x) obj <- sxp(y) expect_false(attr(obj[[1]], "has_seen")) expect_true(attr(obj[[2]], "has_seen")) }) test_that("captures names of special environments", { x <- list( emptyenv(), baseenv(), globalenv() ) obj <- sxp(x) expect_equal(attr(obj[[1]], "value"), "empty") expect_equal(attr(obj[[2]], "value"), "base") expect_equal(attr(obj[[3]], "value"), "global") }) test_that("captures names of lists", { x <- list(a = 1, b = 2, c = 3) obj <- sxp(x) expect_named(obj, c(names(x), "_attrib")) }) test_that("can expand lists", { x <- c("xxx", "xxx", "y") obj <- sxp(x, expand = "character") expect_length(obj, 3) expect_equal(attr(obj[[1]], "ref"), attr(obj[[2]], "ref")) }) test_that("can inspect active bindings", { e <- new.env(hash = FALSE) env_bind_active(e, f = function() stop("!")) x <- sxp(e) expect_named(x, c("f", "_enclos")) }) # Regression tests -------------------------------------------------------- test_that("can inspect all atomic vectors", { x <- list( TRUE, 1L, 1, "3", 1i, raw(1) ) expect_snapshot(sxp(x)) }) test_that("can inspect functions", { f <- function(x, y = 1, ...) x + 1 attr(f, "srcref") <- NULL environment(f) <- globalenv() expect_snapshot(sxp(f)) }) test_that("can inspect environments", { e1 <- new.env(parent = emptyenv(), size = 5L) e1$x <- 10 e1$y <- e1 e2 <- new.env(parent = e1, size = 5L) expect_snapshot({ print(sxp(e2)) print(sxp(e2, expand = "environment", max_depth = 5L)) }) }) test_that("can expand altrep", { skip_if_not(getRversion() >= "3.5") skip_if_not(.Machine$sizeof.pointer == 8) # _class RAWSXP has different size expect_snapshot({ x <- 1:10 print(sxp(x, expand = "altrep", max_depth = 4L)) }) }) test_that("can inspect cons cells", { expect_snapshot({ cell <- new_node(1, 2) sxp(cell) non_nil_terminated_list <- new_node(1, new_node(2, 3)) sxp(non_nil_terminated_list) }) }) lobstr/tests/testthat/test-ast.R0000644000176200001440000000142114253140421016442 0ustar liggesuserstest_that("quosures print same as expressions", { expect_equal(ast_tree(quo(x)), ast_tree(expr(x))) }) test_that("can print complex expression", { skip_on_os("windows") x <- expr(function(x) if (x > 1) f(y$x, "x", g())) expect_snapshot({ ast(!!x) }) }) test_that("can print complex expression without unicode", { old <- options(lobstr.fancy.tree = FALSE) on.exit(options(old)) x <- expr(function(x) if (x > 1) f(y$x, "x", g())) expect_snapshot({ ast(!!x) }) }) test_that("can print scalar expressions nicely", { old <- options(lobstr.fancy.tree = FALSE) on.exit(options(old)) x <- expr(list( logical = c(FALSE, TRUE, NA), integer = 1L, double = 1, character = "a", complex = 1i )) expect_snapshot({ ast(!!x) }) }) lobstr/tests/testthat/test-address.R0000644000176200001440000000244014253140421017302 0ustar liggesuserstest_that("address of expression varies", { a <- obj_addr(1:10) b <- obj_addr(1:10) expect_false(identical(a, b)) }) test_that("address of variable is constant", { x <- 1:10 expect_equal(obj_addr(x), obj_addr(x)) }) test_that("address flows through function wrappers", { x <- 1:10 f <- function(x) obj_addr(x) g <- function(y) f(y) h <- function(z) g(z) address <- obj_addr(x) expect_equal(f(x), address) expect_equal(g(x), address) expect_equal(h(x), address) }) # addresses --------------------------------------------------------------- test_that("can find addresses of list elements", { x <- 1:3 y <- 1:3 addr <- c(obj_addr(x), obj_addr(y)) l <- list(x, y) expect_equal(obj_addrs(l), addr) }) test_that("can find addresses of environment elements", { x <- 1:3 y <- 1:3 addr <- c(obj_addr(x), obj_addr(y)) e1 <- new.env(hash = TRUE) e1$x <- x e1$y <- y expect_setequal(obj_addrs(e1), addr) e2 <- new.env(hash = FALSE) e2$x <- x e2$y <- y expect_setequal(obj_addrs(e2), addr) }) test_that("address of character vectors points to global string pool", { addr <- obj_addrs(c("a", "a", "a")) expect_equal(addr[[1]], addr[[2]]) }) test_that("addresses of other elements throws errors", { expect_error(obj_addrs(1:10), "must be a list") }) lobstr/tests/testthat/test-ref.R0000644000176200001440000000211014253143157016434 0ustar liggesuserstest_that("basic list display", { skip_on_os("windows") test_addr_reset() expect_snapshot({ x <- 1:10 y <- list(x, x) ref( x, list(), list(x, x, x), list(a = x, b = x), letters ) }) }) test_that("basic environment display", { skip_on_os("windows") test_addr_reset() expect_snapshot({ e <- env(a = 1:10) e$b <- e$a e$c <- e ref(e) }) }) test_that("environment shows objects beginning with .", { skip_on_os("windows") test_addr_reset() expect_snapshot({ e <- env(. = 1:10) ref(e) }) }) test_that("can display ref to global string pool on request", { skip_on_os("windows") test_addr_reset() expect_snapshot({ ref(c("string", "string", "new string"), character = TRUE) }) }) test_that("custom methods are never called (#30)", { # `[[.numeric_number` causes infinite recursion expect_error(ref(package_version("1.1.1")), NA) e <- env(a = 1:10) e$b <- e$a e$c <- e # `as.list.data.frame`(, ...) fails class(e) <- "data.frame" expect_error(ref(e), NA) }) lobstr/tests/testthat/test-tree.R0000644000176200001440000001153614253140421016622 0ustar liggesusers test_that("Array-like indices can be shown or hidden", { testthat::skip_on_os("windows") expect_snapshot({ tree(list(a = "a", "b", "c"), index_unnamed = TRUE) }) expect_snapshot({ tree(list(a = "a", "b", "c"), index_unnamed = FALSE) }) }) test_that("Atomic arrays have sensible defaults w/ truncation for longer than 10-elements",{ testthat::skip_on_os("windows") expect_snapshot( tree( list( name = "vectored list", num_vec = 1:10, char_vec = letters ) ) ) expect_snapshot( tree( list( name = "vectored list", num_vec = 1:10, char_vec = letters ), hide_scalar_types = FALSE ) ) }) test_that("Large and multiline strings are handled gracefully", { testthat::skip_on_os("windows") expect_snapshot({ long_strings <- list( "normal string" = "first element", "really long string" = paste(rep(letters, 4), collapse = ""), "vec of long strings" = c( "a long\nand multi\nline string element", "a fine length", "another long\nand also multi\nline string element" ) ) # No truncation of first string # Really long single string is truncated and elipsesed # Short string inside vector with long strings is not truncated tree(long_strings) # Newline removal can be disabled tree(long_strings, remove_newlines = FALSE) }) }) test_that("Max depth and length can be enforced", { # This test also disables the unicode printing so it can be run on windows # platforms old_opts <- options("lobstr.fancy.tree" = FALSE) on.exit(options(old_opts)) expect_snapshot({ deep_list <- list( list( id = "b", val = 1, children = list( list(id = "b1",val = 2.5), list( id = "b2", val = 8, children = list( list(id = "b21", val = 4) ) ) ) ), list(id = "a", val = 2) ) tree(deep_list, max_depth = 1) tree(deep_list, max_depth = 2) tree(deep_list, max_depth = 3) tree(deep_list, max_length = 0) tree(deep_list, max_length = 2) tree(deep_list, max_depth = 1, max_length = 4) }) }) test_that("Missing values are caught and printed properly", { testthat::skip_on_os("windows") expect_snapshot( tree( list( "null-element" = NULL, "NA-element" = NA ) ) ) }) test_that("non-named elements in named list", { testthat::skip_on_os("windows") expect_snapshot( tree(list("a" = 1, "el w/o id")) ) }) test_that("Attributes are properly displayed as special children nodes", { testthat::skip_on_os("windows") expect_snapshot({ list_w_attrs <- structure( list( structure( list(id = "a", val = 2), level = 2, name = "first child" ), structure( list( id = "b", val = 1, children = list( list(id = "b1", val = 2.5) ) ), level = 2, name = "second child", class = "custom-class" ), level = "1", name = "root" ) ) # Shows attributes tree(list_w_attrs, show_attributes = TRUE) # Hides attributes (default) tree(list_w_attrs, show_attributes = FALSE) }) }) test_that("Can optionally recurse into environments", { testthat::skip_on_os("windows") # Wrapped in a local to avoid different environment setup for code running in # test_that instead of interactively # Can't use snapshots here because environment address change on each run env_printing <- capture.output( local( { ea <- rlang::env(d = 4, e = 5) tree(rlang::env(ea, a = 1, b = 2, c = 3)) }, envir = rlang::global_env() ) ) # Seven total nodes should be printed expect_equal( length(env_printing), 4 ) # Printed only the names we expected expect_equal( mean( grepl( pattern = "(environment|a|b|c):", env_printing ) ), 1 ) # Should only print two environment nodes (aka didn't escape past global env) expect_equal( sum(grepl(pattern = "` │ │ ├─x │ │ └─1 │ └─█─f │ ├─█─`$` │ │ ├─y │ │ └─x │ ├─"x" │ └─█─g └─ # can print complex expression without unicode Code ast(!!x) Output o-`function` +-o-x = `` +-o-`if` | +-o-`>` | | +-x | | \-1 | \-o-f | +-o-`$` | | +-y | | \-x | +-"x" | \-o-g \- # can print scalar expressions nicely Code ast(!!x) Output o-list +-logical = o-c | +-FALSE | +-TRUE | \-NA +-integer = 1L +-double = 1 +-character = "a" \-complex = 1i lobstr/tests/testthat/_snaps/ref.md0000644000176200001440000000213014254707572017153 0ustar liggesusers# basic list display Code x <- 1:10 y <- list(x, x) ref(x, list(), list(x, x, x), list(a = x, b = x), letters) Output [1:0x001] █ [2:0x002] █ [3:0x003] ├─[1:0x001] ├─[1:0x001] └─[1:0x001] █ [4:0x004] ├─a = [1:0x001] └─b = [1:0x001] [5:0x005] # basic environment display Code e <- env(a = 1:10) e$b <- e$a e$c <- e ref(e) Output █ [1:0x001] ├─a = [2:0x002] ├─b = [2:0x002] └─c = [1:0x001] # environment shows objects beginning with . Code e <- env(. = 1:10) ref(e) Output █ [1:0x001] └─. = [2:0x002] # can display ref to global string pool on request Code ref(c("string", "string", "new string"), character = TRUE) Output █ [1:0x001] ├─[2:0x002] ├─[2:0x002] └─[3:0x003] lobstr/tests/testthat/_snaps/sxp.md0000644000176200001440000000407614254707573017225 0ustar liggesusers# can inspect all atomic vectors Code sxp(x) Output [1] () [2] () [3] () [4] () [5] () [6] () [7] () # can inspect functions Code sxp(f) Output [1] () _formals [2] () x [3] () y [4] () ... [3] _body [5] () ... _env [6] () # can inspect environments Code print(sxp(e2)) Output [1] () _enclos [2] () x [3] () y [2] _enclos [4] () Code print(sxp(e2, expand = "environment", max_depth = 5L)) Output [1] () _frame _hashtab [3] () _enclos [4] () _frame _hashtab [5] () [6] () x [7] () [8] () y [4] _enclos [9] () # can expand altrep Code x <- 1:10 print(sxp(x, expand = "altrep", max_depth = 4L)) Output [1] (altrep ) _class [2] () _attrib [3] () [4] () [5] () [6] () _data1 [7] () _data2 # can inspect cons cells Code cell <- new_node(1, 2) sxp(cell) Output [1] () [2] () _cdr [3] () Code non_nil_terminated_list <- new_node(1, new_node(2, 3)) sxp(non_nil_terminated_list) Output [1] () [2] () [3] () _cdr [4] () lobstr/tests/testthat/_snaps/tree.md0000644000176200001440000001314114254707573017343 0ustar liggesusers# Array-like indices can be shown or hidden Code tree(list(a = "a", "b", "c"), index_unnamed = TRUE) Output ├─a: "a" ├─2: "b" └─3: "c" --- Code tree(list(a = "a", "b", "c"), index_unnamed = FALSE) Output ├─a: "a" ├─"b" └─"c" # Atomic arrays have sensible defaults w/ truncation for longer than 10-elements Code tree(list(name = "vectored list", num_vec = 1:10, char_vec = letters)) Output ├─name: "vectored list" ├─num_vec: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 └─char_vec: "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", ... --- Code tree(list(name = "vectored list", num_vec = 1:10, char_vec = letters), hide_scalar_types = FALSE) Output ├─name: "vectored list" ├─num_vec: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 └─char_vec: "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", ... # Large and multiline strings are handled gracefully Code long_strings <- list(`normal string` = "first element", `really long string` = paste( rep(letters, 4), collapse = ""), `vec of long strings` = c( "a long\nand multi\nline string element", "a fine length", "another long\nand also multi\nline string element")) tree(long_strings) Output ├─normal string: "first element" ├─really long string: "abcdefghijklmnopqrstuvwxyzabcdef..." └─vec of long strings: "a long↵and m...", "a fine length", "another long..." Code tree(long_strings, remove_newlines = FALSE) Output ├─normal string: "first element" ├─really long string: "abcdefghijklmnopqrstuvwxyzabcdef..." └─vec of long strings: "a long and m...", "a fine length", "another long..." # Max depth and length can be enforced Code deep_list <- list(list(id = "b", val = 1, children = list(list(id = "b1", val = 2.5), list(id = "b2", val = 8, children = list(list(id = "b21", val = 4))))), list( id = "a", val = 2)) tree(deep_list, max_depth = 1) Output +-... \-... Code tree(deep_list, max_depth = 2) Output +- | +-id: "b" | +-val: 1 | \-children: ... \- +-id: "a" \-val: 2 Code tree(deep_list, max_depth = 3) Output +- | +-id: "b" | +-val: 1 | \-children: | +-... | \-... \- +-id: "a" \-val: 2 Code tree(deep_list, max_length = 0) Output ... Code tree(deep_list, max_length = 2) Output +- ... Code tree(deep_list, max_depth = 1, max_length = 4) Output +-... \-... # Missing values are caught and printed properly Code tree(list(`null-element` = NULL, `NA-element` = NA)) Output ├─null-element: └─NA-element: NA # non-named elements in named list Code tree(list(a = 1, "el w/o id")) Output ├─a: 1 └─"el w/o id" # Attributes are properly displayed as special children nodes Code list_w_attrs <- structure(list(structure(list(id = "a", val = 2), level = 2, name = "first child"), structure(list(id = "b", val = 1, children = list(list( id = "b1", val = 2.5))), level = 2, name = "second child", class = "custom-class"), level = "1", name = "root")) tree(list_w_attrs, show_attributes = TRUE) Output ├─ │ ├─id: "a" │ ├─val: 2 │ ├┄attr(,"names"): "id", "val" │ ├┄attr(,"level"): 2 │ └┄attr(,"name"): "first child" ├─S3 │ ├─id: "b" │ ├─val: 1 │ ├─children: │ ┊ └─ │ ┊ ├─id: "b1" │ ┊ ├─val: 2.5 │ ┊ └┄attr(,"names"): "id", "val" │ ├┄attr(,"names"): "id", "val", "children" │ ├┄attr(,"level"): 2 │ ├┄attr(,"name"): "second child" │ └┄attr(,"class"): "custom-class" ├─level: "1" ├─name: "root" └┄attr(,"names"): "", "", "level", "name" Code tree(list_w_attrs, show_attributes = FALSE) Output ├─ │ ├─id: "a" │ └─val: 2 ├─S3 │ ├─id: "b" │ ├─val: 1 │ └─children: │ └─ │ ├─id: "b1" │ └─val: 2.5 ├─level: "1" └─name: "root" # Function arguments get printed Code tree(list(no_args = function() { }, few_args = function(a, b, c) { }, lots_of_args = function(d, e, f, g, h, i, j, k, l, m, n, o, p) { })) Output ├─no_args: function() ├─few_args: function(a, b, c) └─lots_of_args: function(d, e, f, g, h, ...) # Handles expressions Code tree(list(a = quote(a), b = quote(a + 1), c = y ~ mx + b)) Output ├─a: a ├─b: a + 1 └─c: S3 y ~ mx + b # Hidden lists dont cause infinite recursion Code tree(packageVersion("lobstr")) Output S3 └─1, 1, 1, 9000 lobstr/tests/testthat/test-size.R0000644000176200001440000001116114254621577016650 0ustar liggesusersexpect_same <- function(x, ...) { lab <- as.character(expr_text(enexpr(x))) act <- as.vector(obj_size(x)) exp <- as.vector(object.size(x)) msg <- sprintf("`obj_size(%s)` is %s, not %s (\u0394%+i)", lab, act, exp, act - exp) expect(identical(act, exp), msg) invisible(act) } # S3 methods -------------------------------------------------------------- test_that("combined bytes are aligned", { expect_snapshot({ new_bytes(c(400, 400000)) }) }) # Compatibility with base --------------------------------------------------- test_that("size correct for length one vectors", { expect_same(1) expect_same(1L) expect_same("abc") expect_same(paste(rep("banana", 100), collapse = "")) expect_same(charToRaw("a")) expect_same(5 + 1i) }) test_that("size scales correctly with length (accounting for vector pool)", { expect_same(numeric()) expect_same(1) expect_same(2) expect_same(c(1:10)) expect_same(c(1:1000)) }) test_that("size of list computed recursively", { expect_same(list()) expect_same(as.list(1)) expect_same(as.list(1:2)) expect_same(as.list(1:3)) expect_same(list(list(list(list(list()))))) }) test_that("size of symbols same as base", { expect_same(quote(x)) expect_same(quote(asfsadfasdfasdfds)) }) test_that("size of pairlists same as base", { expect_same(pairlist()) expect_same(pairlist(1)) expect_same(pairlist(1, 2)) expect_same(pairlist(1, 2, 3)) expect_same(pairlist(1, 2, 3, 4)) }) test_that("don't crash with large pairlists", { n <- 1e5 x <- pairlist(1) xn <- as.pairlist(rep(1, n)) expect_equal(obj_size(xn), n * obj_size(x)) }) test_that("size of S4 objects same as base", { Z <- methods::setClass("Z", slots = c(x = "integer")) z <- Z(x = 1L) expect_same(z) }) test_that("size of attributes included in object size", { expect_same(c(x = 1)) expect_same(list(x = 1)) expect_same(c(x = "y")) }) test_that("duplicated CHARSXPS only counted once", { expect_same("x") expect_same(c("x", "y", "x")) expect_same(c("banana", "banana", "banana")) }) test_that("obj_sizes computes relative size", { x <- 1:10 + 1 out <- obj_sizes(x, x) expect_equal(out[1], obj_size(x)) expect_equal(out[2], new_bytes(0)) }) # Improved behaviour for shared components ------------------------------------ test_that("shared components only counted once", { x <- 1:1e3 z <- list(x, x, x) expect_equal(obj_size(z), obj_size(x) + obj_size(vector("list", 3))) }) test_that("size of closures same as base", { f <- function() NULL attributes(f) <- NULL # zap srcrefs environment(f) <- emptyenv() expect_same(f) }) # Improved behaviour for ALTREP objects ----------------------------------- test_that("altrep size measured correctly", { skip_if_not(getRversion() > "3.5.0") # Currently reported size is 640 B # If regular vector would be 4,000,040 B # This test is conservative so shouldn't fail in case representation # changes in the future expect_true(obj_size(1:1e6) < 10000) }) test_that("can compute size of deferred string vectors", { x <- 1:10 names(x) <- 10:1 y <- names(x) obj_size(y) # Just assert that it doesn't crash succeed("Didn't crash") }) # Environment sizes ----------------------------------------------------------- test_that("terminal environments have size zero", { expect_equal(obj_size(globalenv()), new_bytes(0)) expect_equal(obj_size(baseenv()), new_bytes(0)) expect_equal(obj_size(emptyenv()), new_bytes(0)) expect_equal(obj_size(asNamespace("stats")), new_bytes(0)) }) test_that("environment size computed recursively", { e <- new.env(parent = emptyenv()) e_size <- obj_size(e) f <- new.env(parent = e) obj_size(f) expect_equal(obj_size(f), 2 * obj_size(e)) }) test_that("size of function includes environment", { f <- function() { y <- 1:1e3 a ~ b } g <- function() { y <- 1:1e3 function() 10 } expect_true(obj_size(f()) > obj_size(1:1e3)) expect_true(obj_size(g()) > obj_size(1:1e3)) }) test_that("size doesn't include parents of current environment", { x <- c(1:1e4) embedded <- (function() { g <- function() { x <- c(1:1e3) a ~ b } obj_size(g()) })() expect_true(embedded < obj_size(x)) }) test_that("support dots in closure environments", { fn <- (function(...) function() NULL)(foo) expect_error(obj_size(fn), NA) }) test_that("supports cons cells", { cell <- new_node(1, 2) expect_equal( obj_size(cell), obj_size(new_node(NULL, NULL)) + obj_size(1) + obj_size(2) ) non_nil_terminated_list <- new_node(1, new_node(2, 3)) expect_equal( obj_size(non_nil_terminated_list), obj_size(new_node(1, NULL)) + obj_size(cell) ) }) lobstr/tests/testthat.R0000644000176200001440000000007013162455060014703 0ustar liggesuserslibrary(testthat) library(lobstr) test_check("lobstr") lobstr/src/0000755000176200001440000000000014254716056012360 5ustar liggesuserslobstr/src/inspect.cpp0000644000176200001440000002332714254707527014543 0ustar liggesusers#include #include #include #include #include #include "utils.h" struct Expand { bool alrep; bool charsxp; bool env; bool call; bool bytecode; }; class GrowableList { cpp11::writable::list data_; cpp11::writable::strings names_; R_xlen_t n_; public: GrowableList(R_xlen_t size = 10) : data_(size), names_(size), n_(0) { } void push_back(const char* string, SEXP x) { int n_protected = 0; if (Rf_xlength(data_) == n_) { data_ = PROTECT(Rf_xlengthgets(data_, n_ * 2)); n_protected++; names_ = PROTECT(Rf_xlengthgets(names_, n_ * 2)); n_protected++; } SEXP string_ = PROTECT(Rf_mkChar(string)); n_protected++; SET_STRING_ELT(names_, n_, string_); SET_VECTOR_ELT(data_, n_, x); n_++; UNPROTECT(n_protected); } cpp11::list vector() { if (Rf_xlength(data_) != n_) { data_ = Rf_xlengthgets(data_, n_); names_ = Rf_xlengthgets(names_, n_); } Rf_setAttrib(data_, R_NamesSymbol, names_); return data_; } }; SEXP obj_children_(SEXP x, std::map& seen, double max_depth, Expand expand); bool is_namespace(cpp11::environment env); bool is_altrep(SEXP x) { #if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0) return ALTREP(x); #else return false; #endif } SEXP obj_inspect_(SEXP x, std::map& seen, double max_depth, Expand& expand) { int id; SEXP children; bool has_seen; if (seen.count(x)) { has_seen = true; id = seen[x]; children = PROTECT(Rf_allocVector(VECSXP, 0)); } else { has_seen = false; id = seen.size() + 1; seen[x] = id; children = PROTECT(obj_children_(x, seen, max_depth, expand)); } // don't store object directly to avoid increasing refcount Rf_setAttrib(children, Rf_install("addr"), PROTECT(Rf_mkString(obj_addr_(x).c_str()))); Rf_setAttrib(children, Rf_install("has_seen"), PROTECT(Rf_ScalarLogical(has_seen))); Rf_setAttrib(children, Rf_install("id"), PROTECT(Rf_ScalarInteger(id))); Rf_setAttrib(children, Rf_install("type"), PROTECT(Rf_ScalarInteger(TYPEOF(x)))); Rf_setAttrib(children, Rf_install("length"), PROTECT(Rf_ScalarReal(sxp_length(x)))); Rf_setAttrib(children, Rf_install("altrep"), PROTECT(Rf_ScalarLogical(is_altrep(x)))); Rf_setAttrib(children, Rf_install("named"), PROTECT(Rf_ScalarInteger(NAMED(x)))); Rf_setAttrib(children, Rf_install("object"), PROTECT(Rf_ScalarInteger(OBJECT(x)))); UNPROTECT(8); if (Rf_isVector(x)) { if (TRUELENGTH(x) > 0) { Rf_setAttrib(children, Rf_install("truelength"), PROTECT(Rf_ScalarReal(TRUELENGTH(x)))); UNPROTECT(1); } } const char* value = NULL; if (TYPEOF(x) == SYMSXP && PRINTNAME(x) != R_NilValue) { value = CHAR(PRINTNAME(x)); } else if (TYPEOF(x) == ENVSXP) { if (x == R_GlobalEnv) { value = "global"; } else if (x == R_EmptyEnv) { value = "empty"; } else if (x == R_BaseEnv) { value = "base"; } else { if (R_PackageEnvName(x) != R_NilValue) value = CHAR(STRING_ELT(R_PackageEnvName(x), 0)); } } if (value != NULL) { Rf_setAttrib(children, Rf_install("value"), PROTECT(Rf_mkString(value))); UNPROTECT(1); } Rf_setAttrib(children, Rf_install("class"), PROTECT(Rf_mkString("lobstr_inspector"))); UNPROTECT(1); UNPROTECT(1); return children; } inline void recurse( GrowableList* children, std::map& seen, const char* name, SEXP child, double max_depth, Expand& expand) { SEXP descendents = PROTECT(obj_inspect_(child, seen, max_depth - 1, expand)); children->push_back(name, descendents); UNPROTECT(1); } SEXP obj_children_( SEXP x, std::map& seen, double max_depth, Expand expand) { GrowableList children; bool skip = false; // Handle ALTREP objects if (expand.alrep && is_altrep(x)) { #if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0) SEXP klass = ALTREP_CLASS(x); recurse(&children, seen, "_class", klass, max_depth, expand); recurse(&children, seen, "_data1", R_altrep_data1(x), max_depth, expand); recurse(&children, seen, "_data2", R_altrep_data2(x), max_depth, expand); #endif } else if (max_depth <= 0) { switch (TYPEOF(x)) { // Non-recursive types case NILSXP: case SPECIALSXP: case BUILTINSXP: case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case RAWSXP: case CHARSXP: case SYMSXP: skip = false; break; default: skip = true; }; } else { switch (TYPEOF(x)) { // Non-recursive types case NILSXP: case SPECIALSXP: case BUILTINSXP: case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case RAWSXP: case CHARSXP: case SYMSXP: break; // Strings case STRSXP: if (expand.charsxp) { for (R_xlen_t i = 0; i < XLENGTH(x); i++) { recurse(&children, seen, "", STRING_ELT(x, i), max_depth, expand); } } break; // Recursive vectors case VECSXP: case EXPRSXP: case WEAKREFSXP: { SEXP names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); if (TYPEOF(names) == STRSXP) { for (R_xlen_t i = 0; i < XLENGTH(x); ++i) { recurse(&children, seen, CHAR(STRING_ELT(names, i)), VECTOR_ELT(x, i), max_depth, expand); } } else { for (R_xlen_t i = 0; i < XLENGTH(x); ++i) { recurse(&children, seen, "", VECTOR_ELT(x, i), max_depth, expand); } } UNPROTECT(1); break; } // Linked lists case LANGSXP: if (!expand.call) { skip = true; break; } case DOTSXP: case LISTSXP: { if (x == R_MissingArg) { // Needed for DOTSXP break; } SEXP cons = x; for (; is_linked_list(cons); cons = CDR(cons)) { SEXP tag = TAG(cons); if (TYPEOF(tag) == NILSXP) { recurse(&children, seen, "", CAR(cons), max_depth, expand); } else if (TYPEOF(tag) == SYMSXP) { recurse(&children, seen, CHAR(PRINTNAME(tag)), CAR(cons), max_depth, expand); } else { // TODO: add index? needs to be a list? recurse(&children, seen, "_tag", tag, max_depth, expand); recurse(&children, seen, "_car", CAR(cons), max_depth, expand); } } if (cons != R_NilValue) { recurse(&children, seen, "_cdr", cons, max_depth, expand); } break; } case BCODESXP: if (!expand.bytecode) { skip = true; break; } recurse(&children, seen, "_tag", TAG(x), max_depth, expand); recurse(&children, seen, "_car", CAR(x), max_depth, expand); recurse(&children, seen, "_cdr", CDR(x), max_depth, expand); break; // Environments case ENVSXP: if (x == R_BaseEnv || x == R_GlobalEnv || x == R_EmptyEnv || is_namespace(x)) break; if (expand.env) { recurse(&children, seen, "_frame", FRAME(x), max_depth, expand); recurse(&children, seen, "_hashtab", HASHTAB(x), max_depth, expand); } else { SEXP names = PROTECT(R_lsInternal(x, TRUE)); for (R_xlen_t i = 0; i < XLENGTH(names); ++i) { const char* name = CHAR(STRING_ELT(names, i)); SEXP sym = PROTECT(Rf_install(name)); if (R_BindingIsActive(sym, x)) { SEXP sym = PROTECT(Rf_install("_active_binding")); SEXP active = PROTECT(obj_inspect_(sym, seen, max_depth, expand)); children.push_back(name, active); UNPROTECT(2); } else { SEXP obj = PROTECT(Rf_findVarInFrame(x, sym)); recurse(&children, seen, name, obj, max_depth, expand); UNPROTECT(1); } UNPROTECT(1); } UNPROTECT(1); } recurse(&children, seen, "_enclos", ENCLOS(x), max_depth, expand); break; // Functions case CLOSXP: recurse(&children, seen, "_formals", FORMALS(x), max_depth, expand); recurse(&children, seen, "_body", BODY(x), max_depth, expand); recurse(&children, seen, "_env", CLOENV(x), max_depth, expand); break; case PROMSXP: recurse(&children, seen, "_value", PRVALUE(x), max_depth, expand); recurse(&children, seen, "_code", PRCODE(x), max_depth, expand); recurse(&children, seen, "_env", PRENV(x), max_depth, expand); break; case EXTPTRSXP: recurse(&children, seen, "_prot", EXTPTR_PROT(x), max_depth, expand); recurse(&children, seen, "_tag", EXTPTR_TAG(x), max_depth, expand); break; case S4SXP: recurse(&children, seen, "_tag", TAG(x), max_depth, expand); break; default: cpp11::stop("Don't know how to handle type %s", Rf_type2char(TYPEOF(x))); } } // CHARSXPs have fake attriibutes if (max_depth > 0 && TYPEOF(x) != CHARSXP && !Rf_isNull(ATTRIB(x))) { recurse(&children, seen, "_attrib", ATTRIB(x), max_depth, expand); } SEXP out = PROTECT(children.vector()); if (skip) { Rf_setAttrib(out, Rf_install("skip"), PROTECT(Rf_ScalarLogical(skip))); UNPROTECT(1); } UNPROTECT(1); return out; } [[cpp11::register]] cpp11::list obj_inspect_(SEXP x, double max_depth, bool expand_char = false, bool expand_altrep = false, bool expand_env = false, bool expand_call = false, bool expand_bytecode = false) { std::map seen; Expand expand = {expand_altrep, expand_char, expand_env, expand_call}; return obj_inspect_(x, seen, max_depth, expand); } lobstr/src/utils.h0000644000176200001440000000111114253140421013645 0ustar liggesusers#include #include inline std::string obj_addr_(SEXP x) { std::stringstream ss; ss << static_cast(x); return ss.str(); } static inline bool is_linked_list(SEXP x) { switch (TYPEOF(x)) { case DOTSXP: case LISTSXP: case LANGSXP: return true; default: return false; } } // Rf_length() crashes on flexible cells static inline R_xlen_t sxp_length(SEXP x) { if (TYPEOF(x) == LISTSXP) { R_xlen_t i = 0; while (is_linked_list(x)) { ++i; x = CDR(x); } return i; } else { return Rf_length(x); } } lobstr/src/size.cpp0000644000176200001440000001616714254621577014054 0ustar liggesusers#include #include #include #include #include #include "utils.h" [[cpp11::register]] double v_size(double n, int element_size) { if (n == 0) return 0; double vec_size = std::max(sizeof(SEXP), sizeof(double)); double elements_per_byte = vec_size / element_size; double n_bytes = ceil(n / elements_per_byte); // Rcout << n << " elements, each of " << elements_per_byte << " = " << // n_bytes << "\n"; double size = 0; // Big vectors always allocated in 8 byte chunks if (n_bytes > 16) size = n_bytes * 8; // For small vectors, round to sizes allocated in small vector pool else if (n_bytes > 8) size = 128; else if (n_bytes > 6) size = 64; else if (n_bytes > 4) size = 48; else if (n_bytes > 2) size = 32; else if (n_bytes > 1) size = 16; else if (n_bytes > 0) size = 8; // Size is pointer to struct + struct size return size; } bool is_namespace(cpp11::environment env) { return env == R_BaseNamespace || Rf_findVarInFrame3(env, Rf_install(".__NAMESPACE__."), FALSE) != R_UnboundValue; } // R equivalent // https://github.com/wch/r-source/blob/master/src/library/utils/src/size.c#L41 double obj_size_tree(SEXP x, cpp11::environment base_env, int sizeof_node, int sizeof_vector, std::set& seen, int depth) { // NILSXP is a singleton, so occupies no space. Similarly SPECIAL and // BUILTIN are fixed and unchanging if (TYPEOF(x) == NILSXP || TYPEOF(x) == SPECIALSXP || TYPEOF(x) == BUILTINSXP) return 0; // Don't count objects that we've seen before if (!seen.insert(x).second) return 0; // Rcout << "\n" << std::string(depth * 2, ' '); // Rprintf("type: %s", Rf_type2char(TYPEOF(x))); // Use sizeof(SEXPREC) and sizeof(VECTOR_SEXPREC) computed in R. // CHARSXP are treated as vectors for this purpose double size = (Rf_isVector(x) || TYPEOF(x) == CHARSXP) ? sizeof_vector : sizeof_node; #if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0) // Handle ALTREP objects if (ALTREP(x)) { SEXP klass = ALTREP_CLASS(x); size += 3 * sizeof(SEXP); size += obj_size_tree(klass, base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(R_altrep_data1(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(R_altrep_data2(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); return size; } #endif // CHARSXPs have fake attributes if (TYPEOF(x) != CHARSXP ) size += obj_size_tree(ATTRIB(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); switch (TYPEOF(x)) { // Vectors ------------------------------------------------------------------- // See details in v_size() // Simple vectors case LGLSXP: case INTSXP: size += v_size(XLENGTH(x), sizeof(int)); break; case REALSXP: size += v_size(XLENGTH(x), sizeof(double)); break; case CPLXSXP: size += v_size(XLENGTH(x), sizeof(Rcomplex)); break; case RAWSXP: size += v_size(XLENGTH(x), 1); break; // Strings case STRSXP: size += v_size(XLENGTH(x), sizeof(SEXP)); for (R_xlen_t i = 0; i < XLENGTH(x); i++) { size += obj_size_tree(STRING_ELT(x, i), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } break; case CHARSXP: size += v_size(LENGTH(x) + 1, 1); break; // Generic vectors case VECSXP: case EXPRSXP: case WEAKREFSXP: size += v_size(XLENGTH(x), sizeof(SEXP)); for (R_xlen_t i = 0; i < XLENGTH(x); ++i) { size += obj_size_tree(VECTOR_ELT(x, i), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } break; // Nodes --------------------------------------------------------------------- // https://github.com/wch/r-source/blob/master/src/include/Rinternals.h#L237-L249 // All have enough space for three SEXP pointers // Linked lists case DOTSXP: case LISTSXP: case LANGSXP: { if (x == R_MissingArg) { // Needed for DOTSXP break; } SEXP cons = x; for (; is_linked_list(cons); cons = CDR(cons)) { if (cons != x) { size += sizeof_node; } size += obj_size_tree(TAG(cons), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CAR(cons), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } // Handle non-nil CDRs size += obj_size_tree(cons, base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; } case BCODESXP: size += obj_size_tree(TAG(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CAR(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CDR(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; // Environments case ENVSXP: if (x == R_BaseEnv || x == R_GlobalEnv || x == R_EmptyEnv || x == base_env || is_namespace(x)) return 0; size += obj_size_tree(FRAME(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(ENCLOS(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(HASHTAB(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; // Functions case CLOSXP: size += obj_size_tree(FORMALS(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); // BODY is either an expression or byte code size += obj_size_tree(BODY(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CLOENV(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case PROMSXP: size += obj_size_tree(PRVALUE(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(PRCODE(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(PRENV(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case EXTPTRSXP: size += sizeof(void *); // the actual pointer size += obj_size_tree(EXTPTR_PROT(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(EXTPTR_TAG(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case S4SXP: size += obj_size_tree(TAG(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case SYMSXP: break; default: cpp11::stop("Can't compute size of %s", Rf_type2char(TYPEOF(x))); } // Rprintf("type: %-10s size: %6.0f\n", Rf_type2char(TYPEOF(x)), size); return size; } [[cpp11::register]] double obj_size_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector) { std::set seen; double size = 0; int n = objects.size(); for (int i = 0; i < n; ++i) { size += obj_size_tree(objects[i], base_env, sizeof_node, sizeof_vector, seen, 0); } return size; } [[cpp11::register]] cpp11::doubles obj_csize_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector) { std::set seen; int n = objects.size(); cpp11::writable::doubles out(n); for (int i = 0; i < n; ++i) { out[i] = obj_size_tree(objects[i], base_env, sizeof_node, sizeof_vector, seen, 0); } return out; } lobstr/src/address.cpp0000644000176200001440000000250113762501764014510 0ustar liggesusers#include "utils.h" #include #include [[cpp11::register]] std::string obj_addr_(SEXP name, cpp11::environment env) { return obj_addr_(Rf_eval(name, env)); } void frame_addresses(SEXP frame, std::vector* refs) { for(SEXP cur = frame; cur != R_NilValue; cur = CDR(cur)) { SEXP obj = CAR(cur); if (obj != R_UnboundValue) refs->push_back(obj_addr_(obj)); } } void hash_table_addresses(SEXP table, std::vector* refs) { int n = Rf_length(table); for (int i = 0; i < n; ++i) frame_addresses(VECTOR_ELT(table, i), refs); } [[cpp11::register]] std::vector obj_addrs_(SEXP x) { int n = Rf_length(x); std::vector out; switch(TYPEOF(x)) { case STRSXP: for (int i = 0; i < n; ++i) { out.push_back(obj_addr_(STRING_ELT(x, i))); } break; case VECSXP: for (int i = 0; i < n; ++i) { out.push_back(obj_addr_(VECTOR_ELT(x, i))); } break; case ENVSXP: { bool isHashed = HASHTAB(x) != R_NilValue; if (isHashed) { hash_table_addresses(HASHTAB(x), &out); } else { frame_addresses(FRAME(x), &out); } break; } default: cpp11::stop( "`x` must be a list, environment, or character vector, not a %s.", Rf_type2char(TYPEOF(x)) ); } return out; } lobstr/src/cpp11.cpp0000644000176200001440000000637014254707536014021 0ustar liggesusers// Generated by cpp11: do not edit by hand // clang-format off #include "cpp11/declarations.hpp" #include // address.cpp std::string obj_addr_(SEXP name, cpp11::environment env); extern "C" SEXP _lobstr_obj_addr_(SEXP name, SEXP env) { BEGIN_CPP11 return cpp11::as_sexp(obj_addr_(cpp11::as_cpp>(name), cpp11::as_cpp>(env))); END_CPP11 } // address.cpp std::vector obj_addrs_(SEXP x); extern "C" SEXP _lobstr_obj_addrs_(SEXP x) { BEGIN_CPP11 return cpp11::as_sexp(obj_addrs_(cpp11::as_cpp>(x))); END_CPP11 } // inspect.cpp cpp11::list obj_inspect_(SEXP x, double max_depth, bool expand_char, bool expand_altrep, bool expand_env, bool expand_call, bool expand_bytecode); extern "C" SEXP _lobstr_obj_inspect_(SEXP x, SEXP max_depth, SEXP expand_char, SEXP expand_altrep, SEXP expand_env, SEXP expand_call, SEXP expand_bytecode) { BEGIN_CPP11 return cpp11::as_sexp(obj_inspect_(cpp11::as_cpp>(x), cpp11::as_cpp>(max_depth), cpp11::as_cpp>(expand_char), cpp11::as_cpp>(expand_altrep), cpp11::as_cpp>(expand_env), cpp11::as_cpp>(expand_call), cpp11::as_cpp>(expand_bytecode))); END_CPP11 } // size.cpp double v_size(double n, int element_size); extern "C" SEXP _lobstr_v_size(SEXP n, SEXP element_size) { BEGIN_CPP11 return cpp11::as_sexp(v_size(cpp11::as_cpp>(n), cpp11::as_cpp>(element_size))); END_CPP11 } // size.cpp double obj_size_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector); extern "C" SEXP _lobstr_obj_size_(SEXP objects, SEXP base_env, SEXP sizeof_node, SEXP sizeof_vector) { BEGIN_CPP11 return cpp11::as_sexp(obj_size_(cpp11::as_cpp>(objects), cpp11::as_cpp>(base_env), cpp11::as_cpp>(sizeof_node), cpp11::as_cpp>(sizeof_vector))); END_CPP11 } // size.cpp cpp11::doubles obj_csize_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector); extern "C" SEXP _lobstr_obj_csize_(SEXP objects, SEXP base_env, SEXP sizeof_node, SEXP sizeof_vector) { BEGIN_CPP11 return cpp11::as_sexp(obj_csize_(cpp11::as_cpp>(objects), cpp11::as_cpp>(base_env), cpp11::as_cpp>(sizeof_node), cpp11::as_cpp>(sizeof_vector))); END_CPP11 } extern "C" { static const R_CallMethodDef CallEntries[] = { {"_lobstr_obj_addr_", (DL_FUNC) &_lobstr_obj_addr_, 2}, {"_lobstr_obj_addrs_", (DL_FUNC) &_lobstr_obj_addrs_, 1}, {"_lobstr_obj_csize_", (DL_FUNC) &_lobstr_obj_csize_, 4}, {"_lobstr_obj_inspect_", (DL_FUNC) &_lobstr_obj_inspect_, 7}, {"_lobstr_obj_size_", (DL_FUNC) &_lobstr_obj_size_, 4}, {"_lobstr_v_size", (DL_FUNC) &_lobstr_v_size, 2}, {NULL, NULL, 0} }; } extern "C" attribute_visible void R_init_lobstr(DllInfo* dll){ R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } lobstr/R/0000755000176200001440000000000014254707536011775 5ustar liggesuserslobstr/R/utils.R0000644000176200001440000000327214253140421013243 0ustar liggesusersis_testing <- function () { identical(Sys.getenv("TESTTHAT"), "true") } # CLI --------------------------------------------------------------------- box_chars <- function() { fancy <- getOption("lobstr.fancy.tree") %||% l10n_info()$`UTF-8` orange <- crayon::make_style("orange") if (fancy) { list( "h" = "\u2500", # - horizontal "hd" = "\u2504", # - horizontal dotted "v" = "\u2502", # | vertical "vd" = "\u250A", # | vertical dotted "l" = "\u2514", # \ leaf "j" = "\u251C", # + junction "n" = orange("\u2588") # X node ) } else { list( "h" = "-", "hd" = "-", # Just use normal chars for dotted "v" = "|", "vd" = "|", "l" = "\\", "j" = "+", "n" = orange("o") ) } } grey <- function(...) { crayon::make_style(grDevices::grey(0.5), grey = TRUE)(...) } # string ----------------------------------------------------------------- str_dup <- function(x, n) { vapply(n, function(i) paste0(rep(x, i), collapse = ""), character(1)) } str_indent <- function(x, first, rest) { if (length(x) == 0) { character() } else if (length(x) == 1) { paste0(first, x) } else { c( paste0(first, x[[1]]), paste0(rest, x[-1L]) ) } } str_truncate <- function(x, n) { too_long <- nchar(x, type = "width") > n x[too_long] <- paste0(substr(x[too_long], 1, n - 3), "...") x } new_raw <- function(x) { structure(x, class = "lobstr_raw") } #' @export print.lobstr_raw <- function(x, ...) { cat(paste(x, "\n", collapse = ""), sep = "") invisible(x) } cat_line <- function(...) { cat(paste0(..., "\n", collapse = "")) } lobstr/R/size.R0000644000176200001440000000736614254674612013104 0ustar liggesusers#' Calculate the size of an object. #' #' `obj_size()` computes the size of an object or set of objects; #' `obj_sizes()` breaks down the individual contribution of multiple objects #' to the total size. #' #' @section Compared to `object.size()`: #' Compared to [object.size()], `obj_size()`: #' #' * Accounts for all types of shared values, not just strings in #' the global string pool. #' #' * Includes the size of environments (up to `env`) #' #' * Accurately measures the size of ALTREP objects. #' #' @section Environments: #' `obj_size()` attempts to take into account the size of the #' environments associated with an object. This is particularly important #' for closures and formulas, since otherwise you may not realise that you've #' accidentally captured a large object. However, it's easy to over count: #' you don't want to include the size of every object in every environment #' leading back to the [emptyenv()]. `obj_size()` takes #' a heuristic approach: it never counts the size of the global environment, #' the base environment, the empty environment, or any namespace. #' #' Additionally, the `env` argument allows you to specify another #' environment at which to stop. This defaults to the environment from which #' `obj_size()` is called to prevent double-counting of objects created #' elsewhere. #' #' @export #' @param ... Set of objects to compute size. #' @param env Environment in which to terminate search. This defaults to the #' current environment so that you don't include the size of objects that #' are already stored elsewhere. #' #' Regardless of the value here, `obj_size()` never looks past the #' global or base environments. #' #' @return An estimate of the size of the object, in bytes. #' @examples #' # obj_size correctly accounts for shared references #' x <- runif(1e4) #' obj_size(x) #' #' z <- list(a = x, b = x, c = x) #' obj_size(z) #' #' # this means that object size is not transitive #' obj_size(x) #' obj_size(z) #' obj_size(x, z) #' #' # use obj_size() to see the unique contribution of each component #' obj_sizes(x, z) #' obj_sizes(z, x) #' obj_sizes(!!!z) #' #' # obj_size() also includes the size of environments #' f <- function() { #' x <- 1:1e4 #' a ~ b #' } #' obj_size(f()) #' #' #' # In R 3.5 and greater, `:` creates a special "ALTREP" object that only #' # stores the first and last elements. This will make some vectors much #' # smaller than you'd otherwise expect #' obj_size(1:1e6) obj_size <- function(..., env = parent.frame()) { dots <- list2(...) size <- obj_size_(dots, env, size_node(), size_vector()) new_bytes(size) } #' @rdname obj_size #' @export obj_sizes <- function(..., env = parent.frame()) { dots <- list2(...) size <- obj_csize_(dots, env, size_node(), size_vector()) names(size) <- names(dots) new_bytes(size) } size_node <- function(x) as.vector(utils::object.size(quote(expr = ))) size_vector <- function(x) as.vector(utils::object.size(logical())) new_bytes <- function(x) { structure(x, class = "lobstr_bytes") } #' @export format.lobstr_bytes <- function(x, ...) { prettyunits::pretty_bytes(unclass(x)) } #' @export print.lobstr_bytes <- function(x, ...) { fx <- format(x) if (length(x) == 1) { cat_line(fx) } else { if (!is.null(names(x))) { cat_line(format(names(x)), ": ", fx) } else { cat_line("* ", fx) } } invisible(x) } #' @export c.lobstr_bytes <- function(...) { new_bytes(NextMethod()) } #' @export `[.lobstr_bytes` <- function(...) { new_bytes(NextMethod()) } # Helpers for interactive exploration ------------------------------------- comp <- function(x) { base <- utils::object.size(x) lobstr <- obj_size(x) c(base = base, lobstr = lobstr, diff = base - lobstr) } insp <- function(x) { eval(quote(.Internal(inspect(x)))) } lobstr/R/lobstr.R0000644000176200001440000000010113762501764013413 0ustar liggesusers#' @import rlang #' @useDynLib lobstr, .registration = TRUE NULL lobstr/R/mem.R0000644000176200001440000000143113251235323012657 0ustar liggesusers#' How much memory is currently used by R? #' #' `mem_used()` wraps around `gc()` and returns the exact number of bytes #' currently used by R. Note that changes will not match up exactly to #' [obj_size()] as session specific state (e.g. [.Last.value]) adds minor #' variations. #' #' @export #' @examples #' prev_m <- 0; m <- mem_used(); m - prev_m #' #' x <- 1:1e6 #' prev_m <- m; m <- mem_used(); m - prev_m #' obj_size(x) #' #' rm(x) #' prev_m <- m; m <- mem_used(); m - prev_m #' #' prev_m <- m; m <- mem_used(); m - prev_m mem_used <- function() { new_bytes(sum(gc()[, 1] * c(node_size(), 8))) } node_size <- function() { bit <- 8L * .Machine$sizeof.pointer if (!(bit == 32L || bit == 64L)) { stop("Unknown architecture", call. = FALSE) } if (bit == 32L) 28L else 56L } lobstr/R/cst.R0000644000176200001440000000214413304255564012704 0ustar liggesusers#' Call stack tree #' #' Shows the relationship between calls on the stack. This function #' combines the results of [sys.calls()] and [sys.parents()] yielding a display #' that shows how frames on the call stack are related. #' #' @export #' @examples #' # If all evaluation is eager, you get a single tree #' f <- function() g() #' g <- function() h() #' h <- function() cst() #' f() #' #' # You get multiple trees with delayed evaluation #' try(f()) #' #' # Pay attention to the first element of each subtree: each #' # evaluates the outermost call #' f <- function(x) g(x) #' g <- function(x) h(x) #' h <- function(x) x #' try(f(cst())) #' #' # With a little ingenuity you can use it to see how NSE #' # functions work in base R #' with(mtcars, {cst(); invisible()}) #' invisible(subset(mtcars, {cst(); cyl == 0})) #' #' # You can also get unusual trees by evaluating in frames #' # higher up the call stack #' f <- function() g() #' g <- function() h() #' h <- function() eval(quote(cst()), parent.frame(2)) #' f() cst <- function() { x <- rlang::trace_back(globalenv()) print(x, simplify = "none") invisible() } lobstr/R/cpp11.R0000644000176200001440000000144014254707536013043 0ustar liggesusers# Generated by cpp11: do not edit by hand obj_addr_ <- function(name, env) { .Call(`_lobstr_obj_addr_`, name, env) } obj_addrs_ <- function(x) { .Call(`_lobstr_obj_addrs_`, x) } obj_inspect_ <- function(x, max_depth, expand_char, expand_altrep, expand_env, expand_call, expand_bytecode) { .Call(`_lobstr_obj_inspect_`, x, max_depth, expand_char, expand_altrep, expand_env, expand_call, expand_bytecode) } v_size <- function(n, element_size) { .Call(`_lobstr_v_size`, n, element_size) } obj_size_ <- function(objects, base_env, sizeof_node, sizeof_vector) { .Call(`_lobstr_obj_size_`, objects, base_env, sizeof_node, sizeof_vector) } obj_csize_ <- function(objects, base_env, sizeof_node, sizeof_vector) { .Call(`_lobstr_obj_csize_`, objects, base_env, sizeof_node, sizeof_vector) } lobstr/R/tree.R0000644000176200001440000003226714254437054013064 0ustar liggesusers#' Pretty tree-like object printing #' #' A cleaner and easier to read replacement for `str` for nested list-like #' objects #' #' @param x A tree like object (list, etc.) #' @param index_unnamed Should children of containers without names have indices #' used as stand-in? #' @param max_depth How far down the tree structure should be printed. E.g. `1` #' means only direct children of the root element will be shown. Useful for #' very deep lists. #' @param show_environments Should environments be treated like normal lists and #' recursed into? #' @param hide_scalar_types Should atomic scalars be printed with type and #' length like vectors? E.g. `x <- "a"` would be shown as `x: "a"` #' instead of `x: "a"`. #' @param max_length How many elements should be printed? This is useful in case #' you try and print an object with 100,000 items in it. #' @param val_printer Function that values get passed to before being drawn to #' screen. Can be used to color or generally style output. #' @param class_printer Same as `val_printer` but for the the class types of #' non-atomic tree elements. #' @param show_attributes Should attributes be printed as a child of the list or #' avoided? #' @param remove_newlines Should character strings with newlines in them have #' the newlines removed? Not doing so will mess up the vertical flow of the #' tree but may be desired for some use-cases if newline structure is #' important to understanding object state. #' @param tree_chars List of box characters used to construct tree. Needs #' elements `$h` for horizontal bar, `$hd` for dotted horizontal bar, `$v` for #' vertical bar, `$vd` for dotted vertical bar, `$l` for l-bend, and `$j` for #' junction (or middle child). #' @param ... Ignored (used to force use of names) #' #' @return console output of structure #' #' @examples #' #' x <- list( #' list(id = "a", val = 2), #' list( #' id = "b", #' val = 1, #' children = list( #' list(id = "b1", val = 2.5), #' list( #' id = "b2", #' val = 8, #' children = list( #' list(id = "b21", val = 4) #' ) #' ) #' ) #' ), #' list( #' id = "c", #' val = 8, #' children = list( #' list(id = "c1"), #' list(id = "c2", val = 1) #' ) #' ) #' ) #' #' # Basic usage #' tree(x) #' #' # Even cleaner output can be achieved by not printing indices #' tree(x, index_unnamed = FALSE) #' #' # Limit depth if object is potentially very large #' tree(x, max_depth = 2) #' #' # You can customize how the values and classes are printed if desired #' tree(x, val_printer = function(x) { #' paste0("_", x, "_") #' }) #' @export tree <- function(x, ..., index_unnamed = FALSE, max_depth = 10L, max_length = 1000L, show_environments = TRUE, hide_scalar_types = TRUE, val_printer = crayon::blue, class_printer = crayon::silver, show_attributes = FALSE, remove_newlines = TRUE, tree_chars = box_chars()) { rlang::check_dots_empty() # Pack up the unchanging arguments into a list and send to tree_internal termination_type <- tree_internal( x, opts = list( index_unnamed = index_unnamed, max_depth = max_depth, max_length = max_length, show_envs = show_environments, hide_scalar_types = hide_scalar_types, val_printer = val_printer, class_printer = class_printer, show_attributes = show_attributes, remove_newlines = remove_newlines, tree_chars = tree_chars ) ) if (termination_type == "early") { cat("...", "\n") } invisible(x) } # Tree printing internal function # # This is the internal function for the main tree printing code. It wraps the # static options arguments from the user-facing `tree()` into a single opts # list to make recursive calls cleaner. It also has arguments that as it is # called successively but the end-user shouldn't see or use. tree_internal <- function(x, x_id = NULL, branch_hist = character(0), opts, attr_mode = FALSE, counter_env = rlang::new_environment( data = list(n_printed = 0, envs_seen = c()) )) { counter_env$n_printed <- counter_env$n_printed + 1 # Stop if we've reached the max number of times printed desired if (counter_env$n_printed > opts$max_length) { return("early") } # Since self-loops can occur in environments check to see if we've seen any # environments before already_seen <- FALSE if (rlang::is_environment(x)) { already_seen <- any(vapply(counter_env$envs_seen, identical, x, FUN.VALUE = logical(1))) if (!already_seen) { # If this environment is new, add it to the seen counter_env$envs_seen[[length(counter_env$envs_seen) + 1]] <- x } } depth <- length(branch_hist) # Build branch string from branch history # Start with empty spaces branch_chars <- rep_len(" ", depth) branch_chars[branch_hist == "child"] <- paste0(opts$tree_chars$v, " ") branch_chars[grepl("attr", branch_hist, fixed = TRUE)] <- paste0(opts$tree_chars$vd, " ") # Next update the final element (aka the current step) with the correct branch type last_step <- branch_hist[depth] root_node <- length(branch_hist) == 0 branch_chars[depth] <- if (root_node) { "" } else { paste0( if (grepl("last", last_step)) opts$tree_chars$l else opts$tree_chars$j, if (grepl("attribute", last_step)) opts$tree_chars$hd else opts$tree_chars$h ) } # Build label label <- paste0( x_id, make_type_abrev(x, opts$hide_scalar_types), if (!rlang::is_null(x_id) && x_id != "") ": ", tree_label(x, opts), if (already_seen) " (Already seen)" ) # Figure out how many children we have (plus attributes if they are being # printed) so we can setup how to proceed x_attributes <- attributes(x) if (attr_mode) { # Filter out "names" attribute as this is already shown by tree x_attributes <- x_attributes[names(x_attributes) != "names"] } has_attributes <- length(x_attributes) > 0 && opts$show_attributes has_children <- has_attributes || length(x) > 1 max_depth_reached <- depth >= opts$max_depth && has_children # Do the actual printing to the console with an optional ellipses to indicate # we've reached the max depth and won't recurse more cat( paste(branch_chars, collapse = ""), label, if (max_depth_reached) "...", "\n", sep = "" ) # ===== Start recursion logic if (already_seen || max_depth_reached) { return("Normal finish") } if (rlang::is_list(x) || is_printable_env(x)) { # Coerce current object to a plain list. This is necessary as some s3 # classes override `[[` and return funky stuff like themselves (see s3 class # "package_version") children <- if (is_printable_env(x)) { # Environments are funky as they don't have names before conversion to list # but do after, so let them handle their conversion. # We use all.names = TRUE in an effort to fully explain the object as.list.environment(x, all.names = TRUE) } else { # By wiping all attributes except for the names we force the object to be # a plain list. This is inspired by the (now depreciated) rlang::as_list(). attributes(x) <- list(names = names(x)) as.list(x) } # Traverse children, if any exist n_children <- length(children) child_names <- names(children) # If children have names, give them the names for (i in seq_along(children)) { id <- child_names[i] if ((rlang::is_null(id) || id == "") && opts$index_unnamed) id <- crayon::italic(i) child_type <- if (i < n_children) { "child" } else if (has_attributes) { # We use "attrs" here instead of full "attribute" so a grep for # attributes just gets plain "attribute" or "last-attribute" but a grep # for "attr" gets all attribute related types "pre-attrs" } else { "last-child" } termination_type <- Recall( x = children[[i]], x_id = id, branch_hist = c(branch_hist, child_type), opts = opts, counter_env = counter_env ) if (termination_type == "early") { return(termination_type) } } } # ===== End recursion logic # Add any attributes as an "attr" prefixed children at end if (has_attributes) { n_attributes <- length(x_attributes) for (i in seq_len(n_attributes)) { termination_type <- Recall( x = x_attributes[[i]], x_id = crayon::italic(paste0("attr(,\"", names(x_attributes)[i], "\")")), opts = opts, branch_hist = c(branch_hist, paste0(if (i == n_attributes) "last-", "attribute")), attr_mode = TRUE, # Let tree know this is an attribute counter_env = counter_env ) if (termination_type == "early") { return(termination_type) } } } # If all went smoothly we reach here "Normal finish" } # There are a few environments we don't want to recurse into is_printable_env <- function(x) { is_environment(x) && !( identical(x, rlang::global_env()) || identical(x, rlang::empty_env()) || identical(x, rlang::base_env()) || rlang::is_namespace(x) ) } #' Build element or node label in tree #' #' These methods control how the value of a given node is printed. New methods #' can be added if support is needed for a novel class #' #' @inheritParams tree #' @param opts A list of options that directly mirrors the named arguments of #' [tree]. E.g. `list(val_printer = crayon::red)` is equivalent to #' `tree(..., val_printer = crayon::red)`. #' #' @export tree_label <- function(x, opts) { UseMethod("tree_label") } #' @export tree_label.function <- function(x, opts) { func_args <- collapse_and_truncate_vec(methods::formalArgs(x), 5) crayon::italic(paste0("function(", func_args, ")")) } #' @export tree_label.environment <- function(x, opts) { format.default(x) } #' @export tree_label.NULL <- function(x, opts) { "" } #' @export tree_label.character <- function(x, opts) { # Get rid of new-line so they don't break tree flow if (opts$remove_newlines) { x <- gsub("\\n", replacement = "\u21B5", x = x, perl = TRUE) } # Shorten strings if needed max_standalone_length <- 35 max_vec_length <- 15 max_length <- if (length(x) == 1) max_standalone_length else max_vec_length x <- truncate_string(x, max_length) tree_label.default(paste0("\"", x, "\""), opts) } #' @export tree_label.default <- function(x, opts) { if (rlang::is_atomic(x)) { opts$val_printer(collapse_and_truncate_vec(x, 10)) } else if (rlang::is_function(x)) { # Lots of times function-like functions don't actually trigger the s3 method # for function because they dont have function in their class-list. This # catches those. tree_label.function(x, opts) } else if (rlang::is_environment(x)) { # Environments also tend to have the same trouble as functions. For instance # the srcobject attached to a function's attributes is an environment but # doesn't report as one to s3. tree_label.environment(x, opts) } else if (rlang::is_expression(x) || rlang::is_formula(x)) { paste0(label_class(x, opts), " ", crayon::italic(deparse(x))) } else { # The "base-case" is simply a list-like object. label_class(x, opts) } } collapse_and_truncate_vec <- function(vec, max_length) { vec <- as.character(vec) too_long <- length(vec) > max_length if (too_long) { vec <- utils::head(vec, max_length) vec <- c(vec, "...") } paste0(vec, collapse = ", ") } truncate_string <- function(char_vec, max_length) { ifelse( nchar(char_vec) > max_length, # Since we add an elipses we need to take a bit more than the max length # off. The gsub adds elipses but also makes sure we dont awkwardly end on # a space. gsub( x = substr(char_vec, start = 1, max_length - 3), pattern = "\\s*$", replacement = "...", perl = TRUE ), char_vec ) } make_type_abrev <- function(x, omit_scalars) { if (!rlang::is_atomic(x) || (rlang::is_scalar_atomic(x) && omit_scalars)) { return("") } type_abrev <- switch(typeof(x), logical = "lgl", integer = "int", double = "dbl", character = "chr", complex = "cpl", expression = "expr", raw = "raw", "unknown" ) paste0("<", type_abrev, " [", format(length(x), big.mark = ","), "]>") } # Inspired by waldo:::friendly_type_of(). Prints the class name and hierarchy # encased in angle brackets along with a prefix that tells you what OO system # the object belongs to (if it does.) label_class <- function(x, opts) { if (is_missing(x)) { return("absent") } oo_prefix <- "" class_list <- if (!is.object(x)) { typeof(x) } else if (isS4(x)) { oo_prefix <- "S4" methods::is(x) } else if (inherits(x, "R6")) { oo_prefix <- "R6" setdiff(class(x), "R6") } else { oo_prefix <- "S3" class(x) } opts$class_printer( paste0(oo_prefix, "<", paste(class_list, collapse = "/"), ">") ) } lobstr/R/sxp.R0000644000176200001440000001264713502504057012730 0ustar liggesusers#' Inspect an object #' #' `sxp(x)` is similar to `.Internal(inspect(x))`, recursing into the C data #' structures underlying any R object. The main difference is the output is a #' little more compact, it recurses fully, and avoids getting stuck in infinite #' loops by using a depth-first search. It also returns a list that you can #' compute with, and carefully uses colour to highlight the most important #' details. #' #' The name `sxp` comes from `SEXP`, the name of the C data structure that #' underlies all R objects. #' #' @param x Object to inspect #' @param max_depth Maximum depth to recurse. Use `max_depth = Inf` (with care!) #' to recurse as deeply as possible. Skipped elements will be shown as `...`.` #' @param expand Optionally, expand components of the true that are usually #' suppressed. Use: #' #' * "character" to show underlying entries in the global string pool. #' * "environment" to show the underlying hashtables. #' * "altrep" to show the underlying data. #' * "call" to show the full AST (but [ast()] is usually superior) #' * "bytecode" to show generated bytecode. #' @family object inspectors #' @export #' @examples #' x <- list( #' TRUE, #' 1L, #' runif(100), #' "3" #' ) #' sxp(x) #' #' # Expand "character" to see underlying CHARSXP entries in the global #' # string pool #' x <- c("banana", "banana", "apple", "banana") #' sxp(x) #' sxp(x, expand = "character") #' #' # Expand altrep to see underlying data #' x <- 1:10 #' sxp(x) #' sxp(x, expand = "altrep") #' #' # Expand environmnets to see the underlying implementation details #' e1 <- new.env(hash = FALSE, parent = emptyenv(), size = 3L) #' e2 <- new.env(hash = TRUE, parent = emptyenv(), size = 3L) #' e1$x <- e2$x <- 1:10 #' #' sxp(e1) #' sxp(e1, expand = "environment") #' sxp(e2, expand = "environment") sxp <- function(x, expand = character(), max_depth = 5L) { opts <- c("character", "altrep", "environment", "call", "bytecode") if (any(!expand %in% opts)) { abort("`expand` must contain only values from ", paste("'", opts, "'", collapse = ",")) } obj_inspect_(x, max_depth - 1L, opts[[1]] %in% expand, opts[[2]] %in% expand, opts[[3]] %in% expand, opts[[4]] %in% expand, opts[[5]] %in% expand ) } #' @export format.lobstr_inspector <- function(x, ..., depth = 0, name = NA) { indent <- paste0(rep(" ", depth), collapse = "") id <- crayon::bold(attr(x, "id")) if (!is_testing()) { addr <- paste0(":", crayon::silver(attr(x, "addr"))) } else { addr <- "" } if (attr(x, "type") == 0) { desc <- crayon::silver("") } else if (attr(x, "has_seen")) { desc <- paste0("[", attr(x, "id"), addr, "]") } else { type <- sexp_type(attr(x, "type")) if (sexp_is_vector(type)) { if (!is.null(attr(x, "truelength"))) { length <- paste0("[", attr(x, "length"), "/", attr(x, "truelength"), "]") } else { length <- paste0("[", attr(x, "length"), "]") } } else { length <- NULL } if (!is.null(attr(x, "value"))) { value <- paste0(": ", attr(x, "value")) } else { value <- NULL } # show altrep, object, named etc sxpinfo <- paste0( if (attr(x, "altrep")) "altrep ", if (attr(x, "object")) "object ", if (!is_testing()) paste0("named:", attr(x, "named")) ) desc <- paste0( "[", id, addr, "] ", "<", crayon::cyan(type), length, value, "> ", "(", sxpinfo, ")" ) } name <- if (!identical(name, "")) { paste0(crayon::italic(crayon::silver(name)), " ") } paste0(indent, name, desc) } #' @export print.lobstr_inspector <- function(x, ..., depth = 0, name = "") { cat_line(format(x, depth = depth, name = name)) if (isTRUE(attr(x, "skip"))) { indent <- paste0(rep(" ", depth + 1), collapse = "") cat_line(indent, crayon::silver("...")) } for (i in seq_along(x)) { print(x[[i]], depth = depth + 1, name = names(x)[[i]]) } } sxp_view <- function(x, expand = character()) { if (!"tools:rstudio" %in% search()) { abort("Can only be called from within RStudio") } env <- as.environment("tools:rstudio") old_opt <- options(crayon.enabled = FALSE) on.exit(options(old_opt), add = TRUE) old_fun <- env$.rs.explorer.objectDesc on.exit(env$.rs.addFunction("explorer.objectDesc", old_fun), add = TRUE) assign(".rs.explorer.objectDesc", envir = env, function(x) { if (inherits(x, "lobstr_inspector")) { format.lobstr_inspector(x) } else { old_fun(x) } }) obj <- sxp(x, expand = expand) env$.rs.viewHook(NULL, obj, "Object inspector") # explorer.objectDesc() is called lazily so this is a crude hack Sys.sleep(10) } # helpers ----------------------------------------------------------------- sexp_type <- function(x) { unname(SEXPTYPE[as.character(x)]) } sexp_is_vector <- function(x) { x %in% c("LGLSXP", "INTSXP", "REALSXP", "STRSXP", "RAWSXP", "CPLXSXP", "VECSXP", "EXPRSXP") } SEXPTYPE <- c( "0" = "NILSXP", "1" = "SYMSXP", "2" = "LISTSXP", "3" = "CLOSXP", "4" = "ENVSXP", "5" = "PROMSXP", "6" = "LANGSXP", "7" = "SPECIALSXP", "8" = "BUILTINSXP", "9" = "CHARSXP", "10" = "LGLSXP", "13" = "INTSXP", "14" = "REALSXP", "15" = "CPLXSXP", "16" = "STRSXP", "17" = "DOTSXP", "18" = "ANYSXP", "19" = "VECSXP", "20" = "EXPRSXP", "21" = "BCODESXP", "22" = "EXTPTRSXP", "23" = "WEAKREFSXP", "24" = "RAWSXP", "25" = "S4SXP", "30" = "NEWSXP", "31" = "FREESXP", "99" = "FUNSXP" ) lobstr/R/address.R0000644000176200001440000000264213406773157013551 0ustar liggesusers#' Find memory location of objects and their children. #' #' `obj_addr()` gives the address of the value that `x` points to; #' `obj_addrs()` gives the address of the components the list, #' environment, and character vector `x` point to. #' #' `obj_addr()` has been written in such away that it avoids taking #' references to an object. #' #' @param x An object #' @export #' @examples #' # R creates copies lazily #' x <- 1:10 #' y <- x #' obj_addr(x) == obj_addr(y) #' #' y[1] <- 2L #' obj_addr(x) == obj_addr(y) #' #' y <- runif(10) #' obj_addr(y) #' z <- list(y, y) #' obj_addrs(z) #' #' y[2] <- 1.0 #' obj_addrs(z) #' obj_addr(y) #' #' # The address of an object is different every time you create it: #' obj_addr(1:10) #' obj_addr(1:10) #' obj_addr(1:10) obj_addr <- function(x) { x <- enquo(x) addr <- obj_addr_(quo_get_expr(x), quo_get_env(x)) if (is_testing()) { test_addr_get(addr) } else { addr } } #' @export #' @rdname obj_addr obj_addrs <- function(x) { addrs <- obj_addrs_(x) if (is_testing()) { vapply(addrs, test_addr_get, character(1), USE.NAMES = FALSE) } else { addrs } } test_addr <- child_env(emptyenv(), "__next_id" = 1) test_addr_get <- function(addr) { if (env_has(test_addr, addr)) { addr <- env_get(test_addr, addr) } else { addr <- obj_id(test_addr, addr) } sprintf("0x%03i", addr) } test_addr_reset <- function() { env_poke(test_addr, "__next_id", 1) } lobstr/R/ast.R0000644000176200001440000000456713502504130012677 0ustar liggesusers#' Display the abstract syntax tree #' #' This is a useful alternative to `str()` for expression objects. #' #' @param x An expression to display. Input is automatically quoted, #' use `!!` to unquote if you have already captured an expression object. #' @family object inspectors #' @export #' @examples #' # Leaves #' ast(1) #' ast(x) #' #' # Simple calls #' ast(f()) #' ast(f(x, 1, g(), h(i()))) #' ast(f()()) #' ast(f(x)(y)) #' #' ast((x + 1)) #' #' # Displaying expression already stored in object #' x <- quote(a + b + c) #' ast(x) #' ast(!!x) #' #' # All operations have this same structure #' ast(if (TRUE) 3 else 4) #' ast(y <- x * 10) #' ast(function(x = 1, y = 2) { x + y } ) #' #' # Operator precedence #' ast(1 * 2 + 3) #' ast(!1 + !1) ast <- function(x) { expr <- enexpr(x) new_raw(ast_tree(expr)) } ast_tree <- function(x, layout = box_chars()) { if (is_quosure(x)) { x <- quo_squash(x) } # base cases if (rlang::is_syntactic_literal(x)) { return(ast_leaf_constant(x)) } else if (is_symbol(x)) { return(ast_leaf_symbol(x)) } else if (!is.pairlist(x) && !is.call(x)) { return(paste0("")) } # recursive case subtrees <- lapply(x, ast_tree, layout = layout) subtrees <- name_subtree(subtrees) n <- length(x) if (n == 0) { character() } else if (n == 1) { str_indent(subtrees[[1]], paste0(layout$n, layout$h), " " ) } else { c( str_indent(subtrees[[1]], paste0(layout$n, layout$h), paste0(layout$v, " ") ), unlist(lapply(subtrees[-c(1, n)], str_indent, paste0(layout$j, layout$h), paste0(layout$v, " ") )), str_indent(subtrees[[n]], paste0(layout$l, layout$h), " " ) ) } } name_subtree <- function(x) { nm <- names(x) if (is.null(nm)) return(x) has_name <- nm != "" label <- paste0(crayon::italic(grey(nm)), " = ") indent <- str_dup(" ", nchar(nm) + 3) x[has_name] <- Map(str_indent, x[has_name], label[has_name], indent[has_name]) x } ast_leaf_symbol <- function(x) { x <- as.character(x) if (!is.syntactic(x)) { x <- encodeString(x, quote = "`") } crayon::bold(crayon::magenta(x)) } ast_leaf_constant <- function(x) { if (is.complex(x)) { paste0(Im(x), "i") } else { deparse(x) } } is.syntactic <- function(x) make.names(x) == x lobstr/R/ref.R0000644000176200001440000000652314253143157012672 0ustar liggesusers#' Display tree of references #' #' This tree display focusses on the distinction between names and values. #' For each reference-type object (lists, environments, and optional character #' vectors), it displays the location of each component. The display #' shows the connection between shared references using a locally unique id. #' #' @param ... One or more objects #' @param character If `TRUE`, show references from character vector in to #' global string pool #' @export #' @family object inspectors #' @examples #' x <- 1:100 #' ref(x) #' #' y <- list(x, x, x) #' ref(y) #' ref(x, y) #' #' e <- new.env() #' e$e <- e #' e$x <- x #' e$y <- list(x, e) #' ref(e) #' #' # Can also show references to global string pool if requested #' ref(c("x", "x", "y")) #' ref(c("x", "x", "y"), character = TRUE) ref <- function(..., character = FALSE) { x <- list(...) seen <- child_env(emptyenv(), `__next_id` = 1) out <- lapply(x, ref_tree, character = character, seen = seen) n <- length(x) if (n > 1) { out[-n] <- lapply(out[-n], function(x) c(x, "")) } new_raw(unlist(out)) } ref_tree <- function(x, character = FALSE, seen = child_env(emptyenv()), layout = box_chars()) { addr <- obj_addr(x) has_seen <- env_has(seen, addr) id <- obj_id(seen, addr) desc <- obj_desc(addr, type_sum(x), has_seen, id) # Not recursive or already seen if (!has_references(x, character) || has_seen) { return(desc) } # Remove classes to avoid custom methods (note that environments cannot be unclasse()ed) attr(x, "class") <- NULL # recursive cases if (is.list(x)) { subtrees <- lapply(x, ref_tree, layout = layout, seen = seen, character = character) } else if (is.environment(x)) { subtrees <- lapply(as.list(x, all.names = TRUE), ref_tree, layout = layout, seen = seen, character = character) } else if (is.character(x)) { subtrees <- ref_tree_chr(x, layout = layout, seen = seen) } subtrees <- name_subtree(subtrees) self <- str_indent(desc, paste0(layout$n, " "), paste0(layout$v, " ")) n <- length(subtrees) if (n == 0) { return(self) } c( self, unlist(lapply(subtrees[-n], str_indent, paste0(layout$j, layout$h), paste0(layout$v, " ") )), str_indent(subtrees[[n]], paste0(layout$l, layout$h), " " ) ) } type_sum <- function(x) { if (is_installed("pillar")) { pillar::type_sum(x) } else { typeof(x) } } obj_desc <- function(addr, type, has_seen, id) { if (has_seen) { paste0("[", grey(paste0(id, ":", addr)), "]") } else { paste0("[", crayon::bold(id), ":", addr, "] ", "<", type, ">") } } has_references <- function(x, character = FALSE) { is_list(x) || is.environment(x) || (character && is_character(x)) } ref_tree_chr <- function(x, layout = box_chars(), seen = child_env(emptyenv())) { addrs <- obj_addrs(x) has_seen <- logical(length(x)) ids <- integer(length(x)) for (i in seq_along(addrs)) { has_seen[[i]] <- env_has(seen, addrs[[i]]) ids[[i]] <- obj_id(seen, addrs[[i]]) } type <- paste0('string: "', str_truncate(x, 10), '"') out <- Map(obj_desc, addrs, type, has_seen, ids) names(out) <- names(x) out } obj_id <- function(env, ref) { if (env_has(env, ref)) { env_get(env, ref) } else { id <- env_get(env, "__next_id") env_poke(env, "__next_id", id + 1) env_poke(env, ref, id) id } } lobstr/NEWS.md0000644000176200001440000000231414254716036012665 0ustar liggesusers# lobstr 1.1.2 * Switched to cpp11 from Rcpp. * Relicensed as MIT (#51). * `obj_size()` and `sxp()` now support non-nil terminated pairlists. * `obj_size()` now displays large objects with KB, MB, etc (#57, #60), and no longer returns NA for objects larger than 2^31 bytes (#45). * `obj_sizes()` now computes relative sizes correctly (without meaningless floating point differences). * `ref()` lists all contents of environments even those with names beginning with `.` (@krlmlr, #53). * New, experimental `tree()` function as alternative to `str()` (#56). # lobstr 1.1.1 * Fix PROTECT error. * Remove UTF-8 characters from comments # lobstr 1.1.0 * `ref()` now handles custom classes properly (@yutannihilation, #36) * `sxp()` is a new tool for displaying the underlying C representation of an object (#38). * `obj_size()` now special cases the ALTREP "deferred string vectors" which previously crashed due to the way in which they abuse the pairlist type (#35). # lobstr 1.0.1 * `ast()` prints scalar integer and complex more accurately (#24) * `obj_addr()` no longer increments the reference count of its input (#25) * `obj_size()` now correctly computes size of ALTREP objects on R 3.5.0 (#32) lobstr/MD50000644000176200001440000000414714254721642012104 0ustar liggesusers13fb43076ca5fb87aff9bda6f22b4841 *DESCRIPTION 0b8b43cc3178cffe7f78ad8789a2bd49 *LICENSE d15184f1067513154810f50b2839bf67 *NAMESPACE cb4ea47f344f89fd79066a11892e6eb9 *NEWS.md 93d58f53eeb7461eb9be11353d16243b *R/address.R 5cd39b056b3bdc4b0d0b945532dda9b4 *R/ast.R 35a421512b15bd05139b98bda4e2cfbb *R/cpp11.R bb5066b00bc02e63f4225fb8817f8848 *R/cst.R 8ff1133e3902f5f682911cb060af0d78 *R/lobstr.R 77012918976575fd5b176b95a1d18fb3 *R/mem.R 6756cf9b8a5090f2f87993c0192e7209 *R/ref.R 64232f760ef653df76faac2074e91e7d *R/size.R f7d3d97198a963fb6c687ec382fc5e66 *R/sxp.R 02fea32c93391640b69ef0232524fe41 *R/tree.R fb36e4c596fed84621a22c788399a45e *R/utils.R 4df38bc3504490d8c117f7cc982413c6 *README.md 267bfee1a7dd458cb068810b671a9c35 *man/ast.Rd ec937196239fb6b6959b59e5f7764caa *man/cst.Rd 8f3defd041d3786de9355197c1b259a5 *man/figures/logo.png b6292677acd723224e8bb27b7938225e *man/mem_used.Rd de54fc026d86e22ce7e10db07ab32377 *man/obj_addr.Rd f8b5ee446ac342e149827cad29a7f658 *man/obj_size.Rd dcb225128ccb2e5e9828868ac64a5bff *man/ref.Rd 9f1f4cd1468e49216fa231ba3ef4176e *man/sxp.Rd 89e3465b46568090f937cf5f74fb1f96 *man/tree.Rd 0b86e73f611aed90ccdbbf5e4b47c719 *man/tree_label.Rd ac8218dd1fa55ac4acdef1179bf527af *src/address.cpp e43e492d938def548457ba14753bbcdf *src/cpp11.cpp 87efdd658ffc22a9c996538ce72da93c *src/inspect.cpp 43620725133477e801cbd3ac4ffb2731 *src/size.cpp 0dedf8f905fe4f91d2c947965f7847da *src/utils.h 35f98f5a6ad54e371e4e1f6638702a56 *tests/testthat.R d1c5d4f6ca1bb06511f91dcc97e4411c *tests/testthat/_snaps/ast.md 5edf1832e72c5c1b136d22b718fbc5a5 *tests/testthat/_snaps/ref.md 49c177f4b6c0498ea010271f15c41f09 *tests/testthat/_snaps/size.md 0d68aa140a64c449bf14eb60351c846e *tests/testthat/_snaps/sxp.md bfb9d3c85232a1c00202c09e09c976f0 *tests/testthat/_snaps/tree.md 6dbe9bae43164489a61eafc76d13efdd *tests/testthat/test-address.R 2c3935f0dd379dfe85fd6343d9ff534a *tests/testthat/test-ast.R 7a1b90369e931672aff2d32874300b72 *tests/testthat/test-ref.R 1cf0bcc2a3b1b7c210146717b42c1def *tests/testthat/test-size.R 3a6406c0cdbcc0e03750dbeb9b6d24d9 *tests/testthat/test-sxp.R aef1176d87229b708344718117f4c14f *tests/testthat/test-tree.R