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
|
discard <- function(treat, pscore, option, X) {
n.obs <- length(treat)
pmax0 <- max(pscore[treat==0])
pmax1 <- max(pscore[treat==1])
pmin0 <- min(pscore[treat==0])
pmin1 <- min(pscore[treat==1])
if (is.logical(option)) # user input
return(option)
else if (option == "none") # keep all units
discarded <- rep(FALSE, n.obs)
else if (option == "both") # discard units outside of common support
discarded <- (pscore < max(pmin0, pmin1) | pscore > min(pmax0, pmax1))
else if (option == "control") # discard control units only
discarded <- (pscore < pmin1 | pscore > pmax1)
else if (option == "treat") # discard treated units only
discarded <- (pscore < pmin0 | pscore > pmax0)
else if (any(grep(option, c("hull.control", "hull.treat", "hull.both")))) {
## convext hull stuff
if (!("WhatIf" %in% .packages(all = TRUE)))
install.packages("WhatIf")
# if (!("lpSolve" %in% .packages(all = TRUE)))
# install.packages("lpSolve")
require(WhatIf)
# require(lpSolve)
discarded <- rep(FALSE, n.obs)
if (option == "hull.control"){ # discard units not in T convex hull
wif <- whatif(cfact = X[treat==0,], data = X[treat==1,])
discarded[treat==0] <- !wif$in.hull
} else if (option == "hull.treat") {
wif <- whatif(cfact = X[treat==1,], data = X[treat==0,])
discarded[treat==1] <- !wif$in.hull
} else if (option == "hull.both"){ # discard units not in T&C convex hull
wif <- whatif(cfact = cbind(1-treat, X), data = cbind(treat, X))
discarded <- !wif$in.hull
}
else
stop("invalid input for `discard'")
} else
stop("invalid input for `discard'")
names(discarded) <- names(treat)
return(discarded)
}
|
