/
group.preferences.R
272 lines (261 loc) · 7.34 KB
/
group.preferences.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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
#' Group Preferences
#'
#' Create an object of class `grouped_preferences` which associates a
#' group index with an object of class `preferences`. This allows the
#' preferences to be linked to covariates with group-specific values.
#'
#' @param index A numeric vector or a factor with length equal to the number of
#' preferences specifying the subject for each set.
#' @param x A [`preferences`][preferences] object for `group()`; otherwise a
#' `grouped_preferences` object.
#' @param i Indices specifying groups to extract, may be any data type accepted
#' by `[`.
#' @param j Indices specifying items to extract.
#' object, otherwise return a matrix/vector.
#' @param max The maximum number of preferences to format per subject.
#' @param width The maximum width in number of characters to format the
#' preferences.
#' @param ... Additional arguments passed on to
#' [`as.preferences`][as.preferences] by `grouped_preferences`; unused by
#' `format`.
#' @return An object of class `grouped_preferences`, which is a vector of
#' of group IDs with the following attributes:
#' \item{preferences}{ The `preferences` object.}
#' \item{index}{ An index matching each preference set to each group ID.}
#' @examples
#'
#' # ungrouped preferences (5 preference sets, 4 items)
#' R <- as.preferences(
#' matrix(c(
#' 1, 2, 0, 0,
#' 0, 2, 1, 0,
#' 0, 0, 1, 2,
#' 2, 1, 0, 0,
#' 0, 1, 2, 3
#' ), ncol = 4, byrow = TRUE),
#' format = "ranking",
#' item_names = LETTERS[1:4]
#' )
#' length(R)
#'
#' # group preferences (first three in group 1, next two in group 2)
#' G <- group(R, c(1, 1, 1, 2, 2))
#' length(G)
#'
#' ## by default up to 2 preference sets are shown per group, "..." indicates if
#' ## there are further preferences
#' G
#' print(G, max = 1)
#'
#' ## select preferences from group 1
#' G[1, ]
#'
#' ## exclude item 3 from preferences
#' G[, -3]
#'
#' ## Project preferences in all groups to their first preference
#' G[, 1, by.rank = TRUE]
#'
#' ## preferences from group 2, excluding item 3
#' ## - note group 2 becomes the first (and only) group
#' G[2, -3]
#'
#' # Group preferences by a factor
#' G <- group(R, factor(c("G1", "G1", "G1", "G2", "G2")))
#'
#' G
#' print(G, max = 1)
#'
#' ## select preferences from group G1
#' G["G1"]
#'
#' @name group
#' @export
NULL
#' @rdname group
#' @export
group <- function(x, ...) {
UseMethod("group")
}
#' @rdname group
#' @method group preferences
#' @export
group.preferences <- function(x, index, ...) {
if (!((is.vector(index) || is.factor(index)) &&
length(index) == length(x))) {
stop("index must be a vector or factor with length equal to preferences")
}
if (is.factor(index)) {
group_names <- levels(index)
} else {
group_names <- NULL
}
index <- as.numeric(index)
structure(seq_len(max(index)),
preferences = x,
index = index,
group_names = group_names,
class = "grouped_preferences"
)
}
#' @rdname group
#' @method [ grouped_preferences
#' @export
"[.grouped_preferences" <- function(x, i, j, ...) {
group_names <- attr(x, "group_names")
if (!missing(i)) {
if (is.character(i)) {
i <- match(i, group_names)
}
group_names <- group_names[i]
if (missing(j)) {
j <- TRUE
}
# always a vector if picking out elements of preferences matrix
if (is.matrix(i)) {
r <- split(seq_along(attr(x, "index")), attr(x, "index"))
i1 <- unlist(r[i[, 1L]])
i2 <- rep(i[, 2L], lengths(r))
return(.subset(attr(x, "preferences"), cbind(i1, i2)))
}
# convert index of groups to index of preferences
g <- .subset(x, i)
# create index for preferences matrix
i <- which(attr(x, "index") %in% g)
groups <- split(i, attr(x, "index")[i])[as.character(g)]
i <- unlist(groups)
# update value and index to remove omitted groups
value <- seq_along(groups)
index <- rep(value, lengths(groups))
} else {
if (missing(j)) {
return(x)
}
value <- x
i <- TRUE
index <- attr(x, "index")
}
# now subset preferences matrix
preferences <- attr(x, "preferences")[i, j, ...]
# convert preferences matrix to grouped_preferences
if (!is.null(group_names)) {
group(preferences, as.factor(group_names[index]))
} else {
group(preferences, index)
}
}
#' @method as.data.frame grouped_preferences
#' @export
# nolint start
as.data.frame.grouped_preferences <-
function(x, row.names = NULL, optional = FALSE, ...,
nm = paste(deparse(substitute(x), width.cutoff = 20L),
collapse = " "
)) {
if (is.null(row.names)) {
row.names <- attr(x, "group_names")
}
value <- list(x)
if (!optional) {
names(value) <- nm
}
if (is.null(row.names) && !is.null(rownames(x))) {
row.names <- rownames(x)
}
if (is.null(row.names)) {
row.names <- .set_row_names(length(x))
} else {
if (is.object(row.names) || !is.integer(row.names)) {
row.names <- as.character(row.names)
}
if (anyNA(row.names)) {
stop("row names contain missing values")
}
if (anyDuplicated(row.names)) {
stop(paste(
"duplicate row.names: ",
toString(unique(row.names[duplicated(row.names)]))
))
}
}
attr(value, "row.names") <- row.names
class(value) <- "data.frame"
value
}
# nolint end
#' @method print grouped_preferences
#' @export
print.grouped_preferences <- function(x, max = 2L, width = 20L, ...) {
print.default(format(x, max = max, width = width, ...), quote = FALSE)
}
#' @rdname group
#' @method format grouped_preferences
#' @export
format.grouped_preferences <- function(x, max = 2L, width = 20L, ...) {
tab <- tabulate(attr(x, "index"))
rep <- numeric(length(attr(x, "index")))
rep[order(attr(x, "index"))] <- sequence(tab)
if (ncol(attr(x, "preferences")) > 0L) {
j <- TRUE
} else {
j <- NULL
}
r <- attr(x, "preferences")[rep <= max, j]
char <- format.preferences(r, width = width)
value <- vapply(
split(char, attr(x, "index")[rep <= max]),
function(x) {
if (all(is.na(x))) {
return(NA_character_)
}
toString(x)
},
"a"
)
# add ... if more than max preferences
trunc <- tab > max & !is.na(value)
value[trunc] <- paste0(value[trunc], ", ...")
group_names <- attr(x, "group_names")
if (!is.null(group_names)) {
names(value) <- group_names
}
value
}
#' @method na.omit grouped_preferences
#' @importFrom stats na.omit
na.omit.grouped_preferences <- function(object, ...) {
omit <- seq_along(
attr(
object,
"preferences"
)
)[is.na(attr(object, "preferences"))]
if (length(omit) == 0L) {
return(object)
}
nm <- names(object)
index <- attr(object, "index")[-omit]
index <- match(index, unique(index))
names(omit) <- nm[omit]
attr(omit, "class") <- "omit"
structure(unique(index),
preferences = attr(object, "preferences")[-omit, , drop = FALSE],
index = index,
na.action = omit,
class = "grouped_preferences"
)
}
#' @method na.exclude grouped_preferences
#' @importFrom stats na.exclude
na.exclude.grouped_preferences <- function(object, ...) {
out <- na.omit(object)
class(attr(out, "na.action")) <- "na.exclude" # nolint: object_name_linter
out
}
#' @method is.na grouped_preferences
#' @export
is.na.grouped_preferences <- function(x) {
out <- tapply(attr(x, "preferences"), attr(x, "index"), sum) == 0L
names(out) <- names(x)
out
}