R Under development (unstable) (2024-05-17 r86565 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2024 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> source(file.path("_helper", "init.R"))
> source(file.path("aammrtf", "ref.R")); make_ref_obj_funs("item")
> 
> options(unitizer.color = FALSE)
> 
> # These tests are intended to cover all the functions/classes/methods in:
> # - item.R
> # - item.sub.R
> # - test_eval.R     # indirectly
> # - heal.R
> # - unitizer.R
> # Basically everything that can be tested non-interactively
> # Helper funs
> 
> callDep <- function(x) paste0(deparse(x@call, width.cutoff = 500),
+     collapse = "")
> lsObjs <- function(x) paste0(x@ls$names, x@ls$status, collapse = ", ")
> lsStat <- function(x) x@ls$status
> lsInv <- function(x) isTRUE(attr(x@ls, "invalid"))
> # Get started
> 
> new.exps <- expression(
+   1 + 1,
+   a <- 54,     # keep
+   b <- 38,     # keep
+   a + b,
+   e <- 5 * a,  # keep
+   a ^ 2,       # Keep
+   f <- e * a,
+   matrix(rep(f, 20))  # keep
+ )
> ref.exps <- expression(
+   1 + 1,
+   a <- 54,
+   b <- 38,
+   a + b,
+   e <- 5 * a,
+   e ^ 3
+ )
> 
> Sys.sleep(0.2)
> my.unitizer <- new("unitizer", id = 1, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer <- my.unitizer + ref.exps)
> my.unitizer2 <- new("unitizer", id = 2, zero.env = new.env())
> # now convert them to reference items
> coi(my.unitizer2 <- my.unitizer2 + my.unitizer@items.new)
> # now test against new.exps
> coi(my.unitizer2 <- my.unitizer2 + new.exps)
> 
> # - "item funs" ----------------------------------------------------------------
> 
> item <- my.unitizer@items.new[[1L]]
> unitizer:::itemType(item)
[1] "new"
> try(unitizer:::itemType(item) <- "asdfasd")
Error in unitizer:::`itemType<-`(`*tmp*`, value = "asdfasd") : 
  Argument `value` must be in c("new", "reference")
> unitizer:::itemType(item) <- "reference"
> unitizer:::itemType(item)
[1] "reference"
> try(unitizer:::itemsType(my.unitizer@items.new) <- as.character(1:1000))
Error in unitizer:::`itemsType<-`(`*tmp*`, value = c("1", "2", "3", "4",  : 
  Argument `value` must be length 1L or have same length as argument `x`
> try(item$booboo)
Error in .local(x, i, j, ...) : 
  Argument `name` must be in c("call", "state", "value", "conditions", "output", "message", "aborted")
> 
> # - "unitizer creation worked as expected" -------------------------------------
> 
> validObject(my.unitizer, complete = TRUE)
[1] TRUE
> all.equal(capture.output(show(my.unitizer@items.new[[1L]])), rds(100))
[1] TRUE
> identical(length(my.unitizer2), length(new.exps))
[1] TRUE
> identical(length(my.unitizer2@items.new), length(new.exps))
[1] TRUE
> identical(length(my.unitizer2@items.ref), length(ref.exps))
[1] TRUE
> all.equal(
+   as.expression(
+     lapply(unitizer:::as.list(my.unitizer2@items.new), slot, "call")
+   ),
+   new.exps
+ )
[1] TRUE
> all.equal(
+   as.expression(
+     lapply(unitizer:::as.list(my.unitizer2@items.ref), slot, "call")
+   ),
+   ref.exps
+ )
[1] TRUE
> vals <- lapply(
+   unitizer:::as.list(my.unitizer2@items.new), function(x) x@data@value[[1L]]
+ )
> vals.ign <- unitizer:::ignored(my.unitizer2@items.new)
> all.equal(vals[!vals.ign], lapply(new.exps, eval)[!vals.ign])
[1] TRUE
> all(vapply(vals[vals.ign], is, logical(1L), "unitizerDummy"))
[1] TRUE
> 
> vals <- lapply(
+   unitizer:::as.list(my.unitizer2@items.ref), function(x) x@data@value[[1L]]
+ )
> vals.ign <- unitizer:::ignored(my.unitizer2@items.ref)
> all.equal(vals[!vals.ign], lapply(ref.exps, eval)[!vals.ign])
[1] TRUE
> all(vapply(vals[vals.ign], is, logical(1L), "unitizerDummy"))
[1] TRUE
> my.unitizer2@items.new.map
[1]  1  2  3  4  5 NA NA NA
> my.unitizer2@items.ref.map
[1]  1  2  3  4  5 NA
> my.unitizer2@tests.fail
[1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
> my.unitizer2@tests.status
[1] Pass Pass Pass Pass Pass New  New  New 
Levels: Pass Fail New Deleted Error
> my.unitizer2@section.map
[1] 1 1 1 1 1 1 1 1
> unitizer:::ignored(my.unitizer2@items.new)
[1] FALSE  TRUE  TRUE FALSE  TRUE FALSE  TRUE FALSE
> unitizer:::ignored(my.unitizer2@items.ref)
[1] FALSE  TRUE  TRUE FALSE  TRUE FALSE
> 
> # - "Size Measurement works" ---------------------------------------------------
> 
> # Used to produce warnings because the same base.env was used for every
> # unitizer because it was created on package load as part of the S4 class
> # definition instead of in "initialize", so any time we instantiated more
> # than one object they all shared the same environment, causing issues with
> # saveRDS
> x <- unitizer:::sizeUntz(my.unitizer2)
> is.matrix(x) && is.numeric(x)
[1] TRUE
> colnames(x)
[1] "size" "rds" 
> 
> # - "Environment healing works" ------------------------------------------------
> 
> items.mixed <- my.unitizer2@items.new[4:5] + my.unitizer2@items.ref[[1]] +
+     my.unitizer2@items.new[c(2, 6, 8)]
> items.sorted <- unitizer:::healEnvs(items.mixed, my.unitizer2)
> env.anc <- lapply(unitizer:::as.list(items.sorted), function(x) rev(unitizer:::env_ancestry(x@env,
+     my.unitizer2@base.env)))
> max.len <- max(vapply(env.anc, length, 1L))
> env.anc.2 <- lapply(env.anc, function(x) {
+     length(x) <- max.len
+     x
+ })
> env.anc.df <- as.data.frame(env.anc.2, stringsAsFactors = FALSE)
> # Here only the first item is reference, all others
> length(unique(unlist(env.anc.df[2, ])))
[1] 1
> all(
+   apply(
+     env.anc.df[-(1:2), -1], 1,
+     function(x) length(unique(Filter(Negate(is.na), x)))
+   ) == 1L
+ )
[1] TRUE
> # First item is reference, all others are new
> unitizer:::itemsType(items.sorted)
[1] "reference" "new"       "new"       "new"       "new"       "new"      
[7] "new"       "new"      
> # Expected order of ids
> vapply(unitizer:::as.list(items.sorted), function(x) x@id, integer(1L))
[1] 1 2 3 4 5 6 7 8
> lapply(unitizer:::as.list(items.sorted), function(x) x@ls$names)
[[1]]
character(0)

[[2]]
character(0)

[[3]]
character(0)

[[4]]
[1] "a" "b"

[[5]]
character(0)

[[6]]
[1] "a" "b" "e"

[[7]]
character(0)

[[8]]
[1] "a" "b" "e" "f"

> unique(unlist(lapply(unitizer:::as.list(items.sorted), function(x) x@ls$status)))
[1] ""
> # Tests with conditions
> 
> # - "Items with conditions" ----------------------------------------------------
> 
> my_fun <- function() {
+     warning("hello")
+     25
+ }
> ref.exps1a <- expression(stop("boom"), my_fun())
> my.unitizer1a <- new("unitizer", id = 100, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer1a <- my.unitizer1a + ref.exps1a)
> 
> all.equal(capture.output(show(my.unitizer1a@items.new[[1L]])), rds(200))
[1] TRUE
> all.equal(capture.output(show(my.unitizer1a@items.new[[2L]])), rds(300))
[1] TRUE
> all.equal(
+   capture.output(show(my.unitizer1a@items.new[[1L]]@data@conditions)), rds(400)
+ )
[1] TRUE
> # - "Environment healing works 2" ----------------------------------------------
> 
> # Stars highlight items we are selecting, but keep in mind that unitizer only
> # cares about non ignored tests, and that the selection status of ignored test
> # has nothing to do with what we end up with wrt to ignored tests
> 
> new.exps2 <- expression(
+   1 + 1,                   #  1 *
+   a <- 54,                 #  2
+   b <- runif(5),           #  3
+   howdy <- "yowser",       #  4 *
+   a + b,                   #  5 *
+   e <- 5 * a,              #  6
+   a ^ 2,                   #  7
+   f <- e * a,              #  8
+   matrix(rep(f, 20))       #  9 *
+ )
> ref.exps2 <- expression(
+   1 + 1,                   #  1
+   a <- 54,                 #  2
+   b <- runif(5),           #  3 *
+   25 + 3,                  #  4
+   q <- b ^ 2 / a,          #  5 *
+   a + b,                   #  6
+   z <- w <- list(1, 2, 3), #  7
+   Reduce(`+`, z),          #  8 * Doesn't exist, should connect back to `a + b`
+   e <- 5 * a,              #  9
+   e ^ 3,                   # 10 *
+   e * a                    # 11 *
+ )
> 
> # Note that healEnvs modifies objects that contain environments, and as such
> # you won't get the same result if you run this function twice, so don't be
> # surprised if tests fail in those circumstances
> my.unitizer3 <- new("unitizer", id = 1, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer3 <- my.unitizer3 + ref.exps2)
> my.unitizer4 <- new("unitizer", id = 2, zero.env = new.env())
> # now convert them to reference items
> coi(my.unitizer4 <- my.unitizer4 + my.unitizer3@items.new)
> # now test against new.exps
> coi(my.unitizer4 <- my.unitizer4 + new.exps2)
> coi(
+   items.mixed2 <- my.unitizer4@items.ref[c(8, 10, 3, 5, 11)] +
+     my.unitizer4@items.new[c(1, 4, 5, 9)]
+ )
> items.sorted2 <- unitizer:::healEnvs(items.mixed2, my.unitizer4)
> 
> env.anc <- lapply(unitizer:::as.list(items.sorted2), function(x) rev(unitizer:::env_ancestry(x@env,
+     my.unitizer4@base.env)))
> max.len <- max(vapply(env.anc, length, 1L))
> env.anc.2 <- lapply(env.anc, function(x) {
+     length(x) <- max.len
+     x
+ })
> # oldest ancestor the same
> env.anc.df <- as.data.frame(env.anc.2, stringsAsFactors = FALSE)
> length(unique(unname(unlist(env.anc.df[1, ]))))  # 1
[1] 1
> # "base.env should be unitizer env")
> identical(
+   env.anc.df[1, 1], unitizer:::env_name(my.unitizer4@base.env)
+ )
[1] TRUE
> # "all tests should also have another sub base.env")
> length(unique(unlist(env.anc.df[2, ]))) == 1L
[1] TRUE
> # "and it should be the items.ref here")
> identical(
+   env.anc.df[2, 1], unitizer:::env_name(my.unitizer4@items.ref@base.env)
+ )
[1] TRUE
> items <- items.sorted2
> items.lst <- unitizer:::as.list(items)
> # "new items should all have normal status",
> heal.info <- cbind(
+   type = unitizer:::itemsType(items), ignored = unitizer:::ignored(items),
+   id = vapply(items.lst, slot, 1L, "id"),
+   call = vapply(items.lst, callDep, ""),
+   ls = vapply(items.lst, lsObjs, ""),
+   ls.invalid = vapply(items.lst, lsInv, TRUE)
+ )
> # ""
> unique(unlist(lapply(items.lst[unitizer:::itemsType(items) == "new"], lsStat)))
[1] ""
> # "Reference tests should have no ls data",
> unique(vapply(items.lst[unitizer:::ignored(items)], lsObjs, ""))
[1] ""
> all(vapply(items.lst[unitizer:::ignored(items)], lsInv, logical(1L)))
[1] TRUE
> 
> # - "ls works" -----------------------------------------------------------------
> 
> my.unitizer5 <- new("unitizer", id = 2, zero.env = new.env())
> # now add back our composite elements as references
> coi(my.unitizer5 <- my.unitizer5 + items.sorted2)
> # and new items
> coi(my.unitizer5 <- my.unitizer5 + new.exps2)
> 
> # This is an ignored test, so there will be some problems
> env.val <- new.env(parent = my.unitizer5@items.new[[3]]@env)
> env.eval <- new.env(parent = env.val)
> assign(".NEW", my.unitizer5@items.new[[3]], env.val)
> assign(".new", my.unitizer5@items.new[[3]]@data@value[[1L]],
+     env.val)
> assign(".REF", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[3]]]],
+     env.val)
> assign(".ref", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[3]]]]@data@value[[1L]],
+     env.val)
> ls.res <- evalq(unitizer:::unitizer_ls(), env.eval)  # warn
Warning in unitizer:::unitizer_ls() :
  The ls output for `.ref` is invalid.  This may be because you had corrupted environment chains that had to be repaired. Re-generating the `unitizer` with `unitize(..., force.update=TRUE)` should fix the problem.  If it persists, please contact maintainer.
