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
|
eval_c <- function(expr, data_mask, context_mask) {
expr <- call_expand_dots(expr, context_mask$.__current__.)
expr <- node_compact_missing(expr)
node <- node_cdr(expr)
# If the first selector is exclusive (negative), start with all
# columns. `-foo` is syntax for `everything() - foo`.
if (c_arg_kind(node_car(node)) %in% c("diff", "diff_colon")) {
init <- quote(everything())
} else {
init <- named(int())
}
reduce_sels(node, data_mask, context_mask, init = init)
}
reduce_sels <- function(node, data_mask, context_mask, init) {
out <- walk_data_tree(init, data_mask, context_mask)
while (!is_null(node)) {
tag <- node_tag(node)
car <- node_car(node)
cdr <- node_cdr(node)
kind <- c_arg_kind(car)
new <- switch(kind,
diff = unnegate(car),
diff_colon = unnegate_colon(car),
car
)
new <- walk_data_tree(new, data_mask, context_mask)
if (!is_null(tag)) {
internal <- data_mask$.__tidyselect__.$internal
new <- combine_names(new, tag, internal$name_spec, internal$strict)
}
if (kind == "union") {
out <- sel_union(out, new)
} else {
vars <- data_mask$.__tidyselect__.$internal$vars
out <- sel_diff(out, new, vars)
}
node <- cdr
}
out
}
c_arg_kind <- function(x) {
expr <- quo_get_expr2(x, x)
if (is_negated(x)) {
"diff"
} else if (is_negated_colon(x)) {
"diff_colon"
} else {
"union"
}
}
unnegate <- function(x) {
expr <- quo_get_expr2(x, x)
expr <- node_cadr(expr)
if (is_quosure(expr)) {
expr
} else if (is_quosure(x)) {
quo_set_expr(x, expr)
} else {
expr
}
}
unnegate_colon <- function(x) {
expr <- quo_get_expr2(x, x)
expr[[2]] <- unnegate(expr[[2]])
expr[[3]] <- unnegate(expr[[3]])
quo_set_expr2(x, expr, expr)
}
is_negated <- function(x) {
expr <- quo_get_expr2(x, x)
is_call(expr, "-", n = 1)
}
is_negated_colon <- function(x) {
expr <- quo_get_expr2(x, x)
is_call(expr, ":") && is_negated(expr[[2]]) && is_negated(expr[[3]])
}
combine_names <- function(x, tag, name_spec, uniquely_named) {
if (uniquely_named && is_data_dups(x)) {
name <- as_string(tag)
abort("Can't rename duplicate variables to `{name}`.")
}
vctrs::vec_c(!!tag := x, .name_spec = name_spec)
}
unique_name_spec <- function(outer, inner) {
# For compatibily, we enumerate as "foo1", "foo2", rather than
# "foo...1", "foo...2"
sep <- if (is_character(inner)) "..." else ""
paste(outer, inner, sep = sep)
}
minimal_name_spec <- function(outer, inner) {
if (is_character(inner)) {
paste(outer, inner, sep = "...")
} else {
outer
}
}
|
