R Under development (unstable) (2024-03-06 r86056 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("incl/start.R")
> 
> message("*** utils ...")
*** utils ...
> 
> message("- envname() ...")
- envname() ...
> 
> name <- envname(NULL)
> print(name)
[1] NA
> stopifnot(is.character(name), length(name) == 1L, is.na(name))
> 
> env <- new.env()
> print(env)
<environment: 0x0000015e65884928>
> name <- utils::capture.output(print(env))
> stopifnot(is.character(name), length(name) == 1L)
> name <- envname(env)
> print(name)
[1] "0x0000015e65884928"
> stopifnot(is.character(name), length(name) == 1L, !is.na(name),
+           class(env) == "environment")
> 
> env <- structure(new.env(), class = "foo")
> print.foo <- function(x, ...) { str(as.list(letters[1:3])); invisible(x) }
> print(env)
List of 3
 $ : chr "a"
 $ : chr "b"
 $ : chr "c"
> name <- utils::capture.output(print(env))
> stopifnot(is.character(name), length(name) > 1L)
> name <- envname(env)
> print(name)
[1] "0x0000015e658bb990"
> stopifnot(is.character(name), length(name) == 1L, !is.na(name),
+           class(env) == "foo")
> 
> env <- structure(new.env(), handlers = "foo")
> print(env)
<environment: 0x0000015e6617d3e8>
attr(,"handlers")
[1] "foo"
> name <- utils::capture.output(print(env))
> stopifnot(is.character(name), length(name) > 1L)
> name <- envname(env)
> print(name)
[1] "0x0000015e6617d3e8"
> stopifnot(is.character(name), length(name) == 1L, !is.na(name))
> 
> message("- envname() ... DONE")
- envname() ... DONE
> 
> 
> message("* hpaste() ...")
* hpaste() ...
> 
> printf <- function(...) cat(sprintf(...))
> hpaste <- globals:::hpaste
> 
> # Some vectors
> x <- 1:6
> y <- 10:1
> z <- LETTERS[x]
> 
> # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
> # Abbreviation of output vector
> # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
> printf("x = %s.\n", hpaste(x))
x = 1, 2, 3, ..., 6.
> ## x = 1, 2, 3, ..., 6.
> 
> printf("x = %s.\n", hpaste(x, max_head = 2))
x = 1, 2, ..., 6.
> ## x = 1, 2, ..., 6.
> 
> printf("x = %s.\n", hpaste(x, max_head = 3)) # Default
x = 1, 2, 3, ..., 6.
> ## x = 1, 2, 3, ..., 6.
> 
> # It will never output 1, 2, 3, 4, ..., 6
> printf("x = %s.\n", hpaste(x, max_head = 4))
x = 1, 2, 3, 4, 5, 6.
> ## x = 1, 2, 3, 4, 5 and 6.
> 
> # Showing the tail
> printf("x = %s.\n", hpaste(x, max_head = 1, max_tail = 2))
x = 1, ..., 5, 6.
> ## x = 1, ..., 5, 6.
> 
> # Turning off abbreviation
> printf("y = %s.\n", hpaste(y, max_head = Inf))
y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1.
> ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
> 
> ## ...or simply
> printf("y = %s.\n", paste(y, collapse = ", "))
y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1.
> ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
> 
> # Change last separator
> printf("x = %s.\n", hpaste(x, last_collapse = " and "))
x = 1, 2, 3, 4, 5 and 6.
> ## x = 1, 2, 3, 4, 5 and 6.
> 
> # No collapse
> stopifnot(all(hpaste(x, collapse = NULL) == x))
> 
> # Empty input
> stopifnot(identical(hpaste(character(0)), character(0)))
> 
> message("* hpaste() ... DONE")
* hpaste() ... DONE
> 
> 
> message("* as_function() ...")
* as_function() ...
> fcn <- as_function({ 1 })
> print(fcn())
[1] 1
> stopifnot(fcn() == 1)
> 
> 
> message("* is_base_pkg() ...")
* is_base_pkg() ...
> base_pkgs <- c("base")
> for (pkg in base_pkgs) {
+   stopifnot(is_base_pkg(pkg))
+ }
> stopifnot(!is_base_pkg("globals"))
> 
> message("* isPackageNamespace() ... Bug #80")
* isPackageNamespace() ... Bug #80
> 
> `$.strict_env` <- function(x, name) get(name, envir = x, inherits = FALSE)
> env <- structure(new.env(), class = "strict_env")
> res <- globals:::isPackageNamespace(env)
> stopifnot(!res)
> 
> 
> message("* is.base() & is_internal() ...")
* is.base() & is_internal() ...
> stopifnot(is.base(base::library))
> stopifnot(!is.base(globals::globalsOf))
> stopifnot(!is.base(NULL))
> stopifnot(is_internal(print.default))
> stopifnot(!is_internal(globals::globalsOf))
> stopifnot(!is_internal(NULL))
> 
> 
> 
> 
> message("* where() ...")
* where() ...
> 
> env <- where("sample", where = 1L)
> str(env)
<environment: base> 
> 
> env <- where("sample", frame = 1L)
> str(env)
<environment: namespace:base> 
> 
> message("- where('sample') ...")
- where('sample') ...
> env <- where("sample", mode = "function")
> print(env)
<environment: base>
> if (!"covr" %in% loadedNamespaces()) {
+   stopifnot(identical(env, baseenv()))
+ }
> obj <- get("sample", mode = "function", envir = env, inherits = FALSE)
> stopifnot(identical(obj, base::sample))
> 
> 
> message("- where('sample', mode = 'integer') ...")
- where('sample', mode = 'integer') ...
> env <- where("sample", mode = "integer")
> print(env)
NULL
> stopifnot(is.null(env))
> 
> 
> message("- where('sample2') ...")
- where('sample2') ...
> sample2 <- base::sample
> env <- where("sample2", mode = "function")
> print(env)
<environment: R_GlobalEnv>
> stopifnot(identical(env, environment()))
> obj <- get("sample2", mode = "function", envir = env, inherits = FALSE)
> stopifnot(identical(obj, sample2))
> 
> 
> message("- where() - objects inside functions ...")
- where() - objects inside functions ...
> aa <- 1
> 
> foo <- function() {
+   bb <- 2 #nolint
+   list(aa = where("aa"), bb = where("bb"), cc = where("cc"),
+        envir = environment())
+ }
> 
> envs <- foo()
> str(envs)
List of 4
 $ aa   :<environment: R_GlobalEnv> 
 $ bb   :<environment: 0x0000015e6351c3b0> 
 $ cc   : NULL
 $ envir:<environment: 0x0000015e6351c3b0> 
> stopifnot(identical(envs$aa, globalenv()))
> stopifnot(identical(envs$bb, envs$envir))
> stopifnot(is.null(envs$cc))
> 
> message("- where() - missing ...")
- where() - missing ...
> env <- where("non-existing-object", inherits = FALSE)
> stopifnot(is.null(env))
> 
> rm(list = c("aa", "envs", "foo", "env", "obj", "where"))
> 
> message("* where() ... DONE")
* where() ... DONE
> 
> message("- mdebug() ...")
- mdebug() ...
> 
> mdebug("Message A")
> oopts <- options(globals.debug = TRUE)
> mdebug("Message B")
Message B
> options(oopts)
> 
> message("* mdebug() ... DONE")
* mdebug() ... DONE
> 
> message("*** utils ... DONE")
*** utils ... DONE
> 
> source("incl/end.R")
> 
> proc.time()
   user  system elapsed 
   0.20    0.07    0.21