tests/testthat/test_npr.R

In kolesarm/RDHonest: Honest Inference in Regression Discontinuity Designs

test_that("Test NN variance estimator", {
    r0 <- RDHonest(cn|retired~ elig_year, data=rcp[1:500, ],
                   M=c(1, 1), h=20)
    d <- r0$d

    s0 <- sigmaNN(d$X[d$p], d$Y[d$p, ], J=5)
    s1 <- sigmaNN(d$X[d$p], d$Y[d$p, 1], J=5)
    s2 <- sigmaNN(d$X[d$p], d$Y[d$p, 2], J=5)
    expect_equal(s0[, 1], s1)
    expect_equal(s0[, 4], s2)
})

test_that("Test LPreg", {
    d <- rcp[1:1000, ]
    r0 <- RDHonest(cn ~ elig_year, data=d, M=1, h=10, J=4)
    r0m <- RDHonest(cn ~ elig_year, data=d, M=1, h=10, subset=elig_year<0,
                    point.inference=TRUE, J=4)
    r0p <- RDHonest(cn ~ elig_year, data=d, M=1, h=10, subset=elig_year>=0,
                    point.inference=TRUE, J=4)
    expect_equal(r0p$coefficients$estimate-r0m$coefficients$estimate,
                 r0$coefficients$estimate)
    expect_equal(range(c(r0m$data$sigma2, r0p$data$sigma2)-r0$data$sigma2),
                 c(0, 0))
    expect_equal(as.numeric(r0m$coefficients[c(2:10)]),
                 c(20139.543667707,  2097.006669471,     6.641178638,
                   16029.465508831, 24249.621826583, 16683.633463048,
                   23595.453872367,    10L,   125.503763304))
    rr <- NPReg(r0$data, h=6, kern="triangular", order=2, se.method="nn", J=6)
    expect_equal(as.numeric(rr[1:2]),  c(-4052.273935, 7942.849050))
})

test_that("Test NPReg", {
    ## Replicate Ludwig-Miller
    lumi <- headst[!is.na(headst$mortHS), c("mortHS", "povrate")]
    mort <- RDHonest(mortHS~povrate, data=lumi, M=1)$d
    mortm <- RDHonest(mortHS~povrate, data=lumi, M=1,
                      subset=povrate<0, point.inference=TRUE)$d
    mortp <- RDHonest(mortHS~povrate, data=lumi, M=1,
                      subset=povrate>=0, point.inference=TRUE)$d
    t1 <- data.frame()
    t2 <- data.frame()
    bws <- c(9, 18, 36)
    for (bw in bws) {
        rfe <- NPReg(mort, bw, "uniform", order=1, se.method="EHW")
        rfn <- NPReg(mort, bw, "uniform", order=1, se.method="nn")
        t1 <- rbind(t1, data.frame(bw=bw, estimate=rfe$estimate,
                                   EHW=rfe$se, nn=rfn$se))
        rme <- NPReg(mortm, bw, "uniform", order=1, se.method="EHW")
        rmn <- NPReg(mortm, bw, "uniform", order=1, se.method="nn")
        rpe <- NPReg(mortp, bw, "uniform", order=1, se.method="EHW")
        rpn <- NPReg(mortp, bw, "uniform", order=1, se.method="nn")
        t2 <- rbind(t2, data.frame(bw=bw, estimate=rpe$estimate-rme$estimate,
                                   EHW=sqrt(rpe$se^2+rme$se^2),
                                   nn=sqrt(rpn$se^2+rmn$se^2)))
    }
    exp <- rbind(c(9, -1.895234221, 0.9801414664, 1.0381954004),
                 c(18, -1.198258131, 0.6608206598, 0.6955768728),
                 c(36, -1.113938949, 0.5001394599, 0.5223659480))
    expect_equal(unname(as.matrix(t1)), exp)
    expect_lt(max(abs(t1-t2)), 1e-11)

    ## Replicate Battistin et al
    df <- RDHonest(retired~elig_year, data=rcp, M=1, h=6)$d
    dr <- RDHonest(log(cn)~elig_year, data=rcp, M=1, h=6)$d
    d <- RDHonest(log(cn)|retired~elig_year, data=rcp, M=c(1, 1), h=6)$d

    rf <- NPReg(df, 10, "uniform", order=1, se.method="EHW")
    rr <- NPReg(dr, 10, "uniform", order=1, se.method="EHW")
    expect_equal(unname(c(rf$estimate, round(rf$se, 4))),
                 c(0.43148435, 0.0181))
    expect_equal(unname(c(rr$estimate, round(rr$se, 4))),
                 c(-0.03550599496, 0.0211))
    r1 <- NPReg(d, 10, "uniform", order=1, se.method="EHW")
    expect_equal(unname(c(r1$estimate, r1$se)),
                 c(-0.08228802393, 0.04830389419))
    ## Numbers from
    ## dt <- cbind(logcn=log(rcp[, 6]), rcp[, c(3, 2)], Z=rcp$elig_year>=0)
    ## r4 <- AER::ivreg(logcn ~ retired + Z:elig_year + elig_year |
    ##                      Z:elig_year + elig_year + Z,
    ##                  subset=(abs(elig_year)<=10), data=dt)
    ## summary(r4, vcov = sandwich::sandwich,
    ##         diagnostics=TRUE)$coefficients[2, 1:2]
    expect_lt(abs(r1$estimate- rr$estimate/rf$estimate), 1e-10)
    r2 <- NPReg(d, 5, function(x) abs(x)<=1, order=0, se.method="EHW")
    ## r3 <- AER::ivreg(logcn~retired | Z, subset=(abs(elig_year)<=5), data=dt)
    ## summary(r3, vcov = sandwich::sandwich,
    ## diagnostics = TRUE)$coefficients[2, 1:2]
    expect_equal(unname(c(r2$estimate, r2$se)),
                 c(-0.14157767658, 0.02562096397))
})