├── .Rbuildignore
├── .gitignore
├── DESCRIPTION
├── INSTALLING_MOSEK.md
├── NAMESPACE
├── R
    ├── optrdd.R
    └── utils.R
├── README.md
├── baselines
    ├── local.lin.reg.R
    └── old.optrdd.R
├── example.R
├── experiments_from_paper
    ├── README.md
    ├── compulsory_schooling
    │   ├── analysis.R
    │   ├── armstrong_kolesar_gamma.R
    │   └── uk_analysis_sample.csv
    ├── geographic_rdd
    │   ├── KeeleTitiunik2014-PA-replication-files
    │   │   ├── Data
    │   │   │   ├── BorderSegmentPoints_Project.dbf
    │   │   │   └── Voters
    │   │   │   │   └── Voters_Final.dta
    │   │   └── README.txt
    │   └── analysis.R
    ├── intro
    │   └── figures_1_and_2.R
    └── summer_school
    │   ├── analysis.R
    │   ├── make_final_tables.R
    │   └── ssextract_karthik.csv
├── man
    ├── get.plusminus.Rd
    └── optrdd.Rd
├── optrdd.Rproj
├── releases
    ├── optrdd_1.0.1.tar.gz
    ├── optrdd_1.0.2.tar.gz
    └── optrdd_1.0.tar.gz
└── tests
    ├── testthat.R
    └── testthat
        ├── test_all.R
        ├── test_for_cran.R
        └── test_numerics.R


