/
bind.R
176 lines (161 loc) · 6.03 KB
/
bind.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
#' Unpack a list and assign to multiple variables.
#'
#' This is a "destructuring bind" for R. It can be used to unpack
#' structured lists into different variables, or achieve the effect of
#' multiple return values from a function.
#'
#' Element to variable matching should match R's argument binding
#' rules, with the modification that arguments to the right of the
#' ... will be matched positionally to elements at the end of the
#' unpacked sequence. Calls to bind() can be nested to unpack nested
#' structures.
#'
#' You may leave an argument blank as in \code{bind[, skipKey=,
#' ...=rest] <- seq} to skip an element. (Here the first element of
#' \code{seq} and the one tagged "skipKey" are both skipped and the
#' rest are gathered in the output variable \code{rest}.)
#'
#' Note that the assigned-to variable is on the \emph{right} side of
#' each \code{=} in the argument list. This is admittedly awkward but
#' is the best way to remain consistent with R's argument-binding
#' semantics.
#'
#' @usage bind[key=varName, ...] <- list(key=value, ...)
#' @name bind
#' @format N/A
#' @examples
#' #match by position
#' bind[x, y] <- c("foo", "bar")
#'
#' #match by name
#' bind[a=x, b=y] <- c(b="bar", a="foo")
#'
#' # one often wants to unpack the first and/or last, and rest of a list.
#' bind[first, ...=rest, last] <- letters
#'
#' record <- list("Marilyn", "Monroe", dob=list("June", 1, 1926),
#' profession="film star", "born Norma Jean Baker",
#' donotuse="garbage", "1947 California Artichoke Queen",
#' list("August", 5, 1962))
#' bind[first, last,
#' dob=bind[month, day, year],
#' donotuse=, ...=notes, death] <- record
#'
#' @note This will incidentally create a local variable named "bind"
#' in your environment. On the other hand if you have an object
#' already named "bind" and not of class "bind" this method won't be
#' found, so it's merely annoying and not destructive. It's not
#' clear how to avoid this and still use an assignment operator to do
#' the binding. (I could write a simple function, but I strongly
#' prefer there to be a \code{<-} anywhere that there is a
#' modification to the environment.)
#'
#' Nonlocal assignments (\code{<<-}) are not supported and will behave
#' as local assignments.
#'
#' @param ... a list of assignments, key on left, target variable on
#' right. That is, \code{bind[a=x] <- c(a=1)} creates a variable named
#' \code{x}, not \code{a}. It is somewhat counterintuitive but this is
#' the only way that matches R's argument binding syntax.
#' @aliases bind bind<- [<-.bind <-.bind
#' @method "[<-" bind
#' @return a "bind" object, since it is invoked via a subset on "bind".
#' @author Peter Meilstrup
#' @S3method "[<-" bind
`[<-.bind` <- function(`*temp*`, ..., value) {
envirs = environments(dots(...))
#why square brackets?
#1. I want there to be a <- everywhere there is a change to the workspace.
#2. we can't simply have
#bind(x=a, y=b) <- c(x=1,y=2) because R mangles
#`<-`(bind(x=a,y=b), c(1,2) into
#`bind<-`(`*tmp*`, c(x=1, y=2), y=b)
#which erases the fact that you wanted to match to the key "x".
#using `{<-` would allow more flexible syntax but won't work on account
#of more involved mangling.
eOut <- eval(substitute(alist(...)))
nOut <- if(is.null(names(eOut))) rep("", length(eOut)) else names(eOut)
vOut <- bind_match(nOut, value)
for (i in seq(len=length(nOut))) {
to <- eOut[[i]]
if (!missing(to)) {
expr <- quote(a <- quote(b))
expr[[2]] <- to
if (is.null(vOut[[i]])) {
expr[[3]][2] <- vOut[i]
} else expr[[3]][[2]] <- vOut[[i]]
eval(expr, envirs[[i]])
}
}
#a side effect is that R creates a variable named "bind" in local
#workspace.
`*temp*`
}
bind_match <- function(nOut, value) {
##Match according to name, and compute the values to assign to the outputs.
##You know, this might be a whole lot easier if I didn't support
##partial matching.
##First, match all names.
i_in_out <- pmatch(nOut, names(value))
if (any(is.na(i_in_out) & !(nOut %in% c("", "...")))) {
stop(sprintf("no matches found for %s",
paste("\"",
nOut[is.na(i_in_out) & !(nOut %in% c("", "..."))],
"\"", sep="", collapse=", ")))
}
#From the front, assign inputs to outputs until you hit "..."
i_out_unmatched <- which(is.na(i_in_out) & nOut %in% c("", "..."))
i_in_unmatched <- na.omit(`[<-`(seq_along(value), i_in_out, NA))
for (i in seq_along(i_in_unmatched)) {
if (i > length(i_out_unmatched)) {
stop("Too many items to bind")
}
if (nOut[i_out_unmatched[i]] == "...") {
break
}
i_in_out[i_out_unmatched[i]] <- i_in_unmatched[i]
}
#same from the back
i_out_unmatched <- rev(which(is.na(i_in_out) & nOut %in% c("", "...")))
i_in_unmatched <- rev(na.omit(`[<-`(seq(length(value)), i_in_out, NA)))
for (i in seq(len=length(i_in_unmatched))) {
if (i > length(i_out_unmatched)) {
stop("Too many items to bind at end") #shouldn't ever happen?
}
if (nOut[i_out_unmatched[i]] == "...") {
break
}
i_in_out[i_out_unmatched[i]] <- i_in_unmatched[i]
}
#data.frame objects choke on selecing columns with NAs, so...
vOut <- vector(length(nOut), mode="list")
assigned <- !is.na(i_in_out)
if (any(assigned)) {
vOut[assigned] <- as.list(value[i_in_out[assigned]])
}
#then put the rest into dots.
if (any(!assigned)) {
if (identical(nOut[!assigned], "...")) {
i_out_dots <- which(!assigned)
i_in_out[i_out_dots] <- 0
i_in_dots <- `[<-`(seq_along(value), i_in_out, 0)
vOut[i_out_dots] <- list(value[i_in_dots])
} else {
stop("Not enough items to bind")
}
}
if (any(is.na(i_in_out))) {
stop("Too many items to bind")
}
vOut
}
#' @export
bind <- "bind"
class(bind) <- "bind"
#' @S3method print bind
print.bind <- function(...)
invisible(cat("Use bind[a=x, b=y] <- c(a=1,b=2) to do parallel assignment.\n\n"))
##' @export
`[.bind` <- function(tmp) {
stop("bind[...] must be used as the target of an assignment.");
}