> # Reference tests won't show up since they were nuked by `healEnvs`
> all.equal(ls.res, rds(500))
[1] TRUE
> # These are normal tests so should work
> env.val <- new.env(parent = my.unitizer5@items.new[[9]]@env)
> env.eval <- new.env(parent = env.val)
> assign(".NEW", my.unitizer5@items.new[[9]], env.val)
> assign(".new", my.unitizer5@items.new[[9]]@data@value[[1L]],
+     env.val)
> assign(".REF", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[9]]]],
+     env.val)
> assign(".ref", my.unitizer5@items.ref[[my.unitizer5@items.new.map[[9]]]]@data@value[[1L]],
+     env.val)
> all.equal(evalq(unitizer:::unitizer_ls(), env.eval),
+     rds(600))
[1] TRUE
> all.equal(capture.output(print(evalq(unitizer:::unitizer_ls(),
+     env.eval))), rds(700))
[1] TRUE
> 
> # - "Environment Healing Works #3" ---------------------------------------------
> #
> # Main difference to previous versions is that we're testing that moving the
> # order of tests around between ref and new still works
> #
> # Test that reference tests moving around doesn't cause major issues
> 
> new.exps6 <- expression(
+   1 + 1,                #  1   *
+   a <- 54,              #  2
+   b <- runif(5),        #  3
+   howdy <- "yowser",    #  4
+   a + b,                #  5
+   e <- 5 * a,           #  6
+   a ^ 2,                #  7   *
+   f <- 25,              #  8   *
+   matrix(rep(f, 20))    #  9
+ )
> ref.exps6 <- expression(
+   1 + 1,                #  1
+   a <- 54,              #  2
+   f <- 25,              #  3
+   matrix(rep(f, 20)),   #  4   *
+   b <- runif(5),        #  5
+   boomboom <- "boo",    #  6
+   a + b,                #  7   *
+   a + b + f,            #  8
+   e <- 5 * a,           #  9
+   a ^ 2                 # 10
+ )
> my.unitizer10 <- new("unitizer", id = 1, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer10 <- my.unitizer10 + ref.exps6)
> my.unitizer11 <- new("unitizer", id = 2, zero.env = new.env())
> # now convert them to reference items
> coi(my.unitizer11 <- my.unitizer11 + my.unitizer10@items.new)
> # now test against new.exps
> coi(my.unitizer11 <- my.unitizer11 + new.exps6)
> items.mixed3 <- my.unitizer11@items.ref[c(4, 7)] +
+   my.unitizer11@items.new[c(1, 7, 8)]
> items.sorted3 <- unitizer:::healEnvs(items.mixed3, my.unitizer11)
> 
> # Both reference tests get appended to item #1, which means among other things
> # that for the second refernce test, the `a` object is absent (but `b` is
> # present because it gets sucked in by virtue of being an ignored test just
> # ahead of it)
> items <- items.sorted3
> items.lst <- unitizer:::as.list(items)
> cbind(
+   type = unitizer:::itemsType(items), ignored = unitizer:::ignored(items),
+   id = vapply(items.lst, slot, 1L, "id"),
+   call = vapply(items.lst, callDep, ""),
+   ls = vapply(items.lst, lsObjs, ""),
+   ls.invalid = vapply(items.lst, lsInv, TRUE)
+ )
      type        ignored id  call                  ls                   
 [1,] "new"       "FALSE" "1" "1 + 1"               ""                   
 [2,] "reference" "TRUE"  "2" "a <- 54"             ""                   
 [3,] "reference" "TRUE"  "3" "f <- 25"             ""                   
 [4,] "reference" "FALSE" "4" "matrix(rep(f, 20))"  "a, f"               
 [5,] "reference" "TRUE"  "5" "b <- runif(5)"       ""                   
 [6,] "reference" "TRUE"  "6" "boomboom <- \"boo\"" ""                   
 [7,] "reference" "FALSE" "7" "a + b"               "a*, b, boomboom, f*"
 [8,] "new"       "TRUE"  "6" "e <- 5 * a"          ""                   
 [9,] "new"       "FALSE" "7" "a^2"                 "a, b, e, howdy"     
      ls.invalid
 [1,] "FALSE"   
 [2,] "TRUE"    
 [3,] "TRUE"    
 [4,] "FALSE"   
 [5,] "TRUE"    
 [6,] "TRUE"    
 [7,] "FALSE"   
 [8,] "TRUE"    
 [9,] "FALSE"   
