-
Notifications
You must be signed in to change notification settings - Fork 0
/
coerce-aggregation_structure.R
108 lines (106 loc) · 3.31 KB
/
coerce-aggregation_structure.R
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
#' Coerce an aggregation structure into a tabular form
#'
#' Coerce a price index aggregation structure into an aggregation matrix, or a
#' data frame.
#'
#' @param x A price index aggregation structure, as made by
#' [aggregation_structure()].
#' @param sparse Should the result be a sparse matrix from \pkg{Matrix}? This
#' is faster for large aggregation structures. The default returns an ordinary
#' dense matrix.
#' @param stringsAsFactors See [as.data.frame()].
#' @param ... Not currently used.
#'
#' @returns
#' `as.matrix()` represents an aggregation structure as a matrix,
#' such that multiplying with a (column) vector of elemental indexes gives the
#' aggregated index.
#'
#' `as.data.frame()` takes an aggregation structure and returns a data
#' frame that could have generated it, with columns `level1`,
#' `level2`, ..., `ea`, and `weight`.
#'
#' @seealso
#' [as_aggregation_structure()] for coercing into an aggregation structure.
#'
#' @examples
#' # A simple aggregation structure
#' # 1
#' # |-----+-----|
#' # 11 12
#' # |---+---| |
#' # 111 112 121
#' # (1) (3) (4)
#'
#' aggregation_weights <- data.frame(
#' level1 = c("1", "1", "1"),
#' level2 = c("11", "11", "12"),
#' ea = c("111", "112", "121"),
#' weight = c(1, 3, 4)
#' )
#'
#' pias <- as_aggregation_structure(aggregation_weights)
#'
#' as.matrix(pias)
#'
#' all.equal(as.data.frame(pias), aggregation_weights)
#'
#' @family aggregation structure methods
#' @export
as.matrix.piar_aggregation_structure <- function(x, ..., sparse = FALSE) {
nea <- length(x$weights)
height <- length(x$levels)
if (height == 1L) {
res <- matrix(numeric(0L), ncol = nea, dimnames = list(NULL, x$levels[[1L]]))
if (sparse) {
return(Matrix::Matrix(res, sparse = TRUE))
} else {
return(res)
}
}
cols <- seq_len(nea)
# Don't need the eas.
lev <- lapply(as.list(x)[-height], \(z) factor(z, unique(z)))
res <- vector("list", length(lev))
# Generate the rows for each level of the matrix and rbind together.
for (i in seq_along(res)) {
w <- unsplit(
lapply(split(x$weights, lev[[i]]), gpindex::scale_weights), lev[[i]]
)
if (sparse) {
mat <- Matrix::sparseMatrix(lev[[i]], cols, x = w)
} else {
mat <- matrix(0, nlevels(lev[[i]]), nea)
mat[cbind(lev[[i]], cols)] <- w
}
dimnames(mat) <- list(levels(lev[[i]]), x$levels[[height]])
res[[i]] <- mat
}
do.call(rbind, res)
}
#' @rdname as.matrix.piar_aggregation_structure
#' @export
as.data.frame.piar_aggregation_structure <- function(x, ...,
stringsAsFactors = FALSE) {
colnames <- c(paste0("level", seq_along(x$child), recycle0 = TRUE), "ea")
res <- as.data.frame(as.list(x),
col.names = colnames,
stringsAsFactors = stringsAsFactors
)
res$weight <- x$weights
res
}
#' @export
as.list.piar_aggregation_structure <- function(x, ...) {
if (length(x$levels) == 1L) {
return(x$levels[1L])
}
res <- vector("list", length(x$parent))
res[[1L]] <- x$parent[[1L]]
# Walk up the parent nodes to reconstruct the inputs that generated 'x'.
for (i in seq_along(x$parent)[-1L]) {
res[[i]] <- x$parent[[i]][res[[i - 1L]]]
}
top <- names(x$child[[length(x$child)]])[res[[length(res)]]]
c(list(top), lapply(rev(res), names))
}