Merge pull request #39 from priism-center/dev

Merge December 8th

.github/workflows/deploy-shinyapps-dev.yml

@@ -5,6 +5,9 @@ on:
   push:
     branches: [dev]
 
+env:
+  RENV_CONFIG_SANDBOX_ENABLED: False
+
 jobs:
   deploy-shinyapps:
     timeout-minutes: 45
@@ -15,13 +18,13 @@ jobs:
         with:
           r-version: '4.2.0'
       - uses: priism-center/thinkCausal_dev/.github/setup-renv@master
-      - name: Install extra dependencies
-        shell: Rscript {0}
-        run: install.packages(c("remotes", "rsconnect"))
-        working-directory: thinkCausal
+#      - name: Install extra dependencies
+#        shell: Rscript {0}
+#        run: install.packages(c("remotes", "rsconnect"))
+#        working-directory: thinkCausal
       - name: Deploy to shinyapps.io
         shell: Rscript {0}
         run: |
           rsconnect::setAccountInfo(name = "${{secrets.SA_ACCOUNT_NAME}}", token = "${{secrets.SA_TOKEN}}", secret = "${{secrets.SA_SECRET}}")
-          rsconnect::deployApp(appName = 'thinkCausal-dev', account = "${{secrets.SA_ACCOUNT_NAME}}")
+          rsconnect::deployApp(appName = 'thinkCausal-dev', account = "${{secrets.SA_ACCOUNT_NAME}}", forceUpdate = TRUE)
         working-directory: thinkCausal

.github/workflows/test-functions.yml

@@ -6,14 +6,22 @@ on:
   pull_request:
     branches: [main, master, dev, workflows]
 
+env:
+  RENV_CONFIG_SANDBOX_ENABLED: False
+  GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
 jobs:
   test-functions:
     timeout-minutes: 45
-    runs-on: ubuntu-latest
+    runs-on: ubuntu-20.04
     steps:
       - uses: actions/checkout@v1
       - uses: r-lib/actions/setup-r@v2
-      - uses: gperrett/thinkCausal_dev/.github/setup-renv@master
+        with:
+          r-version: '4.2.0'
+      - uses: priism-center/thinkCausal_dev/.github/setup-renv@master
+        env:
+          GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
       - name: Run tests
         shell: Rscript {0}
         run: print(getwd()); testthat::test_local();

.gitignore

@@ -1,8 +1,8 @@
 .DS_Store
 .DS_store
 .ds_store
-thinkCausal/rsconnect
-thinkCausal-old/rsconnect
+#thinkCausal/rsconnect
+#thinkCausal-old/rsconnect
 *.html
 
 # vscode workspaces

scratch/Ignorability_draft.R

@@ -0,0 +1,126 @@
+set.seed(2)
+x <- rbinom(4000, 1, .07)
+
+z <- rbinom(4000, 1, ifelse(x == 1, .9, .05))
+
+y1 <- 240 - 5 - 80*x + rnorm(1000, 0, 5)
+y0 <- 240 - 80*x + rnorm(1000, 0, 5)
+y <- ifelse(z == 1, y1, y0)
+
+
+# difference in means 
+fit1 <- lm(y ~ z) # ATE = -50
+fit1
+
+# regression 
+fit2 <- lm(y ~ z + x) # ATE = -5
+fit2
+# with bars
+tibble(x, z, y) %>% 
+  group_by(z) %>% 
+  summarise(y_hat = mean(y)) %>% 
+ggplot(aes(as.factor(z), y_hat, fill = as.factor(z))) + 
+  geom_col(col = 'black') + 
+  scale_fill_manual(values = c(4, 2)) + 
+  theme_bw()
+
+tibble(x, z, y) %>% 
+  group_by(z) %>% 
+  summarise(y_hat = mean(y)) %>% 
+  ggplot(aes(as.factor(z), y_hat, fill = as.factor(z))) + 
+  geom_col(col = 'black') + 
+  scale_fill_manual(values = c(4, 2)) + 
+  theme_bw() + 
+  geom_segment(aes(x = 2.5, xend = 2.5, y = 189, yend = 239)) + 
+  geom_segment(aes(x = 2.5, xend = 2.47, y = 189, yend = 189)) + 
+  geom_segment(aes(x = 2.5, xend = 2.47, y = 239, yend = 239)) + 
+  geom_label(aes(label = 'Difference in Means = -50.19 minutes!', x = 2.3 , y = 214), show.legend = F, col = 1) + 
+  theme(legend.position = 'bottom')
+
+
+tibble(x, z, y) %>% 
+  group_by(z, x) %>% 
+  summarise(y_hat = mean(y)) %>% 
+  ggplot(aes(as.factor(z), y_hat, fill = as.factor(z))) + 
+  geom_col(col = 'black') + 
+  facet_wrap(~x) + 
+  scale_fill_manual(values = c(4, 2)) + 
+  theme_bw()
+
+
+
+# with points 
+
+tibble(x, z, y) %>% 
+  group_by(z) %>% 
+  summarise(y_hat = mean(y)) %>% 
+  mutate(ucl = y_hat + 1.96*sqrt(diag(vcov(fit1)))['z'], 
+         lcl = y_hat - 1.96*sqrt(diag(vcov(fit1)))['z']) %>% 
+  ggplot(aes(as.factor(z), y_hat, col = as.factor(z))) + 
+  geom_point(size = 2) + 
+  geom_segment(aes(x = as.factor(z), xend = as.factor(z), 
+                    y = ucl, yend = lcl)) +
+  geom_segment(aes(x = 1.5, xend = 1.5, y = 239, yend = 189), col = 1) + 
+  geom_label(aes(label = 'Difference in Means = -50.19 minutes!', x = 1.5 , y = 214), show.legend = F, col = 1) + 
+  scale_color_manual(values = c(4, 2)) + 
+  theme_bw()
+
+
+tibble(x, z, y) %>% 
+  group_by(z, x) %>% 
+  summarise(y_hat = mean(y)) %>% 
+  ggplot(aes(as.factor(z), y_hat, col = as.factor(z))) + 
+  geom_point(size = 2) + 
+  facet_wrap(~x) + 
+  #geom_segment(aes(x = 1.5, xend = 1.5, y = 239, yend = 189), col = 1) + 
+  #geom_label(aes(label = 'Difference in Means = -50.19 minutes!', x = 1.5 , y = 214), show.legend = F, col = 1) + 
+  scale_color_manual(values = c(4, 2)) + 
+  theme_bw()
+
+
+
+
+
+### DGP 2
+
+age <- c(runif(500, 18, 65), rnorm(1000, 35, 5), runif(500, 20, 37))
+age[age < 18] <- 18
+
+get_income <- function(x){
+  case_when(
+            x < 25 ~ rnorm(1, 40, 5), 
+            x < 35 ~ rnorm(1, 60, 10), 
+            x < 45 ~ rnorm(1, 80, 10), 
+            x < 70 ~ rnorm(1, 50, 5)
+  )
+}
+
+income <- sapply(age, get_income)
+
+z <- rbinom()
+
+set.seed(2)
+x <- rbinom(4000, 1, .07)
+state_p <- c(.3, .1, .05, .05, .025, .025,.025, .025, .02, .02, rep(.009, 40))
+state <- sample(size = 4000, 1:50, replace = T, prob = state_p)
+
+state_mat <- matrix(nrow = 4000, ncol = 50)
+for (i in 1:50) {
+  state_mat[, i] <- ifelse(state == i,1, 0)
+}
+
+colnames(state_mat) <- paste0('state_', 1:50)
+X <- cbind(pro = x, state_mat)
+
+beta <- c(qnorm(.9), qnorm(runif(50, 0, .3)))
+z <- rbinom(4000, 1, pnorm(X %*% beta))
+
+y1 <- 240 - 5 - 80*x + rnorm(1000, 0, 5)
+y0 <- 240 - 80*x + rnorm(1000, 0, 5)
+y <- ifelse(z == 1, y1, y0)
+
+lm(y ~ z + state_mat)
+
+sum(z)
+
+

