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
|
withPV<-function(mapping, data, action, rewrite=TRUE, ...) UseMethod("withPV", data)
withPV.default<-function(mapping, data, action,rewrite=TRUE, ...){
if(inherits(mapping,"formula")) mapping<-list(mapping)
if (!is.list(mapping))
stop("'mapping' must be a list of formulas")
if (!all(sapply(mapping, length)==3))
stop("'mapping' must be a list of two-sided formulas")
PVframes<-lapply(mapping, function(f) model.frame(f[-2], data))
nvars<-length(PVframes)
PVnames<-sapply(mapping, function(f) deparse(f[[2]]))
if (any(PVnames %in% colnames(data)))
stop("working PV names must not already occur in the data")
nreps<-sapply(PVframes, NCOL)
if (length(unique(nreps))>1)
stop("number of plausible values must be the same for all variables")
nreps<-nreps[1]
results<-vector("list",nreps)
if(rewrite){
sublist<-vector("list",nvars)
names(sublist)<-PVnames
for(i in 1:nreps){
for(j in 1:nvars) sublist[[j]]<-as.name(names(PVframes[[j]])[i])
if (is.function(action)){
actioni<-action
body(actioni) <- eval(bquote(substitute(.(body(actioni)), sublist)))
results[[i]]<-action(data)
} else {
actioni <- eval(bquote(substitute(.(action), sublist)))
results[[i]] <- eval(actioni, data)
}
}
} else {
for(i in 1:nreps){
dfi<-lapply(PVframes, function(d) d[[i]])
names(dfi)<-PVnames
.DATA<-cbind(data, as.data.frame(dfi))
if (is.function(action))
results[[i]] <- action(.DATA)
else
results[[i]] <- eval(action)
}
}
attr(results,"call")<-sys.call()
results
}
|