/.Rbuildignore:
--------------------------------------------------------------------------------
 1 | example.R
 2 | README.md
 3 | INSTALLING_MOSEK.md
 4 | optrdd.Rproj
 5 | baselines
 6 | experiments_from_paper/*
 7 | tests/testthat/test_all.R
 8 | tests/testthat/test_numerics.R
 9 | releases/*
10 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | *.Rproj.user
 2 | *.Rhistory
 3 | *.history
 4 | *.RData
 5 | *.DS_Store
 6 | *.aux
 7 | *.blg
 8 | *.log
 9 | *.out
10 | *.gz
11 | *.pdf
12 | *.toc
13 | *.nav
14 | *.snm
15 | *.swp
16 | 


--------------------------------------------------------------------------------
/DESCRIPTION:
--------------------------------------------------------------------------------
 1 | Package: optrdd
 2 | Title: Optimized Regression Discontinuity Designs
 3 | Version: 1.0.2
 4 | Authors@R: c(
 5 |   person("Guido", "Imbens", email = "imbens@stanford.edu", role = c("aut")),
 6 |   person("Stefan", "Wager", email = "swager@stanford.edu", role = c("aut", "cre")))
 7 | Description: Optimized inference in regression discontinuity designs, as proposed by Imbens and Wager (2017) <arXiv:1705.01677>.
 8 | Depends:
 9 |     R (>= 3.2.0)
10 | Imports: quadprog,
11 |     splines,
12 |     Matrix,
13 |     CVXR,
14 |     glmnet
15 | Suggests: Rmosek,
16 |     RColorBrewer,
17 |     testthat
18 | License: GPL-3
19 | Encoding: UTF-8
20 | LazyData: true
21 | RoxygenNote: 6.0.1
22 | 


--------------------------------------------------------------------------------
/INSTALLING_MOSEK.md:
--------------------------------------------------------------------------------
 1 | When using our method for regression discontinuity designs with a multivariate
 2 | running variable, we recommend using the optimizer MOSEK. This is a commerical
 3 | optimizer that needs to be installed separately; however, MOSEK is free for academics.
 4 | MOSEK is called from R via the RMosek interface.
 5 | 
 6 | MOSEK can be installed as follows
 7 | 
 8 | 1. [Download](https://www.mosek.com/resources/downloads) MOSEK for the relevant platform.
 9 | 2. Place the downloaded files in the home directory (e.g., /home/`<userid>`/mosek/)
10 | 3. Request a licence. If you're an [academic](https://www.mosek.com/resources/academic-license),
11 | you can get one for free.
12 | 4. Place the license in the mosek directory (e.g., /home/`<userid>`/mosek/mosek.lic)
13 | 5. Install the RMosek interface. The following (Mac OSX specific) command worked for me:
14 | 
15 | ```R
16 | install.packages("Rmosek", type="source", repos="http://download.mosek.com/R/8", configure.vars=c("PKG_MOSEKHOME=~/mosek/8/tools/platform/osx64x86", "PKG_MOSEKLIB=mosek64"))
17 | ```
18 | 


--------------------------------------------------------------------------------
/NAMESPACE:
--------------------------------------------------------------------------------
1 | # Generated by roxygen2: do not edit by hand
2 | 
3 | S3method(plot,optrdd)
4 | S3method(print,optrdd)
5 | S3method(summary,optrdd)
6 | export(get.plusminus)
7 | export(optrdd)
8 | 


--------------------------------------------------------------------------------
/R/optrdd.R:
--------------------------------------------------------------------------------
  1 | #' Optimized regression discontinuity design
  2 | #'
  3 | #' Optimized estimation and inference of treamtment effects identified
  4 | #' via regression discontinuities
  5 | #'
  6 | #' @param X The running variables.
  7 | #' @param Y The outcomes. If null, only optimal weights are computed.
  8 | #' @param W Treatment assignments, typically of the form 1(X >= c).
  9 | #' @param max.second.derivative A bound on the second derivative of mu_w(x) = E[Y(w) | X = x].
 10 | #' @param estimation.point Point "c" at which CATE is to be estimated. If estimation.point = NULL,
 11 | #'                         we estimate a weighted CATE, with weights chosen to minimize MSE,
 12 | #'                         as in Section 4.1 of Imbens and Wager (2017).
 13 | #' @param sigma.sq The irreducible noise level. If null, estimated from the data.
 14 | #' @param alpha Coverage probability of confidence intervals.
 15 | #' @param lambda.mult Optional multplier that can be used to over- or under-penalize variance.
 16 | #' @param bin.width Bin width for discrete approximation.
 17 | #' @param num.bucket Number of bins for discrete approximation. Can only be used if bin.width = NULL.
 18 | #' @param use.homoskedatic.variance Whether confidence intervals should be built assuming homoskedasticity.
 19 | #' @param use.spline Whether non-parametric components should be modeled as quadratic splines
 20 | #'                   in order to reduce the number of optimization parameters, and potentially
 21 | #'                   improving computational performance.
 22 | #' @param spline.df Number of degrees of freedom (per running variable) used for spline computation.
 23 | #' @param try.elnet.for.sigma.sq Whether an elastic net on a spline basis should be used for estimating sigma^2.
 24 | #' @param optimizer Which optimizer to use? Mosek is a commercial solver, but free
 25 | #'                  academic licenses are available. Needs to be installed separately.
 26 | #'                  ECOS is an open-source interior-point solver for conic problems,
 27 | #'                  made available via the CVXR wrapper.
 28 | #'                  Quadprog is the default R solver; it may be slow on large problems, but
 29 | #'                  is very accurate on small problems.
 30 | #'                  SCS is an open-source "operator splitting" solver that implements a first order
 31 | #'                  method for solving very large cone programs to modest accuracy. The speed of SCS may
 32 | #'                  be helpful for prototyping; however, the results may be noticeably less accurate.
 33 | #'                  SCS is also accessed via the CVXR wrapper.
 34 | #'                  The option "auto" uses a heuristic to choose.
 35 | #' @param verbose whether the optimizer should print progress information
 36 | #'
 37 | #' @return A trained optrdd object.
 38 | #' 
 39 | #' @references Domahidi, A., Chu, E., & Boyd, S. (2013, July).
 40 | #' ECOS: An SOCP solver for embedded systems.
 41 | #' In Control Conference (ECC), 2013 European (pp. 3071-3076). IEEE.
 42 | #' 
 43 | #' @references Imbens, G., & Wager, S. (2017).
 44 | #' Optimized Regression Discontinuity Designs.
 45 | #' arXiv preprint arXiv:1705.01677.
 46 | #' 
 47 | #' @references O’Donoghue, B., Chu, E., Parikh, N., & Boyd, S. (2016).
 48 | #' Conic optimization via operator splitting and homogeneous self-dual embedding.
 49 | #' Journal of Optimization Theory and Applications, 169(3), 1042-1068.
 50 | #' 
 51 | #' @examples
 52 | #' # Simple regression discontinuity with discrete X
 53 | #' n = 4000; threshold = 0
 54 | #' X = sample(seq(-4, 4, by = 8/41.5), n, replace = TRUE)
 55 | #' W = as.numeric(X >= threshold)
 56 | #' Y = 0.4 * W + 1 / (1 + exp(2 * X)) + 0.2 * rnorm(n)
 57 | #' # using 0.4 for max.second.derivative would have been enough
 58 | #' out.1 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = threshold)
 59 | #' print(out.1); plot(out.1, xlim = c(-1.5, 1.5))
 60 | #' 
 61 | #' # Now, treatment is instead allocated in a neighborhood of 0
 62 | #' thresh.low = -1; thresh.high = 1
 63 | #' W = as.numeric(thresh.low <= X & X <= thresh.high)
 64 | #' Y = 0.2 * (1 + X) * W + 1 / (1 + exp(2 * X)) + rnorm(n)
 65 | #' # This estimates CATE at specifically chosen points
 66 | #' out.2 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.low)
 67 | #' print(out.2); plot(out.2, xlim = c(-2.5, 2.5))
 68 | #' out.3 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.high)
 69 | #' print(out.3); plot(out.3, xlim = c(-2.5, 2.5))
 70 | #' # This estimates a weighted CATE, with lower variance
 71 | #' out.4 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5)
 72 | #' print(out.4); plot(out.4, xlim = c(-2.5, 2.5))
 73 | #'
 74 | #' \dontrun{
 75 | #' # RDD with multivariate running variable.
 76 | #' X = matrix(runif(n*2, -1, 1), n, 2)
 77 | #' W = as.numeric(X[,1] < 0 | X[,2] < 0)
 78 | #' Y = X[,1]^2/3 + W * (1 + X[,2]) + rnorm(n)
 79 | #' out.5 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1)
 80 | #' print(out.5); plot(out.5)
 81 | #' out.6 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1, estimation.point = c(0, 0.5))
 82 | #' print(out.6); plot(out.6)}
 83 | #' 
 84 | #' @export
 85 | optrdd = function(X,
 86 |                   Y = NULL,
 87 |                   W,
 88 |                   max.second.derivative,
 89 |                   estimation.point = NULL,
 90 |                   sigma.sq = NULL,
 91 |                   alpha = 0.95,
 92 |                   lambda.mult = 1,
 93 |                   bin.width = NULL,
 94 |                   num.bucket = NULL,
 95 |                   use.homoskedatic.variance = FALSE,
 96 |                   use.spline = TRUE,
 97 |                   spline.df = NULL,
 98 |                   try.elnet.for.sigma.sq = FALSE,
 99 |                   optimizer = c("auto", "mosek", "ECOS", "quadprog", "SCS"),
100 |                   verbose = TRUE) {
101 | 
102 |     n = length(W)
103 |     if (class(W) == "logical") W = as.numeric(W)
104 |     if (!all(W %in% c(0, 1))) stop("The treatment assignment W must be binary.")
105 |     if (!is.null(Y) & (length(Y) != n)) { stop("Y and W must have same length.") }
106 |     if (is.null(dim(X))) { X = matrix(X, ncol = 1) }
107 |     if (nrow(X) != n) { stop("The number of rows of X and the length of W must match") }
108 |     if (length(max.second.derivative) != 1) { stop("max.second.derivative must be of length 1.") }
109 |     if (!is.null(bin.width) & !is.null(num.bucket)) { stop("Only one of bin.width or num.bucket may be used.") }
110 |     
111 |     nvar = ncol(X)
112 |     if (nvar >= 3) { stop("Not yet implemented for 3 or more running variables.") }
113 |     
114 |     cate.at.pt = !is.null(estimation.point)
115 |     if (is.null(estimation.point)) { estimation.point = colMeans(X) }
116 |     univariate.monotone = (nvar == 1) &&
117 |         ((max(X[W==0, 1]) <= min(X[W==1, 1])) || (max(X[W==1, 1]) <= min(X[W==0, 1])))
118 |     
119 |     mosek_available = requireNamespace("Rmosek", quietly = TRUE)
120 | 
121 |     # Naive initialization for sigma.sq if needed
122 |     if (is.null(sigma.sq)) {
123 |         if (is.null(Y)) {
124 |             warning("Setting noise level to 1 as default...")
125 |             sigma.sq = 1
126 |         } else {
127 |             Y.hat = stats::predict(stats::lm(Y ~ X * W))
128 |             sigma.sq = mean((Y - Y.hat)^2) * length(W) / (length(W) - 2 - 2 * nvar)
129 |             if (try.elnet.for.sigma.sq){
130 |                 if(ncol(X) > 1) {
131 |                     stop("Elastic net for sigma squared not implemented with more than 1 running variable.")
132 |                 }
133 |                 linear.params = 1 + 2 * ncol(X)
134 |                 elnet.df = 7
135 |                 ridge.mat = cbind(W, X, W * X, matrix(0, length(W), 2 * elnet.df))
136 |                 ridge.mat[W==0, linear.params + 1:elnet.df] = splines::ns(X[W==0,], df = elnet.df)
137 |                 ridge.mat[W==1, linear.params + elnet.df + 1:elnet.df] = splines::ns(X[W==1,], df = elnet.df)
138 |                 elnet = glmnet::cv.glmnet(ridge.mat, Y,
139 |                                           penalty.factor = c(rep(0, linear.params),
140 |                                                              rep(1, 2 * elnet.df)),
141 |                                           keep = TRUE, alpha = 0.5)
142 |                 elnet.hat = elnet$fit.preval[,!is.na(colSums(elnet$fit.preval)),drop=FALSE][, elnet$lambda == elnet$lambda.1se]
143 |                 sigma.sq.elnet = mean((elnet.hat - Y)^2)
144 |                 sigma.sq = min(sigma.sq, sigma.sq.elnet)
145 |             }
146 |         }
147 |     }
148 | 
149 |     optimizer = match.arg(optimizer)
150 |     if (optimizer == "auto") {
151 |         if (nvar == 1 &&
152 |             use.spline &&
153 |             (univariate.monotone || !cate.at.pt) &&
154 |             length(unique(c(X))) <= 100 &&
155 |             max.second.derivative / sigma.sq <= 4) {
156 |             optimizer = "quadprog"
157 |         } else {
158 |             if (mosek_available) {
159 |                 optimizer = "mosek"
160 |             } else {
161 |                 optimizer = "ECOS"
162 |             }
163 |         }
164 |     }
165 | 
166 |     if (optimizer == "mosek") {
167 |         if (!mosek_available) {
168 |             optimizer = "ECOS"
169 |             warning("The mosek optimizer is not installed; using ECOS instead.")
170 |         }
171 |         # if (!requireNamespace("Rmosek", quietly = TRUE)) {
172 |         #     optimizer = "quadprog"
173 |         #     if (nvar >= 2) {
174 |         #         op = options("warn")
175 |         #         on.exit(options(op))
176 |         #         options(warn=1)
177 |         #         warning(paste("The mosek optimizer is not installed; using quadprog instead.",
178 |         #                       "This may be very slow with more than one running variable."))
179 |         #     } else {
180 |         #         warning(paste("The mosek optimizer is not installed; using quadprog instead."))
181 |         #     }
182 |         # }
183 |     }
184 | 
185 |     if (optimizer == "SCS") {
186 |         warning(paste("SCS is a fast an free optimizer, but doesn't solve the problem exactly.",
187 |                       "Resulting confidence intervals may be needlessly long.",
188 |                       "It is recommended to also try MOSEK."))
189 |     }
190 | 
191 |     # Create discrete grid on which to optimize, and assign each training example
192 |     # to a cell.
193 |     if (nvar == 1) {
194 |         
195 |         if (is.null(bin.width)) {
196 |             if (is.null(num.bucket)) { num.bucket = 2000 }
197 |             bin.width = (max(X[,1]) - min(X[,1])) / num.bucket
198 |         }
199 |         breaks = seq(min(X[,1]) - bin.width/2, max(X[,1]) + bin.width, by = bin.width)
200 |         xx.grid = breaks[-1] - bin.width/2
201 |         num.bucket = length(xx.grid)
202 |         
203 |         xx.grid = matrix(xx.grid, ncol = 1)
204 |         xx.centered = matrix(xx.grid - estimation.point, ncol = 1)
205 |         zeroed.idx = max(which(xx.centered < 0)) + c(0, 1)
206 |         
207 |         idx.to.bucket = as.numeric(cut(X[,1], breaks = breaks))
208 |         
209 |     } else if (nvar == 2) {
210 |         
211 |         if (is.null(bin.width)) {
212 |             if (is.null(num.bucket)) { 
213 |                 if (optimizer == "quadprog") {
214 |                     num.bucket = 900
215 |                     warning(paste("Using coarse discrete approximation of size 30x30",
216 |                                   "to make quadprog run faster (i.e., num.bucket = 900.)"))
217 |                 } else {
218 |                     num.bucket = 10000
219 |                 }
220 |             }
221 |             bin.width = sqrt((max(X[,1]) - min(X[,1])) * (max(X[,2]) - min(X[,2])) / num.bucket)
222 |         }
223 |         breaks1 = seq(min(X[,1]) - bin.width/2, max(X[,1]) + bin.width, by = bin.width)
224 |         breaks2 = seq(min(X[,2]) - bin.width/2, max(X[,2]) + bin.width, by = bin.width)
225 |         xx1 = breaks1[-1] - bin.width/2
226 |         xx2 = breaks2[-1] - bin.width/2
227 |         xx.grid = expand.grid(xx1, xx2)
228 |         xx.centered = t(t(xx.grid) - estimation.point)
229 |         num.bucket = nrow(xx.grid)
230 | 
231 |         z1 = max(which(xx1 < estimation.point[1])) + c(0, 1)
232 |         z2 = max(which(xx2 < estimation.point[2])) + c(0, 1)
233 |         zeroed.idx = as.matrix(expand.grid(z1 - 1, z2 - 1)) %*% c(1, length(xx1))
234 |         
235 |         idx.1 = as.numeric(cut(X[,1], breaks = breaks1))
236 |         idx.2 = as.numeric(cut(X[,2], breaks = breaks2))
237 |         idx.to.bucket = sapply(1:nrow(X), function(iter) idx.1[iter] + (idx.2[iter] - 1) * length(xx1))
238 |         
239 |     } else {
240 |         stop("Not yet implemented for 3 or more running variables.")
241 |     }
242 |     
243 |     # Define matrix of constraints.
244 |     # D2 is a raw curvature matrix, not accounting for bin.width.
245 |     if (nvar == 1) {
246 |         D2 = Matrix::bandSparse(n=num.bucket-2, m=num.bucket, k = c(0, 1, 2),
247 |                                 diag = list(rep(1, num.bucket), rep(-2, num.bucket))[c(1, 2, 1)])
248 |     } else if (nvar == 2) {
249 |         all.idx = expand.grid(1:length(xx1), 1:length(xx2))
250 |         # remove corners
251 |         all.idx = all.idx[!(all.idx[,1] %in% c(1, length(xx1)) & all.idx[,2] %in% c(1, length(xx2))),]
252 |         D2.entries = do.call(rbind, sapply(1:nrow(all.idx), function(i12) {
253 |             i1 = all.idx[i12,1]
254 |             i2 = all.idx[i12,2]
255 |             edge.1 = i1 %in% c(1, length(xx1))
256 |             edge.2 = i2 %in% c(1, length(xx2))
257 |             rbind(
258 |                 if (!edge.1) {
259 |                     cbind(j=(i1 - 1):(i1 + 1) + (i2 - 1) * length(xx1),
260 |                           x=c(1, -2, 1))
261 |                 } else { numeric() },
262 |                 if (!edge.2) {
263 |                     cbind(j=i1 + ((i2 - 2):i2) * length(xx1),
264 |                           x=c(1, -2, 1))
265 |                 } else { numeric() },
266 |                 if (!(edge.1 | edge.2)) {
267 |                     cbind(j = c((i1 - 1):(i1 + 1) + ((i2 - 2):i2) * length(xx1),
268 |                                 (i1 - 1):(i1 + 1) + (i2:(i2 - 2)) * length(xx1)),
269 |                           x = c(c(1/2, -1, 1/2), c(1/2, -1, 1/2)))
270 |                 } else { numeric() })
271 |         }))
272 |         D2.i = c(t(matrix(rep(1:(nrow(D2.entries)/3), 3), ncol = 3)))
273 |         D2 = Matrix::sparseMatrix(i=D2.i, j=D2.entries[,1], x=D2.entries[,2])
274 |     } else {
275 |         stop("Not yet implemented for 3 or more running variables.")
276 |     }
277 |     
278 |     # Construct a (weighted) histogram representing the X and Y values.
279 |     fact = factor(idx.to.bucket, levels = as.character(1:num.bucket))
280 |     bucket.map = Matrix::sparse.model.matrix(~fact + 0, transpose = TRUE)
281 |     X.counts = as.numeric(bucket.map %*% rep(1, n))
282 |     W.counts = as.numeric(bucket.map %*% W)
283 |     
284 |     realized.idx.0 = which(X.counts > W.counts)
285 |     realized.idx.1 = which(W.counts > 0)
286 |     num.realized.0 = length(realized.idx.0)
287 |     num.realized.1 = length(realized.idx.1)
288 |     
289 |     # These matrices map non-parametric dual parameters f_w(x) to buckets
290 |     # where gamma needs to be evaluated
291 |     selector.0 = Matrix::Diagonal(num.bucket, 1)[realized.idx.0,]
292 |     selector.1 = Matrix::Diagonal(num.bucket, 1)[realized.idx.1,]
293 |     
294 |     # We force centering.matrix %*% f_w(x) = 0, to ensure identification of f_w(x)
295 |     centering.matrix = Matrix::sparseMatrix(dims = c(length(zeroed.idx), num.bucket),
296 |                                             i = 1:length(zeroed.idx),
297 |                                             j = zeroed.idx,
298 |                                             x = rep(1, length(zeroed.idx)))
299 |     
300 |     # Computational performance can be improved by representing non-parametric
301 |     # components in a quadratic spline basis.
302 |     if (use.spline) {
303 |         if (is.null(spline.df)) {
304 |             if (optimizer == "mosek" || optimizer == "SCS" || optimizer == "ECOS") {
305 |                 spline.df = c(100, 45 - 15 * cate.at.pt)[nvar]
306 |             } else {
307 |                 spline.df = c(40, 10)[nvar]
308 |             }
309 |         }
310 |         if ((nvar == 1 && spline.df > nrow(xx.centered) / 2) |
311 |             (nvar == 2 && spline.df > min(length(xx1), length(xx2)) * 0.7)) {
312 |             use.spline = FALSE
313 |         }
314 |     }
315 |     
316 |     if (use.spline) {
317 |         if (nvar == 1) {
318 |             basis.mat.raw = splines::bs(xx.grid, degree = 2, df=spline.df, intercept = TRUE)
319 |             class(basis.mat.raw) = "matrix"
320 |             basis.mat = Matrix::Matrix(basis.mat.raw)
321 |         } else if (nvar == 2) {
322 |             basis.mat.1 = splines::bs(xx.grid[,1], degree = 2, df=spline.df, intercept = TRUE)
323 |             basis.mat.2 = splines::bs(xx.grid[,2], degree = 2, df=spline.df, intercept = TRUE)
324 |             basis.mat = Matrix::sparse.model.matrix(~ basis.mat.1:basis.mat.2 + 0)
325 |         } else {
326 |             stop("Not yet implemented for 3 or more running variables.")
327 |         }
328 |         
329 |         D2 = D2 %*% basis.mat
330 |         selector.0 = selector.0 %*% basis.mat
331 |         selector.1 = selector.1 %*% basis.mat
332 |         centering.matrix = centering.matrix %*% basis.mat
333 |         num.df = ncol(basis.mat)
334 |     } else {
335 |         num.df = num.bucket
336 |     }
337 |     
338 |     # If we are in one dimension and have a threshold RDD, it is
339 |     # enough to estimate a single nuisance function f0.
340 |     change.slope = cate.at.pt
341 |     #two.fun = cate.at.pt & !univariate.monotone
342 |     two.fun = TRUE
343 |                                
344 |     # We now prepare inputs to a numerical optimizer. We seek to
345 |     # solve a discretized version of equation (18) from Imbens and Wager (2017).
346 |     # The parameters to the problem are ordered as (G(0), G(1), lambda, f0, f1).
347 |     num.lambda = 3 + nvar * (1 + change.slope)
348 |     num.params = num.realized.0 + num.realized.1 + num.lambda + (1 + two.fun) * num.df
349 |     
350 |     # The quadratic component of the objective is 1/2 sum_j Dmat.diagonal_j * params_j^2
351 |     Dmat.diagonal = c((X.counts[realized.idx.0] - W.counts[realized.idx.0]) / 2 / sigma.sq,
352 |                       (W.counts[realized.idx.1]) / 2 / sigma.sq,
353 |                       lambda.mult / max.second.derivative^2 / 2,
354 |                       rep(0, num.lambda - 1 + (1 + two.fun) * num.df))
355 |     # The linear component of the objective is sum(dvec * params)
356 |     dvec = c(rep(0, num.realized.0 + num.realized.1 + 1), 1, -1,
357 |              rep(0, num.lambda - 3 + (1 + two.fun) * num.df))
358 |     # We now impose constrains on Amat %*% params.
359 |     # The first meq constrains are equality constraints (Amat %*% params = 0);
360 |     # the remaining ones are inequalities (Amat %*% params >= 0).
361 |     Amat = rbind(
362 |         # Defines G(0) in terms of the other problem parameters (equality constraint)
363 |         cbind(Matrix::Diagonal(num.realized.0, -1),
364 |               Matrix::Matrix(0, num.realized.0, num.realized.1),
365 |               0, 0, 1, xx.centered[realized.idx.0,],
366 |               if(change.slope) { -xx.centered[realized.idx.0,] } else { numeric() },
367 |               selector.0,
368 |               if(two.fun) { Matrix::Matrix(0, num.realized.0, num.df) } else { numeric() }),
369 |         # Defines G(1) in terms of the other problem parameters (equality constraint)
370 |         cbind(Matrix::Matrix(0, num.realized.1, num.realized.0),
371 |               Matrix::Diagonal(num.realized.1, -1),
372 |               0, 1, 0, xx.centered[realized.idx.1,],
373 |               if(change.slope) { xx.centered[realized.idx.1,] } else { numeric() },
374 |               if(two.fun) {
375 |                   cbind(Matrix::Matrix(0, num.realized.1, num.df), selector.1)
376 |               } else {
377 |                   selector.1
378 |               }),
379 |         # Ensure that f_w(c), f'_w(c) = 0
380 |         cbind(Matrix::Matrix(0, length(zeroed.idx), num.realized.0 + num.realized.1 + num.lambda),
381 |               centering.matrix,
382 |               Matrix::Matrix(0, length(zeroed.idx), as.numeric(two.fun) * num.df)),
383 |         if(two.fun) {
384 |             cbind(Matrix::Matrix(0, length(zeroed.idx), num.realized.0 + num.realized.1 + num.lambda + num.df),
385 |                   centering.matrix)
386 |         } else { numeric() },
387 |         # Bound the second derivative of f_0 by lambda_1
388 |         cbind(Matrix::Matrix(0, 2 * nrow(D2), num.realized.0 + num.realized.1),
389 |               bin.width^2,
390 |               matrix(0, 2 * nrow(D2), num.lambda - 1),
391 |               rbind(D2, -D2),
392 |               if (two.fun) { Matrix::Matrix(0, 2 * nrow(D2), num.df) } else { numeric() }),
393 |         # Bound the second derivative of f_1 by lambda_1
394 |         if (two.fun) {
395 |             cbind(Matrix::Matrix(0, 2 * nrow(D2), num.realized.0 + num.realized.1),
396 |                   bin.width^2,
397 |                   matrix(0, 2 * nrow(D2), num.lambda - 1 + num.df),
398 |                   rbind(D2, -D2))
399 |         })
400 |     
401 |     meq = num.realized.0 + num.realized.1 + length(zeroed.idx) * (1 + two.fun)
402 |     bvec = rep(0, nrow(Amat))
403 |     
404 |     gamma.0 = rep(0, num.bucket)
405 |     gamma.1 = rep(0, num.bucket)
406 |     
407 |     if (optimizer == "quadprog") {
408 |         
409 |         if (verbose) {
410 |             print(paste0("Running quadrprog with problem of size: ",
411 |                          dim(Amat)[1], " x ", dim(Amat)[2], "..."))
412 |         }
413 |         # For quadprog, we need Dmat to be positive definite, which is why we add a small number to the diagonal.
414 |         # The conic implementation via mosek does not have this issue.
415 |         soln = quadprog::solve.QP(Matrix::Diagonal(num.params, Dmat.diagonal + 0.000000001),
416 |                                   -dvec,
417 |                                   Matrix::t(Amat),
418 |                                   bvec,
419 |                                   meq=meq)
420 |         
421 |         gamma.0[realized.idx.0] = - soln$solution[1:num.realized.0] / sigma.sq / 2
422 |         gamma.1[realized.idx.1] = - soln$solution[num.realized.0 + 1:num.realized.1] / sigma.sq / 2
423 |         t.hat = soln$solution[num.realized.0 + num.realized.1 + 1] / (2 * max.second.derivative^2)
424 |         
425 |     } else if (optimizer == "SCS" || optimizer == "ECOS") {
426 |       
427 |         if (verbose && optimizer == "SCS") {
428 |             print(paste0("Running CVXR/SCS with problem of size: ",
429 |                          dim(Amat)[1], " x ", dim(Amat)[2], "..."))
430 |         }
431 |         
432 |         if (verbose && optimizer == "ECOS") {
433 |             print(paste0("Running CVXR/ECOS with problem of size: ",
434 |                          dim(Amat)[1], " x ", dim(Amat)[2], "..."))
435 |         }
436 |         
437 |         xx = CVXR::Variable(ncol(Amat))
438 |         objective = sum(Dmat.diagonal/2 * xx^2 + dvec * xx)
439 |         contraints = list(
440 |             Amat[1:meq,] %*% xx == bvec[1:meq],
441 |             Amat[(meq+1):nrow(Amat),] %*% xx >= bvec[(meq+1):nrow(Amat)]
442 |         )
443 |         cvx.problem = CVXR::Problem(CVXR::Minimize(objective), contraints)
444 |         cvx.output = CVXR::solve(cvx.problem, solver = optimizer, verbose = verbose)
445 |         
446 |         if (cvx.output$status != "optimal") {
447 |             warning(paste0("CVXR returned with status: ",
448 |                            cvx.output$status,
449 |                            ". For better results, try another optimizer (MOSEK is recommended)."))
450 |         }
451 |         
452 |         result = cvx.output$getValue(xx)
453 |         gamma.0[realized.idx.0] = - result[1:num.realized.0] / sigma.sq / 2
454 |         gamma.1[realized.idx.1] = - result[num.realized.0 + 1:num.realized.1] / sigma.sq / 2
455 |         t.hat = result[num.realized.0 + num.realized.1 + 1] / (2 * max.second.derivative^2)
456 |       
457 |     } else if (optimizer == "mosek") {
458 |         
459 |         # We need to rescale our optimization parameters, such that Dmat has only
460 |         # ones and zeros on the diagonal; i.e.,
461 |         A.natural = Amat %*% Matrix::Diagonal(ncol(Amat), x=1/sqrt(Dmat.diagonal + as.numeric(Dmat.diagonal == 0)))
462 |         
463 |         mosek.problem <- list()
464 |         
465 |         # The A matrix relates parameters to constraints, via
466 |         # blc <= A * { params } <= buc, and blx <= params <= bux
467 |         # The conic fomulation adds two additional parameters to the problem, namely
468 |         # a parameter "S" and "ONE", that are characterized by a second-order cone constraint
469 |         # S * ONE >= 1/2 {params}' Dmat {params},
470 |         # and the equality constraint ONE = 1
471 |         mosek.problem$A <- cbind(A.natural, Matrix::Matrix(0, nrow(A.natural), 2))
472 |         mosek.problem$bc <- rbind(blc = rep(0, nrow(A.natural)), buc = c(rep(0, meq), rep(Inf, nrow(A.natural) - meq)))
473 |         mosek.problem$bx <- rbind(blx = c(rep(-Inf, ncol(A.natural)), 0, 1), bux = c(rep(Inf, ncol(A.natural)), Inf, 1))
474 |         
475 |         # This is the cone constraint
476 |         mosek.problem$cones <- cbind(list("RQUAD", c(ncol(Amat) + 1, ncol(Amat) + 2, which(Dmat.diagonal != 0))))
477 |         
478 |         # We seek to minimize c * {params}
479 |         mosek.problem$sense <- "min"
480 |         mosek.problem$c <- c(dvec, 1, 0)
481 |         
482 |         #mosek.problem$dparam= list(BASIS_TOL_S=1.0e-9, BASIS_TOL_X=1.0e-9)
483 |         
484 |         if (verbose) {
485 |             mosek.out = Rmosek::mosek(mosek.problem)
486 |         } else {
487 |             mosek.out = Rmosek::mosek(mosek.problem, opts=list(verbose=0))
488 |         }
489 |         
490 |         if (mosek.out$response$code != 0) {
491 |             warning(paste("MOSEK returned with status",
492 |                           mosek.out$response$msg,
493 |                           "For better results, try another optimizer."))
494 |         }
495 |         
496 |         # We now also need to re-adjust for "natural" scaling
497 |         gamma.0[realized.idx.0] = - mosek.out$sol$itr$xx[1:num.realized.0] / sigma.sq / 2 /
498 |             sqrt(Dmat.diagonal[1:num.realized.0])
499 |         gamma.1[realized.idx.1] = - mosek.out$sol$itr$xx[num.realized.0 + 1:num.realized.1] / sigma.sq / 2 /
500 |             sqrt(Dmat.diagonal[num.realized.0 + 1:num.realized.1])
501 |         t.hat = mosek.out$sol$itr$xx[num.realized.0 + num.realized.1 + 1] / (2 * max.second.derivative^2) /
502 |             sqrt(Dmat.diagonal[num.realized.0 + num.realized.1 + 1])
503 |         
504 |     } else {
505 |         stop("Optimizer choice not valid.")
506 |     }
507 |     
508 |     # Now map the x-wise functions into a weight for each observation
509 |     gamma = rep(0, length(W))
510 |     gamma[W==0] = as.numeric(Matrix::t(bucket.map[,which(W==0)]) %*% gamma.0)
511 |     gamma[W==1] = as.numeric(Matrix::t(bucket.map[,which(W==1)]) %*% gamma.1)
512 |     
513 |     # Patch up numerical inaccuracies
514 |     gamma[W==0] = -gamma[W==0] / sum(gamma[W==0])
515 |     gamma[W==1] = gamma[W==1] / sum(gamma[W==1])
516 |     
517 |     # Compute the worst-case imbalance...
518 |     max.bias = max.second.derivative * t.hat
519 |     
520 |     # If outcomes are provided, also compute confidence intervals for tau.
521 |     if (!is.null(Y)) {
522 |         
523 |         # The point estimate
524 |         tau.hat = sum(gamma * Y)
525 |         
526 |         if (use.homoskedatic.variance) {
527 |             se.hat.tau = sqrt(sum(gamma^2 * sigma.sq))
528 |         } else {
529 |             # A heteroskedaticity-robust variance estimate.
530 |             # Weight the regression towards areas used in estimation, so we are not
531 |             # too vulnerable to curvature effects far from the boundary.
532 |             regr.df = data.frame(X=X, W=W, Y=Y, gamma.sq = gamma^2)
533 |             regr.df = regr.df[regr.df$gamma.sq != 0,]
534 |             Y.fit = stats::lm(Y ~ X * W, data = regr.df, weights = regr.df$gamma.sq)
535 |             self.influence = stats::lm.influence(Y.fit)$hat
536 |             Y.resid.sq = (regr.df$Y - stats::predict(Y.fit))^2
537 |             se.hat.tau = sqrt(sum(Y.resid.sq * regr.df$gamma.sq / (1 - self.influence)))
538 | 
539 |             if (!try.elnet.for.sigma.sq & se.hat.tau^2 < 0.8 * sum(regr.df$gamma.sq) * sigma.sq) {
540 |                 warning(paste("Implicit estimate of sigma^2 may be too pessimistic,",
541 |                               "resulting in valid but needlessly long confidence intervals.",
542 |                               "Try the option `try.elnet.for.sigma.sq = TRUE` for potentially improved performance."))
543 |             }
544 |         }
545 |         
546 |         # Confidence intervals that account for both bias and variance
547 |         tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
548 |     } else {
549 |         tau.hat = NULL
550 |         se.hat.tau = sqrt(sigma.sq * sum(gamma^2))
551 |         tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
552 |     }
553 |     
554 |     ret = list(tau.hat=tau.hat,
555 |                tau.plusminus=tau.plusminus,
556 |                alpha=alpha,
557 |                max.bias = max.bias,
558 |                sampling.se=se.hat.tau,
559 |                gamma=gamma,
560 |                gamma.fun.0 = data.frame(xx=xx.grid[realized.idx.0,],
561 |                                         gamma=gamma.0[realized.idx.0]),
562 |                gamma.fun.1 = data.frame(xx=xx.grid[realized.idx.1,],
563 |                                         gamma=gamma.1[realized.idx.1]))
564 |     class(ret) = "optrdd"
565 |     return(ret)
566 | }
567 | 


--------------------------------------------------------------------------------
/R/utils.R:
--------------------------------------------------------------------------------
  1 | #' Bias-adjusted Gaussian confidence intervals.
  2 | #'
  3 | #' @param max.bias Worst-case bias of estimate.
  4 | #' @param sampling.se Sampling error of estimate.
  5 | #' @param alpha Coverage probability of confidence interval.
  6 | #'
  7 | #' @return Half-width of confidence interval.
  8 | #' @export
  9 | get.plusminus = function(max.bias, sampling.se, alpha = 0.95) {
 10 |     rel.bias = max.bias/sampling.se
 11 |     zz = stats::uniroot(function(z) stats::pnorm(rel.bias - z) +
 12 |                             stats::pnorm(-rel.bias - z) + alpha - 1,
 13 |                         c(0, rel.bias - stats::qnorm((1 - alpha)/3)))$root
 14 |     zz * sampling.se
 15 | }
 16 | 
 17 | #' @export
 18 | print.optrdd = function(x, ...) {
 19 |     if (!is.null(x$tau.hat)) {
 20 |         print(paste0(100 * x$alpha, "% CI for tau: ",
 21 |                      signif(x$tau.hat, 2), " +/- ", signif(x$tau.plusminus, 2)))
 22 |     } else {
 23 |         print(paste0(100 * x$alpha, "% CI for tau: [point estimate] +/- ", 
 24 |                      signif(x$tau.plusminus, 2)))
 25 |     }
 26 | }
 27 | 
 28 | #' @export
 29 | summary.optrdd = function(object, ...) {
 30 |     unlist(object)[1:5]
 31 | }
 32 | 
 33 | #' @export
 34 | plot.optrdd = function(x, ...) {
 35 |     
 36 |     nvar = dim(x$gamma.fun.0)[2] - 1
 37 |     args = list(...)
 38 |     
 39 |     if (nvar == 1) {
 40 |         
 41 |         all.x = c(x$gamma.fun.0[,1], x$gamma.fun.1[,1])
 42 |         if (!"xlim" %in% names(args)) {
 43 |             args$xlim = range(all.x)
 44 |         }
 45 |         if (!"ylim" %in% names(args)) {
 46 |             args$ylim = range(x$gamma)
 47 |         }
 48 |         if (!"xlab" %in% names(args)) {
 49 |             args$xlab = "x"
 50 |         }
 51 |         if (!"ylab" %in% names(args)) {
 52 |             args$ylab = "gamma"
 53 |         }
 54 |         args$x = NA; args$y = NA
 55 |         do.call(graphics::plot, args)
 56 |         if (length (unique(all.x) > 40)) {
 57 |             graphics::points(x$gamma.fun.0, col = 4, pch = 16, cex = 1.5)
 58 |             graphics::points(x$gamma.fun.1, col = 2, pch = 16, cex = 1.5)
 59 |         } else {
 60 |             graphics::lines(x$gamma.fun.0, col = 4, lwd = 2)
 61 |             graphics::lines(x$gamma.fun.1, col = 2, lwd = 2)
 62 |         }
 63 |         graphics::abline(h=0, lty = 3)
 64 |         
 65 |     } else if (nvar == 2) {
 66 |         
 67 |         if (!requireNamespace("RColorBrewer", quietly = TRUE)) {
 68 |             stop("RColorBrewer needed for this function to work. Please install it.", 
 69 |                  call. = FALSE)
 70 |         }
 71 |         gamma.all = c(x$gamma.fun.0[, 3], x$gamma.fun.1[, 3])
 72 |         cidx = 51 + round(50 * gamma.all/max(abs(gamma.all)))
 73 |         hc = grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "RdBu"))(101)
 74 |         
 75 |         x1rng = range(x$gamma.fun.0[, 1], x$gamma.fun.1[, 1])
 76 |         x2rng = range(x$gamma.fun.0[, 2], x$gamma.fun.1[, 2])
 77 |         
 78 |         if (!"xlim" %in% names(args)) {
 79 |             args$xlim = x1rng
 80 |         }
 81 |         if (!"ylim" %in% names(args)) {
 82 |             args$ylim = x2rng
 83 |         }
 84 |         if (!"xlab" %in% names(args)) {
 85 |             args$xlab = "x1"
 86 |         }
 87 |         if (!"ylab" %in% names(args)) {
 88 |             args$ylab = "x2"
 89 |         }
 90 |         args$x = NA; args$y = NA
 91 |         do.call(graphics::plot, args)
 92 |         graphics::points(x$gamma.fun.0[, 1:2],
 93 |                          col = hc[cidx[1:nrow(x$gamma.fun.0)]],
 94 |                          pch = 16)
 95 |         graphics::points(x$gamma.fun.1[, 1:2],
 96 |                          col = hc[cidx[nrow(x$gamma.fun.0) + 1:nrow(x$gamma.fun.1)]],
 97 |                          pch = 1, lwd = 2)
 98 |     
 99 |     } else {
100 |         stop("Corrupted object.")
101 |     }
102 | }
103 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # optrdd
 2 | Optimized inference in regression discontinuity designs, as proposed by Imbens and Wager (2017).
 3 | 
 4 | To install this package in R, run the following commands:
 5 | 
 6 | ```R
 7 | library(devtools) 
 8 | install_github("swager/optrdd")
 9 | ```
10 | 
11 | This package currently works with two optimizers: `mosek` an `quadprog`.
12 | Mosek is a commercial interior point solver that needs to be installed separately,
13 | while quadprog is a standard `R` optimization library.
14 | Both optimizers appear to work well with a univariate running variable;
15 | however, with multi-dimensional running variables, we strongly recommend
16 | [installing mosek](INSTALLING_MOSEK.md).
17 | 
18 | Replication files for Imbens and Wager (2017) are available in
19 | the directory `experiments_from_paper`.
20 | 
21 | Example usage:
22 | 
23 | ```R
24 | library(optrdd)
25 | 
26 | # Simple regression discontinuity with discrete X
27 | n = 4000; threshold = 0
28 | X = sample(seq(-4, 4, by = 8/41.5), n, replace = TRUE)
29 | W = as.numeric(X >= threshold)
30 | Y = 0.4 * W + 1 / (1 + exp(2 * X)) + 0.2 * rnorm(n)
31 | # using 0.4 for max.second.derivative would have been enough
32 | out.1 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = threshold)
33 | print(out.1); plot(out.1, xlim = c(-1.5, 1.5))
34 | 
35 | # Now, treatment is instead allocated in a neighborhood of 0
36 | thresh.low = -1; thresh.high = 1
37 | W = as.numeric(thresh.low <= X & X <= thresh.high)
38 | Y = 0.2 * (1 + X) * W + 1 / (1 + exp(2 * X)) + rnorm(n)
39 | # This estimates CATE at specifically chosen points
40 | out.2 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.low)
41 | print(out.2); plot(out.2, xlim = c(-2.5, 2.5))
42 | out.3 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.high)
43 | print(out.3); plot(out.3, xlim = c(-2.5, 2.5))
44 | # This estimates a weighted CATE, with lower variance
45 | out.4 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5)
46 | print(out.4); plot(out.4, xlim = c(-2.5, 2.5))
47 | 
48 | # RDD with multivariate running variable. Warning: slow without mosek.
49 | X = matrix(runif(n*2, -1, 1), n, 2)
50 | W = as.numeric(X[,1] < 0 | X[,2] < 0)
51 | Y = X[,1]^2/3 + W * (1 + X[,2]) + rnorm(n)
52 | out.5 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1)
53 | print(out.5); plot(out.5)
54 | out.6 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1, estimation.point = c(0, 0.5))
55 | print(out.6); plot(out.6)
56 | ```
57 | 
58 | #### References
59 | Guido Imbens and Stefan Wager.
60 | <b>Optimized Regression Discontinuity Designs.</b>
61 | <i>Review of Economics and Statistics</i>, forthcoming.
62 | [<a href="https://arxiv.org/pdf/1705.01677.pdf">arxiv</a>]
63 | 


--------------------------------------------------------------------------------
/baselines/local.lin.reg.R:
--------------------------------------------------------------------------------
  1 | #' Locally linear regression discontinuity design
  2 | #' 
  3 | #' Locally linear estimation and inference of treamtment effects identified
  4 | #' via regression discontinuities
  5 | #' 
  6 | #' @param X The running variables.
  7 | #' @param max.second.derivative A bound on the second derivative of mu_w(x) = E[Y(w) | X = x].
  8 | #' @param bandwidth Bandwidth for the llr. If null, adaptively optimize for the bandwidth.
  9 | #' @param Y The outcomes.
 10 | #' @param num.samples Number of samples used to compute each datapoint (perhaps we only have
 11 | #'                    access to summary data, where each datapoint is averaged over many samples).
 12 | #' @param threshold The threshold determining treatment assignment.
 13 | #' @param sigma.sq The irreducible noise level. If null, estimated from the data.
 14 | #' @param change.derivative Whether we allow for a change in slope at the threshold.
 15 | #' @param alpha Coverage probability of confidence intervals.
 16 | #' @param max.window Maximum possible bandwidth to consider in optimization.
 17 | #' @param num.bucket Number of histogram buckets in numerical analysis.
 18 | #' @param kernel Shape of weighting function for local regression.
 19 | #' @param minimization.target Whether bandwidth should minimize maximum mse or confidence
 20 | #'                            interval length.
 21 | #' @param use.homoskedatic.variance Whether confidence intervals should be built assuming homoskedasticity.
 22 | #'
 23 | #' @return A trained optrdd object. Note that locally linear regression also provides
 24 | #'         a linear estimator for tau, just like optrdd. The gammas simply aren't optimal.
 25 | llr = function(X,
 26 |                max.second.derivative,
 27 |                bandwidth = NULL,
 28 |                Y = NULL,
 29 |                num.samples = rep(1, length(X)), 
 30 |                threshold = 0,
 31 |                sigma.sq = NULL,
 32 |                change.derivative = TRUE,
 33 |                alpha = 0.95,
 34 |                max.window = NULL,
 35 |                num.bucket = 600,
 36 |                kernel = c("rectangular", "triangular"),
 37 |                minimization.target = c("mse", "ci.length"),
 38 |                use.homoskedatic.variance = FALSE) {
 39 |   
 40 |   kernel = match.arg(kernel)
 41 |   minimization.target = match.arg(minimization.target)
 42 |   
 43 |   # We compute our estimator based on a histogram summary of the data,
 44 |   # shifted such that the threshold is at 0. The breaks vector defines
 45 |   # the boundaries between buckets.
 46 |   if (is.null(max.window)) {
 47 |       xx = seq(min(X - threshold), max(X - threshold), length.out = num.bucket)
 48 |   } else {
 49 |       xx = seq(-max.window, max.window, length.out = num.bucket)
 50 |   }
 51 |   bin.width = xx[2] - xx[1]
 52 |   breaks = c(xx - bin.width/2, max(xx) + bin.width/2)
 53 |   
 54 |   # Construct a (weighted) histogram representing the X-values.
 55 |   if (!is.null(max.window)) {
 56 |       inrange = which(abs(X - threshold) / max.window <= 1)
 57 |   } else {
 58 |       inrange = 1:length(X)
 59 |   }
 60 |   bucket = cut(X[inrange] - threshold, breaks = breaks)
 61 |   bucket.map = Matrix::sparse.model.matrix(~bucket + 0, transpose = TRUE)
 62 |   X.counts = as.numeric(bucket.map %*% num.samples[inrange])
 63 |   
 64 |   # Naive initialization for sigma.sq if needed
 65 |   if (is.null(sigma.sq)) {
 66 |     if (is.null(Y)) {
 67 |       warning("Setting noise level to 1 as default...")
 68 |       sigma.sq = 1
 69 |     } else {
 70 |       regr.df = data.frame(X=X, W=X>=threshold, Y=Y)
 71 |       Y.fit = lm(Y ~ X * W, data = regr.df[inrange,], weights=num.samples[inrange])
 72 |       sigma.sq = sum((Y[inrange] - predict(Y.fit))^2 * num.samples[inrange]^2) /
 73 |         (sum(num.samples[inrange]) - 4)
 74 |     }
 75 |   }
 76 |   
 77 |   # The matrix M is used to intergrate a function over xx,
 78 |   # starting at 0. The matrix M2 integrates twice.
 79 |   M = outer(xx, xx, FUN=Vectorize(function(x1, x2) {
 80 |     if(x1 < 0 & x2 <= 0 & x1 < x2) {return(-bin.width)}
 81 |     if(x1 > 0 & x2 >= 0 & x1 > x2) {return(bin.width)}
 82 |     return(0)
 83 |   }))
 84 |   M2 = M %*% M
 85 |   
 86 |   if (!is.null(bandwidth)) {
 87 |       bw.vec = bandwidth
 88 |   } else {
 89 |       if (!is.null(max.window)) {
 90 |           bw.vec = c(1:40) * max.window / 40
 91 |       } else {
 92 |           bw.vec = c(1:40) * min(max(xx), max(-xx)) / 40
 93 |       }
 94 |   }
 95 |   
 96 |   soln.vec = lapply(bw.vec, function(bw) {
 97 |     
 98 |     # only consider counts that occurs inside the bandwidth
 99 |     realized.idx = which((X.counts > 0) & (abs(xx) < bw))
100 |     num.realized = length(realized.idx)
101 |     
102 |     signed.num.realized = min(sum(xx[realized.idx] > 0), sum(xx[realized.idx] < 0))
103 |     
104 |     if (signed.num.realized < 2) {
105 |       return(list(max.mse=NA, max.bias=NA, homosk.plusminus=NA, gamma.xx=NA, realized.idx=NA))
106 |     }
107 |     
108 |     # This optimizer learns bucket-wise gammas. Let k denote
109 |     # the bucket index, n[k] the number of observations in
110 |     # bucket k, and x[k] is the center of bucket k.
111 |     #
112 |     # We solve the following. Note that gamma[k] must be 0
113 |     # if n[k] is 0, so we only optimize gamma over realized indices.
114 |     #
115 |     # argmin sum_k gamma[k]^2 * n[k]
116 |     # subject to:
117 |     #  sum_k n[k] gamma[k] = 0
118 |     #  sum_k n[k] gamma[k] (2 W[k] - 1) = 2
119 |     #  sum_k n[k] gamma[k] x[k] = 0
120 |     
121 |     if (kernel == "rectangular") {
122 |       Dmat = diag(X.counts[realized.idx])
123 |     } else if (kernel == "triangular") {
124 |       Dmat = diag(X.counts[realized.idx] / (1 - abs(xx[realized.idx]) / bw))
125 |     }
126 |     dvec = rep(0, num.realized)
127 |     
128 |     Amat = cbind(X.counts[realized.idx],
129 |                  X.counts[realized.idx] * sign(xx[realized.idx]),
130 |                  X.counts[realized.idx] * xx[realized.idx])
131 |     
132 |     if(!change.derivative) {
133 |       bvec = c(0, 2, 0)
134 |       meq = 3
135 |     } else {
136 |       Amat = cbind(Amat,
137 |                    X.counts[realized.idx] * pmax(xx[realized.idx], 0))
138 |       bvec = c(0, 2, 0, 0)
139 |       meq = 4
140 |     }
141 |     
142 |     soln = quadprog::solve.QP(Dmat, dvec, Amat, bvec, meq)$solution
143 |     
144 |     gamma.xx = rep(0, num.bucket)
145 |     gamma.xx[realized.idx] = soln[1:num.realized]
146 |     max.bias = max.second.derivative * sum(abs(t(M2) %*% (X.counts * gamma.xx)))
147 |     sigma.hat.homosk = sqrt(sigma.sq * sum(X.counts[realized.idx] * gamma.xx[realized.idx]^2))
148 |     max.mse = max.bias^2 + sigma.hat.homosk^2
149 |     homosk.plusminus = get.plusminus(max.bias, sigma.hat.homosk, alpha)
150 |     
151 |     return(list(max.mse=max.mse,
152 |                max.bias=max.bias,
153 |                homosk.plusminus=homosk.plusminus,
154 |                gamma.xx=gamma.xx,
155 |                realized.idx=realized.idx))
156 |   })
157 |   
158 |   # pick out the best soln
159 |   if(minimization.target == "mse") {
160 |     max.mse = unlist(sapply(soln.vec, function(vv) vv$max.mse))
161 |     opt.idx = which.min(max.mse)
162 |   } else {
163 |     plusmin = unlist(sapply(soln.vec, function(vv) vv$homosk.plusminus))
164 |     opt.idx = which.min(plusmin)
165 |   }
166 |   
167 |   gamma.xx = soln.vec[[opt.idx]]$gamma.xx
168 |   realized.idx = soln.vec[[opt.idx]]$realized.idx
169 |   
170 |   # Now map this x-wise function into a weight for each observation
171 |   gamma = rep(0, length(X))
172 |   gamma[inrange] = num.samples[inrange] * as.numeric(Matrix::t(bucket.map) %*% gamma.xx)
173 |   
174 |   # Compute the worst-case imbalance...
175 |   max.bias = max.second.derivative * sum(abs(t(M2) %*% (X.counts * gamma.xx)))
176 |   
177 |   # If outcomes are provided, also compute confidence intervals for tau.
178 |   if (!is.null(Y)) {
179 |     
180 |     # The point estimate
181 |     tau.hat = sum(gamma * Y)
182 |     
183 |     if (use.homoskedatic.variance) {
184 |       se.hat.tau = sqrt(sum(gamma^2 * sigma.sq / num.samples))
185 |     } else {
186 |       # A heteroskedaticity-robust variance estimate
187 |       regr.df = data.frame(X=X, W=X>=threshold, Y=Y)
188 |       Y.fit = lm(Y ~ X * W, data = regr.df[inrange,], weights=num.samples[inrange])
189 |       Y.resid.sq = rep(0, length(Y))
190 |       Y.resid.sq[inrange] = (Y[inrange] - predict(Y.fit))^2 *
191 |         sum(num.samples[inrange]) / (sum(num.samples[inrange]) - 4)
192 |       se.hat.tau = sqrt(sum(Y.resid.sq * gamma^2))
193 |     }
194 |     
195 |     # Confidence intervals that account for both bias and variance
196 |     tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
197 |   } else {
198 |     tau.hat = NULL
199 |     se.hat.tau = sqrt(sigma.sq * sum(gamma^2))
200 |     tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
201 |   }
202 |   
203 |   ret = list(tau.hat=tau.hat,
204 |              tau.plusminus=tau.plusminus,
205 |              alpha=alpha,
206 |              max.bias = max.bias,
207 |              sampling.se=se.hat.tau,
208 |              bandwidth=bw.vec[opt.idx],
209 |              gamma=gamma,
210 |              gamma.fun = data.frame(xx=xx[realized.idx] + threshold,
211 |                                     gamma=gamma.xx[realized.idx]))
212 |   class(ret) = "llr"
213 |   return(ret)
214 | }
215 | 
216 | print.llr = function(obj) {
217 |     optrdd:::print.optrdd(obj)
218 | }
219 | 
220 | plot.llr = function(obj) {
221 |     plot(obj$gamma.fun)
222 |     abline(h = 0, lty = 3)
223 | }
224 | 
225 | summary.llr = function(obj) {
226 |     unlist(obj)[1:5]
227 | }


--------------------------------------------------------------------------------
/baselines/old.optrdd.R:
--------------------------------------------------------------------------------
  1 | #' Optimized regression discontinuity design
  2 | #'
  3 | #' Optimized estimation and inference of treamtment effects identified
  4 | #' via regression discontinuities
  5 | #'
  6 | #' @param X The running variables.
  7 | #' @param max.second.derivative A bound on the second derivative of mu_w(x) = E[Y(w) | X = x].
  8 | #' @param Y The outcomes.
  9 | #' @param num.samples Number of samples used to compute each datapoint (perhaps we only have
 10 | #'                    access to summary data, where each datapoint is averaged over many samples).
 11 | #' @param threshold The threshold determining treatment assignment.
 12 | #' @param sigma.sq The irreducible noise level. If null, estimated from the data.
 13 | #' @param change.derivative Whether we allow for a change in slope at the threshold.
 14 | #' @param alpha Coverage probability of confidence intervals.
 15 | #' @param lambda.mult Optional multplier that can be used to over- or under-penalize variance.
 16 | #' @param max.window Observations further than max.window from the threshold are ignored.
 17 | #' @param num.bucket Number of buckets used in numerical optimization.
 18 | #' @param use.homoskedatic.variance Whether confidence intervals should be built assuming homoskedasticity.
 19 | #'
 20 | #' @return A trained optrdd object.
 21 | #' @export
 22 | optrdd.primal = function(X,
 23 |                          max.second.derivative,
 24 |                          Y = NULL,
 25 |                          num.samples = rep(1, length(X)),
 26 |                          threshold = 0,
 27 |                          sigma.sq = NULL,
 28 |                          change.derivative = TRUE,
 29 |                          alpha = 0.95,
 30 |                          lambda.mult = 1,
 31 |                          max.window = max(abs(X - threshold)),
 32 |                          num.bucket = 200,
 33 |                          use.homoskedatic.variance = FALSE) {
 34 |   
 35 |   # We compute our estimator based on a histogram summary of the data,
 36 |   # shifted such that the threshold is at 0. The breaks vector defines
 37 |   # the boundaries between buckets.
 38 |   xx = seq(-max.window, max.window, length.out = num.bucket)
 39 |   bin.width = xx[2] - xx[1]
 40 |   breaks = c(xx - bin.width/2, max(xx) + bin.width/2)
 41 |   
 42 |   # Construct a (weighted) histogram representing the X-values.
 43 |   inrange = which(abs(X - threshold) / max.window <= 1)
 44 |   bucket = cut(X[inrange] - threshold, breaks = breaks)
 45 |   bucket.map = Matrix::sparse.model.matrix(~bucket + 0, transpose = TRUE)
 46 |   X.counts = as.numeric(bucket.map %*% num.samples[inrange])
 47 |   
 48 |   # Naive initialization for sigma.sq if needed
 49 |   if (is.null(sigma.sq)) {
 50 |     if (is.null(Y)) {
 51 |       warning("Setting noise level to 1 as default...")
 52 |       sigma.sq = 1
 53 |     } else {
 54 |       regr.df = data.frame(X=X, W=X>=threshold, Y=Y)
 55 |       Y.fit = lm(Y ~ X * W, data = regr.df[inrange,], weights=num.samples[inrange])
 56 |       sigma.sq = sum((Y[inrange] - predict(Y.fit))^2 * num.samples[inrange]^2) /
 57 |         (sum(num.samples[inrange]) - 4)
 58 |     }
 59 |   }
 60 |   
 61 |   realized.idx = which(X.counts > 0)
 62 |   num.realized = length(realized.idx)
 63 |   
 64 |   # The matrix M is used to intergrate a function over xx,
 65 |   # starting at 0. The matrix M2 integrates twice.
 66 |   M = outer(xx, xx, FUN=Vectorize(function(x1, x2) {
 67 |     if(x1 < 0 & x2 <= 0 & x1 < x2) {return(-bin.width)}
 68 |     if(x1 > 0 & x2 >= 0 & x1 > x2) {return(bin.width)}
 69 |     return(0)
 70 |   }))
 71 |   M2 = M %*% M
 72 |   
 73 |   # Given homoskedatisc errors with variance sigma.sq, and a bound
 74 |   # max.derivative on the second derivate, this choice of lambda minimizes
 75 |   # the worst-case MSE of the estimator for tau.
 76 |   # 
 77 |   # The factor lambda.mult can be used to tune the parameter choice (e.g.,
 78 |   # to make the CIs as short as possible).
 79 |   lambda = lambda.mult * max.second.derivative^2 / sigma.sq
 80 |   
 81 |   # This optimizer learns bucket-wise gammas. Let k denote
 82 |   # the bucket index, n[k] the number of observations in
 83 |   # bucket k, and x[k] is the center of bucket k.
 84 |   # W also have positive dummy variables such that
 85 |   # nu_+ + nu_- = abs(t(M2) %*% (n * gamma)); note that
 86 |   # the maximum error due to curvature is
 87 |   # ||t(M2) %*% (n * gamma)||_1.
 88 |   #
 89 |   # We solve the following. Note that gamma[k] must be 0
 90 |   # if n[k] is 0, so we only optimize gamma over realized indices.
 91 |   #
 92 |   # argmin sum_k gamma[k]^2 * n[k] + lambda z^2
 93 |   # subject to:
 94 |   #  sum_k n[k] gamma[k] = 0
 95 |   #  sum_k n[k] gamma[k] (2 W[k] - 1) = 2
 96 |   #  sum_k n[k] gamma[k] x[k] = 0
 97 |   #  sum_k nu_+[k] + nu_-[k] = z
 98 |   #  - t(M2) %*% (n * gamma) + nu_+ >= 0 (elem. wise)
 99 |   #  t(M2) %*% (n * gamma)[k] + nu_- >= 0 (elem. wise)
100 |   #  nu_+, nu_- >= 0
101 |   
102 |   penalty.mat = diag(X.counts)[realized.idx,] %*% M2
103 |   Dmat = diag(c(X.counts[realized.idx], rep(0.00000000001 * lambda, 2*num.bucket), lambda))
104 |   dvec = rep(0, num.realized + 2* num.bucket + 1)
105 |   Amat = cbind(c(X.counts[realized.idx], rep(0, 2*num.bucket + 1)),
106 |                c(X.counts[realized.idx] * sign(xx[realized.idx]), rep(0, 2*num.bucket + 1)),
107 |                c(X.counts[realized.idx] * xx[realized.idx], rep(0, 2*num.bucket + 1)),
108 |                c(rep(0, num.realized), rep(1, 2*num.bucket), -1),
109 |                rbind(-penalty.mat, diag(1, num.bucket), diag(0, num.bucket), 0),
110 |                rbind(penalty.mat, diag(0, num.bucket), diag(1, num.bucket), 0),
111 |                rbind(matrix(0, num.realized, num.bucket), diag(1, num.bucket), diag(0, num.bucket), 0),
112 |                rbind(matrix(0, num.realized, num.bucket), diag(0, num.bucket), diag(1, num.bucket), 0))
113 |   bvec = c(0, 2, 0, 0, rep(0, 4 * num.bucket))
114 |   meq = 4
115 |   
116 |   # If we want to identify the CATE at the thresold, we also need to
117 |   # add the constraint: sum_{k : x[k] >= 0} n[k] gamma[k] x[k] = 0
118 |   if(change.derivative) {
119 |     Amat = cbind(c(X.counts[realized.idx] * pmax(xx[realized.idx], 0), rep(0, 2*num.bucket + 1)), Amat)
120 |     bvec = c(0, bvec)
121 |     meq = meq + 1
122 |   }
123 |   
124 |   # Solve the QP...
125 |   soln = quadprog::solve.QP(Dmat, dvec, Amat, bvec, meq)$solution
126 |   
127 |   # Extract the weighting function gamma(x), as a function of x
128 |   gamma.xx = rep(0, num.bucket)
129 |   gamma.xx[realized.idx] = soln[1:num.realized]
130 |   
131 |   # Now map this x-wise function into a weight for each observation
132 |   gamma = rep(0, length(X))
133 |   gamma[inrange] = num.samples[inrange] * as.numeric(Matrix::t(bucket.map) %*% gamma.xx)
134 |   
135 |   # Compute the worst-case imbalance...
136 |   max.bias = max.second.derivative * sum(abs(t(M2) %*% (X.counts * gamma.xx)))
137 |   
138 |   # If outcomes are provided, also compute confidence intervals for tau.
139 |   if (!is.null(Y)) {
140 |     
141 |     # The point estimate
142 |     tau.hat = sum(gamma * Y)
143 |     
144 |     if (use.homoskedatic.variance) {
145 |       se.hat.tau = sqrt(sum(gamma^2 * sigma.sq / num.samples))
146 |     } else {
147 |       # A heteroskedaticity-robust variance estimate
148 |       regr.df = data.frame(X=X, W=X>=threshold, Y=Y)
149 |       Y.fit = lm(Y ~ X * W, data = regr.df[inrange,], weights=num.samples[inrange])
150 |       Y.resid.sq = rep(0, length(Y))
151 |       Y.resid.sq[inrange] = (Y[inrange] - predict(Y.fit))^2 *
152 |         sum(num.samples[inrange]) / (sum(num.samples[inrange]) - 4)
153 |       se.hat.tau = sqrt(sum(Y.resid.sq * gamma^2))
154 |     }
155 |     
156 |     # Confidence intervals that account for both bias and variance
157 |     tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
158 |   } else {
159 |     tau.hat = NULL
160 |     se.hat.tau = sqrt(sigma.sq * sum(gamma^2))
161 |     tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
162 |   }
163 |   
164 |   ret = list(tau.hat=tau.hat,
165 |              tau.plusminus=tau.plusminus,
166 |              alpha=alpha,
167 |              max.bias = max.bias,
168 |              sampling.se=se.hat.tau,
169 |              gamma=gamma,
170 |              gamma.fun = data.frame(xx=xx[realized.idx] + threshold,
171 |                                     gamma=gamma.xx[realized.idx]))
172 |   class(ret) = "llr"
173 |   return(ret)
174 | }
175 | 
176 | 


--------------------------------------------------------------------------------
/example.R:
--------------------------------------------------------------------------------
 1 | rm(list = ls())
 2 | library(optrdd)
 3 | 
 4 | # Simple regression discontinuity with discrete X
 5 | n = 4000; threshold = 0
 6 | X = sample(seq(-4, 4, by = 8/41.5), n, replace = TRUE)
 7 | W = as.numeric(X >= threshold)
 8 | Y = 0.4 * W + 1 / (1 + exp(2 * X)) + 0.2 * rnorm(n)
 9 | # using 0.4 for max.second.derivative would have been enough
10 | out.1 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = threshold)
11 | print(out.1); plot(out.1, xlim = c(-1.5, 1.5))
12 | 
13 | # Now, treatment is instead allocated in a neighborhood of 0
14 | thresh.low = -1; thresh.high = 1
15 | W = as.numeric(thresh.low <= X & X <= thresh.high)
16 | Y = 0.2 * (1 + X) * W + 1 / (1 + exp(2 * X)) + rnorm(n)
17 | # This estimates CATE at specifically chosen points
18 | out.2 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.low)
19 | print(out.2); plot(out.2, xlim = c(-2.5, 2.5))
20 | out.3 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.high)
21 | print(out.3); plot(out.3, xlim = c(-2.5, 2.5))
22 | # This estimates a weighted CATE, with lower variance
23 | out.4 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5)
24 | print(out.4); plot(out.4, xlim = c(-2.5, 2.5))
25 | 
26 | # RDD with multivariate running variable. Warning: slow without mosek.
27 | X = matrix(runif(n*2, -1, 1), n, 2)
28 | W = as.numeric(X[,1] < 0 | X[,2] < 0)
29 | Y = X[,1]^2/3 + W * (1 + X[,2]) + rnorm(n)
30 | out.5 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1)
31 | print(out.5); plot(out.5)
32 | out.6 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1, estimation.point = c(0, 0.5))
33 | print(out.6); plot(out.6)
34 | 


--------------------------------------------------------------------------------
/experiments_from_paper/README.md:
--------------------------------------------------------------------------------
1 | The experiments in the paper were run with version 1.0 of the package, with optimizer set to "auto" and MOSEK installed. Results with different optimizers may vary slightly.
2 | 
3 | To replicate Figures 1 and 2, run intro/figures_1_and_2.R.
4 | 
5 | To replicate Figures 3 and 7, and Table 4, run geographic_rdd/analysis.R.
6 | 
7 | To replicate Figure 4 and Table 1, run compulsory_schooling/analysis.R.
8 | 
9 | To replicate Figures 5 and 6, and Table 3, run summer_school/analysis.R.


--------------------------------------------------------------------------------
/experiments_from_paper/compulsory_schooling/analysis.R:
--------------------------------------------------------------------------------
  1 | set.seed(1234)
  2 | 
  3 | rm(list = ls())
  4 | 
  5 | #library(foreign)
  6 | detach("package:optrdd", unload=TRUE)
  7 | library(optrdd)
  8 | source("~/git/optrdd/baselines/local.lin.reg.R")
  9 | 
 10 | # print more
 11 | print.optrdd = function (obj) 
 12 | {
 13 |   if (!is.null(obj$tau.hat)) {
 14 |     print(paste0(100 * obj$alpha, "% CI for tau: $", round(obj$tau.hat, 4),
 15 |                  " \\pm ", round(obj$tau.plusminus, 4), "$"))
 16 |   }
 17 |   else {
 18 |     print(paste0(100 * obj$alpha, "% CI for tau: [point estimate] +/- ", 
 19 |                  round(obj$tau.plusminus, 3)))
 20 |   }
 21 | }
 22 | print.llr = function(obj) {
 23 |     print.optrdd(obj)
 24 | }
 25 | 
 26 | 
 27 | setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
 28 | 
 29 | # filtering as in kolesar & rothe
 30 | # cghs = foreign::read.dta("combined general household survey.dta")
 31 | # cghs$yearat14 <- cghs$yobirth+14
 32 | # d <- within(cghs, {
 33 | #   k1 <- yearat14 >= 35 & yearat14 <= 65 & age <= 64 &
 34 | #     agelfted >= 10 & !is.na(agelfted);
 35 | #   k2 <- k1 & !is.na(earn) & nireland==0;
 36 | #   k3 <- k2 & abs(yearat14-47) <= 6
 37 | #   k4 <- k2 & abs(yearat14-47) <= 3
 38 | #   learn <- log(earn)
 39 | # })
 40 | # d$x <- d$yearat14
 41 | # 
 42 | # ## save subset of GB data
 43 | # data <- d[d$k2, c("learn", "x", "agelfted", "sex", "datyear")]
 44 | # write.csv(data, "uk_analysis_sample.csv")
 45 | data <- read.csv("uk_analysis_sample.csv")
 46 | 
 47 | threshold <- 46.99
 48 | max.window <- 12.1
 49 | datsub <- data[which(data$x - threshold <= max.window),]
 50 | W = as.numeric(datsub$x > threshold)
 51 | 
 52 | # repro K & R
 53 | rect.003 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.003,
 54 |     threshold = threshold, num.bucket = 400,
 55 |     minimization.target = "ci.length")
 56 | rect.006 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.006,
 57 |                threshold = threshold, num.bucket = 400,
 58 |                minimization.target = "ci.length")
 59 | rect.012 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.012,
 60 |                threshold = threshold, num.bucket = 400,
 61 |                minimization.target = "ci.length")
 62 | rect.03 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.03,
 63 |     threshold = threshold, num.bucket = 400,
 64 |     minimization.target = "ci.length")
 65 | 
 66 | # now with triangular kernel
 67 | tri.003 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.003, kernel = "triangular",
 68 |            threshold = threshold, num.bucket = 400,
 69 |            minimization.target = "ci.length")
 70 | tri.006 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.006, kernel = "triangular",
 71 |               threshold = threshold, num.bucket = 400,
 72 |               minimization.target = "ci.length")
 73 | tri.012 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.012, kernel = "triangular",
 74 |               threshold = threshold, num.bucket = 400,
 75 |               minimization.target = "ci.length")
 76 | tri.03 = llr(datsub$x, Y=datsub$learn, max.second.derivative = 0.03, kernel = "triangular",
 77 |               threshold = threshold, num.bucket = 400,
 78 |              minimization.target = "ci.length")
 79 | 
 80 | opt.003 = optrdd(datsub$x, Y=datsub$learn, W=W, max.second.derivative = 0.003,
 81 |                  estimation.point = threshold, num.bucket = 400)
 82 | opt.006 = optrdd(datsub$x, Y=datsub$learn, max.second.derivative = 0.006,
 83 |                  estimation.point = threshold, W=W, num.bucket = 400)
 84 | opt.012 = optrdd(datsub$x, Y=datsub$learn, max.second.derivative = 0.012,
 85 |                  estimation.point = threshold, W=W, num.bucket = 400)
 86 | opt.03 = optrdd(datsub$x, Y=datsub$learn, max.second.derivative = 0.03,
 87 |                 estimation.point = threshold, W=W, num.bucket = 400)
 88 | 
 89 | rect.003
 90 | rect.03
 91 | tri.003
 92 | tri.03
 93 | opt.003
 94 | opt.03
 95 | 
 96 | cat(paste(substr(print(rect.003), 17, 35),
 97 |   substr(print(tri.003), 17, 35),
 98 |   substr(print(opt.003), 17, 35), sep = " & "))
 99 | 
100 | cat(paste(substr(print(rect.006), 17, 35),
101 |           substr(print(tri.006), 17, 35),
102 |           substr(print(opt.006), 17, 35), sep = " & "))
103 | 
104 | cat(paste(substr(print(rect.012), 17, 35),
105 |           substr(print(tri.012), 17, 35),
106 |           substr(print(opt.012), 17, 35), sep = " & "))
107 | 
108 | cat(paste(substr(print(rect.03), 17, 35),
109 |           substr(print(tri.03), 17, 35),
110 |           substr(print(opt.03), 17, 35), sep = " & "))
111 | 
112 | #
113 | # This is used to pick the curvature bound B. Note that this regression
114 | # should not be interpreted as an estimate of the RDD parameter.
115 | #
116 | 
117 | W = datsub$x >= threshold
118 | X = (datsub$x - threshold)
119 | X2 = (X - threshold)^2
120 | Y = datsub$learn
121 | RDF = data.frame(W=W, X=X, X2=X2, Y=Y)
122 | 
123 | summary(lm(Y ~ W * (X + X2), data = RDF))
124 | 
125 | 
126 | COLS = RColorBrewer::brewer.pal(9, "Set1")
127 | pdf("oreopoulos_weights.pdf")
128 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
129 | plot(NA, NA, xlim=(47 + 6 * c(-1, 1)), pch = 4, cex=2, xlab = "Year turned 14", ylab = "gamma", ylim = range(c(opt.012$gamma.fun.0[,2], opt.012$gamma.fun.1[,2], tri.012$gamma.fun[,2], rect.012$gamma.fun[,2])))
130 | points(opt.012$gamma.fun.0[,1], opt.012$gamma.fun.0[,2], pch = 4, lwd=3, col = COLS[2], cex=2)
131 | points(opt.012$gamma.fun.1[,1], opt.012$gamma.fun.1[,2], pch = 4, lwd=3, col = COLS[2], cex=2)
132 | lines(rect.012$gamma.fun[rect.012$gamma.fun[,1] < threshold,1], rect.012$gamma.fun[rect.012$gamma.fun[,1] < threshold,2], lwd = 3, col = COLS[5])
133 | lines(rect.012$gamma.fun[rect.012$gamma.fun[,1] >= threshold,1], rect.012$gamma.fun[rect.012$gamma.fun[,1] >= threshold,2], lwd = 3, col = COLS[5])
134 | points(tri.012$gamma.fun, pch = 3, cex=2, col = COLS[4], lwd = 3)
135 | abline(h = 0, lty = 3, lwd = 2)
136 | legend("bottomright", c("Optimized", "Tri Kenrel", "Rect Kernel"), lwd = 3, col = COLS[c(2, 4, 5)], pch = c(4, 3, NA), lty = c(NA, NA, 1), cex = 2)
137 | par=pardef
138 | dev.off()
139 | 
140 | 
141 | source("armstrong_kolesar_gamma.R")
142 | ak.003 = ak.tau(datsub$x, Y=datsub$learn, max.second.derivative = 0.003,
143 |                 threshold = threshold, num.bucket = 400)
144 | ak.006 = ak.tau(datsub$x, Y=datsub$learn, max.second.derivative = 0.006,
145 |                 threshold = threshold, num.bucket = 400)
146 | ak.012 = ak.tau(datsub$x, Y=datsub$learn, max.second.derivative = 0.012,
147 |                 threshold = threshold, num.bucket = 400)
148 | ak.03 = ak.tau(datsub$x, Y=datsub$learn, max.second.derivative = 0.03,
149 |                 threshold = threshold, num.bucket = 400)
150 | 
151 | 
152 | ak = sapply(list(ak.003, ak.006, ak.012, ak.03), print)
153 | 
154 | 
155 | 
156 | 
157 | 


--------------------------------------------------------------------------------
/experiments_from_paper/compulsory_schooling/armstrong_kolesar_gamma.R:
--------------------------------------------------------------------------------
  1 | ak.tau = function(X, max.second.derivative, Y = NULL, weights = rep(1, length(X)), threshold = 0, sigma.sq = NULL, change.derivative = TRUE, alpha = 0.95, max.window = max(abs(X - threshold)), num.bucket = 200) {
  2 |   
  3 |   # Naive initialization for sigma.sq if needed
  4 |   if (is.null(sigma.sq)) {
  5 |     if (is.null(Y)) {
  6 |       warning("Setting noise level to 1 as default...")
  7 |       sigma.sq = 1
  8 |     } else {
  9 |       Y.bar = sum(Y * weights) / sum(weights)
 10 |       sigma.sq = sum((Y - Y.bar)^2 * weights^2) / sum(weights)
 11 |     }
 12 |   }
 13 |   
 14 |   # We compute our estimator based on a histogram summary of the data,
 15 |   # shifted such that the threshold is at 0. The breaks vector defines
 16 |   # the boundaries between buckets.
 17 |   xx = seq(-max.window, max.window, length.out = num.bucket)
 18 |   bin.width = xx[2] - xx[1]
 19 |   breaks = c(xx - bin.width/2, max(xx) + bin.width/2)
 20 |   
 21 |   # Construct a (weighted) histogram representing the X-values.
 22 |   inrange = which(abs(X - threshold) / max.window <= 1)
 23 |   bucket = cut(X[inrange] - threshold, breaks = breaks)
 24 |   bucket.map = Matrix::sparse.model.matrix(~bucket + 0, transpose = TRUE)
 25 |   X.counts = as.numeric(bucket.map %*% weights[inrange])
 26 |   
 27 |   
 28 |   # only consider counts that occurs inside the bandwidth
 29 |   realized.idx = which(X.counts > 0)
 30 |   num.realized = length(realized.idx)
 31 |   
 32 |   # This optimizer learns bucket-wise gammas. Let k denote
 33 |   # the bucket index, n[k] the number of observations in
 34 |   # bucket k, and x[k] is the center of bucket k.
 35 |   #
 36 |   # We solve the following. Note that gamma[k] must be 0
 37 |   # if n[k] is 0, so we only optimize gamma over realized indices.
 38 |   #
 39 |   # argmin sum_k (gamma_+[k] - gamma_-[k])^2 * n[k] + B^2 I^2
 40 |   # subject to:
 41 |   #  sum_k n[k] (gamma_+[k] - gamma_-[k]) = 0
 42 |   #  sum_k n[k] (gamma_+[k] - gamma_-[k]) (2 W[k] - 1) = 2
 43 |   #  sum_k n[k] (gamma_+[k] - gamma_-[k]) x[k] = 0
 44 |   #  sum_k n[k] (gamma_+[k] - gamma_-[k]) (x[k])_+ = 0
 45 |   #  sum_k n[k] (gamma_+[k] + gamma_-[k]) x[k]^2 / 2 = I
 46 |   #  gamma_+, gamma_- >= 0
 47 |   
 48 |   Dmat =diag(c(sigma.sq * X.counts[realized.idx],
 49 |                sigma.sq * X.counts[realized.idx],
 50 |                max.second.derivative^2))
 51 |   dvec = rep(0, 2 * num.realized + 1)
 52 |   
 53 |   if(!change.derivative) {
 54 |     stop("Only implemented with derivate change at threshold.")
 55 |   }
 56 |   
 57 |   Amat = cbind(c(X.counts[realized.idx], -X.counts[realized.idx], 0),
 58 |                c(X.counts[realized.idx] * sign(xx[realized.idx]),
 59 |                  -X.counts[realized.idx] * sign(xx[realized.idx]), 0),
 60 |                c(X.counts[realized.idx] * xx[realized.idx],
 61 |                  -X.counts[realized.idx] * xx[realized.idx], 0),
 62 |                c(X.counts[realized.idx] *  pmax(xx[realized.idx], 0),
 63 |                  -X.counts[realized.idx] *  pmax(xx[realized.idx], 0), 0),
 64 |                c(X.counts[realized.idx] * xx[realized.idx]^2/2,
 65 |                  X.counts[realized.idx] * xx[realized.idx]^2/2, -1),
 66 |                diag(rep(1, 2 * num.realized + 1)))
 67 |   
 68 |   bvec = c(0, 2, 0, 0, 0, rep(rep(0, 2 * num.realized + 1)))
 69 |   meq = 5
 70 |   
 71 |   soln = quadprog::solve.QP(Dmat, dvec, Amat, bvec, meq)$solution
 72 |   
 73 |   gamma.xx = rep(0, num.bucket)
 74 |   gamma.xx[realized.idx] = soln[1:num.realized] - soln[num.realized + (1:num.realized)]
 75 |   
 76 |   # Now map this x-wise function into a weight for each observation
 77 |   gamma = rep(0, length(X))
 78 |   gamma[inrange] = weights[inrange] * as.numeric(Matrix::t(bucket.map) %*% gamma.xx)
 79 |   
 80 |   max.bias = max.second.derivative * soln[1 + 2 * num.realized]
 81 |   
 82 |   # If outcomes are provided, also compute confidence intervals for tau.
 83 |   if (!is.null(Y)) {
 84 |     
 85 |     # The point estimate
 86 |     tau.hat = sum(gamma * Y)
 87 |     
 88 |     # A heteroskedaticity-robust variance estimate
 89 |     regr.df = data.frame(X=X, W=X>=threshold, Y=Y)
 90 |     Y.fit = lm(Y ~ X * W, data = regr.df[inrange,], weights=weights[inrange])
 91 |     Y.resid.sq = rep(0, length(Y))
 92 |     Y.resid.sq[inrange] = (Y[inrange] - predict(Y.fit))^2 * sum(weights[inrange]) / (sum(weights[inrange]) - 4)
 93 |     se.hat.tau = sqrt(sum(Y.resid.sq * gamma^2))
 94 |     
 95 |     # Confidence intervals that account for both bias and variance
 96 |     tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
 97 |   } else {
 98 |     tau.hat = NULL
 99 |     se.hat.tau = sqrt(sigma.sq * sum(gamma^2))
100 |     tau.plusminus = get.plusminus(max.bias, se.hat.tau, alpha)
101 |   }
102 |   
103 |   ret = list(tau.hat=tau.hat,
104 |              tau.plusminus=tau.plusminus,
105 |              alpha=alpha,
106 |              max.bias = max.bias,
107 |              sampling.se=se.hat.tau,
108 |              gamma=gamma,
109 |              gamma.fun = data.frame(xx=xx[realized.idx] + threshold,
110 |                                     gamma=gamma.xx[realized.idx]))
111 |   class(ret) = "optrdd"
112 |   return(ret)
113 | }


--------------------------------------------------------------------------------
/experiments_from_paper/geographic_rdd/KeeleTitiunik2014-PA-replication-files/Data/BorderSegmentPoints_Project.dbf:
--------------------------------------------------------------------------------
1 | qY!
xWIdNRefFIDN	StepIDN	XFYFTurnAngleFPOINT_XFPOINT_YF
      0        0        1 5.31424224283e+005 4.46594703989e+006-9.99000000000e+002-7.46300003648e+001 4.03434807730e+001      0        0        2 5.31423708294e+005 4.46584705870e+006 1.42167958770e+000-7.46300113608e+001 4.03425800548e+001      0        0        3 5.31420711392e+005 4.46574710461e+006 2.70914989929e-002-7.46300515648e+001 4.03416796742e+001      0        0        4 5.31417667199e+005 4.46564715096e+006 2.30050534052e+001-7.46300923244e+001 4.03407792992e+001      0        0        5 5.31453247269e+005 4.46555570700e+006 5.31630078270e+000-7.46296779225e+001 4.03399541329e+001      0        0        6 5.31497987030e+005 4.46546627368e+006 7.80814860811e+000-7.46291555915e+001 4.03391467334e+001      0        0        7 5.31554242615e+005 4.46538406843e+006 4.80111756949e+000-7.46284973379e+001 4.03384040141e+001      0        0        8 5.31603264916e+005 4.46529771716e+006 2.92175249426e+001-7.46279244617e+001 4.03376242133e+001      0        0        9 5.31683413757e+005 4.46524918007e+006 1.05401131992e+001-7.46269832723e+001 4.03371838988e+001      0        0       10 5.31755845753e+005 4.46518455777e+006 6.85338180990e+000-7.46261337447e+001 4.03365989578e+001      0        0       11 5.31821580162e+005 4.46511001758e+006 3.56889307365e+000-7.46253635751e+001 4.03359249148e+001      0        0       12 5.31882246780e+005 4.46503191664e+006 1.29454693628e+001-7.46246532599e+001 4.03352189814e+001      0        0       13 5.31959130892e+005 4.46496917691e+006 2.14093767211e+001-7.46237512702e+001 4.03346508128e+001      0        0       14 5.32002678907e+005 4.46489181320e+006 2.51215351150e+001-7.46232424754e+001 4.03339521680e+001      0        0       15 5.32010093842e+005 4.46479211833e+006 2.89260653788e+000-7.46231601795e+001 4.03330537247e+001      0        0       16 5.32012458674e+005 4.46469258235e+006 2.14384464743e+001-7.46231373281e+001 4.03321569065e+001      0        0       17 5.31978451738e+005 4.46459954052e+006 7.59480950179e+000-7.46235423188e+001 4.03313199891e+001      0        0       18 5.31932113744e+005 4.46451117568e+006 2.68699167875e+001-7.46240922245e+001 4.03305256774e+001      0        0       19 5.31930739862e+005 4.46441307074e+006 4.18201858027e+000-7.46241133007e+001 4.03296418943e+001      0        0       20 5.31935232066e+005 4.46433700285e+006 6.14444809386e+001-7.46240642221e+001 4.03289564203e+001      0        0       21 5.32014102597e+005 4.46429992982e+006 2.38337332694e+001-7.46231376513e+001 4.03286194043e+001      0        0       22 5.32073871684e+005 4.46423115017e+006 4.04668674703e+001-7.46224375326e+001 4.03279974675e+001      0        0       23 5.32074785061e+005 4.46413119924e+006 1.45564737116e+001-7.46224317982e+001 4.03270969659e+001      0        0       24 5.32050813166e+005 4.46403528791e+006 1.22045766061e+001-7.46227187874e+001 4.03262338132e+001      0        0       25 5.32047693149e+005 4.46393754665e+006 3.31446269481e+001-7.46227604152e+001 4.03253533733e+001      0        0       26 5.32099389392e+005 4.46385257572e+006 3.10207023795e+001-7.46221561707e+001 4.03245858759e+001      0        0       27 5.32181712368e+005 4.46380942299e+006 4.43739446900e+001-7.46211893375e+001 4.03241939389e+001      0        0       28 5.32275886364e+005 4.46383769615e+006 1.04549138648e+001-7.46200794140e+001 4.03244450180e+001      0        0       29 5.32361955718e+005 4.46388186498e+006 2.36266442935e+001-7.46190640756e+001 4.03248396061e+001      0        0       30 5.32461764996e+005 4.46388803815e+006 7.28672111735e-002-7.46178889242e+001 4.03248913447e+001      0        0       31 5.32561565809e+005 4.46389433821e+006 4.16165507239e-001-7.46167138643e+001 4.03249442150e+001      0        0       32 5.32661318719e+005 4.46390136304e+006 3.22945126723e+001-7.46155393295e+001 4.03250036046e+001      0        0       33 5.32748823608e+005 4.46385431295e+006 3.88973871290e+000-7.46145117335e+001 4.03245762976e+001      0        0       34 5.32833395755e+005 4.46380114568e+006 1.07987355364e+000-7.46135189853e+001 4.03240939867e+001      0        0       35 5.32914952222e+005 4.46374770365e+006 1.76020301846e+001-7.46125617618e+001 4.03236093109e+001      0        0       36 5.33011252522e+005 4.46372075479e+006 4.04326059850e-002-7.46114296410e+001 4.03233627233e+001      0        0       37 5.33107533139e+005 4.46369373816e+006 1.48719282710e+001-7.46102977637e+001 4.03231155150e+001      0        0       38 5.33191393809e+005 4.46364424931e+006 5.89373099292e+000-7.46093132505e+001 4.03226663354e+001      0        0       39 5.33271261522e+005 4.46358527978e+006 7.50601573404e+000-7.46083762424e+001 4.03221318945e+001      0        0       40 5.33341399809e+005 4.46351767576e+006 3.15854712983e+001-7.46075542173e+001 4.03215200460e+001      0        0       41 5.33426735404e+005 4.46349897521e+006 3.25243473820e+001-7.46065507753e+001 4.03213481583e+001      0        0       42 5.33520604372e+005 4.46353344506e+006 3.14634824782e+001-7.46054441107e+001 4.03216549358e+001      0        0       43 5.33616246411e+005 4.46351433456e+006 1.40273857384e+001-7.46043193846e+001 4.03214789216e+001      0        0       44 5.33700713356e+005 4.46347435850e+006 6.58655163193e+001-7.46033272975e+001 4.03211153684e+001      0        0       45 5.33698986172e+005 4.46339138628e+006 3.35410745079e+001-7.46033520012e+001 4.03203679351e+001      0        0       46 5.33745309571e+005 4.46331824721e+006 4.80001893694e+001-7.46028106346e+001 4.03197071482e+001      0        0       47 5.33722448958e+005 4.46323665366e+006 1.21836235025e+001-7.46030840066e+001 4.03189729893e+001      0        0       48 5.33717981803e+005 4.46316294097e+006 6.25086622079e+001-7.46031404721e+001 4.03183090863e+001      0        0       49 5.33799965492e+005 4.46311375934e+006 2.45214096532e+001-7.46021781514e+001 4.03178626898e+001      0        0       50 5.33855153031e+005 4.46303351871e+006 5.00373214627e+000-7.46015328659e+001 4.03171375594e+001      0        0       51 5.33903303659e+005 4.46294846649e+006 6.30579853241e+000-7.46009706692e+001 4.03163693632e+001      0        0       52 5.33942571916e+005 4.46285688965e+006 3.74818410304e+001-7.46005133699e+001 4.03155427445e+001      0        0       53 5.34028583672e+005 4.46280860542e+006 7.81419412575e+000-7.45995036513e+001 4.03151042469e+001      0        0       54 5.34118893900e+005 4.46277304174e+006 1.76772145822e+001-7.45984426782e+001 4.03147801652e+001      0        0       55 5.34217010929e+005 4.46276649550e+006 9.32057957229e+000-7.45972882841e+001 4.03147171745e+001      0        0       56 5.34310852130e+005 4.46277553723e+006 2.33022596461e+001-7.45961833782e+001 4.03147947812e+001      0        0       57 5.34391352973e+005 4.46281980356e+006 1.52946824182e+001-7.45952335786e+001 4.03151902679e+001      0        0       58 5.34485259222e+005 4.46284236772e+006 2.89965637982e+001-7.45941271679e+001 4.03153896769e+001      0        0       59 5.34576343861e+005 4.46281713263e+006 3.62721883873e+000-7.45930565437e+001 4.03151585650e+001      0        0       60 5.34674190563e+005 4.46279658759e+006 1.21307329482e+001-7.45919060894e+001 4.03149694155e+001      0        0       61 5.34762354262e+005 4.46275735493e+006 5.06573955485e+000-7.45908706173e+001 4.03146122997e+001      0        0       62 5.34842460496e+005 4.46271285129e+006 3.22890394329e+000-7.45899302713e+001 4.03142080242e+001      0        0       63 5.34928929243e+005 4.46267100263e+006 5.49859459786e+000-7.45889149120e+001 4.03138273939e+001      0        0       64 5.35020981714e+005 4.46263690169e+006 1.04249550140e+000-7.45878334260e+001 4.03135163203e+001      0        0       65 5.35115370627e+005 4.46260387544e+006 1.52226566242e+001-7.45867243939e+001 4.03132148204e+001      0        0       66 5.35202832299e+005 4.46259766434e+006 7.73046770038e+001-7.45856954202e+001 4.03131551814e+001      0        0       67 5.35216200166e+005 4.46250961928e+006 4.41798510652e+001-7.45855429461e+001 4.03123614137e+001      0        0       68 5.35295613930e+005 4.46244936962e+006 7.81285959593e+001-7.45846116819e+001 4.03118152674e+001      0        0       69 5.35260049791e+005 4.46237418566e+006 4.74927733157e+001-7.45850343647e+001 4.03111394322e+001      0        0       70 5.35295749468e+005 4.46228660711e+006 8.57396956210e-001-7.45846190703e+001 4.03103489227e+001      0        0       71 5.35331472177e+005 4.46219507706e+006 1.46075983255e+001-7.45842037328e+001 4.03095228113e+001      0        0       72 5.35343084605e+005 4.46209640808e+006 3.33997992670e-001-7.45840725291e+001 4.03086334038e+001      0        0       73 5.35354136081e+005 4.46199754407e+006 1.56449772108e+001-7.45839479406e+001 4.03077422629e+001      0        0       74 5.35387941310e+005 4.46191397100e+006 3.01942449835e+001-7.45835547511e+001 4.03069879150e+001      0        0       75 5.35439681214e+005 4.46187386277e+006 2.29505010778e+001-7.45829481149e+001 4.03066243830e+001      0        0       76 5.35466021029e+005 4.46182686241e+006 2.95943215693e+001-7.45826407642e+001 4.03061998352e+001      0        0       77 5.35533097726e+005 4.46178633743e+006 6.40937143928e+000-7.45818536877e+001 4.03058318915e+001      0        0       78 5.35601702081e+005 4.46175474047e+006 3.74120832367e+001-7.45810481464e+001 4.03055443106e+001      0        0       79 5.35645592399e+005 4.46167170118e+006 4.57335403760e+001-7.45805362978e+001 4.03047943315e+001      0        0       80 5.35623548822e+005 4.46160335060e+006 8.84185855785e+001-7.45807994973e+001 4.03041794963e+001      0        0       81 5.35717366823e+005 4.46157020838e+006 4.35385357504e+000-7.45796973740e+001 4.03038769090e+001      0        0       82 5.35813850787e+005 4.46154417056e+006 4.10825082592e+001-7.45785634923e+001 4.03036382010e+001      0        0       83 5.35870220315e+005 4.46157163952e+006 3.21702302615e+000-7.45778986469e+001 4.03038832521e+001      0        0       84 5.35940645577e+005 4.46160119011e+006 3.81702395980e+001-7.45770682834e+001 4.03041464482e+001      0        0       85 5.36037051747e+005 4.46157462236e+006 4.27937044242e+001-7.45759353520e+001 4.03039029437e+001      0        0       86 5.36075830939e+005 4.46151207568e+006 1.52609391939e+001-7.45754825594e+001 4.03033377822e+001      0        0       87 5.36101090892e+005 4.46142700749e+006 2.54512618695e+001-7.45751901251e+001 4.03025703053e+001      0        0       88 5.36167964497e+005 4.46135270919e+006 1.05266809724e+001-7.45744074306e+001 4.03018980537e+001      0        0       89 5.36219062054e+005 4.46126920365e+006-9.99000000000e+002-7.45738109042e+001 4.03011435322e+001


--------------------------------------------------------------------------------
/experiments_from_paper/geographic_rdd/KeeleTitiunik2014-PA-replication-files/Data/Voters/Voters_Final.dta:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/swager/optrdd/8d85c92972aa1e90943d7c571de9ba379e5c0584/experiments_from_paper/geographic_rdd/KeeleTitiunik2014-PA-replication-files/Data/Voters/Voters_Final.dta


--------------------------------------------------------------------------------
/experiments_from_paper/geographic_rdd/KeeleTitiunik2014-PA-replication-files/README.txt:
--------------------------------------------------------------------------------
  1 | 
  2 | ######################
  3 | ######################
  4 | 
  5 | OPTRDD NOTE:
  6 | 
  7 | We here distribute only the part of the replication files of Keele and Titiunik
  8 | required to run our experiments. For all other files, contact the original authors.
  9 | 
 10 | ######################
 11 | ######################
 12 | 
 13 | ------------------------------------------------------------------------------
 14 | June 6, 2014
 15 | 
 16 | This folder contains the replication files for the paper "Geographic Boundaries as Regression Discontinuities" to appear in Political Analysis
 17 | 
 18 | -------------------------------------------------------------------------------
 19 | 
 20 | Authors contact information			
 21 | 
 22 | 
 23 | Luke Keele				Rocio Titiunik
 24 | Associate Professor			Assistant Professor
 25 | Political Science			Political Science
 26 | Penn State University			University of Michigan
 27 | ljk20@psu.edu				titiunik@umich.edu
 28 | 
 29 | --------------------------------------------------------------------------------
 30 | 
 31 | File list
 32 | 
 33 | README.txt							This file
 34 | 
 35 | ./Analysis:							Directory containing all codes to perform estimation ==> NOTE: these analysis require function distance-functions.R described below
 36 | Balance								Directory containing all codes to perform balance tests
 37 | Local Poly							Directory containing all codes to perform local polynomial estimation 
 38 | Matching							Directory containing all codes to perform matching analysis
 39 | 
 40 | ./Analysis/Balance:
 41 | Housing								Analysis for house-level outcomes
 42 | Voters								Analysis for voter-level outcomes
 43 | 
 44 | ./Analysis/Balance/Housing:
 45 | 01-balance-pre-matching.R					Performs balance before matching
 46 | 03-balance-buffers.R						Performs balance in buffers
 47 | 04-balance-chordmatch.R						Performs balance after matching on chordal distance
 48 | 05-balance-chordmatch-buffers.R					Performs balance after matching on chordal distance within buffers
 49 | House-Summary.txt						Summary of results
 50 | Results								Directory were all results are stored
 51 | 
 52 | ./Analysis/Balance/Housing/Results:
 53 | balance_postmatch_buffers.RData
 54 | house_balance_buffers.RData
 55 | house_balance_postmatch_fulldata.RData
 56 | prematch_balance_house.RData
 57 | 
 58 | ./Analysis/Balance/Voters:
 59 | 01-balance-pre-matching.R					Performs balance before matching
 60 | 02-balance-buffers.R						Performs balance in buffers	
 61 | 03-balance-chordmatch.R						Performs balance after matching on chordal distance
 62 | 04-balance-chordmatch-buffers.R					Performs balance after matching on chordal distance within buffers
 63 | Balance - Tests - Summary.txt					Summary of results
 64 | Results	  	  						Directory were all results are stored
 65 | 
 66 | ./Analysis/Balance/Voters/Results:
 67 | balance_postmatch_buffers.RData
 68 | balance_postmatch_fulldata.RData
 69 | prematch_balance_fulldata.RData
 70 | voters_balance_buffers.RData
 71 | 
 72 | ./Analysis/Local Poly:
 73 | 01-localpoly-estimation-housing-outcomes.R			Local polynomial estimation for housing outcomes
 74 | 01-localpoly-estimation-non-housing-outcomes.R			Local polynomial estimation for non-housing outcomes
 75 | distance-functions.R						Functions to calculate different geographic distances
 76 | 
 77 | ./Analysis/Matching:
 78 | Housing
 79 | Voters
 80 | 
 81 | ./Analysis/Matching/Housing:
 82 | 01-chordmatch.R							Performs matching on chordal distance
 83 | 02-chordmatch-buffers.R						Performs matching on chordal distance within buffers 
 84 | chordmatch_bufferdata.RData					Results from matching on chordal distance within buffers 
 85 | chordmatch_fulldata.RData					Results from matching on chordal distance
 86 | 
 87 | ./Analysis/Matching/Voters:
 88 | 01-chordmatch.R							Performs matching on chordal distance
 89 | 03-chordmatch-buffers.R						Performs matching on chordal distance within buffers 							 
 90 | Results								Directory were matching results are stored
 91 | 
 92 | ./Analysis/Matching/Voters/Results:
 93 | chordmatch_bufferdata.RData
 94 | chordmatch_fulldata.RData
 95 | 
 96 | ./Data:								Datasets used for analysis 
 97 | BorderSegmentPoints_Project.dbf					Points along the border for Philadelphia vs New York media market application
 98 | Housing								Directory containing housing data
 99 | Voters								Directory containing voter data
100 | 
101 | ./Data/Housing:
102 | House_Buffer_Final.dta						Housing data for buffers around the boundary for Philadelphia vs New York media market application
103 | NJ_House_Final.dta						Complete housing data around the boundary for Philadelphia vs New York media market application
104 | 
105 | ./Data/Voters:
106 | Voters_Buffer_Final.dta						Voter data for buffers around the boundary for Philadelphia vs New York media market application
107 | Voters_Final.dta						Complete voter data for Philadelphia vs New York media market application
108 | 


--------------------------------------------------------------------------------
/experiments_from_paper/geographic_rdd/analysis.R:
--------------------------------------------------------------------------------
  1 | rm(list=ls())
  2 | 
  3 | set.seed(1234)
  4 | 
  5 | library(optrdd)
  6 | library(foreign)
  7 | library(RColorBrewer)
  8 | library(xtable)
  9 | library(glmnet)
 10 | library(splines)
 11 | 
 12 | setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
 13 | 
 14 | pointsALL <- read.dbf("KeeleTitiunik2014-PA-replication-files/Data/BorderSegmentPoints_Project.dbf")
 15 | pointsALL$latitude= pointsALL$POINT_Y
 16 | pointsALL$longitude= pointsALL$POINT_X
 17 | 
 18 | data.voting <- read.dta("KeeleTitiunik2014-PA-replication-files/Data/Voters/Voters_Final.dta",convert.dates = FALSE, convert.factors = FALSE, convert.underscore = FALSE)
 19 | data.voting.nona = data.voting[!is.na(data.voting$treat),]
 20 | 
 21 | plot(data.voting.nona$longitude,
 22 |      data.voting.nona$latitude,
 23 |      col=data.voting.nona$treat + 1,  pch = ".", cex = 3)
 24 | lines(pointsALL$longitude, pointsALL$latitude, lwd = 4)
 25 | 
 26 | WV = data.voting.nona$treat
 27 | XV = (pi * 6371 /180) * cbind(
 28 |     A=data.voting.nona$longitude - mean(data.voting.nona$longitude),
 29 |     B=data.voting.nona$latitude - mean(data.voting.nona$latitude))
 30 | 
 31 | hc = ((grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "RdBu")))(101))[101:1]
 32 | purple = ((grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "Purples")))(101))
 33 | 
 34 | compute_curvature = function(xgrid.pred, nA, nB, centers, binw) {
 35 |     curvs0 = sapply(centers, function(idx) {
 36 |         c((xgrid.pred[idx + 1] + xgrid.pred[idx - 1] - 2 * xgrid.pred[idx]) / binw^2,
 37 |           (xgrid.pred[idx + nA] + xgrid.pred[idx - nA] - 2 * xgrid.pred[idx]) / binw^2,
 38 |           (xgrid.pred[idx + nA + 1] + xgrid.pred[idx - nA - 1] - 2 * xgrid.pred[idx]) / binw^2 / 2,
 39 |           (xgrid.pred[idx + nA - 1] + xgrid.pred[idx - nA + 1] - 2 * xgrid.pred[idx]) / binw^2 / 2)
 40 |     })
 41 |     curvs = apply(curvs0, 2, function(iii) max(abs(iii)))
 42 |     quantile(curvs, 0.95, na.rm=TRUE)
 43 | }
 44 | 
 45 | get_curvature = function(xx, outcome, ww, make_plot = TRUE, binw = 0.1) {
 46 |     
 47 |     xx = data.frame(xx)
 48 |     yy = data.voting.nona[,outcome]
 49 |     
 50 |     names(xx) = c("A", "B")
 51 |     
 52 |     gridA = seq(min(xx$A) - 1.5 * binw, max(xx$A) + 1.5 * binw, by = binw)
 53 |     gridB = seq(min(xx$B) - 1.5 * binw, max(xx$B) + 1.5 * binw, by = binw)
 54 |     xgrid = data.frame(expand.grid(A=gridA, B = gridB))
 55 |     xspl.all = model.matrix(~ 0 + ns(A, df = 7) * ns(B, df = 7),
 56 |                             data = rbind(xx, xgrid))
 57 |     xspl = xspl.all[1:nrow(xx),]
 58 |     
 59 |     fit0 = cv.glmnet(xspl[ww==0,], yy[ww==0], alpha = 0)
 60 |     fit1 = cv.glmnet(xspl[ww==1,], yy[ww==1], alpha = 0)
 61 |     
 62 |     if (make_plot) {
 63 |         pred = rep(NA, nrow(xx))
 64 |         pred[ww==0] = predict(fit0, xspl[ww==0,], s="lambda.1se")
 65 |         pred[ww==1] = predict(fit1, xspl[ww==1,], s="lambda.1se")
 66 |         print(paste(outcome, range(pred)))
 67 |         cidx = 1 + round(100 * (pred - min(pred))/(max(abs(pred)) - min(pred)))
 68 |         pdf(paste0("output/raw_pred_", outcome, ".pdf"))
 69 |         pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
 70 |         plot(NA, NA, xlim = range(data.voting.nona$longitude), ylim = range(data.voting.nona$latitude),
 71 |              xlab = "longitude", ylab = "latitude")
 72 |         points(data.voting.nona$longitude, data.voting.nona$latitude, col = purple[cidx], pch = 16)
 73 |         lines(pointsALL$longitude, pointsALL$latitude, lwd = 2, lty = 1)
 74 |         par = pardef
 75 |         dev.off()
 76 |     }
 77 | 
 78 |     xgrid.spl = xspl.all[nrow(xx) + 1:nrow(xgrid),]
 79 |     xgrid.pred.0 = predict(fit0, xgrid.spl, s="lambda.1se")
 80 |     xgrid.pred.1 = predict(fit1, xgrid.spl, s="lambda.1se")
 81 |     
 82 |     nA = length(gridA)
 83 |     nB = length(gridB)
 84 |     
 85 |     bucketA = as.numeric(cut(xx[,1], gridA))
 86 |     bucketB = as.numeric(cut(xx[,2], gridB))
 87 |     bucket = bucketA + nA * bucketB
 88 |     
 89 |     c.hat.0 = compute_curvature(xgrid.pred.0, nA, nB, centers = bucket[ww == 0], binw = binw)
 90 |     c.hat.1 = compute_curvature(xgrid.pred.1, nA, nB, centers = bucket[ww == 1], binw = binw)
 91 |     max(c.hat.0, c.hat.1)
 92 | }
 93 | 
 94 | #
 95 | # Run analysis
 96 | #
 97 | 
 98 | #outcomes = c("e2008p", "age", "black", "hisp", "dem", "female")
 99 | outcomes = c("e2008p", "age", "black", "dem", "female")
100 | 
101 | BOUNDARY_PT = 37
102 | estimation.point = (pi * 6371 /180) *
103 |     c(pointsALL$longitude[BOUNDARY_PT] - mean(data.voting.nona$longitude),
104 |       pointsALL$latitude[BOUNDARY_PT] - mean(data.voting.nona$latitude))
105 | 
106 | res.all =  lapply(outcomes, function(outcome) {
107 |     YV = data.voting.nona[,outcome]
108 |     max.curv = get_curvature(XV, outcome, WV)
109 |     print(max.curv)
110 |     out = optrdd(X=XV, Y=YV, W=WV, max.second.derivative = max.curv)
111 |     out.pt = optrdd(X=XV, Y=YV, W=WV, max.second.derivative = max.curv, estimation.point = estimation.point)
112 |     return(list(out, out.pt))
113 | })
114 | 
115 | #
116 | # Make results table
117 | #
118 | 
119 | res.avg = lapply(res.all, function(x) x[[1]])
120 | res.pt = lapply(res.all, function(x) x[[2]])
121 | 
122 | parsed = cbind(c("WATE", rep("", 4)), outcomes,
123 |                t(sapply(res.avg, function(out) {
124 |                    c(sprintf("%.3f", round(out$tau.hat, 3)),
125 |                      paste0("(", sprintf("%.3f", round(out$tau.hat - out$tau.plusminus, 3)),
126 |                             ", ", sprintf("%.3f", round(out$tau.hat + out$tau.plusminus, 3))
127 |                             , ")"),
128 |                      sprintf("%.3f", round(out$max.bias, 3)), 
129 |                      sprintf("%.3f", round(out$sampling.se, 3)))
130 |                })))
131 | 
132 | parsed.pt = cbind(c("CATE", rep("", 4)), outcomes,
133 |                       t(sapply(res.pt, function(out) {
134 |                           c(sprintf("%.3f", round(out$tau.hat, 3)),
135 |                             paste0("(", sprintf("%.3f", round(out$tau.hat - out$tau.plusminus, 3)),
136 |                                    ", ", sprintf("%.3f", round(out$tau.hat + out$tau.plusminus, 3))
137 |                                    , ")"),
138 |                             sprintf("%.3f", round(out$max.bias, 3)), 
139 |                             sprintf("%.3f", round(out$sampling.se, 3)))
140 |                       })))
141 | 
142 | tab.all = rbind(parsed, parsed.pt)
143 | colnames(tab.all) = c("", "outcome", "point estimate", "conf interval", "max bias", "sampling std err")
144 | xtab = xtable(tab.all, align=c("r", "|", "r", "r", "|", "c", "c", "c", "c", "|"))
145 | print(xtab, include.rownames = FALSE,
146 |       hline.after = c(-1, 0, 5, 10),
147 |       file="output/geo_out.tex")
148 | 
149 | 
150 | #
151 | # Make gamma plots
152 | #
153 | 
154 | main.res = res.all[[1]]
155 | 
156 | out = main.res[[1]]
157 | gamma.all = c(out$gamma.fun.0[, 3], out$gamma.fun.1[, 3])
158 | cidx = 51 + round(50 * gamma.all/max(abs(gamma.all)))
159 | 
160 | lon.all = c(out$gamma.fun.0[,1], out$gamma.fun.1[,1]) /
161 |     (pi * 6371 /180) + mean(data.voting.nona$longitude)
162 | lat.all = c(out$gamma.fun.0[,2], out$gamma.fun.1[,2]) /
163 |     (pi * 6371 /180) + mean(data.voting.nona$latitude)
164 | 
165 | control = 1:nrow(out$gamma.fun.0)
166 | treat = nrow(out$gamma.fun.0) + 1:nrow(out$gamma.fun.1)
167 | 
168 | pdf("output/geo_WATE.pdf")
169 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
170 | plot(NA, NA, xlim = range(lon.all), ylim = range(lat.all),
171 |      xlab = "longitude", ylab = "latitude")
172 | points(lon.all[control], lat.all[control], col = hc[cidx[control]], pch = 10, lwd = 1.5)
173 | points(lon.all[treat], lat.all[treat], col = hc[cidx[treat]], pch = 16, lwd = 1.5)
174 | lines(pointsALL$longitude, pointsALL$latitude, lwd = 2, lty = 1)
175 | par = pardef
176 | dev.off()
177 | 
178 | 
179 | out.pt = main.res[[2]]
180 | 
181 | gamma.all.pt = c(out.pt$gamma.fun.0[, 3], out.pt$gamma.fun.1[, 3])
182 | cidx.pt = 51 + round(50 * gamma.all.pt/max(abs(gamma.all.pt)))
183 | 
184 | lon.all.pt = c(out.pt$gamma.fun.0[,1], out.pt$gamma.fun.1[,1]) /
185 |     (pi * 6371 /180) + mean(data.voting.nona$longitude)
186 | lat.all.pt = c(out.pt$gamma.fun.0[,2], out.pt$gamma.fun.1[,2]) /
187 |     (pi * 6371 /180) + mean(data.voting.nona$latitude)
188 | 
189 | control.pt = 1:nrow(out.pt$gamma.fun.0)
190 | treat.pt = nrow(out.pt$gamma.fun.0) + 1:nrow(out.pt$gamma.fun.1)
191 | 
192 | pdf("output/geo_CATE.pdf")
193 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
194 | plot(NA, NA, xlim = range(lon.all.pt), ylim = range(lat.all.pt),
195 |      xlab = "longitude", ylab = "latitude")
196 | points(lon.all.pt[control.pt], lat.all.pt[control.pt],
197 |        col = hc[cidx.pt[control.pt]], pch = 10, lwd = 1.5)
198 | points(lon.all.pt[treat.pt], lat.all.pt[treat.pt],
199 |        col = hc[cidx.pt[treat.pt]], pch = 16, lwd = 1.5)
200 | lines(pointsALL$longitude, pointsALL$latitude, lwd = 2, lty = 1)
201 | points(pointsALL$longitude[BOUNDARY_PT], pointsALL$latitude[BOUNDARY_PT],
202 |        lwd = 4, cex = 1.5, pch = 4)
203 | par = pardef
204 | dev.off()
205 | 


--------------------------------------------------------------------------------
/experiments_from_paper/intro/figures_1_and_2.R:
--------------------------------------------------------------------------------
 1 | rm(list = ls())
 2 | 
 3 | set.seed(2)
 4 | 
 5 | detach("package:optrdd", unload=TRUE)
 6 | library(optrdd)
 7 | source("~/git/optrdd/baselines/local.lin.reg.R")
 8 | setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
 9 | 
10 | COLS = RColorBrewer::brewer.pal(9, "Set1")
11 | 
12 | max.second.derivative = 5
13 | K = 40
14 | supp = rnorm(K)
15 | prob = rexp(K)
16 | prob = prob/sum(prob)
17 | 
18 | nn.all = round(1000 * exp(((-3):12 / 3) * log(3)))
19 | nn.plot = 1000 * 3^(0:3)
20 | 
21 | maxerr.list = lapply(nn.all, function(n) {
22 | #maxerr.list = lapply(nn.plot, function(n) {
23 |   
24 |   bucket = as.numeric(1:K %*% rmultinom(n, 1, prob))
25 |   X = supp[bucket]
26 | 
27 |   X.short=X[abs(X) <= 1]  
28 |   W.short=as.numeric(X.short > 0)
29 |   rdd = optrdd(X=X.short, W=W.short, max.second.derivative=max.second.derivative, estimation.point = 0, sigma.sq=1, num.bucket = 600)
30 |   rectangle = llr(X.short, max.second.derivative, sigma.sq=1, kernel="rectangular", num.bucket = 600)
31 |   triangle = llr(X.short, max.second.derivative, sigma.sq=1, kernel="triangular", num.bucket = 600)
32 |   
33 |   maxerr = data.frame(bias=c(rdd$max.bias, rectangle$max.bias, triangle$max.bias),
34 |                       se=c(rdd$sampling.se, rectangle$sampling.se, triangle$sampling.se))
35 |   rownames(maxerr) = c("rdd", "rectangle", "triangle")
36 |   
37 |   if (n %in% nn.plot) {
38 |     
39 |     X.g = rnorm(n)
40 |     X.g = X.g[abs(X.g) <= 1]
41 |     W.g = as.numeric(X.g > 0)
42 |     rdd.g = optrdd(X=X.g, W=W.g, max.second.derivative=max.second.derivative, sigma.sq=1, estimation.point = 0, bin.width = 2/600)
43 |     
44 |     pdf(paste0("plots/first_", n, ".pdf"))
45 |     plot(NA, NA, ylim = c(-5.5, 5.5), xlim = c(-0.7, 0.7), xlab = "", ylab = "", yaxt='n', cex.axis=1.5)
46 |     points(rdd$gamma.fun.0[,1], rdd$gamma.fun.0[,2] * n^(4/5), pch = 16, cex=2, col=COLS[1])
47 |     points(rdd$gamma.fun.1[,1], rdd$gamma.fun.1[,2] * n^(4/5), pch = 16, cex=2, col=COLS[1])
48 |     lines(rdd.g$gamma.fun.0[,1], rdd.g$gamma.fun.0[,2] * n^(4/5), lwd = 3, col=COLS[2])
49 |     lines(rdd.g$gamma.fun.1[,1], rdd.g$gamma.fun.1[,2] * n^(4/5), lwd=3, col=COLS[2])
50 |     abline(h=0, lty = 2, lwd = 3)
51 |     abline(v=0, lty = 2, lwd = 1)
52 |     dev.off()
53 |   }
54 |   
55 |   return(maxerr)
56 |   
57 | })
58 | 
59 | out = Reduce(cbind, lapply(maxerr.list, function(mm) rowSums(mm^2)))
60 | 
61 | pdf("plots/mse_plot.pdf")
62 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
63 | plot(nn.all, out[2,]/out[1,], log="x", ylim=range(c(1, range(out[2,]/out[1,]), range(out[3,]/out[1,]))),
64 |      xlab="n", ylab = "Relative Excess Error", pch = 24, col = COLS[5], bg = COLS[5], cex = 1.5, xaxt="n")
65 | points(nn.all, out[3,]/out[1,], col = COLS[4], pch = 25, cex = 1.5, bg=COLS[4])
66 | abline(h=1, lty = 2, lwd = 2, col = 1)
67 | abline(h=1.05, lty = 4, lwd = 1)
68 | abline(h=1.1, lty = 4, lwd = 1)
69 | abline(h=1.15, lty = 4, lwd = 1)
70 | abline(h=1.2, lty = 4, lwd = 1)
71 | legend("topleft", c("Rectangular Kernel", "Triangular Kernel"), pch = c(24, 25), col = COLS[5:4], pt.bg = COLS[5:4], cex = 1.5, bg="white")
72 | axis(1, at=c(500, 5000, 50000), labels=c(500, 5000, 50000))
73 | par=pardef
74 | dev.off()
75 | 
76 | pdf("plots/intro_pmf.pdf")
77 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
78 | plot(NA, NA, xlim = c(-0.7, 0.7), ylim = c(0, 0.1), xlab = "X", ylab = "Probability Mass")
79 | for(iter in 1:K) {
80 |   if(abs(supp[iter]) < 0.75) {
81 |     segments(supp[iter], 0, supp[iter], prob[iter], lwd = 4, col = COLS[7])
82 |   }
83 | }
84 | abline(h=0, lwd = 4)
85 | abline(v=0, lty = 2)
86 | par=pardef
87 | dev.off()
88 | 
89 | 
90 | 
91 | 


--------------------------------------------------------------------------------
/experiments_from_paper/summer_school/analysis.R:
--------------------------------------------------------------------------------
  1 | rm(list = ls())
  2 | 
  3 | set.seed(1234)
  4 | setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
  5 | 
  6 | #detach("package:optrdd", unload=TRUE)
  7 | library(optrdd)
  8 | 
  9 | library(RColorBrewer)
 10 | 
 11 | data.all = read.csv("ssextract_karthik.csv")[,-1]
 12 | hist(data.all$mdcut01)
 13 | hist(data.all$rdcut01)
 14 | 
 15 | THRESH = 40
 16 | 
 17 | data = data.all[pmax(abs(data.all$mdcut01), abs(data.all$rdcut01)) <= THRESH,]
 18 | data$itt = data$mdcut01 > 0 & data$rdcut01 > 0
 19 | 
 20 | table(data$mdcut01 > 0, data$rdcut01 > 0)
 21 | round(mean(data$ssatyn01), 3)
 22 | round(mean(data$ssatyn01[data$mdcut01 < 0 & data$rdcut01 < 0]), 3)
 23 | round(mean(data$ssatyn01[data$mdcut01 > 0 & data$rdcut01 < 0]), 3)
 24 | round(mean(data$ssatyn01[data$mdcut01 < 0 & data$rdcut01 > 0]), 3)
 25 | round(mean(data$ssatyn01[data$mdcut01 > 0 & data$rdcut01 > 0]), 3)
 26 | 
 27 | data.sm = data.all[pmax(abs(data.all$mdcut01), abs(data.all$rdcut01)) < 20,]
 28 | 
 29 | data.sm$pass = data.sm$mdcut01 > 0 & data.sm$rdcut01 > 0
 30 | summary(lm(zmscr02 ~ mdcut01 + rdcut01 + pass, data = data.sm))
 31 | 
 32 | X = as.numeric(data$mdcut01)
 33 | Y = as.numeric(data$zmscr02)
 34 | 
 35 | uu = unique(X)
 36 | yy = sapply(uu, function(uuu) mean(Y[X == uuu]))
 37 | plot(uu, yy)
 38 | 
 39 | X1 = as.numeric(data$mdcut01) / THRESH
 40 | X2 = as.numeric(data$rdcut01) / THRESH
 41 | X = cbind(X1, X2)
 42 | Y.math = as.numeric(data$zmscr02)
 43 | Y.reading = as.numeric(data$zrscr02)
 44 | W = as.numeric(X[,1] <= 0 | X[,2] <= 0)
 45 | 
 46 | threshold = c(0, 0)
 47 | max.window = c(1, 1)
 48 | num.bucket = c(40, 40)
 49 | 
 50 | # Guess at max second derivative
 51 | DF = data.frame(Y=Y.reading, X1=X1, X1.2=(X1 - mean(X1))^2, X2=X2, X2.2=(X2 - mean(X2))^2, X12=(X1 - mean(X1))*(X2 - mean(X2)), W=as.numeric(X1 < 0 | X2 < 0))
 52 | lmb = coef(lm(Y ~ W * ., data = DF))
 53 | M0.curv = matrix(c(2*lmb[4], lmb[7], lmb[7], 2*lmb[6]), 2, 2)
 54 | M1.curv = M0.curv + matrix(c(2*lmb[9], lmb[12], lmb[12], 2*lmb[11]), 2, 2)
 55 | svd(M0.curv)$d
 56 | svd(M1.curv)$d
 57 | 
 58 | # Biggest curvature effects:
 59 | # 
 60 | # For math, among treated (i.e., summer school) sample, curvature of -0.2 in the
 61 | # (8, 5) direction (i.e., summer school maybe doesn't help good students,
 62 | # esp. students good at math?)
 63 | # 
 64 | # For reading, among controls (no summer school) sample, curvature of +0.46
 65 | # in the (1, 2) direction (i.e., good readers improve on their own?).
 66 | 
 67 | subjects = c("math", "reading")
 68 | max.derivs = c(0.5, 1)
 69 | cate.at.pts = c(TRUE, FALSE)
 70 | #centers = c(TRUE, FALSE)
 71 | 
 72 | curr.idx = 1
 73 | summaries = list()
 74 | 
 75 | for (subject in subjects) {
 76 |   for (max.second.derivative in max.derivs) {
 77 |     #for (center in centers) {
 78 |       for (cate.at.pt in cate.at.pts) {
 79 |         
 80 |         center = cate.at.pt
 81 |         if (!center & cate.at.pt) next;
 82 |         
 83 |         if (subject == "math") {
 84 |           Y = Y.math
 85 |         } else {
 86 |           Y = Y.reading
 87 |         }
 88 |         
 89 |         if (cate.at.pt) {
 90 |             estimation.point = threshold
 91 |         } else {
 92 |             estimation.point = NULL
 93 |         }
 94 |         gamma = optrdd(X = X, Y = Y, W = W,
 95 |                         max.second.derivative = max.second.derivative,
 96 |                         estimation.point = estimation.point)
 97 |         print(gamma)
 98 |         
 99 |         
100 |         
101 |         pdf(paste0("output/gamma_", subject, "_B_", 10 * max.second.derivative,
102 |                    "_cate_", cate.at.pt, "_center_", center, ".pdf"))
103 |         #plot(gamma, xlab="math score", ylab="reading score")
104 |         x=gamma
105 |         gamma.all = c(x$gamma.fun.0[, 3], x$gamma.fun.1[, 3])
106 |         cidx = 51 + round(50 * gamma.all/max(abs(gamma.all)))
107 |         hc = (grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "RdBu")))(101)[101:1]
108 |         x1rng = range(x$gamma.fun.0[, 1], x$gamma.fun.1[, 1])
109 |         x2rng = range(x$gamma.fun.0[, 2], x$gamma.fun.1[, 2])
110 |         
111 |         pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
112 |         plot(NA, NA, xlim = x1rng, ylim = x2rng,
113 |              xlab="math score", ylab="reading score")
114 |         points(x$gamma.fun.0[, 1], x$gamma.fun.0[, 2],
115 |                col = hc[cidx[1:length(x$gamma.fun.0[, 3])]], pch = 10, lwd = 1.5)
116 |         points(x$gamma.fun.1[, 1], x$gamma.fun.1[, 2],
117 |                col = hc[cidx[length(x$gamma.fun.0[, 3]) + 1:length(x$gamma.fun.1[, 3])]], pch = 16, lwd = 1.5)
118 |         segments(0, 0, 0, 2, lwd = 2)
119 |         segments(0, 0, 2, 0, lwd = 2)
120 |         
121 |         if (cate.at.pt) {
122 |             points(estimation.point[1], estimation.point[2], lwd = 4, cex = 1.5, pch = 4)
123 |         } else {
124 |             middle = colSums(X[W == 1,] * gamma$gamma[W==1])
125 |             points(middle[1], middle[2], lwd = 4, cex = 1.25, pch = 5)
126 |         }
127 |         
128 |         par = pardef
129 |         dev.off()
130 |         
131 |         
132 |         
133 |         save(gamma, file=paste0("output/object_", subject, "_B_", max.second.derivative,
134 |                    "_cate_", cate.at.pt, "_center_", center, ".RData"))
135 |         
136 |         summaries[[curr.idx]] = c(subject=subject,
137 |                                   max.second.derivative=max.second.derivative,
138 |                                   cate.at.pt=cate.at.pt,
139 |                                   center=cate.at.pt,
140 |                                   summary(gamma))
141 |         curr.idx = curr.idx + 1
142 |       }
143 |     #}
144 |   }
145 | }
146 | 
147 | result_summaries = data.frame(Reduce(rbind, summaries))
148 | write.csv(result_summaries, file="output/result_summaries.csv")
149 | 
150 | #
151 | # Sensitivity analysis for math and reading.
152 | #
153 | 
154 | bvals = c(0.01, seq(0.25, 4, by = 0.25))
155 | COLS = RColorBrewer::brewer.pal(9, "Set1")
156 | 
157 | Y = Y.math
158 | ci.math = sapply(bvals, function(max.second.derivative) {
159 |   optrdd.out = optrdd(X = X, Y = Y, W = W,
160 |                       max.second.derivative = max.second.derivative)
161 |   c(PT=optrdd.out$tau.hat,
162 |     LOW=optrdd.out$tau.hat - optrdd.out$tau.plusminus,
163 |     HIGH=optrdd.out$tau.hat + optrdd.out$tau.plusminus,
164 |     ESS=2/sum(optrdd.out$gamma^2),
165 |     ESST=1/sum(optrdd.out$gamma[W==1]^2),
166 |     ESSC=1/sum(optrdd.out$gamma[W==0]^2))
167 | })
168 | 
169 | Y = Y.reading
170 | ci.reading = sapply(bvals, function(max.second.derivative) {
171 |   optrdd.out = optrdd(X = X, Y = Y, W = W,
172 |                       max.second.derivative = max.second.derivative)
173 |   c(PT=optrdd.out$tau.hat,
174 |     LOW=optrdd.out$tau.hat - optrdd.out$tau.plusminus,
175 |     HIGH=optrdd.out$tau.hat + optrdd.out$tau.plusminus,
176 |     ESS=2/sum(optrdd.out$gamma^2),
177 |     ESST=1/sum(optrdd.out$gamma[W==1]^2),
178 |     ESSC=1/sum(optrdd.out$gamma[W==0]^2))
179 | })
180 | 
181 | pdf("output/math_sensitivity.pdf")
182 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
183 | plot(bvals, ci.math[1,], type = "l", lwd = 3,
184 |      xlim = c(0, max(bvals)), ylim = range(ci.math[1:3,], ci.reading[1:3,]),
185 |      xlab = "max second derivative",
186 |      ylab = "tau", col = COLS[7])
187 | lines(bvals, ci.math[2,], lty = 2, lwd = 3, col = COLS[5])
188 | lines(bvals, ci.math[3,], lty = 2, lwd = 3, col = COLS[5])
189 | abline(h = 0, lty = 1)
190 | abline(v = 0.5, lty = 3)
191 | abline(v = 1, lty = 3)
192 | dev.off()
193 | 
194 | pdf("output/reading_sensitivity.pdf")
195 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
196 | plot(bvals, ci.reading[1,], type = "l", lwd = 3,
197 |      xlim = c(0, max(bvals)), ylim = range(ci.math[1:3,], ci.reading[1:3,]),
198 |      xlab = "max second derivative",
199 |      ylab = "tau", col = COLS[7])
200 | lines(bvals, ci.reading[2,], lty = 2, lwd = 3, col = COLS[5])
201 | lines(bvals, ci.reading[3,], lty = 2, lwd = 3, col = COLS[5])
202 | abline(h = 0, lty = 1)
203 | abline(v = 0.5, lty = 3)
204 | abline(v = 1, lty = 3)
205 | dev.off()
206 | 
207 | pdf("output/effective_ss.pdf")
208 | pardef = par(mar = c(5, 4, 4, 2) + 0.5, cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5)
209 | plot(bvals[-1], ci.math[5,-1], type = "l", lwd = 3,
210 |      ylim = range(ci.math[5:6,-1]),
211 |      xlab = "max second derivative",
212 |      ylab = "effective sample size", col = COLS[1], log = "xy")
213 | lines(bvals[-1], ci.math[6,-1], lty = 5, col = COLS[2], lwd = 3)
214 | legend("topright", c("Treated", "Controls"), col = COLS[1:2], lwd = 3, lty = c(1, 5), cex = 1.5)
215 | dev.off()
216 | 


--------------------------------------------------------------------------------
/experiments_from_paper/summer_school/make_final_tables.R:
--------------------------------------------------------------------------------
 1 | rm(list = ls())
 2 | library(optrdd)
 3 | library(RColorBrewer)
 4 | 
 5 | setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
 6 | 
 7 | data = read.csv("output/result_summaries.csv")
 8 | data = data[data$cate.at.pt == data$center,]
 9 | 
10 | idx = c(1, 3)
11 | 
12 | pretty = data.frame(stringsAsFactors = FALSE,
13 | 	CI=paste0("$", round(data$tau.hat, 3), ' \\pm ', round(data$tau.plusminus, 3), "$"),
14 | 	max.bias=as.character(round(data$max.bias, 3)),
15 | 	samp.se=as.character(round(data$sampling.se, 3)))
16 | 	
17 | for(offs in c(0, 2, 4, 6)) {
18 | 	cat(Reduce(function(a, b) paste(a, b, sep = " & "), unlist(c(pretty[offs+1,], pretty[offs+2,]))))
19 | 	print("")
20 | }
21 | 


--------------------------------------------------------------------------------
/man/get.plusminus.Rd:
--------------------------------------------------------------------------------
 1 | % Generated by roxygen2: do not edit by hand
 2 | % Please edit documentation in R/utils.R
 3 | \name{get.plusminus}
 4 | \alias{get.plusminus}
 5 | \title{Bias-adjusted Gaussian confidence intervals.}
 6 | \usage{
 7 | get.plusminus(max.bias, sampling.se, alpha = 0.95)
 8 | }
 9 | \arguments{
10 | \item{max.bias}{Worst-case bias of estimate.}
11 | 
12 | \item{sampling.se}{Sampling error of estimate.}
13 | 
14 | \item{alpha}{Coverage probability of confidence interval.}
15 | }
16 | \value{
17 | Half-width of confidence interval.
18 | }
19 | \description{
20 | Bias-adjusted Gaussian confidence intervals.
21 | }
22 | 


--------------------------------------------------------------------------------
/man/optrdd.Rd:
--------------------------------------------------------------------------------
  1 | % Generated by roxygen2: do not edit by hand
  2 | % Please edit documentation in R/optrdd.R
  3 | \name{optrdd}
  4 | \alias{optrdd}
  5 | \title{Optimized regression discontinuity design}
  6 | \usage{
  7 | optrdd(X, Y = NULL, W, max.second.derivative, estimation.point = NULL,
  8 |   sigma.sq = NULL, alpha = 0.95, lambda.mult = 1, bin.width = NULL,
  9 |   num.bucket = NULL, use.homoskedatic.variance = FALSE, use.spline = TRUE,
 10 |   spline.df = NULL, try.elnet.for.sigma.sq = FALSE, optimizer = c("auto",
 11 |   "mosek", "ECOS", "quadprog", "SCS"), verbose = TRUE)
 12 | }
 13 | \arguments{
 14 | \item{X}{The running variables.}
 15 | 
 16 | \item{Y}{The outcomes. If null, only optimal weights are computed.}
 17 | 
 18 | \item{W}{Treatment assignments, typically of the form 1(X >= c).}
 19 | 
 20 | \item{max.second.derivative}{A bound on the second derivative of mu_w(x) = E[Y(w) | X = x].}
 21 | 
 22 | \item{estimation.point}{Point "c" at which CATE is to be estimated. If estimation.point = NULL,
 23 | we estimate a weighted CATE, with weights chosen to minimize MSE,
 24 | as in Section 4.1 of Imbens and Wager (2017).}
 25 | 
 26 | \item{sigma.sq}{The irreducible noise level. If null, estimated from the data.}
 27 | 
 28 | \item{alpha}{Coverage probability of confidence intervals.}
 29 | 
 30 | \item{lambda.mult}{Optional multplier that can be used to over- or under-penalize variance.}
 31 | 
 32 | \item{bin.width}{Bin width for discrete approximation.}
 33 | 
 34 | \item{num.bucket}{Number of bins for discrete approximation. Can only be used if bin.width = NULL.}
 35 | 
 36 | \item{use.homoskedatic.variance}{Whether confidence intervals should be built assuming homoskedasticity.}
 37 | 
 38 | \item{use.spline}{Whether non-parametric components should be modeled as quadratic splines
 39 | in order to reduce the number of optimization parameters, and potentially
 40 | improving computational performance.}
 41 | 
 42 | \item{spline.df}{Number of degrees of freedom (per running variable) used for spline computation.}
 43 | 
 44 | \item{try.elnet.for.sigma.sq}{Whether an elastic net on a spline basis should be used for estimating sigma^2.}
 45 | 
 46 | \item{optimizer}{Which optimizer to use? Mosek is a commercial solver, but free
 47 | academic licenses are available. Needs to be installed separately.
 48 | ECOS is an open-source interior-point solver for conic problems,
 49 | made available via the CVXR wrapper.
 50 | Quadprog is the default R solver; it may be slow on large problems, but
 51 | is very accurate on small problems.
 52 | SCS is an open-source "operator splitting" solver that implements a first order
 53 | method for solving very large cone programs to modest accuracy. The speed of SCS may
 54 | be helpful for prototyping; however, the results may be noticeably less accurate.
 55 | SCS is also accessed via the CVXR wrapper.
 56 | The option "auto" uses a heuristic to choose.}
 57 | 
 58 | \item{verbose}{whether the optimizer should print progress information}
 59 | }
 60 | \value{
 61 | A trained optrdd object.
 62 | }
 63 | \description{
 64 | Optimized estimation and inference of treamtment effects identified
 65 | via regression discontinuities
 66 | }
 67 | \examples{
 68 | # Simple regression discontinuity with discrete X
 69 | n = 4000; threshold = 0
 70 | X = sample(seq(-4, 4, by = 8/41.5), n, replace = TRUE)
 71 | W = as.numeric(X >= threshold)
 72 | Y = 0.4 * W + 1 / (1 + exp(2 * X)) + 0.2 * rnorm(n)
 73 | # using 0.4 for max.second.derivative would have been enough
 74 | out.1 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = threshold)
 75 | print(out.1); plot(out.1, xlim = c(-1.5, 1.5))
 76 | 
 77 | # Now, treatment is instead allocated in a neighborhood of 0
 78 | thresh.low = -1; thresh.high = 1
 79 | W = as.numeric(thresh.low <= X & X <= thresh.high)
 80 | Y = 0.2 * (1 + X) * W + 1 / (1 + exp(2 * X)) + rnorm(n)
 81 | # This estimates CATE at specifically chosen points
 82 | out.2 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.low)
 83 | print(out.2); plot(out.2, xlim = c(-2.5, 2.5))
 84 | out.3 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5, estimation.point = thresh.high)
 85 | print(out.3); plot(out.3, xlim = c(-2.5, 2.5))
 86 | # This estimates a weighted CATE, with lower variance
 87 | out.4 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 0.5)
 88 | print(out.4); plot(out.4, xlim = c(-2.5, 2.5))
 89 | 
 90 | \dontrun{
 91 | # RDD with multivariate running variable.
 92 | X = matrix(runif(n*2, -1, 1), n, 2)
 93 | W = as.numeric(X[,1] < 0 | X[,2] < 0)
 94 | Y = X[,1]^2/3 + W * (1 + X[,2]) + rnorm(n)
 95 | out.5 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1)
 96 | print(out.5); plot(out.5)
 97 | out.6 = optrdd(X=X, Y=Y, W=W, max.second.derivative = 1, estimation.point = c(0, 0.5))
 98 | print(out.6); plot(out.6)}
 99 | 
100 | }
101 | \references{
102 | Domahidi, A., Chu, E., & Boyd, S. (2013, July).
103 | ECOS: An SOCP solver for embedded systems.
104 | In Control Conference (ECC), 2013 European (pp. 3071-3076). IEEE.
105 | 
106 | Imbens, G., & Wager, S. (2017).
107 | Optimized Regression Discontinuity Designs.
108 | arXiv preprint arXiv:1705.01677.
109 | 
110 | O’Donoghue, B., Chu, E., Parikh, N., & Boyd, S. (2016).
111 | Conic optimization via operator splitting and homogeneous self-dual embedding.
112 | Journal of Optimization Theory and Applications, 169(3), 1042-1068.
113 | }
114 | 


--------------------------------------------------------------------------------
/optrdd.Rproj:
--------------------------------------------------------------------------------
 1 | Version: 1.0
 2 | 
 3 | RestoreWorkspace: No
 4 | SaveWorkspace: No
 5 | AlwaysSaveHistory: Default
 6 | 
 7 | EnableCodeIndexing: Yes
 8 | Encoding: UTF-8
 9 | 
10 | AutoAppendNewline: Yes
11 | StripTrailingWhitespace: Yes
12 | 
13 | BuildType: Package
14 | PackageUseDevtools: Yes
15 | PackageInstallArgs: --no-multiarch --with-keep.source
16 | PackageRoxygenize: rd,collate,namespace
17 | 


--------------------------------------------------------------------------------
/releases/optrdd_1.0.1.tar.gz:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/swager/optrdd/8d85c92972aa1e90943d7c571de9ba379e5c0584/releases/optrdd_1.0.1.tar.gz


--------------------------------------------------------------------------------
/releases/optrdd_1.0.2.tar.gz:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/swager/optrdd/8d85c92972aa1e90943d7c571de9ba379e5c0584/releases/optrdd_1.0.2.tar.gz


--------------------------------------------------------------------------------
/releases/optrdd_1.0.tar.gz:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/swager/optrdd/8d85c92972aa1e90943d7c571de9ba379e5c0584/releases/optrdd_1.0.tar.gz


--------------------------------------------------------------------------------
/tests/testthat.R:
--------------------------------------------------------------------------------
1 | library(testthat)
2 | library(optrdd)
3 | 
4 | test_check("optrdd")
5 | 


--------------------------------------------------------------------------------
/tests/testthat/test_all.R:
--------------------------------------------------------------------------------
  1 | context("Test that answers from optimizers match.")
  2 | 
  3 | set.seed(1)
  4 | 
  5 | max.second.derivative = 1
  6 | K = 20
  7 | vv = 1.27 * 1:20
  8 | supp = 2 * (vv - trunc(vv)) - 1
  9 | prob = rexp(K)
 10 | prob = prob/sum(prob)
 11 | 
 12 | n = 2000
 13 | 
 14 | bucket = as.numeric(1:K %*% rmultinom(n, 1, prob))
 15 | 
 16 | X = supp[bucket]
 17 | threshold = 0
 18 | W = as.numeric(X >= threshold)
 19 | Y = 10 + X + rnorm(n) + W
 20 | 
 21 | # Test methods initially, and confirm gamma moments
 22 | rdd.free = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, verbose = FALSE, optimizer = "mosek")
 23 | rdd.cate = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose = FALSE, optimizer = "mosek")
 24 | 
 25 | test_that("optrdd gammas satisfy constraints", {
 26 |     tol = rdd.cate$gamma.fun.0[2, 1] - rdd.cate$gamma.fun.0[1, 1]
 27 |     expect_equal(sum(rdd.cate$gamma), 0)
 28 |     expect_equal(sum(rdd.cate$gamma * W), 1)
 29 |     expect_equal(sum(rdd.cate$gamma * X), 0, tolerance = tol)
 30 |     expect_equal(sum(rdd.cate$gamma * X * W), 0, tolerance = tol)
 31 |     expect_equal(sum(rdd.free$gamma), 0)
 32 |     expect_equal(sum(rdd.free$gamma * W), 1)
 33 |     expect_equal(sum(rdd.free$gamma * X), 0, tolerance = tol)
 34 | })
 35 | 
 36 | test_that("cate constraint hurts", {
 37 |     expect_true(rdd.cate$tau.plusminus > rdd.free$tau.plusminus)
 38 | })
 39 | 
 40 | # Check implementation against legacy implementation
 41 | test_that("results match legacy implementation", {
 42 |     skip_on_cran()
 43 |     source("../../baselines/old.optrdd.R")
 44 |     rdd.old = optrdd.primal(X=X, Y=Y, threshold = 0, max.second.derivative = max.second.derivative)
 45 |     expect_equal(rdd.cate$tau.hat, rdd.old$tau.hat, tolerance = rdd.cate$tau.plusminus)
 46 |     expect_equal(rdd.cate$tau.plusminus, rdd.old$tau.plusminus, tolerance = 0.01)
 47 | })
 48 | 
 49 | # Test optimization strategies
 50 | rdd.free.raw = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, bin.width = 0.05, use.spline = FALSE, verbose = FALSE)
 51 | rdd.cate.raw = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, bin.width = 0.05, use.spline = FALSE, verbose = FALSE)
 52 | rdd.free.qp = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "quadprog", verbose = FALSE)
 53 | rdd.cate.qp = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "quadprog", verbose = FALSE)
 54 | rdd.free.mk = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "mosek", verbose = FALSE)
 55 | rdd.cate.mk = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "mosek", verbose = FALSE)
 56 | rdd.free.ecos = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "ECOS", verbose = FALSE)
 57 | rdd.cate.ecos = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "ECOS", verbose = FALSE)
 58 | expect_warning(rdd.free.scs <- optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "SCS", verbose = FALSE))
 59 | expect_warning(rdd.cate.scs <- optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "SCS", verbose = FALSE))
 60 | 
 61 | test_that("optimization strategies are equivalent", {
 62 |     expect_equal(rdd.free$tau.hat, rdd.free.raw$tau.hat, tolerance = rdd.free$tau.plusminus)
 63 |     expect_equal(rdd.free$tau.plusminus, rdd.free.raw$tau.plusminus, tolerance = 0.01)
 64 |     expect_equal(rdd.free$tau.hat, rdd.free.qp$tau.hat, tolerance = 0.01)
 65 |     expect_equal(rdd.free$tau.plusminus, rdd.free.qp$tau.plusminus, tolerance = 0.01)
 66 |     expect_equal(rdd.free$tau.hat, rdd.free.mk$tau.hat, tolerance = 0.001)
 67 |     expect_equal(rdd.free$tau.plusminus, rdd.free.mk$tau.plusminus, tolerance = 0.001)
 68 |     expect_equal(rdd.free$tau.hat, rdd.free.ecos$tau.hat, tolerance = 0.001)
 69 |     expect_equal(rdd.free$tau.plusminus, rdd.free.ecos$tau.plusminus, tolerance = 0.001)
 70 |     
 71 |     # SCS is not actually quite the same...
 72 |     expect_equal(rdd.free$tau.hat, rdd.free.scs$tau.hat, tolerance = 0.05)
 73 |     expect_equal(rdd.free$tau.plusminus, rdd.free.scs$tau.plusminus, tolerance = 0.05)
 74 |     
 75 |     expect_equal(rdd.cate$tau.hat, rdd.cate.raw$tau.hat, tolerance = rdd.cate$tau.plusminus)
 76 |     expect_equal(rdd.cate$tau.plusminus, rdd.cate.raw$tau.plusminus, tolerance = 0.05)
 77 |     expect_equal(rdd.cate$tau.hat, rdd.cate.qp$tau.hat, tolerance = 0.01)
 78 |     expect_equal(rdd.cate$tau.plusminus, rdd.cate.qp$tau.plusminus, tolerance = 0.05)
 79 |     expect_equal(rdd.cate$tau.hat, rdd.cate.mk$tau.hat, tolerance = 0.001)
 80 |     expect_equal(rdd.cate$tau.plusminus, rdd.cate.mk$tau.plusminus, tolerance = 0.001)
 81 |     expect_equal(rdd.cate$tau.hat, rdd.cate.ecos$tau.hat, tolerance = 0.005)
 82 |     expect_equal(rdd.cate$tau.plusminus, rdd.cate.ecos$tau.plusminus, tolerance = 0.005)
 83 |     
 84 |     # SCS is not actually quite the same...
 85 |     expect_equal(rdd.cate$tau.hat, rdd.cate.scs$tau.hat, tolerance = 0.05)
 86 |     expect_equal(rdd.cate$tau.plusminus, rdd.cate.scs$tau.plusminus, tolerance = 0.12)
 87 | })
 88 | 
 89 | # Test sigma square estimation for optrdd
 90 | rdd.fixed = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose=FALSE,
 91 |                    sigma.sq=1, use.homoskedatic.variance=FALSE)
 92 | rdd.homosk = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose=FALSE,
 93 |                     sigma.sq=1, use.homoskedatic.variance=TRUE)
 94 | 
 95 | test_that("oprdd gets variance almost right", {
 96 |     expect_equal(rdd.cate$tau.hat, rdd.fixed$tau.hat, tolerance = 0.01)
 97 |     expect_equal(rdd.cate$tau.plusminus, rdd.fixed$tau.plusminus, tolerance = 0.05)
 98 |     expect_equal(rdd.cate$tau.hat, rdd.homosk$tau.hat, tolerance = 0.01)
 99 |     expect_equal(rdd.cate$tau.plusminus, rdd.homosk$tau.plusminus, tolerance = 0.05)
100 | })
101 | 
102 | 
103 | # Test bias-adjusted confidence interval function
104 | 
105 | test_that("test plusminus function", {
106 |     max.bias = 1
107 |     se = 2
108 |     alpha = 0.95
109 |     pm = get.plusminus(max.bias, se, alpha)
110 |     err = pnorm(-(pm + max.bias)/se) + pnorm(-(pm - max.bias)/se)
111 |     expect_equal(alpha + err, 1, tolerance = 10^(-5))
112 |     
113 |     pm2 = get.plusminus(0, 1, 0.9)
114 |     expect_equal(pm2, qnorm(0.95), tolerance = 10^(-5))
115 | })
116 | 
117 | # Test 2d optrdd
118 | X.2d = cbind(X, runif(n, -1, 1))
119 | W = X.2d[, 1] < 0 | X.2d[, 2] < 0
120 | 
121 | MOSEK = requireNamespace("Rmosek", quietly = TRUE)
122 | rdd.2d.free.mk = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
123 |                         verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "mosek")
124 | rdd.2d.cate.mk = optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
125 |                         verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "mosek")
126 | # For quadprog, make the problem easier...
127 | rdd.2d.free.qp = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
128 |                         verbose = FALSE, spline.df = 6, bin.width = 0.2, optimizer = "quadprog")
129 | rdd.2d.cate.qp = optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
130 |                         verbose = FALSE, spline.df = 6, bin.width = 0.2, optimizer = "quadprog")
131 | 
132 | 
133 | rdd.2d.free.ecos = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
134 |                          verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "ECOS")
135 | rdd.2d.cate.ecos = optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
136 |                          verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "ECOS")
137 | expect_warning(rdd.2d.free.scs <- optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
138 |                      verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "SCS"))
139 | expect_warning(rdd.2d.cate.scs <- optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
140 |                      verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "SCS"))
141 | 
142 | 
143 | test_that("2d-optrdd gammas satisfy constraints with mosek", {
144 |     tol = 0.01
145 |     expect_equal(sum(rdd.2d.free.mk$gamma), 0)
146 |     expect_equal(sum(rdd.2d.free.mk$gamma * W), 1)
147 |     expect_equal(sum(rdd.2d.free.mk$gamma * X.2d[, 1]), 0, tolerance = tol)
148 |     expect_equal(sum(rdd.2d.free.mk$gamma * X.2d[, 2]), 0, tolerance = tol)
149 |     expect_equal(sum(rdd.2d.cate.mk$gamma), 0)
150 |     expect_equal(sum(rdd.2d.cate.mk$gamma * W), 1)
151 |     expect_equal(sum(rdd.2d.cate.mk$gamma * X.2d[, 1]), 0, tolerance = tol)
152 |     expect_equal(sum(rdd.2d.cate.mk$gamma * X.2d[, 2]), 0, tolerance = tol)
153 |     expect_equal(sum(rdd.2d.cate.mk$gamma * W * X.2d[, 1]), 0, tolerance = tol)
154 |     expect_equal(sum(rdd.2d.cate.mk$gamma * W * X.2d[, 2]), 0, tolerance = tol)
155 | })
156 | 
157 | test_that("2d-optrdd gammas satisfy constraints with quadprog", {
158 |     tol = 0.05 # note the somewhate loose tolerance
159 |     expect_equal(sum(rdd.2d.free.qp$gamma), 0)
160 |     expect_equal(sum(rdd.2d.free.qp$gamma * W), 1)
161 |     expect_equal(sum(rdd.2d.free.qp$gamma * X.2d[, 1]), 0, tolerance = tol)
162 |     expect_equal(sum(rdd.2d.free.qp$gamma * X.2d[, 2]), 0, tolerance = tol)
163 |     expect_equal(sum(rdd.2d.cate.qp$gamma), 0)
164 |     expect_equal(sum(rdd.2d.cate.qp$gamma * W), 1)
165 |     expect_equal(sum(rdd.2d.cate.qp$gamma * X.2d[, 1]), 0, tolerance = tol)
166 |     expect_equal(sum(rdd.2d.cate.qp$gamma * X.2d[, 2]), 0, tolerance = tol)
167 |     expect_equal(sum(rdd.2d.cate.qp$gamma * W * X.2d[, 1]), 0, tolerance = tol)
168 |     expect_equal(sum(rdd.2d.cate.qp$gamma * W * X.2d[, 2]), 0, tolerance = tol)
169 | })
170 | 
171 | test_that("2d-optrdd gammas satisfy constraints with ECOS", {
172 |     tol = 0.01
173 |     expect_equal(sum(rdd.2d.free.ecos$gamma), 0)
174 |     expect_equal(sum(rdd.2d.free.ecos$gamma * W), 1)
175 |     expect_equal(sum(rdd.2d.free.ecos$gamma * X.2d[, 1]), 0, tolerance = tol)
176 |     expect_equal(sum(rdd.2d.free.ecos$gamma * X.2d[, 2]), 0, tolerance = tol)
177 |     expect_equal(sum(rdd.2d.cate.ecos$gamma), 0)
178 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * W), 1)
179 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * X.2d[, 1]), 0, tolerance = tol)
180 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * X.2d[, 2]), 0, tolerance = tol)
181 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * W * X.2d[, 1]), 0, tolerance = tol)
182 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * W * X.2d[, 2]), 0, tolerance = tol)
183 | })
184 | 
185 | test_that("2d-optrdd gammas satisfy constraints with SCS", {
186 |     tol = 0.01
187 |     expect_equal(sum(rdd.2d.free.scs$gamma), 0)
188 |     expect_equal(sum(rdd.2d.free.scs$gamma * W), 1)
189 |     expect_equal(sum(rdd.2d.free.scs$gamma * X.2d[, 1]), 0, tolerance = tol)
190 |     expect_equal(sum(rdd.2d.free.scs$gamma * X.2d[, 2]), 0, tolerance = tol)
191 |     expect_equal(sum(rdd.2d.cate.scs$gamma), 0)
192 |     expect_equal(sum(rdd.2d.cate.scs$gamma * W), 1)
193 |     expect_equal(sum(rdd.2d.cate.scs$gamma * X.2d[, 1]), 0, tolerance = tol)
194 |     expect_equal(sum(rdd.2d.cate.scs$gamma * X.2d[, 2]), 0, tolerance = tol)
195 |     expect_equal(sum(rdd.2d.cate.scs$gamma * W * X.2d[, 1]), 0, tolerance = tol)
196 |     expect_equal(sum(rdd.2d.cate.scs$gamma * W * X.2d[, 2]), 0, tolerance = tol)
197 | })
198 | 
199 | test_that("MOSEK/ECOS give same answer on 2d problem", {
200 |     expect_equal(rdd.2d.free.mk$tau.hat, rdd.2d.free.ecos$tau.hat, tolerance = 0.001)
201 |     expect_equal(rdd.2d.free.mk$tau.plusminus, rdd.2d.free.ecos$tau.plusminus, tolerance = 0.001)
202 |     expect_equal(rdd.2d.cate.mk$tau.hat, rdd.2d.cate.ecos$tau.hat, tolerance = 0.001)
203 |     expect_equal(rdd.2d.cate.mk$tau.plusminus, rdd.2d.cate.ecos$tau.plusminus, tolerance = 0.001)
204 | })
205 | 
206 | test_that("MOSEK/SCS give same answer on 2d problem", {
207 |     # note the looser tolerance
208 |     expect_equal(rdd.2d.free.mk$tau.hat, rdd.2d.free.scs$tau.hat, tolerance = 0.05)
209 |     expect_equal(rdd.2d.free.mk$tau.plusminus, rdd.2d.free.scs$tau.plusminus, tolerance = 0.01)
210 |     expect_equal(rdd.2d.cate.mk$tau.hat, rdd.2d.cate.scs$tau.hat, tolerance = 0.05)
211 |     expect_equal(rdd.2d.cate.mk$tau.plusminus, rdd.2d.cate.scs$tau.plusminus, tolerance = 0.01)
212 | })
213 | 
214 | rdd.2d.free.raw.mk = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
215 |                          use.spline = FALSE, bin.width = 0.05, verbose = FALSE, optimizer = "mosek")
216 | rdd.2d.free.raw.ecos = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
217 |                              use.spline = FALSE, bin.width = 0.05, verbose = FALSE, optimizer = "ECOS")
218 | expect_warning(rdd.2d.free.raw.scs <- optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
219 |                                              use.spline = FALSE, bin.width = 0.05, verbose = FALSE, optimizer = "SCS"))
220 | 
221 | test_that("Spline approximation doesn't affect MOSEK", {
222 |     expect_equal(rdd.2d.free.mk$tau.hat, rdd.2d.free.raw.mk$tau.hat, tolerance = rdd.2d.free.mk$tau.plusminus)
223 |     expect_equal(rdd.2d.free.mk$tau.plusminus, rdd.2d.free.raw.mk$tau.plusminus, tolerance = 0.01)
224 | })
225 | 
226 | test_that("Spline approximation doesn't affect ECOS", {
227 |     expect_equal(rdd.2d.free.ecos$tau.hat, rdd.2d.free.raw.ecos$tau.hat, tolerance = rdd.2d.free.ecos$tau.plusminus)
228 |     expect_equal(rdd.2d.free.ecos$tau.plusminus, rdd.2d.free.raw.ecos$tau.plusminus, tolerance = 0.01)
229 | })
230 | 
231 | 
232 | test_that("Spline approximation doesn't affect SCS", {
233 |     expect_equal(rdd.2d.free.scs$tau.hat, rdd.2d.free.raw.scs$tau.hat, tolerance = rdd.2d.free.scs$tau.plusminus)
234 |     expect_equal(rdd.2d.free.scs$tau.plusminus, rdd.2d.free.raw.scs$tau.plusminus, tolerance = 0.07)
235 | })
236 | 
237 | 
238 | test_that("baseline local linear regression implementation works", {
239 |     
240 |     skip_on_cran()
241 |     source("../../baselines/local.lin.reg.R")
242 |     rectangle = llr(X, Y = Y, max.second.derivative, kernel = "rectangular", 
243 |                     minimization.target = "mse", max.window = 1)
244 |     triangle = llr(X, Y = Y, max.second.derivative, kernel = "triangular", 
245 |                    minimization.target = "mse", max.window = 1)
246 |     
247 |     half.bucket = min(rectangle$gamma.fun[-1, 1] -
248 |                           rectangle$gamma.fun[-nrow(rectangle$gamma.fun), 1])
249 |     expect_equal(sum(rectangle$gamma), 0)
250 |     expect_equal(sum(rectangle$gamma * (X > 0)), 1)
251 |     expect_equal(sum(rectangle$gamma * X), 0, tolerance = half.bucket)
252 |     expect_equal(sum(rectangle$gamma * X * (X > 0)), 0, tolerance = half.bucket)
253 |     
254 |     half.bucket = min(triangle$gamma.fun[-1, 1] -
255 |                           triangle$gamma.fun[-nrow(triangle$gamma.fun), 1])
256 |     expect_equal(sum(triangle$gamma), 0)
257 |     expect_equal(sum(triangle$gamma * (X > 0)), 1)
258 |     expect_equal(sum(triangle$gamma * X), 0, tolerance = half.bucket)
259 |     expect_equal(sum(triangle$gamma * X * (X > 0)), 0, tolerance = half.bucket)
260 |     
261 |     expect_true(rdd.cate$max.bias^2 + rdd.cate$sampling.se^2 <
262 |                     triangle$max.bias^2 + triangle$sampling.se^2)
263 |     expect_true(triangle$max.bias^2 + triangle$sampling.se^2 < 
264 |                     rectangle$max.bias^2 + rectangle$sampling.se^2)
265 |     
266 |     # Test sigma square estimation for llr
267 |     triangle.fixed = llr(X, Y = Y, max.second.derivative, sigma.sq = 1, max.window = 1, 
268 |                          use.homoskedatic.variance = TRUE, kernel = "triangular",
269 |                          minimization.target = "mse")
270 |     
271 |     expect_equal(triangle$tau.hat, triangle.fixed$tau.hat, tolerance = 0.05)
272 |     expect_equal(triangle$tau.plusminus, triangle.fixed$tau.plusminus, 
273 |                  tolerance = 0.05)
274 | })
275 | 
276 | 


--------------------------------------------------------------------------------
/tests/testthat/test_for_cran.R:
--------------------------------------------------------------------------------
  1 | context("Run tests for CRAN.")
  2 | 
  3 | set.seed(1)
  4 | 
  5 | max.second.derivative = 1
  6 | K = 20
  7 | vv = 1.27 * 1:20
  8 | supp = 2 * (vv - trunc(vv)) - 1
  9 | prob = rexp(K)
 10 | prob = prob/sum(prob)
 11 | 
 12 | n = 2000
 13 | 
 14 | bucket = as.numeric(1:K %*% rmultinom(n, 1, prob))
 15 | 
 16 | X = supp[bucket]
 17 | threshold = 0
 18 | W = as.numeric(X >= threshold)
 19 | Y = 10 + X + rnorm(n) + W
 20 | 
 21 | # Test methods initially, and confirm gamma moments
 22 | rdd.free.qp = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, verbose = FALSE, optimizer = "quadprog")
 23 | rdd.cate.qp = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose = FALSE, optimizer = "quadprog")
 24 | 
 25 | rdd.free.ecos = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, verbose = FALSE, optimizer = "ECOS")
 26 | rdd.cate.ecos = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose = FALSE, optimizer = "ECOS")
 27 | 
 28 | test_that("optrdd gammas satisfy constraints with quadprog", {
 29 |     tol = rdd.cate.qp$gamma.fun.0[2, 1] - rdd.cate.qp$gamma.fun.0[1, 1]
 30 |     expect_equal(sum(rdd.cate.qp$gamma), 0)
 31 |     expect_equal(sum(rdd.cate.qp$gamma * W), 1)
 32 |     expect_equal(sum(rdd.cate.qp$gamma * X), 0, tolerance = tol)
 33 |     expect_equal(sum(rdd.cate.qp$gamma * X * W), 0, tolerance = tol)
 34 |     expect_equal(sum(rdd.free.qp$gamma), 0)
 35 |     expect_equal(sum(rdd.free.qp$gamma * W), 1)
 36 |     expect_equal(sum(rdd.free.qp$gamma * X), 0, tolerance = tol)
 37 | })
 38 | 
 39 | test_that("optrdd gammas satisfy constraints with ECOS", {
 40 |     tol = rdd.cate.ecos$gamma.fun.0[2, 1] - rdd.cate.ecos$gamma.fun.0[1, 1]
 41 |     expect_equal(sum(rdd.cate.ecos$gamma), 0)
 42 |     expect_equal(sum(rdd.cate.ecos$gamma * W), 1)
 43 |     expect_equal(sum(rdd.cate.ecos$gamma * X), 0, tolerance = tol)
 44 |     expect_equal(sum(rdd.cate.ecos$gamma * X * W), 0, tolerance = tol)
 45 |     expect_equal(sum(rdd.free.ecos$gamma), 0)
 46 |     expect_equal(sum(rdd.free.ecos$gamma * W), 1)
 47 |     expect_equal(sum(rdd.free.ecos$gamma * X), 0, tolerance = tol)
 48 | })
 49 | 
 50 | test_that("ECOS and quadprog optimizers match", {
 51 |     expect_equal(rdd.cate.qp$tau.hat, rdd.cate.ecos$tau.hat, tolerance = 0.01)
 52 |     expect_equal(rdd.cate.qp$tau.plusminus, rdd.cate.ecos$tau.plusminus, tolerance = 0.01)
 53 | })
 54 | 
 55 | test_that("cate constraint hurts", {
 56 |     expect_true(rdd.cate.qp$tau.plusminus > rdd.free.qp$tau.plusminus)
 57 |     expect_true(rdd.cate.ecos$tau.plusminus > rdd.free.ecos$tau.plusminus)
 58 | })
 59 | 
 60 | 
 61 | # Test optimization strategies
 62 | 
 63 | rdd.free = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "quadprog", verbose = FALSE)
 64 | rdd.cate = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "quadprog", verbose = FALSE)
 65 | rdd.free.ecos = optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "ECOS", verbose = FALSE)
 66 | rdd.cate.ecos = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "ECOS", verbose = FALSE)
 67 | expect_warning(rdd.free.scs <- optrdd(X=X, Y=Y, W=W, max.second.derivative = max.second.derivative, optimizer = "SCS", verbose = FALSE))
 68 | expect_warning(rdd.cate.scs <- optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, optimizer = "SCS", verbose = FALSE))
 69 | 
 70 | test_that("optimization strategies are equivalent", {
 71 | 
 72 |     expect_equal(rdd.free$tau.hat, rdd.free.ecos$tau.hat, tolerance = 0.01)
 73 |     expect_equal(rdd.free$tau.plusminus, rdd.free.ecos$tau.plusminus, tolerance = 0.01)
 74 |     # SCS is too inaccurate, so this test gets flaky
 75 |     #expect_equal(rdd.free$tau.hat, rdd.free.scs$tau.hat, tolerance = 0.2)
 76 |     #expect_equal(rdd.free$tau.plusminus, rdd.free.scs$tau.plusminus, tolerance = 0.2)
 77 |     
 78 |     expect_equal(rdd.cate$tau.hat, rdd.cate.ecos$tau.hat, tolerance = 0.01)
 79 |     expect_equal(rdd.cate$tau.plusminus, rdd.cate.ecos$tau.plusminus, tolerance = 0.01)
 80 |     #expect_equal(rdd.cate$tau.hat, rdd.cate.scs$tau.hat, tolerance = 0.2)
 81 |     #expect_equal(rdd.cate$tau.plusminus, rdd.cate.scs$tau.plusminus, tolerance = 0.2)
 82 | })
 83 | 
 84 | # Test sigma square estimation for optrdd
 85 | rdd.fixed = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose=FALSE,
 86 |                    sigma.sq=1, use.homoskedatic.variance=FALSE, optimizer = "ECOS")
 87 | rdd.homosk = optrdd(X=X, Y=Y, W=W, estimation.point = threshold, max.second.derivative = max.second.derivative, verbose=FALSE,
 88 |                     sigma.sq=1, use.homoskedatic.variance=TRUE, optimizer = "ECOS")
 89 | 
 90 | test_that("oprdd gets variance almost right", {
 91 |     expect_equal(rdd.cate$tau.hat, rdd.fixed$tau.hat, tolerance = 0.01)
 92 |     expect_equal(rdd.cate$tau.plusminus, rdd.fixed$tau.plusminus, tolerance = 0.05)
 93 |     expect_equal(rdd.cate$tau.hat, rdd.homosk$tau.hat, tolerance = 0.01)
 94 |     expect_equal(rdd.cate$tau.plusminus, rdd.homosk$tau.plusminus, tolerance = 0.05)
 95 | })
 96 | 
 97 | 
 98 | # Test bias-adjusted confidence interval function
 99 | 
100 | test_that("test plusminus function", {
101 |     max.bias = 1
102 |     se = 2
103 |     alpha = 0.95
104 |     pm = get.plusminus(max.bias, se, alpha)
105 |     err = pnorm(-(pm + max.bias)/se) + pnorm(-(pm - max.bias)/se)
106 |     expect_equal(alpha + err, 1, tolerance = 10^(-5))
107 |     
108 |     pm2 = get.plusminus(0, 1, 0.9)
109 |     expect_equal(pm2, qnorm(0.95), tolerance = 10^(-5))
110 | })
111 | 
112 | # Test 2d optrdd
113 | X.2d = cbind(X, runif(n, -1, 1))
114 | W = X.2d[, 1] < 0 | X.2d[, 2] < 0
115 | 
116 | # For quadprog, make the problem easier...
117 | rdd.2d.free.qp = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
118 |                         verbose = FALSE, spline.df = 6, bin.width = 0.2, optimizer = "quadprog")
119 | rdd.2d.cate.qp = optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
120 |                         verbose = FALSE, spline.df = 6, bin.width = 0.2, optimizer = "quadprog")
121 | 
122 | 
123 | rdd.2d.free.ecos = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
124 |                          verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "ECOS")
125 | rdd.2d.cate.ecos = optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
126 |                          verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "ECOS")
127 | expect_warning(rdd.2d.free.scs <- optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
128 |                                          verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "SCS"))
129 | expect_warning(rdd.2d.cate.scs <- optrdd(X=X.2d, Y=Y, W=W, estimation.point = c(0, 0), max.second.derivative = max.second.derivative,
130 |                                          verbose = FALSE, spline.df = 20, bin.width = 0.05, optimizer = "SCS"))
131 | 
132 | test_that("2d-optrdd gammas satisfy constraints with quadprog", {
133 |     tol = 0.05 # note the somewhate loose tolerance
134 |     expect_equal(sum(rdd.2d.free.qp$gamma), 0)
135 |     expect_equal(sum(rdd.2d.free.qp$gamma * W), 1)
136 |     expect_equal(sum(rdd.2d.free.qp$gamma * X.2d[, 1]), 0, tolerance = tol)
137 |     expect_equal(sum(rdd.2d.free.qp$gamma * X.2d[, 2]), 0, tolerance = tol)
138 |     expect_equal(sum(rdd.2d.cate.qp$gamma), 0)
139 |     expect_equal(sum(rdd.2d.cate.qp$gamma * W), 1)
140 |     expect_equal(sum(rdd.2d.cate.qp$gamma * X.2d[, 1]), 0, tolerance = tol)
141 |     expect_equal(sum(rdd.2d.cate.qp$gamma * X.2d[, 2]), 0, tolerance = tol)
142 |     expect_equal(sum(rdd.2d.cate.qp$gamma * W * X.2d[, 1]), 0, tolerance = tol)
143 |     expect_equal(sum(rdd.2d.cate.qp$gamma * W * X.2d[, 2]), 0, tolerance = tol)
144 | })
145 | 
146 | test_that("2d-optrdd gammas satisfy constraints with ECOS", {
147 |     tol = 0.03
148 |     expect_equal(sum(rdd.2d.free.ecos$gamma), 0)
149 |     expect_equal(sum(rdd.2d.free.ecos$gamma * W), 1)
150 |     expect_equal(sum(rdd.2d.free.ecos$gamma * X.2d[, 1]), 0, tolerance = tol)
151 |     expect_equal(sum(rdd.2d.free.ecos$gamma * X.2d[, 2]), 0, tolerance = tol)
152 |     expect_equal(sum(rdd.2d.cate.ecos$gamma), 0)
153 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * W), 1)
154 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * X.2d[, 1]), 0, tolerance = tol)
155 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * X.2d[, 2]), 0, tolerance = tol)
156 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * W * X.2d[, 1]), 0, tolerance = tol)
157 |     expect_equal(sum(rdd.2d.cate.ecos$gamma * W * X.2d[, 2]), 0, tolerance = tol)
158 | })
159 | 
160 | test_that("2d-optrdd gammas satisfy constraints with SCS", {
161 |     tol = 0.03
162 |     expect_equal(sum(rdd.2d.free.scs$gamma), 0)
163 |     expect_equal(sum(rdd.2d.free.scs$gamma * W), 1)
164 |     expect_equal(sum(rdd.2d.free.scs$gamma * X.2d[, 1]), 0, tolerance = tol)
165 |     expect_equal(sum(rdd.2d.free.scs$gamma * X.2d[, 2]), 0, tolerance = tol)
166 |     expect_equal(sum(rdd.2d.cate.scs$gamma), 0)
167 |     expect_equal(sum(rdd.2d.cate.scs$gamma * W), 1)
168 |     expect_equal(sum(rdd.2d.cate.scs$gamma * X.2d[, 1]), 0, tolerance = tol)
169 |     expect_equal(sum(rdd.2d.cate.scs$gamma * X.2d[, 2]), 0, tolerance = tol)
170 |     expect_equal(sum(rdd.2d.cate.scs$gamma * W * X.2d[, 1]), 0, tolerance = tol)
171 |     expect_equal(sum(rdd.2d.cate.scs$gamma * W * X.2d[, 2]), 0, tolerance = tol)
172 | })
173 | 
174 | test_that("ECOS/SCS give same answer on 2d problem", {
175 |     # note the looser tolerance
176 |     expect_equal(rdd.2d.free.ecos$tau.hat, rdd.2d.free.scs$tau.hat, tolerance = 0.1)
177 |     expect_equal(rdd.2d.free.ecos$tau.plusminus, rdd.2d.free.scs$tau.plusminus, tolerance = 0.05)
178 |     expect_equal(rdd.2d.cate.ecos$tau.hat, rdd.2d.cate.scs$tau.hat, tolerance = 0.1)
179 |     expect_equal(rdd.2d.cate.ecos$tau.plusminus, rdd.2d.cate.scs$tau.plusminus, tolerance = 0.05)
180 | })
181 | 
182 | rdd.2d.free.raw.ecos = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
183 |                              use.spline = FALSE, bin.width = 0.05, verbose = FALSE, optimizer = "ECOS")
184 | test_that("Spline approximation doesn't affect ECOS", {
185 |     expect_equal(rdd.2d.free.ecos$tau.hat, rdd.2d.free.raw.ecos$tau.hat, tolerance = rdd.2d.free.ecos$tau.plusminus)
186 |     expect_equal(rdd.2d.free.ecos$tau.plusminus, rdd.2d.free.raw.ecos$tau.plusminus, tolerance = 0.01)
187 | })
188 | 
189 | # SCS is again a little flaky
190 | # rdd.2d.free.raw.scs = optrdd(X=X.2d, Y=Y, W=W, max.second.derivative = max.second.derivative,
191 | #                              use.spline = FALSE, bin.width = 0.05, verbose = FALSE, optimizer = "SCS")
192 | # test_that("Spline approximation doesn't affect SCS", {
193 | #     expect_equal(rdd.2d.free.scs$tau.hat, rdd.2d.free.raw.scs$tau.hat, tolerance = rdd.2d.free.scs$tau.plusminus)
194 | #     expect_equal(rdd.2d.free.scs$tau.plusminus, rdd.2d.free.raw.scs$tau.plusminus, tolerance = 0.1)
195 | # })
196 | 
197 | 


--------------------------------------------------------------------------------
/tests/testthat/test_numerics.R:
--------------------------------------------------------------------------------
 1 | context("Test behavior on example with strong curvature.")
 2 | 
 3 | set.seed(1)
 4 | 
 5 | ludwig.miller = Vectorize(function(x) {
 6 |     if (x < 0) {
 7 |         mu = 3.71 + 2.3 * x + 3.28 * x^2 + 1.45 * x^3 + 0.23 * x^4 + 0.03 * x^5
 8 |     } else {
 9 |         mu = 0.26  + 18.49 * x - 54.81 * x^2 + 74.30 * x^3 - 45.02 * x^4 + 9.83 * x^5
10 |     }
11 |     mu
12 | })
13 | B.ludwig.miller = 2 * 54.81
14 | tau.ludwig.miller = - 3.71 + 0.26
15 | 
16 | fff = ludwig.miller
17 | Bmax = B.ludwig.miller
18 | tau.true = tau.ludwig.miller
19 | 
20 | n = 5000
21 | sigma = 0.1295
22 | 
23 | X = 2 * rbeta(n, 2, 4) - 1
24 | Y = fff(X) + sigma * rnorm(n)
25 | W = as.numeric(X > 0)
26 | 
27 | test_that("Elastic net is recommended when appropriate.", {
28 |     # Since there is a lot of curvature, we need to use an elastic net to
29 |     # get good CIs (and avoid a warning)
30 |     expect_warning(run1 <- optrdd(X, Y, W, Bmax, optimizer = "mosek", verbose = FALSE))
31 |     expect_silent(run2 <- optrdd(X, Y, W, Bmax, optimizer = "mosek", verbose = FALSE, try.elnet.for.sigma.sq = TRUE))
32 |     expect_true(run2$tau.plusminus < 0.97 * run1$tau.plusminus)
33 |     expect_true(abs(run2$tau.hat - tau.true) < run2$tau.plusminus)
34 | })
35 | 
36 | test_that("Optimizer warnings are emitted.", {
37 |     # ECOS is unable to solve accurately here. There should be a warning.
38 |     expect_warning(run3 <- optrdd(X, Y, W, Bmax, optimizer = "ECOS", verbose = FALSE, try.elnet.for.sigma.sq = TRUE))
39 |     # SCS sometimes doesn't find the true optimum. There should be a warning about this.
40 |     expect_warning(run4 <- optrdd(X, Y, W, Bmax, optimizer = "SCS", verbose = FALSE, try.elnet.for.sigma.sq = TRUE))
41 | })


--------------------------------------------------------------------------------