> # - "No circular environment references" ---------------------------------------
> 
> # This is to test for issue #2, which resulted in a self referential environment
> # in the stored items.  The following code used to fail:
> new.exps3 <- expression(1 + 1, a <- 54, b <- 5, 2 + 2, runif(1))
> ref.exps3 <- expression(1 + 1, a <- 54, 2 + 2, runif(1))
> my.unitizer6 <- new("unitizer", id = 1, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer6 <- my.unitizer6 + ref.exps3)
> my.unitizer7 <- new("unitizer", id = 2, zero.env = new.env())
> # now convert them to reference items
> coi(my.unitizer7 <- my.unitizer7 + my.unitizer6@items.new)
> # now test against new.exps
> coi(my.unitizer7 <- my.unitizer7 + new.exps3)
> # Note this doesn't test that there are no circular references, only that what
> # used to fail no longer fails.
> 
> cbind(my.unitizer7@tests.new, my.unitizer7@tests.result)
           value conditions output message aborted
[1,] FALSE  TRUE       TRUE   TRUE    TRUE    TRUE
[2,] FALSE  TRUE       TRUE   TRUE    TRUE    TRUE
[3,]  TRUE FALSE      FALSE  FALSE   FALSE   FALSE
[4,] FALSE  TRUE       TRUE   TRUE    TRUE    TRUE
[5,] FALSE FALSE       TRUE   TRUE    TRUE    TRUE
> 
> # - "testFuns" -----------------------------------------------------------------
> 
> # Error objects
> 
> # these two should just work fine
> is(new("testFuns", output = all.equal, value = function(x, y) TRUE), "testFuns")
[1] TRUE
> is(new("testFuns"), "testFuns")
[1] TRUE
> try(new("testFuns", output = all.equal, value = function(x, y, z) TRUE))
Error in validObject(.Object) : 
  invalid class "unitizerItemTestFun" object: Slot `@fun` must be a function with the first two parameters non-optional and all others optional (cannot have any non-optional arguments other than first two).
