This is an automated email from the git hooks/post-receive script. misterc-guest pushed a commit to branch master in repository r-cran-listenv.
commit c6f21a0ffcd603259935be97b2e29c565233eed7 Author: Michael R. Crusoe <[email protected]> Date: Sat Jun 25 16:14:33 2016 -0700 Imported Upstream version 0.6.0 --- DESCRIPTION | 20 + MD5 | 31 ++ NAMESPACE | 33 ++ NEWS | 65 +++ R/get_variable.R | 87 ++++ R/listenv.R | 960 ++++++++++++++++++++++++++++++++++++ R/parse_env_subset.R | 269 ++++++++++ R/undim.R | 34 ++ R/utils.R | 33 ++ build/vignette.rds | Bin 0 -> 230 bytes inst/doc/listenv.html | 642 ++++++++++++++++++++++++ inst/doc/listenv.md.rsp | 360 ++++++++++++++ man/as.list.listenv.Rd | 27 + man/cash-.listenv.Rd | 22 + man/cash-set-.listenv.Rd | 21 + man/get_variable.Rd | 27 + man/length.listenv.Rd | 16 + man/listenv.Rd | 33 ++ man/map.Rd | 20 + man/names.listenv.Rd | 17 + man/parse_env_subset.Rd | 24 + man/undim.Rd | 27 + tests/as.listenv.R | 33 ++ tests/get_variable,dimensions.R | 38 ++ tests/get_variable.R | 100 ++++ tests/listenv,dimensions.R | 303 ++++++++++++ tests/listenv.R | 692 ++++++++++++++++++++++++++ tests/parse_env_subset,dimensions.R | 105 ++++ tests/parse_env_subset.R | 222 +++++++++ tests/undim.R | 33 ++ tests/utils.R | 43 ++ vignettes/listenv.md.rsp | 360 ++++++++++++++ 32 files changed, 4697 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000..4960961 --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,20 @@ +Package: listenv +Version: 0.6.0 +Depends: R (>= 3.1.2) +Suggests: R.utils, R.rsp +VignetteBuilder: R.rsp +Title: Environments Behaving (Almost) as Lists +Authors@R: c(person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"), + email = "[email protected]")) +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: 5.0.1 +NeedsCompilation: no +Packaged: 2015-12-27 23:02:54 UTC; hb +Author: Henrik Bengtsson [aut, cre, cph] +Maintainer: Henrik Bengtsson <[email protected]> +Repository: CRAN +Date/Publication: 2015-12-28 00:07:26 diff --git a/MD5 b/MD5 new file mode 100644 index 0000000..de276cf --- /dev/null +++ b/MD5 @@ -0,0 +1,31 @@ +e745d634585a29c2e525cfb3d39d59e8 *DESCRIPTION +89e15c945dcfb605128c7abdc0f68f80 *NAMESPACE +c9f8fda1ddd2984c19a67b0ce7a20210 *NEWS +f06dc34d2a1839d07cd98d30600e3c26 *R/get_variable.R +7a9462d34a31c2577bdd583fec4d052a *R/listenv.R +5fa2a45fdd2adb019d52f36b466cd268 *R/parse_env_subset.R +fe8db3909366f82cc1d31603046f0e92 *R/undim.R +0b750b7626b75191087db81e86f7e731 *R/utils.R +950222ec3362beed946618f55d5254dd *build/vignette.rds +56d74cee9b8f35a17dd7a98ab0c16e8c *inst/doc/listenv.html +43ebcd44126cb94d23ac395145ba2444 *inst/doc/listenv.md.rsp +db64844e07ab14c995f6116fcfe170df *man/as.list.listenv.Rd +aeff557461299c3b2e5bcd5968991af1 *man/cash-.listenv.Rd +3764c89fb96ace37631c81fd22a3e638 *man/cash-set-.listenv.Rd +dcd80183ea3e1c1b87b6785b59536880 *man/get_variable.Rd +90ca995bbbc8ac59ad49c3202eeed63e *man/length.listenv.Rd +957163178691b32d4a5987d96abd430c *man/listenv.Rd +f7a3e638c5ddc9075772ccc2c1604838 *man/map.Rd +563213dc5b6d707bcc0367a0321c1396 *man/names.listenv.Rd +d6870fe0e2c4089f7d483db848ab3a74 *man/parse_env_subset.Rd +cbdcda4780136f1f2a35ed42b39d8f31 *man/undim.Rd +06b8c0ea74d231f933dd0ccda150594f *tests/as.listenv.R +384d4562acfd09d1a0e8b0970d01f745 *tests/get_variable,dimensions.R +13f5f5c5c2cb4965c35f27d628463776 *tests/get_variable.R +8e40808adef445b921d0edd5b17d8ffa *tests/listenv,dimensions.R +6a67a4b0a46b2be6452fc02b33956828 *tests/listenv.R +d256b53faf4e45c2765fc8707dcdc589 *tests/parse_env_subset,dimensions.R +b76a7090fb365a74664dbb2b1ed63597 *tests/parse_env_subset.R +07e4d80d68932de4faf92db1e9058d0f *tests/undim.R +3ff218c62aa9169c129c7d4e5b6c0ec6 *tests/utils.R +43ebcd44126cb94d23ac395145ba2444 *vignettes/listenv.md.rsp diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..48d9993 --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,33 @@ +# 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(dim,listenv) +S3method(dimnames,listenv) +S3method(get_variable,listenv) +S3method(length,listenv) +S3method(names,listenv) +S3method(print,listenv) +S3method(undim,default) +S3method(undim,listenv) +S3method(unlist,listenv) +export(as.listenv) +export(get_variable) +export(listenv) +export(map) +export(parse_env_subset) +export(undim) diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..9314196 --- /dev/null +++ b/NEWS @@ -0,0 +1,65 @@ +Package: listenv +================ + +Version: 0.6.0 [2015-12-27] +o Added support for multi-dimensional subsetting of list environments + just as for list. +o BUG FIX: 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] +o Add support for assigning elements when creating list environment + similarly how to lists work, e.g. x <- listenv(a=1, b=2). +o length(x) <- n now expand/truncate a list environment. +o Added unlist() and all.equal() for list environments. +o DEPRECATED: Deprecated x <- listenv(length=n). Instead use + x <- listenv(); length(x) <- n. +o BUG FIX: as.listenv(x) would drop NULL elements in 'x'. +o BUG FIX: x[idxs], x[name] <- y and x$<name> <- y would introduce + NA names for non-named list environments. + + +Version: 0.4.0 [2015-08-08] +o Added as.listenv(). +o CONSISTENCY: Assigning NULL now removes element just as lists, + e.g. x$a <- NULL. To assign value NULL, do x['a'] <- list(NULL). +o Added support for subsetting with [(), which returns another + list environment, e.g. x[2:3], x[-1] and x[c(TRUE, FALSE)]. +o Added [<- assignment, e.g. x['a'] <- 1 and x[2:3] <- c(3,8). +o CLEANUP: Dropped stray debug code. + + +Version: 0.3.0 [2015-05-23] +o Package no longer depends on other packages. + + +Version: 0.2.4 [2015-05-22] +o Added helper function parse_env_subset(). + + +Version: 0.2.3 [2015-05-21] +o print() on listenv() handles empty and no-named listenv:s better. + + +Version: 0.2.2 [2015-05-20] +o Now listenv(length=...) always allocates internal variables. + + +Version: 0.2.1 [2015-05-19] +o get_variable() gained argument 'mustExist'. + + +Version: 0.2.0 [2015-05-19] +o Moved list environments from an in-house package to its own package. + + +Version: 0.1.4 [2015-05-02] +o Added print() for listenv:s. +o CLEANUP: Using tempvar() of R.utils. + + +Version: 0.1.0 [2015-02-07] +o Created. diff --git a/R/get_variable.R b/R/get_variable.R new file mode 100644 index 0000000..c506c04 --- /dev/null +++ b/R/get_variable.R @@ -0,0 +1,87 @@ +#' 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 \code{name} +#' does not exist. +#' @param create If TRUE, element \code{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) { + stop(sprintf("Subscript must be a scalar or of equal length as the number of dimension (%d): %d", ndim, length(name)), call.=FALSE) + } + + ## Map multi-dimensional index to scalar index + if (length(name) > 1L) { + stopifnot(is.numeric(name)) + idxs <- name + if (anyNA(idxs)) stop("Unknown index detected") + + for (kk in seq_len(ndim)) { + if (idxs[kk] < 1 || idxs[kk] > dim[kk]) { + stop(sprintf("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 <- map(x) + + ## Existing variable? + var <- map[name] + if (length(var) == 1L && !is.na(var)) return(var) + + if (mustExist) { + stop(sprintf("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) map(x) <- map + + var +} diff --git a/R/listenv.R b/R/listenv.R new file mode 100644 index 0000000..78eae4e --- /dev/null +++ b/R/listenv.R @@ -0,0 +1,960 @@ +#' 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) + + ## Add elements? + if (nargs > 0L) { + ## Backward compatibility + if (nargs == 1L && identical(names[1L], "length")) { + .Deprecated(msg="Use of x <- listenv(length=n) to allocate a list environment of length n is deprecated. Use x <- listenv(); length(x) <- n instead.") + length <- args$length + stopifnot(length >= 0L) + args <- vector("list", length=length) + nargs <- length + names <- NULL + } + } + + ## 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 (is.null(names) && n > 0) { + s <- sprintf("%s unnamed", s) + } + if (n == 1) { + s <- sprintf("%s element", s) + } else { + s <- sprintf("%s elements", s) + } + if (!is.null(names)) { + s <- sprintf("%s (%s)", s, hpaste(sQuote(names))) + } + if (ndim > 1) { + dimstr <- paste(dim, collapse="x") + hasDimnames <- !sapply(dimnames, FUN=is.null) + dimnamesT <- 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(hasDimnames)) { + s <- sprintf("%s rows (%s) and columns (%s)", s, dimnamesT[1L], dimnamesT[2L]) + } else if (hasDimnames[1]) { + s <- sprintf("%s rows (%s) and unnamed columns", s, dimnamesT[1L]) + } else if (hasDimnames[2]) { + s <- sprintf("%s unnamed rows and columns (%s)", s, dimnamesT[2L]) + } else { + s <- sprintf("%s unnamed rows and columns", s, dimstr) + } + } + } else { + if (is.null(dimnames)) { + s <- sprintf("%s unnamed dimensions", s) + } else { + dimnamesT[!hasDimnames] <- "NULL" + dimnamesT <- sprintf("#%d: %s", seq_along(dimnamesT), dimnamesT) + dimnamesT <- paste(dimnamesT, collapse="; ") + if (all(hasDimnames)) { + s <- sprintf("%s dimensions (%s)", s, dimnamesT) + } else if (!any(hasDimnames)) { + s <- sprintf("%s unnamed dimensions", s) + } else { + s <- sprintf("%s partially named dimensions (%s)", s, dimnamesT) + } + } + } + } + + s <- sprintf("%s.\n", s) + cat(s) +} + +#' Variable name map for elements of list environment +#' +#' @param x A list environment. +#' +#' @return The a named character vector +#' +#' @aliases map.listenv +#' @export +#' @keywords internal +map <- function(x, ...) { + get(".listenv.map", envir=parent.env(x), inherits=FALSE) +} + +`map<-` <- function(x, value) { + stopifnot(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. +#' +#' @export +#' @keywords internal +length.listenv <- function(x) { + length(map(x)) +} + +#' @export +`length<-.listenv` <- function(x, value) { + map <- map(x) + n <- length(map) + value <- as.numeric(value) + + if (value < 0) stop("invalid value") + + ## 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] + } + map(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(map(x)) +} + +#' @export +`names<-.listenv` <- function(x, value) { + map <- map(x) + if (is.null(value)) { + } else if (length(value) != length(map)) { + stop(sprintf("Number of names does not match the number of elements: %s != %s", length(value), length(map))) + } +## if (any(duplicated(value))) { +## stop("Environments cannot have duplicate names on elements") +## } + names(map) <- value + map(x) <- map + invisible(x) +} + +#' List representation of a list environment +#' +#' @param x A list environment. +#' @param all.names If \code{TRUE}, variable names starting with +#' a period are included, otherwise not. +#' @param sorted If \code{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 <- map(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 <- map(x) + var <- map[name] + + ## Non-existing variable? + if (is.na(var)) return(NULL) + + get(var, envir=x, inherits=FALSE) +} + + +## [[i,j,...]] -> [[idx]] +toIndex <- function(x, idxs) { + nidxs <- length(idxs) + + dim <- dim(x) + if (is.null(dim)) dim <- length(x) + ndim <- length(dim) + if (ndim != nidxs) { + stop("incorrect number of dimensions") + } + dimnames <- dimnames(x) + idxDimnames <- 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)) stop("subscript out of bounds") + } else if (is.logical(i)) { + d <- dim[kk] + ni <- length(i) + if (ni > d) stop("(subscript) logical subscript too long") + if (ni < d) i <- rep(i, length.out=d) + i <- which(i) + } else if (is.numeric(i)) { + d <- dim[kk] + if (any(i > d)) stop("subscript out of bounds") + if (any(i < 0)) { + if (any(i > 0)) { + stop("only 0's may be mixed with negative subscripts") + } + ## Drop elements + i <- setdiff(seq_len(d), -i) + } + ## Drop zeros + i <- i[i != 0] + } else { + stop("invalid subscript type", sQuote(typeof(i))) + } + + ## Subset dimnames? + if (!is.null(idxDimnames)) { + dn <- idxDimnames[[kk]] + if (!is.null(dn)) idxDimnames[[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) { + stop(sprintf("INTERNAL ERROR: Incompatible dimensions: %d != %d", ndim, nidxs)) + } + + ## Preserve names(dim) + names(dim(idx)) <- names(dim(x)) + + ## Preserve dimnames + dimnames(idx) <- idxDimnames + + + idx +} # toIndex() + + +#' @export +`[[.listenv` <- function(x, ...) { + map <- map(x) + n <- length(map) + + idxs <- list(...) + nidxs <- length(idxs) + + ## Subsetting by multiple dimensions? + if (nidxs > 1L) { + i <- toIndex(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)) + } + + if (i < 1L || i > n) { + stop(sprintf("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)] + idxs$drop <- NULL + nidxs <- length(idxs) + + ## Assert that subsetting has correct shape + dim <- dim(x) + ndim <- length(dim) + if (nidxs > 1 && nidxs != ndim) { + stop(sprintf("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) + } + } + } 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) + } + + if (nidxs <= 1L) { + i <- idxs[[1L]] + } else { + i <- toIndex(x, idxs) + } + + map <- map(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)) { + stopifnot(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 +} # new_variable() + + +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(name), call.=FALSE) + } else if (nchar(name) == 0L) { + stop("Cannot assign value. Empty name specific: ", name, call.=FALSE) + } + + map <- map(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 + map(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 + map(x) <- map + } + + ## Assign value + assign(var, value, envir=x, inherits=FALSE) + + invisible(x) +} # assign_by_name() + + +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 <- map(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 + map(x) <- map + } else { + assign(var, value, envir=x, inherits=FALSE) + } + + invisible(x) +} # assign_by_index() + + +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(name), call.=FALSE) + } else if (nchar(name) == 0L) { + stop("Cannot remove element. Empty name specific: ", name, call.=FALSE) + } + + map <- map(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] + map(x) <- map + + invisible(x) +} # remove_by_name() + + +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 <- map(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] + map(x) <- map + + invisible(x) +} # remove_by_index() + + + + +#' 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 <- map(x) + n <- length(map) + + idxs <- list(...) + nidxs <- length(idxs) + + ## Subsetting by multiple dimensions? + if (nidxs > 1L) { + i <- toIndex(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 { + stop(sprintf("Subsetted [[<- assignment to listenv's is only supported for names and indices, not %s", mode(i)), call.=FALSE) + } + + 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)] + idxs$value <- NULL + nidxs <- length(idxs) + + ## Assert that subsetting has correct shape + dim <- dim(x) + ndim <- length(dim) + if (nidxs > 1 && nidxs != ndim) { + stop(sprintf("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) + } + } + } 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) + } + + if (nidxs <= 1L) { + i <- idxs[[1L]] + } else { + i <- toIndex(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)) + + nvalue <- length(value) + if (nvalue == 0L) stop("Replacement has zero length", call.=FALSE) + + if (ni != nvalue) { + if (ni < nvalue || ni %% nvalue != 0) { + warning(sprintf("Number of items to replace is not a multiple of replacement length: %d != %d", ni, nvalue), call.=FALSE) + } + 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]]) + } + } else { + stop(sprintf("Subsetted [<- assignment to listenv's is only supported for names and indices, not %s", mode(i)), call.=FALSE) + } + return(invisible(x)) +} + + +#' @export +#' @method unlist listenv +unlist.listenv <- function(x, recursive=TRUE, use.names=TRUE) { + 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 +dim.listenv <- function(x) attr(x, "dim.") + +#' @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) { + stop(sprintf("dims [product %d] do not match the length of object [%d]", 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 +} + + +#' @export +dimnames.listenv <- function(x) attr(x, "dimnames.") + +#' @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]) { + stop(sprintf("length of 'dimnames' [%d] not equal to array extent", kk)) + } + } + attr(x, "dimnames.") <- value + x +} + +#' @export +#' @method all.equal listenv +all.equal.listenv <- function(target, current, all.names=TRUE, 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, ...) +} diff --git a/R/parse_env_subset.R b/R/parse_env_subset.R new file mode 100644 index 0000000..3a02d36 --- /dev/null +++ b/R/parse_env_subset.R @@ -0,0 +1,269 @@ +#' 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 +#' \code{substitute()}:ed, otherwise not. +#' +#' @return A named list. +#' +#' @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) { + stop(sprintf("Does not specify a single variable, but %d: %s", length(expr), hpaste(sQuote(expr), collapse=", ")), call.=FALSE) + } + res$name <- expr + } else if (is.numeric(expr)) { + ## Variable specified as a subset of envir + if (length(expr) > 1L) { + stop(sprintf("Does not specify a single index, but %d: %s", length(expr), hpaste(sQuote(expr), collapse=", ")), call.=FALSE) + } + res$subset <- list(expr) + } else { + n <- length(expr) + stopifnot(n >= 2L) + + if (n >= 3L) { + ## Assignment to enviroment 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)) { + stop(sprintf("Object %s not found: %s", sQuote(objname), sQuote(code)), call.=FALSE) + } + + obj <- get(objname, envir=envir, inherits=TRUE) + if (!is.environment(obj)) { + stop(sprintf("Subsetting can not be done on a %s; only to an environment: %s", sQuote(mode(obj)), sQuote(code)), call.=FALSE) + } + res$envir <- obj + + ## Subset + subset <- list() + for (kk in 3:n) { + missing <- (length(expr[[kk]]) == 1L) && (expr[[kk]] == "") + if (missing) { + subsetKK <- NULL + } else { + subsetKK <- expr[[kk]] + } + if (is.symbol(subsetKK)) { + subsetKK <- deparse(subsetKK) + if (op == "[[") { + if (!exists(subsetKK, envir=envir, inherits=TRUE)) { + stop(sprintf("Object %s not found: %s", sQuote(subsetKK), sQuote(code)), call.=FALSE) + } + subsetKK <- get(subsetKK, envir=envir, inherits=TRUE) + } + } else if (is.language(subsetKK)) { + subsetKK <- eval(subsetKK, envir=envir) + } + if (is.null(subsetKK)) { + subset[kk-2L] <- list(NULL) + } else { + subset[[kk-2L]] <- subsetKK + } + } + + res$subset <- subset + } # if (n >= 3) + } # if (is.symbol(expr)) + + + ## Validat 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)) { + stop(sprintf("INTERNAL ERROR (expected 'subset' to be a list): %s", sQuote(code)), call.=FALSE) + } + if (length(subset) == 0L) { + stop(sprintf("Subsetting of at least on element is required: %s", sQuote(code)), call.=FALSE) + } + + for (kk in seq_along(subset)) { + subsetKK <- subset[[kk]] + if (is.null(subsetKK)) { + } else if (any(is.na(subsetKK))) { + stop(sprintf("Invalid subsetting. Subset must not contain missing values: %s", sQuote(code)), call.=FALSE) + } else if (is.character(subsetKK)) { + if (!all(nzchar(subsetKK))) { + stop(sprintf("Invalid subset. Subset must not contain empty names: %s", sQuote(code)), call.=FALSE) + } + } else if (is.numeric(subsetKK)) { + } else { + stop(sprintf("Invalid subset of type %s: %s", sQuote(typeof(subsetKK)), sQuote(code)), call.=FALSE) + } + } # for (kk ...) + + ## Special: listenv:s + envir <- res$envir + stopifnot(is.environment(envir)) + + if (inherits(envir, "listenv")) { + names <- names(envir) + map <- map(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) + } + dimnames <- dimnames(envir) + exists <- TRUE + for (kk in seq_along(subset)) { + subsetKK <- subset[[kk]] + if (is.null(subsetKK)) { + subset[[kk]] <- seq_len(dim[kk]) + } else if (is.numeric(subsetKK)) { + exists <- exists && (subsetKK >= 1 && subsetKK <= dim[kk]) + } else if (is.character(subsetKK)) { + subsetKK <- match(subsetKK, dimnames[[kk]]) + exists <- exists && !is.na(subsetKK) + subset[[kk]] <- subsetKK + } + } + + ## 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]] + stopifnot(is.numeric(i)) + d <- dim[kk] + 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(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] + if (length(res$name) == 0L) res$name <- "" + if (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 == "[[") { + ## BACKWARD COMPATIBILITY: + ## In order not to break two `R CMD check` package tests + ## for future 0.9.0 on CRAN, we tweak the result here in + ## order for those two tests not to fail. /HB 2015-12-26 + ## FIX ME: Remove when future (> 0.9.0) is on CRAN. + if (identical(i, 0) && identical(code, "x[[0]]") && is.element("package:future", search()) && utils::packageVersion("future") <= "0.9.0") { + res$idx <- i + res$exists <- FALSE + return(res) + } + 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] + if (length(res$name) == 0L) res$name <- "" + } else if (is.character(subset)) { + res$idx <- match(subset, names) + 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 (is.character(subset)) res$name <- subset + } + + ## 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(map(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 + stopifnot(is.environment(res$envir)) + stopifnot(is.character(res$name)) + stopifnot(is.null(res$idx) || all(is.numeric(res$idx))) + stopifnot(is.logical(res$exists), !anyNA(res$exists)) + stopifnot(length(res$exists) == length(res$idx)) + + res +} diff --git a/R/undim.R b/R/undim.R new file mode 100644 index 0000000..1bfef77 --- /dev/null +++ b/R/undim.R @@ -0,0 +1,34 @@ +#' 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 \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}. +#' +#' @export +#' @aliases undim.default +#' @aliases undim.listenv +undim <- function(x, ...) UseMethod("undim") + +#' @export +undim.default <- function(x, ...) { + 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, ...) { + x <- NextMethod("undim") + attr(x, "dim.") <- NULL + attr(x, "dimnames.") <- NULL + x +} diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..937423e --- /dev/null +++ b/R/utils.R @@ -0,0 +1,33 @@ +## From R.utils 2.0.2 (2015-05-23) +hpaste <- function(..., sep="", collapse=", ", lastCollapse=NULL, maxHead=if (missing(lastCollapse)) 3 else Inf, maxTail=if (is.finite(maxHead)) 1 else Inf, abbreviate="...") { + maxHead <- as.double(maxHead) + maxTail <- as.double(maxTail) + if (is.null(lastCollapse)) lastCollapse <- 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 > maxHead + maxTail + 1) { + head <- x[seq(length=maxHead)] + tail <- rev(rev(x)[seq(length=maxTail)]) + x <- c(head, abbreviate, tail) + n <- length(x) + } + + if (!is.null(collapse) && n > 1) { + if (lastCollapse == collapse) { + x <- paste(x, collapse=collapse) + } else { + xT <- paste(x[1:(n-1)], collapse=collapse) + x <- paste(xT, x[n], sep=lastCollapse) + } + } + + x +} # hpaste() diff --git a/build/vignette.rds b/build/vignette.rds new file mode 100644 index 0000000..bd092ae Binary files /dev/null and b/build/vignette.rds differ diff --git a/inst/doc/listenv.html b/inst/doc/listenv.html new file mode 100644 index 0000000..de3fd86 --- /dev/null +++ b/inst/doc/listenv.html @@ -0,0 +1,642 @@ +<!DOCTYPE html> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8"/> + +<title>List Environments</title> + +<script type="text/javascript"> +window.onload = function() { + var imgs = document.getElementsByTagName('img'), i, img; + for (i = 0; i < imgs.length; i++) { + img = imgs[i]; + // center an image if it is the only element of its parent + if (img.parentElement.childElementCount === 1) + img.parentElement.style.textAlign = 'center'; + } +}; +</script> + +<!-- Styles for R syntax highlighter --> +<style type="text/css"> + pre .operator, + pre .paren { + color: rgb(104, 118, 135) + } + + pre .literal { + color: #990073 + } + + pre .number { + color: #099; + } + + pre .comment { + color: #998; + font-style: italic + } + + pre .keyword { + color: #900; + font-weight: bold + } + + pre .identifier { + color: rgb(0, 0, 0); + } + + pre .string { + color: #d14; + } +</style> + +<!-- R syntax highlighter --> +<script type="text/javascript"> +var hljs=new function(){function m(p){return p.replace(/&/gm,"&").replace(/</gm,"<")}function f(r,q,p){return RegExp(q,"m"+(r.cI?"i":"")+(p?"g":""))}function b(r){for(var p=0;p<r.childNodes.length;p++){var q=r.childNodes[p];if(q.nodeName=="CODE"){return q}if(!(q.nodeType==3&&q.nodeValue.match(/\s+/))){break}}}function h(t,s){var p="";for(var r=0;r<t.childNodes.length;r++){if(t.childNodes[r].nodeType==3){var q=t.childNodes[r].nodeValue;if(s){q=q.replace(/\n/g,"")}p+=q}else{if(t.chi [...] +hljs.initHighlightingOnLoad(); +</script> + + + +<style type="text/css"> +body, td { + font-family: sans-serif; + background-color: white; + font-size: 13px; +} + +body { + max-width: 800px; + margin: auto; + padding: 1em; + line-height: 20px; +} + +tt, code, pre { + font-family: 'DejaVu Sans Mono', 'Droid Sans Mono', 'Lucida Console', Consolas, Monaco, monospace; +} + +h1 { + font-size:2.2em; +} + +h2 { + font-size:1.8em; +} + +h3 { + font-size:1.4em; +} + +h4 { + font-size:1.0em; +} + +h5 { + font-size:0.9em; +} + +h6 { + font-size:0.8em; +} + +a:visited { + color: rgb(50%, 0%, 50%); +} + +pre, img { + max-width: 100%; +} +pre { + overflow-x: auto; +} +pre code { + display: block; padding: 0.5em; +} + +code { + font-size: 92%; + border: 1px solid #ccc; +} + +code[class] { + background-color: #F8F8F8; +} + +table, td, th { + border: none; +} + +blockquote { + color:#666666; + margin:0; + padding-left: 1em; + border-left: 0.5em #EEE solid; +} + +hr { + height: 0px; + border-bottom: none; + border-top-width: thin; + border-top-style: dotted; + border-top-color: #999999; +} + +@media print { + * { + background: transparent !important; + color: black !important; + filter:none !important; + -ms-filter: none !important; + } + + body { + font-size:12pt; + max-width:100%; + } + + a, a:visited { + text-decoration: underline; + } + + hr { + visibility: hidden; + page-break-before: always; + } + + pre, blockquote { + padding-right: 1em; + page-break-inside: avoid; + } + + tr, img { + page-break-inside: avoid; + } + + img { + max-width: 100% !important; + } + + @page :left { + margin: 15mm 20mm 15mm 10mm; + } + + @page :right { + margin: 15mm 10mm 15mm 20mm; + } + + p, h2, h3 { + orphans: 3; widows: 3; + } + + h2, h3 { + page-break-after: avoid; + } +} +</style> + +<meta name="keywords" content="R, package, vignette, listenv"> +<meta name="author" content="Henrik Bengtsson"> + +</head> + +<body> +<h1>List Environments</h1> + +<p><em>List environments</em> are environments that have list-like properties. They are implemented by the <a href="http://cran.r-project.org/package=listenv";>listenv</a> package. The main features of a list environment are summarized in the below table:</p> + +<table><thead> +<tr> +<th>Property</th> +<th align="center">list environments</th> +<th align="center">lists</th> +<th align="center">environments</th> +</tr> +</thead><tbody> +<tr> +<td>Number of elements, e.g. <code>length()</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center">yes</td> +</tr> +<tr> +<td>Named elements, e.g. <code>names()</code>, <code>x$a</code> and <code>x[["a"]]</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center">yes</td> +</tr> +<tr> +<td>Duplicated names</td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Indexed elements, e.g. <code>x[[4]]</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Dimensions, e.g. <code>dim(x)</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Names of dimensions, e.g. <code>dimnames(x)</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Indexing by dimensions, e.g. <code>x[[2,4]]</code> and <code>x[[2,"D"]]</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Multi-element subsetting, e.g. <code>x[c("a", "c")]</code>, <code>x[-1]</code>, <code>[2:1,,3]</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Multi-element subsetting preserves element names</td> +<td align="center">yes</td> +<td align="center"></td> +<td align="center"></td> +</tr> +<tr> +<td>Removing element by assigning NULL, e.g. <code>x$c <- NULL</code></td> +<td align="center">yes</td> +<td align="center">yes</td> +<td align="center"></td> +</tr> +<tr> +<td>Mutable, e.g. <code>y <- x; y$a <- 3; identical(y, x)</code></td> +<td align="center">yes</td> +<td align="center"></td> +<td align="center">yes</td> +</tr> +<tr> +<td>Compatible* with <code>assign()</code>, <code>delayedAssign()</code>, <code>get()</code> and <code>exists()</code></td> +<td align="center">yes</td> +<td align="center"></td> +<td align="center">yes</td> +</tr> +</tbody></table> + +<p>For example,</p> + +<pre><code class="r">> 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 +</code></pre> + +<h2>Creating list environments</h2> + +<p>List environments are created similarly to lists but also similarly to environments. To create an empty list environment, use</p> + +<pre><code class="r">> x <- listenv() +> x +A 'listenv' vector with 0 elements. +</code></pre> + +<p>This can later can be populated using named assignments,</p> + +<pre><code class="r">> x$a <- 1 +> x +A 'listenv' vector with 1 element ('a'). +</code></pre> + +<p>comparable to how both lists and environments work. Similarly to lists, they can also be populated using indices, e.g.</p> + +<pre><code class="r">> x[[2]] <- 2 +> x$c <- 3 +> x +A 'listenv' vector with 3 elements ('a', '', 'c'). +</code></pre> + +<p>Just as for lists, a list environment is expanded with <code>NULL</code> elements whenever a new element is added that is beyond the current length plus one, e.g.</p> + +<pre><code class="r">> x[[5]] <- 5 +> x +A 'listenv' vector with 5 elements ('a', '', 'c', '', ''). +> x[[4]] +NULL +</code></pre> + +<p>As with lists, the above list environment can also be created from the start, e.g.</p> + +<pre><code class="r">> x <- listenv(a = 1, 3, c = 4, NULL, 5) +> x +A 'listenv' vector with 5 elements ('a', '', 'c', '', ''). +</code></pre> + +<p>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.</p> + +<pre><code class="r">> 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 +</code></pre> + +<p>If increased, new elements are populated with unnamed elements of <code>NULL</code>, e.g.</p> + +<pre><code class="r">> length(x) <- 4 +> x +A 'listenv' vector with 4 elements ('a', '', '', ''). +> x[[3]] +NULL +> x[[4]] +NULL +</code></pre> + +<p>To allocate an “empty” list environment (with all <code>NULL</code>:s) of a given length, do</p> + +<pre><code class="r">> x <- listenv() +> length(x) <- 4 +> x +A 'listenv' vector with 4 unnamed elements. +</code></pre> + +<p><em>Note</em>: Unfortunately, it is <em>not</em> possible to use <code>x <- vector("listenv", length=4)</code>; that construct is only supported for the basic data types.</p> + +<h2>Iterating over elements</h2> + +<h3>Iterating over elements by names</h3> + +<p>Analogously to lists and plain environments, it is possible to iterate over elements of list environments by the element names. For example,</p> + +<pre><code class="r">> 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 +</code></pre> + +<h3>Iterating over elements by indices</h3> + +<p>Analogously to lists, but contrary to plain environments, it is also possible to iterate over elements by their indices. For example,</p> + +<pre><code class="r">> 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 +</code></pre> + +<h2>Coercion to and from list environments</h2> + +<h3>Coercing to lists and vectors</h3> + +<p>Coercing a list environment to a list:</p> + +<pre><code class="r">> 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" +</code></pre> + +<p>Coercing a list to a list environment:</p> + +<pre><code class="r">> 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 +</code></pre> + +<p>Unlisting:</p> + +<pre><code class="r">> 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 +</code></pre> + +<h2>Multi-dimensional list environments</h2> + +<p>Analogously to lists, and contrary to plain environments, list environments can have dimensions with corresponding names. For example,</p> + +<pre><code class="r">> 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 unnamed elements arranged in 2x3 rows ('a', 'b') and columns ('A', 'B', 'C'). +</code></pre> + +<p>An easy way to quickly get an overview is to coerce to a list, e.g.</p> + +<pre><code class="r">> as.list(x) + A B C +a 1 3 5 +b 2 4 6 +</code></pre> + +<p>Individual elements of a list environment can be accessed using standard subsetting syntax, e.g.</p> + +<pre><code class="r">> x[["a", "B"]] +[1] 3 +> x[[1, 2]] +[1] 3 +> x[[1, "B"]] +[1] 3 +</code></pre> + +<p>We can assign individual elements similarly, e.g.</p> + +<pre><code class="r">> x[["b", "B"]] <- -x[["b", "B"]] +> as.list(x) + A B C +a 1 3 5 +b 2 -4 6 +</code></pre> + +<p>We can also assign multiple elements through dimensional subsetting, e.g.</p> + +<pre><code class="r">> 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 +</code></pre> + +<p>Concurrently with dimensional names it is possible to have names of the invidual elements just as for list environments without dimensions. For example,</p> + +<pre><code class="r">> 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 +</code></pre> + +<p>Contrary to lists, element names are preserved also with multi-dimensional subsetting, e.g.</p> + +<pre><code class="r">> 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'). +</code></pre> + +<p>Note, whenever dimensions are set using <code>dim(x) <- dims</code> both the dimensional names and the element names are removed, e.g.</p> + +<pre><code class="r">> dim(x) <- NULL +> names(x) +NULL +</code></pre> + +<p>This behavior is by design, cf. <code>help("dim", package="base")</code>.</p> + +<h3>Limitations</h3> + +<p>The current implementation does <em>not</em> support <em>dimensional subsetting</em> of more than one element. For instance, <code>x[1,]</code> is not supported by this version.</p> + +<h2>Important about environments</h2> + +<p>List environments are as their name suggests <em>environments</em>. Whenever working with environments in R, it is important to understand that <em>environments are mutable</em> whereas all other of the basic data types in R are immutable. For example, consider the following function that assigns zero to element <code>a</code> of object <code>x</code>:</p> + +<pre><code class="r">> setA <- function(x) { ++ x$a <- 0 ++ x ++ } +</code></pre> + +<p>If we pass a regular list to this function,</p> + +<pre><code class="r">> x <- list(a = 1) +> y <- setA(x) +> x$a +[1] 1 +> y$a +[1] 0 +</code></pre> + +<p>we see that <code>x</code> is unaffected by the assignment. This is because <em>lists are immutable</em> in R. However, if we pass an environment instead,</p> + +<pre><code class="r">> x <- new.env() +> x$a <- 1 +> y <- setA(x) +> x$a +[1] 0 +> y$a +[1] 0 +</code></pre> + +<p>we find that <code>x</code> was affected by the assignment. This is because <em>environments are mutable</em> in R. Since list environments inherits from environments, this also goes for them, e.g.</p> + +<pre><code class="r">> x <- listenv(a = 1) +> y <- setA(x) +> x$a +[1] 0 +> y$a +[1] 0 +</code></pre> + +<p>What is also important to understand is that it is not just the <em>content</em> of an environment that is mutable but also its <em>attributes</em>. For example,</p> + +<pre><code class="r">> x <- listenv(a = 1) +> y <- x +> attr(y, "foo") <- "Hello!" +> attr(x, "foo") +[1] "Hello!" +</code></pre> + +<hr/> + +<p>Copyright Henrik Bengtsson, 2015</p> + +</body> + +</html> diff --git a/inst/doc/listenv.md.rsp b/inst/doc/listenv.md.rsp new file mode 100644 index 0000000..c5e1de6 --- /dev/null +++ b/inst/doc/listenv.md.rsp @@ -0,0 +1,360 @@ +<%@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"%> + +_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 | | +| 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]`, `[2:1,,3]` | yes | yes | | +| Multi-element subsetting preserves element names | yes | | | +| Removing element by assigning NULL, e.g. `x$c <- NULL` | yes | 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]])) +} +<%--- +get(map(x)["b"], envir=x) +assign(map(x)["b"], 3, envir=x) +---%> + +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. + + + +## 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 invidual 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) +})%> +``` +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")`. +<%--- +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. +---%> + +### Limitations +The current implementation does _not_ support _dimensional subsetting_ of more than one element. For instance, `x[1,]` is not supported by this version. + + + +## 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") +})%> +``` + + +[listenv]: http://cran.r-project.org/package=listenv + +--- +Copyright Henrik Bengtsson, 2015 diff --git a/man/as.list.listenv.Rd b/man/as.list.listenv.Rd new file mode 100644 index 0000000..c7aea62 --- /dev/null +++ b/man/as.list.listenv.Rd @@ -0,0 +1,27 @@ +% 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} + diff --git a/man/cash-.listenv.Rd b/man/cash-.listenv.Rd new file mode 100644 index 0000000..2d415a5 --- /dev/null +++ b/man/cash-.listenv.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/listenv.R +\name{$.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 NULL if the element does not exist +} +\description{ +Get elements of list environment +} +\keyword{internal} + diff --git a/man/cash-set-.listenv.Rd b/man/cash-set-.listenv.Rd new file mode 100644 index 0000000..1b09ca3 --- /dev/null +++ b/man/cash-set-.listenv.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/listenv.R +\name{$<-.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} + diff --git a/man/get_variable.Rd b/man/get_variable.Rd new file mode 100644 index 0000000..7679be4 --- /dev/null +++ b/man/get_variable.Rd @@ -0,0 +1,27 @@ +% 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 TRUE, an error is generated if \code{name} +does not exist.} + +\item{create}{If 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} + diff --git a/man/length.listenv.Rd b/man/length.listenv.Rd new file mode 100644 index 0000000..243bb5d --- /dev/null +++ b/man/length.listenv.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/listenv.R +\name{length.listenv} +\alias{length.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} + diff --git a/man/listenv.Rd b/man/listenv.Rd new file mode 100644 index 0000000..8dbd844 --- /dev/null +++ b/man/listenv.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/listenv.R +\name{listenv} +\alias{as.listenv} +\alias{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 `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) +} + diff --git a/man/map.Rd b/man/map.Rd new file mode 100644 index 0000000..cc6d24a --- /dev/null +++ b/man/map.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/listenv.R +\name{map} +\alias{map} +\alias{map.listenv} +\title{Variable name map for elements of list environment} +\usage{ +map(x, ...) +} +\arguments{ +\item{x}{A list environment.} +} +\value{ +The a named character vector +} +\description{ +Variable name map for elements of list environment +} +\keyword{internal} + diff --git a/man/names.listenv.Rd b/man/names.listenv.Rd new file mode 100644 index 0000000..72620f6 --- /dev/null +++ b/man/names.listenv.Rd @@ -0,0 +1,17 @@ +% 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} + diff --git a/man/parse_env_subset.Rd b/man/parse_env_subset.Rd new file mode 100644 index 0000000..43d2890 --- /dev/null +++ b/man/parse_env_subset.Rd @@ -0,0 +1,24 @@ +% 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 TRUE, then the expression is +\code{substitute()}:ed, otherwise not.} +} +\value{ +A named list. +} +\description{ +Helper function to infer target from expression and environment +} +\keyword{internal} + diff --git a/man/undim.Rd b/man/undim.Rd new file mode 100644 index 0000000..33ab05e --- /dev/null +++ b/man/undim.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/undim.R +\name{undim} +\alias{undim} +\alias{undim.default} +\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}. +} + diff --git a/tests/as.listenv.R b/tests/as.listenv.R new file mode 100644 index 0000000..2bc9b92 --- /dev/null +++ b/tests/as.listenv.R @@ -0,0 +1,33 @@ +library("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()) diff --git a/tests/get_variable,dimensions.R b/tests/get_variable,dimensions.R new file mode 100644 index 0000000..a08f603 --- /dev/null +++ b/tests/get_variable,dimensions.R @@ -0,0 +1,38 @@ +library("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]]])) + varV <- get_variable(x, ii, create=FALSE) + varA <- get_variable(x, idx, create=FALSE) + stopifnot(identical(varA, varV)) +} + +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)) + + varV <- get_variable(x, ii) + varA <- get_variable(x, idx) + stopifnot(identical(varA, varV)) +} + + +message("* get_variable() - multi-dimensional list environments ... DONE") + +## Cleanup +options(oopts) +rm(list=setdiff(ls(envir=globalenv()), ovars), envir=globalenv()) diff --git a/tests/get_variable.R b/tests/get_variable.R new file mode 100644 index 0000000..625a331 --- /dev/null +++ b/tests/get_variable.R @@ -0,0 +1,100 @@ +library("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(map(x)) + +var <- get_variable(x, "a") +stopifnot(!is.na(var)) +stopifnot(length(x) == 3L) +print(map(x)) + +var <- get_variable(x, "b") +stopifnot(!is.na(var)) +stopifnot(length(x) == 3L) +print(map(x)) + +var <- get_variable(x, "c") +stopifnot(!is.na(var)) +stopifnot(length(x) == 3L) +print(map(x)) + +var <- get_variable(x, "d") +stopifnot(!is.na(var)) +stopifnot(length(x) == 4L) +print(map(x)) + +var <- get_variable(x, 4L) +stopifnot(!is.na(var)) +stopifnot(length(x) == 4L) +print(map(x)) + +x$b <- 2 +var <- get_variable(x, "b") +stopifnot(!is.na(var)) +stopifnot(length(x) == 4L) +print(map(x)) + +var <- get_variable(x, length(x) + 1L) +stopifnot(length(x) == 5L) +print(names(x)) +print(map(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()) diff --git a/tests/listenv,dimensions.R b/tests/listenv,dimensions.R new file mode 100644 index 0000000..4c7fecb --- /dev/null +++ b/tests/listenv,dimensions.R @@ -0,0 +1,303 @@ +library("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)) + + excls <- c(list(NULL), as.list(seq_along(dimnames)), list(seq_along(dimnames))) + for (ll in seq_along(excls)) { + excl <- excls[[ll]] + dimnamesT <- dimnames + dimnamesT[excl] <- list(NULL) + dimnames(x0) <- dimnamesT + dimnames(x) <- dimnamesT + 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("* Exceptions ...") +x <- listenv() +res <- try(dim(x) <- c(2,3), silent=TRUE) +stopifnot(inherits(res, "try-error")) + +length(x) <- 6 +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("* List environment and multiple dimensions ... DONE") + + +## Cleanup +options(oopts) +rm(list=setdiff(ls(envir=globalenv()), ovars), envir=globalenv()) diff --git a/tests/listenv.R b/tests/listenv.R new file mode 100644 index 0000000..eeef4e0 --- /dev/null +++ b/tests/listenv.R @@ -0,0 +1,692 @@ +library("listenv") + +ovars <- ls(envir=globalenv()) +oopts <- options(warn=1) + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +## Allocation +## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +x <- listenv() +print(x) +stopifnot(length(x) == 0) +stopifnot(is.null(names(x))) + +x <- listenv(a=1) +print(x) +stopifnot(length(x) == 1) +stopifnot(identical(names(x), c("a"))) +stopifnot(identical(x$a, 1)) + +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)) + + +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)) + + +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)) + + +withCallingHandlers({ + x <- listenv(length=3) +}, warning = function(warn) { + cat("WARNING:", warn$message) + invokeRestart("muffleWarning") +}) +print(x) +stopifnot(length(x) == 3) +stopifnot(is.null(names(x))) + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +## 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)) + +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)) + + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +## 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))) + +y <- x[] +print(y) +stopifnot(length(y) == length(x)) +stopifnot(all.equal(y, x)) +stopifnot(!identical(y, x)) +stopifnot(is.null(names(y))) + +y <- x[1] +print(y) +stopifnot(is.null(names(y))) + +y <- x[2:3] +print(y) +stopifnot(is.null(names(y))) + +y <- x[-1] +print(y) +stopifnot(is.null(names(y))) + +x[c('c', '.a', 'b')] <- list(NULL, 3, 1) +print(x) +stopifnot(identical(names(x), c("", "", "", "c", ".a", "b"))) + +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)))) + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +## 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))) + + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +## 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")) + + +## Cleanup +options(oopts) +rm(list=setdiff(ls(envir=globalenv()), ovars), envir=globalenv()) diff --git a/tests/parse_env_subset,dimensions.R b/tests/parse_env_subset,dimensions.R new file mode 100644 index 0000000..e2783e6 --- /dev/null +++ b/tests/parse_env_subset,dimensions.R @@ -0,0 +1,105 @@ +library("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-dimensional 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[[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,4]], substitute=TRUE) +str(target) +stopifnot(identical(target$envir, x), is.na(target$idx), !target$exists) + +## 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))) + +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))) + +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))) + +message("*** parse_env_subset() on multi-dimensional listenv ... DONE") + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - +## Exception handling +## - - - - - - - - - - - - - - - - - - - - - - - - - - +message("*** parse_env_subset() on multi-dimensional 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-dimensional listenv - exceptions ... DONE") + + +## Cleanup +rm(list=setdiff(ls(envir=globalenv()), ovars), envir=globalenv()) diff --git a/tests/parse_env_subset.R b/tests/parse_env_subset.R new file mode 100644 index 0000000..b151baa --- /dev/null +++ b/tests/parse_env_subset.R @@ -0,0 +1,222 @@ +library("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) + +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[[1]], substitute=TRUE) +str(target) +stopifnot(identical(target$envir, x), target$name == "a", target$idx == 1, 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", "", ""))) + + +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) +stopifnot(length(target$idx) == 1L, !target$exists) + +message("*** parse_env_subset() on listenv ... DONE") + + +## - - - - - - - - - - - - - - - - - - - - - - - - - - +## Exception handling +## - - - - - - - - - - - - - - - - - - - - - - - - - - +message("*** parse_env_subset() - exceptions ...") + +x <- listenv() + +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()) diff --git a/tests/undim.R b/tests/undim.R new file mode 100644 index 0000000..1ba6ac0 --- /dev/null +++ b/tests/undim.R @@ -0,0 +1,33 @@ +library("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") diff --git a/tests/utils.R b/tests/utils.R new file mode 100644 index 0000000..cdd50d4 --- /dev/null +++ b/tests/utils.R @@ -0,0 +1,43 @@ +printf <- 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, maxHead=2)) +## x = 1, 2, ..., 6. + +printf("x = %s.\n", hpaste(x), maxHead=3) # Default +## x = 1, 2, 3, ..., 6. + +# It will never output 1, 2, 3, 4, ..., 6 +printf("x = %s.\n", hpaste(x, maxHead=4)) +## x = 1, 2, 3, 4, 5 and 6. + +# Showing the tail +printf("x = %s.\n", hpaste(x, maxHead=1, maxTail=2)) +## x = 1, ..., 5, 6. + +# Turning off abbreviation +printf("y = %s.\n", hpaste(y, maxHead=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, lastCollapse=" and ")) +## x = 1, 2, 3, 4, 5 and 6. diff --git a/vignettes/listenv.md.rsp b/vignettes/listenv.md.rsp new file mode 100644 index 0000000..c5e1de6 --- /dev/null +++ b/vignettes/listenv.md.rsp @@ -0,0 +1,360 @@ +<%@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"%> + +_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 | | +| 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]`, `[2:1,,3]` | yes | yes | | +| Multi-element subsetting preserves element names | yes | | | +| Removing element by assigning NULL, e.g. `x$c <- NULL` | yes | 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]])) +} +<%--- +get(map(x)["b"], envir=x) +assign(map(x)["b"], 3, envir=x) +---%> + +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. + + + +## 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 invidual 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) +})%> +``` +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")`. +<%--- +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. +---%> + +### Limitations +The current implementation does _not_ support _dimensional subsetting_ of more than one element. For instance, `x[1,]` is not supported by this version. + + + +## 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") +})%> +``` + + +[listenv]: http://cran.r-project.org/package=listenv + +--- +Copyright Henrik Bengtsson, 2015 -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-listenv.git _______________________________________________ debian-med-commit mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/debian-med-commit
