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
|
# The `sel_` prefixed operations match on both values and names, with
# unnamed elements matching named ones
sel_union <- function(x, y) {
if (is_null(names(x)) && is_null(names(y))) {
set_union(x, y)
} else {
sel_operation(x, y, set_union)
}
}
sel_intersect <- function(x, y) {
if (is_null(names(x)) && is_null(names(y))) {
set_intersect(x, y)
} else {
sel_operation(x, y, set_intersect)
}
}
sel_unique <- function(x) {
x <- vctrs::new_data_frame(list(value = x, names = names2(x)))
x <- propagate_names(x)
out <- vctrs::vec_unique(x)
set_names(out$value, out$names)
}
# Set difference and set complement must validate their RHS eagerly,
# otherwise OOB elements might be selected out and go unnoticed
sel_diff <- function(x, y, vars = NULL, error_call = caller_env()) {
if (!is_null(vars)) {
y <- loc_validate(y, vars, call = error_call)
}
if (is_null(names(x)) || is_null(names(y))) {
set_diff(x, y)
} else {
sel_operation(x, y, set_diff)
}
}
sel_complement <- function(x, vars = NULL, error_call = caller_env()) {
sel_diff(seq_along(vars), x, vars, error_call = error_call)
}
sel_operation <- function(x, y, sel_op) {
x <- vctrs::new_data_frame(list(value = x, names = names2(x)))
y <- vctrs::new_data_frame(list(value = y, names = names2(y)))
x <- propagate_names(x, y)
y <- propagate_names(y, x)
out <- sel_op(x, y)
set_names(out$value, out$names)
}
propagate_names <- function(x, from = NULL) {
unnamed <- x$names == ""
if (!any(unnamed)) {
return(x)
}
# Match names inside `x` first, so we preserve order
from <- vctrs::vec_c(x, from)
# Prevent unnamed elements from matching
vctrs::vec_slice(from$value, from$names == "") <- NA
matches <- match(
x$value[unnamed],
from$value,
nomatch = 0L
)
x$names[unnamed][matches != 0L] <- from$names[matches]
x
}
# https://github.com/r-lib/vctrs/issues/548
set_diff <- function(x, y) {
vctrs::vec_unique(vctrs::vec_slice(x, !vctrs::vec_in(x, y)))
}
set_intersect <- function(x, y) {
pos <- vctrs::vec_match(y, x)
pos <- vctrs::vec_unique(pos)
pos <- vctrs::vec_sort(pos)
pos <- pos[!is.na(pos)]
vctrs::vec_slice(x, pos)
}
set_union <- function(x, y) {
vctrs::vec_unique(vctrs::vec_c(x, y))
}
|