> # this should work too now, since technically has two args
> is(
+   new("testFuns", output = all.equal, value = function(x, y = 1, z = 1) TRUE),
+   "testFuns"
+ )
[1] TRUE
> try(new("testFuns", cabbage = all.equal))
Error in initialize(value, ...) : 
  Can't initialize invalid slots "cabbage"
> 
> # - "Misc" ---------------------------------------------------------------------
> 
> new.exps4 <- expression(a <- function() b(), b <- function() TRUE, a())
> my.unitizer8 <- new("unitizer", id = 3, zero.env = new.env())
> new.exps5 <- expression(a <- function() b(), NULL, b <- function() TRUE, a())
> my.unitizer9 <- new("unitizer", id = 4, zero.env = new.env())
> coi(x <- my.unitizer9 + new.exps5)
> 
> local({
+   fun <- function() quote(stop("This error should not be thrown"))
+   is(
+     new(
+       "unitizerItem", value = fun(), call = quote(fun()),
+       env = sys.frame(sys.parent() + 1L)
+     ),
+     "unitizerItem"
+   )
+ })
[1] TRUE
> # Nested environment hand waving can break down under certain circumstances
> # this first one should work because there are no tests until after all
> # the pieces necessary to run `a()` are defined:
> coi(res <- my.unitizer8 + new.exps4)
> is(res, "unitizer")
[1] TRUE
> # this should break because the NULL forces `b` to be stored in a different
> # environment to `a`; note: funky error message matching because in
> # at least some versions of rdevel reported fun name seems to change
> # (possibly related to level 3 bytecode)
> # could not find fun
> x@items.new[[4]]@data@message[[1]]
[1] "Error in b() : could not find function \"b\"\n"
> 
> # - "Comparison Function Errors" -----------------------------------------------
> 
> exps <- expression(fun <- function(x, y) warning("not gonna work"),
+     unitizer_sect(compare = fun, expr = {
+         1 + 1
+     }))
> my.unitizer <- new("unitizer", id = 25, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer <- my.unitizer + exps)
> coi(my.unitizer2 <- new("unitizer", id = 26, zero.env = new.env()) +
+     my.unitizer@items.new)
> # warn: not gonna work
> coi(my.unitizer2 <- my.unitizer2 + exps)
Warning in close_and_clear(e1@global$cons) :
  Test comparison functions appear to have produced output, which should not happen (see `?unitizer_sect` for more details).  If you did not provide custom testing functions, contact maintainer.  First 50 lines follow:
