1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
#' @export
dim.listenv <- function(x) attr(x, "dim.", exact = TRUE)
#' @export
`dim<-.listenv` <- function(x, value) {
n <- length(x)
if (!is.null(value)) {
names <- names(value)
value <- as.integer(value)
p <- prod(as.double(value))
if (p != n) {
if (n == 0) {
length(x) <- p
} else {
stopf("Cannot set dimension to c(%s) because its length do not match the length of the object: %d != %s", paste(value, collapse = ", "), p, n)
}
}
names(value) <- names
}
## Always remove "dimnames" and "names" attributes, cf. help("dim")
dimnames(x) <- NULL
names(x) <- NULL
attr(x, "dim.") <- value
x
}
#' Set the dimension of an object
#'
#' @param x An \R object, e.g. a list environment, a matrix, an array, or
#' a data frame.
#'
#' @param value A numeric vector coerced to integers.
#' If one of the elements is missing, then its value is inferred from the
#' other elements (which must be non-missing) and the length of `x`.
#'
#' @return An object with the dimensions set, similar to what
#' \code{\link[base:dim]{dim(x) <- value}} returns.
#'
#' @examples
#' x <- 1:6
#' dim_na(x) <- c(2, NA)
#' print(dim(x)) ## [1] 2 3
#'
#' @name dim_na
#' @aliases dim_na<-
#' @export
`dim_na<-` <- function(x, value) {
if (!is.null(value)) {
value <- as.integer(value)
nas <- which(is.na(value))
if (length(nas) > 0) {
if (length(nas) > 1) {
stopf("Argument 'value' may only have one NA: %s",
sprintf("c(%s)", paste(value, collapse = ", ")))
}
value[nas] <- as.integer(length(x) / prod(value[-nas]))
}
}
dim(x) <- value
invisible(x)
}
#' @export
dimnames.listenv <- function(x) attr(x, "dimnames.", exact = TRUE)
#' @export
`dimnames<-.listenv` <- function(x, value) {
dim <- dim(x)
if (is.null(dim) && !is.null(value)) {
stop("'dimnames' applied to non-array")
}
for (kk in seq_along(dim)) {
names <- value[[kk]]
if (is.null(names)) next
n <- length(names)
if (n != dim[kk]) {
stopf("Length of 'dimnames' for dimension #%d not equal to array extent: %d != %d", kk, n, dim[kk])
}
}
attr(x, "dimnames.") <- value
x
}
#' @method is.matrix listenv
#' @export
is.matrix.listenv <- function(x, ...) {
dim <- dim(x)
(length(dim) == 2L)
}
#' @export
is.array.listenv <- function(x, ...) {
dim <- dim(x)
!is.null(dim)
}
#' @method as.vector listenv
#' @export
as.vector.listenv <- function(x, mode = "any") {
if (mode == "any") mode <- "list"
x <- as.list(x)
if (mode != "list") {
x <- as.vector(x, mode = mode)
}
x
}
#' @export
#' @method as.matrix listenv
as.matrix.listenv <- function(x, ...) {
dim <- dim(x)
if (length(dim) != 2L) {
dim <- c(length(x), 1L)
dim(x) <- dim
}
x
}
|