scratch/make_colinearity.R

@@ -0,0 +1,80 @@
+library(tidyverse)
+library(bartCause)
+
+set.seed(5)
+# create X
+n <- 500
+R <- matrix(nrow = 2, ncol = 2)
+diag(R) <- 1
+R[lower.tri(R)] <- c(.85)
+R[upper.tri(R)] <- t(R[lower.tri(R)])
+X <- MASS::mvrnorm(n, mu = c(0, 0), R)
+interact <- X[, 1]*X[, 2]
+X <- cbind(X, interact)
+#X <- apply(X, 2, function(i){(i*7) + 76})
+
+p.score <- vector(length = n)
+
+
+p.score <- pnorm(-1.4*X[, 1] + 1.4*X[, 2] + .2*X[,3])
+hist(p.score)
+
+
+
+
+
+z <- rbinom(n, 1, p.score)
+
+dat <- cbind.data.frame(X, z)
+
+# make y
+y0 <- 10 + cbind(rep(1, nrow(X)),X)%*%c(0, 0, 0, .6) + rnorm(n, 0, 1)
+y1 <- 10 + cbind(rep(1, nrow(X)),X)%*%c(0, 0, 0, .6) + -.25*sd(y0) + rnorm(n, 0, 1)
+y <- ifelse(z == 1, y1, y0)
+
+unscale <- function(x){
+  (x*10) + 150
+}
+
+X <- apply(X, 2, unscale)
+y <- unscale(y)
+y1 <- unscale(y1)
+y0 <- unscale(y0)
+hist(y)
+
+colnames(X)[1:2] <- c('qualify1', 'qualify2')
+colinearity <- data.frame(X[, 1:2], hyperShoe = z,Y0 = y0,Y1 = y1, Y = y)
+colinearity <- purrr::map_df(colinearity, function(x) round(x, 0))
+with(colinearity, mean(Y1 - Y0))
+
+readr::write_csv(colinearity, 'inst/extdata/colinearity.csv')
+
+summary(lm(Y ~ hyperShoe + qualify1 + qualify2, data = colinearity))
+
+# plots
+
+colinearity %>%
+  group_by(hyperShoe) %>%
+  summarise(mean(qualify1), mean(qualify2))
+
+
+ggplot(colinearity, aes(qualify2, fill = as.factor(hyperShoe))) +
+  geom_boxplot()
+
+
+ggplot(colinearity, aes(qualify1, qualify2)) +
+  geom_point() +
+  theme_bw() +
+  labs(title = 'Correlation of qualifying times = .85')
+
+ggsave('inst/app/www/learn/colinearity/plots/p1.png', device = 'png', height = 5, width = 8)
+
+
+
+both <- bartc(Y, hyperShoe, ., data = colinearity, seed = 2)
+one_only <- bartCause::bartc(Y, hyperShoe, qualify1, data = colinearity, seed = 2, method.trt = 'none')
+two_only <- bartCause::bartc(Y, hyperShoe, qualify2, data = colinearity, seed = 2, method.trt = 'none')
+estimates <- rbind(summary(both, 'cate')$estimates,
+                   summary(one_only, 'cate')$estimates,
+                   summary(two_only, 'cate')$estimates)
+estimates