Warning in fun(2, 2) : not gonna work

> as.character(my.unitizer2@tests.status)
[1] "Pass"  "Error"
> my.unitizer2@tests.errorDetails[[2]]@value@value
[1] "comparison function `fun` signaled a condition of class `c(\"simpleWarning\", \"warning\", \"condition\")`, with message \"not gonna work\" and call `fun(2, 2)`."
> 
> # - "Language Objects Tested Properly" -----------------------------------------
> 
> exps <- expression(quote(x), quote(x + y), quote(identity(x)),
+     expression(1 + y), quote(expression(1 + y)))
> my.unitizer <- new("unitizer", id = 27, zero.env = new.env())
> # add ref.exps as new items
> coi(my.unitizer <- my.unitizer + exps)
> coi(my.unitizer2 <- new("unitizer", id = 28, zero.env = new.env()) +
+     my.unitizer@items.new)
> coi(my.unitizer2 <- my.unitizer2 + exps)
> # This used to error b/c expressions returning unevaluated calls/symbols were
> # not compared as such (they were evaluated)
> as.character(my.unitizer2@tests.status)
[1] "Pass" "Pass" "Pass" "Pass" "Pass"
> 
> # - "Test Fun Captured Properly" -----------------------------------------------
> 
> new("unitizerItemTestFun", fun = identical)@fun.name
[1] "identical"
> 
> 
> proc.time()
   user  system elapsed 
   1.00    0.14    1.35