listenv/0000755000176200001440000000000013572274462011752 5ustar liggesuserslistenv/NAMESPACE0000644000176200001440000000172013572256770013173 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",listenv) S3method("$<-",listenv) S3method("[",listenv) S3method("[<-",listenv) S3method("[[",listenv) S3method("[[<-",listenv) S3method("dim<-",listenv) S3method("dimnames<-",listenv) S3method("length<-",listenv) S3method("names<-",listenv) S3method(all.equal,listenv) S3method(as.list,listenv) S3method(as.listenv,default) S3method(as.listenv,environment) S3method(as.listenv,list) S3method(as.listenv,listenv) S3method(as.matrix,listenv) S3method(as.vector,listenv) S3method(dim,listenv) S3method(dimnames,listenv) S3method(get_variable,listenv) S3method(is.array,listenv) S3method(is.matrix,listenv) S3method(length,listenv) S3method(lengths,listenv) S3method(names,listenv) S3method(print,listenv) S3method(undim,default) S3method(undim,listenv) S3method(unlist,listenv) export("dim_na<-") export(as.listenv) export(get_variable) export(listenv) export(map) export(mapping) export(parse_env_subset) export(undim) listenv/man/0000755000176200001440000000000013572226030012511 5ustar liggesuserslistenv/man/listenv.Rd0000644000176200001440000000105313572226030014463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{listenv} \alias{listenv} \alias{as.listenv} \title{Create a list environment} \usage{ listenv(...) as.listenv(...) } \arguments{ \item{\dots}{(optional) Named and/or unnamed objects to be assigned to the list environment.} } \value{ An environment of class \code{listenv}. } \description{ Create a list environment } \examples{ x <- listenv(c = 2, a = 3, d = "hello") print(names(x)) names(x)[2] <- "A" x$b <- 5:8 y <- as.list(x) str(y) z <- as.listenv(y) } listenv/man/as.list.listenv.Rd0000644000176200001440000000117113322430416016036 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{as.list.listenv} \alias{as.list.listenv} \title{List representation of a list environment} \usage{ \method{as.list}{listenv}(x, all.names = TRUE, sorted = FALSE, ...) } \arguments{ \item{x}{A list environment.} \item{all.names}{If \code{TRUE}, variable names starting with a period are included, otherwise not.} \item{sorted}{If \code{TRUE}, elements are ordered by their names before being compared, otherwise not.} \item{...}{Not used.} } \value{ A list. } \description{ List representation of a list environment } \keyword{internal} listenv/man/names.listenv.Rd0000644000176200001440000000054313322430416015566 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{names.listenv} \alias{names.listenv} \alias{names<-.listenv} \title{Names of elements in list environment} \usage{ \method{names}{listenv}(x) } \arguments{ \item{x}{A list environment.} } \description{ Names of elements in list environment } \keyword{internal} listenv/man/undim.Rd0000644000176200001440000000125613572226030014120 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/undim.R \name{undim} \alias{undim} \alias{undim.default} \alias{undim.listenv} \title{Removes the dimension of an object} \usage{ undim(x, ...) } \arguments{ \item{x}{An object with or without dimensions} \item{...}{Not used.} } \value{ The object with the dimension attribute removed. } \description{ Removes the dimension of an object } \details{ This function does \code{attr(x, "dim") <- NULL}, which automatically also does \code{attr(x, "dimnames") <- NULL}. However, other attributes such as names attributes are preserved, which is not the case if one do \code{dim(x) <- NULL}. } \keyword{internal} listenv/man/mapping.Rd0000644000176200001440000000121313572226030014430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{mapping} \alias{mapping} \alias{mapping.listenv} \alias{map.listenv} \alias{map} \title{Variable name map for elements of list environment} \usage{ mapping(x, ...) map(x, ...) } \arguments{ \item{x}{A list environment.} } \value{ A named character vector } \description{ Variable name map for elements of list environment } \details{ \emph{Functions \code{map()} and \verb{map<-()} have been renamed to \code{mapping()} and \verb{mapping<-()}. The former will soon become deprecated and eventually defunct. Please update accordingly.} } \keyword{internal} listenv/man/parse_env_subset.Rd0000644000176200001440000000210513322430416016343 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parse_env_subset.R \name{parse_env_subset} \alias{parse_env_subset} \title{Helper function to infer target from expression and environment} \usage{ parse_env_subset(expr, envir = parent.frame(), substitute = TRUE) } \arguments{ \item{expr}{An expression.} \item{envir}{An environment.} \item{substitute}{If \code{TRUE}, then the expression is \code{\link[base:substitute]{base::substitute()}}:ed, otherwise not.} } \value{ A named list with elements: \describe{ \item{\code{envir}}{An environment (defaults to argument \code{envir})} \item{\code{name}}{A character vector. ...} \item{\code{op}}{...} \item{\code{subset}}{A list of \code{NULL}. ...} \item{\code{idx}}{An integer vector or \code{NULL}. ...} \item{\code{exists}}{A logical vector of length \code{length(idx)} with \code{TRUE} and \code{FALSE} values.} \item{\code{code}}{The deparsed expression \code{expr} coerced to a single character string.} } } \description{ Helper function to infer target from expression and environment } \keyword{internal} listenv/man/get_variable.Rd0000644000176200001440000000123713322430416015425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_variable.R \name{get_variable} \alias{get_variable} \alias{get_variable.listenv} \title{Get name of variable for a specific element of list environment} \usage{ get_variable(...) } \arguments{ \item{x}{A list environment.} \item{name}{The name or index of element of interest.} \item{mustExist}{If \code{TRUE}, an error is generated if \code{name} does not exist.} \item{create}{If \code{TRUE}, element \code{name} is created if missing.} } \value{ The name of the underlying variable } \description{ Get name of variable for a specific element of list environment } \keyword{internal} listenv/man/cash-.listenv.Rd0000644000176200001440000000075413572226030015464 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{$.listenv} \alias{$.listenv} \alias{[[.listenv} \alias{[.listenv} \title{Get elements of list environment} \usage{ \method{$}{listenv}(x, name) } \arguments{ \item{x}{A list environment.} \item{name}{The name or index of the element to retrieve.} } \value{ The value of an element or \code{NULL} if the element does not exist. } \description{ Get elements of list environment } \keyword{internal} listenv/man/dim_na.Rd0000644000176200001440000000133213322430416014224 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv,dims.R \name{dim_na} \alias{dim_na} \alias{dim_na<-} \title{Set the dimension of an object} \usage{ dim_na(x) <- value } \arguments{ \item{x}{An \R object, e.g. a list environment, a matrix, an array, or a data frame.} \item{value}{A numeric vector coerced to integers. If one of the elements is missing, then its value is inferred from the other elements (which must be non-missing) and the length of \code{x}.} } \value{ An object with the dimensions set, similar to what \code{\link[base:dim]{dim(x) <- value}} returns. } \description{ Set the dimension of an object } \examples{ x <- 1:6 dim_na(x) <- c(2, NA) print(dim(x)) ## [1] 2 3 } listenv/man/length.listenv.Rd0000644000176200001440000000055013322430416015742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{length.listenv} \alias{length.listenv} \alias{lengths.listenv} \title{Number of elements in list environment} \usage{ \method{length}{listenv}(x) } \arguments{ \item{x}{A list environment.} } \description{ Number of elements in list environment } \keyword{internal} listenv/man/cash-set-.listenv.Rd0000644000176200001440000000071613572226030016253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listenv.R \name{$<-.listenv} \alias{$<-.listenv} \alias{[[<-.listenv} \alias{[<-.listenv} \title{Set an element of list environment} \usage{ \method{$}{listenv}(x, name) <- value } \arguments{ \item{x}{A list environment.} \item{name}{Name or index of element} \item{value}{The value to assign to the element} } \description{ Set an element of list environment } \keyword{internal} listenv/DESCRIPTION0000644000176200001440000000172413572274462013464 0ustar liggesusersPackage: listenv Version: 0.8.0 Depends: R (>= 3.1.2) Suggests: R.utils, R.rsp, markdown VignetteBuilder: R.rsp Title: Environments Behaving (Almost) as Lists Authors@R: c(person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"), email = "henrikb@braju.com")) Description: List environments are environments that have list-like properties. For instance, the elements of a list environment are ordered and can be accessed and iterated over using index subsetting, e.g. 'x <- listenv(a = 1, b = 2); for (i in seq_along(x)) x[[i]] <- x[[i]] ^ 2; y <- as.list(x)'. License: LGPL (>= 2.1) LazyLoad: TRUE URL: https://github.com/HenrikBengtsson/listenv BugReports: https://github.com/HenrikBengtsson/listenv/issues RoxygenNote: 7.0.2 NeedsCompilation: no Packaged: 2019-12-05 19:44:24 UTC; hb Author: Henrik Bengtsson [aut, cre, cph] Maintainer: Henrik Bengtsson Repository: CRAN Date/Publication: 2019-12-05 21:40:02 UTC listenv/build/0000755000176200001440000000000013572257030013041 5ustar liggesuserslistenv/build/vignette.rds0000644000176200001440000000034613572257030015403 0ustar liggesusersePK0-Oh'FƸp@F(4w\ 5R'igޛ%Dr dZ"0.@6 ]uqǼm4tstc5FXJ ݣ?Alw^KHCX./-ߞ(IqqA&hƶƠu\q܉cT3_:&8j^Z})3J s,p|/~ listenv/tests/0000755000176200001440000000000013572226030013100 5ustar liggesuserslistenv/tests/get_variable.R0000644000176200001440000000456613322430416015660 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) oopts <- options(warn = 1) map <- listenv:::map x <- listenv() length(x) <- 3L names(x) <- c("a", "b", "c") stopifnot(length(x) == 3L) print(mapping(x)) var <- get_variable(x, "a") stopifnot(!is.na(var)) stopifnot(length(x) == 3L) print(mapping(x)) var <- get_variable(x, "b") stopifnot(!is.na(var)) stopifnot(length(x) == 3L) print(mapping(x)) var <- get_variable(x, "c") stopifnot(!is.na(var)) stopifnot(length(x) == 3L) print(mapping(x)) var <- get_variable(x, "d") stopifnot(!is.na(var)) stopifnot(length(x) == 4L) print(mapping(x)) var <- get_variable(x, 4L) stopifnot(!is.na(var)) stopifnot(length(x) == 4L) print(mapping(x)) x$b <- 2 var <- get_variable(x, "b") stopifnot(!is.na(var)) stopifnot(length(x) == 4L) print(mapping(x)) var <- get_variable(x, length(x) + 1L) stopifnot(length(x) == 5L) print(names(x)) print(mapping(x)) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Allocation ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() length(x) <- 3L print(x[[1]]) print(x[[2]]) print(x[[3]]) ## Out-of-bound subsetting res <- try(x[[0]], silent = TRUE) stopifnot(inherits(res, "try-error")) ## Out-of-bound subsetting res <- try(x[[4]], silent = TRUE) stopifnot(inherits(res, "try-error")) print(get_variable(x, 1L, mustExist = FALSE)) print(get_variable(x, 2L, mustExist = FALSE)) print(get_variable(x, 3L, mustExist = FALSE)) ## Out-of-bound element res <- try(var <- get_variable(x, 0L, mustExist = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) ## Out-of-bound element res <- try(var <- get_variable(x, length(x) + 1L, mustExist = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Exception handling ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() length(x) <- 3L names(x) <- c("a", "b", "c") ## Non-existing element res <- try(var <- get_variable(x, "z", mustExist = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(var <- get_variable(x, c("a", "b")), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(var <- get_variable(x, 1 + 2i), silent = TRUE) stopifnot(inherits(res, "try-error")) ## Cleanup options(oopts) rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/tests/utils.R0000644000176200001440000000225313322430416014363 0ustar liggesusersprintf <- function(...) cat(sprintf(...)) hpaste <- listenv:::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. printf("x = %s.\n", hpaste(x, max_head = 2)) ## x = 1, 2, ..., 6. printf("x = %s.\n", hpaste(x), max_head = 3) # Default ## 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 and 6. # Showing the tail printf("x = %s.\n", hpaste(x, max_head = 1, max_tail = 2)) ## 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 ## ...or simply printf("y = %s.\n", paste(y, collapse = ", ")) ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Adding a special separator before the last element # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Change last separator printf("x = %s.\n", hpaste(x, last_collapse = " and ")) ## x = 1, 2, 3, 4, 5 and 6. listenv/tests/parse_env_subset.R0000644000176200001440000002213713572226030016577 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) if (exists("x")) rm(list = "x") if (exists("y")) rm(list = "y") ## - - - - - - - - - - - - - - - - - - - - - - - - - - ## Variable in global/parent environment ## - - - - - - - - - - - - - - - - - - - - - - - - - - message("*** parse_env_subset() on parent environment ...") target <- parse_env_subset(x, substitute = TRUE) str(target) stopifnot(identical(target$envir, environment()), target$name == "x", is.na(target$idx), !target$exists) target <- parse_env_subset("x", substitute = TRUE) str(target) stopifnot(identical(target$envir, environment()), target$name == "x", is.na(target$idx), !target$exists) x <- NULL target <- parse_env_subset(x, substitute = TRUE) str(target) stopifnot(identical(target$envir, environment()), target$name == "x", is.na(target$idx), target$exists) target <- parse_env_subset(y, substitute = TRUE) str(target) stopifnot(identical(target$envir, environment()), target$name == "y", is.na(target$idx), !target$exists) message("*** parse_env_subset() on parent environment ... DONE") ## - - - - - - - - - - - - - - - - - - - - - - - - - - ## Environment ## - - - - - - - - - - - - - - - - - - - - - - - - - - message("parse_env_subset() on environment ...") x <- new.env() target <- parse_env_subset(x, substitute = TRUE) str(target) stopifnot(identical(target$envir, environment()), target$name == "x", is.na(target$idx), target$exists) target <- parse_env_subset(x$a, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) target <- parse_env_subset("a", envir = x, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) target <- parse_env_subset(x[["a"]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) target <- parse_env_subset("a", envir = x, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) res <- try(target <- parse_env_subset(1, substitute = FALSE), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(target <- parse_env_subset(x[[1]], substitute = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) x$a <- 1 target <- parse_env_subset(x$a, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), target$exists) message("parse_env_subset() on environment ... DONE") ## - - - - - - - - - - - - - - - - - - - - - - - - - - ## List environment ## - - - - - - - - - - - - - - - - - - - - - - - - - - message("*** parse_env_subset() on listenv ...") x <- listenv() target <- parse_env_subset(x, substitute = TRUE) str(target) stopifnot(identical(target$envir, environment()), target$name == "x", is.na(target$idx), target$exists) target <- parse_env_subset(x$a, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) target <- parse_env_subset(x[["a"]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) target <- parse_env_subset("a", envir = x, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", is.na(target$idx), !target$exists) target <- parse_env_subset(x[[1]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "", target$idx == 1, !target$exists) target <- parse_env_subset(x[[2]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "", target$idx == 2, !target$exists) target <- parse_env_subset(x[], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "", length(target$idx) == 0L, is.numeric(target$idx), length(target$exists) == 0L, is.logical(target$exists)) x$a <- 1 target <- parse_env_subset(x$a, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", target$idx == 1, target$exists) target <- parse_env_subset("a", envir = x, substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", target$idx == 1, target$exists) stopifnot(x$a == 1) stopifnot(x[[1]] == 1) target <- parse_env_subset(x[[c("a", "a")]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), length(target$name) == 2L, all(target$name == "a"), length(target$idx) == 2L, all(target$idx == 1), length(target$exists) == 2L, all(target$exists)) target <- parse_env_subset(x[[1]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", target$idx == 1, target$exists) target <- parse_env_subset(x[], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "", length(target$idx) == 1L, target$idx == 1, length(target$exists) == 1L, target$exists) x[[3]] <- 3 target <- parse_env_subset(x[[3]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "", target$idx == 3, target$exists) stopifnot(x[[3]] == 3) print(names(x)) stopifnot(identical(names(x), c("a", "", ""))) target <- parse_env_subset(x[], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "", length(target$idx) == 3L, all(target$idx == 1:3), length(target$exists) == 3L, all(target$exists == c(TRUE, FALSE, TRUE))) b <- 1 target <- parse_env_subset(x[[b]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$name == "a", target$idx == 1, target$exists) x <- listenv() length(x) <- 2 target <- parse_env_subset(x[[1]], substitute = TRUE) str(target) stopifnot(!target$exists) target <- parse_env_subset(x[[2]], substitute = TRUE) str(target) stopifnot(!target$exists) target <- parse_env_subset(x[[3]], substitute = TRUE) str(target) stopifnot(!target$exists) stopifnot(length(x) == 2) x[[2]] <- 2 target <- parse_env_subset(x[[2]], substitute = TRUE) str(target) stopifnot(target$exists) x[[4]] <- 4 stopifnot(length(x) == 4) target <- parse_env_subset(x[[3]], substitute = TRUE) str(target) stopifnot(!target$exists) target <- parse_env_subset(x[1:5], substitute = TRUE) stopifnot(length(target$idx) == 5, all(target$idx == 1:5)) str(target) target <- parse_env_subset(x[integer(0L)], substitute = TRUE) stopifnot(length(target$idx) == 0) str(target) target <- parse_env_subset(x[[integer(0L)]], substitute = TRUE) stopifnot(length(target$idx) == 0) str(target) target <- parse_env_subset(x[0], substitute = TRUE) stopifnot(length(target$idx) == 0) str(target) target <- parse_env_subset(x[-1], substitute = TRUE) stopifnot(length(target$idx) == length(x) - 1) str(target) ## Odds and ends #target <- parse_env_subset(x[[""]], substitute = TRUE) #str(target) #stopifnot(length(target$idx) == 1L, !target$exists) message("*** parse_env_subset() on listenv ... DONE") ## - - - - - - - - - - - - - - - - - - - - - - - - - - ## Exception handling ## - - - - - - - - - - - - - - - - - - - - - - - - - - message("*** parse_env_subset() - exceptions ...") x <- new.env() x$a <- 1 res <- tryCatch({ parse_env_subset(x[], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[[]], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[""], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[[""]], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[[1]], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[[TRUE]], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[[c("a", "a")]], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) x <- listenv() res <- tryCatch({ parse_env_subset(x[""], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- tryCatch({ parse_env_subset(x[[""]], substitute = TRUE) }, error = identity) stopifnot(inherits(res, "error")) res <- try(target <- parse_env_subset(x[[0]], substitute = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(target <- parse_env_subset("_a", substitute = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(target <- parse_env_subset(1:10, envir = x, substitute = FALSE), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try( target <- parse_env_subset(c("a", "b"), envir = x, substitute = FALSE), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(target <- parse_env_subset(x@a, substitute = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) message("*** parse_env_subset() - exceptions ... DONE") ## Cleanup rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/tests/parse_env_subset,dimensions.R0000644000176200001440000001117213572226030020741 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) if (exists("x")) rm(list = "x") if (exists("y")) rm(list = "y") ## - - - - - - - - - - - - - - - - - - - - - - - - - - ## Multi-dimensional subsetting ## - - - - - - - - - - - - - - - - - - - - - - - - - - message("*** parse_env_subset() on multi-dim listenv ...") x <- listenv() length(x) <- 6 dim(x) <- c(2, 3) target <- parse_env_subset(x[2], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 2, !target$exists) target <- parse_env_subset(x[[2]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 2, !target$exists) target <- parse_env_subset(x[1, 2], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, !target$exists) target <- parse_env_subset(x[[1, 2]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, !target$exists) x[[1, 2]] <- 1.2 target <- parse_env_subset(x[1, 2], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, target$exists) target <- parse_env_subset(x[[1, 2]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, target$exists) target <- parse_env_subset(x[1, 4], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), is.na(target$idx), !target$exists) target <- parse_env_subset(x[[1, 4]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), is.na(target$idx), !target$exists) target <- parse_env_subset(x[1, 1:2], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), length(target$idx) == 2L, all(target$idx == c(1,3)), length(target$exists) == 2L, all(target$exists == c(FALSE, TRUE))) target <- parse_env_subset(x[1, -3], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), length(target$idx) == 2L, all(target$idx == c(1,3)), length(target$exists) == 2L, all(target$exists == c(FALSE, TRUE))) ## Assert that x[[1, 4]] is not the same as x[[c(1, 4)]] target <- parse_env_subset(x[[1, 4]], substitute = TRUE) str(target) target2 <- parse_env_subset(x[[c(1, 4)]], substitute = TRUE) str(target2) target$code <- target2$code <- NULL stopifnot(!isTRUE(all.equal(target2, target))) dimnames(x) <- list(c("a", "b"), c("A", "B", "C")) print(x) target <- parse_env_subset(x[["a", 2]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, target$exists) target <- parse_env_subset(x[["a", "B"]], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, target$exists) target <- parse_env_subset(x["a", "B"], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), target$idx == 3, target$exists) target <- parse_env_subset(x["a", 1:3], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), length(target$idx) == 3, all(target$idx == c(1, 3, 5)), all(target$exists == c(FALSE, TRUE, FALSE))) target <- parse_env_subset(x["a", ], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), length(target$idx) == 3, all(target$idx == c(1, 3, 5)), all(target$exists == c(FALSE, TRUE, FALSE))) target <- parse_env_subset(x["a", -1], substitute = TRUE) str(target) stopifnot(identical(target$envir, x), length(target$idx) == 2, all(target$idx == c(3, 5)), all(target$exists == c(TRUE, FALSE))) message("*** parse_env_subset() on multi-dim listenv ... DONE") ## - - - - - - - - - - - - - - - - - - - - - - - - - - ## Exception handling ## - - - - - - - - - - - - - - - - - - - - - - - - - - message("*** parse_env_subset() on multi-dim listenv - exceptions ...") x <- listenv() ## Multidimensional subsetting on 'x' without dimensions res <- try(target <- parse_env_subset(x[[1, 2]], substitute = TRUE), silent = TRUE) stopifnot(inherits(res, "try-error")) ## Multi-dimensional subsetting x <- listenv() length(x) <- 6 dim(x) <- c(2, 3) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - ## FIXME: Should zero indices give parse errors or not? ## - - - - - - - - - - - - - - - - - - - - - - - - - - - res <- try(target <- parse_env_subset(x[[0]], substitute = TRUE), silent = TRUE) ## stopifnot(inherits(res, "try-error")) res <- try(target <- parse_env_subset(x[[1, 0]], substitute = TRUE), silent = TRUE) ## stopifnot(inherits(res, "try-error")) res <- try(target <- parse_env_subset(x[[1, 2, 3]], substitute = TRUE), silent = TRUE) ## stopifnot(inherits(res, "try-error")) message("*** parse_env_subset() on multi-dim listenv - exceptions ... DONE") ## Cleanup rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/tests/get_variable,dimensions.R0000644000176200001440000000164613322430416020021 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) oopts <- options(warn = 1) map <- listenv:::map message("* get_variable() - multi-dimensional list environments ...") x <- listenv() length(x) <- 6 dim(x) <- c(2, 3) for (ii in seq_along(x)) { stopifnot(is.null(x[[ii]])) idx <- arrayInd(ii, .dim = dim(x)) stopifnot(is.null(x[[idx[1], idx[2]]])) var_v <- get_variable(x, ii, create = FALSE) var_a <- get_variable(x, idx, create = FALSE) stopifnot(identical(var_a, var_v)) } x[1:6] <- 1:6 for (ii in seq_along(x)) { stopifnot(identical(x[[ii]], ii)) idx <- arrayInd(ii, .dim = dim(x)) stopifnot(identical(x[[idx[1], idx[2]]], ii)) var_v <- get_variable(x, ii) var_a <- get_variable(x, idx) stopifnot(identical(var_a, var_v)) } message("* get_variable() - multi-dimensional list environments ... DONE") ## Cleanup options(oopts) rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/tests/lapply.R0000644000176200001440000000137113572226030014526 0ustar liggesuserslibrary("listenv") message("*** lapply() ...") x <- as.list(1:6) names(x) <- letters[seq_along(x)] y <- as.listenv(x) z0 <- lapply(x, FUN = function(x) x^2) z1 <- lapply(y, FUN = function(x) x^2) stopifnot(identical(z1, z0)) message("*** lapply() ... DONE") message("*** apply() ...") x <- matrix(as.list(1:6), nrow = 2) rownames(x) <- letters[seq_len(nrow(x))] colnames(x) <- LETTERS[seq_len(ncol(x))] y <- as.listenv(x) z0 <- apply(x, MARGIN = 1L, FUN = function(x) sum(unlist(x))) ## FIXME: Implement proper aperm() for listenv aperm.listenv <- function(a, ...) { a <- as.list(a) a <- aperm(a, ...) as.listenv(a) } z1 <- apply(y, MARGIN = 1L, FUN = function(x) sum(unlist(x))) stopifnot(identical(z1, z0)) message("*** apply() ... DONE") listenv/tests/as.listenv.R0000644000176200001440000000136013322430416015307 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) oopts <- options(warn = 1) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Single-element assignments and subsetting ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- list(a = 1, b = 2, c = 3) str(x) y <- as.listenv(x) print(y) stopifnot(identical(as.list(y), x)) z <- as.listenv(y) stopifnot(identical(as.list(y), as.list(z))) e <- new.env() e$a <- 1 e$b <- 2 e$c <- 3 y <- as.listenv(e) print(y) stopifnot(identical(as.list(y), as.list(e))) x <- c(a = 1, b = 2, c = 3) y <- as.listenv(x) print(y) stopifnot(identical(as.list(y), as.list(x))) ## Cleanup options(oopts) rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/tests/as.vector.R0000644000176200001440000000311413322430416015124 0ustar liggesuserslibrary("listenv") dims <- list(3, c(3, 1), c(2, 3), c(2, 3, 4)) for (dim in dims) { x <- as.list(1:prod(dim)) if (length(dim) > 1) { dim(x) <- dim dimnames(x) <- lapply(dim, FUN = function(n) letters[seq_len(n)]) } y <- as.listenv(x) ## NOTE: is.vector() will always be FALSE for list environments, because: ## "is.vector returns TRUE if x is a vector of the specified mode having ## no attributes other than names. It returns FALSE otherwise." ## Source: help("is.vector", package = "base") stopifnot(!is.vector(y)) stopifnot(is.matrix(x) == is.matrix(y)) stopifnot(is.array(x) == is.array(y)) for (mode in c("any", "list", "logical", "integer", "double", "complex", "character", "raw")) { message("mode: ", mode) ## as.vector(): y <- as.listenv(x) vx <- as.vector(x, mode = mode) print(vx) vy <- as.vector(y, mode = mode) stopifnot(identical(vy, vx)) stopifnot(is.matrix(vx) == is.matrix(vy)) stopifnot(is.array(vx) == is.array(vy)) ## as.matrix(): y <- as.listenv(x) mx <- as.matrix(x) print(mx) my <- as.matrix(y) stopifnot(identical(dim(my), dim(mx))) stopifnot(identical(dimnames(my), dimnames(mx))) stopifnot(is.matrix(mx) == is.matrix(my)) stopifnot(is.array(mx) == is.array(my)) ## as.array(): y <- as.listenv(x) ax <- as.array(x) print(ax) ay <- as.array(y) stopifnot(identical(dim(ay), dim(ax))) stopifnot(identical(dimnames(ay), dimnames(ax))) stopifnot(is.matrix(ax) == is.matrix(ay)) stopifnot(is.array(ax) == is.array(ay)) } } listenv/tests/listenv,dimensions.R0000644000176200001440000002142613322430416017057 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) oopts <- options(warn = 1) message("* List environment and multiple dimensions ...") x <- listenv() dim(x) <- c(0, 0) print(x) stopifnot(length(x) == 0) x <- listenv(a = 1) stopifnot(identical(names(x), "a")) dim(x) <- c(1, 1) print(x) stopifnot(length(x) == 1) stopifnot(is.null(dimnames(x))) stopifnot(is.null(names(x))) x0 <- as.list(1:6) x <- as.listenv(x0) print(x) stopifnot(is.null(dim(x))) stopifnot(is.null(dimnames(x))) y <- as.list(x) stopifnot(identical(y, x0)) z <- as.listenv(y) stopifnot(all.equal(z, x)) message("* dim(x) and dimnames(x) ...") dims <- list(2:3, 2:4) for (kk in seq_along(dims)) { dim <- dims[[kk]] dimnames <- lapply(dim, FUN = function(n) letters[seq_len(n)]) names <- letters[seq_len(prod(dim))] str(list(dim = dim, dimnames = dimnames, names = names)) n <- prod(dim) values <- seq_len(n) x0 <- as.list(values) x <- as.listenv(values) print(x) stopifnot(identical(dim(x), dim(x0))) y <- as.list(x) stopifnot(identical(y, x0)) z <- as.listenv(y) stopifnot(all.equal(z, x)) dim(x0) <- dim dim(x) <- dim print(x) stopifnot(identical(dim(x), dim(x0))) stopifnot(is.null(dimnames(x))) stopifnot(is.null(names(x))) names(x0) <- names names(x) <- names y <- as.list(x) stopifnot(identical(y, x0)) z <- as.listenv(y) stopifnot(all.equal(z, x)) ## Infer one of the dimensions if given as NA dim0 <- dim(x) for (dd in seq_along(dim0)) { dim_dd <- dim0 dim_dd[dd] <- NA_integer_ dim_na(x) <- dim_dd print(x) stopifnot(identical(dim(x), dim0)) } names(x) <- names excls <- c(list(NULL), as.list(seq_along(dimnames)), list(seq_along(dimnames))) for (ll in seq_along(excls)) { excl <- excls[[ll]] dimnames_tmp <- dimnames dimnames_tmp[excl] <- list(NULL) dimnames(x0) <- dimnames_tmp dimnames(x) <- dimnames_tmp print(x) stopifnot(identical(dim(x), dim(x0))) stopifnot(identical(dimnames(x), dimnames(x0))) stopifnot(identical(names(x), names)) y <- as.list(x) stopifnot(identical(y, x0)) z <- as.listenv(y) stopifnot(all.equal(z, x)) } ## for (ll ...) } ## for (kk ...) # Assign names x <- as.listenv(1:6) dim(x) <- c(2, 3) dimnames(x) <- lapply(dim(x), FUN = function(n) letters[seq_len(n)]) names(x) <- letters[seq_along(x)] print(x) stopifnot(!is.null(dim(x))) stopifnot(!is.null(dimnames(x))) stopifnot(!is.null(names(x))) stopifnot(x[["b"]] == 2L) stopifnot(x[["a", "b"]] == 3L) ## Extract single element message("* y <- x[[i,j]] and z <- x[i,j] ...") dim(x) <- c(2, 3) dimnames(x) <- list(c("a", "b"), NULL) y <- x[[3]] stopifnot(identical(y, 3L)) z <- x[3] stopifnot(identical(z[[1]], y)) y <- x[[1, 1]] stopifnot(identical(y, x[[1]])) z <- x[1, 1] stopifnot(identical(z[[1]], y)) y <- x[[2, 3]] stopifnot(identical(y, x[[6]])) z <- x[2, 3] stopifnot(identical(z[[1]], y)) y <- x[["a", 3]] stopifnot(identical(y, x[[1, 3]])) stopifnot(identical(y, x[[5]])) z <- x["a", 3] stopifnot(identical(z[[1]], y)) y <- x[[1, c(FALSE, FALSE, TRUE)]] stopifnot(identical(y, x[[1, 3]])) stopifnot(identical(y, x[[5]])) z <- x[1, c(FALSE, FALSE, TRUE)] stopifnot(identical(z[[1]], y)) message("* x[[i,j]] <- value ...") ## Assign single element x[[3]] <- -x[[3]] stopifnot(identical(x[[3]], -3L)) x[[1, 1]] <- -x[[1, 1]] stopifnot(identical(x[[1]], -1L)) x[[2, 3]] <- -x[[2, 3]] stopifnot(identical(x[[6]], -6L)) x[["a", 3]] <- -x[["a", 3]] stopifnot(identical(x[[1, 3]], -5L)) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Multi-element subsetting ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - message("* x[i], x[i,j] ...") x <- as.listenv(1:24) dim(x) <- c(2, 3, 4) names(x) <- letters[seq_along(x)] x[2] <- list(NULL) print(x) y <- x[] print(y) stopifnot(length(y) == length(x)) stopifnot(all.equal(y, x)) stopifnot(!identical(y, x)) stopifnot(all.equal(as.list(y), as.list(x)[])) y <- x[1] print(y) stopifnot(all.equal(as.list(y), as.list(x)[1])) y <- x[2:3] print(y) stopifnot(all.equal(as.list(y), as.list(x)[2:3])) y <- x[-1] print(y) stopifnot(all.equal(as.list(y), as.list(x)[-1])) y <- x[1:2, 1:3, 1:4] print(y) stopifnot(all.equal(dim(y), dim(x))) stopifnot(all.equal(y, x)) stopifnot(all.equal(unlist(y), unlist(x))) stopifnot(all.equal(as.list(y), as.list(x)[1:2, 1:3, 1:4], check.attributes = FALSE)) y <- x[0, 0, 0] print(y) stopifnot(length(y) == 0) stopifnot(all.equal(dim(y), c(0, 0, 0))) stopifnot(all.equal(y, as.list(x)[0, 0, 0])) y <- x[0, , ] print(y) stopifnot(length(y) == 0) stopifnot(all.equal(dim(y), c(0, dim(x)[-1]))) stopifnot(all.equal(y, as.list(x)[0, , ])) y <- x[2, 1, , drop = FALSE] print(y) stopifnot(all.equal(dim(y), c(1, 1, dim(x)[3]))) stopifnot(all.equal(as.list(y), as.list(x)[2, 1, , drop = FALSE], check.attributes = FALSE)) y <- x[2, 1, , drop = TRUE] print(y) stopifnot(is.null(dim(y))) stopifnot(all.equal(as.list(y), as.list(x)[2, 1, , drop = TRUE], check.attributes = FALSE)) y <- x[2, 1, ] print(y) stopifnot(is.null(dim(y))) stopifnot(all.equal(as.list(y), as.list(x)[2, 1, ], check.attributes = FALSE)) y <- x[-1, , c(3, 3, 1)] print(y) stopifnot(all.equal(as.list(y), as.list(x)[-1, , c(3, 3, 1)], check.attributes = FALSE)) message("* x[i], x[i,j] ... DONE") message("* x[i] <- value, x[i,j] <- value ...") dim <- c(2, 3) n <- prod(dim) names <- letters[seq_len(n)] x0 <- as.list(1:n) dim(x0) <- dim names(x0) <- names x <- as.listenv(1:n) dim(x) <- dim names(x) <- names x0[] <- 6:1 x[] <- 6:1 stopifnot(all(unlist(x) == unlist(x0))) x0[1, ] <- 1:3 x[1, ] <- 1:3 stopifnot(all(unlist(x) == unlist(x0))) x0[, -2] <- 1:2 x[, -2] <- 1:2 stopifnot(all(unlist(x) == unlist(x0))) message("* x[i] <- value, x[i,j] <- value ... DONE") message("* Dropping dimensions from matrix/array by assigning NULL ...") message("- Dropping rows and columns from matrix") x <- as.list(1:12) dim(x) <- c(4, 3) dimnames(x) <- list(letters[1:4], LETTERS[1:3]) y <- as.listenv(x) x <- x[, -2, drop = FALSE] print(x) y[, 2] <- NULL print(as.list(y)) stopifnot(identical(as.list(y), x)) ## Drop every 2nd row using logical select x <- x[c(FALSE, TRUE), , drop = FALSE] print(x) y[c(TRUE, FALSE), ] <- NULL print(as.list(y)) stopifnot(identical(as.list(y), x)) ## Drop by row names x <- x["b", , drop = FALSE] print(x) y["d", ] <- NULL print(as.list(y)) stopifnot(identical(as.list(y), x)) ## Dropping multiple, duplicated indices x <- as.list(1:12) dim(x) <- c(4, 3) dimnames(x) <- list(letters[1:4], LETTERS[1:3]) y <- as.listenv(x) x <- x[3:4, 1, drop = FALSE] print(x) y[, 3:2] <- NULL y[c(1, 1, 1, 2), ] <- NULL print(as.list(y)) stopifnot(identical(as.list(y), x)) message("- Dropping dimensions from array") x <- as.list(1:12) dim(x) <- c(2, 2, 3) dimnames(x) <- list(c("u", "v"), c("a", "b"), c("A", "B", "C")) print(x) y <- as.listenv(x) print(y) x <- x[-1, , -3, drop = FALSE] print(x) y[1, , ] <- NULL y[, , 3] <- NULL print(as.list(y)) stopifnot(identical(as.list(y), x)) message("* Dropping dimensions from matrix/array by assigning NULL ... DONE") message("* dim(x) <- dim on length(x) == 0 ...") x <- listenv() dim(x) <- c(2, 3) stopifnot(length(x) == 6, nrow(x) == 2, ncol(x) == 3) message("* Exceptions ...") x <- listenv() dim(x) <- c(2, 3) res <- try(x[[3, 3]], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[3, 3], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[c(-1, 1), 3], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[c(TRUE, TRUE, TRUE), ], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(dimnames(x) <- NA, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(dimnames(x) <- list("a", "b", "c"), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(dimnames(x) <- list("a", NULL), silent = TRUE) stopifnot(inherits(res, "try-error")) dimnames(x) <- list(c("a", "b"), NULL) message("* Changing dim(x) and dimnames(x) ...") x <- listenv() x[1:12] <- 1:12 dim(x) <- c(2, 2, 3) dimnames(x) <- list(c("a", "b"), NULL, NULL) print(x) stopifnot(identical(dim(x), c(2L, 2L, 3L))) stopifnot(identical(dimnames(x), list(c("a", "b"), NULL, NULL))) x[[2, 1, 2]] <- -x[[2, 1, 2]] y <- unlist(x) print(y) dim(x) <- c(4, 3) print(x) stopifnot(identical(dim(x), c(4L, 3L))) stopifnot(is.null(dimnames(x))) x[[2, 2]] <- -x[[2, 2]] y <- unlist(x) print(y) stopifnot(identical(y, 1:12)) message("* Removing elements ...") x <- as.listenv(1:6) dim(x) <- c(2, 3) names(x) <- letters[seq_along(x)] print(x) x[[3]] <- NULL print(x) stopifnot(is.null(dim(x))) stopifnot(!is.null(names(x)), identical(names(x), c("a", "b", "d", "e", "f"))) message("* List environment and multiple dimensions ... DONE") ## Cleanup options(oopts) rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/tests/undim.R0000644000176200001440000000115313322430416014335 0ustar liggesuserslibrary("listenv") message("*** undim() ...") ## General x <- c(a = 1, b = 2, A = 3, B = 4) names <- names(x) dim <- c(2, 2) dimnames <- list(c("a", "b"), c("A", "B")) ## Basic arrays y <- array(x, dim = dim, dimnames = dimnames) names(y) <- names z <- undim(y) stopifnot(identical(names(z), names)) ## Lists y <- as.list(x) dim(y) <- dim dimnames(y) <- dimnames names(y) <- names z <- undim(y) stopifnot(identical(names(z), names)) ## List environments y <- as.listenv(x) dim(y) <- dim dimnames(y) <- dimnames names(y) <- names z <- undim(y) stopifnot(identical(names(z), names)) message("*** undim() ... DONE") listenv/tests/listenv.R0000644000176200001440000004222313572226030014712 0ustar liggesuserslibrary("listenv") ovars <- ls(envir = globalenv()) oopts <- options(warn = 1) with_r_330 <- function(expr) { if (getRversion() < "3.3.0") return() eval(substitute(expr), envir = parent.frame(), enclos = baseenv()) } ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Allocation ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() print(x) stopifnot(length(x) == 0) stopifnot(is.null(names(x))) with_r_330({ stopifnot(identical(lengths(x), integer(0L))) }) ## Named, empty list environment x <- listenv() names(x) <- character(0L) print(x) x <- listenv(a = 1) print(x) stopifnot(length(x) == 1) stopifnot(identical(names(x), c("a"))) stopifnot(identical(x$a, 1)) with_r_330({ stopifnot(identical(lengths(x), c(a = 1L))) }) x <- listenv(a = 1, b = 2:3) print(x) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(x$a, 1), identical(x$b, 2:3)) with_r_330({ stopifnot(identical(lengths(x), c(a = 1L, b = 2L))) stopifnot(identical(lengths(x, use.names = FALSE), c(1L, 2L))) }) x <- listenv(b = 2:3, .a = 1) print(x) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("b", ".a"))) stopifnot(identical(x$.a, 1), identical(x$b, 2:3)) with_r_330({ stopifnot(identical(lengths(x), c(b = 2L, .a = 1L))) }) x <- listenv(length = 3, a = 1) print(x) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("length", "a"))) stopifnot(identical(x$length, 3), identical(x$a, 1)) with_r_330({ stopifnot(identical(lengths(x), c(length = 1L, a = 1L))) }) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Single-element assignments and subsetting ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 0) x$a <- 1 print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 1) stopifnot(identical(names(x), c("a"))) stopifnot(identical(x$a, 1), is.null(x$b)) x$b <- 2 print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(x$b, 2)) x$a <- 0 print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(x[["a"]], 0)) x$"a" <- 1 print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(x$a, 1)) with_r_330({ stopifnot(identical(lengths(x), c(a = 1L, b = 1L))) }) x[["a"]] <- 0 print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) key <- "b" x[[key]] <- 3 print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(x$b, 3), identical(x[["b"]], 3), identical(x[[key]], 3)) x[[3]] <- 3.14 print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", ""))) stopifnot(identical(x[[3]], 3.14)) names(x) <- c("a", "b", "c") stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", "c"))) stopifnot(identical(x[[3]], 3.14), identical(x[["c"]], 3.14), identical(x$c, 3.14)) with_r_330({ stopifnot(identical(lengths(x), c(a = 1L, b = 1L, c = 1L))) }) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Multi-element subsetting ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Assert than no false names are introduced x <- listenv() x[1:3] <- list(1, NULL, 3) print(x) stopifnot(is.null(names(x))) with_r_330({ stopifnot(identical(lengths(x), c(1L, 0L, 1L))) }) y <- x[] print(y) stopifnot(length(y) == length(x)) stopifnot(all.equal(y, x)) stopifnot(!identical(y, x)) stopifnot(is.null(names(y))) with_r_330({ stopifnot(identical(lengths(y), c(1L, 0L, 1L))) }) y <- x[1] print(y) stopifnot(is.null(names(y))) y <- x[2:3] print(y) stopifnot(is.null(names(y))) with_r_330({ stopifnot(identical(lengths(y), c(0L, 1L))) }) y <- x[-1] print(y) stopifnot(is.null(names(y))) with_r_330({ stopifnot(identical(lengths(y), c(0L, 1L))) }) x[c("c", ".a", "b")] <- list(NULL, 3, 1) print(x) stopifnot(identical(names(x), c("", "", "", "c", ".a", "b"))) with_r_330({ stopifnot(identical(lengths(x), c(1L, 0L, 1L, c = 0L, .a = 1L, b = 1L))) }) y <- as.list(x) str(y) stopifnot(identical(names(y), c("", "", "", "c", ".a", "b"))) y <- as.list(x, all.names = FALSE) str(y) stopifnot(identical(names(y), c("", "", "", "c", "b"))) y <- as.list(x, sorted = TRUE) str(y) stopifnot(identical(names(y), c("", "", "", ".a", "b", "c"))) y <- as.list(x, all.names = FALSE, sorted = TRUE) str(y) stopifnot(identical(names(y), c("", "", "", "b", "c"))) x <- listenv() x[c("a", "b", "c")] <- list(1, NULL, 3) y <- x[NULL] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list())) y <- x[integer(0L)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list())) y <- x["a"] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(a = 1))) y <- x[c("a", "c")] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(a = 1, c = 3))) y <- x[c("c", "a")] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(c = 3, a = 1))) y <- x[c(1, 3)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(a = 1, c = 3))) y <- x[-2] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(a = 1, c = 3))) y <- x[-c(1, 3)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(b = NULL))) y <- x[rep(1L, times = 6L)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, rep(list(a = 1), times = 6L))) y <- x[1:10] print(y) z <- as.list(y) print(z) stopifnot(identical(z, c(as.list(x), rep(list(NULL), times = 7L)))) y <- x[c(TRUE, FALSE, TRUE)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(a = 1, c = 3))) y <- x[c(TRUE, FALSE)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list(a = 1, c = 3))) y <- x[TRUE] print(y) z <- as.list(y) print(z) stopifnot(identical(z, as.list(x))) y <- x[FALSE] print(y) z <- as.list(y) print(z) stopifnot(identical(z, list())) y <- x[rep(TRUE, times = 5L)] print(y) z <- as.list(y) print(z) stopifnot(identical(z, c(as.list(x), list(NULL), list(NULL)))) with_r_330({ stopifnot(identical(lengths(z), c(a = 1L, b = 0L, c = 1L, 0L, 0L))) }) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Local access ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv(a = 1, b = 2, c = 3.14) y <- local({ x[[3]] }) stopifnot(identical(y, 3.14)) y <- local({ x[3] }) stopifnot(identical(y[[1]], 3.14)) y <- local({ ii <- 3 x[[ii]] }) stopifnot(identical(y, 3.14)) y <- local({ ii <- 3 x[ii] }) stopifnot(identical(y[[1]], 3.14)) local({ x[[3]] <- 42L }) y <- x[[3]] stopifnot(identical(y, 42L)) local({ x[3] <- 3.14 }) y <- x[[3]] stopifnot(identical(y, 3.14)) local({ ii <- 3 x[ii] <- 42L }) y <- x[[3]] stopifnot(identical(y, 42L)) local({ ii <- 3 x[[ii]] <- 3.14 }) y <- x[[3]] stopifnot(identical(y, 3.14)) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Removing elements ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x[["a"]] <- NULL print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("b", "c"))) x[[3L]] <- NULL print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("b", "c"))) x[[2L]] <- NULL print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 1) stopifnot(identical(names(x), c("b"))) x$b <- NULL print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 0) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Assigning NULL ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x[2L] <- list(NULL) print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("", ""))) x["c"] <- list(NULL) print(x) print(length(x)) print(names(x)) stopifnot(length(x) == 3) stopifnot(identical(names(x), c("", "", "c"))) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Assigning multiple elements at once ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() x[c("a", "b", "c")] <- 1:3 print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", "c"))) stopifnot(identical(as.list(x), list(a = 1L, b = 2L, c = 3L))) stopifnot(identical(unlist(x), c(a = 1L, b = 2L, c = 3L))) x[] <- 3:1 stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", "c"))) stopifnot(identical(as.list(x), list(a = 3L, b = 2L, c = 1L))) x[c("c", "b")] <- 2:3 print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", "c"))) stopifnot(identical(as.list(x), list(a = 3L, b = 3L, c = 2L))) x[c("a", "c")] <- 1L print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", "c"))) stopifnot(identical(as.list(x), list(a = 1L, b = 3L, c = 1L))) x[c("d", "e")] <- 4:5 print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 5) stopifnot(identical(names(x), c("a", "b", "c", "d", "e"))) stopifnot(identical(as.list(x), list(a = 1L, b = 3L, c = 1L, d = 4L, e = 5L))) x <- listenv() x[c("a", "b")] <- 1:2 x[c(TRUE, FALSE)] <- 2L print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(as.list(x), list(a = 2L, b = 2L))) x[c(TRUE)] <- 1L print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 2) stopifnot(identical(names(x), c("a", "b"))) stopifnot(identical(as.list(x), list(a = 1L, b = 1L))) x[c(TRUE, FALSE, TRUE, FALSE)] <- 3L print(x) str(as.list(x)) print(length(x)) print(names(x)) stopifnot(length(x) == 3) stopifnot(identical(names(x), c("a", "b", ""))) stopifnot(identical(as.list(x), list(a = 3L, b = 1L, 3L))) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Removing multiple elements at once ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- as.listenv(1:6) names(x) <- letters[seq_along(x)] y <- as.list(x) stopifnot(identical(as.list(x), y)) x[2] <- NULL y[2] <- NULL stopifnot(identical(as.list(x), y)) x[4:3] <- NULL y[4:3] <- NULL stopifnot(identical(as.list(x), y)) x[rep(2, times = 10)] <- NULL y[rep(2, times = 10)] <- NULL stopifnot(identical(as.list(x), y)) ## Erase all elements y[] <- NULL x[] <- NULL stopifnot(identical(as.list(x), y)) x <- as.listenv(1:6) names(x) <- letters[seq_along(x)] y <- as.list(x) stopifnot(identical(as.list(x), y)) # Every other by logical indexing x[c(TRUE, FALSE)] <- NULL y[c(TRUE, FALSE)] <- NULL stopifnot(identical(as.list(x), y)) x[c("b", "f")] <- NULL y[c("b", "f")] <- NULL stopifnot(identical(as.list(x), y)) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Expanding ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() for (ii in 1:3) { x[[ii]] <- letters[ii] print(x[[ii]]) } print(x) names(x) <- sprintf("item%d", seq_along(x)) print(x) y <- as.list(x) str(y) stopifnot(identical(names(y), c("item1", "item2", "item3"))) stopifnot(identical(y[[1]], "a"), identical(y[[2]], "b"), identical(y[[3]], "c")) x[[2]] <- "B" stopifnot(identical(x$item2, "B")) x <- listenv() x[[1]] <- { 1 } x[[3]] <- { "Hello world!" } stopifnot(length(x) == 3) stopifnot(identical(seq_along(x), seq_len(length(x)))) print(x) names(x) <- c("a", "b", "c") print(x) x$b <- TRUE stopifnot(identical(x[[1]], 1)) stopifnot(identical(x[[2]], TRUE)) stopifnot(identical(x$b, TRUE)) stopifnot(identical(x[["b"]], TRUE)) y <- as.list(x) str(y) stopifnot(length(y) == 3) ## Mixed names and indices x <- listenv() x$a <- 1 x[[3]] <- 3 print(names(x)) stopifnot(identical(names(x), c("a", "", ""))) # First element (should be named "a") var <- get_variable(x, "a") stopifnot(var == "a") var <- get_variable(x, 1) stopifnot(var == "a") # Third element (should be a temporary name) var <- get_variable(x, 3) stopifnot(var != "c") names(x) <- c("a", "b", "c") var <- get_variable(x, 3) stopifnot(var != "c") var <- get_variable(x, "c") stopifnot(var != "c") ## Second element (should become "b", because it was never used # before it was "named" "b") x$b <- 2 var <- get_variable(x, 2) stopifnot(var == "b") var <- get_variable(x, "b") stopifnot(var == "b") ## Names where as.integer(names(x)) are integers x <- listenv() x[["1"]] <- 1 x[["3"]] <- 3 print(names(x)) stopifnot(identical(names(x), c("1", "3"))) ## Expand and shrink x <- listenv() stopifnot(length(x) == 0L) length(x) <- 3L stopifnot(length(x) == 3L) stopifnot(is.null(names(x))) names(x) <- c("a", "b", "c") x$a <- 2 stopifnot(identical(x$a, 2)) x[c("a", "c")] <- c(2, 1) stopifnot(identical(x$a, 2), identical(x$c, 1)) length(x) <- 4L stopifnot(length(x) == 4L) stopifnot(identical(names(x), c("a", "b", "c", ""))) length(x) <- 1L stopifnot(length(x) == 1L) stopifnot(identical(names(x), c("a"))) stopifnot(identical(x$a, 2)) length(x) <- 0L stopifnot(length(x) == 0L) stopifnot(length(names(x)) == 0) # Actually, character(0), cf. lists ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Flatten ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - for (recursive in c(FALSE, TRUE)) { x <- list(); x$a <- list(B = 1:3); x$b <- list(C = 1:3, D = 4:5) y1 <- unlist(x, recursive = recursive) x <- listenv(); x$a <- list(B = 1:3); x$b <- list(C = 1:3, D = 4:5) y2 <- unlist(x, recursive = recursive) stopifnot(identical(y2, y1)) } # for (recursive ...) x <- listenv(); x$a <- list(B = 1:3); x$b <- as.listenv(list(C = 1:3, D = 4:5)) y3 <- unlist(x, recursive = TRUE) stopifnot(identical(y3, y1)) x <- listenv() y <- unlist(x) stopifnot(length(y) == 0) stopifnot(is.null(y)) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Comparisons ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv(c = NULL, .a = 3, b = 1) print(x) ## A list environment is always equal to itself stopifnot(all.equal(x, x)) ## List environments emulate lists stopifnot(all.equal(x, list(c = NULL, .a = 3, b = 1))) stopifnot(all.equal(x, list(c = NULL, .a = 3, b = 1), sorted = TRUE)) stopifnot(all.equal(x, list(.a = 3, b = 1, c = NULL), sorted = TRUE)) stopifnot(all.equal(x, list(c = NULL, b = 1), all.names = FALSE)) stopifnot(all.equal(x, list(.a = 3, c = NULL, b = 1), all.names = FALSE)) stopifnot(all.equal(x, list(b = 1, c = NULL), all.names = FALSE, sorted = TRUE)) res <- all.equal(x, list(b = 1, c = NULL), sorted = FALSE) stopifnot(!isTRUE(res)) res <- all.equal(x, list(b = 1, c = NULL), all.names = FALSE) stopifnot(!isTRUE(res)) ## Assert listenv() -> as.list() -> as.listenv() equality y <- as.list(x) stopifnot(identical(names(y), names(x))) z <- as.listenv(y) stopifnot(identical(names(z), names(y))) stopifnot(all.equal(x, y)) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Warnings ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() x[1:3] <- 1:3 res <- tryCatch(x[1:2] <- 1:4, warning = function(w) { class(w) <- "try-warning" w }) stopifnot(inherits(res, "try-warning")) res <- tryCatch(x[1:3] <- 1:2, warning = function(w) { class(w) <- "try-warning" w }) stopifnot(inherits(res, "try-warning")) res <- tryCatch(x[integer(0L)] <- 1, warning = function(w) { class(w) <- "try-warning" w }) stopifnot(!inherits(res, "try-warning")) ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## Exception handling ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - x <- listenv() length(x) <- 3L names(x) <- c("a", "b", "c") res <- try(names(x) <- c("a", "b"), silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[1:2]], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[0]], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[length(x) + 1]], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[1 + 2i]], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[1 + 2i], silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[1 + 2i]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[1 + 2i] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[integer(0L)]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[1:2]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[Inf]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[0]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[-1]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[character(0L)]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[c("a", "b")]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) res <- try(x[[""]] <- 1, silent = TRUE) stopifnot(inherits(res, "try-error")) ## Defunct res <- tryCatch({ x <- listenv(length = 3L) }, error = identity) stopifnot(inherits(res, "error")) ## Cleanup options(oopts) rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) listenv/vignettes/0000755000176200001440000000000013572257030013752 5ustar liggesuserslistenv/vignettes/listenv.md.rsp0000644000176200001440000002340413572226030016562 0ustar liggesusers<%@meta language="R-vignette" content="-------------------------------- %\VignetteIndexEntry{List Environments} %\VignetteAuthor{Henrik Bengtsson} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{listenv} %\VignetteEngine{R.rsp::rsp} %\VignetteTangle{FALSE} --------------------------------------------------------------------"%> <% R.utils::use("R.utils") use("listenv") options("withCapture/newline" = FALSE) %> # <%@meta name="title"%> ## Summary _List environments_ are environments that have list-like properties. They are implemented by the [listenv] package. The main features of a list environment are summarized in the below table: | Property | list environments | lists | environments | |------------------------------------------------------------------------------|:-----------------:|:------:|:------------:| | Number of elements, e.g. `length()` | yes | yes | yes | | Named elements, e.g. `names()`, `x$a` and `x[["a"]]` | yes | yes | yes | | Duplicated names | yes | yes | | | Element names are optional | yes | yes | | | Indexed elements, e.g. `x[[4]]` | yes | yes | | | Dimensions, e.g. `dim(x)` | yes | yes | | | Names of dimensions, e.g. `dimnames(x)` | yes | yes | | | Indexing by dimensions, e.g. `x[[2, 4]]` and `x[[2, "D"]]` | yes | yes | | | Multi-element subsetting, e.g. `x[c("a", "c")]`, `x[-1]` and `x[2:1, , 3]` | yes | yes | | | Multi-element subsetting preserves element names | yes | | | | Removing elements by assigning NULL, e.g. `x$c <- NULL` and `x[1:3] <- NULL` | yes | yes | | | Removing parts of dimensions by assigning NULL, e.g. `x[,2] <- NULL` | yes | | | | Mutable, e.g. `y <- x; y$a <- 3; identical(y, x)` | yes | | yes | | Compatible* with `assign()`, `delayedAssign()`, `get()` and `exists()` | yes | | yes | For example, ```r <%=withCapture({ x <- listenv(a = 1, b = 2, c = "hello") x length(x) names(x) x$a x[[3]] <- toupper(x[[3]]) x$c y <- x y$d <- y$a + y[["b"]] names(y)[2] <- "a" y$a y identical(y, x) for (ii in seq_along(x)) { cat(sprintf("Element %d (%s): %s\n", ii, sQuote(names(x)[ii]), x[[ii]])) } x[c(1, 3)] <- list(2, "Hello world!") x y <- as.list(x) str(y) z <- as.listenv(y) z identical(z, x) all.equal(z, x) })%> ``` ## Creating list environments List environments are created similarly to lists but also similarly to environments. To create an empty list environment, use ```r <%=withCapture({ x <- listenv() x })%> ``` This can later can be populated using named assignments, ```r <%=withCapture({ x$a <- 1 x })%> ``` comparable to how both lists and environments work. Similarly to lists, they can also be populated using indices, e.g. ```r <%=withCapture({ x[[2]] <- 2 x$c <- 3 x })%> ``` Just as for lists, a list environment is expanded with `NULL` elements whenever a new element is added that is beyond the current length plus one, e.g. ```r <%=withCapture({ x[[5]] <- 5 x x[[4]] })%> ``` As with lists, the above list environment can also be created from the start, e.g. ```r <%=withCapture({ x <- listenv(a = 1, 3, c = 4, NULL, 5) x })%> ``` As for lists, the length of a list environment can at any time be increased or decreased by assigning it a new length. If decreased, elements are dropped, e.g. ```r <%=withCapture({ x length(x) <- 2 x x[[1]] x[[2]] })%> ``` If increased, new elements are populated with unnamed elements of `NULL`, e.g. ```r <%=withCapture({ length(x) <- 4 x x[[3]] x[[4]] })%> ``` To allocate an "empty" list environment (with all `NULL`:s) of a given length, do ```r <%=withCapture({ x <- listenv() length(x) <- 4 x })%> ``` _Note_: Unfortunately, it is _not_ possible to use `x <- vector("listenv", length = 4)`; that construct is only supported for the basic data types. Elements can be dropped by assigning `NULL`, e.g. to drop the first and third element of a list environment, do: ```r <%=withCapture({ x[c(1, 3)] <- NULL x })%> ``` ## Iterating over elements ### Iterating over elements by names Analogously to lists and plain environments, it is possible to iterate over elements of list environments by the element names. For example, ```r <%=withCapture({ x <- listenv(a = 1, b = 2, c = 3) for (name in names(x)) { cat(sprintf("Element %s: %s\n", sQuote(name), x[[name]])) } })%> ``` ### Iterating over elements by indices Analogously to lists, but contrary to plain environments, it is also possible to iterate over elements by their indices. For example, ```r <%=withCapture({ x <- listenv(a = 1, b = 2, c = 3) for (ii in seq_along(x)) { cat(sprintf("Element %d: %s\n", ii, x[[ii]])) } })%> ``` ## Coercion to and from list environments ### Coercing to lists and vectors Coercing a list environment to a list: ```r <%=withCapture({ x <- listenv(a = 2, b = 3, c = "hello") x y <- as.list(x) str(y) })%> ``` Coercing a list to a list environment: ```r <%=withCapture({ z <- as.listenv(y) z identical(z, x) all.equal(z, x) })%> ``` Unlisting: ```r <%=withCapture({ unlist(x) unlist(x[-3]) unlist(x[1:2], use.names=FALSE) })%> ``` ## Multi-dimensional list environments Analogously to lists, and contrary to plain environments, list environments can have dimensions with corresponding names. For example, ```r <%=withCapture({ x <- as.listenv(1:6) dim(x) <- c(2, 3) dimnames(x) <- list(c("a", "b"), c("A", "B","C")) x })%> ``` An easy way to quickly get an overview is to coerce to a list, e.g. ```r <%=withCapture({ as.list(x) })%> ``` Individual elements of a list environment can be accessed using standard subsetting syntax, e.g. ```r <%=withCapture({ x[["a", "B"]] x[[1, 2]] x[[1, "B"]] })%> ``` We can assign individual elements similarly, e.g. ```r <%=withCapture({ x[["b", "B"]] <- -x[["b", "B"]] as.list(x) })%> ``` We can also assign multiple elements through dimensional subsetting, e.g. ```r <%=withCapture({ x[2, -1] <- 98:99 as.list(x) x["a", c(1, 3)] <- list(97, "foo") as.list(x) x[] <- 1:6 as.list(x) })%> ``` Concurrently with dimensional names it is possible to have names of the individual elements just as for list environments without dimensions. For example, ```r <%=withCapture({ names(x) <- letters[seq_along(x)] x x[["a"]] x[["f"]] x[c("a", "f")] unlist(x) as.list(x) })%> ``` Contrary to lists, element names are preserved also with multi-dimensional subsetting, e.g. ```r <%=withCapture({ x[1, 2] x[1, 2, drop = FALSE] x[1:2, 2:1] x[2, ] x[2, , drop = FALSE] x["b", -2, drop = FALSE] })%> ``` Note, whenever dimensions are set using `dim(x) <- dims` both the dimensional names and the element names are removed, e.g. ```r > dim(x) <- NULL > names(x) NULL ``` This behavior is by design, cf. `help("dim", package="base")`. To allocate an "empty" list environment array (with all `NULL`:s) of a given dimension, do ```r <%=withCapture({ x <- listenv() dim(x) <- c(2, 3) dimnames(x) <- list(c("a", "b"), c("A", "B", "C")) x })%> ``` Rows and columns can be dropped by assigning `NULL`, e.g. to drop the first and third column of a list-environment matrix, do: ```r <%=withCapture({ x[, c(1, 3)] <- NULL x })%> ``` <%--- Because of this, the listenv package provides the `undim()` function, which removes the dimensions but preserves the names, e.g. ```r <%=withCapture({ x <- undim(x) names(x) })%> ``` _Warning_: Since list environments _and their attributes_ are mutable, calling ```r undim(x) ``` will have the same effect as ```r x <- undim(x) ``` That is, the dimension attributes of `x` will be changed. The reason for this is explained in Section 'Important about environments' above. ---%> ## Important about environments List environments are as their name suggests _environments_. Whenever working with environments in R, it is important to understand that _environments are mutable_ whereas all other of the basic data types in R are immutable. For example, consider the following function that assigns zero to element `a` of object `x`: ```r <%=withCapture({ setA <- function(x) { x$a <- 0 x } })%> ``` If we pass a regular list to this function, ```r <%=withCapture({ x <- list(a = 1) y <- setA(x) x$a y$a })%> ``` we see that `x` is unaffected by the assignment. This is because _lists are immutable_ in R. However, if we pass an environment instead, ```r <%=withCapture({ x <- new.env() x$a <- 1 y <- setA(x) x$a y$a })%> ``` we find that `x` was affected by the assignment. This is because _environments are mutable_ in R. Since list environments inherits from environments, this also goes for them, e.g. ```r <%=withCapture({ x <- listenv(a = 1) y <- setA(x) x$a y$a })%> ``` What is also important to understand is that it is not just the _content_ of an environment that is mutable but also its _attributes_. For example, ```r <%=withCapture({ x <- listenv(a = 1) y <- x attr(y, "foo") <- "Hello!" attr(x, "foo") })%> ``` More importantly, since dimensions and their names are also attributes, this also means they are mutable. For example, ```r <%=withCapture({ x <- as.listenv(1:6) dim(x) <- c(2, 3) x y <- x dim(y) <- c(3, 2) x })%> ``` [listenv]: https://cran.r-project.org/package=listenv --- Copyright Henrik Bengtsson, 2015-2018 listenv/NEWS0000644000176200001440000001136313572256770012457 0ustar liggesusersPackage: listenv ================ Version: 0.8.0 [2019-12-05] SIGNFICANT CHANGES: * S3 method lengths.listenv() is no longer exported. NEW FEATURES: * Made several error messages more informative. The downside is that those messages are no longer translated (because they are no longer aligned with built-in R error messages which have translations) BUG FIXES: * parse_env_subset(x[1, names]) on a listenv 'x' matrix would throw error 'Error in if (any(i < 0)) { : missing value where TRUE/FALSE needed' if one of the elements in 'names' specifies a non-existing column name. * parse_env_subset(x[]) on a listenv 'x' would throw an error on "Invalid subset: 'x[]'". * parse_env_subset(x[names]) on a listenv 'x' would throw an error on 'length(x) = 2 > 1' in coercion to 'logical(1)' when length(names) > 1 and _R_CHECK_LENGTH_1_LOGIC2_=true. * parse_env_subset(x[1,idxs]) on a listenv 'x' would throw an error on 'length(x) = 2 > 1' in coercion to 'logical(1)' with length(idxs) > 1 and _R_CHECK_LENGTH_1_LOGIC2_=true. * parse_env_subset(x[[names]]) on a regular environment 'x' with length(names) > 1 would not throw an error, whereas x[[names]] would. * parse_env_subset(x[[1]]) on a regular environment 'x' would not throw an error, whereas x[[1]] would. Version: 0.7.0 [2018-01-21] NEW FEATURES: * Now it is possible to set the dimension on an empty list environment without first resizing it with length(), e.g. x <- listenv(); dim(x) <- c(2, 3). * Now it is possible to remove multiple elements by assigning NULL, e.g. x[c(2:3, 10)] <- NULL and x[, "B"] <- NULL. * Added lengths() for list environments. Requires R (>= 3.3.0). * dim_na(x) <- dims, where 'dims' contain exactly one missing value, will set the "missing" dimension based on the length of 'x' and the other dimensions specified, e.g. with length(x) == 6, dim_na(x) <- c(2, NA) will set dim(x) <- c(2, 3). This works for all types of object to which dimensions can be assigned - not only list environments. * Added is.matrix(), is.array(), as.vector() and as.matrix() for list environments. BUG FIXES: * print() on a named, empty list environment would output an empty string. * Removing an element from a list environment did not remove dimensions, e.g. x$a <- NULL. DEPRECATED AND DEFUNCT: * Function map() has been renamed to mapping() and same for the corresponding replacement function. The map() and map<-() functions will soon be deprecated and eventually defunct. * x <- listenv(length = n) is defunct; use x <- listenv(); length(x) <- n. Version: 0.6.0 [2015-12-27] NEW FEATURES: * Added support for multi-dimensional subsetting of list environments just as for list. BUG FIXES: * parse_env_subset(x[[idx]]) for list environment 'x' and index 'idx' claimed x[[idx]] exists as long as idx in [1,length(x)] but it forgot to check if element really existed, which may not be true if 'x' has been expanded. Version: 0.5.0 [2015-10-30] NEW FEATURES: * Add support for assigning elements when creating list environment similarly how to lists work, e.g. x <- listenv(a = 1, b = 2). * length(x) <- n now expand/truncate a list environment. * Added unlist() and all.equal() for list environments. DEPRECATED AND DEFUNCT: * Deprecated x <- listenv(length = n); use x <- listenv(); length(x) <- n. BUG FIXES: * as.listenv(x) would drop NULL elements in 'x'. * x[idxs], x[name] <- y and x$ <- y would introduce NA names for non-named list environments. Version: 0.4.0 [2015-08-08] NEW FEATURES: * Added as.listenv(). * CONSISTENCY: Assigning NULL now removes element just as lists, e.g. x$a <- NULL. To assign value NULL, do x['a'] <- list(NULL). * Added support for subsetting with [(), which returns another list environment, e.g. x[2:3], x[-1] and x[c(TRUE, FALSE)]. * Added [<- assignment, e.g. x['a'] <- 1 and x[2:3] <- c(3,8). * CLEANUP: Dropped stray debug code. Version: 0.3.0 [2015-05-23] CODE REFACTORIZATION: * Package no longer depends on other packages. Version: 0.2.4 [2015-05-22] NEW FEATURES: * Added helper function parse_env_subset(). Version: 0.2.3 [2015-05-21] NEW FEATURES: * print() on listenv() handles empty and no-named listenv:s better. Version: 0.2.2 [2015-05-20] NEW FEATURES: * Now listenv(length = ...) always allocates internal variables. Version: 0.2.1 [2015-05-19] NEW FEATURES: * get_variable() gained argument 'mustExist'. Version: 0.2.0 [2015-05-19] SIGNFICANT CHANGES: * Moved list environments from an in-house package to its own package. Version: 0.1.4 [2015-05-02] NEW FEATURES: * Added print() for listenv:s. CODE REFACTORIZATION: * Using tempvar() of R.utils. Version: 0.1.0 [2015-02-07] * Created. listenv/R/0000755000176200001440000000000013572256770012155 5ustar liggesuserslistenv/R/get_variable.R0000644000176200001440000000456113572226030014714 0ustar liggesusers#' Get name of variable for a specific element of list environment #' #' @param x A list environment. #' #' @param name The name or index of element of interest. #' #' @param mustExist If `TRUE`, an error is generated if `name` does not exist. #' #' @param create If `TRUE`, element `name` is created if missing. #' #' @return The name of the underlying variable #' #' @aliases get_variable.listenv #' @export #' @keywords internal get_variable <- function(...) UseMethod("get_variable") #' @export get_variable.listenv <- function(x, name, mustExist = FALSE, create = !mustExist, ...) { if (is.character(name)) { } else if (is.numeric(name)) { } else { stop("Subscript must be a name or an index: ", mode(name), call. = FALSE) } dim <- dim(x) if (is.null(dim)) { if (length(name) != 1L) { stop("Subscript must be a scalar: ", length(name), call. = FALSE) } } else { ndim <- length(dim) if (length(name) != 1L && length(name) != ndim) { stopf("Subscript must be a scalar or of equal length to the number of dimension (%d): %d", ndim, length(name), call. = FALSE) #nolint } ## Map multi-dimensional index to scalar index if (length(name) > 1L) { stop_if_not(is.numeric(name)) idxs <- name if (anyNA(idxs)) stop("Unknown (NA) index detected") for (kk in seq_len(ndim)) { if (idxs[kk] < 1 || idxs[kk] > dim[kk]) { stopf("Index #%d out of range [1,%d]: %s", kk, dim[kk], idxs[kk]) } } bases <- rev(c(cumprod(dim[-ndim]), 1)) idx <- sum(bases * (idxs - 1)) + 1 name <- idx } } map <- mapping(x) ## Existing variable? var <- map[name] if (length(var) == 1L && !is.na(var)) return(var) if (mustExist) { stopf("No such %s element: %s", sQuote(class(x)[1]), name) } ## Create new variable if (is.character(name)) { var <- name ## Non-existing name? if (!is.element(name, names(map))) { map <- c(map, var) names(map)[length(map)] <- var } } else if (is.numeric(name)) { i <- name ## Expand map? if (i > length(map)) { extra <- rep(NA_character_, times = i - length(map)) map <- c(map, extra) } ## Create internal variable var <- new_variable(x, value = NULL, create = create) map[i] <- var } ## Update map? if (create) mapping(x) <- map var } listenv/R/utils.R0000644000176200001440000000324313572226030013424 0ustar liggesusers## From R.utils 2.0.2 (2015-05-23) hpaste <- function(..., sep = "", collapse = ", ", last_collapse = NULL, max_head = if (missing(last_collapse)) 3 else Inf, max_tail = if (is.finite(max_head)) 1 else Inf, abbreviate = "...") { max_head <- as.double(max_head) max_tail <- as.double(max_tail) if (is.null(last_collapse)) last_collapse <- collapse # Build vector 'x' x <- paste(..., sep = sep) n <- length(x) # Nothing todo? if (n == 0) return(x) if (is.null(collapse)) return(x) # Abbreviate? if (n > max_head + max_tail + 1) { head <- x[seq_len(max_head)] tail <- rev(rev(x)[seq_len(max_tail)]) x <- c(head, abbreviate, tail) n <- length(x) } if (!is.null(collapse) && n > 1) { if (last_collapse == collapse) { x <- paste(x, collapse = collapse) } else { x_head <- paste(x[1:(n - 1)], collapse = collapse) x <- paste(x_head, x[n], sep = last_collapse) } } x } stopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint stop(sprintf(fmt, ...), call. = call., domain = domain) } warnf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint warning(sprintf(fmt, ...), call. = call., domain = domain) } stop_if_not <- function(...) { res <- list(...) n <- length(res) if (n == 0L) return() for (ii in 1L:n) { res_ii <- .subset2(res, ii) if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) { mc <- match.call() call <- deparse(mc[[ii + 1]], width.cutoff = 60L) if (length(call) > 1L) call <- paste(call[1L], "...") stop(sQuote(call), " is not TRUE", call. = FALSE, domain = NA) } } } listenv/R/parse_env_subset.R0000644000176200001440000002402713572226030015636 0ustar liggesusers#' Helper function to infer target from expression and environment #' #' @param expr An expression. #' #' @param envir An environment. #' #' @param substitute If `TRUE`, then the expression is [base::substitute()]:ed, #' otherwise not. #' #' @return A named list with elements: #' \describe{ #' \item{`envir`}{An environment (defaults to argument `envir`)} #' \item{`name`}{A character vector. ...} #' \item{`op`}{...} #' \item{`subset`}{A list of `NULL`. ...} #' \item{`idx`}{An integer vector or `NULL`. ...} #' \item{`exists`}{A logical vector of length `length(idx)` with `TRUE` #' and `FALSE` values.} #' \item{`code`}{The deparsed expression `expr` coerced to a single character #' string.} #' } #' #' @export #' @keywords internal parse_env_subset <- function(expr, envir = parent.frame(), substitute = TRUE) { if (substitute) expr <- substitute(expr) code <- paste(deparse(expr), collapse = "") res <- list(envir = envir, name = "", op = NULL, subset = NULL, idx = NA_integer_, exists = NA, code = code) if (is.symbol(expr)) { ## Variable specified as a symbol res$name <- deparse(expr) } else if (is.character(expr)) { ## Variable specified as a name if (length(expr) > 1L) { stopf("Does not specify a single variable, but %d: %s", length(expr), hpaste(sQuote(expr)), call. = FALSE) } res$name <- expr } else if (is.numeric(expr)) { ## Variable specified as a subset of envir if (length(expr) > 1L) { stopf("Does not specify a single index, but %d: %s", length(expr), hpaste(sQuote(expr)), call. = FALSE) } res$subset <- list(expr) } else { n <- length(expr) stop_if_not(n >= 2L) if (n >= 3L) { ## Assignment to environment via $ and [[ op <- as.character(expr[[1]]) res$op <- op if (op == "$" && n > 3L) { stop("Invalid syntax: ", sQuote(code), call. = FALSE) } else if (!is.element(op, c("$", "[[", "["))) { stop("Invalid syntax: ", sQuote(code), call. = FALSE) } ## Target objname <- deparse(expr[[2]]) if (!exists(objname, envir = envir, inherits = TRUE)) { stopf("Object %s not found: %s", sQuote(objname), sQuote(code), call. = FALSE) } obj <- get(objname, envir = envir, inherits = TRUE) if (!is.environment(obj)) { stopf("Subsetting can not be done on a %s; only to an environment: %s", sQuote(mode(obj)), sQuote(code), call. = FALSE) } res$envir <- obj ## Check whether an empty symbol or not is_empty <- local({ symbol <- alist(empty=) function(x) identical(x, symbol$empty) }) ## Subset subset <- list() for (kk in 3:n) { if (is_empty(expr[[kk]])) { subset_kk <- NULL } else { subset_kk <- expr[[kk]] } if (is.symbol(subset_kk)) { subset_kk <- deparse(subset_kk) if (op == "[[") { if (!exists(subset_kk, envir = envir, inherits = TRUE)) { stopf("Object %s not found: %s", sQuote(subset_kk), sQuote(code), call. = FALSE) } subset_kk <- get(subset_kk, envir = envir, inherits = TRUE) } } else if (is.language(subset_kk)) { subset_kk <- eval(subset_kk, envir = envir, enclos = baseenv()) } if (is.null(subset_kk)) { subset[kk - 2L] <- list(NULL) } else { subset[[kk - 2L]] <- subset_kk } } res$subset <- subset } # if (n >= 3) } # if (is.symbol(expr)) ## Validate name, iff any name <- res$name if (nzchar(name) && !grepl("^[.a-zA-Z]+", name)) { stop("Not a valid variable name: ", sQuote(name), call. = FALSE) } ## Validate subsetting, e.g. x[[1]], x[["a"]], and x$a, iff any subset <- res$subset if (!is.null(subset)) { if (!is.list(subset)) { stopf("INTERNAL ERROR (expected 'subset' to be a list): %s", sQuote(code), call. = FALSE) } if (length(subset) == 0L) { stopf("Subsetting of at least on element is required: %s", sQuote(code), call. = FALSE) } for (kk in seq_along(subset)) { subset_kk <- subset[[kk]] if (is.null(subset_kk)) { } else if (any(is.na(subset_kk))) { stopf("Invalid subsetting for dimension #%d. Subset must not contain missing values: %s", kk, sQuote(code), call. = FALSE) } else if (is.character(subset_kk)) { if (!all(nzchar(subset_kk))) { stopf("Invalid subset for dimension #%d. Subset must not contain empty names: %s", kk, sQuote(code), call. = FALSE) } } else if (is.numeric(subset_kk)) { } else { stopf("Invalid subset for dimension #%d of type %s: %s", kk, sQuote(typeof(subset_kk)), sQuote(code), call. = FALSE) } } # for (kk ...) ## Special: listenv:s envir <- res$envir stop_if_not(is.environment(envir)) if (inherits(envir, "listenv")) { names <- names(envir) map <- mapping(envir) dim <- dim(envir) op <- res$op if (is.null(op)) op <- "[[" ## Multi-dimensional subsetting? if (length(subset) > 1L) { if (is.null(dim)) { stop("Multi-dimensional subsetting on list environment without dimensions: ", sQuote(code), call. = TRUE) #nolint } dimnames <- dimnames(envir) ## Expland NULL indices and map names to indices for (kk in seq_along(subset)) { subset_kk <- subset[[kk]] if (is.null(subset_kk)) { subset[[kk]] <- seq_len(dim[kk]) } else if (is.character(subset_kk)) { subset_kk <- match(subset_kk, dimnames[[kk]]) if (anyNA(subset_kk)) { unknown <- name[is.na(subset_kk)] stopf("Unknown names for dimension #%d: %s", kk, hpaste(sQuote(unknown))) } subset[[kk]] <- subset_kk } } ## Indexing scale factor per dimension ndim <- length(dim) scale <- c(1L, cumprod(dim[-ndim])) idx <- 1 for (kk in seq_along(subset)) { i <- subset[[kk]] stop_if_not(is.numeric(i)) d <- dim[kk] if (any(i < 0)) { if (op == "[[") { stopf("Invalid (negative) indices for dimension #%d: %s", kk, hpaste(i)) } else if (any(i > 0)) { stopf("Only 0's may be mixed with negative subscripts (dimension #%d)", kk) } ## Drop elements i <- setdiff(seq_len(d), -i) } if (any(i > d)) i[i > d] <- NA_integer_ ## Drop zeros i <- i[i != 0] i <- scale[kk] * (i - 1) if (kk == 1) { idx <- idx + i } else { idx <- outer(idx, i, FUN = `+`) } } # for (kk ...) res$idx <- idx res$name <- names[res$idx] ## Check if elements exist exists <- rep(TRUE, times = length(idx)) for (kk in seq_along(subset)) { subset_kk <- subset[[kk]] if (is.numeric(subset_kk)) { exists <- exists & (subset_kk >= 1 & subset_kk <= dim[kk]) } else { stopf("INTERNAL ERROR: Subset for dimension #%d should already be an index: ", kk, mode(subset_kk)) } } stop_if_not(length(exists) == length(idx)) exists[exists] <- !is.na(map[idx]) res$exists <- exists } else { subset <- subset[[1L]] if (is.numeric(subset)) { i <- subset n <- length(envir) if (any(i < 0)) { if (op == "[[") { stop("Invalid (negative) indices: ", hpaste(i)) } else if (any(i > 0)) { stop("Only 0's may be mixed with negative subscripts") } ## Drop elements i <- setdiff(seq_len(n), -i) } ## Drop zeros? keep <- which(i != 0) if (length(keep) != length(i)) { if (op == "[[") stop("Invalid (zero) indices: ", hpaste(i)) i <- i[keep] } res$idx <- i res$exists <- !is.na(map[res$idx]) & (res$idx >= 1 & res$idx <= n) res$name <- names[i] } else if (is.character(subset)) { res$idx <- match(subset, names) res$exists <- !is.na(res$idx) & !is.na(map[res$idx]) } else if (is.null(subset)) { res$idx <- seq_len(length(envir)) res$exists <- !is.na(res$idx) & !is.na(map[res$idx]) } } } else { if (length(subset) > 1L) { stop("Invalid subset: ", sQuote(code), call. = TRUE) } subset <- subset[[1L]] if (length(subset) > 1L) { stopf("Wrong arguments for subsetting an environment: %s", sQuote(code), call. = TRUE) } if (!is.character(subset)) { stopf("Wrong arguments for subsetting an environment: %s", sQuote(code), call. = TRUE) } } if (is.character(subset)) { res$name <- subset } } if (length(res$name) == 0L) res$name <- "" ## Identify index? if (inherits(res$envir, "listenv")) { envir <- res$envir if (any(is.na(res$idx)) && nzchar(res$name)) { res$idx <- match(res$name, names(envir)) } res$exists <- !is.na(res$idx) & !is.na(mapping(envir)[res$idx]) } ## Validate if (is.null(dim) && length(res$subset) == 1 && identical(res$op, "[")) { if (any(is.na(res$idx)) && !nzchar(res$name)) { stop("Invalid subset: ", sQuote(code), call. = TRUE) } } unknown <- which(is.na(res$exists)) if (length(unknown) > 0) { res$exists[unknown] <- sapply(unknown, FUN = function(idx) { exists(res$name[idx], envir = res$envir, inherits = TRUE) }) } ## Sanity check stop_if_not(is.environment(res$envir)) stop_if_not(is.character(res$name)) stop_if_not(is.null(res$subset) || is.list(res$subset)) stop_if_not(is.null(res$idx) || all(is.numeric(res$idx))) stop_if_not(is.logical(res$exists), !anyNA(res$exists)) stop_if_not(length(res$exists) == length(res$idx)) res } listenv/R/listenv,dims.R0000644000176200001440000000534613572256770014725 0ustar liggesusers#' @export dim.listenv <- function(x) attr(x, "dim.", exact = TRUE) #' @export `dim<-.listenv` <- function(x, value) { n <- length(x) if (!is.null(value)) { names <- names(value) value <- as.integer(value) p <- prod(as.double(value)) if (p != n) { if (n == 0) { length(x) <- p } else { stopf("Cannot set dimension to c(%s) because its length do not match the length of the object: %d != %s", paste(value, collapse = ", "), p, n) } } names(value) <- names } ## Always remove "dimnames" and "names" attributes, cf. help("dim") dimnames(x) <- NULL names(x) <- NULL attr(x, "dim.") <- value x } #' Set the dimension of an object #' #' @param x An \R object, e.g. a list environment, a matrix, an array, or #' a data frame. #' #' @param value A numeric vector coerced to integers. #' If one of the elements is missing, then its value is inferred from the #' other elements (which must be non-missing) and the length of `x`. #' #' @return An object with the dimensions set, similar to what #' \code{\link[base:dim]{dim(x) <- value}} returns. #' #' @examples #' x <- 1:6 #' dim_na(x) <- c(2, NA) #' print(dim(x)) ## [1] 2 3 #' #' @name dim_na #' @aliases dim_na<- #' @export `dim_na<-` <- function(x, value) { if (!is.null(value)) { value <- as.integer(value) nas <- which(is.na(value)) if (length(nas) > 0) { if (length(nas) > 1) { stop("Argument 'value' may only have one NA: ", sprintf("c(%s)", paste(value, collapse = ", "))) } value[nas] <- as.integer(length(x) / prod(value[-nas])) } } dim(x) <- value invisible(x) } #' @export dimnames.listenv <- function(x) attr(x, "dimnames.", exact = TRUE) #' @export `dimnames<-.listenv` <- function(x, value) { dim <- dim(x) if (is.null(dim) && !is.null(value)) { stop("'dimnames' applied to non-array") } for (kk in seq_along(dim)) { names <- value[[kk]] if (is.null(names)) next n <- length(names) if (n != dim[kk]) { stopf("Length of 'dimnames' for dimension #%d not equal to array extent: %d != %d", kk, n, dim[kk]) } } attr(x, "dimnames.") <- value x } #' @method is.matrix listenv #' @export is.matrix.listenv <- function(x, ...) { dim <- dim(x) (length(dim) == 2L) } #' @export is.array.listenv <- function(x, ...) { dim <- dim(x) !is.null(dim) } #' @method as.vector listenv #' @export as.vector.listenv <- function(x, mode = "any") { if (mode == "any") mode <- "list" x <- as.list(x) if (mode != "list") { x <- as.vector(x, mode = mode) } x } #' @export #' @method as.matrix listenv as.matrix.listenv <- function(x, ...) { dim <- dim(x) if (length(dim) != 2L) { dim <- c(length(x), 1L) dim(x) <- dim } x } listenv/R/undim.R0000644000176200001440000000163013572226030013376 0ustar liggesusers#' Removes the dimension of an object #' #' @param x An object with or without dimensions #' #' @param ... Not used. #' #' @return The object with the dimension attribute removed. #' #' @details #' This function does `attr(x, "dim") <- NULL`, which automatically also does #' `attr(x, "dimnames") <- NULL`. #' However, other attributes such as names attributes are preserved, #' which is not the case if one do `dim(x) <- NULL`. #' #' @export #' @aliases undim.default #' @aliases undim.listenv #' @keywords internal undim <- function(x, ...) UseMethod("undim") #' @export undim.default <- function(x, ...) { #nolint if (is.null(dim(x))) return(x) attr(x, "dim") <- NULL ## Dimnames seems to be unset above, but in case it changes ... attr(x, "dimnames") <- NULL x } #' @export undim.listenv <- function(x, ...) { #nolint x <- NextMethod() attr(x, "dim.") <- NULL attr(x, "dimnames.") <- NULL x } listenv/R/listenv.R0000644000176200001440000006076213572256770013777 0ustar liggesusers#' Create a list environment #' #' @param \dots (optional) Named and/or unnamed objects to be assigned to the #' list environment. #' #' @return An environment of class `listenv`. #' #' @example incl/listenv.R #' #' @aliases as.listenv #' @export listenv <- function(...) { args <- list(...) nargs <- length(args) names <- names(args) ## Allocate empty list environment metaenv <- new.env(parent = parent.frame()) env <- new.env(parent = metaenv) ## Defunct call? if (nargs == 1L && identical(names[1L], "length")) { .Defunct(msg = "Use of x <- listenv(length = n) to allocate a list environment of length n is defunct. Use x <- listenv(); length(x) <- n instead.") #nolint } ## Allocate internal variables maps <- sprintf(".listenv_var_%d", seq_len(nargs)) names(maps) <- names for (kk in seq_len(nargs)) { assign(maps[kk], value = args[[kk]], envir = env, inherits = FALSE) } metaenv[[".listenv.map"]] <- maps assign(".listenv_var_count", nargs, envir = env, inherits = FALSE) class(env) <- c("listenv", class(env)) env } #' @export #' @rdname listenv as.listenv <- function(...) UseMethod("as.listenv") #' @export as.listenv.listenv <- function(x, ...) { x } #' @export as.listenv.list <- function(x, ...) { nx <- length(x) res <- listenv() length(res) <- nx names(res) <- names <- names(x) for (kk in seq_len(nx)) { value <- x[[kk]] if (is.null(value)) value <- list(NULL) res[[kk]] <- value } ## Set dimensions? dim <- dim(x) if (!is.null(dim)) { dim(res) <- dim dimnames(res) <- dimnames(x) names(res) <- names } res } #' @export as.listenv.environment <- function(x, ...) { as.listenv(as.list(x, ...)) } #' @export as.listenv.default <- function(x, ...) { as.listenv(as.list(x, ...)) } #' @export print.listenv <- function(x, ...) { n <- length(x) dim <- dim(x) ndim <- length(dim) names <- names(x) dimnames <- dimnames(x) class <- class(x)[1L] if (ndim <= 1) { what <- "vector" } else if (ndim == 2) { what <- "matrix" } else { what <- "array" } s <- sprintf("A %s %s with %d", sQuote(class), what, n) if (n == 1) { s <- sprintf("%s element", s) } else { s <- sprintf("%s elements", s) } if (is.null(names)) { s <- sprintf("%s (unnamed)", s) } else { if (n == 0) { s <- sprintf("%s (named)", s) } else { s <- sprintf("%s (%s)", s, hpaste(sQuote(names))) } } if (ndim > 1) { dimstr <- paste(dim, collapse = "x") has_dimnames <- !sapply(dimnames, FUN = is.null) dimnames_tmp <- sapply(dimnames, FUN = function(x) hpaste(sQuote(x))) s <- sprintf("%s arranged in %s", s, dimstr) if (ndim == 2) { if (is.null(dimnames)) { s <- sprintf("%s unnamed rows and columns", s, dimstr) } else { if (all(has_dimnames)) { s <- sprintf("%s rows (%s) and columns (%s)", s, dimnames_tmp[1L], dimnames_tmp[2L]) } else if (has_dimnames[1]) { s <- sprintf("%s rows (%s) and unnamed columns", s, dimnames_tmp[1L]) } else if (has_dimnames[2]) { s <- sprintf("%s unnamed rows and columns (%s)", s, dimnames_tmp[2L]) } else { s <- sprintf("%s unnamed rows and columns", s, dimstr) } } } else { if (is.null(dimnames)) { s <- sprintf("%s unnamed dimensions", s) } else { dimnames_tmp[!has_dimnames] <- "NULL" dimnames_tmp <- sprintf("#%d: %s", seq_along(dimnames_tmp), dimnames_tmp) dimnames_tmp <- paste(dimnames_tmp, collapse = "; ") if (all(has_dimnames)) { s <- sprintf("%s dimensions (%s)", s, dimnames_tmp) } else if (!any(has_dimnames)) { s <- sprintf("%s unnamed dimensions", s) } else { s <- sprintf("%s partially named dimensions (%s)", s, dimnames_tmp) } } } } s <- sprintf("%s.\n", s) cat(s) } #' Variable name map for elements of list environment #' #' @param x A list environment. #' #' @return A named character vector #' #' @details #' _Functions `map()` and `map<-()` have been renamed to `mapping()` and #' `mapping<-()`. The former will soon become deprecated and eventually #' defunct. Please update accordingly._ #' #' @aliases mapping.listenv #' @aliases map.listenv #' @export #' @keywords internal mapping <- function(x, ...) { get(".listenv.map", envir = parent.env(x), inherits = FALSE) } #' @rdname mapping #' @export #' @keywords internal map <- mapping `mapping<-` <- function(x, value) { stop_if_not(is.character(value)) assign(".listenv.map", value, envir = parent.env(x), inherits = FALSE) invisible(x) } #' Number of elements in list environment #' #' @param x A list environment. #' #' @aliases lengths.listenv #' @export #' @keywords internal length.listenv <- function(x) { length(mapping(x)) } ## BACKPORT / WORKAROUND: ## lengths() was introduced in R 3.2.0, but only became a generic in R 3.3.0. ## Since this packages is supported on R (>= 3.1.2), declaring above methods ## as S3method() in the NAMESPACE would given an error on R (< 3.2.0). ## Because of this, lengths() is declared as a generic if missing, i.e. ## in R (< 3.2.0). This will make lengths() for list environments to work ## with R (<= 3.2.0) and R (>= 3.3.0) but not with R 3.2.x versions. if (!exists("lengths", mode = "function")) { lengths <- function(x, use.names = FALSE) UseMethod("lengths") #nolint } #' @export `length<-.listenv` <- function(x, value) { map <- mapping(x) n <- length(map) value <- as.numeric(value) if (value < 0) stop("Cannot set a negative length") ## Nothing to do? if (value == n) return(invisible(x)) ## Expand or shrink? if (value > n) { ## Add place holders for added elements extra <- rep(NA_character_, times = value - n) map <- c(map, extra) } else { ## Drop existing variables drop <- (value + 1):n var <- map[drop] ## Some may be internal place holders var <- var[!is.na(var)] if (length(var) > 0) remove(list = var, envir = x, inherits = FALSE) map <- map[-drop] } mapping(x) <- map invisible(x) } #' Names of elements in list environment #' #' @param x A list environment. #' #' @aliases names<-.listenv #' @export #' @keywords internal names.listenv <- function(x) { names(mapping(x)) } #' @export `names<-.listenv` <- function(x, value) { map <- mapping(x) if (is.null(value)) { } else if (length(value) != length(map)) { stopf("The number of names does not match the number of elements: %s != %s", length(value), length(map)) } names(map) <- value mapping(x) <- map invisible(x) } #' @exportS3Method lengths listenv lengths.listenv <- function(x, use.names = TRUE) { #nolint ns <- lapply(x, FUN = length) if (length(ns) == 0L) return(integer(0L)) unlist(ns, use.names = use.names) } #' List representation of a list environment #' #' @param x A list environment. #' #' @param all.names If `TRUE`, variable names starting with a period are #' included, otherwise not. #' #' @param sorted If `TRUE`, elements are ordered by their names before being #' compared, otherwise not. #' #' @param ... Not used. #' #' @return A list. #' #' @export #' @keywords internal as.list.listenv <- function(x, all.names = TRUE, sorted = FALSE, ...) { vars <- mapping(x) nvars <- length(vars) names <- names(x) ## Drop names starting with a period if (!all.names && nvars > 0) { keep <- !grepl("^[.]", names) vars <- vars[keep] names <- names[keep] nvars <- length(vars) } ## Sort by names? if (sorted && nvars > 0) { o <- order(names) vars <- vars[o] names <- names[o] } ## Collect as a named list res <- vector("list", length = nvars) names(res) <- names if (nvars > 0) { ok <- !is.na(vars) res[ok] <- mget(vars[ok], envir = x, inherits = FALSE) } ## Set dimensions? dim <- dim(x) if (!is.null(dim)) { dim(res) <- dim dimnames(res) <- dimnames(x) names(res) <- names } res } #' Get elements of list environment #' #' @param x A list environment. #' #' @param name The name or index of the element to retrieve. #' #' @return The value of an element or `NULL` if the element does not exist. #' #' @aliases [[.listenv #' @aliases [.listenv #' @export #' @keywords internal `$.listenv` <- function(x, name) { #' @keywords internal map <- mapping(x) var <- map[name] # Non-existing variable? if (is.na(var)) return(NULL) get(var, envir = x, inherits = FALSE) } ## [[i,j,...]] -> [[idx]] to_index <- function(x, idxs) { nidxs <- length(idxs) dim <- dim(x) if (is.null(dim)) dim <- length(x) ndim <- length(dim) if (nidxs != ndim) { stopf("Incorrect number of dimensions: %d != %d", nidxs, ndim) } dimnames <- dimnames(x) idx_dimnames <- dimnames ## Indexing scale factor per dimension scale <- c(1L, cumprod(dim[-ndim])) ## Subset idx <- 1 for (kk in 1:nidxs) { i <- idxs[[kk]] ni <- length(i) if (is.character(i)) { name <- i i <- match(name, table = dimnames[[kk]]) if (anyNA(i)) { unknown <- name[is.na(i)] stopf("Unknown names for dimension #%d: %s", kk, hpaste(sQuote(unknown))) } } else if (is.logical(i)) { d <- dim[kk] ni <- length(i) if (ni > d) { stopf("Logical subscript for dimension #%d too long: %d > %d", kk, ni, d) } if (ni < d) i <- rep(i, length.out = d) i <- which(i) } else if (is.numeric(i)) { d <- dim[kk] if (any(i > d)) { stopf("Subscript for dimension #%d out of bounds [%d,%d]", kk, min(1, d), d) } if (any(i < 0)) { if (any(i > 0)) { stopf("Only 0's may be mixed with negative subscripts (dimension #%d)", kk) } ## Drop elements i <- setdiff(seq_len(d), -i) } ## Drop zeros i <- i[i != 0] } else { stopf("Invalid subscript type for dimension #%d: %s", kk, sQuote(typeof(i))) } ## Subset dimnames? if (!is.null(idx_dimnames)) { dn <- idx_dimnames[[kk]] if (!is.null(dn)) idx_dimnames[[kk]] <- dn[i] } i <- scale[kk] * (i - 1) if (kk == 1) { idx <- idx + i } else { idx <- outer(idx, i, FUN = `+`) } } # for (kk ...) ## Sanity check dim <- dim(idx) ndim <- length(dim) if (ndim != nidxs) { stopf("INTERNAL ERROR: Incompatible dimensions: %d != %d", ndim, nidxs) } ## Preserve names(dim) names(dim(idx)) <- names(dim(x)) ## Preserve dimnames dimnames(idx) <- idx_dimnames idx } #' @export `[[.listenv` <- function(x, ...) { map <- mapping(x) n <- length(map) idxs <- list(...) nidxs <- length(idxs) ## Subsetting by multiple dimensions? if (nidxs > 1L) { i <- to_index(x, idxs) } else { i <- idxs[[1L]] if (is.character(i)) { name <- i i <- match(name, table = names(map)) if (is.na(i)) return(NULL) } else if (!is.numeric(i)) { return(NextMethod()) } if (length(i) != 1L) { stop("Subsetting of more than one element at the time is not allowed for listenv's: ", length(i)) #nolint } if (i < 1L || i > n) { stopf("Subscript out of bounds [%d,%d]: %d", min(1, n), n, i, call. = FALSE) } } var <- map[i] ## Return default (NULL)? if (is.na(var) || !exists(var, envir = x, inherits = FALSE)) return(NULL) get(var, envir = x, inherits = FALSE) } #' @export `[.listenv` <- function(x, ..., drop = TRUE) { # Need to allow for implicit indices, e.g. x[1,,2] idxs <- as.list(sys.call())[-(1:2)] #nolint idxs$drop <- NULL nidxs <- length(idxs) ## Assert that subsetting has correct shape dim <- dim(x) ndim <- length(dim) if (nidxs > 1 && nidxs != ndim) { stopf("Incorrect subsetting. Expected %d dimensions but got %d", ndim, nidxs) } ## Implicitly specified dimensions missing <- sapply(idxs, FUN = function(x) { is.symbol(x) && identical("", deparse(x)) }) if (any(missing)) { if (nidxs == ndim) { envir <- parent.frame() for (kk in seq_len(ndim)) { if (missing[kk]) { idxs[[kk]] <- seq_len(dim[kk]) } else { idxs[[kk]] <- eval(idxs[[kk]], envir = envir, enclos = baseenv()) } } } else if (nidxs == 1) { if (ndim == 0) { idxs <- list(seq_len(length(x))) } else { # Special case: Preserve dimensions when x[] idxs <- lapply(dim, FUN = function(n) seq_len(n)) nidxs <- length(idxs) } } } else { envir <- parent.frame() idxs <- lapply(idxs, FUN = eval, envir = envir, enclos = baseenv()) } if (nidxs <= 1L) { i <- idxs[[1L]] } else { i <- to_index(x, idxs) } map <- mapping(x) nmap <- length(map) names <- names(map) if (is.null(i)) { i <- integer(0L) } else if (is.character(i)) { name <- i i <- match(name, table = names) } else if (is.numeric(i)) { ## Exclude elements with negative indices? if (any(i < 0)) { stop_if_not(is.null(dim(i))) if (any(i > 0)) { stop("Only 0's may be mixed with negative subscripts") } ## Drop elements i <- setdiff(seq_len(nmap), -i) } ## Drop zeros? if (is.null(dim(i))) { i <- i[i != 0] } } else if (is.logical(i)) { if (length(i) < nmap) i <- rep(i, length.out = nmap) i <- which(i) } else { return(NextMethod()) } ## Nothing to do? ni <- length(i) ## Allocate result res <- listenv() length(res) <- ni res <- structure(res, class = class(x)) if (ni > 0L) { # Add names? if (!is.null(names)) { names2 <- names[i] names2[i > nmap] <- "" names(res) <- names2 } # Ignore out-of-range indices j <- i[i <= nmap] for (kk in seq_along(j)) { value <- x[[j[kk]]] if (!is.null(value)) res[[kk]] <- value } } ## Preserve dimensions? dim <- dim(i) ndim <- length(dim) if (ndim > 1) { dimnames <- dimnames(i) ## Drop singleton dimensions? if (drop) { keep <- (dim != 1) dim <- dim[keep] dimnames <- dimnames[keep] ndim <- length(dim) } if (ndim > 1) { names <- names(res) dim(res) <- dim dimnames(res) <- dimnames names(res) <- names } } res } new_variable <- function(envir, value, create = TRUE) { count <- get(".listenv_var_count", envir = envir, inherits = FALSE) count <- count + 1L name <- sprintf(".listenv_var_%f", count) if (!missing(value)) { assign(name, value, envir = envir, inherits = FALSE) } if (create) { assign(".listenv_var_count", count, envir = envir, inherits = FALSE) } name } assign_by_name <- function(x, name, value) { ## Argument 'name': if (length(name) == 0L) { stop("Cannot assign value. Zero-length name.", call. = FALSE) } else if (length(name) > 1L) { stop("Cannot assign value. More than one name specified: ", hpaste(sQuote(name)), call. = FALSE) } else if (nchar(name) == 0L) { stop("Cannot assign value. Empty name specific: ", sQuote(name), call. = FALSE) } map <- mapping(x) names <- names(map) ## Map to an existing or a new element? if (is.element(name, names)) { var <- map[name] ## A new variable? if (is.na(var)) { var <- name map[name] <- name mapping(x) <- map } } else { var <- name ## Append to map map <- c(map, var) if (is.null(names)) names <- rep("", times = length(map)) names[length(map)] <- var names(map) <- names mapping(x) <- map } ## Assign value assign(var, value, envir = x, inherits = FALSE) invisible(x) } assign_by_index <- function(x, i, value) { ## Argument 'i': if (length(i) == 0L) { stop("Cannot assign value. Zero-length index.", call. = FALSE) } else if (length(i) > 1L) { stop("Cannot assign value. More than one index specified: ", hpaste(i), call. = FALSE) } else if (!is.finite(i)) { stop("Cannot assign value. Non-finite index: ", i, call. = FALSE) } else if (i < 1L) { stop("Cannot assign value. Non-positive index: ", i, call. = FALSE) } map <- mapping(x) n <- length(map) ## Variable name var <- map[i] ## Non-existing variable? if (is.na(var)) { ## Expand map? if (i > n) { extra <- rep(NA_character_, times = i - n) map <- c(map, extra) } ## Create internal variable map[i] <- new_variable(x, value = value) ## Update map mapping(x) <- map } else { assign(var, value, envir = x, inherits = FALSE) } invisible(x) } remove_by_name <- function(x, name) { ## Argument 'name': if (length(name) == 0L) { stop("Cannot remove element. Zero-length name.", call. = FALSE) } else if (length(name) > 1L) { stop("Cannot remove element. More than one name specified: ", hpaste(sQuote(name)), call. = FALSE) } else if (nchar(name) == 0L) { stop("Cannot remove element. Empty name specific: ", sQuote(name), call. = FALSE) } map <- mapping(x) ## Position in names map? idx <- match(name, names(map)) ## Nothing to do? if (is.na(idx)) return(invisible(x)) ## Drop internal variable, unless place holder var <- map[idx] if (!is.na(var)) remove(list = var, envir = x, inherits = FALSE) map <- map[-idx] mapping(x) <- map ## Remove dimensions names <- names(x) dim(x) <- NULL names(x) <- names invisible(x) } remove_by_index <- function(x, i) { ## Argument 'i': if (length(i) == 0L) { stop("Cannot remove element. Zero-length index.", call. = FALSE) } else if (length(i) > 1L) { stop("Cannot remove element. More than one index specified: ", hpaste(i), call. = FALSE) } else if (!is.finite(i)) { stop("Cannot remove element. Non-finite index: ", i, call. = FALSE) } else if (i < 1L) { stop("Cannot remove element. Non-positive index: ", i, call. = FALSE) } map <- mapping(x) ## Nothing to do? if (i > length(map)) return(invisible(x)) ## Drop internal variable, unless place holder var <- map[i] if (!is.na(var)) remove(list = var, envir = x, inherits = FALSE) map <- map[-i] mapping(x) <- map ## Remove dimensions names <- names(x) dim(x) <- NULL names(x) <- names invisible(x) } #' Set an element of list environment #' #' @param x A list environment. #' @param name Name or index of element #' @param value The value to assign to the element #' #' @aliases [[<-.listenv #' @aliases [<-.listenv #' @export #' @keywords internal `$<-.listenv` <- function(x, name, value) { if (is.null(value)) { remove_by_name(x, name = name) } else { assign_by_name(x, name = name, value = value) } } #' @export `[[<-.listenv` <- function(x, ..., value) { map <- mapping(x) idxs <- list(...) nidxs <- length(idxs) ## Subsetting by multiple dimensions? if (nidxs > 1L) { i <- to_index(x, idxs) } else { i <- idxs[[1L]] if (is.character(i)) { if (is.null(value)) { x <- remove_by_name(x, name = i) } else { x <- assign_by_name(x, name = i, value = value) } return(invisible(x)) } } if (is.numeric(i)) { if (is.null(value)) { x <- remove_by_index(x, i = i) } else { x <- assign_by_index(x, i = i, value = value) } } else { stopf("Subsetted [[<- assignment to listenv's is only supported for names and indices, not %s", mode(i), call. = FALSE) #nolint } return(invisible(x)) } #' @export `[<-.listenv` <- function(x, ..., value) { ## Need to allow for implicit indices, e.g. x[1,,2] idxs <- as.list(sys.call())[-(1:2)] #nolint idxs$value <- NULL nidxs <- length(idxs) ## Assert that subsetting has correct shape dim <- dim(x) ndim <- length(dim) if (nidxs > 1 && nidxs != ndim) { stopf("Incorrect subsetting. Expected %d dimensions but got %d", ndim, nidxs) } ## Implicitly specified dimensions missing <- sapply(idxs, FUN = function(x) { is.symbol(x) && identical("", deparse(x)) }) ## Drop elements from matrix or array, e.g. x[,2] <- NULL? if (ndim > 0L && nidxs > 1L && is.null(value)) { if (ndim - sum(missing) != 1L) { stop("Only one dimension at the time can be dropped when assigning NULL") } envir <- parent.frame() dimnames <- dimnames(x) array_idxs <- array(seq_along(x), dim = dim) dimnames(array_idxs) <- dimnames args <- c(list(array_idxs), idxs, list(drop = FALSE)) idxs_drop <- do.call(`[`, args = args) for (dd in which(!missing)) { idxs_dd <- idxs[[dd]] idxs_dd <- eval(idxs_dd, envir = envir, enclos = baseenv()) if (length(idxs_dd) == 0) next if (is.logical(idxs_dd)) { idxs_dd <- rep(idxs_dd, length.out = dim[dd]) idxs_dd <- which(idxs_dd) } else if (is.character(idxs_dd)) { idxs_dd <- unique(idxs_dd) idxs_dd <- match(idxs_dd, dimnames[[dd]]) } else { idxs_dd <- unique(idxs_dd) } stop_if_not(is.numeric(idxs_dd)) dim[dd] <- dim[dd] - length(idxs_dd) dimnames[[dd]] <- dimnames[[dd]][-idxs_dd] } idxs_drop <- sort(unique(idxs_drop), decreasing = TRUE) for (i in idxs_drop) x <- remove_by_index(x, i = i) dim(x) <- dim dimnames(x) <- dimnames return(invisible(x)) } if (any(missing)) { if (nidxs == ndim) { envir <- parent.frame() for (kk in seq_len(ndim)) { if (missing[kk]) { idxs[[kk]] <- seq_len(dim[kk]) } else { idxs[[kk]] <- eval(idxs[[kk]], envir = envir, enclos = baseenv()) } } } else if (nidxs == 1) { if (ndim == 0) { idxs <- list(seq_len(length(x))) } else { ## Special case: Preserve dimensions when x[] idxs <- lapply(dim, FUN = function(n) seq_len(n)) nidxs <- length(idxs) } } } else { envir <- parent.frame() idxs <- lapply(idxs, FUN = eval, envir = envir, enclos = baseenv()) } if (nidxs <= 1L) { i <- idxs[[1L]] } else { i <- to_index(x, idxs) } ni <- length(i) if (is.logical(i)) { n <- length(x) if (ni < n) i <- rep(i, length.out = n) i <- which(i) ni <- length(i) } # Nothing to do? if (ni == 0L) return(invisible(x)) if (!is.character(i) && !is.numeric(i)) { stopf("Subsetted [<- assignment to listenv's is only supported for names and indices, not %s", mode(i), call. = FALSE) #nolint } # Remove elements? if (is.null(value)) { idxs <- unique(i) if (is.character(i)) { for (i in idxs) x <- remove_by_name(x, name = i) } else if (is.numeric(i)) { idxs <- sort(idxs, decreasing = TRUE) for (i in idxs) x <- remove_by_index(x, i = i) } return(invisible(x)) } nvalue <- length(value) if (nvalue == 0L) stop("Replacement has zero length", call. = FALSE) if (ni != nvalue) { if (ni < nvalue || ni %% nvalue != 0) { warnf("Number of items to replace is not a multiple of replacement length: %d != %d", ni, nvalue, call. = FALSE) #nolint } value <- rep(value, length.out = ni) nvalue <- length(value) } if (is.character(i)) { for (kk in seq_len(ni)) { x <- assign_by_name(x, name = i[kk], value = value[[kk]]) } } else if (is.numeric(i)) { for (kk in seq_len(ni)) { x <- assign_by_index(x, i = i[kk], value = value[[kk]]) } } return(invisible(x)) } #' @export #' @method unlist listenv unlist.listenv <- function(x, recursive = TRUE, use.names = TRUE) { #nolint names <- names(x) x <- as.list(x) names(x) <- names if (recursive) { repeat { x <- unlist(x, recursive = TRUE, use.names = use.names) idxs <- unlist(lapply(x, FUN = inherits, "listenv"), use.names = FALSE) if (length(idxs) == 0L) break idxs <- which(idxs) if (length(idxs) == 0L) break for (ii in idxs) { x[[ii]] <- unlist(x[[ii]], recursive = TRUE, use.names = use.names) } } x } else { unlist(x, recursive = FALSE, use.names = use.names) } } #' @export #' @method all.equal listenv all.equal.listenv <- function(target, current, all.names = TRUE, #nolint sorted = FALSE, ...) { if (identical(target, current)) return(TRUE) ## Coerce to lists target <- as.list(target, all.names = all.names, sorted = sorted) current <- as.list(current, all.names = all.names, sorted = sorted) ## Not all as.list() methods support 'all.names' if (!all.names) { keep <- target <- target[!grepl("^[.]", names(target))] current <- current[!grepl("^[.]", names(current))] } ## Not all as.list() methods support 'sorted' if (sorted) { target <- target[order(names(target))] current <- current[order(names(current))] } all.equal(target = target, current = current, ...) } listenv/MD50000644000176200001440000000354413572274462012270 0ustar liggesusersd94b50f883d76aa2fe68835aa53bfd0d *DESCRIPTION 78b5720308ac97bcff6b2c5967eaa48a *NAMESPACE f47e3012bfc837db602db91009d8302a *NEWS 70e545972566e6dd9cc2a7b5980ec7cd *R/get_variable.R 54c1361f7c2ab2e795dce003d36f4ef1 *R/listenv,dims.R 50be4d70116678405567012075372530 *R/listenv.R 76f1abefd36739f703b7b036b5471480 *R/parse_env_subset.R 2ec37b3ab2060043dca7b51fba5c4c9b *R/undim.R 671b25a181bb247a355917b906f48f61 *R/utils.R f0c039c346a3fada84292efee0b94ae2 *build/vignette.rds ac189a88d160a4a6b84a8e85eb545ed9 *inst/WORDLIST 88cb08570dd6cbb8e8407dae713f60aa *inst/doc/listenv.html f015af3f5601cc4edbba94ba6b22046c *inst/doc/listenv.md.rsp d0ee747db6d77160279efee9eb1095a2 *man/as.list.listenv.Rd e982f217717067d8d387d986c26a2cb0 *man/cash-.listenv.Rd 2f0c1f9924fcc9be1f525db06d358029 *man/cash-set-.listenv.Rd ec16ea2bc816320ab4099b0bab976097 *man/dim_na.Rd 40ba9fe89ca43bb995bccdd19ac654b3 *man/get_variable.Rd dd41089372b2fbe6a1019020df8ada6e *man/length.listenv.Rd a4077b97ea4182f8545cd656c0863939 *man/listenv.Rd fe54120d9bc3823216510e4cdd34a35d *man/mapping.Rd 361f77ca1970aa55addc8c003bdf3ef9 *man/names.listenv.Rd b66985730293af0a2cb4926836e2c350 *man/parse_env_subset.Rd 83f5fee7ceddd87977f7849486e717e9 *man/undim.Rd 72cc0e7ed2f3d1307974ff4ef27ff7d3 *tests/as.listenv.R bdb6dad63097428284bd1c6a590f96c6 *tests/as.vector.R 13d347b56fabf7522074617f051b7d89 *tests/get_variable,dimensions.R 80c829a17974e18b842de059842e0ce2 *tests/get_variable.R 46d2a686fd2df5c7221df82f195325b8 *tests/lapply.R 18422f518a4d9d524ec63f95d07b62e8 *tests/listenv,dimensions.R b9bfce7ffc4b41ea4674955e59490344 *tests/listenv.R 8379d75ef3eb253ff36eff3e9c2f8d86 *tests/parse_env_subset,dimensions.R e0c7d8f0d69609c86f3af85a8a460f39 *tests/parse_env_subset.R f43afb9f46e3c16246cfe8dc100c8fc4 *tests/undim.R e9657f065540b68b2b25eeacd2903b59 *tests/utils.R f015af3f5601cc4edbba94ba6b22046c *vignettes/listenv.md.rsp listenv/inst/0000755000176200001440000000000013572257030012717 5ustar liggesuserslistenv/inst/doc/0000755000176200001440000000000013572257030013464 5ustar liggesuserslistenv/inst/doc/listenv.md.rsp0000644000176200001440000002340413572226030016274 0ustar liggesusers<%@meta language="R-vignette" content="-------------------------------- %\VignetteIndexEntry{List Environments} %\VignetteAuthor{Henrik Bengtsson} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{listenv} %\VignetteEngine{R.rsp::rsp} %\VignetteTangle{FALSE} --------------------------------------------------------------------"%> <% R.utils::use("R.utils") use("listenv") options("withCapture/newline" = FALSE) %> # <%@meta name="title"%> ## Summary _List environments_ are environments that have list-like properties. They are implemented by the [listenv] package. The main features of a list environment are summarized in the below table: | Property | list environments | lists | environments | |------------------------------------------------------------------------------|:-----------------:|:------:|:------------:| | Number of elements, e.g. `length()` | yes | yes | yes | | Named elements, e.g. `names()`, `x$a` and `x[["a"]]` | yes | yes | yes | | Duplicated names | yes | yes | | | Element names are optional | yes | yes | | | Indexed elements, e.g. `x[[4]]` | yes | yes | | | Dimensions, e.g. `dim(x)` | yes | yes | | | Names of dimensions, e.g. `dimnames(x)` | yes | yes | | | Indexing by dimensions, e.g. `x[[2, 4]]` and `x[[2, "D"]]` | yes | yes | | | Multi-element subsetting, e.g. `x[c("a", "c")]`, `x[-1]` and `x[2:1, , 3]` | yes | yes | | | Multi-element subsetting preserves element names | yes | | | | Removing elements by assigning NULL, e.g. `x$c <- NULL` and `x[1:3] <- NULL` | yes | yes | | | Removing parts of dimensions by assigning NULL, e.g. `x[,2] <- NULL` | yes | | | | Mutable, e.g. `y <- x; y$a <- 3; identical(y, x)` | yes | | yes | | Compatible* with `assign()`, `delayedAssign()`, `get()` and `exists()` | yes | | yes | For example, ```r <%=withCapture({ x <- listenv(a = 1, b = 2, c = "hello") x length(x) names(x) x$a x[[3]] <- toupper(x[[3]]) x$c y <- x y$d <- y$a + y[["b"]] names(y)[2] <- "a" y$a y identical(y, x) for (ii in seq_along(x)) { cat(sprintf("Element %d (%s): %s\n", ii, sQuote(names(x)[ii]), x[[ii]])) } x[c(1, 3)] <- list(2, "Hello world!") x y <- as.list(x) str(y) z <- as.listenv(y) z identical(z, x) all.equal(z, x) })%> ``` ## Creating list environments List environments are created similarly to lists but also similarly to environments. To create an empty list environment, use ```r <%=withCapture({ x <- listenv() x })%> ``` This can later can be populated using named assignments, ```r <%=withCapture({ x$a <- 1 x })%> ``` comparable to how both lists and environments work. Similarly to lists, they can also be populated using indices, e.g. ```r <%=withCapture({ x[[2]] <- 2 x$c <- 3 x })%> ``` Just as for lists, a list environment is expanded with `NULL` elements whenever a new element is added that is beyond the current length plus one, e.g. ```r <%=withCapture({ x[[5]] <- 5 x x[[4]] })%> ``` As with lists, the above list environment can also be created from the start, e.g. ```r <%=withCapture({ x <- listenv(a = 1, 3, c = 4, NULL, 5) x })%> ``` As for lists, the length of a list environment can at any time be increased or decreased by assigning it a new length. If decreased, elements are dropped, e.g. ```r <%=withCapture({ x length(x) <- 2 x x[[1]] x[[2]] })%> ``` If increased, new elements are populated with unnamed elements of `NULL`, e.g. ```r <%=withCapture({ length(x) <- 4 x x[[3]] x[[4]] })%> ``` To allocate an "empty" list environment (with all `NULL`:s) of a given length, do ```r <%=withCapture({ x <- listenv() length(x) <- 4 x })%> ``` _Note_: Unfortunately, it is _not_ possible to use `x <- vector("listenv", length = 4)`; that construct is only supported for the basic data types. Elements can be dropped by assigning `NULL`, e.g. to drop the first and third element of a list environment, do: ```r <%=withCapture({ x[c(1, 3)] <- NULL x })%> ``` ## Iterating over elements ### Iterating over elements by names Analogously to lists and plain environments, it is possible to iterate over elements of list environments by the element names. For example, ```r <%=withCapture({ x <- listenv(a = 1, b = 2, c = 3) for (name in names(x)) { cat(sprintf("Element %s: %s\n", sQuote(name), x[[name]])) } })%> ``` ### Iterating over elements by indices Analogously to lists, but contrary to plain environments, it is also possible to iterate over elements by their indices. For example, ```r <%=withCapture({ x <- listenv(a = 1, b = 2, c = 3) for (ii in seq_along(x)) { cat(sprintf("Element %d: %s\n", ii, x[[ii]])) } })%> ``` ## Coercion to and from list environments ### Coercing to lists and vectors Coercing a list environment to a list: ```r <%=withCapture({ x <- listenv(a = 2, b = 3, c = "hello") x y <- as.list(x) str(y) })%> ``` Coercing a list to a list environment: ```r <%=withCapture({ z <- as.listenv(y) z identical(z, x) all.equal(z, x) })%> ``` Unlisting: ```r <%=withCapture({ unlist(x) unlist(x[-3]) unlist(x[1:2], use.names=FALSE) })%> ``` ## Multi-dimensional list environments Analogously to lists, and contrary to plain environments, list environments can have dimensions with corresponding names. For example, ```r <%=withCapture({ x <- as.listenv(1:6) dim(x) <- c(2, 3) dimnames(x) <- list(c("a", "b"), c("A", "B","C")) x })%> ``` An easy way to quickly get an overview is to coerce to a list, e.g. ```r <%=withCapture({ as.list(x) })%> ``` Individual elements of a list environment can be accessed using standard subsetting syntax, e.g. ```r <%=withCapture({ x[["a", "B"]] x[[1, 2]] x[[1, "B"]] })%> ``` We can assign individual elements similarly, e.g. ```r <%=withCapture({ x[["b", "B"]] <- -x[["b", "B"]] as.list(x) })%> ``` We can also assign multiple elements through dimensional subsetting, e.g. ```r <%=withCapture({ x[2, -1] <- 98:99 as.list(x) x["a", c(1, 3)] <- list(97, "foo") as.list(x) x[] <- 1:6 as.list(x) })%> ``` Concurrently with dimensional names it is possible to have names of the individual elements just as for list environments without dimensions. For example, ```r <%=withCapture({ names(x) <- letters[seq_along(x)] x x[["a"]] x[["f"]] x[c("a", "f")] unlist(x) as.list(x) })%> ``` Contrary to lists, element names are preserved also with multi-dimensional subsetting, e.g. ```r <%=withCapture({ x[1, 2] x[1, 2, drop = FALSE] x[1:2, 2:1] x[2, ] x[2, , drop = FALSE] x["b", -2, drop = FALSE] })%> ``` Note, whenever dimensions are set using `dim(x) <- dims` both the dimensional names and the element names are removed, e.g. ```r > dim(x) <- NULL > names(x) NULL ``` This behavior is by design, cf. `help("dim", package="base")`. To allocate an "empty" list environment array (with all `NULL`:s) of a given dimension, do ```r <%=withCapture({ x <- listenv() dim(x) <- c(2, 3) dimnames(x) <- list(c("a", "b"), c("A", "B", "C")) x })%> ``` Rows and columns can be dropped by assigning `NULL`, e.g. to drop the first and third column of a list-environment matrix, do: ```r <%=withCapture({ x[, c(1, 3)] <- NULL x })%> ``` <%--- Because of this, the listenv package provides the `undim()` function, which removes the dimensions but preserves the names, e.g. ```r <%=withCapture({ x <- undim(x) names(x) })%> ``` _Warning_: Since list environments _and their attributes_ are mutable, calling ```r undim(x) ``` will have the same effect as ```r x <- undim(x) ``` That is, the dimension attributes of `x` will be changed. The reason for this is explained in Section 'Important about environments' above. ---%> ## Important about environments List environments are as their name suggests _environments_. Whenever working with environments in R, it is important to understand that _environments are mutable_ whereas all other of the basic data types in R are immutable. For example, consider the following function that assigns zero to element `a` of object `x`: ```r <%=withCapture({ setA <- function(x) { x$a <- 0 x } })%> ``` If we pass a regular list to this function, ```r <%=withCapture({ x <- list(a = 1) y <- setA(x) x$a y$a })%> ``` we see that `x` is unaffected by the assignment. This is because _lists are immutable_ in R. However, if we pass an environment instead, ```r <%=withCapture({ x <- new.env() x$a <- 1 y <- setA(x) x$a y$a })%> ``` we find that `x` was affected by the assignment. This is because _environments are mutable_ in R. Since list environments inherits from environments, this also goes for them, e.g. ```r <%=withCapture({ x <- listenv(a = 1) y <- setA(x) x$a y$a })%> ``` What is also important to understand is that it is not just the _content_ of an environment that is mutable but also its _attributes_. For example, ```r <%=withCapture({ x <- listenv(a = 1) y <- x attr(y, "foo") <- "Hello!" attr(x, "foo") })%> ``` More importantly, since dimensions and their names are also attributes, this also means they are mutable. For example, ```r <%=withCapture({ x <- as.listenv(1:6) dim(x) <- c(2, 3) x y <- x dim(y) <- c(3, 2) x })%> ``` [listenv]: https://cran.r-project.org/package=listenv --- Copyright Henrik Bengtsson, 2015-2018 listenv/inst/doc/listenv.html0000644000176200001440000006733213572257030016051 0ustar liggesusers List Environments

List Environments

Summary

List environments are environments that have list-like properties. They are implemented by the listenv package. The main features of a list environment are summarized in the below table:

Property list environments lists environments
Number of elements, e.g. length() yes yes yes
Named elements, e.g. names(), x$a and x[["a"]] yes yes yes
Duplicated names yes yes
Element names are optional yes yes
Indexed elements, e.g. x[[4]] yes yes
Dimensions, e.g. dim(x) yes yes
Names of dimensions, e.g. dimnames(x) yes yes
Indexing by dimensions, e.g. x[[2, 4]] and x[[2, "D"]] yes yes
Multi-element subsetting, e.g. x[c("a", "c")], x[-1] and x[2:1, , 3] yes yes
Multi-element subsetting preserves element names yes
Removing elements by assigning NULL, e.g. x$c <- NULL and x[1:3] <- NULL yes yes
Removing parts of dimensions by assigning NULL, e.g. x[,2] <- NULL yes
Mutable, e.g. y <- x; y$a <- 3; identical(y, x) yes yes
Compatible* with assign(), delayedAssign(), get() and exists() yes yes

For example,

> x <- listenv(a = 1, b = 2, c = "hello")
> x
A ‘listenv’ vector with 3 elements (‘a’, ‘b’, ‘c’).
> length(x)
[1] 3
> names(x)
[1] "a" "b" "c"
> x$a
[1] 1
> x[[3]] <- toupper(x[[3]])
> x$c
[1] "HELLO"
> y <- x
> y$d <- y$a + y[["b"]]
> names(y)[2] <- "a"
> y$a
[1] 1
> y
A ‘listenv’ vector with 4 elements (‘a’, ‘a’, ‘c’, ‘d’).
> identical(y, x)
[1] TRUE
> for (ii in seq_along(x)) {
+     cat(sprintf("Element %d (%s): %s\n", ii, sQuote(names(x)[ii]), 
+         x[[ii]]))
+ }
Element 1 (‘a’): 1
Element 2 (‘a’): 2
Element 3 (‘c’): HELLO
Element 4 (‘d’): 3
> x[c(1, 3)] <- list(2, "Hello world!")
> x
A ‘listenv’ vector with 4 elements (‘a’, ‘a’, ‘c’, ‘d’).
> y <- as.list(x)
> str(y)
List of 4
 $ a: num 2
 $ a: num 2
 $ c: chr "Hello world!"
 $ d: num 3
> z <- as.listenv(y)
> z
A ‘listenv’ vector with 4 elements (‘a’, ‘a’, ‘c’, ‘d’).
> identical(z, x)
[1] FALSE
> all.equal(z, x)
[1] TRUE

Creating list environments

List environments are created similarly to lists but also similarly to environments. To create an empty list environment, use

> x <- listenv()
> x
A ‘listenv’ vector with 0 elements (unnamed).

This can later can be populated using named assignments,

> x$a <- 1
> x
A ‘listenv’ vector with 1 element (‘a’).

comparable to how both lists and environments work. Similarly to lists, they can also be populated using indices, e.g.

> x[[2]] <- 2
> x$c <- 3
> x
A ‘listenv’ vector with 3 elements (‘a’, ‘’, ‘c’).

Just as for lists, a list environment is expanded with NULL elements whenever a new element is added that is beyond the current length plus one, e.g.

> x[[5]] <- 5
> x
A ‘listenv’ vector with 5 elements (‘a’, ‘’, ‘c’, ‘’, ‘’).
> x[[4]]
NULL

As with lists, the above list environment can also be created from the start, e.g.

> x <- listenv(a = 1, 3, c = 4, NULL, 5)
> x
A ‘listenv’ vector with 5 elements (‘a’, ‘’, ‘c’, ‘’, ‘’).

As for lists, the length of a list environment can at any time be increased or decreased by assigning it a new length. If decreased, elements are dropped, e.g.

> x
A ‘listenv’ vector with 5 elements (‘a’, ‘’, ‘c’, ‘’, ‘’).
> length(x) <- 2
> x
A ‘listenv’ vector with 2 elements (‘a’, ‘’).
> x[[1]]
[1] 1
> x[[2]]
[1] 3

If increased, new elements are populated with unnamed elements of NULL, e.g.

> length(x) <- 4
> x
A ‘listenv’ vector with 4 elements (‘a’, ‘’, ‘’, ‘’).
> x[[3]]
NULL
> x[[4]]
NULL

To allocate an “empty” list environment (with all NULL:s) of a given length, do

> x <- listenv()
> length(x) <- 4
> x
A ‘listenv’ vector with 4 elements (unnamed).

Note: Unfortunately, it is not possible to use x <- vector("listenv", length = 4); that construct is only supported for the basic data types.

Elements can be dropped by assigning NULL, e.g. to drop the first and third element of a list environment, do:

> x[c(1, 3)] <- NULL
> x
A ‘listenv’ vector with 2 elements (unnamed).

Iterating over elements

Iterating over elements by names

Analogously to lists and plain environments, it is possible to iterate over elements of list environments by the element names. For example,

> x <- listenv(a = 1, b = 2, c = 3)
> for (name in names(x)) {
+     cat(sprintf("Element %s: %s\n", sQuote(name), x[[name]]))
+ }
Element ‘a’: 1
Element ‘b’: 2
Element ‘c’: 3

Iterating over elements by indices

Analogously to lists, but contrary to plain environments, it is also possible to iterate over elements by their indices. For example,

> x <- listenv(a = 1, b = 2, c = 3)
> for (ii in seq_along(x)) {
+     cat(sprintf("Element %d: %s\n", ii, x[[ii]]))
+ }
Element 1: 1
Element 2: 2
Element 3: 3

Coercion to and from list environments

Coercing to lists and vectors

Coercing a list environment to a list:

> x <- listenv(a = 2, b = 3, c = "hello")
> x
A ‘listenv’ vector with 3 elements (‘a’, ‘b’, ‘c’).
> y <- as.list(x)
> str(y)
List of 3
 $ a: num 2
 $ b: num 3
 $ c: chr "hello"

Coercing a list to a list environment:

> z <- as.listenv(y)
> z
A ‘listenv’ vector with 3 elements (‘a’, ‘b’, ‘c’).
> identical(z, x)
[1] FALSE
> all.equal(z, x)
[1] TRUE

Unlisting:

> unlist(x)
      a       b       c 
    "2"     "3" "hello" 
> unlist(x[-3])
a b 
2 3 
> unlist(x[1:2], use.names = FALSE)
[1] 2 3

Multi-dimensional list environments

Analogously to lists, and contrary to plain environments, list environments can have dimensions with corresponding names. For example,

> x <- as.listenv(1:6)
> dim(x) <- c(2, 3)
> dimnames(x) <- list(c("a", "b"), c("A", "B", "C"))
> x
A ‘listenv’ matrix with 6 elements (unnamed) arranged in 2x3 rows (‘a’, ‘b’) and columns (‘A’, ‘B’, ‘C’).

An easy way to quickly get an overview is to coerce to a list, e.g.

> as.list(x)
  A B C
a 1 3 5
b 2 4 6

Individual elements of a list environment can be accessed using standard subsetting syntax, e.g.

> x[["a", "B"]]
[1] 3
> x[[1, 2]]
[1] 3
> x[[1, "B"]]
[1] 3

We can assign individual elements similarly, e.g.

> x[["b", "B"]] <- -x[["b", "B"]]
> as.list(x)
  A B  C
a 1 3  5
b 2 -4 6

We can also assign multiple elements through dimensional subsetting, e.g.

> x[2, -1] <- 98:99
> as.list(x)
  A B  C 
a 1 3  5 
b 2 98 99
> x["a", c(1, 3)] <- list(97, "foo")
> as.list(x)
  A  B  C    
a 97 3  "foo"
b 2  98 99   
> x[] <- 1:6
> as.list(x)
  A B C
a 1 3 5
b 2 4 6

Concurrently with dimensional names it is possible to have names of the individual elements just as for list environments without dimensions. For example,

> names(x) <- letters[seq_along(x)]
> x
A ‘listenv’ matrix with 6 elements (‘a’, ‘b’, ‘c’, ..., ‘f’) arranged in 2x3 rows (‘a’, ‘b’) and columns (‘A’, ‘B’, ‘C’).
> x[["a"]]
[1] 1
> x[["f"]]
[1] 6
> x[c("a", "f")]
A ‘listenv’ vector with 2 elements (‘a’, ‘f’).
> unlist(x)
a b c d e f 
1 2 3 4 5 6 
> as.list(x)
  A B C
a 1 3 5
b 2 4 6
attr(,"names")
[1] "a" "b" "c" "d" "e" "f"

Contrary to lists, element names are preserved also with multi-dimensional subsetting, e.g.

> x[1, 2]
A ‘listenv’ vector with 1 element (‘c’).
> x[1, 2, drop = FALSE]
A ‘listenv’ matrix with 1 element (‘c’) arranged in 1x1 rows (‘a’) and columns (‘B’).
> x[1:2, 2:1]
A ‘listenv’ matrix with 4 elements (‘c’, ‘d’, ‘a’, ‘b’) arranged in 2x2 rows (‘a’, ‘b’) and columns (‘B’, ‘A’).
> x[2, ]
A ‘listenv’ vector with 3 elements (‘b’, ‘d’, ‘f’).
> x[2, , drop = FALSE]
A ‘listenv’ matrix with 3 elements (‘b’, ‘d’, ‘f’) arranged in 1x3 rows (‘b’) and columns (‘A’, ‘B’, ‘C’).
> x["b", -2, drop = FALSE]
A ‘listenv’ matrix with 2 elements (‘b’, ‘f’) arranged in 1x2 rows (‘b’) and columns (‘A’, ‘C’).

Note, whenever dimensions are set using dim(x) <- dims both the dimensional names and the element names are removed, e.g.

> dim(x) <- NULL
> names(x)
NULL

This behavior is by design, cf. help("dim", package="base").

To allocate an “empty” list environment array (with all NULL:s) of a given dimension, do

> x <- listenv()
> dim(x) <- c(2, 3)
> dimnames(x) <- list(c("a", "b"), c("A", "B", "C"))
> x
A ‘listenv’ matrix with 6 elements (unnamed) arranged in 2x3 rows (‘a’, ‘b’) and columns (‘A’, ‘B’, ‘C’).

Rows and columns can be dropped by assigning NULL, e.g. to drop the first and third column of a list-environment matrix, do:

> x[, c(1, 3)] <- NULL
> x
A ‘listenv’ matrix with 2 elements (unnamed) arranged in 2x1 rows (‘a’, ‘b’) and columns (‘B’).

Important about environments

List environments are as their name suggests environments. Whenever working with environments in R, it is important to understand that environments are mutable whereas all other of the basic data types in R are immutable. For example, consider the following function that assigns zero to element a of object x:

> setA <- function(x) {
+     x$a <- 0
+     x
+ }

If we pass a regular list to this function,

> x <- list(a = 1)
> y <- setA(x)
> x$a
[1] 1
> y$a
[1] 0

we see that x is unaffected by the assignment. This is because lists are immutable in R. However, if we pass an environment instead,

> x <- new.env()
> x$a <- 1
> y <- setA(x)
> x$a
[1] 0
> y$a
[1] 0

we find that x was affected by the assignment. This is because environments are mutable in R. Since list environments inherits from environments, this also goes for them, e.g.

> x <- listenv(a = 1)
> y <- setA(x)
> x$a
[1] 0
> y$a
[1] 0

What is also important to understand is that it is not just the content of an environment that is mutable but also its attributes. For example,

> x <- listenv(a = 1)
> y <- x
> attr(y, "foo") <- "Hello!"
> attr(x, "foo")
[1] "Hello!"

More importantly, since dimensions and their names are also attributes, this also means they are mutable. For example,

> x <- as.listenv(1:6)
> dim(x) <- c(2, 3)
> x
A ‘listenv’ matrix with 6 elements (unnamed) arranged in 2x3 unnamed rows and columns.
> y <- x
> dim(y) <- c(3, 2)
> x
A ‘listenv’ matrix with 6 elements (unnamed) arranged in 3x2 unnamed rows and columns.

Copyright Henrik Bengtsson, 2015-2018

listenv/inst/WORDLIST0000644000176200001440000000003313572226030014101 0ustar liggesusersAppVeyor CMD macOS pre Pre