diff --git a/.github/workflows/deploy-shinyapps-dev.yml b/.github/workflows/deploy-shinyapps-dev.yml index 6142a3db..021bdbaf 100644 --- a/.github/workflows/deploy-shinyapps-dev.yml +++ b/.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 diff --git a/.github/workflows/test-functions.yml b/.github/workflows/test-functions.yml index 1011dabc..f0b02a6d 100644 --- a/.github/workflows/test-functions.yml +++ b/.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(); diff --git a/.gitignore b/.gitignore index 9df8f964..0cbbf202 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,8 @@ .DS_Store .DS_store .ds_store -thinkCausal/rsconnect -thinkCausal-old/rsconnect +#thinkCausal/rsconnect +#thinkCausal-old/rsconnect *.html # vscode workspaces diff --git a/scratch/Ignorability_draft.R b/scratch/Ignorability_draft.R new file mode 100644 index 00000000..473367af --- /dev/null +++ b/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) + + diff --git a/scratch/make_colinearity.R b/scratch/make_colinearity.R new file mode 100644 index 00000000..b566110c --- /dev/null +++ b/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 diff --git a/scratch/make_estimands2.R b/scratch/make_estimands2.R new file mode 100644 index 00000000..252ceb30 --- /dev/null +++ b/scratch/make_estimands2.R @@ -0,0 +1,484 @@ +library(dplyr) +library(ggplot2) + +# make all the data +set.seed(2) +X <- runif(1000, 130, 200) +p.score <- ifelse(X < 200, pnorm(scale(X)*-.5), 0) +Z <- rbinom(1000, 1, p.score) +Z <- ifelse(X >=144.2, 0, Z) +scaleX <- 1.5 + as.vector(scale(X)) + + +Y0 <- 160 + scaleX*2 + (scaleX**2)*3 + rnorm(1000) +Y1 <- 160 + -5 + scaleX*2 + rnorm(1000) +Y <- ifelse(Z == 1, Y1, Y0) + +dat <- data.frame(X, scaleX, Y = Y, Z = Z, Y1 = Y1, Y0 = Y0) + +set.seed(2) +X <- runif(1000, 130, 200) +p.score <- ifelse(X < 200, pnorm(scale(X)*-.5), 0) +Z <- rbinom(1000, 1, p.score) +Z <- ifelse(X >=144.2, 0, Z) +scaleX <- 1.5 + as.vector(scale(X)) + + +Y0 <- 160 + scaleX*2 + (scaleX**2)*3 + rnorm(1000) +Y1 <- 160 + -5 + scaleX*2 + (scaleX**2)*3 + rnorm(1000) +Y <- ifelse(Z == 1, Y1, Y0) + +world1 <- data.frame(X, scaleX, Y = Y, Z = Z, Y1 = Y1, Y0 = Y0) + +set.seed(2) +X <- runif(1000, 130, 200) +p.score <- ifelse(X < 200, pnorm(scale(X)*-.5), 0) +Z <- rbinom(1000, 1, p.score) +Z <- ifelse(X >=144.2, 0, Z) +scaleX <- 1.5 + as.vector(scale(X)) + + +Y0 <- 160 + scaleX*2 + (scaleX**2)*3 + rnorm(1000) +Y1 <- 160 + -5 + scaleX*2 + rnorm(1000) +Y <- ifelse(Z == 1, Y1, Y0) + +world2 <- data.frame(X, scaleX, Y = Y, Z = Z, Y1 = Y1, Y0 = Y0) + +set.seed(2) +X <- runif(1000, 130, 200) +p.score <- ifelse(X < 200, pnorm(scale(X)*-.5), 0) +Z <- rbinom(1000, 1, p.score) +Z <- ifelse(X >=144.2, 0, Z) +scaleX <- 1.5 + as.vector(scale(X)) + + +Y0 <- 160 + scaleX*2 + (scaleX**2)*3 + rnorm(1000) +Y1 <- ifelse(X > 145, + 160 + -5 + scaleX*3 +(scaleX**2)*4.5 + rnorm(1000), + 160 + -5 + scaleX*2 + rnorm(1000) +) +Y <- ifelse(Z == 1, Y1, Y0) + +world3 <- data.frame(X, scaleX, Y = Y, Z = Z, Y1 = Y1, Y0 = Y0) + +p1 <- dat %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = 'Marathon Running Data', subtitle = 'The data from our hypothetical study') +p1 +ggsave('inst/app/www/learn/estimands2/plots/p1.png', device = 'png', height = 5, width = 8) + +p2 <- dat %>% + filter(Z == 1) %>% + add_row(Z = 0, X = 0, Y = 0, Y1 = 0, Y0 = 0, scaleX = 0) %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = 'Runners that wore HyperShoes') +p2 +ggsave('inst/app/www/learn/estimands2/plots/p2.png', device = 'png', height = 5, width = 8) + +p3 <- dat %>% + ggplot() + + geom_point(data = dat %>% filter(X<145), aes(X, Y, col = as.factor(Z))) + + geom_point(data = dat %>% filter(X>=145), aes(X, Y, col = as.factor(Z))) + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + + annotate("rect", xmin = 129.2, xmax = 146, ymin = 150, ymax = 165, + alpha = 0, color= "black") + +p3 +ggsave('inst/app/www/learn/estimands2/plots/p3.png', device = 'png', height = 5, width = 8) + + +# make table 1 +table1 <- dat %>% filter(Z == 1) %>% + select(X, Z, Y0, Y1, Y) %>% + mutate_all(~round(., 1)) %>% + mutate(Y0 = '?') + +readr::write_csv(table1, 'inst/extdata/estimands2_table1.csv') + + +p4 <- dat %>% + ggplot() + + geom_point(data = dat %>% filter(X<145), aes(X, Y, col = as.factor(Z))) + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z') + + annotate("rect", xmin = 129.2, xmax = 146, ymin = 150, ymax = 165, + alpha = 0, color= "black") + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + +p4 +ggsave('inst/app/www/learn/estimands2/plots/p4.png', device = 'png', height = 5, width = 8) + + +fit <- bartCause::bartc(Y, Z, X, data = dat, estimand = 'att') +y.cf <- bartCause::extract(fit, 'y.0') +dat %>% + filter(X < 145) + +p5 <- ggplot() + + geom_point(data = dat %>% filter(X < 145) , aes(X, Y, col = as.factor(Z))) + + scale_color_manual(values = c(4, 2)) + + geom_line(data = dat %>% filter(Z == 1) %>% mutate(y.cf =apply(y.cf, 2, mean)), + aes(X, y.cf), size = 1, col = 2) + + theme_bw() + + annotate("rect", xmin = 129.2, xmax = 146, ymin = 150, ymax = 165, + alpha = 0, color= "black") + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + +p5 +ggsave('inst/app/www/learn/estimands2/plots/p5.png', device = 'png', height = 5, width = 8) + + +p6 <- p1 +p6 +ggplot2::ggsave('inst/app/www/learn/estimands2/plots/p6.png', device = 'png', height = 5, width = 8) + + +p7 <- dat %>% + filter(Z == 0) %>% + add_row(Z = 1, X = 0, Y = 0, Y1 = 0, Y0 = 0, scaleX = 0) %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = 'Runners that did not wear HyperShoes', subtitle = 'What would have happened to these runners if they had worn HyperShoes?') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + +p7 +ggsave('inst/app/www/learn/estimands2/plots/p7.png', device = 'png', height = 5, width = 8) + + +table2 <- dat %>% filter(Z == 0) %>% + select(X, Z, Y0, Y1, Y) %>% + mutate_all(~round(., 1)) %>% + mutate(Y1 = '?') + +readr::write_csv(table2, 'inst/extdata/estimands2_table2.csv') + +p10 <- dat %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z') + + geom_text(aes(label = '???', x = 180, y = 165), col = 1, size = 6) + + geom_text(aes(label = '???', x = 190, y = 160), col = 1, size = 6) + + geom_text(aes(label = '???', x = 160, y = 157), col = 1, size = 6) + + geom_text(aes(label = '???', x = 160, y = 180), col = 1, size = 6) + + geom_text(aes(label = '???', x = 180, y = 190), col = 1, size = 6) + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + +p10 + +ggsave('inst/app/www/learn/estimands2/plots/p10.png', device = 'png', height = 5, width = 8) + +p11 <- ggplot() + theme_void() +p11 +ggsave('inst/app/www/learn/estimands2/plots/p11.png', device = 'png', height = 5, width = 8) + + +p12 <- ggplot() + + geom_point(data = world1, aes(X, Y, col = as.factor(Z))) + + geom_point(data = world1 %>% filter(X> max(world1$X[world1$Z == 1]), Z == 0), aes(X, Y1, col = as.factor(Z)), shape = 21, col = 2, alpha = .3) + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = 'HyperShoes work equally well for slower runners!') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + +p12 +ggsave('inst/app/www/learn/estimands2/plots/p12.png', device = 'png', height = 5, width = 8) + + +p13 <- ggplot() + + geom_point(data = world2, aes(X, Y, col = as.factor(Z))) + + geom_point(data = world2 %>% filter(X> max(world2$X[world3$Z == 1]), Z == 0), aes(X, Y1, col = as.factor(Z)), shape = 21, col = 2, alpha = .3) + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', + title = "HyperShoes work even better for slower runners!") + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + + +p13 + +ggsave('inst/app/www/learn/estimands2/plots/p13.png', device = 'png', height = 5, width = 8) + + +p14 <- ggplot() + + geom_point(data = world3, aes(X, Y, col = as.factor(Z))) + + geom_point(data = world3 %>% filter(X> max(world2$X[world3$Z == 1]), Z == 0), + aes(X, Y1, col = as.factor(Z)), shape = 21, col = 2, alpha = .3) + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = "HyperShoes make slower runners even slower!") + +p14 + +ggsave('inst/app/www/learn/estimands2/plots/p14.png', device = 'png', height = 5, width = 8) + + +p15 <- dat %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + + geom_text(aes(label = '???', x = 180, y = 165), col = 1, size = 6) + + geom_text(aes(label = '???', x = 190, y = 160), col = 1, size = 6) + + geom_text(aes(label = '???', x = 160, y = 157), col = 1, size = 6) + + geom_text(aes(label = '???', x = 160, y = 180), col = 1, size = 6) + + geom_text(aes(label = '???', x = 180, y = 190), col = 1, size = 6) + +p15 +ggsave('inst/app/www/learn/estimands2/plots/p15.png', device = 'png', height = 5, width = 8) + + +p16 <- p1 +p16 +ggplot2::ggsave('inst/app/www/learn/estimands2/plots/p16.png', device = 'png', height = 5, width = 8) + +p17 <- ggplot() + theme_void() +p17 +ggsave('inst/app/www/learn/estimands2/plots/p17.png', device = 'png', height = 5, width = 8) + +p18 <- dat %>% + filter(Z == 1) %>% + add_row(Z = 0, X = 0, Y = 0, Y1 = 0, Y0 = 0, scaleX = 0) %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = 'Runners that wore HyperShoes', subtitle = 'What would have happened to these runners if they did not wear HyperShoes?') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) +p18 +ggsave('inst/app/www/learn/estimands2/plots/p18.png', device = 'png', height = 5, width = 8) + +p19 <- dat %>% + filter(Z == 0) %>% + add_row(Z = 1, X = 0, Y = 0, Y1 = 0, Y0 = 0, scaleX = 0) %>% + ggplot(aes(X, Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2)) + + theme_bw() + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color ='Z', title = 'Runners that did not wear HyperShoes', subtitle = 'What would have happened to these runners if they wore HyperShoes?') + + coord_cartesian(ylim = c(150, 199), xlim = c(129, 200)) + +p19 +ggsave('inst/app/www/learn/estimands2/plots/p19.png', device = 'png', height = 5, width = 8) + + +table3 <- dat %>% + select(X, Z, Y0, Y1, Y) %>% + mutate_all(~round(., 1)) %>% + mutate(Y0 = ifelse(Z == 1, '?', Y0), + Y1 = ifelse(Z == 1, Y1, '?')) + +readr::write_csv(table3, 'inst/extdata/estimands2_table3.csv') + + +# quiz plots +N <- 750 + +X <- rnorm(N, 35, 10) +X <- X[X > 18 & X < 55] + +dat <- data.frame(age = X, scaled_age = scale(X)) + +#beta.z <-c(-1) +asn_z <- function(x){ + if(x <= 30){ + rbinom(1, 1, .77) + } + + else{rbinom(1, 1, .4)} +} + +dat$z <- sapply(X, asn_z) + + + +dat$y1 <- with(dat, + 180 -7 +.5*scaled_age + I((scaled_age-.1)^2)*2 + rnorm(nrow(dat)) +) + +dat$true.1 <- with(dat, + 180 -7 +.5*scaled_age + I((scaled_age-.1)^2)*2 +) + +dat$y0 <- with(dat, + 176 +.5*scaled_age + I((scaled_age+.3)^2)*3.2 + rnorm(nrow(dat)) +) + +dat$true.0 <- with(dat, + 176 +.5*scaled_age + I((scaled_age+.3)^2)*3.2 +) + +dat$y <- ifelse(dat$z ==1, dat$y1, dat$y0) + +dat %>% + filter(scaled_age < 2.1) %>% + ggplot(aes(scaled_age, y, col = as.factor(z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + + theme_bw() + + labs(color = NULL, x = 'X the single confounder',y = 'Outcome Y') + +ggsave('inst/app/www/learn/estimands2/plots/quiz1.png', device = 'png', height = 5, width = 8) + + +# quiz question 2 +N <- 750 + +X <- rnorm(N, 35, 10) +X <- X[X > 18 & X < 55] + +dat <- data.frame(age = X, scaled_age = scale(X)) + +#beta.z <-c(-1) +asn_z <- function(x){ + if(x <= 30){ + rbinom(1, 1, .73) + } + + else{rbinom(1, 1, .4)} +} + +dat$z <- sapply(X, asn_z) + + + +dat$y1 <- with(dat, + 180 -10 +2*scaled_age + rnorm(nrow(dat)) +) + + +dat$y0 <- with(dat, + 176 +.5*scaled_age + I((scaled_age+.3)^2)*1.3 + rnorm(nrow(dat)) +) + + + +dat$y <- ifelse(dat$z ==1, dat$y1, dat$y0) + +dat %>% + filter(scaled_age > .3 & scaled_age < 1.5 | z == 1) %>% + ggplot(aes(scaled_age, y, col = as.factor(z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + + theme_bw() + + labs(color = NULL, x = 'X the single confounder',y = 'Outcome Y') + +ggsave('inst/app/www/learn/estimands2/plots/quiz2.png', device = 'png', height = 5, width = 8) + + +# quiz question 3 +N <- 750 + +X <- rnorm(N, 35, 10) +X <- X[X > 18 & X < 55] + +dat <- data.frame(age = X, scaled_age = scale(X)) + +#beta.z <-c(-1) +asn_z <- function(x){ + if(x <= 30){ + rbinom(1, 1, .6) + } + + else{rbinom(1, 1, .4)} +} + +dat$z <- sapply(X, asn_z) + + + +dat$y1 <- with(dat, + 180 -10 +.5*scaled_age + I((scaled_age-.1)^2)*2 + rnorm(nrow(dat)) +) + + +dat$y0 <- with(dat, + 176 +.5*scaled_age + I((scaled_age+.3)^2)*1.3 + rnorm(nrow(dat)) +) + + +dat$y <- ifelse(dat$z ==1, dat$y1, dat$y0) + +dat %>% + filter(scaled_age <.3 | z == 0) %>% + ggplot(aes(scaled_age, y, col = as.factor(z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + + theme_bw() + + labs(color = NULL, x = 'X the single confounder',y = 'Outcome Y') + +ggsave('inst/app/www/learn/estimands2/plots/quiz3.png', device = 'png', height = 5, width = 8) + + +z <- rbinom(500, 1, .5) +X1 <- rnorm(500, 20, 10) +X1 <- ifelse(X1<0, 0, X1) +X0 <- rnorm(500, 40, 10) +X0 <- ifelse(X0>60, 60, X0) +X0 <- ifelse(X0 <0, 0, X0) +X <- ifelse(z==1, X1, X0) +y1 <- rnorm(500, 72 + 3*sqrt(X1), 1) +y0 <- rnorm(500, 90 + exp((.06*X0)), 1) +y <- ifelse(z==1, y1, y0) +dat <- data.frame(X1, X0, X, y1, y0, y, z) + +ggplot(dat %>% filter(X<31 | z == 0) %>% mutate(y= y + 70), aes(X, y, col = as.factor(z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + + theme_bw() + + labs(col = NULL) + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color = NULL) + +ggsave('inst/app/www/learn/estimands2/plots/partial_overlap.png', device = 'png', height = 5, width = 8) + + +ggplot(dat %>% filter(X<31 | z == 0) %>% mutate(y= y + 70), aes(X, y, col = as.factor(z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + + theme_bw() + + annotate("rect", xmin = 12, xmax = 32, ymin = 150, ymax = 170, + alpha = 0, color= "black") + + labs(col = NULL) + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color = NULL) + + +# +# ggplot(dat %>% filter(X > 8& X<31 | z == 0) %>% mutate(y= y + 70), aes(X, y, col = as.factor(z))) + +# geom_point() + +# scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + +# annotate('rect', xmin=-Inf, xmax=min(X[z == 0])-.5, ymin=-Inf, ymax=Inf, alpha=.2, fill='red') + +# theme_bw() + +# labs(col = NULL) + +# labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color = NULL) +# + +dat %>% filter(X <23 | z == 0) %>% mutate(y= y + 70) %>% + filter(X>40|z == 1) %>% + ggplot(aes(X, y, col = as.factor(z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('control', 'treated')) + + #annotate('rect', xmin= 30+ .7, xmax=Inf, ymin=-Inf, ymax=Inf, alpha=.2, fill='blue') + + # annotate('rect', xmin=-Inf, xmax=min(X[z == 0])-.5, ymin=-Inf, ymax=Inf, alpha=.2, fill='red') + + theme_bw() + + labs(col = NULL) + + labs(x = 'Single confounder X', y = 'Outcome Y (running times)', color = NULL) + +ggsave('inst/app/www/learn/estimands2/plots/no_overlap.png', device = 'png', height = 5, width = 8) diff --git a/scratch/make_fundemental.R b/scratch/make_fundemental.R new file mode 100644 index 00000000..0cf620fb --- /dev/null +++ b/scratch/make_fundemental.R @@ -0,0 +1,683 @@ +#library(tidyverse) +library(ggrepel) +library(ggdark) +library(ggplot2) +library(tidyr) +library(dplyr) + +set.seed(62) +n <- 20 +prior_race <- sample(c(0, 1, 2, 3), n, replace = T) + +dat <- data.frame(prior_race) + +for (i in 0:max(prior_race)) { + dat[,i + 2] <- ifelse(dat$prior_race == i, 1, 0) + names(dat)[i + 2] <- paste0('prior_race', i) +} + + +dat <- dat[, 2:length(dat)] +Y1 <- as.matrix(cbind(rep(1, nrow(dat)), dat)) %*% c(230, 40, 40, 20, -5) +Y0 <- as.matrix(cbind(rep(1, nrow(dat)), dat)) %*% c(235, 45, 45, 25, 15) + +Y1 <- round(Y1 + rnorm(n, 0, 2.5), 0) +Y0 <- round(Y0 + rnorm(n, 0, 2.5), 0) +Y1[Y1 == 223] <- 224 +Y0[17] <- 279 + +Z <- rbinom(n, 1, .5) +Y <- ifelse(Z == 1, Y1, Y0) +fit <- lm(Y ~ Z*as.factor(prior_race)) +imputed <- predict(fit) + +Zcf <- abs(Z - 1) +cf_dat <- data.frame(Z = Zcf, prior_race) +imputed_cf <- predict(fit, newdata = cf_dat) +ite_true <- c(Y1 - Y0) +ite_est <- ifelse(Z == 1, c(Y1), imputed_cf) - ifelse(Z == 0, c(Y0), imputed_cf) + +tibble(ite_true, ite_est, runner = 1:20) %>% + pivot_longer(1:2) %>% + ggplot(aes(as.factor(runner), value, col = name, shape = name, size = name)) + + scale_shape_manual(values = c(19, 21), guide = 'none') + + scale_size_manual(values = c(1, 1.5), guide = 'none') + + scale_color_manual(values = c('purple', 'white'), + labels = c('estimated ITE', 'true ITE'), + guide = guide_legend( + override.aes = list(shape = c(19, 21)) + ) + ) + + geom_point() + + coord_cartesian(ylim = c(-35, -5)) + + labs(color = NULL, x = 'runner', y = 'Individual Treatment Effect (ITE)') + + dark_theme_grey() + + +ggsave('inst/app/www/learn/fundemental/plots/cf1.png', device = 'png', height = 5, width = 8) + + + +tibble(ite_true, ite_est, runner = 1:20) %>% + pivot_longer(1:2) %>% + ggplot(aes(as.factor(runner), value, col = name, shape = name, size = name)) + + scale_shape_manual(values = c(19, 21), guide = 'none') + + scale_size_manual(values = c(1, 1.5), guide = 'none') + + geom_hline(aes(yintercept = mean(ite_true), linetype = 'true ATE = -12.75'), col = 'white') + + geom_hline(aes(yintercept = mean(ite_est), linetype = 'estimated ATE = -12.14'), col = 'purple') + + scale_color_manual(values = c('purple', 'white'), + labels = c('estimated ITE', 'true ITE'), + guide = guide_legend( + override.aes = list(shape = c(19, 21)) + ) + ) + + geom_point() + + scale_linetype_manual(values = c(1, 2), + guide = guide_legend( + override.aes = list( + linetype = c(1, 2), + color = c('purple', 'white') + )) + )+ + coord_cartesian(ylim = c(-35, -5)) + + labs(linetype = NULL, col = NULL, x = 'runner', y = 'Individual Treatment Effect (ITE)') + + dark_theme_grey() +ggsave('inst/app/www/learn/fundemental/plots/cf2.png', device = 'png', height = 5, width = 8) + + + +tibble(ite_true, ite_est, runner = 1:20) %>% + pivot_longer(1:2) %>% + ggplot(aes(value, fill = name)) + + geom_histogram(bins = 12, position = 'identity', col = 'black', alpha = .6) + + geom_vline(aes(xintercept = mean(ite_true), col = 'true ATE = -12.75')) + + geom_vline(aes(xintercept = mean(ite_est), col = 'estimated ATE = -12.14')) + + scale_color_manual(values = c('purple', 'white')) + + scale_fill_manual(values = c('purple', 'white'), labels = c('estimated ITE', 'True')) + + dark_theme_gray() + + + + + +data.frame(Y, prior_race, Z) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Observed Data') + + theme_bw() + + +ggsave('inst/app/www/learn/fundemental/plots/p1.png', device = 'png', height = 5, width = 8) + + +data.frame(Y, prior_race, Z) %>% + filter(prior_race == 0) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + scale_x_discrete(limits = c('0', '1', '2', '3')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Observed Data') + + theme_bw() + + +ggsave('inst/app/www/learn/fundemental/plots/p2.png', device = 'png', height = 5, width = 8) + + +data.frame(Y, prior_race, Z,Y0) %>% + filter(prior_race == 0) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + geom_segment(x = .5, xend = 1.5, y = round(imputed[Z == 0 & prior_race == 0][1],0), yend = round(imputed[Z == 0 & prior_race == 0][1],0), aes(linetype = 'Average Y0 = 281'), col = 4) + + scale_x_discrete(limits = c('0', '1', '2', '3')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Using Information from Observed Y0s', + subtitle = 'average of observed Y0 for runners with 0 prior races = 281', + linetype = NULL + ) + + theme_bw() +ggsave('inst/app/www/learn/fundemental/plots/p3.png', device = 'png', height = 5, width = 8) + + +data.frame(Y, prior_race, Z,Y1) %>% + filter(prior_race == 0) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + geom_segment(aes(linetype = 'Average Y1 = 270'), + x = .5, xend = 1.5, + y = round(imputed[Z == 1 & prior_race == 0][1],0), yend = round(imputed[Z == 1 & prior_race == 0][1],0), + col = 2) + + scale_x_discrete(limits = c('0', '1', '2', '3')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Using Information from Observed Y1s', + subtitle = 'average of observed Y1 for runners with 0 prior races = 270', + linetype = NULL + ) + + theme_bw() +ggsave('inst/app/www/learn/fundemental/plots/p4.png', device = 'png', height = 5, width = 8) + + +data.frame(Y, prior_race, Z,Y1, Y0) %>% + filter(prior_race == 1) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + geom_segment(aes(linetype = 'Average Y1'), + x = 1.5, xend = 2.5, + y = round(imputed[Z == 1 & prior_race == 1][1],0), yend = round(imputed[Z == 1 & prior_race == 1][1],0), + col = 2) + + geom_segment(aes(linetype = 'Average Y0'), + x = 1.5, xend = 2.5, + y = round(imputed[Z == 0 & prior_race == 1][1],0), yend = round(imputed[Z == 0 & prior_race == 1][1],0), + col = 4) + + scale_linetype_manual(values = c(1, 1), + labels = c(paste(round(imputed[Z == 0 & prior_race == 1][1],1)), paste(round(imputed[Z == 1 & prior_race == 1][1],1))), + guide = guide_legend( + override.aes = list( + linetype = c(1, 1), + color = c(4, 2) + )) + ) + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + scale_x_discrete(limits = c('0', '1', '2', '3')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Runners with 1 prior race', + subtitle = 'average of observed Y0 = 280\naverage of observed Y1 = 273', + linetype = NULL + ) + + theme_bw() + +ggsave('inst/app/www/learn/fundemental/plots/p5.png', device = 'png', height = 5, width = 8) + + +p6 <- data.frame(Y, prior_race, Z,Y1, Y0) %>% + filter(prior_race == 2) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + geom_segment(aes(linetype = 'Average Y1'), + x = 2.5, xend = 3.5, + y = round(imputed[Z == 1 & prior_race == 2][1],0), yend = round(imputed[Z == 1 & prior_race == 2][1],0), + col = 2) + + geom_segment(aes(linetype = 'Average Y0'), + x = 2.5, xend = 3.5, + y = round(imputed[Z == 0 & prior_race == 2][1],0), yend = round(imputed[Z == 0 & prior_race == 2][1],0), + col = 4) + + scale_linetype_manual(values = c(1, 1), + labels = c(paste(round(imputed[Z == 0 & prior_race == 2][1],0)), + paste(round(imputed[Z == 1 & prior_race == 2][1],0))), + guide = guide_legend( + override.aes = list( + linetype = c(1, 1), + color = c(4, 2) + )) + ) + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + scale_x_discrete(limits = c('0', '1', '2', '3')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Runners with 2 prior race', + subtitle = paste(paste('Average observed Y0 =', round(imputed[Z == 0 & prior_race == 2][1],0)), + paste('Average observed Y1 =',round(imputed[Z == 1 & prior_race == 2][1],0)), sep = '\n'), + linetype = NULL + ) + + theme_bw() + +p6 +readr::write_rds(p6, 'inst/app/www/learn/fundemental/plots/p6.rds') + +ggsave('inst/app/www/learn/fundemental/plots/p6.png', device = 'png', height = 5, width = 8) + + + +p7 <- data.frame(Y, prior_race, Z,Y1, Y0) %>% + filter(prior_race == 3) %>% + ggplot(aes(as.factor(prior_race), Y, col = as.factor(Z))) + + geom_point() + + geom_segment(aes(linetype = 'Average Y1'), + x = 3.5, xend = 4.5, + y = round(imputed[Z == 1 & prior_race == 3][1],0), yend = round(imputed[Z == 1 & prior_race == 3][1],0), + col = 2) + + geom_segment(aes(linetype = 'Average Y0'), + x = 3.5, xend = 4.5, + y = round(imputed[Z == 0 & prior_race == 3][1],0), yend = round(imputed[Z == 0 & prior_race == 3][1],0), + col = 4) + + scale_linetype_manual(values = c(1, 1), + labels = c(paste(round(imputed[Z == 0 & prior_race == 3][1],0)), + paste(round(imputed[Z == 1 & prior_race == 3][1],0))), + guide = guide_legend( + override.aes = list( + linetype = c(1, 1), + color = c(4, 2) + )) + ) + + scale_color_manual(values = c(4, 2), labels = c('no hyperShoe', 'hyperShoe')) + + scale_x_discrete(limits = c('0', '1', '2', '3')) + + labs(x = 'number of prior races', + y = 'observed running time (Y)', + color = NULL, + title = 'Runners with 3 prior race', + subtitle = paste(paste('Average observed Y0 =', round(imputed[Z == 0 & prior_race == 3][1],0)), + paste('Average observed Y1 =',round(imputed[Z == 1 & prior_race == 3][1],0)), sep = '\n'), + linetype = NULL + ) + + theme_bw() +p7 +readr::write_rds(p7, 'inst/app/www/learn/fundemental/plots/p7.rds') + +ggsave('inst/app/www/learn/fundemental/plots/p7.png', device = 'png', height = 5, width = 8) + +truth <- tibble(runner = 1:20, prior_race, Z, Y0, Y1, Y) %>% + rename(hyperShoe = Z, + `prior races` = prior_race) %>% + map_df(., function(x){round(x, 0)}) + +truth <- apply(truth, 2, as.vector) +truth <- as.data.frame(truth) + +write_csv(truth, '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/truth.csv') + + +table1 <- tibble(runner = 1:20, prior_race, Z, Y0, Y1, Y) %>% + rename(hyperShoe = Z, + `prior races` = prior_race) %>% + map_df(., function(x){round(x, 0)}) %>% + mutate(Y0 = ifelse(hyperShoe == 1, NA, Y0), + Y1 = ifelse(hyperShoe == 0, NA, Y1)) + +write_csv(table1, '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/fundamental_table1.csv') + +table2 <- table1 +table2$Y0[is.na(table2$Y0)] <- round(predict(fit, newdata = cf_dat), 0)[is.na(table2$Y0)] +table2$Y1[is.na(table2$Y1)] <- round(predict(fit, newdata = cf_dat), 0)[is.na(table2$Y1)] +readr::write_csv(table2, '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/fundamental_table2.csv') + + +table2 %>% + mutate(ITE = Y1 - Y0) %>% + summarise(mean(ITE + )) + + + + +# set.seed(21) +# Y1 <- floor(250 - 5 + rnorm(10, 0, 2)) +# Y0 <- floor(250 + rnorm(10, 0, 2)) +# +# dat.nf <- data.frame(runner = 1:10, `first race` = 'no', Y0, Y1) +# +# Y1 <- floor(265 - 5 + rnorm(20, 0, 2)) +# Y0 <- floor(265 + rnorm(20, 0, 2)) +# +# +# dat.f<- data.frame(runner = 11:30, `first race` = 'yes', Y0, Y1) +# +# dat <- rbind(dat.nf, dat.f) +# dat$Z <- rbinom(30, 1, .5) +# dat$Y <- ifelse(dat$Z == 1, dat$Y1, dat$Y0) +# +# dat <- dat[sample(1:nrow(dat), nrow(dat)), ] +# dat$runner <- 1:nrow(dat) +# rownames(dat) <- 1:nrow(dat) +# hold <- dat[2,] +# dat[2,] <- dat[23,] +# dat[23,] <- hold +# rownames(dat) <- 1:nrow(dat) +# dat$runner <- 1:nrow(dat) +# table1 <- dat %>% select(-first.race) %>% select(runner, Z, Y0, Y1, Y) %>% rename(`hyperShoe` = Z) +# +# write_csv(table1, '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/fundamental_table1.csv') +# +# +# write_csv(table1[1,], '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/fundamental_table2.csv') +# +# +# dat[1, ] %>% +# pivot_longer(cols = c(Y0, Y1)) %>% +# mutate(cf = ifelse(Z != str_sub(name, -1), T, F)) %>% +# filter(name == 'Y1') %>% +# ggplot(aes(name, value, col = name, label = runner)) + +# geom_point(aes(shape = cf)) + +# scale_shape_manual(values = c(19, 21), labels = c('observed', 'counterfactual')) + +# scale_x_discrete(limits = c('Y0', 'Y1')) + +# coord_cartesian(ylim = c(240, 270)) + +# geom_text_repel(show.legend = FALSE, seed = 4) + +# scale_color_manual(values = c(2)) + +# theme_bw() + +# labs(x = 'Potential Outcomes', col = NULL, y = 'Running Time', title = 'Runner 1', subtitle = 'observed outcome', shape = NULL) +# +# ggsave('inst/app/www/learn/fundemental/plots/p1.png', device = 'png', height = 5, width = 8) +# +# +# +# +# dat[1, ] %>% +# pivot_longer(cols = c(Y0, Y1)) %>% +# mutate(cf = ifelse(Z != str_sub(name, -1), T, F)) %>% +# ggplot(aes(name, value, col = name, label = runner)) + +# geom_point(aes(shape = cf)) + +# scale_shape_manual(values = c(19, 21), labels = c('observed', 'counterfactual')) + +# geom_text_repel(show.legend = FALSE, seed = 4) + +# scale_color_manual(values = c(4, 2)) + +# coord_cartesian(ylim = c(240, 270)) + +# theme_bw() + +# labs(x = 'Potential Outcomes', col = NULL, y = 'Running Time', title = 'Runner 1', subtitle = 'observed and counter-factual outcomes', shape = NULL) +# +# ggsave('inst/app/www/learn/fundemental/plots/p2.png', device = 'png', height = 5, width = 8) +# +# +# +# dat[1:2, ] %>% +# pivot_longer(cols = c(Y0, Y1)) %>% +# slice(c(1,2,3)) %>% +# mutate(cf = ifelse(Z != str_sub(name, -1), T, F)) %>% +# ggplot(aes(name, value, col = name, label = runner)) + +# geom_point(aes(shape = cf)) + +# scale_shape_manual(values = c(19, 21), labels = c('observed', 'counterfactual')) + +# geom_text_repel(show.legend = FALSE, seed = 4) + +# scale_color_manual(values = c(4, 2)) + +# coord_cartesian(ylim = c(240, 270)) + +# theme_bw() + +# labs(x = 'Potential Outcomes', col = NULL, y = 'Running Time', title = 'Runners 1 & 2',subtitle = "consider runner 2's observed outcome", shape = NULL) +# +# ggsave('inst/app/www/learn/fundemental/plots/p3.png', device = 'png', height = 5, width = 8) +# +# +# dat[1:2, ] %>% +# pivot_longer(cols = c(Y0, Y1)) %>% +# mutate(cf = ifelse(Z != str_sub(name, -1), T, F)) %>% +# ggplot(aes(name, value, col = name, label = runner)) + +# geom_point(aes(shape = cf)) + +# scale_shape_manual(values = c(19, 21), labels = c('observed', 'counterfactual')) + +# geom_text_repel(show.legend = FALSE, seed = 4) + +# scale_color_manual(values = c(4, 2)) + +# coord_cartesian(ylim = c(240, 270)) + +# theme_bw() + +# labs(x = 'Potential Outcomes', col = NULL, y = 'Running Time', title = 'Runners 1 & 2',subtitle = 'observed and counter-factual outcomes', shape = NULL) +# +# ggsave('inst/app/www/learn/fundemental/plots/p4.png', device = 'png', height = 5, width = 8) +# +# +# pj <- position_jitter(width = .25, height = .45, seed = 23) +# +# dat %>% +# pivot_longer(cols = c(Y0, Y1)) %>% +# mutate(cf = ifelse(Z != str_sub(name, -1), T, F)) %>% +# ggplot(aes(name, value, col = name, label = runner)) + +# geom_point(aes(shape = cf), position = pj) + +# scale_shape_manual(values = c(21, 19), labels = c('counterfactual', 'observed')) + +# scale_color_manual(values = c(4, 2)) + +# coord_cartesian(ylim = c(240, 270)) + +# theme_bw() + +# labs(x = 'Potential Outcomes', col = NULL, y = 'Running Time', title = "All Runners 'Jittered'", subtitle = 'observed and counterfactual outcomes', shape = NULL) +# +# +# ggsave('inst/app/www/learn/fundemental/plots/p5.png', device = 'png', height = 5, width = 8) +# +# Y1 <- dat$Y1 +# Y0 <- dat$Y0 +# dat %>% +# pivot_longer(cols = c(Y0, Y1)) %>% +# mutate(cf = ifelse(Z != str_sub(name, -1), T, F)) %>% +# ggplot(aes(name, value, col = name, label = runner)) + +# geom_point(aes(shape = cf), position = pj) + +# geom_segment(aes( x = 1.7, xend = 2.3, y = round(mean(Y1), 0), yend = round(mean(Y1), 0)), col = 1, linetype = 2) + +# geom_segment(aes( x = 0.7, xend = 1.3, y = mean(Y0), yend = mean(Y0)), col = 1, linetype = 2) + +# scale_color_manual(values = c(4, 2)) + +# scale_shape_manual(values = c(21, 19), labels = c('counterfactual Y', 'observed Y')) + +# theme_bw() + +# coord_cartesian(ylim = c(240, 270)) + +# annotate( +# geom = "curve", x = .65, y = 257, xend = .68, yend = 260, +# curvature = -.8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 1, y = 257, label = "average Y0 = 260", hjust = "center", size = 3.5) + +# annotate( +# geom = "curve", x = 2.35, y = 252, xend = 2.32, yend = 255, +# curvature = .8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 2, y = 252, label = "average Y1 = 255", hjust = "center", size = 3.5) + +# +# labs(shape = NULL, color = NULL) + +# labs(x = 'Potential Outcomes', col = NULL, y = 'Running Time', title = "True ATE = -5", subtitle = 'ATE = the average Y1 - the average Y0', shape = NULL) +# +# +# ggsave('inst/app/www/learn/fundemental/plots/p6.png', device = 'png', height = 5, width = 8) +# +# +# +# +# dat %>% +# ggplot(aes(as.factor(Z), Y, col = as.factor(Z))) + +# geom_point(position = pj) + +# scale_color_manual(values = c(4, 2), labels = c('No hyperShoe', 'hyperShoe')) + +# scale_x_discrete(labels = c('No hyperShoe (observed Y0)', 'hyperShoe (observed Y1)')) + +# theme_bw() + +# coord_cartesian(ylim = c(240, 270)) + +# labs(x = NULL, y = 'Running time', col = NULL, title = 'Observed outcomes only') +# +# ggsave('inst/app/www/learn/fundemental/plots/p7.png', device = 'png', height = 5, width = 8) +# +# +# dat2 <- table1 +# dat2$Y1 <- as.character(dat2$Y1) +# dat2$Y0 <- as.character(dat2$Y0) +# dat2 <- dat2 %>% mutate(Y1 = ifelse(hyperShoe == 1, Y1, NA), +# Y0 = ifelse(hyperShoe == 0, Y0, NA)) +# +# +# write_csv(dat2, '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/fundemental_table3.csv') +# +# +# dat %>% +# ggplot(aes(as.factor(Z), Y, col = as.factor(Z))) + +# geom_point(position = pj) + +# geom_segment(aes( x = 1.7, xend = 2.3, y = round(mean(Y[Z == 1]), 0), yend = round(mean(Y[Z == 1]), 0)), col = 1, linetype = 1) + +# geom_segment(aes( x = 0.7, xend = 1.3, y = round(mean(Y[Z == 0]), 0), yend = round(mean(Y[Z == 0]), 0)), col = 1, linetype = 1) + +# scale_color_manual(values = c(4, 2), labels = c('No hyperShoe', 'hyperShoe')) + +# scale_x_discrete(labels = c('No hyperShoe (Observed Y0)', 'hyperShoe (Observed Y1)')) + +# theme_bw() + +# labs(x = NULL, y = 'Running time', col = NULL, title = 'Averages of Observed Y0 and Observed Y1') + +# annotate( +# geom = "curve", x = .65, y = 260, xend = .68, yend = 258, +# curvature = .8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 1, y = 260.5, label = "average observed Y0 = 258", hjust = "center", size = 3.5) + +# annotate( +# geom = "curve", x = 2.35, y = 254, xend = 2.32, yend = 256, +# curvature = .8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 2, y = 253.5, label = "average observed Y1 = 256", hjust = "center", size = 3.5) + +# coord_cartesian(ylim = c(240, 270)) +# +# +# ggsave('inst/app/www/learn/fundemental/plots/p8.png', device = 'png', height = 5, width = 8) +# +# +# dat3 <- dat +# dat3 <- dat3 %>% mutate(Y1 = ifelse(Z == 1, Y1, 256), +# Y0 = ifelse(Z == 0, Y0, 258)) +# dat3 <- dat3 %>% mutate(ITE = Y1 - Y0) +# dat3 <- dat3 %>% select(runner, first.race, Z, Y0, Y1, Y, ITE) +# +# +# write_csv(dat3 %>% select(1:6) %>% rename(hyperShoe = Z), '~/Dropbox/thinkCausal_dev/thinkCausal/inst/extdata/fundemental_table4.csv') +# +# +# +# dat3$ITE_true <- with(dat, Y1 - Y0) +# +# dat3 %>% +# ggplot(aes(runner, ITE, label = runner)) + +# geom_point() + +# geom_text_repel(show.legend = FALSE, seed = 4, size = 3) + +# annotate( +# geom = "curve", x = 2, y = 8.5, xend = 2, yend = 10.5, +# curvature = 0, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 6, y = 8, label = "predicted treatment effect of 11", hjust = "center", size = 3) + +# annotate( +# geom = "curve", x = 4, y = -10.5, xend = 4, yend = -12.5, +# curvature = 0, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 8, y = -10, label = "predicted treatment effect of -13", hjust = "center", size = 3) + +# theme_bw() + +# theme(legend.position = 'top', legend.justification='left') + +# labs(x = 'Runner ID', y = 'Predicted Causal Effect of hyperShoes', linetype = NULL, title = 'Estimated Causal Effects') +# ggsave('inst/app/www/learn/fundemental/plots/p9.png', device = 'png', height = 5, width = 8) +# +# +# dat3 %>% +# pivot_longer(contains('ITE')) %>% +# ggplot(aes(runner, value, col = name, shape = name)) + +# scale_color_manual(values = c(1, 6), labels = c('Predicted Causal Effect', 'True Causal Effect')) + +# scale_shape_manual(values = c(19, 21), labels = c('Predicted Causal Effect', 'True Causal Effect')) + +# geom_line(aes(group = runner,linetype = 'bias'), col = 'dark grey') + +# scale_linetype_manual(values = 2) + +# geom_point() + +# #geom_hline(aes(yintercept = mean(value), col = name)) + +# #geom_hline(yintercept = mean(dat3$ITE)) + +# #geom_hline(yintercept = mean(dat3$ITE_true), col = 6, linetype = 2) + +# theme_bw() + +# theme(legend.position = 'top', legend.justification = 'left') + +# labs(col = NULL, shape = NULL, linetype = NULL, x = 'Runner ID') +# ggsave('inst/app/www/learn/fundemental/plots/p10.png', device = 'png', height = 5, width = 8) +# +# +# dat3 %>% +# pivot_longer(contains('ITE')) %>% +# ggplot(aes(value, fill = name)) + +# geom_histogram(col = 'black') + +# facet_wrap(~name, ncol = 1) + +# theme_bw() +# +# +# +# dat %>% +# ggplot(aes(as.factor(Z), Y, col = as.factor(Z), shape = first.race)) + +# geom_point(position = pj) + +# scale_color_manual(values = c(4, 2), labels = c('No hyperShoe', 'hyperShoe')) + +# scale_shape_manual(values = c(4, 19)) + +# scale_x_discrete(labels = c('No hyperShoe (Observed Y0)', 'hyperShoe (Observed Y1)')) + +# theme_bw() + +# coord_cartesian(ylim = c(240, 270)) + +# labs(x = NULL, y = 'Running time', col = NULL, title = 'Averages of Observed Y1 and Observed Y0') +# +# ggsave('inst/app/www/learn/fundemental/plots/p11.png', device = 'png', height = 5, width = 8) +# +# +# +# dat %>% +# group_by(first.race, Z) %>% +# summarise(mean(Y)) +# +# dat %>% +# ggplot(aes(as.factor(Z), Y, col = as.factor(Z), shape = first.race)) + +# geom_point(position = pj) + +# geom_segment(aes( x = 1.7, xend = 2.3, y = round(mean(Y[Z == 1& first.race == 'yes']), 0), yend = round(mean(Y[Z == 1 & first.race == 'yes']), 0)), col = 1, linetype = 1) + +# geom_segment(aes( x = 0.7, xend = 1.3, y = round(mean(Y[Z == 0 & first.race == 'yes']), 0), yend = round(mean(Y[Z == 0 & first.race == 'yes']), 0)), col = 1, linetype = 1) + +# annotate( +# geom = "curve", x = .65, y = 269.5, xend = .65, yend = 265, +# curvature = .8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 1, y = 270, label = "average observed Y0 = 265", hjust = "center", size = 3) + +# annotate( +# geom = "curve", x = 2.35, y = 263.5, xend = 2.35, yend = 260, +# curvature = -.8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 2, y = 264, label = "average observed Y1 = 260", hjust = "center", size = 3) + +# annotate( +# geom = "curve", x = .65, y = 248, xend = .65, yend = 250, +# curvature = -.8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 1, y = 247.5, label = "average observed Y0 = 250", hjust = "center", size = 3) + +# annotate( +# geom = "curve", x = 2.35, y = 242.5, xend = 2.35, yend = 245, +# curvature = .8, arrow = arrow(length = unit(2, "mm")) +# ) + +# annotate(geom = "text", x = 2, y = 242, label = "average observed Y1 = 245", hjust = "center", size = 3) + +# geom_segment(aes( x = 1.7, xend = 2.3, y = mean(Y[Z == 1 & first.race == 'no']), yend = mean(Y[Z == 1 & first.race == 'no'])), col = 1, linetype = 1) + +# geom_segment(aes( x = 0.7, xend = 1.3, y = mean(Y[Z == 0 & first.race == 'no']), yend = mean(Y[Z == 0 & first.race == 'no'])), col = 1, linetype = 1) + +# scale_color_manual(values = c(4, 2), labels = c('No hyperShoe', 'hyperShoe')) + +# scale_shape_manual(values = c(17, 19)) + +# scale_x_discrete(labels = c('No hyperShoe (Observed Y0)', 'hyperShoe (Observed Y1)')) + +# theme_bw() + +# coord_cartesian(ylim = c(240, 270)) + +# labs(x = NULL, y = 'Running time', col = NULL, title = 'Averages of Observed Y0 and Observed Y1') +# +# ggsave('inst/app/www/learn/fundemental/plots/p12.png', device = 'png', height = 5, width = 8) +# +# +# +# dat4 <- dat +# dat4 <- dat4 %>% mutate(Y1 = case_when( +# Z == 0 & first.race == 'yes' ~ 260, +# Z == 0 & first.race == 'no' ~ 245, +# TRUE ~ Y1 +# ), +# Y0 = case_when( +# Z == 1 & first.race == 'yes' ~ 265, +# Z == 1 & first.race == 'no' ~ 250, +# TRUE ~ Y0 +# )) +# dat4 <- dat4 %>% mutate(ITE = Y1 - Y0) +# dat4 <- dat4 %>% select(runner, first.race, Z, Y0, Y1, Y, ITE) +# +# +# +# dat4$ITE_true <- with(dat, Y1 - Y0) +# +# dat4 %>% +# ggplot(aes(runner, ITE, label = runner)) + +# geom_point() + +# geom_text_repel(show.legend = FALSE, seed = 4, size = 3) + +# # annotate( +# # geom = "curve", x = 2, y = 8.5, xend = 2, yend = 10.5, +# # curvature = 0, arrow = arrow(length = unit(2, "mm")) +# # ) + +# # annotate(geom = "text", x = 6, y = 8, label = "predicted treatment effect of 11", hjust = "center", size = 3) + +# # annotate( +# # geom = "curve", x = 4, y = -10.5, xend = 4, yend = -12.5, +# # curvature = 0, arrow = arrow(length = unit(2, "mm")) +# # ) + +# # annotate(geom = "text", x = 8, y = -10, label = "predicted treatment effect of -13", hjust = "center", size = 3) + +# theme_bw() + +# theme(legend.position = 'top', legend.justification='left') + +# labs(x = 'Runner ID', y = 'Predicted Causal Effect of hyperShoes', linetype = NULL, title = 'Estimated Causal Effects') +# ggsave('inst/app/www/learn/fundemental/plots/p13.png', device = 'png', height = 5, width = 8) +# +# +# +# +# dat4 %>% +# pivot_longer(contains('ITE')) %>% +# ggplot(aes(runner, value, col = name, shape = name)) + +# scale_color_manual(values = c(1, 6), labels = c('Predicted Causal Effect', 'True Causal Effect')) + +# scale_shape_manual(values = c(19, 21), labels = c('Predicted Causal Effect', 'True Causal Effect')) + +# geom_line(aes(group = runner,linetype = 'bias'), col = 'dark grey') + +# scale_linetype_manual(values = 2) + +# geom_point() + +# #geom_hline(aes(yintercept = mean(value), col = name)) + +# #geom_hline(yintercept = mean(dat3$ITE)) + +# #geom_hline(yintercept = mean(dat3$ITE_true), col = 6, linetype = 2) + +# theme_bw() + +# theme(legend.position = 'top', legend.justification = 'left') + +# labs(col = NULL, shape = NULL, linetype = NULL, x = 'Runner ID') +# ggsave('inst/app/www/learn/fundemental/plots/p14.png', device = 'png', height = 5, width = 8) +# +# +# diff --git a/scratch/potential_outcomes_two.Rmd b/scratch/potential_outcomes_two.Rmd index a76d2662..161a17c7 100644 --- a/scratch/potential_outcomes_two.Rmd +++ b/scratch/potential_outcomes_two.Rmd @@ -20,7 +20,7 @@ library(ggrepel) -A causal effect is the difference between all potential outcomes. Let's concider our hypothetical example of the HyperShoe. For those unaware, the HyperShoe is a speciatly running shoe released with the claim that wearing HyperShoes casues runners to run faster than they would have ran had they worn statndard running shoes. How do we know that the causal claim about waering HyperShoes and fast running is true? Ideally, we would look at a sample of runners and compare their running times if they had worn HyperShoes (Y1) to their running times if they had not worn HyperShoes (Y0). +A causal effect is the difference between all potential outcomes. Let's concider our hypothetical example of the HyperShoe. For those unaware, the HyperShoe is a speciatly running shoe released with the claim that wearing HyperShoes causes runners to run faster than they would have ran had they worn standard running shoes. How do we know that the causal claim about wearing hyperShoes and fast running is true? Ideally, we would look at a sample of runners and compare their running times if they had worn hyperShoes (Y1) to their running times if they had not worn hyperShoes (Y0). >**Notation Review** @@ -218,13 +218,13 @@ dat3$ITE_true <- with(dat, Y1 - Y0) dat3 %>% pivot_longer(contains('ITE')) %>% ggplot(aes(runner, value, col = name, shape = name)) + - geom_point() + scale_color_manual(values = c(1, 6)) + scale_shape_manual(values = c(19, 21)) + + geom_line(aes(group = runner), col = 'dark grey', linetype = 2) + + geom_point() + #geom_hline(aes(yintercept = mean(value), col = name)) + - geom_hline(yintercept = mean(dat3$ITE)) + - geom_hline(yintercept = mean(dat3$ITE_true), col = 6) + - geom_area(aes(runner)) + + #geom_hline(yintercept = mean(dat3$ITE)) + + #geom_hline(yintercept = mean(dat3$ITE_true), col = 6, linetype = 2) + theme_bw() ``` diff --git a/thinkCausal/.Rprofile b/thinkCausal/.Rprofile index 81b960f5..cfed6e94 100644 --- a/thinkCausal/.Rprofile +++ b/thinkCausal/.Rprofile @@ -1 +1,3 @@ source("renv/activate.R") +options(shiny.launch.browser = TRUE) +options(repos = c(RSPM = "https://packagemanager.rstudio.com/cran/latest")) diff --git a/thinkCausal/DESCRIPTION b/thinkCausal/DESCRIPTION index b7b64d8c..2375618e 100644 --- a/thinkCausal/DESCRIPTION +++ b/thinkCausal/DESCRIPTION @@ -2,40 +2,41 @@ Package: thinkCausal Title: Point-and-click bartCause analysis and causal inference education Version: 0.5.0 Authors@R: c( - person('Joseph', 'Marlo', email = 'jpm770@nyu.edu', role = c('cre', 'aut')), - person("George", "Perrett", email = "gp77@nyu.edu", role = "aut"), - person("Jennifer", "Hill", email = "jennifer.hill@nyu.edu", role = "aut") + person("George", "Perrett", email = "gp77@nyu.edu", role = c('cre', 'aut')), + person("Jennifer", "Hill", email = "jennifer.hill@nyu.edu", role = "aut"), + person('Joseph', 'Marlo', email = 'jpm770@nyu.edu', role = "aut") ) -Description: A federally funded project devoted to building scaffolded causal inference software implementing Bayesian Additive Regression Trees. +Description: An Institute of Education Sciences (IES) funded project devoted to building scaffolded causal inference software implementing Bayesian Additive Regression Trees. License: MIT + file LICENSE URL: https://github.com/priism-center/thinkCausal_dev Imports: - bartCause (>= 1.0.5), + bartCause (>= 1.0.6), bs4Dash (>= 2.1.0), cli, config (>= 0.3.1), dplyr (>= 1.0.5), + ggdark (>= 0.2.1), ggplot2 (>= 3.3.2), glue, golem (>= 0.3.2), - Hmisc (>= 4.7.0), htmltools, jsonlite, lubridate (>= 1.8.0), openxlsx (>= 4.2.5), patchwork (>= 1.1.1), pkgload, - plotBart (>= 0.1.23), + plotBart (>= 0.1.25), purrr, reactable (>= 0.3.0), readr, - readstata13 (>= 0.10.0), rlang (>= 1.0.3), scales (>= 1.1.1), shiny (>= 1.7.1), shinybrowser (>= 1.0.0), shinydisconnect (>= 0.1.0), + shinyFeedback (>= 0.4.0.9001), shinyjs (>= 2.1.0), + shinyQuiz (>= 0.0.0.9000), shinyWidgets (>= 0.7.4), sortable (>= 0.4.5), stringr, @@ -51,8 +52,11 @@ Config/testthat/edition: 3 Encoding: UTF-8 Language: en-US LazyData: true -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 VignetteBuilder: knitr BugReports: https://priism-center.github.io/thinkCausal//issues Remotes: - github::priism-center/plotBart + github::priism-center/plotBart, + github::merlinoa/shinyFeedback, + github::priism-center/shinyQuiz, + nsgrantham/ggdark diff --git a/thinkCausal/R/app_server.R b/thinkCausal/R/app_server.R index f2db9a3f..3ce17849 100644 --- a/thinkCausal/R/app_server.R +++ b/thinkCausal/R/app_server.R @@ -5,7 +5,7 @@ #' @import shiny #' @noRd app_server <- function(input, output, session) { - + # test deployment # close loading spinner Sys.sleep(1.5) # prevent flashing waiter::waiter_hide() @@ -46,7 +46,14 @@ app_server <- function(input, output, session) { # learn mod_learn_server(module_ids$learn$home, store) mod_learn_estimands_server(module_ids$learn$estimands) + mod_learn_estimands2_server(module_ids$learn$estimands2) + mod_learn_fundamental_server(module_ids$learn$fundamental) + mod_learn_versionA_server(module_ids$learn$versionA) + mod_learn_versionB_server(module_ids$learn$versionB) + mod_learn_randomization_dist_server(module_ids$learn$rand_dist) mod_learn_rct_analysis_server(module_ids$learn$randomization) + mod_learn_variable_selection_server(module_ids$learn$selection, store) + mod_learn_colinearity_server(module_ids$learn$colinearity, id_parent = module_ids$learn$selection) mod_learn_post_treatment_server(module_ids$learn$post_treatment, store) mod_learn_potential_outcomes_server(module_ids$learn$potential_outcomes) mod_learn_obs_analysis_server(module_ids$learn$observational) @@ -56,7 +63,6 @@ app_server <- function(input, output, session) { # analysis store <- mod_analysis_upload_server(module_ids$analysis$upload, store) - store <- mod_analysis_design_server(module_ids$analysis$design, store) store <- mod_analysis_variable_selection_server(module_ids$analysis$select, store) store <- mod_analysis_verify_server(module_ids$analysis$verify, store) store <- mod_analysis_visualize_server(module_ids$analysis$visualize, store) diff --git a/thinkCausal/R/app_ui.R b/thinkCausal/R/app_ui.R index 2a65b074..9a2a7325 100644 --- a/thinkCausal/R/app_ui.R +++ b/thinkCausal/R/app_ui.R @@ -6,10 +6,12 @@ #' @noRd app_ui <- function(request) { tagList( - # add external resources golem_add_external_resources(), + # add feedback + shinyFeedback::useShinyFeedback(), + # initial load spinner waiter::waiterShowOnLoad( color = "#302F42", @@ -25,6 +27,9 @@ app_ui <- function(request) { ) ), + # add beta ribbon + add_beta_ribbon(), + # message when server disconnects # TODO: this can be removed for native installation shinydisconnect::disconnectMessage( @@ -59,19 +64,6 @@ app_ui <- function(request) { body = bs4Dash::dashboardBody( - # add beta ribbon - tags$div( - class = 'cornerRibbon', - 'BETA', - tags$div( - tags$a( - href = 'https://docs.google.com/forms/d/e/1FAIpQLSd7dZjpw4FtoVAFUmovNOgKeW-kxnJrs3zV2r3lJ8kvhdq8lA/viewform?usp=sf_link', - target = "_blank", - 'Have feedback?' - ) - ) - ), - bs4Dash::tabItems( bs4Dash::tabItem( @@ -88,6 +80,26 @@ app_ui <- function(request) { tabName = 'learn_estimands', mod_learn_estimands_ui(module_ids$learn$estimands) ), + bs4Dash::tabItem( + tabName = 'learn_estimands2', + mod_learn_estimands2_ui(module_ids$learn$estimands2) + ), + bs4Dash::tabItem( + tabName = 'learn_versionA', + mod_learn_versionA_ui(module_ids$learn$versionA) + ), + bs4Dash::tabItem( + tabName = 'learn_versionB', + mod_learn_versionB_ui(module_ids$learn$versionB) + ), + bs4Dash::tabItem( + tabName = 'learn_rand_dist', + mod_learn_randomization_dist_ui(module_ids$learn$rand_dist) + ), + bs4Dash::tabItem( + tabName = 'learn_fundamental', + mod_learn_fundamental_ui(module_ids$learn$fundamental) + ), bs4Dash::tabItem( tabName = 'learn_randomization', mod_learn_rct_analysis_ui(module_ids$learn$randomization) @@ -100,6 +112,14 @@ app_ui <- function(request) { tabName = 'learn_balance', mod_learn_balance_ui(module_ids$learn$balance) ), + bs4Dash::tabItem( + tabName = 'learn_variable_selection', + mod_learn_variable_selection_ui(module_ids$learn$selection) + ), + bs4Dash::tabItem( + tabName = 'learn_colinearity', + mod_learn_colinearity_ui(module_ids$learn$colinearity) + ), bs4Dash::tabItem( tabName = 'learn_post_treatment', mod_learn_post_treatment_ui(module_ids$learn$post_treatment) @@ -112,7 +132,6 @@ app_ui <- function(request) { tabName = 'learn_scrolly', mod_learn_scrolly_example_ui('learn_scrolly') ), - # analysis pages bs4Dash::tabItem( tabName = 'analysis_upload', @@ -155,12 +174,13 @@ app_ui <- function(request) { mod_analysis_subgroup_ui(module_ids$analysis$subgroup) ), - + # reproduce bs4Dash::tabItem( tabName = 'reproduce', mod_reproduce_ui(module_ids$reproduce) ), + # settings pages bs4Dash::tabItem( tabName = 'settings_options', mod_settings_options_ui(module_ids$settings$options) @@ -183,12 +203,14 @@ app_ui <- function(request) { bs4Dash::sidebarMenu( id = 'sidebar', + # home page bs4Dash::menuItem( text = 'thinkCausal', tabName = 'home', icon = icon("home", verify_fa = FALSE) ), + # learning pages bs4Dash::menuItem( text = 'Learn', icon = icon("book", verify_fa = FALSE), @@ -205,6 +227,42 @@ app_ui <- function(request) { text = 'Causal estimands', tabName = 'learn_estimands' ), + bs4Dash::menuSubItem( + text = 'Estimands 2', + tabName = 'learn_estimands2' + ), + bs4Dash::menuSubItem( + text = 'version A', + tabName = 'learn_versionA' + ), + bs4Dash::menuSubItem( + text = 'version B', + tabName = 'learn_versionB' + ), + bs4Dash::menuSubItem( + text = 'Sandbox', + tabName = 'learn_rand_dist' + ), + bs4Dash::menuSubItem( + text = 'Fundamental', + tabName = 'learn_fundamental' + ), + bs4Dash::menuItem( + text = 'Variable Selection', + tabName = 'learn_variable_selection', + bs4Dash::menuSubItem( + text = 'Variable Selection', + tabName = 'learn_variable_selection', + ), + bs4Dash::menuSubItem( + text = 'Colinearity', + tabName = 'learn_colinearity', + ), + bs4Dash::menuSubItem( + text = 'Overfitting', + tabName = 'learn_overfitting', + ) + ), bs4Dash::menuSubItem( text = 'Post treatment variables', tabName = 'learn_post_treatment' @@ -283,12 +341,14 @@ app_ui <- function(request) { ) ), + # reproduce bs4Dash::menuItem( text = 'Reproduce', tabName = 'reproduce', icon = shiny::icon('repeat', verify_fa = FALSE) ), + # settings pages bs4Dash::menuItem( text = 'Settings', tabName = 'settings', @@ -345,9 +405,6 @@ golem_add_external_resources <- function() { app_title = "thinkCausal" ), - # make all links open in a new tab - # tags$base(target = "_blank"), - # enable shinyjs shinyjs::useShinyjs(), diff --git a/thinkCausal/R/fct_clean.R b/thinkCausal/R/fct_clean.R index e8d85f1f..63ec8b33 100644 --- a/thinkCausal/R/fct_clean.R +++ b/thinkCausal/R/fct_clean.R @@ -136,7 +136,7 @@ clean_detect_logical <- function(x){ clean_detect_binary <- function(x){ if(inherits(x, 'data.frame')) stop('x cannot be a dataframe') - is_binary <- ifelse(length(unique(x)) == 2, TRUE, FALSE) + is_binary <- ifelse(length(unique(na.omit(x))) == 2, TRUE, FALSE) return(is_binary) } @@ -209,6 +209,7 @@ clean_auto_convert_integers <- function(.data){ return(.data) } +#' @noRd #' @describeIn clean_auto_convert_integers detect if a vector is integers clean_detect_integers <- function(x, n_levels_threshold = 15){ @@ -452,7 +453,8 @@ clean_detect_plot_vars <- function(.column_types, .treatment_column, .response_c #' @param df a dataframe with varibales #' #' @return a dataframe with no categorical variables -#' @author George Perrett & Joe Marlo +#' @author George Perrett, Joseph Marlo +#' @noRd clean_to_indicator <- function(df){ character_vars <- names(which(sapply(df, is.character))) factor_vars <- names(which(sapply(df, is.factor))) diff --git a/thinkCausal/R/fct_convert.R b/thinkCausal/R/fct_convert.R index 13485cea..cf721e7a 100644 --- a/thinkCausal/R/fct_convert.R +++ b/thinkCausal/R/fct_convert.R @@ -29,6 +29,7 @@ convert_data_types <- function(.data, new_data_types){ return(.data) } +#' @noRd #' @describeIn convert_data_types converts x to the new_data_type convert_data_types_ <- function(x, new_data_type){ if (new_data_type %notin% c('Categorical', 'Binary', 'Continuous')) stop("new_data_type must be one of c('Categorical', 'Binary', 'Continuous')") diff --git a/thinkCausal/R/fct_create.R b/thinkCausal/R/fct_create.R index 5e1804e6..b93d4317 100644 --- a/thinkCausal/R/fct_create.R +++ b/thinkCausal/R/fct_create.R @@ -290,10 +290,9 @@ create_interpretation <- function(.model, type, treatment, units, participants){ if(units == '') units <- 'units' if(participants == '') participants <- 'participants' if(type == 'Causal'){ - if(.model$estimand == 'att') estimand <- paste0('For ', participants, ' in this study that received the ', treatment, ', receiving the ', treatment) - if(.model$estimand == 'ate') estimand <- paste0('For ', participants, ' in this study, receiving the ', treatment) - if(.model$estimand == 'atc') estimand <- paste0('For ', participants, ' in this study that did not receive the ', treatment, ' receiving the ', treatment, ' would have') - + if(.model$estimand == 'att') estimand <- paste0('Assuming Ignorability and SUTVA', ', for ', participants, ' in this study that received the ', treatment, ', receiving the ', treatment) + if(.model$estimand == 'ate') estimand <- paste0('Assuming Ignorability and SUTVA', ', for ', participants, ' in this study, receiving the ', treatment) + if(.model$estimand == 'atc') estimand <- paste0('Assuming Ignorability and SUTVA', ', for ', participants, ' in this study that did not receive the ', treatment, ' receiving the ', treatment, ' would have') if(as.data.frame(summary(.model)$estimates)[1] > 0) result <- paste0(' led to an increase of ', as.character(round(as.data.frame(summary(.model)$estimates)[1], 2)), ' ', units) if(as.data.frame(summary(.model)$estimates)[1] < 0) result <- paste0(' led to a decrease of ', as.character(round(as.data.frame(summary(.model)$estimates)[1], 2)), ' ', units) @@ -774,3 +773,254 @@ create_table <- function(.data = NULL, correct_answers = NULL, n_rows = 6, y_min return(out) } + +#' Create a table that can be used for oracle type tables +# +#' @param z vector of the treatment variable +#' @param id optional vector of an id variable +#' @param X vector or matrix of covariates +#' @param Y0 vector of true Y0 value +#' @param estY0 vector of Y0 with estimated counter-factual values +#' @param Y1 vector of true Y1 value +#' @param estY1 vector Y1 with estimated counter-factual values +#' @param show.imputed logical if TRUE will show imputed counter-factual values +#' +#' @author George Perrett +#' +#' @return data.frame +#' @noRd + +create_table_researcher <- function(df, imputed, rows = 20){ + + if(isFALSE(imputed)){ + df$Y1[df$hyperShoe == 0] <- NA + df$Y0[df$hyperShoe == 1] <- NA + } + + if(isTRUE(imputed)){ + colorY1 <- ifelse(df$hyperShoe == 0, "#DF536B", 'none') + colorY0 <- ifelse(df$hyperShoe == 1, "#2297E6", 'none') + }else{ + colorY1 <- NULL + colorY0 <- NULL + } + + reactable::reactable( + data = df, + fullWidth = FALSE, + theme = reactable::reactableTheme(cellPadding = "1px 6px"), + defaultPageSize = rows, + defaultColDef = reactable::colDef( + footerStyle = list(fontWeight = "bold", background = 'white'), + ), + columns = list( + Y0 = reactable::colDef( + #show = 'Y0' %in% .show, + footer = round(mean(df$Y0), 1), + footerStyle = list(fontWeight = "bold"), + style = function(value, index) { + list(color = colorY0[index]) + } + ), + Y1 = reactable::colDef( + footer = round(mean(df$Y1), 1), + footerStyle = list(fontWeight = "bold"), + style = function(value, index) { + list(color = colorY1[index]) + } + ), + Y = reactable::colDef( + # show = 'Y' %in% .show + ), + estITE = reactable::colDef( + show = isTRUE(imputed), + name = 'estimated ITE', + footer = round(mean(df$estITE), 1), + footerStyle = list(fontWeight = "bold") + # show = 'Y' %in% .show + ) + ) + ) + +} + + +create_table_parallel <- function(df, rows){ + + df$hyperShoe <- abs(df$hyperShoe - 1) + df$Y <- ifelse(df$hyperShoe == 1, df$Y1, df$Y0) + df$Y1[df$hyperShoe == 0] <- NA + df$Y0[df$hyperShoe == 1] <- NA + + + backgroundY1 <- rep('black', nrow(df)) + backgroundY0 <- rep('black', nrow(df)) + backgroundY <- rep('black', nrow(df)) + backgroundZ <- rep('black', nrow(df)) + + colorY <- rep('white', nrow(df)) + colorZ <- rep('white', nrow(df)) + colorY1 <- rep('white', nrow(df)) + colorY0 <- rep('white', nrow(df)) + + reactable::reactable( + data = df, + fullWidth = FALSE, + theme = reactable::reactableTheme(cellPadding = "1px 6px"), + defaultPageSize = rows, + columns = list( + # runner = reactable::colDef(show = 'runner' %in% .show), + # `prior races` = reactable::colDef(show = 'prior races' %in% .show), + hyperShoe = reactable::colDef( + # show = 'hyperShoe' %in% .show + style = function(value, index) { + list(color = colorZ[index], + background = backgroundZ[index] + ) + } + ), + Y0 = reactable::colDef( + #show = 'Y0' %in% .show, + style = function(value, index) { + list(color = colorY0[index], + background = backgroundY0[index]) + } + ), + Y1 = reactable::colDef( + #show = 'Y1' %in% .show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(color = colorY1[index], + background = backgroundY1[index]) + } + ), + Y = reactable::colDef( + # show = 'Y' %in% .show + style = function(value, index) { + list(color = colorY[index], + background = backgroundY[index]) + } + ) + ) + ) + +} + +create_table_oracle <- function(df, imputed, .show, rows, estimand = 'ate'){ + if('estY1' %notin% names(df)){ + df$estY1 <- NA + } + + if('estY0' %notin% names(df)){ + df$estY0 <- NA + } + + if('estITE' %notin% names(df)){ + df$estITE <- NA + } + + df <- df %>% dplyr::mutate( + ITE = Y1 - Y0, + estY0 = ifelse(hyperShoe == 0, Y0, estY0), + estY1 = ifelse(hyperShoe == 1, Y1, estY1) + ) + if(isTRUE(imputed)){ + colorEstY1 <- ifelse(df$hyperShoe == 0, "#DF536B", 'none') + colorEstY0 <- ifelse(df$hyperShoe == 1, "#2297E6", 'none') + }else{ + colorEstY1 <- NULL + colorEstY0 <- NULL + } + + backgroundY1 <- ifelse(df$hyperShoe == 1, 'white', 'black') + backgroundY0 <- ifelse(df$hyperShoe == 0, 'white', 'black') + backgroundITE <- rep('black', nrow(df)) + colorY1 <- ifelse(df$hyperShoe == 0, 'white', 'none') + colorY0 <- ifelse(df$hyperShoe == 1, 'white', 'none') + colorITE <- rep('white', nrow(df)) + reactable::reactable( + data = df, #%>% dplyr::select(.show, dplyr::everything()), + fullWidth = FALSE, + theme = reactable::reactableTheme(cellPadding = "1px 6px"), + defaultPageSize = rows, + defaultColDef = reactable::colDef( + footerStyle = list(fontWeight = "bold", background = 'white'), + ), + columns = list( + runner = reactable::colDef(footer = 'Average', footerStyle = list(background = 'white')), + estY0 = reactable::colDef( + show = isTRUE(imputed), + name = 'est.', + footerStyle = list(fontWeight = "bold", background = 'white'), + footer = round(mean(df$estY0), 1), + maxWidth = ifelse(isTRUE(imputed), 60, 100), + #show = isTRUE(imputed) & 'estY0' %in% .show, + style = function(value, index) { + list(color = colorEstY0[index]) + } + ), + Y0 = reactable::colDef( + name = ifelse(isTRUE(imputed), 'true', 'Y0'), + footer = round(mean(df$Y0), 1), + footerStyle = list(fontWeight = "bold", color = 'white', background = 'black'), + #show = 'Y0' %in% .show, + maxWidth = ifelse(isTRUE(imputed), 60, 100), + style = function(value, index) { + list(color = colorY0[index], + background = backgroundY0[index]) + } + ), + estY1 = reactable::colDef( + show = isTRUE(imputed), + name = 'est.', + footer = round(mean(df$estY1), 1), + footerStyle = list(fontWeight = "bold"), + maxWidth = ifelse(isTRUE(imputed), 60, 100), + #show = isTRUE(imputed)&'estY1' %in% .show, + style = function(value, index) { + list(color = colorEstY1[index]) + } + ), + Y1 = reactable::colDef( + footer = round(mean(df$Y1), 1), + footerStyle = list(fontWeight = "bold", color = 'white', background = 'black'), + #show = 'Y1' %in% .show, + name = ifelse(isTRUE(imputed), 'true', 'Y1'), + maxWidth = ifelse(isTRUE(imputed), 60, 100), + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(color = colorY1[index], + background = backgroundY1[index]) + } + ), + estITE = reactable::colDef( + show = isTRUE(imputed), + footer = round(mean(df$estITE), 1), + footerStyle = list(fontWeight = "bold"), + name = 'est.', + maxWidth = 60 + + ), + ITE = reactable::colDef( + footer = round(mean(df$ITE), 1), + footerStyle = list(fontWeight = "bold", color = 'white', background = 'black'), + name = ifelse(isTRUE(imputed), 'true', 'ITE'), + #show = 'ITE' %in% .show, + maxWidth = ifelse(isTRUE(imputed), 60, 100), + style = function(value, index) { + list(color = colorITE[index], + background = backgroundITE[index]) + } + ) + ), + if(isTRUE(imputed)){ + columnGroups = list( + reactable::colGroup(name = "Y0", columns = c("estY0", "Y0")), + reactable::colGroup(name = "Y1", columns = c("estY1", "Y1")), + reactable::colGroup(name = 'ITE', columns = c('estITE', 'ITE')) + ) + } + ) + +} + diff --git a/thinkCausal/R/fct_learn_estimands.R b/thinkCausal/R/fct_learn_estimands.R index bd5ce1a2..4b98eff8 100644 --- a/thinkCausal/R/fct_learn_estimands.R +++ b/thinkCausal/R/fct_learn_estimands.R @@ -7,35 +7,51 @@ #' @noRd quiz_content_estimands <- local({ - content <- list() - content$ns_quiz <- NS(NS('learning_estimands')('quiz')) - po <- create_table(ate = -5, y_min = 30, y_max = 50, po_question = FALSE, ite_question = FALSE, id_unit = 'Runner', button = FALSE, ) - # questions - question_1 <- tagList( - h4("Calculating the ATE"), - hr(), - h3("Question 1"), # h3 required for checkmark/red x placement - p("Imagine you're asked to determine the average treatment effect of wearing HyperShoes (Z = 1) on 5k running times. The potential outcomes for a sample of 6 runners are shown below. Use this data to calculate the average treatment effect (ATE)."), - HTML(po[[1]]), - br(), - p("The Average Treatment Effect (ATE) for the sample of runners is:") - ) - question_prompt_1 <- numericInput( - inputId = content$ns_quiz('answers'), - label = NULL, - value = NULL, - step = 0.1 - ) - - # answer - correct_answer_1 <- list(c(mean(as.numeric(po[[2]]$ITE)))) - # place in a single list - content$question_texts <- list(question_1) - content$question_prompts <- list(question_prompt_1) - content$correct_answers <- list(correct_answer_1) - content$message_correct <- "Well done! You got all of them correct. Please read on to learn about the next topic." - content$message_wrong <- "Good attempt but you got at least one wrong. Take another try!" - content$message_skipped <- 'Quiz skipped. You can restart it using the button below.' + # content <- list() + # content$ns_quiz <- NS(NS('learning_estimands')('quiz')) + #ns <- shiny::NS(shiny::NS('learning_estimands')('quiz')) + ns <- shiny::NS('learning_estimands') + ns1 <- shiny::NS(ns('quiz')) + generate_estimand <- function(){ + po <- create_table(ate = sample(-25:0, 1), y_min = 20, y_max = 50, po_question = FALSE, ite_question = FALSE, id_unit = 'Runner', button = FALSE) + estimand <- sample(c('ATE','ATT', 'ATC'), 1) + estimand_long <- switch (estimand, + 'ATE' = 'average treatment effect (ATE)', + 'ATT' = 'average treatment effect on the treated (ATT)', + 'ATC' = 'average treatment effect on the control (ATC)' + ) + + # possible answers + + ate <- round(mean(as.numeric(po[[2]]$Y1) - as.numeric(po[[2]]$Y0)), 2) + att <- round(mean(as.numeric(po[[2]]$Y1[po[[2]]$Z == '1']) - as.numeric(po[[2]]$Y0[po[[2]]$Z == '1'])), 2) + atc <- round(mean(as.numeric(po[[2]]$Y1[po[[2]]$Z == '0']) - as.numeric(po[[2]]$Y0[po[[2]]$Z == '0'])), 2) + avg_y <- round(lm(as.numeric(po[[2]]$Y) ~ as.numeric(po[[2]]$Z))$coef[2], 2) + + question_prompt <- tagList( + h5(glue::glue("Calculating the {estimand}")), + p(glue::glue("Imagine you're asked to determine the average treatment effect of wearing HyperShoes (Z = 1) on 5k running times. The potential outcomes for a sample of 6 runners are shown below. Use this data to calculate the {estimand_long}.")), + HTML(po[[1]]), + br(), + p(glue::glue("The {estimand_long} for this sample of runners is:")) + ) + + + q <- shinyQuiz::create_question(prompt = question_prompt, + shinyQuiz::add_choice('', correct = FALSE), + shinyQuiz::add_choice(ate, correct = estimand == 'ATE'), + shinyQuiz::add_choice(att, correct = estimand == 'ATT'), + shinyQuiz::add_choice(atc, correct = estimand == 'ATC'), + shinyQuiz::add_choice(avg_y), + ns = ns1) + + + return(q) + + } + + sandbox_q <- shinyQuiz::create_question_sandbox(.f = generate_estimand, n = 25) + content <- shinyQuiz::create_quiz(sandbox_q, options = shinyQuiz::set_quiz_options(ns = ns1)) return(content) }) diff --git a/thinkCausal/R/fct_learn_estimands2.R b/thinkCausal/R/fct_learn_estimands2.R new file mode 100644 index 00000000..1da3f36b --- /dev/null +++ b/thinkCausal/R/fct_learn_estimands2.R @@ -0,0 +1,91 @@ +#' Content for the estimands2 quiz +#' +#' @description A fct function +#' +#' @return a list +#' +#' @noRd +quiz_content_estimands2 <- local({ + + # content <- list() + # content$ns_quiz <- NS(NS('learning_estimands')('quiz')) + #ns <- shiny::NS(shiny::NS('learning_estimands')('quiz')) + ns <- shiny::NS('learning_estimands2') + ns1 <- shiny::NS(ns('quiz')) + generate_estimand2 <- function(){ + n <- 750 + x = switch (sample(c('norm', 'unif'), 1), + 'norm' = rnorm(n), + 'unif' = runif(n, -2, 2) + ) + + if(isTRUE(sample(c(T, F), 1))){ + beta <- rnorm(1, 2) + y1 = x*beta + rnorm(n) + rnorm(1, -2, 5) + if(isTRUE(sample(c(T, F), 1))) beta <- rnorm(1, 2) + y0 = x*beta + rnorm(n) + + }else{ + y0 <- rnorm(1, 2,1)*x + rnorm(n) + if(isTRUE(sample(c(T, F), 1))) y0 <- rnorm(1, .3, 1)*x + I((x+.3)^2)*rnorm(1, 1, .5) + rnorm(n) + y1 <- 6 + rnorm(1, .3, 1)*x + I((x+.3)^2)*rnorm(1, 1, .5) + rnorm(n) + } + + z <- rbinom(n, 1, .5) + y <- ifelse(z == 1, y1, y0) + dat <- data.frame(y, z, x) + + correct_aws <- sample(c('ATE', 'ATT', 'ATC'), 1) + + val <- quantile(x)[sample(c(2:4), 1)] + direction <- sample(c('>', '<'), 1) + ind <- switch (sample(c('greater', 'less'), 1), + 'greater' = eval(parse(text = "x > val")), + 'less' = eval(parse(text = "x < val")) + ) + + dat <- switch (correct_aws, + 'ATE' = dat, + 'ATT' = dat %>% dplyr::filter(ind | z == 0), + 'ATC' = dat %>% dplyr::filter(ind | z == 1) + ) + + + + if(correct_aws == 'ATE') correct_aws <- c('ATE', 'ATT', 'ATC') + + + question_prompt <- tagList( + h5(glue::glue("Select estimands")), + p(glue::glue("Given the data, which estimands can we estimate with a statistical model?")), + renderPlot({ + ggplot2::ggplot(dat, ggplot2::aes(x, y, col = as.factor(z))) + + ggplot2::geom_point() + + ggplot2::scale_color_manual(values = c(4, 2), labels = c('Control', 'Treatment')) + + ggplot2::labs(col = NULL) + + ggplot2::theme_bw() + }), + br(), + br(), + checkboxGroupInput(inputId = ns1('answers'), + label = 'Select all that apply:', + choices = c('ATE', 'ATT', 'ATC'), + inline = TRUE + ) + ) + + + q <- shinyQuiz::create_question_raw(prompt = question_prompt, + grader = function(user_input){setequal(user_input, correct_aws)}, + correct_answer_pretty = paste(correct_aws, collapse = ', ')) + + + return(q) + + } + + sandbox_q <- shinyQuiz::create_question_sandbox(.f = generate_estimand2, n = 25) + content <- shinyQuiz::create_quiz(sandbox_q, options = shinyQuiz::set_quiz_options(ns = ns1)) + + return(content) +}) diff --git a/thinkCausal/R/fct_learn_fundamental.R b/thinkCausal/R/fct_learn_fundamental.R new file mode 100644 index 00000000..3e2c2c8f --- /dev/null +++ b/thinkCausal/R/fct_learn_fundamental.R @@ -0,0 +1,33 @@ +#' Content for the fundamental quiz +#' +#' @description A fct function +#' +#' @return a list +#' +#' @noRd +quiz_content_fundamental <- local({ + + ns <- shiny::NS('learning_fundamental') + ns1 <- shiny::NS(ns('quiz')) + + question_prompt <- tagList( + p(glue::glue("What is the individual causal effect of runner 3?")), + reactable::reactable(readr::read_csv('inst/extdata/fundamental_table1.csv')[3,]) + ) + + q <- shinyQuiz::create_question(prompt = question_prompt, + shinyQuiz::add_choice(''), + shinyQuiz::add_choice(245), + shinyQuiz::add_choice(8), + shinyQuiz::add_choice(-8, correct = T), + shinyQuiz::add_choice(253), + shinyQuiz::add_choice(249), + type = 'single', + ns = ns1) + + + content <- shinyQuiz::create_quiz(q, options = shinyQuiz::set_quiz_options(ns = ns1, sandbox = F)) + + return(content) + +}) diff --git a/thinkCausal/R/fct_learn_post_treatment.R b/thinkCausal/R/fct_learn_post_treatment.R index 88e7f742..b7a97e9f 100644 --- a/thinkCausal/R/fct_learn_post_treatment.R +++ b/thinkCausal/R/fct_learn_post_treatment.R @@ -13,118 +13,223 @@ quiz_content_post_treatment <- local({ # set quiz structure ------------------------------------------------------ # set the text for question 1 - question_1 <- tagList( - h4("Practice identifying post-treatment variables with these 2 practice questions:"), - hr(), - h3("Question 1"), # h3 required for checkmark/red x placement - p("You’re tasked with determining if omega-3 fish oil supplements cause a decrease in blood pressure over a 6 month period. You have data from an experiment where participants were randomly assigned to take omega-3 fish oil supplements or a placebo supplement for 6 months. Besides the treatment variable (fish_oil) and the outcome variable (bp_6month) you have the following covariates: "), - tags$ul( - tags$li('Blood pressure measured at the start of the study (bp_baseline)'), - tags$li('Blood pressure measured 3 months into the study (bp_3month)'), - tags$li('Sex measured at the start of the study (sex)'), - tags$li('Height measured at the start of the study (height)') + question_text_1 <- htmltools::div( + htmltools::p("You’re tasked with determining if omega-3 fish oil supplements cause a decrease in blood pressure over a 6 month period. You have data from an experiment where participants were randomly assigned to take omega-3 fish oil supplements or a placebo supplement for 6 months. Besides the treatment variable (fish_oil) and the outcome variable (bp_6month) you have the following covariates: "), + htmltools::tags$ul( + htmltools::tags$li('Blood pressure measured at the start of the study (bp_baseline)'), + htmltools::tags$li('Blood pressure measured 3 months into the study (bp_3month)'), + htmltools::tags$li('Sex measured at the start of the study (sex)'), + htmltools::tags$li('Height measured at the start of the study (height)') ), - p("Which covariates would you include in your analysis? Use the drag-drop below to move variables into the include or exclude bins.") - ) + htmltools::p("Which covariates would you include in your analysis? Use the drag-drop below to move variables into the include or exclude bins."), - # set the UI elements for question 1 - question_prompt_1 <- sortable::bucket_list( - header = "Drag the variables to their respective roles", - group_name = content$ns_quiz('answers'), - orientation = "horizontal", - class = 'default-sortable sortable-wide', - sortable::add_rank_list( - input_id = content$ns_quiz('answers_variables'), - text = "Available", - labels = c('bp_baseline','bp_3month', 'sex', 'height'), - options = sortable::sortable_options(multiDrag = TRUE) - ), - sortable::add_rank_list( - input_id = content$ns_quiz('answers_include'), - text = "Control for", - labels = NULL, - options = sortable::sortable_options(multiDrag = TRUE) - ), - sortable::add_rank_list( - input_id = content$ns_quiz('answers_treatment'), - text = "Treatment", - labels = c('fish_oil'), - options = sortable::sortable_options(disabled = TRUE) - ), - sortable::add_rank_list( - input_id = content$ns_quiz('answers_outcome'), - text = "Outcome", - labels = c('bp_6month'), - options = sortable::sortable_options(disabled = TRUE) + # set the UI elements for question 1 + sortable::bucket_list( + header = "Drag the variables to their respective roles", + group_name = content$ns_quiz('answers'), # NOTE: this should be 'answers' for mod_quiz to recognize it + orientation = "horizontal", + class = 'default-sortable sortable-wide', + sortable::add_rank_list( + input_id = content$ns_quiz('answers_variables'), + text = "Available", + labels = c('bp_baseline','bp_3month', 'sex', 'height'), + options = sortable::sortable_options(multiDrag = TRUE) + ), + sortable::add_rank_list( + input_id = content$ns_quiz('answers_include'), + text = "Control for", + labels = NULL, + options = sortable::sortable_options(multiDrag = TRUE) + ), + sortable::add_rank_list( + input_id = content$ns_quiz('answers_treatment'), + text = "Treatment", + labels = c('fish_oil'), + options = sortable::sortable_options(disabled = TRUE) + ), + sortable::add_rank_list( + input_id = content$ns_quiz('answers_outcome'), + text = "Outcome", + labels = c('bp_6month'), + options = sortable::sortable_options(disabled = TRUE) + ) ) ) + # preview: htmltools::html_print(question_text_1) + + # function to check the answers + grader_1 <- function(user_response){ + + # its best to catch any errors in these graders + is_correct <- tryCatch({ + # set the correct answers here + correct_answers <- list( + c('bp_3month'), + c('bp_baseline', 'sex', 'height'), + c('fish_oil'), + c('bp_6month') + ) + + # this structure is a result of input$'answers' where sortable returns 4 lists + all_true <- all( + setequal(user_response[[1]], correct_answers[[1]]), + setequal(user_response[[2]], correct_answers[[2]]), + setequal(user_response[[3]], correct_answers[[3]]), + setequal(user_response[[4]], correct_answers[[4]]) + ) + + if (isTRUE(all_true)){ + return(TRUE) + } else { + return(FALSE) + } + }, + error = function(e) return(FALSE) + ) + + return(is_correct) + } - # return(NULL) + # TODO: move to a permanent home + setClass('quizQuestion', slots = list( + question = 'shiny.tag', + answerUser = 'list', + answerUserDisplay = 'function', # how to print the user answer in the report + answerCorrectDisplay = 'character', # how to print the correct answer in the report + grader = 'function' # function that compares user answer to the correct answer + )) + verify_question_structure <- function(question){ + + if (!isTRUE(isS4(question))) cli::cli_abort('Must be an S4 object') + if (!isTRUE(inherits(question, 'quizQuestion'))) cli::cli_abort('Must be an S4 object with class quizQuestion') + + if (!isTRUE(inherits(question@question, 'shiny.tag'))) cli::cli_abort('`question` must be of class shiny.tag. Preferably generated from htmltools::div().') + + if (!isTRUE(inherits(question@answerUserDisplay, 'function'))) cli::cli_abort('`answerUserDisplay` must be a function that accepts one argument and returns a character.') + if (!isTRUE(inherits(question@answerCorrectDisplay, 'character'))) cli::cli_abort('`answerCorrectDisplay` must be a character.') + if (!isTRUE(inherits(question@grader, 'function'))) cli::cli_abort('`grader` must be a function that accepts one argument and returns a boolean') + + # verify args + + + return(invisible(TRUE)) + } + + + # create the formal quizQuestion + question_1 <- new('quizQuestion') + question_1@question <- question_text_1 + question_1@answerUser = list(NA) + question_1@answerUserDisplay <- function(x) { + tryCatch( + paste0(x[[2]], collapse = ', '), + error = function(e) 'Cannot print user response' + ) + } + question_1@answerCorrectDisplay <- paste0(c('bp_baseline', 'sex', 'height'), collapse = ', ') + question_1@grader <- grader_1 - # set the correct answers for question 1 - # answer structure must match structure provided by input$answers - correct_answer_1 <- list(c('bp_3month'), - c('bp_baseline','sex', 'height'), - c('fish_oil'), - c('bp_6month')) + verify_question_structure(question_1) # question 2 -------------------------------------------------------------- # set the text for question 2 - question_2 <- tagList( - h3("Question 2"), # h3 required for checkmark/red x placement - p("A middle school offers an optional meditation class to 8th grade students at the beginning of their 8th grade year. You’re tasked with determining if the meditation class caused higher grades at the end of 8th grade. Besides the treatment variable (meditation) and the outcome variable (grades), the school provided you with several other covariates. All covariates were pulled from administrative data at the end of 8th grade. Each covariate is show below:"), - ) + question_text_2 <- htmltools::div( + htmltools::p("A middle school offers an optional meditation class to 8th grade students at the beginning of their 8th grade year. You’re tasked with determining if the meditation class caused higher grades at the end of 8th grade. Besides the treatment variable (meditation) and the outcome variable (grades), the school provided you with several other covariates. All covariates were pulled from administrative data at the end of 8th grade. Each covariate is show below:"), - # set the UI elements for question 2 - question_prompt_2 <- sortable::bucket_list( - header = "Drag the variables to their respective roles", - group_name = content$ns_quiz('answers'), - orientation = "horizontal", - class = 'default-sortable sortable-wide', - sortable::add_rank_list( - input_id = content$ns_quiz('answers_variables'), - text = "Available", - labels = c('6th grade grades', '7th grade grades', 'Detentions during 8th grade', 'Race'), - options = sortable::sortable_options(multiDrag = TRUE) - ), - sortable::add_rank_list( - input_id = content$ns_quiz('answers_include'), - text = "Control for", - labels = NULL, - options = sortable::sortable_options(multiDrag = TRUE) - ), - sortable::add_rank_list( - input_id = content$ns_quiz('answers_treatment'), - text = "Treatment", - labels = c('Meditation'), - options = sortable::sortable_options(disabled = TRUE) - ), - sortable::add_rank_list( - input_id = content$ns_quiz('answers_outcome'), - text = "Outcome", - labels = c('Grades'), - options = sortable::sortable_options(disabled = TRUE) + # set the UI elements for question 2 + question_prompt_2 <- sortable::bucket_list( + header = "Drag the variables to their respective roles", + group_name = content$ns_quiz('answers'), + orientation = "horizontal", + class = 'default-sortable sortable-wide', + sortable::add_rank_list( + input_id = content$ns_quiz('answers_variables'), + text = "Available", + labels = c('6th grade grades', '7th grade grades', 'Detentions during 8th grade', 'Race'), + options = sortable::sortable_options(multiDrag = TRUE) + ), + sortable::add_rank_list( + input_id = content$ns_quiz('answers_include'), + text = "Control for", + labels = NULL, + options = sortable::sortable_options(multiDrag = TRUE) + ), + sortable::add_rank_list( + input_id = content$ns_quiz('answers_treatment'), + text = "Treatment", + labels = c('Meditation'), + options = sortable::sortable_options(disabled = TRUE) + ), + sortable::add_rank_list( + input_id = content$ns_quiz('answers_outcome'), + text = "Outcome", + labels = c('Grades'), + options = sortable::sortable_options(disabled = TRUE) + ) ) ) - # set the correct answers for question 2 - correct_answer_2 <- list(c('Detentions during 8th grade'), - c('6th grade grades', '7th grade grades', 'Race'), - c('Meditation'), - c('Grades') - ) - # use character(0) if any rank lists should be empty + # function to check the answers + grader_2 <- function(user_response){ + + # its best to catch any errors in these graders + is_correct <- tryCatch({ + # set the correct answers here + correct_answers <- list( + c('Detentions during 8th grade'), + c('6th grade grades', '7th grade grades', 'Race'), + c('Meditation'), + c('Grades') + ) + + # this structure is a result of input$'answers' where sortable returns 4 lists + all_true <- all( + setequal(user_response[[1]], correct_answers[[1]]), + setequal(user_response[[2]], correct_answers[[2]]), + setequal(user_response[[3]], correct_answers[[3]]), + setequal(user_response[[4]], correct_answers[[4]]) + ) + + if (isTRUE(all_true)){ + return(TRUE) + } else { + return(FALSE) + } + }, + error = function(e) return(FALSE) + ) - content$question_texts <- list(question_1, question_2) - content$question_prompts <- list(question_prompt_1, question_prompt_2) - content$correct_answers <- list(correct_answer_1, correct_answer_2) + return(is_correct) + } + + # create the formal quizQuestion + question_2 <- new('quizQuestion') + question_2@question <- question_text_2 + question_2@answerUser = list(NA) + question_2@answerUserDisplay <- function(x) { + tryCatch( + paste0(x[[2]], collapse = ', '), + error = function(e) 'Cannot print user response' + ) + } + question_2@answerCorrectDisplay <- paste0(c('6th grade grades', '7th grade grades', 'Race'), collapse = ', ') + question_2@grader <- grader_2 + + verify_question_structure(question_2) + + + # put it all in a list ---------------------------------------------------- + + # use character(0) if any rank lists should be empty + content$questions <- list(question_1, question_2) + # content$question_prompts <- list(question_prompt_1, question_prompt_2) + # content$correct_answers <- list(correct_answer_1, correct_answer_2) content$message_correct <- "Well done! You got all of them correct." content$message_wrong <- "Hmmm, bummer! You got at least one wrong." content$message_skipped <- "Quiz skipped. You can restart it using the button below." + # content$graders <- list(grader_1, grader_2) return(content) }) - - diff --git a/thinkCausal/R/fct_popup.R b/thinkCausal/R/fct_popup.R index a4e9253c..496b5d03 100644 --- a/thinkCausal/R/fct_popup.R +++ b/thinkCausal/R/fct_popup.R @@ -111,10 +111,26 @@ show_popup_learn_common_support <- function(session){ show_popup(session = session, content) } +show_popup_model_no_estimand_warning <- function(session, ns){ + content <- tags$div( + style = 'margin: auto; text-align: center', + h3('Before fitting a model, you need to select a causal estimand.'), + br(), + div( + class = 'backNextContainer', + style = "width:60%;display:inline-block;horizontal-align:center;", + actionButton(inputId = ns('analysis_model_estimand_button_popup'), + class = 'nav-btn-focus', + label = 'Stay on page and choose an estimand') + ) + ) + show_popup(session = session, content, easyClose = TRUE) +} + show_popup_model_no_data_warning <- function(session, ns){ content <- tags$div( style = 'margin: auto; text-align: center', - h3('Data must be first uploaded and columns selected'), + h3('Before fitting a model you need to upload Data. Right now you do not have any Data loaded into thinkCausal.'), br(), div( class = 'backNextContainer', diff --git a/thinkCausal/R/fct_scrollytell.R b/thinkCausal/R/fct_scrollytell.R index 3f2ecf39..ed7b9948 100644 --- a/thinkCausal/R/fct_scrollytell.R +++ b/thinkCausal/R/fct_scrollytell.R @@ -8,21 +8,23 @@ #' @noRd scroll_ui_container <- function(ns, ...){ htmltools::div( - id = glue::glue('{ns(NULL)}-scroll-container'), + id = glue::glue('{ns(NULL)}scroll-container'), class = 'scroll-container', ... ) } +#' @noRd #' @describeIn scroll_ui_container UI container for the text sections scroll_ui_text <- function(ns, ...){ htmltools::div( - id = glue::glue('{ns(NULL)}-scroll-text'), + id = glue::glue('{ns(NULL)}scroll-text'), class = 'scroll-text', ... ) } +#' @noRd #' @describeIn scroll_ui_container UI for establishing an individual scrollytell text section scroll_ui_text_section <- function(ns, position, ...){ id <- ns(glue::glue('text-{position}')) @@ -34,16 +36,34 @@ scroll_ui_text_section <- function(ns, position, ...){ ) } +#' @noRd +#' @describeIn scroll_ui_container UI for establishing an individual scrollytell quiz section +#' @description This requires the ui visual container to have style="pointer-events: none"; otherwise it will prevent clicks on the right half of the quiz. +scroll_ui_quiz_section <- function(ns, position, ...){ + id <- ns(glue::glue('text-{position}')) + htmltools::div( + id = glue::glue('{id}-scroll-text-section'), + class = 'scroll-text-section', + class = ns('scroll-text-section'), + style = 'width: 300%', + ... + ) +} + +#' @noRd #' @describeIn scroll_ui_container UI output for the visual (plots, tables, etc.) -scroll_ui_visual <- function(ns){ +#' @description clickable = FALSE is neccessary for when there is a quiz in a UI text section +scroll_ui_visual <- function(ns, clickable = TRUE){ id <- ns('scroll_visual') htmltools::div( id = glue::glue('{id}-container'), class = 'scroll-visual-container', + style = ifelse(isFALSE(clickable), "pointer-events: none", ''), shiny::uiOutput(outputId = id) ) } +#' @noRd #' @describeIn scroll_ui_container runs the JS. For use on the UI side use_scrollytell <- function(ns){ # this adds the javascript listener for the module @@ -59,3 +79,48 @@ use_scrollytell <- function(ns){ js_tag <- shiny::tags$script(htmltools::HTML(js_code)) return(js_tag) } + +#' @title Create a secound scrollytell +#' +#' @description See mod_learn_scrolly_example.R for an example. Requires scrollytell.css and scrollytell.js. This custom implementation is necessary because we need a R-based API (re: non JS) and current R packages do not support modules. +#' +#' @return html for the UI +#' @author Joseph Marlo, George Perrett +#' +#' @noRd +scroll_ui_container2 <- function(ns, ...){ + htmltools::div( + id = glue::glue('{ns(NULL)}scroll-container2'), + class = 'scroll-container', + ... + ) +} + +#' @noRd +#' @describeIn scroll_ui_container UI output for the visual (plots, tables, etc.) +scroll_ui_visual2 <- function(ns){ + id <- ns('scroll_visual2') + htmltools::div( + id = glue::glue('{id}-container'), + class = 'scroll-visual-container', + shiny::uiOutput(outputId = id) + ) +} + +#' @noRd +#' @describeIn scroll_ui_container runs the JS. For use on the UI side +use_scrollytell2 <- function(ns){ + # this adds the javascript listener for the module + moduleId <- ns(NULL) + js_code <- glue::glue( + .open = '<<', + .close = '>>', + 'scrolly.plotState.<> = 1; ', + '$(document).scroll(function() { + scrolly.scroll("<>") + }); ' + ) + js_tag <- shiny::tags$script(htmltools::HTML(js_code)) + return(js_tag) +} + diff --git a/thinkCausal/R/fct_ui.R b/thinkCausal/R/fct_ui.R index 5c473ca0..e94d67a5 100644 --- a/thinkCausal/R/fct_ui.R +++ b/thinkCausal/R/fct_ui.R @@ -7,6 +7,7 @@ #' @param section the title of the h3 section within the help markdown #' #' @return NULL; called for the JavaScript side effects +#' @author Joe Marlo #' @noRd open_help_sidebar <- function(store, section){ @@ -29,3 +30,29 @@ open_help_sidebar <- function(store, section){ ) return(NULL) } + +#' Add a red ribbon in the corner denoting beta status +#' +#' Must include corner-ribbon.css file in the /www folder +#' +#' @return html +#' @author Joe Marlo +#' @noRd +#' +#' @examples +#' # within app_UI +#' add_betta_ribbon() +add_beta_ribbon <- function(){ + + htmltools::tags$div( + class = 'cornerRibbon', + 'BETA', + htmltools::tags$div( + htmltools::tags$a( + href = 'https://docs.google.com/forms/d/e/1FAIpQLSd7dZjpw4FtoVAFUmovNOgKeW-kxnJrs3zV2r3lJ8kvhdq8lA/viewform?usp=sf_link', + target = "_blank", + 'Have feedback?' + ) + ) + ) +} diff --git a/thinkCausal/R/mod_analysis_design.R b/thinkCausal/R/mod_analysis_design.R deleted file mode 100644 index 5f5ab0ab..00000000 --- a/thinkCausal/R/mod_analysis_design.R +++ /dev/null @@ -1,305 +0,0 @@ -#' analysis_design UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_analysis_design_ui <- function(id) { - ns <- NS(id) - tagList(# shinyjs::useShinyjs(), - fluidRow( - column( - width = 3, - bs4Dash::box( - width = 12, - collapsible = FALSE, - title = 'Describe study design', - p('Before going any further, thinkCausal will need to know some information about the data you are analyzing'), - br(), - actionButton( - inputId = ns('analysis_design_help'), - label = 'Help me' - ), - uiOutput(outputId = ns('save_design_btn')) - ) - ), - column( - width = 9, - bs4Dash::box( - id = ns('box1'), - width = 12, - collapsible = FALSE, - title = 'Study design', - selectInput( - inputId = ns('analysis_design'), - label = 'Indicate the study design:', - choices = c( - "", - "Unsure", - 'Observational', - 'Randomized treatment', - 'Block randomized treatment' - ) - ), - HTML('
Advanced options (random effects & survey weights)'), - selectInput( - ns('analysis_random_intercept'), - label = create_info_icon( - 'Include random effects:', - 'Random effects often account for nested/clustered data: classes within schools or patients within medical practices.' - ), - choices = c("No", "Yes") - ), - conditionalPanel( - condition = "input.analysis_random_intercept == 'Yes'", - ns = ns, - selectInput( - ns('analysis_random_effect_variables'), - label = 'Slect all variables you would like to include as random effects:', - choices = NULL, - selected = NULL - ) - ), - selectInput( - inputId = ns('analysis_weights'), - label = create_info_icon( - 'Include survey weights:', - 'Survey weights are used in survey research when samples are not randomly drawn from the population of interest.' - ), - choices = c('No', 'Yes') - ), - conditionalPanel( - condition = "input.analysis_weights == 'Yes'", - ns = ns, - selectInput( - ns('analysis_weight_variable'), - label = 'Slect your survey weight variable:', - choices = NULL, - selected = NULL - ) - ), - HTML('

') - ) - ) - ) - ) -} - -#' analysis_design Server Functions -#' -#' @noRd -mod_analysis_design_server <- function(id, store) { - moduleServer(id, function(input, output, session) { - ns <- session$ns - - # open help on button click - observeEvent(input$analysis_design_help, { - open_help_sidebar(store, 'Study Design') - }) - - active_save_design <- reactive({ - entered <- sum( - input$analysis_design %notin% c(''), - input$analysis_weights %notin% c(''), - input$analysis_random_intercept %notin% c('') - ) - if (counter() == 0) { - if (entered == 3) - eval <- TRUE - else - eval <- FALSE - } else{ - if (update_design() != 3) - eval <- TRUE - else - eval <- FALSE - } - return(eval) - }) - - update_design <- reactive({ - sum( - store$analysis_design_design == input$analysis_design, - store$analysis_design_weights == input$analysis_weights, - store$analysis_design_random_effects == input$analysis_random_intercept - ) - }) - - output$save_design_btn <- renderUI({ - .class <- - if (isFALSE(active_save_design())) - 'btn-disabled' - else - 'nav-path' - .label <- - if (counter() == 0) - "Save & continue" - else - 'Update design' - actionButton( - inputId = ns("analysis_design_button_save_design"), - class = .class, - label = .label - ) - }) - - # release conditions for box 2 - counter <- reactiveVal(0) - observeEvent(input$analysis_design_button_save_design, { - counter(counter() + 1) - }) - - output$render_box2 <- reactive({ - counter() - }) - outputOptions(output, "render_box2", suspendWhenHidden = FALSE) - - - listen <- reactive({ - list( - input$treatment_name, - input$treatment_participants, - input$treatment_participants - ) - }) - observeEvent(listen(), { - if (sum(unlist(listen()) == "") < 3) { - updateActionButton(inputId = 'analysis_design_button_next', - label = 'Save & continue to Upload data') - } else{ - updateActionButton(inputId = 'analysis_design_button_next', - label = 'Skip & continue to Upload data') - } - }) - - - - # render example language - output$analysis_design_text <- renderText({ - # TODO: somehow clean these inputs - name <- input$treatment_name - units <- input$treatment_units - participants <- input$treatment_participants - - # set defaults - if (name == '') - name <- 'treatment condition' - if (units == '') - units <- 'units' - if (participants == '') - participants <- 'participants' - - # create the text - text_out <- paste0( - 'The ', - name, - ' led to an ', - 'increase/decrease', - ' of X ', - units, - ' for ', - participants, - ' in this study' - ) - text_out <- HTML(text_out) - - return(text_out) - }) - - - # save input and remove downstream dataframes if study design changes - observeEvent(input$analysis_design_button_save_design, { - # make sure required inputs have values - local({ - req_inputs <- c(#'analysis_design_estimand', - 'analysis_design', - 'analysis_weights', - 'analysis_random_intercept') - req_values <- reactiveValuesToList(input)[req_inputs] - - # trigger animation if any inputs is unsure or blank - inputs_to_animate <- - req_inputs[which(req_values == 'Unsure' | req_values == '')] - inputs_to_animate_selectors <- - paste0("#", ns(inputs_to_animate), " + div", collapse = ', ') - shinyjs::runjs( - glue::glue( - '$("<>").effect("shake", {times: 4, distance: 3})', - .open = "<<", - .close = ">>" - ) - ) - - # stop here if any unsures or blank inputs - all_complete <- !isTRUE(length(inputs_to_animate) > 0) - req(all_complete) - }) - - # save input to store - store$analysis_design_design <- input$analysis_design - store$analysis_design_weights <- input$analysis_weights - store$analysis_design_random_effects <- - input$analysis_random_intercept - store$analysis_design_treatment_name <- input$treatment_name - store$analysis_design_treatment_units <- input$treatment_units - store$analysis_design_treatment_participants <- - input$treatment_participants - - - # add to log - ## '\t', 'Causal estimand: ', input$analysis_design_estimand, '\n', - log_event <- paste0( - 'Set study design: \n', - '\t', - 'Treatment name: ', - input$treatment_name, - '\n', - '\t', - 'Outcome units: ', - input$treatment_units, - '\n', - '\t', - 'Participants name: ', - input$treatment_participants, - '\n', - '\t', - 'Study design: ', - input$analysis_design, - '\n', - '\t', - 'Survey weights: ', - input$analysis_weights, - '\n', - '\t', - 'Clustered or nested data: ', - input$analysis_random_intercept - ) - store$log <- append(store$log, log_event) - - # remove saved dataframes if they exist - # TODO: error here if user goes back and changes the estimand then saves the design - store <- remove_downstream_data(store, page = 'design') - - # update page - bs4Dash::updateTabItems(store$session_global, - inputId = 'sidebar', - selected = 'analysis_variable_selection') - }) - - - - # # open slide over if answer is unsure - # dropdown_inputs <- c("analysis_design_estimand", "analysis_design", "analysis_weights", "analysis_random_intercept") - # purrr::map(dropdown_inputs, function(input_id){ - # observeEvent(input[[input_id]], { - # if (input[[input_id]] == "Unsure") Sys.sleep(0.2); open_help_sidebar(store, 'Study Design') #shinyjs::runjs('openHelpSection("help-studydesign")') - # }) - # }) - - - return(store) - }) -} diff --git a/thinkCausal/R/mod_analysis_model.R b/thinkCausal/R/mod_analysis_model.R index a8351053..5700637b 100644 --- a/thinkCausal/R/mod_analysis_model.R +++ b/thinkCausal/R/mod_analysis_model.R @@ -11,15 +11,18 @@ mod_analysis_model_ui <- function(id){ ns <- NS(id) tagList( fluidRow( - bs4Dash::box( + column( width = 3, + bs4Dash::box( + width = 12, collapsible = FALSE, title = 'Specify model', selectInput(ns('analysis_model_estimand'), label = 'Select a causal estimand:', - choices = c('ATE - Average treatment effect' = 'ATE', - 'ATT - Average treatment effect on the treated' = 'ATT', - 'ATC - Average treatment effect on the control' = 'ATC')), + choices = c('', + 'ATE - Average treatment effect' = 'ATE', + 'ATT - Average treatment effect on the treated' = 'ATT', + 'ATC - Average treatment effect on the control' = 'ATC')), selectInput(ns('analysis_model_moderator_yes_no'), label = 'Pre-specify subgroup analyses:', choices = c("No", "Yes", 'Unsure')), @@ -35,16 +38,33 @@ mod_analysis_model_ui <- function(id){ label = "Fit model"), actionButton(inputId = ns('analysis_model_help'), label = 'Help me') - ), - bs4Dash::box( + ) + ), + column( width = 9, + bs4Dash::box( + width = 12, collapsible = FALSE, - title = 'Review your model', - p('More coming soon...') + title = 'Fitting a BART model in thinkCausal', + p('thinkCausal will estimate causal effects by using Bayesian Additive Regression Trees (BART), a flexible machine learning algorithm. BART estimates causal effects by making predictions for what would have happened to each individual if they had received the opposite treatment.'), + br(), + p('BART models are non-parametric, this means any interactions or non-linear relationships are automatically learned and included in the model. With the BART model fit in thinkCausal, you do not have to manually include interaction terms or squared terms or transformations of variables.'), + br(), + p('thinkCausal will automatically identify moderators of the treatment effect. A moderator is a variable where the treatment effect varies or changes across different values. While thinkCausal will automatically detect treatment effect moderation, if there are variables you belive are moderators you are encouraged to pre-specify them in the specify model controls.') + #, #verbatimTextOutput(ns('review')) + ), + bs4Dash::box( + width = 12, + collapsible = FALSE, + title = 'Review your model', + tags$head(tags$style(HTML("pre { white-space: pre-wrap; word-break: keep-all; }"))), + verbatimTextOutput(ns('review')) + ) ) + ) ) } @@ -93,30 +113,31 @@ mod_analysis_model_server <- function(id, store){ # model review page on left pannel output$review <- renderText({ - covariates <- paste0(c('re75', 're74'), collapse = '; ') + covariates <- paste0(store$column_assignments$x, collapse = ', ') + + excluded <- paste0(names(store$analysis_data_uploaded_df)[names(store$analysis_data_uploaded_df) %notin% c(store$column_assignments$x, store$column_assignments$z, store$column_assignments$y)], collapse = ', ') + design <- store$analysis_select_design + estimand <- ifelse(input$analysis_model_estimand == '', + 'You have not selected a causal estimand. You will need to make a selection before fitting your model.', + paste0('You are estimating the ', input$analysis_model_estimand) + ) + + treatment <- store$column_assignments$z + outcome <- store$column_assignments$y + + X <- ifelse(design == 'Observational Study (Treatment not Randomized)', 'Confounders', 'Covariates') glue::glue( " - You are testing if changing the TREATMENT causes a change in OUTCOME - by fitting a Bayesian Additive Regression Tree (BART).\n - Your data is from a DESIGN - You are not blocking on any variables. - You have not pre-specified any sub-group comparisons. - You are estimating the: INSERT ESTIMAND\n - Your model will control for: \n - \n\t{covariates} - - You are not controlling for:\n - \tNOT INCLUDED - - You have not specified any random effects of survey weights. - - BART models assume that all confounders are being controled for in the model. - OVERLAP (explan how we will test for overlap) - SUTVA - - BART models will automatically learn any interactions that exist in your data so you do not need to specify interaction effects. - BART models are inherently non-parametric and do not assume the relationship between predictors and the outcome is linear. - Specification of any polynomial terms are not needed. + Desigin: Your data is from a(n) {design}\n\t + Estimand: {estimand}\n\t + Causal Question: You are testing whether {treatment} causes changes in {outcome}.\n\t + + You are including the following variables in your model:\n\t + {covariates} + + You are not controlling for:\n\t + {excluded} + ") }) @@ -135,6 +156,14 @@ mod_analysis_model_server <- function(id, store){ }) } + if(input$analysis_model_estimand == ''){ + show_popup_model_no_estimand_warning(session, ns = ns) + observeEvent(input$analysis_model_estimand_button_popup, { + close_popup(session = session) + }) + + } + # make sure required inputs have values local({ req_inputs <- c( @@ -155,8 +184,7 @@ mod_analysis_model_server <- function(id, store){ # stop here if data hasn't been uploaded and selected validate_data_verified(store) - # TODO: stop here if inputs aren't found - # req(input$) + req(input$analysis_model_estimand) # save the estimand (again, also saved on the design page) store$analysis_design_estimand <- input$analysis_model_estimand @@ -194,7 +222,6 @@ mod_analysis_model_server <- function(id, store){ # ) # } # ) - bart_model <- fit_bart( .data = store$verified_df, .weights = store$column_assignments$weight, diff --git a/thinkCausal/R/mod_analysis_overlap.R b/thinkCausal/R/mod_analysis_overlap.R index 071e07f7..dc6f901c 100644 --- a/thinkCausal/R/mod_analysis_overlap.R +++ b/thinkCausal/R/mod_analysis_overlap.R @@ -33,7 +33,7 @@ mod_analysis_overlap_ui <- function(id){ checkboxInput( inputId = ns('trim'), label = 'Trim plot:', - value = TRUE + value = FALSE ) ), selectInput( diff --git a/thinkCausal/R/mod_analysis_results.R b/thinkCausal/R/mod_analysis_results.R index 0348b0ae..7a4cf99c 100644 --- a/thinkCausal/R/mod_analysis_results.R +++ b/thinkCausal/R/mod_analysis_results.R @@ -5,7 +5,6 @@ #' @param id,input,output,session Internal parameters for {shiny}. #' #' @noRd -#' #' @importFrom shiny NS tagList mod_analysis_results_ui <- function(id){ ns <- NS(id) diff --git a/thinkCausal/R/mod_analysis_subgroup.R b/thinkCausal/R/mod_analysis_subgroup.R index bdadbc01..10e67fe8 100644 --- a/thinkCausal/R/mod_analysis_subgroup.R +++ b/thinkCausal/R/mod_analysis_subgroup.R @@ -129,7 +129,13 @@ mod_analysis_subgroup_ui <- function(id){ plotOutput( outputId = ns('analysis_subgroup_plot'), height = 500 - ) + ), + conditionalPanel(condition = "input.analysis_subgroup_type == 'Exploratory subgroup analysis'", + ns = ns, + reactable::reactableOutput( + outputId = ns('analysis_subgroup_table') + ) + ) ) ) # end of main panel ) @@ -357,6 +363,42 @@ mod_analysis_subgroup_server <- function(id, store){ return(p) }) + output$analysis_subgroup_table <- reactable::renderReactable({ + validate_model_fit(store) + validate(need(input$analysis_subgroup_exploratory, '')) + .moderator <- store$verified_df[[paste0('X_', input$analysis_subgroup_exploratory)]] + + icate <- bartCause::extract(store$analysis$model$model, 'icate') + x <- store$verified_df[[paste0('X_', input$analysis_subgroup_exploratory)]] + if(store$analysis$model$analysis_model_estimand == 'ATT'){ + x <- x[store$verified_df$Z_treat == TRUE] + .moderator <- .moderator[store$verified_df$Z_treat == TRUE] + } + + if(store$analysis$model$analysis_model_estimand == 'ATC'){ + x <- x[store$verified_df$Z_treat == FALSE] + .moderator <- .moderator[store$verified_df$Z_treat == FALSE] + } + + subgroup <- vector() + estimate <- vector() + se <- vector() + lci <- vector() + uci <- vector() + for (i in 1:length(unique(.moderator))) { + post <- apply(icate[, x == unique(.moderator)[i]], 1, mean) + subgroup[i] <- paste0(input$analysis_subgroup_exploratory, ' = ', unique(.moderator)[i]) + estimate[i] <- round(mean(post), 4) + se[i] <- round(sd(post), 4) + lci[i] <- round(quantile(post, prob = .025), 4) + uci[i] <- round(quantile(post, prob = .975), 4) + + } + + data.frame(subgroup, estimate, se, lci, uci) %>% + reactable::reactable() + + }) output$analysis_subgroup_plot <- renderPlot({ diff --git a/thinkCausal/R/mod_analysis_upload.R b/thinkCausal/R/mod_analysis_upload.R index c31c4b5b..e3941599 100644 --- a/thinkCausal/R/mod_analysis_upload.R +++ b/thinkCausal/R/mod_analysis_upload.R @@ -114,7 +114,7 @@ mod_analysis_upload_server <- function(id, store){ # stop if not one of the accepted file types # this should be caught by fileInput() on the UI side - accepted_filetypes <- c('csv', 'txt', 'xlsx', 'dta', 'sav', 'Rdata', 'rds') + accepted_filetypes <- c('csv', 'txt', 'xlsx', 'dta', 'spss', 'sav', 'sas', 'Rdata', 'rds') validate(need( filetype %in% accepted_filetypes, paste( @@ -140,7 +140,7 @@ mod_analysis_upload_server <- function(id, store){ col_names = input$analysis_upload_data_header ) } else if (filetype == 'dta'){ - uploaded_file <- readstata13::read.dta13(file = filepath) + uploaded_file <- haven::read_dta(file = filepath) } else if (filetype == 'xlsx'){ uploaded_file <- openxlsx::read.xlsx(xlsxFile = filepath) } else if (filetype == 'txt'){ @@ -150,7 +150,11 @@ mod_analysis_upload_server <- function(id, store){ col_names = input$analysis_upload_data_header ) } else if (filetype == 'sav'){ - uploaded_file <- Hmisc::spss.get(file = filepath) + uploaded_file <- haven::read_sav(file = filepath) + } else if(filetype == 'spss'){ + uploaded_file <- haven::read_spss(file = filepath) + }else if(filetype == 'sas'){ + uploaded_file <- haven::read_sas(file = filepath) } else if(filetype == 'Rdata'){ e <- new.env() name <- load(file = filepath, envir = e) diff --git a/thinkCausal/R/mod_analysis_variable_selection.R b/thinkCausal/R/mod_analysis_variable_selection.R index da531657..40e87a0d 100644 --- a/thinkCausal/R/mod_analysis_variable_selection.R +++ b/thinkCausal/R/mod_analysis_variable_selection.R @@ -42,7 +42,7 @@ mod_analysis_variable_selection_ui <- function(id) { ns = ns, selectInput( inputId = ns('outcome_level'), - label = 'Define sucssess as:', + label = 'Define success as:', choices = NULL, selected = NULL ) @@ -103,14 +103,13 @@ mod_analysis_variable_selection_server <- function(id, store){ output$outcome_treatment_ui <- renderUI({ validate_data_uploaded(store, message = "You need to upload a dataset on the upload data page before you can select and outcome and treatment variable.") - fluidRow( column( width = 6, selectInput( inputId = ns('analysis_select_outcome'), - label = 'Select an outcome variable from you data', - choices = NULL, + label = 'Select an outcome variable from your data', + choices = c('', names(store$analysis_data_uploaded_df)), selected = NULL ) ), @@ -119,7 +118,7 @@ mod_analysis_variable_selection_server <- function(id, store){ selectInput( inputId = ns('analysis_select_treatment'), label = 'Select a treatment variable from you data', - choices = NULL, + choices = c('', names(store$analysis_data_uploaded_df)), selected = NULL ) ) @@ -147,13 +146,6 @@ mod_analysis_variable_selection_server <- function(id, store){ outputOptions(output, "need_outcome_info", suspendWhenHidden = FALSE) - observeEvent(input$analysis_select_outcome, { - - updateSelectInput(inputId = 'outcome_level', - choices = c('', paste(input$analysis_select_outcome, '=', unique(store$analysis_data_uploaded_df[[input$analysis_select_outcome]]))) - ) - }) - # identify if we need user to provide a treatment level output$need_treatment_info <- reactive({ req(input$analysis_select_treatment) @@ -166,10 +158,137 @@ mod_analysis_variable_selection_server <- function(id, store){ outputOptions(output, "need_treatment_info", suspendWhenHidden = FALSE) + + observeEvent(input$analysis_select_outcome, { + if (length(unique(na.omit(store$analysis_data_uploaded_df[[input$analysis_select_outcome]]))) <=2) { + updateSelectInput(inputId = 'outcome_level', + choices = c('', paste( + input$analysis_select_outcome, + '=', + unique(na.omit(store$analysis_data_uploaded_df[[input$analysis_select_outcome]])) + ))) + } else{ + # we need to do this for reasons related to feedback system input updating + updateSelectInput(inputId = 'outcome_level', + choices = c('not a binary variable')) + } + + }) + observeEvent(input$analysis_select_treatment, { - updateSelectInput(inputId = 'treatment_level', - choices = c('', paste(input$analysis_select_treatment, '=', unique(store$analysis_data_uploaded_df[[input$analysis_select_treatment]]))) + if (length(unique(na.omit(store$analysis_data_uploaded_df[[input$analysis_select_treatment]]))) <=2) { + updateSelectInput(inputId = 'treatment_level', + choices = c('', paste( + input$analysis_select_treatment, + '=', + unique(na.omit(store$analysis_data_uploaded_df[[input$analysis_select_treatment]])) + ))) + } else{ + # we need to do this for reasons related to feedback system input updating + updateSelectInput(inputId = 'treatment_level', + choices = c('not a binary variable')) + } + + }) + + + + + observe(feedback_outcome()) + + feedback_outcome <- reactive({ + req(input$analysis_select_outcome) + + isContinuous_Logical <- clean_detect_continuous_or_logical(store$analysis_data_uploaded_df[[input$analysis_select_outcome]]) + isBinary <- clean_detect_binary(store$analysis_data_uploaded_df[[input$analysis_select_outcome]]) + if(isTRUE(isBinary)){ + possibleLevels <- unique(na.omit(store$analysis_data_uploaded_df[[input$analysis_select_outcome]])) + currentLevel <- gsub(paste(input$analysis_select_outcome,'= '), '', input$outcome_level) + }else{ + possibleLevels <- TRUE + currentLevel <- FALSE + } + + status <- dplyr::case_when( + isTRUE(isContinuous_Logical) ~ 'pass', + isTRUE(isBinary) & isFALSE(currentLevel %in% possibleLevels) ~ 'warn', + isTRUE(isBinary) & isTRUE(currentLevel %in% possibleLevels) ~ 'pass', + T ~ 'fail' + ) + + shinyFeedback::hideFeedback("analysis_select_outcome") + + if(status == 'pass'){ + shinyFeedback::showFeedbackSuccess(inputId = 'analysis_select_outcome', text = paste(input$analysis_select_outcome, 'is either a continuous or binary variable.')) + } + if(status == 'warn'){ + shinyFeedback::showFeedbackWarning(inputId = 'analysis_select_outcome', text = paste(input$analysis_select_outcome, "appears to be a catagorical variable with two levels.
Before moving on, you'll need to indicate which level represents a sucess.")) + + } + if(status == 'fail'){ + shinyFeedback::showFeedbackDanger(inputId = 'analysis_select_outcome', text = 'At this point in time, thinkCausal only handles continuous or binary outcomes.
In order to continue, select a continuous or binary outcome.') + } + + if(input$analysis_select_treatment == input$analysis_select_outcome){ + shinyFeedback::showFeedbackDanger(inputId = 'analysis_select_outcome', text = 'The treatment and outcome must be different variables. Select a different treatment or a different outcome before continuing.') + } + + shinyFeedback::hideFeedback("outcome_level") + if(currentLevel %in% possibleLevels){ + shinyFeedback::showFeedbackSuccess(inputId = 'outcome_level', text = paste(input$outcome_level, 'will be automatically recoded so that', currentLevel, '= TRUE and', possibleLevels[possibleLevels!= currentLevel], '= FALSE.')) + } + + }) + + + + + + observe(feedback_treatment()) + + feedback_treatment <- reactive({ + req(input$analysis_select_treatment) + isLogical <- clean_detect_logical(store$analysis_data_uploaded_df[[input$analysis_select_treatment]]) + isBinary <- clean_detect_binary(store$analysis_data_uploaded_df[[input$analysis_select_treatment]]) + if(isTRUE(isBinary)){ + possibleLevels <- unique(na.omit(store$analysis_data_uploaded_df[[input$analysis_select_treatment]])) + currentLevel <- gsub(paste(input$analysis_select_treatment,'= '), '', input$treatment_level) + }else{ + possibleLevels <- TRUE + currentLevel <- FALSE + } + + status <- dplyr::case_when( + isTRUE(isLogical) ~ 'pass', + isTRUE(isBinary) & isFALSE(currentLevel %in% possibleLevels) ~ 'warn', + isTRUE(isBinary) & currentLevel %in% possibleLevels ~ 'pass', + T ~ 'fail' ) + + shinyFeedback::hideFeedback("analysis_select_treatment") + + if(status == 'pass'){ + shinyFeedback::showFeedbackSuccess(inputId = 'analysis_select_treatment', text = paste(input$analysis_select_treatment, 'is a binary variable.')) + } + if(status == 'warn'){ + shinyFeedback::showFeedbackWarning(inputId = 'analysis_select_treatment', text = paste(input$analysis_select_treatment, "appears to be a catagorical variable with two levels.
Before moving on, you'll need to indicate which level represents receiving the treatment.")) + + } + if(status == 'fail'){ + shinyFeedback::showFeedbackDanger(inputId = 'analysis_select_treatment', text = 'At this point in time, thinkCausal only handles binary treatments.
In order to continue, select a binary treatment.') + } + + if(input$analysis_select_treatment == input$analysis_select_outcome){ + shinyFeedback::showFeedbackDanger(inputId = 'analysis_select_treatment', text = 'The treatment and outcome must be different variables. Select a different treatment or a different outcome before continuing.') + } + + shinyFeedback::hideFeedback("treatment_level") + if(currentLevel %in% possibleLevels){ + shinyFeedback::showFeedbackSuccess(inputId = 'treatment_level', text = paste(input$analysis_select_treatment, 'will be automatically recoded so that', currentLevel, '= TRUE and', possibleLevels[possibleLevels!=currentLevel],'= FALSE.')) + } + + + }) @@ -193,10 +312,9 @@ mod_analysis_variable_selection_server <- function(id, store){ label = 'Indicate the study design:', choices = c( "", - "Unsure", - 'Observational', - 'Randomized treatment', - 'Block randomized treatment' + 'Observational Study (Treatment not Randomized)', + 'Completely Randomized Experement', + 'Block Randomized Experement' ) ), HTML('
Advanced options (random effects & survey weights)'), @@ -221,41 +339,7 @@ mod_analysis_variable_selection_server <- function(id, store){ }) - - # update outcome, treatment, weight and ran_eff options - observeEvent(input$analysis_select_treatment, { - updateSelectInput( - inputId = 'analysis_select_outcome', - selected = input$analysis_select_outcome, - choices = c('', names(store$analysis_data_uploaded_df)[names(store$analysis_data_uploaded_df) != input$analysis_select_treatment]) - ) - }) - - # update outcome, treatment, weight and ran_eff options - observeEvent(input$analysis_select_outcome, { - updateSelectInput( - inputId = 'analysis_select_treatment', - selected = input$analysis_select_treatment, - choices = c('', names(store$analysis_data_uploaded_df)[names(store$analysis_data_uploaded_df) != input$analysis_select_outcome]) - ) - }) - - - observeEvent(store$analysis_data_uploaded_df, { - updateSelectInput( - inputId = 'analysis_select_treatment', - selected = input$analysis_select_treatment, - choices = c('', names(store$analysis_data_uploaded_df)[names(store$analysis_data_uploaded_df) != input$analysis_select_outcome]) - ) - - updateSelectInput( - inputId = 'analysis_select_outcome', - selected = input$analysis_select_outcome, - choices = c('', names(store$analysis_data_uploaded_df)[names(store$analysis_data_uploaded_df) != input$analysis_select_treatment]) - ) - }) - - defaults <- reactiveValues(.default_blocks = NULL, + defaults <- reactiveValues(.default_blocks = NULL, .default_random_effects = NULL, .default_weight = NULL) @@ -360,14 +444,9 @@ mod_analysis_variable_selection_server <- function(id, store){ replacement = '', treatment_level ) - # recode data - store$analysis_data_uploaded_df[[cols_z[1]]] <- - ifelse(store$analysis_data_uploaded_df[[cols_z[1]]] == treatment_level, - TRUE, - FALSE) } } else{ - treatment_level <- 'variable is already logical or coded as 1/0' + treatment_level <- NULL } is_binary @@ -392,14 +471,9 @@ mod_analysis_variable_selection_server <- function(id, store){ replacement = '', outcome_level ) - # recode data - store$analysis_data_uploaded_df[[cols_y[1]]] <- - ifelse(store$analysis_data_uploaded_df[[cols_y[1]]] == outcome_level, - TRUE, - FALSE) } }else{ - outcome_level <- 'outcome is continuous' + outcome_level <- NULL } is_cont_binary }, @@ -442,6 +516,16 @@ mod_analysis_variable_selection_server <- function(id, store){ # store the new dataframe using the uploaded df as the template store$analysis_data_assigned_df <- store$analysis_data_uploaded_df[, all_cols] + # recode treatment/outcome if needed + if(!is.null(treatment_level)){ + store$analysis_data_assigned_df[[cols_z]] <- ifelse(store$analysis_data_assigned_df[[cols_z]] == treatment_level, TRUE, FALSE) + } + + if(!is.null(outcome_level)){ + store$analysis_data_assigned_df[[cols_y]] <- ifelse(store$analysis_data_assigned_df[[cols_y]] == outcome_level, TRUE, FALSE) + } + + # save columns assignments store$column_assignments <- NULL store$column_assignments$z <- cols_z @@ -455,9 +539,9 @@ mod_analysis_variable_selection_server <- function(id, store){ log_event <- paste0('Assigned columns to roles: ', '\n\tdesign: ', input$analysis_design, '\n\ttreatment: ', cols_z, - '\n\ttreatment level:', treatment_level, + '\n\ttreatment level: ', ifelse(is.null(treatment_level), 'variable is already logical or coded as 1/0', treatment_level), '\n\tresponse: ', cols_y, - '\n\tresponse success:', outcome_level, + '\n\tresponse success:', ifelse(is.null(outcome_level), 'outcome is continuous', outcome_level), '\n\tcovariates: ', paste0(cols_x, collapse = '; '), '\n\tsurvey weight: ', cols_weight, '\n\trandom intercepts: ', paste0(cols_ran_eff, collapse = '; '), diff --git a/thinkCausal/R/mod_home.R b/thinkCausal/R/mod_home.R index de2cedd3..72e3004b 100644 --- a/thinkCausal/R/mod_home.R +++ b/thinkCausal/R/mod_home.R @@ -33,7 +33,7 @@ mod_home_ui <- function(id){ img(src = 'www/img/thumbnails/randomization.png', width = '100%'), ), - "Interactively learn the foundational concepts of casual inference." + "Interactively learn the foundational concepts of causal inference." ), actionButton(inputId = ns('learn_start'), label = 'Start learning!', diff --git a/thinkCausal/R/mod_learn_colinearity.R b/thinkCausal/R/mod_learn_colinearity.R new file mode 100644 index 00000000..a69328af --- /dev/null +++ b/thinkCausal/R/mod_learn_colinearity.R @@ -0,0 +1,135 @@ +#' learn_colinearity UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_colinearity_ui <- function(id){ + ns <- NS(id) + tagList( + use_scrollytell(ns = ns), + div(class = 'learning-page', + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + includeMarkdown(app_sys("app", "www", "learn", "colinearity", "markdowns", 'intro.md')), + br(), br(), br(), br(), + ), + scroll_ui_container( + ns = ns, + scroll_ui_text( + ns = ns, + scroll_ui_text_section( + ns = ns, + position = 1, + includeMarkdown(app_sys("app", "www", "learn", "colinearity", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 2, + includeMarkdown(app_sys("app", "www", "learn", "colinearity", "markdowns", 'section2.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 3, + includeMarkdown(app_sys("app", "www", "learn", "colinearity", "markdowns", 'section3.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 4, + includeMarkdown(app_sys("app", "www", "learn", "colinearity", "markdowns", 'section3.md')) + ) + ), + scroll_ui_visual(ns = ns, clickable = T) + ) + ) + ) +} + +#' learn_colinearity Server Functions +#' +#' @noRd +mod_learn_colinearity_server <- function(id, id_parent = 'learn_variable_selection'){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + #ns <- NS(NS(id_parent)(id)) + + dat <- readr::read_csv('inst/extdata/colinearity.csv') + dat$ITE <- with(dat, Y1 - Y0) + dat$runner <- 1:500 + dat <- dat %>% dplyr::select(runner, dplyr::everything()) + + output$scroll_visual <- renderUI({ + items <- list() + + items$position1 <- div( + style = 'visibility: visible;', + reactable::renderReactable({ + reactable::reactable(data = dat %>% + dplyr::mutate(Y0 = ifelse(hyperShoe == 1, NA, Y0), + Y1 = ifelse(hyperShoe == 0, NA, Y1) + )) + }) + ) + + items$position2 <- div( + style = 'visibility: hidden;', + renderImage( + list(src = app_sys('app', 'www/learn/colinearity/plots/p1.png'), + contentType = 'image/png', + width = 800, + height = 500) + , deleteFile = F) + ) + + + items$position3 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view'), label = NULL, + choices = c('Researcher', 'Parallel Universe', 'Oracle'), + selected = 'Researcher', + individual = T + ) + }), + renderUI({ + radioButtons( + 'show', + label = NULL, + choices = c('table', 'plot'), + inline = TRUE + ) + }), + reactable::renderReactable( + switch (input$view, + 'Researcher' = create_table_researcher(df = dat[, names(dat)!='ITE'], imputed = F, rows = 10), + 'Parallel Universe' = create_table_parallel(df = dat[, names(dat)!='ITE'], rows = 10), + 'Oracle' = create_table_oracle(df = dat, rows = 10, imputed = FALSE) + ) + + ) + ) + + items$position4 <- div( + renderUI({ + checkboxGroupInput('analysis', label = 'Analyses Options') + }) + ) + + return(items) + }) + + + + }) +} + +## To be copied in the UI +# mod_learn_colinearity_ui("learn_colinearity_1") + +## To be copied in the server +# mod_learn_colinearity_server("learn_colinearity_1") diff --git a/thinkCausal/R/mod_learn_estimands.R b/thinkCausal/R/mod_learn_estimands.R index ab4e928a..ff5c319f 100644 --- a/thinkCausal/R/mod_learn_estimands.R +++ b/thinkCausal/R/mod_learn_estimands.R @@ -7,19 +7,20 @@ #' @noRd #' #' @importFrom shiny NS tagList +#' mod_learn_estimands_ui <- function(id){ ns <- NS(id) tagList( - div( class = 'learning-page', - # UI content for the learning module div( class = ns('learning-content'), # required class = 'learning-content', # required + style = 'display: block;', includeMarkdown(app_sys("app", "www", "learn", "estimands", "markdowns", 'estimands_1.md')), - br(),br(),br(),br(),br(),br(), + br(),br(),br(),br(),br(),br() + ), div( @@ -44,9 +45,10 @@ mod_learn_estimands_ui <- function(id){ class = ns('learning-content'), # required class = 'learning-content', # required br(),br(),br(), br(), + style = 'display: block;', includeMarkdown(app_sys("app", "www", "learn", "estimands", "markdowns", 'estimands_attatc.md')), # the quiz UI - mod_quiz_ui(id = ns('quiz')), + shinyQuiz::quiz_ui(quiz_content_estimands) ), br(), div( @@ -66,19 +68,21 @@ mod_learn_estimands_ui <- function(id){ mod_learn_estimands_server <- function(id){ moduleServer( id, function(input, output, session){ ns <- session$ns + shinyQuiz::quiz_server(quiz_content_estimands) # run the quiz - mod_quiz_server( - id = "quiz", # this should always be quiz - id_parent = module_ids$learn$estimands, - question_texts = quiz_content_estimands$question_texts, - question_prompts = quiz_content_estimands$question_prompts, - correct_answers = quiz_content_estimands$correct_answers, - message_correct = quiz_content_estimands$message_correct, - message_wrong = quiz_content_estimands$message_wrong, - message_skipped = quiz_content_estimands$message_skipped, - embed_quiz = TRUE - ) + # mod_quiz_server( + # id = "quiz", # this should always be quiz + # id_parent = module_ids$learn$estimands, + # question_texts = quiz_content_estimands$question_texts, + # question_prompts = quiz_content_estimands$question_prompts, + # correct_answers = quiz_content_estimands$correct_answers, + # # graders = quiz_content_estimands$graders, + # message_correct = quiz_content_estimands$message_correct, + # message_wrong = quiz_content_estimands$message_wrong, + # message_skipped = quiz_content_estimands$message_skipped, + # embed_quiz = TRUE + # ) }) diff --git a/thinkCausal/R/mod_learn_estimands2.R b/thinkCausal/R/mod_learn_estimands2.R new file mode 100644 index 00000000..6c6f00d4 --- /dev/null +++ b/thinkCausal/R/mod_learn_estimands2.R @@ -0,0 +1,527 @@ +#' learn_estimands2 UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList + +mod_learn_estimands2_ui<- function(id){ + ns <- NS(id) + tagList( + use_scrollytell(ns = ns), + use_scrollytell2(ns = ns), + div( + class = 'learning-page', + + # UI content for the learning module + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'intro.md')), + br(),br(),br(),br() + ), + + scroll_ui_container( + ns = ns, + scroll_ui_text( + ns = ns, + scroll_ui_text_section( + ns = ns, + position = 1, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 2, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section2.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 3, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section3.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 4, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section4.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 5, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section5.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 6, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section6.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 7, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section7.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 8, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section8.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 9, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section9.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 10, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section10.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 11, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section11.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 12, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section12.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 13, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section13.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 14, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section14.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 15, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section15.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 16, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section16.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 17, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section17.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 18, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section18.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 19, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section19.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 20, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section20.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 21, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section21.md')) + ), + scroll_ui_quiz_section( + ns = ns, + position = 22, + div( + mod_quiz_ui(id = ns('quiz')), + br(), + br(), + br() + #includeMarkdown(app_sys("app", "www", "learn", "post-treatment", "markdowns", 'post_treatment_citations.md')), + #includeMarkdown(app_sys("app", "www", "learn", "post-treatment", "markdowns", 'post_treatment_learn_more.md')) + ) + ), + scroll_ui_text_section( + ns = ns, + position = 23, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 24, + includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section2.md')) + ), + + ), + scroll_ui_visual(ns = ns, clickable = T) + ) + #, scroll_ui_container2( + # ns = ns, + # scroll_ui_text( + # ns = ns, + # scroll_ui_text_section( + # ns = ns, + # position = 22, + # includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section1.md')) + # ), + # scroll_ui_text_section( + # ns = ns, + # position = 23, + # includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section2.md')) + # ), + # scroll_ui_text_section( + # ns = ns, + # position = 24, + # includeMarkdown(app_sys("app", "www", "learn", "estimands2", "markdowns", 'section3.md')) + # ) + # ), + # scroll_ui_visual2(ns = ns) + # ) + + ) + ) +} + +#' learn_estimands2 Server Functions +#' +#' @noRd +#' +mod_learn_estimands2_server <- function(id){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + + # run the quiz + shinyQuiz::quiz_server(quiz_content_estimands2) + + # mod_quiz_server( + # id = "quiz", # this should always be quiz + # id_parent = module_ids$learn$estimands2, + # questions = quiz_content_estimands2$questions, + # # question_texts = quiz_content_post_treatment$question_texts, + # # question_prompts = quiz_content_post_treatment$question_prompts, + # # correct_answers = quiz_content_post_treatment$correct_answers, + # # graders = quiz_content_post_treatment$graders, + # message_correct = quiz_content_estimands2$message_correct, + # message_wrong = quiz_content_estimands2$message_wrong, + # message_skipped = quiz_content_estimands2$message_skipped, + # embed_quiz = TRUE, + # sandbox_mode = FALSE # TODO: test + # ) + # mod_quiz_server( + # id = "quiz", # this should always be quiz + # id_parent = module_ids$learn$estimands2, + # question_texts = quiz_content_estimands2$question_texts, + # question_prompts = quiz_content_estimands2$question_prompts, + # correct_answers = quiz_content_estimands2$correct_answers, + # message_correct = quiz_content_estimands2$message_correct, + # message_wrong = quiz_content_estimands2$message_wrong, + # message_skipped = quiz_content_estimands2$message_skipped, + # embed_quiz = TRUE, + # sandbox_mode = TRUE #TODO: change to false. Currently just for testing + # ) + + output$scroll_visual <- renderUI({ + items <- list() + # item 1 + items$position1 <- div( + style = 'visibility: visible;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p1.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 2 + items$position2 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p2.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 3 + items$position3 <- div( + style = 'visibility: hidden;', + # TODO: note this is not clickable b/c scroll_ui_visual(clickable = FALSE) + reactable::renderReactable({ + readr::read_csv('inst/extdata/estimands2_table1.csv') %>% + reactable::reactable() + }) + ) + + # item 4 + items$position4 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p3.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 5 + items$position5 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p4.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 6 + items$position6 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p5.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 7 + items$position7 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p6.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 8 + items$position8 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p7.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 9 + items$position9 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/estimands2_table2.csv') %>% + reactable::reactable() + }) + ) + + # item 10 + items$position10 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p10.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 11 + items$position11 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p11.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 12 + items$position12 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p12.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 13 + items$position13 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p13.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 14 + items$position14 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p14.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 15 + items$position15 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p15.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 16 + items$position16 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p16.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 17 + items$position17 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p17.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 18 + items$position18 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p18.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 19 + items$position19 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p19.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 20 + items$position20 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/estimands2_table3.csv') %>% + reactable::reactable() + }) + ) + + # item 21 + items$position21 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p15.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 22 + items$position22 <- div( + style = 'visibility: hidden;', + NULL # b/c this is a quiz chunk + ) + + # item 21 + items$position23 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/no_overlap.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + # item 21 + items$position24 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/estimands2/plots/p2.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + + return(items) + }) + + # output$scroll_visual2 <- renderUI({ + # items <- list() + # # item 1 + # items$position22 <- div( + # style = 'visibility: hidden;', + # renderImage({ + # list(src = app_sys('app', 'www/learn/estimands2/plots/p1.png'), + # contentType = 'image/png', + # width = 800, + # height = 500) + # }, deleteFile = F) + # ) + # + # # item 2 + # items$position23 <- div( + # style = 'visibility: hidden;', + # renderImage({ + # list(src = app_sys('app', 'www/learn/estimands2/plots/p2.png'), + # contentType = 'image/png', + # width = 800, + # height = 500) + # }, deleteFile = F) + # ) + # + # # item 3 + # items$position24 <- div( + # style = 'visibility: hidden;', + # reactable::renderReactable({ + # readr::read_csv('inst/extdata/estimands2_table1.csv') %>% + # reactable::reactable() + # }) + # ) + # + # return(items) + # + # }) + + }) +} + diff --git a/thinkCausal/R/mod_learn_fundamental.R b/thinkCausal/R/mod_learn_fundamental.R new file mode 100644 index 00000000..654f5127 --- /dev/null +++ b/thinkCausal/R/mod_learn_fundamental.R @@ -0,0 +1,805 @@ +#' mod_learn_fundemental UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_fundamental_ui <- function(id){ + ns <- NS(id) + tagList( + use_scrollytell(ns = ns), + div(class = 'learning-page', + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'intro.md')), + br(),br(),br(),br() + ), + + scroll_ui_container( + ns = ns, + scroll_ui_text( + ns = ns, + scroll_ui_text_section( + ns = ns, + position = 1, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 2, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section2.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 3, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section3.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 4, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section4.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 5, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section5.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 6, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section6.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 7, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section7.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 8, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section8.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 9, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section9.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 10, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section10.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 11, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section11.md')) + ), + # scroll_ui_text_section( + # ns = ns, + # position = 12, + # includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section12.md')) + # ), + scroll_ui_text_section( + ns = ns, + position = 12, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section13.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 13, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section14.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 14, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section15.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 15, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section16.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 16, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section17.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 17, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section18.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 18, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section19.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 19, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section19.md')) + ) + ), + scroll_ui_visual(ns = ns, clickable = T) + ), + + br(),br(),br(),br(), + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + #includeMarkdown(app_sys("app", "www", "learn", "fundamental", "markdowns", 'intro.md')), + br(),br(),br(),br() + ) + ) + + ) +} + +#' mod_learn_fundamental Server Functions +#' +#' @noRd +mod_learn_fundamental_server <- function(id){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + + # load in everything we need + datImputed <- readr::read_csv('inst/extdata/fundamental_table2.csv') %>% + dplyr::mutate(estITE = Y1 - Y0) + datTruth <- readr::read_csv('inst/extdata/truth.csv') + datCombined <- data.frame( + datImputed[, 1:3], + estY0 = datImputed$Y0, + Y0 = datTruth$Y0, + estY1 = datImputed$Y1, + Y1 = datTruth$Y1, + Y = datImputed$Y, + estITE = datImputed$Y1 - datImputed$Y0 + ) + shinyQuiz::quiz_server(quiz_content_fundamental) + + tab1 <- readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 2) %>% + dplyr::mutate(Y0 = ifelse(hyperShoe == 1, '?', Y0), + Y1 = ifelse(hyperShoe == 0, '?', Y1)) + + + + correct1 <- c(250, 259, 250, 259, 259, 259, 259) + interactive_table1 <- create_interactive_table(tab1, correct_answers = correct1) + + tab2 <- readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 3) %>% + dplyr::mutate(Y0 = ifelse(hyperShoe == 1, '?', Y0), + Y1 = ifelse(hyperShoe == 0, '?', Y1)) + correct2 <- c(250, 250, 223) + interactive_table2 <- create_interactive_table(tab2, correct_answers = correct2) + + + + output$scroll_visual <- renderUI({ + items <- list() + # item 1 + items$position1 <- div( + style = 'visibility: visible;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + reactable::reactable(defaultPageSize = 10) + }) + ) + + # item 2 + items$position2 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/fundamental_table1.csv')[1,] %>% + reactable::reactable() + }) + ) + + # item 3 + items$position3 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/fundamental_table1.csv')[2,] %>% + reactable::reactable() + }) + ) + + + items$position4 <- div( + style = 'visibility: hidden;', + reactable::renderReactable( + readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + reactable::reactable(defaultPageSize = 5) + ), + renderImage( + list(src = app_sys('app', 'www/learn/fundemental/plots/p1.png'), + contentType = 'image/png', + width = 640, + height = 400) + , deleteFile = F) + ) + + items$position5 <- div( + style = 'visibility: hidden;', + reactable::renderReactable( + readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 0) %>% + dplyr::select(-Y, -Y1) %>% + reactable::reactable(defaultPageSize = 7) + ), + renderImage( + list(src = app_sys('app', 'www/learn/fundemental/plots/p2.png'), + contentType = 'image/png', + width = 640, + height = 400) + , deleteFile = F) + ) + + imputedY0 <- "#2297E6" + Y0_pal <- function(x) ifelse(dat3$Z == 1, imputedY0, '#FFFFFF') + dat6 <- readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 0) %>% + dplyr::select(-Y, -Y1) + dat6$Y0[is.na(dat6$Y0)] <- 281 + + items$position6 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/fundemental/plots/p3.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + items$position7 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(dat6, defaultPageSize = 7, columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (dat6$hyperShoe[index] == 1) { + color <- imputedY0 + } else if (dat6$hyperShoe[index] == 0) { + color <- NULL + } + list(color = color) + }) + )) + }) + ) + + items$position8 <- div( + style = 'visibility: hidden;', + reactable::renderReactable( + readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 0) %>% + dplyr::select(-Y, -Y0) %>% + reactable::reactable(defaultPageSize = 7) + ), + renderImage( + list(src = app_sys('app', 'www/learn/fundemental/plots/p_pre4.png'), + contentType = 'image/png', + width = 640, + height = 400) + , deleteFile = F) + ) + + items$position9 <- div( + style = 'visibility: hidden;', + renderImage( + list(src = app_sys('app', 'www/learn/fundemental/plots/p4.png'), + contentType = 'image/png', + width = 800, + height = 500) + , deleteFile = F) + ) + + + imputedY1 <- "#DF536B" + dat10 <- readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 0) %>% + dplyr::select(-Y, -Y0) + dat10$Y1[is.na(dat10$Y1)] <- 270 + + items$position10 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(dat10, defaultPageSize = 7, columns = list( + Y1 = reactable::colDef( + style = function(value, index) { + if (dat10$hyperShoe[index] == 0) { + color <- imputedY1 + } else if (dat10$hyperShoe[index] == 1) { + color <- NULL + } + list(color = color) + }) + )) + }) + ) + + dat11 <- readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 0) + + dat11$Y1[is.na(dat11$Y1)] <- 270 + dat11$Y0[is.na(dat11$Y0)] <- 281 + + + items$position11 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(dat11, defaultPageSize = 7, columns = list( + Y1 = reactable::colDef( + style = function(value, index) { + if (dat11$hyperShoe[index] == 0) { + color <- imputedY1 + } else if (dat11$hyperShoe[index] == 1) { + color <- NULL + } + list(color = color) + }), + Y0 = reactable::colDef( + style = function(value, index) { + if (dat11$hyperShoe[index] == 1) { + color <- imputedY0 + } else if (dat11$hyperShoe[index] == 0) { + color <- NULL + } + list(color = color) + } + ) + )) + }) + ) + + # dat12 <- readr::read_csv('inst/extdata/fundamental_table1.csv') + # dat12$Y1[is.na(dat12$Y1) & dat12$`prior races` == 0] <- 270 + # dat12$Y0[is.na(dat12$Y0) & dat12$`prior races` == 0] <- 281 + # + # items$position12 <- div( + # style = 'visibility: hidden;', + # reactable::renderReactable({ + # reactable::reactable(dat12, defaultPageSize = 5, columns = list( + # Y0 = reactable::colDef( + # style = function(value, index) { + # if (dat12$hyperShoe[index] == 1 & dat12$`prior races`[index] == 0) { + # color <- imputedY0 + # } else { + # color <- NULL + # } + # list(color = color) + # }), + # Y1 = reactable::colDef( + # style = function(value, index) { + # if (dat12$hyperShoe[index] == 0 & dat12$`prior races`[index] == 0) { + # color <- imputedY1 + # } else { + # color <- NULL + # } + # list(color= color) + # }) + # )) + # }), + # renderImage( + # list(src = app_sys('app', 'www/learn/fundemental/plots/p1.png'), + # contentType = 'image/png', + # width = 640, + # height = 400) + # , deleteFile = F) + # ) + + + dat13 <- readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + dplyr::filter(`prior races` == 1) + dat13$Y1[is.na(dat13$Y1) & dat13$`prior races` == 1] <- 273 + dat13$Y0[is.na(dat13$Y0) & dat13$`prior races` == 1] <- 280 + + items$position12 <- div( + style = 'visibility: hidden;', + renderImage( + list(src = app_sys('app', 'www/learn/fundemental/plots/p5.png'), + contentType = 'image/png', + width = 640, + height = 400) + , deleteFile = F), + reactable::renderReactable({ + reactable::reactable(dat13, columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (dat13$hyperShoe[index] == 1 & dat13$`prior races`[index] == 1) { + color <- imputedY0 + } else { + color <- NULL + } + list(color = color) + }), + Y1 = reactable::colDef( + style = function(value, index) { + if (dat13$hyperShoe[index] == 0 & dat13$`prior races`[index] == 1) { + color <- imputedY1 + } else { + color <- NULL + } + list(color = color) + }) + )) + }) + ) + + items$position13 <- div( + style = 'visibility: hidden;', + fluidRow( + column(8, + renderUI({ + HTML(interactive_table1) + }) + ), + column(4, + renderPlot({ + readr::read_rds(app_sys('app', 'www/learn/fundemental/plots/p6.rds')) + }, height = 500, width = 400) + ) + ) + + ) + + items$position14 <- div( + style = 'visibility: hidden;', + fluidRow( + column(8, + renderUI({ + HTML(interactive_table2) + }) + ), + column(4, + renderPlot({ + readr::read_rds(app_sys('app', 'www/learn/fundemental/plots/p7.rds')) + }, height = 500, width = 400) + ) + ) + + ) + + + items$position15 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable( + datImputed %>% dplyr::select(-estITE), + defaultPageSize = 20, + #class = 'small', + theme = reactable::reactableTheme(cellPadding = "1px 6px"), + columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (datImputed$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- NULL + } + list(color = color) + } + ), + Y1 = reactable::colDef( + style = function(value, index) { + if (datImputed$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- NULL + } + list(color = color) + } + ) + ) + ) + }) + ) + + + items$position16 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable( + datImputed, + fullWidth = FALSE, + defaultPageSize = 20, + #class = 'small', + theme = reactable::reactableTheme(cellPadding = "1px 6px"), + defaultColDef = reactable::colDef( + footerStyle = list(fontWeight = "bold", + color = list(NULL, imputedY0, imputedY1, NULL) + ), + ), + columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (datImputed$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- NULL + } + list(color = color) + } + ), + Y1 = reactable::colDef( + style = function(value, index) { + if (datImputed$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- NULL + } + list(color = color) + } + ), + estITE = reactable::colDef( + name = 'estimated ITE' + ) + ) + ) + }) + ) + + + + items$position17 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable( + datImputed, + fullWidth = FALSE, + defaultPageSize = 20, + #class = 'small', + theme = reactable::reactableTheme(cellPadding = "1px 6px"), + defaultColDef = reactable::colDef( + footerStyle = list(fontWeight = "bold", + color = list(NULL, imputedY0, imputedY1, NULL) + ), + ), + columns = list( + runner = reactable::colDef( + footer = 'Average' + ), + Y0 = reactable::colDef( + footer = round(mean(datImputed$Y0), 1), + style = function(value, index) { + if (datImputed$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- NULL + } + list(color = color) + } + ), + Y1 = reactable::colDef( + footer = round(mean(datImputed$Y1), 1), + style = function(value, index) { + if (datImputed$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- NULL + } + list(color = color) + } + ), + estITE = reactable::colDef( + name = 'estimated ITE', + footer = round(mean(datImputed$Y1 - datImputed$Y0), 1) + ) + ) + ) + }) + ) + + items$position18 <- div( + fluidRow( + renderUI({ + shinyWidgets::radioGroupButtons(ns('view'), label = NULL, + choices = c('Researcher', 'Parallel Universe', 'Oracle'), + selected = 'Researcher', + individual = T + ) + }) + # ,renderUI({ + # selectizeInput( + # inputId = ns('cols'), + # label = 'pick some ol columns:', + # choices = c(names(datCombined), 'estITE', 'ITE'), + # selected = c(names(datCombined)[3:length(datCombined)], 'estITE', 'ITE'), + # multiple = TRUE, + # options = list(maxItems = 7, + # plugins = list('remove_button', 'drag_drop')) + # ) + # }) + ), + renderUI({ + shinyWidgets::materialSwitch( + inputId = ns("imputed"), + label = "Show imputed potential outcomes", + status = "primary", + right = TRUE, + value = TRUE + ) + }), + reactable::renderReactable({ + req(input$view) + switch ( + input$view, + 'Researcher' = create_table_researcher(df = datImputed, imputed = input$imputed), + 'Parallel Universe' = create_table_parallel(df = datTruth, rows = 20), + 'Oracle' = create_table_oracle(df = datCombined, imputed = input$imputed, .show = input$cols, rows = 20) + ) + }) + + ) + + + + # # item 13 + # items$position13 <- div( + # style = 'visibility: hidden;', + # renderUI({ + # HTML(interactive_table1) + # }) + # ) + + # # item 14 + # items$position14 <- div( + # style = 'visibility: hidden;', + # reactable::renderReactable({ + # imputed <- "#ff9f1a" + # orange_pal <- function(x) ifelse(dat3$Z == 1, imputed, '#FFFFFF') + # dat14 <- readr::read_csv('inst/extdata/fundemental_table3.csv') %>% + # mutate(Y1 = ifelse(hyperShoe == 1, Y1, 256), + # Y0 = ifelse(hyperShoe == 0, Y0, 258)) + # + # reactable::reactable(dat14, defaultPageSize = 6, columns = list( + # Y0 = reactable::colDef( + # style = function(value, index) { + # if (dat14$hyperShoe[index] == 1) { + # color <- imputed + # } else if (dat14$hyperShoe[index] == 0) { + # color <- 'white' + # } + # list(background = color) + # }), + # Y1 = reactable::colDef( + # style = function(value, index) { + # if (dat14$hyperShoe[index] == 0) { + # color <- imputed + # } else if (dat14$hyperShoe[index] == 1) { + # color <- 'white' + # } + # list(background = color) + # }) + # )) + # }) + # ) + + # item 15 + # items$position15 <- div( + # style = 'visibility: hidden;', + # renderImage({ + # list(src = app_sys('app', 'www/learn/fundemental/plots/p9.png'), + # contentType = 'image/png', + # width = 800, + # height = 500) + # }, deleteFile = F) + # ) + # + # # item 16 + # items$position16 <- div( + # style = 'visibility: hidden;', + # renderImage({ + # list(src = app_sys('app', 'www/learn/fundemental/plots/p10.png'), + # contentType = 'image/png', + # width = 800, + # height = 500) + # }, deleteFile = F) + # ) + # + # # item 17 + # items$position17 <- div( + # style = 'visibility: visible;', + # reactable::renderReactable({ + # readr::read_csv('inst/extdata/fundemental_table4.csv') %>% + # reactable::reactable(defaultPageSize = 6) + # }) + # ) + # + # # item 18 + # items$position18 <- div( + # style = 'visibility: hidden;', + # renderImage({ + # list(src = app_sys('app', 'www/learn/fundemental/plots/p11.png'), + # contentType = 'image/png', + # width = 800, + # height = 500) + # }, deleteFile = F) + # ) + # + # # item 19 + # items$position19 <- div( + # style = 'visibility: hidden;', + # renderImage({ + # list(src = app_sys('app', 'www/learn/fundemental/plots/p12.png'), + # contentType = 'image/png', + # width = 800, + # height = 500) + # }, deleteFile = F) + # ) + # + # # item 20 + # items$position20 <- div( + # style = 'visibility: hidden;', + # renderUI({ + # HTML(interactive_table2) + # }) + # ) + + # item 21 + # items$position21 <- div( + # style = 'visibility: hidden;', + # reactable::renderReactable({ + # imputed <- "#ff9f1a" + # orange_pal <- function(x) ifelse(dat3$Z == 1, imputed, '#FFFFFF') + + # dat21 <- readr::read_csv('inst/extdata/fundemental_table4.csv') %>% + # mutate(Y1 = case_when( + # hyperShoe == 0 & first.race == 'yes' ~ 260, + # hyperShoe == 0 & first.race == 'no' ~ 245, + # TRUE ~ Y1 + # ), + # Y0 = case_when( + # hyperShoe == 1 & first.race == 'yes' ~ 265, + # hyperShoe == 1 & first.race == 'no' ~ 250, + # TRUE ~ Y0 + # )) + # + # reactable::reactable(dat21, defaultPageSize = 6, columns = list( + # Y0 = reactable::colDef( + # style = function(value, index) { + # if (dat21$hyperShoe[index] == 1 & dat21$first.race[index] == 'yes') { + # color <- "#4479E4" + # } else if(dat21$hyperShoe[index] == 1 & dat21$first.race[index] == 'no'){ + # color <- "#9DB9F1" + # }else if (dat21$hyperShoe[index] == 0) { + # color <- 'white' + # } + # list(background = color) + # }), + # Y1 = reactable::colDef( + # style = function(value, index) { + # if (dat21$hyperShoe[index] == 0 & dat21$first.race[index] == 'yes') { + # color <- "#4479E4" + # } else if(dat21$hyperShoe[index] == 0 & dat21$first.race[index] == 'no'){ + # color <- "#9DB9F1" + # }else if (dat21$hyperShoe[index] == 1) { + # color <- 'white' + # } + # list(background = color)}) + # )) + # + # })) + + + + return(items) + + }) + + }) +} + +## To be copied in the UI +# mod_learn_fundemental_ui("mod_learn_fundemental_1") + +## To be copied in the server +# mod_learn_fundemental_server("mod_learn_fundemental_1") diff --git a/thinkCausal/R/mod_learn_obs_analysis.R b/thinkCausal/R/mod_learn_obs_analysis.R index 9a8fa940..b4ca77ce 100644 --- a/thinkCausal/R/mod_learn_obs_analysis.R +++ b/thinkCausal/R/mod_learn_obs_analysis.R @@ -151,7 +151,7 @@ mod_learn_obs_analysis_server <- function(id){ ) items$position2 <- div( - style = 'visibility: visible;', + style = 'visibility: hidden;', renderImage({ list(src = app_sys('app', 'www/learn/observational-analysis/plots/p2.png'), contentType = 'image/png', diff --git a/thinkCausal/R/mod_learn_post_treatment.R b/thinkCausal/R/mod_learn_post_treatment.R index 674cac04..808709e4 100644 --- a/thinkCausal/R/mod_learn_post_treatment.R +++ b/thinkCausal/R/mod_learn_post_treatment.R @@ -91,9 +91,11 @@ mod_learn_post_treatment_server <- function(id, store){ mod_quiz_server( id = "quiz", # this should always be quiz id_parent = module_ids$learn$post_treatment, - question_texts = quiz_content_post_treatment$question_texts, - question_prompts = quiz_content_post_treatment$question_prompts, - correct_answers = quiz_content_post_treatment$correct_answers, + questions = quiz_content_post_treatment$questions, + # question_texts = quiz_content_post_treatment$question_texts, + # question_prompts = quiz_content_post_treatment$question_prompts, + # correct_answers = quiz_content_post_treatment$correct_answers, + # graders = quiz_content_post_treatment$graders, message_correct = quiz_content_post_treatment$message_correct, message_wrong = quiz_content_post_treatment$message_wrong, message_skipped = quiz_content_post_treatment$message_skipped, @@ -154,8 +156,8 @@ mod_learn_post_treatment_server <- function(id, store){ }, deleteFile = F) ) + # browser() return(items) - }) diff --git a/thinkCausal/R/mod_learn_randomization_dist.R b/thinkCausal/R/mod_learn_randomization_dist.R new file mode 100644 index 00000000..fd64ef24 --- /dev/null +++ b/thinkCausal/R/mod_learn_randomization_dist.R @@ -0,0 +1,165 @@ +#' learn_randomization_dist UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_randomization_dist_ui <- function(id){ + ns <- NS(id) + tagList( + div(class = 'learning-page', + div( + #class = ns('learning-content'), # required + #class = 'learning-content', # required + style = 'display: block;', + bs4Dash::tabsetPanel( + id = "sandbox_randomization", + type = 'pill', + tabPanel( + title = 'Intro' + ), + tabPanel( + title = 'Data' + ), + tabPanel( + title = 'Plots' + ) + ), + fluidRow( + column(width = 6, + reactable::reactableOutput(outputId = ns('data')) + ), + column(width = 6, + reactable::reactableOutput(outputId = ns('new_data')) + ), + column(width = 3, + offset = 8, + actionButton(ns('draw'), label = 'Re-Assign Treatment') + ) + ), + plotOutput(ns('plot')), + + br(),br(),br(),br() + )) + ) +} + +#' learn_randomization_dist Server Functions +#' +#' @noRd +mod_learn_randomization_dist_server <- function(id){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + # load true data + dat_truth <- readr::read_csv('inst/extdata/truth.csv') + dat_obs <- dat_truth + dat_obs$sample <- 1 + dat_obs$Y0[dat_obs$hyperShoe == 1] <- NA + dat_obs$Y1[dat_obs$hyperShoe == 0] <- NA + + est_ate <- function(df){ + fit <- lm(Y ~ hyperShoe*as.factor(`prior races`), data = df) + cf_dat <- df + cf_dat$hyperShoe <- abs(df$hyperShoe - 1) + imputed <- predict(fit, newdata = cf_dat) + Y1 <- ifelse(df$hyperShoe == 1, df$Y, imputed) + Y0 <- ifelse(df$hyperShoe == 0, df$Y, imputed) + mean(Y1 - Y0) + + } + + rand_dat <- reactiveValues(data = dat_obs, + est = data.frame(value = est_ate(dat_obs), + status = "Researcher's estimate" + ) + ) + + new_sample <- reactive({ + rank <- 0 + while (rank < 8) { + new_dat <- dat_truth + new_dat$hyperShoe <- rbinom(nrow(dat_truth), 1, .5) + new_dat$Y <- ifelse(new_dat$hyperShoe == 1, new_dat$Y1, new_dat$Y0) + fit <- lm(Y ~ hyperShoe*as.factor(`prior races`), data = new_dat) + rank <- fit$rank + } + + new_dat$Y0[new_dat$hyperShoe == 1] <- NA + new_dat$Y1[new_dat$hyperShoe == 0] <- NA + cf_dat <- new_dat + cf_dat$hyperShoe <- abs(new_dat$hyperShoe - 1) + imputed <- predict(fit, newdata = cf_dat) + Y1 <- ifelse(new_dat$hyperShoe == 1, new_dat$Y, imputed) + Y0 <- ifelse(new_dat$hyperShoe == 0, new_dat$Y, imputed) + + estimate <- mean(Y1 - Y0) + new_dat$sample <- max(rand_dat$data$sample) + 1 + rand_dat$data <- rbind(rand_dat$data, new_dat) + rand_dat$est <- rbind(rand_dat$est,data.frame(value = estimate, status = 'Estimate from a new Parallel Universe!')) + + + }) + + output$data <- reactable::renderReactable({ + reactable::reactable(data = dat_obs[, 1:6], + fullWidth = FALSE, + defaultPageSize = 20, + defaultColDef = reactable::colDef(minWidth = 75), + theme = reactable::reactableTheme(cellPadding = "1px 6px") + ) + }) + + output$new_data <- reactable::renderReactable({ + reactable::reactable(data = tail(rand_dat$data, 20)[, 1:6], + defaultColDef = reactable::colDef(minWidth = 75), + fullWidth = FALSE, + defaultPageSize = 20, + theme = reactable::reactableTheme(cellPadding = "1px 6px") + ) + }) + + + + + observeEvent(input$draw, { + new_sample() + + # plt_dat <- rand_dat$est %>% + # tibble::as_tibble() %>% + # mutate(status = 'estimate from a parrallel universe') + # + # plt_dat$status[length(plt_dat$status)] <- 'new estimate from a parrallel universe!' + # + # ggplot2::ggplot(plt_dat, aes(x = value, fill = as.factor(status))) + + # geom_histogram(col = 'black', binwidth = 0.1368367) + + # theme_bw() + + # coord_cartesian(ylim = c(0, 60), xlim = c(-17, -7)) + + # ggdark::dark_mode() + }) + + output$plot <- renderPlot({ + if(nrow(rand_dat$est) > 2){ + rand_dat$est$status[2:(nrow(rand_dat$est) - 1)] <- 'Estimates from prior Parallel Universes' + } + + rand_dat$est %>% + ggplot2::ggplot(aes(value, fill = status)) + + ggplot2::geom_histogram(col = 'black', binwidth = 0.1368367) + + ggplot2::coord_cartesian(ylim = c(0, 60), xlim = c(-17, -7)) + + ggplot2::theme_dark() + + #ggdark::dark_mode() + }) + + + }) +} + +## To be copied in the UI +# mod_learn_randomization_dist_ui("learn_randomization_dist_1") + +## To be copied in the server +# mod_learn_randomization_dist_server("learn_randomization_dist_1") diff --git a/thinkCausal/R/mod_learn_scrolly_example.R b/thinkCausal/R/mod_learn_scrolly_example.R index a9d7ae65..bf430cd9 100644 --- a/thinkCausal/R/mod_learn_scrolly_example.R +++ b/thinkCausal/R/mod_learn_scrolly_example.R @@ -10,7 +10,6 @@ mod_learn_scrolly_example_ui <- function(id){ ns <- NS(id) tagList( - # shinyjs::useShinyjs(), use_scrollytell(ns = ns), diff --git a/thinkCausal/R/mod_learn_variable_selection.R b/thinkCausal/R/mod_learn_variable_selection.R new file mode 100644 index 00000000..1979c3f4 --- /dev/null +++ b/thinkCausal/R/mod_learn_variable_selection.R @@ -0,0 +1,100 @@ +#' learn_variable_selection UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_variable_selection_ui <- function(id){ + ns <- NS(id) + tagList( +bs4Dash::tabsetPanel( + id = ns('variable_selection_tabs'), + type = 'hidden', + tabPanel(title = 'Variable Selection', + div(class = 'learning-page', + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + includeMarkdown(app_sys("app", "www", "learn", "variable_selection", "markdowns", 'intro.md')), + br(), + fluidRow( + bs4Dash::box( + width = 6, + collapsible = FALSE, + title = 'Co-linearity', + tagList( + shiny::actionLink( + inputId = ns('learn_colinearity_img'), + img(src = 'www/img/thumbnails/potential-outcomes.png', + width = '100%'), + ), + "How I learned to stop worrying about colinearity and include all variables that predict the outcome" + )), + bs4Dash::box( + width = 6, + collapsible = FALSE, + title = 'Overfitting', + tagList( + shiny::actionLink( + inputId = ns('learn_potential_outcomes_img'), + img(src = 'www/img/thumbnails/potential-outcomes.png', + width = '100%'), + ), + "Learn about how thinkCausal automatically protects against overfitting." + ) + ) + ) + + ) + ) + + ), + tabPanelBody( + value = 'learn_colinearity', + mod_learn_colinearity_ui(id = ns('learn_colinearity')) + ), + tabPanelBody(value = 'learn_potential_outcomes') + ) + ) +} + +#' learn_variable_selection Server Functions +#' +#' @noRd +mod_learn_variable_selection_server <- function(id, store){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + + observeEvent(input$learn_colinearity_img, { + updateTabsetPanel( + inputId = "variable_selection_tabs", + selected = "learn_colinearity" + ) + + mod_learn_colinearity_server(id = 'learn_colinearity') + }) + + +# +# selectors <- c( +# 'learn_colinearity', +# 'learn_potential_outcomes' +# ) +# purrr::map(selectors, function(sel){ +# observeEvent(input[[glue::glue('{sel}_img')]], { +# bs4Dash::updatebs4TabItems(store$session_global, inputId = 'sidebar', selected = sel) +# }) +# }) + + }) +} + +## To be copied in the UI +# mod_learn_variable_selection_ui("learn_variable_selection_1") + +## To be copied in the server +# mod_learn_variable_selection_server("learn_variable_selection_1") diff --git a/thinkCausal/R/mod_learn_versionA.R b/thinkCausal/R/mod_learn_versionA.R new file mode 100644 index 00000000..8581fecd --- /dev/null +++ b/thinkCausal/R/mod_learn_versionA.R @@ -0,0 +1,520 @@ +#' version A UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_versionA_ui <- function(id){ + ns <- NS(id) + tagList( + shinyjs::useShinyjs(), + use_scrollytell(ns = ns), + div(class = 'learning-page', + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + p('Filler Text'), + br(),br(),br(),br() + ), + scroll_ui_container( + ns = ns, + scroll_ui_text( + ns = ns, + scroll_ui_text_section( + ns = ns, + position = 1, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 2, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 3, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 4, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 5, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 6, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 7, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ) + ), + scroll_ui_visual(ns = ns, clickable = T) + ), + br(),br(),br(),br(), + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + #includeMarkdown(app_sys("app", "www", "learn", "fundamental", "markdowns", 'intro.md')), + br(),br(),br(),br() + ) + ) + + ) +} + +#' version A Server Functions +#' +#' @noRd +mod_learn_versionA_server <- function(id){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + + output$scroll_visual <- renderUI({ + items <- list() + # item 1 + items$position1 <- div( + style = 'visibility: visible;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + reactable::reactable(defaultPageSize = 10) + }) + ) + + items$position2 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/fundemental/plots/p3.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + imputedY0 <- "#2297E6" + imputedY1 <- "#DF536B" + + dat18 <- readr::read_csv('inst/extdata/fundamental_table2.csv') + items$position3 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(dat18, + #theme = reactable::reactableTheme(cellPadding = "1px 6px"), + #class = 'small', + defaultPageSize = 10, + columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- 'white' + } + list(background = color) + }), + Y1 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- 'white' + } + list(background = color) + }) + )) + }) + + ) + + truth <- readr::read_csv('inst/extdata/truth.csv') + truth$ITE <- with(truth, Y1 - Y0) + imputed <- readr::read_csv('inst/extdata/fundamental_table2.csv') + imputed$ITE <- with(imputed, Y1 - Y0) + combined <- cbind(truth[, 1:3], imputed[, 4], truth[, 4], imputed[, 5], truth[, 5], truth[, 6]) + combined[combined$hyperShoe == 0, 4] <- NA + combined[combined$hyperShoe == 1, 6] <- NA + names(combined)[c(4, 6)] <- paste0('imputed', names(combined)[c(4, 6)]) + combined$est.ITE <- imputed$ITE + combined$ITE <- truth$ITE + + items$position4 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(imputed, fullWidth = F, columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- 'white' + } + list(background = color) + }), + Y1 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- 'white' + } + list(background = color) + }), + + ITE = reactable::colDef( + name = 'est.ITE' + ) + )) + }) + ) + + + + + dat <- reactive({ + if (input$view == 'Researcher' & input$imputed == FALSE) { + dat <- dplyr::mutate(truth, + Y0 = ifelse(hyperShoe == 1, NA, Y0), + Y1 = ifelse(hyperShoe == 1, Y1, NA), + ) %>% + dplyr::select(-ITE) + } + + if (input$view == 'Researcher' & input$imputed == TRUE) { + dat <- imputed + names(dat)[names(dat) == 'ITE'] <- 'est.ITE' + } + + if(input$view == 'Parallel Universe') { + dat <- dplyr::mutate(truth, + hyperShoe = abs(1 - hyperShoe), + Y0 = ifelse(hyperShoe == 1, NA, Y0), + Y1 = ifelse(hyperShoe == 1, Y1, NA), + Y = ifelse(hyperShoe == 1, Y1, Y0)) + + dat <- dat %>% dplyr::select(-ITE) + } + + if(input$view == 'Oracle' & input$imputed == FALSE) { + dat <- truth + } + + if(input$view == 'Oracle' & input$imputed == TRUE) { + dat <- combined + } + + dat + + }) + + background <- reactive({ + hyperShoe <- switch (input$view, + 'Researcher' = 'white', + 'Parallel Universe' = 'black', + 'Oracle' = 'white' + ) + + Y0 <- switch (input$view, + 'Researcher' = switch (as.character(input$imputed), + 'TRUE' = ifelse(truth$hyperShoe == 1, imputedY0, 'white'), + 'FALSE' = 'white'), + 'Parallel Universe' = rep('black', nrow(truth)), + 'Oracle' = ifelse(dat()[['hyperShoe']] == 1, 'black', 'white') + ) + + Y1 <- switch (input$view, + 'Researcher' = switch (as.character(input$imputed), + 'TRUE' = ifelse(truth$hyperShoe == 0, imputedY1, 'white'), + 'FALSE' = 'white'), + 'Parallel Universe' = rep('black', nrow(truth)), + 'Oracle' = ifelse(dat()[['hyperShoe']] == 0, 'black', 'white') + ) + + Y <- switch (input$view, + 'Researcher' = 'white', + 'Parallel Universe' = 'black', + 'Oracle' = 'white' + ) + + + list(hyperShoe = hyperShoe, + Y0 = Y0, + Y1 = Y1, + Y = Y) + }) + + observeEvent(input$view, { + if(input$view == 'Parallel Universe'){ + shinyjs::disable('imputed') + }else{ + shinyjs::enable('imputed') + } + }) + + + items$position5 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view'), label = 'select a view:', + choices = c('Researcher', 'Parallel Universe', 'Oracle'), + individual = T + ) + }), + renderUI({ + shinyWidgets::materialSwitch( + inputId = ns("imputed"), + label = "Show imputed potential outcomes", + status = "primary", + right = TRUE + + ) + }), + renderUI({ + if(input$view == 'Oracle' & input$imputed == TRUE){ + default <- c('hyperShoe', 'Y0', 'Y1', 'Y', 'est.ITE', 'ITE') + }else{ + default <- names(dat()) + } + default <- + selectInput(inputId = ns('show'), + label = 'show', + choices = names(dat()), + selected = default, + multiple = TRUE, + width = '55%' + ) + }), + reactable::renderReactable({ + if(input$imputed == TRUE & input$view == 'Oracle'){ + reactable::reactable(dat(),fullWidth = FALSE, + columns = list( + runner = reactable::colDef( + show = 'runner' %in% input$show + ), + `prior races` = reactable::colDef( + show = 'prior races' %in% input$show + ), + hyperShoe = reactable::colDef( + show = 'hyperShoe' %in% input$show, + style = function(value, index) { + list(background = background()[['hyperShoe']]) + }), + imputedY0 = reactable::colDef( + show = 'Y0' %in% input$show, + name = 'imputed', + style = function(value, index) { + list(background = ifelse(truth$hyperShoe == 1, imputedY0, 'white')[index]) + }), + Y0 = reactable::colDef( + show = 'Y0' %in% input$show, + name = 'true', + headerStyle = list(backgoundColor = 'black'), + style = function(value, index) { + list(background = background()[['Y0']][index]) + }), + imputedY1 = reactable::colDef( + show = 'Y1' %in% input$show, + name = 'imputed', + style = function(value, index) { + list(background = ifelse(truth$hyperShoe == 0, imputedY1, 'white')[index]) + }), + Y1 = reactable::colDef( + name = 'true', + show = 'Y1' %in% input$show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(background = background()[['Y1']][index]) + }), + Y = reactable::colDef( + show = 'Y' %in% input$show, + style = function(value, index) { + list(background = background()[['Y']]) + }), + est.ITE = reactable::colDef( + name = 'estimated' + ), + ITE = reactable::colDef( + name = 'true', + style = function(value, index) { + list(background = 'black') + }) + ), + columnGroups = list( + reactable::colGroup(name = "Y0", columns = c("imputedY0", "Y0")), + reactable::colGroup(name = "Y1", columns = c("imputedY1", "Y1")), + reactable::colGroup(name = 'ITE', columns = c('est.ITE', 'ITE')) + ) + ) + + }else if(input$imputed == FALSE & input$view == 'Oracle'){ + reactable::reactable(dat(),fullWidth = FALSE, columns = list( + runner = reactable::colDef( + show = 'runner' %in% input$show + ), + `prior races` = reactable::colDef( + show = 'prior races' %in% input$show + ), + hyperShoe = reactable::colDef( + show = 'hyperShoe' %in% input$show, + style = function(value, index) { + list(background = background()[['hyperShoe']]) + }), + Y0 = reactable::colDef( + show = 'Y0' %in% input$show, + name = 'true', + headerStyle = list(backgoundColor = 'black'), + style = function(value, index) { + list(background = background()[['Y0']][index]) + }), + Y1 = reactable::colDef( + name = 'true', + show = 'Y1' %in% input$show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(background = background()[['Y1']][index]) + }), + Y = reactable::colDef( + show = 'Y' %in% input$show, + style = function(value, index) { + list(background = background()[['Y']]) + }), + ITE = reactable::colDef( + show = 'ITE' %in% input$show, + style = function(value, index) { + list(background = 'black') + }) + ) + ) + }else{ + reactable::reactable(dat(),fullWidth = FALSE, columns = list( + runner = reactable::colDef( + show = 'runner' %in% input$show + ), + `prior races` = reactable::colDef( + show = 'prior races' %in% input$show + ), + hyperShoe = reactable::colDef( + show = 'hyperShoe' %in% input$show, + style = function(value, index) { + list(background = background()[['hyperShoe']]) + }), + Y0 = reactable::colDef( + show = 'Y0' %in% input$show, + headerStyle = list(backgoundColor = 'black'), + style = function(value, index) { + list(background = background()[['Y0']][index]) + }), + Y1 = reactable::colDef( + show = 'Y1' %in% input$show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(background = background()[['Y1']][index]) + }), + Y = reactable::colDef( + show = 'Y' %in% input$show, + style = function(value, index) { + list(background = background()[['Y']]) + }) + )) + } + + }) + ) + + items$position6 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view6'), label = 'select a view:', + choices = c('Researcher', 'Oracle'), + individual = T, + selected = 'Oracle' + ) + }), + renderImage({ + if(input$view6 == 'Oracle') path <- 'www/learn/fundemental/plots/cf1.png' + if(input$view6 != 'Oracle') path <- 'www/learn/fundemental/plots/factual1.png' + list(src = app_sys('app', path), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + + items$position7 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view7'), label = NULL, + choices = c('Researcher', 'Oracle'), + individual = T, + selected = 'Oracle' + ) + }), + renderUI({ + selectInput(ns('viz7'), label = NULL, + choices = c('Plot', 'Table') + ) + }), + renderUI({ + if(input$viz7 == 'Plot'){ + renderImage({ + if(input$view7 == 'Oracle') path <- 'www/learn/fundemental/plots/cf2.png' + if(input$view7 != 'Oracle') path <- 'www/learn/fundemental/plots/factual2.png' + list(src = app_sys('app', path), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + }else{ + reactable::renderReactable({ + reactable::reactable(combined[, c('runner', 'est.ITE', 'ITE')], + defaultPageSize = 20, + class = 'small', + theme = reactable::reactableTheme( + cellPadding = "1px 6px" + ), + columns = list( + runner = reactable::colDef(footer = 'Average'), + est.ITE = reactable::colDef(footer = 12.14), + ITE = reactable::colDef( + show = input$view7 == 'Oracle', + footer = 12.75, + style = list(background = 'black', + color = 'white'), + footerStyle = list(background = 'black', + color = 'white') + ) + ), + defaultColDef = reactable::colDef( + footerStyle = list(fontWeight = "bold"), + ) + ) + + }) + } + }) + + ) + + return(items) + }) + + }) +} + +## To be copied in the UI +# mod_version A_ui("version A_1") + +## To be copied in the server +# mod_version A_server("version A_1") diff --git a/thinkCausal/R/mod_learn_versionB.R b/thinkCausal/R/mod_learn_versionB.R new file mode 100644 index 00000000..8f42a65f --- /dev/null +++ b/thinkCausal/R/mod_learn_versionB.R @@ -0,0 +1,520 @@ +#' version A UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_versionB_ui <- function(id){ + ns <- NS(id) + tagList( + shinyjs::useShinyjs(), + use_scrollytell(ns = ns), + div(class = 'learning-page', + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + p('Filler Text'), + br(),br(),br(),br() + ), + scroll_ui_container( + ns = ns, + scroll_ui_text( + ns = ns, + scroll_ui_text_section( + ns = ns, + position = 1, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 2, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 3, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 4, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 5, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 6, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ), + scroll_ui_text_section( + ns = ns, + position = 7, + includeMarkdown(app_sys("app", "www", "learn", "fundemental", "markdowns", 'section1.md')) + ) + ), + scroll_ui_visual(ns = ns, clickable = T) + ), + br(),br(),br(),br(), + div( + class = ns('learning-content'), # required + class = 'learning-content', # required + style = 'display: block;', + #includeMarkdown(app_sys("app", "www", "learn", "fundamental", "markdowns", 'intro.md')), + br(),br(),br(),br() + ) + ) + + ) +} + +#' version A Server Functions +#' +#' @noRd +mod_learn_versionB_server <- function(id){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + + output$scroll_visual <- renderUI({ + items <- list() + # item 1 + items$position1 <- div( + style = 'visibility: visible;', + reactable::renderReactable({ + readr::read_csv('inst/extdata/fundamental_table1.csv') %>% + reactable::reactable(defaultPageSize = 10) + }) + ) + + items$position2 <- div( + style = 'visibility: hidden;', + renderImage({ + list(src = app_sys('app', 'www/learn/fundemental/plots/p3.png'), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + imputedY0 <- "#E6C0F0" + imputedY1 <- "#E6C0F0" + + dat18 <- readr::read_csv('inst/extdata/fundamental_table2.csv') + items$position3 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(dat18, + #theme = reactable::reactableTheme(cellPadding = "1px 6px"), + #class = 'small', + defaultPageSize = 10, + columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- 'white' + } + list(background = color) + }), + Y1 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- 'white' + } + list(background = color) + }) + )) + }) + + ) + + truth <- readr::read_csv('inst/extdata/truth.csv') + truth$ITE <- with(truth, Y1 - Y0) + imputed <- readr::read_csv('inst/extdata/fundamental_table2.csv') + imputed$ITE <- with(imputed, Y1 - Y0) + combined <- cbind(truth[, 1:3], imputed[, 4], truth[, 4], imputed[, 5], truth[, 5], truth[, 6]) + combined[combined$hyperShoe == 0, 4] <- NA + combined[combined$hyperShoe == 1, 6] <- NA + names(combined)[c(4, 6)] <- paste0('imputed', names(combined)[c(4, 6)]) + combined$est.ITE <- imputed$ITE + combined$ITE <- truth$ITE + + items$position4 <- div( + style = 'visibility: hidden;', + reactable::renderReactable({ + reactable::reactable(imputed, fullWidth = F, columns = list( + Y0 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 1) { + color <- imputedY0 + } else { + color <- 'white' + } + list(background = color) + }), + Y1 = reactable::colDef( + style = function(value, index) { + if (dat18$hyperShoe[index] == 0) { + color <- imputedY1 + } else { + color <- 'white' + } + list(background = color) + }), + + ITE = reactable::colDef( + name = 'est.ITE' + ) + )) + }) + ) + + + + + dat <- reactive({ + if (input$view == 'What happened' & input$imputed == FALSE) { + dat <- dplyr::mutate(truth, + Y0 = ifelse(hyperShoe == 1, NA, Y0), + Y1 = ifelse(hyperShoe == 1, Y1, NA), + ) %>% + dplyr::select(-ITE) + } + + if (input$view == 'What happened' & input$imputed == TRUE) { + dat <- imputed + names(dat)[names(dat) == 'ITE'] <- 'est.ITE' + } + + if(input$view == 'What would have happened?') { + dat <- dplyr::mutate(truth, + hyperShoe = abs(1 - hyperShoe), + Y0 = ifelse(hyperShoe == 1, NA, Y0), + Y1 = ifelse(hyperShoe == 1, Y1, NA), + Y = ifelse(hyperShoe == 1, Y1, Y0)) + + dat <- dat %>% dplyr::select(-ITE) + } + + if(input$view == 'Compare' & input$imputed == FALSE) { + dat <- truth + } + + if(input$view == 'Compare' & input$imputed == TRUE) { + dat <- combined + } + + dat + + }) + + background <- reactive({ + hyperShoe <- switch (input$view, + 'What happened' = 'white', + 'What would have happened?' = 'black', + 'Compare' = 'white' + ) + + Y0 <- switch (input$view, + 'What happened' = switch (as.character(input$imputed), + 'TRUE' = ifelse(truth$hyperShoe == 1, imputedY0, 'white'), + 'FALSE' = 'white'), + 'What would have happened?' = rep('black', nrow(truth)), + 'Compare' = ifelse(dat()[['hyperShoe']] == 1, 'black', 'white') + ) + + Y1 <- switch (input$view, + 'What happened' = switch (as.character(input$imputed), + 'TRUE' = ifelse(truth$hyperShoe == 0, imputedY1, 'white'), + 'FALSE' = 'white'), + 'What would have happened?' = rep('black', nrow(truth)), + 'Compare' = ifelse(dat()[['hyperShoe']] == 0, 'black', 'white') + ) + + Y <- switch (input$view, + 'What happened' = 'white', + 'What would have happened?' = 'black', + 'Compare' = 'white' + ) + + + list(hyperShoe = hyperShoe, + Y0 = Y0, + Y1 = Y1, + Y = Y) + }) + + observeEvent(input$view, { + if(input$view == 'What would have happened?'){ + shinyjs::disable('imputed') + }else{ + shinyjs::enable('imputed') + } + }) + + + items$position5 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view'), label = 'select a view:', + choices = c('What happened', 'What would have happened?', 'Compare'), + individual = T + ) + }), + renderUI({ + shinyWidgets::materialSwitch( + inputId = ns("imputed"), + label = "Show imputed potential outcomes", + status = "primary", + right = TRUE + + ) + }), + renderUI({ + if(input$view == 'Compare' & input$imputed == TRUE){ + default <- c('hyperShoe', 'Y0', 'Y1', 'Y', 'est.ITE', 'ITE') + }else{ + default <- names(dat()) + } + default <- + selectInput(inputId = ns('show'), + label = 'show', + choices = names(dat()), + selected = default, + multiple = TRUE, + width = '55%' + ) + }), + reactable::renderReactable({ + if(input$imputed == TRUE & input$view == 'Compare'){ + reactable::reactable(dat(),fullWidth = FALSE, + columns = list( + runner = reactable::colDef( + show = 'runner' %in% input$show + ), + `prior races` = reactable::colDef( + show = 'prior races' %in% input$show + ), + hyperShoe = reactable::colDef( + show = 'hyperShoe' %in% input$show, + style = function(value, index) { + list(background = background()[['hyperShoe']]) + }), + imputedY0 = reactable::colDef( + show = 'Y0' %in% input$show, + name = 'imputed', + style = function(value, index) { + list(background = ifelse(truth$hyperShoe == 1, imputedY0, 'white')[index]) + }), + Y0 = reactable::colDef( + show = 'Y0' %in% input$show, + name = 'true', + headerStyle = list(backgoundColor = 'black'), + style = function(value, index) { + list(background = background()[['Y0']][index]) + }), + imputedY1 = reactable::colDef( + show = 'Y1' %in% input$show, + name = 'imputed', + style = function(value, index) { + list(background = ifelse(truth$hyperShoe == 0, imputedY1, 'white')[index]) + }), + Y1 = reactable::colDef( + name = 'true', + show = 'Y1' %in% input$show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(background = background()[['Y1']][index]) + }), + Y = reactable::colDef( + show = 'Y' %in% input$show, + style = function(value, index) { + list(background = background()[['Y']]) + }), + est.ITE = reactable::colDef( + name = 'estimated' + ), + ITE = reactable::colDef( + name = 'true', + style = function(value, index) { + list(background = 'black') + }) + ), + columnGroups = list( + reactable::colGroup(name = "Y0", columns = c("imputedY0", "Y0")), + reactable::colGroup(name = "Y1", columns = c("imputedY1", "Y1")), + reactable::colGroup(name = 'ITE', columns = c('est.ITE', 'ITE')) + ) + ) + + }else if(input$imputed == FALSE & input$view == 'Compare'){ + reactable::reactable(dat(),fullWidth = FALSE, columns = list( + runner = reactable::colDef( + show = 'runner' %in% input$show + ), + `prior races` = reactable::colDef( + show = 'prior races' %in% input$show + ), + hyperShoe = reactable::colDef( + show = 'hyperShoe' %in% input$show, + style = function(value, index) { + list(background = background()[['hyperShoe']]) + }), + Y0 = reactable::colDef( + show = 'Y0' %in% input$show, + name = 'true', + headerStyle = list(backgoundColor = 'black'), + style = function(value, index) { + list(background = background()[['Y0']][index]) + }), + Y1 = reactable::colDef( + name = 'true', + show = 'Y1' %in% input$show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(background = background()[['Y1']][index]) + }), + Y = reactable::colDef( + show = 'Y' %in% input$show, + style = function(value, index) { + list(background = background()[['Y']]) + }), + ITE = reactable::colDef( + show = 'ITE' %in% input$show, + style = function(value, index) { + list(background = 'black') + }) + ) + ) + }else{ + reactable::reactable(dat(),fullWidth = FALSE, columns = list( + runner = reactable::colDef( + show = 'runner' %in% input$show + ), + `prior races` = reactable::colDef( + show = 'prior races' %in% input$show + ), + hyperShoe = reactable::colDef( + show = 'hyperShoe' %in% input$show, + style = function(value, index) { + list(background = background()[['hyperShoe']]) + }), + Y0 = reactable::colDef( + show = 'Y0' %in% input$show, + headerStyle = list(backgoundColor = 'black'), + style = function(value, index) { + list(background = background()[['Y0']][index]) + }), + Y1 = reactable::colDef( + show = 'Y1' %in% input$show, + #headerStyle = list(backgroundColor = 'green'), + style = function(value, index) { + list(background = background()[['Y1']][index]) + }), + Y = reactable::colDef( + show = 'Y' %in% input$show, + style = function(value, index) { + list(background = background()[['Y']]) + }) + )) + } + + }) + ) + + items$position6 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view6'), label = 'select a view:', + choices = c('What happened', 'Compare'), + individual = T, + selected = 'Compare' + ) + }), + renderImage({ + if(input$view6 == 'Compare') path <- 'www/learn/fundemental/plots/cf1.png' + if(input$view6 != 'Compare') path <- 'www/learn/fundemental/plots/factual1.png' + list(src = app_sys('app', path), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + ) + + + items$position7 <- div( + style = 'visibility: hidden;', + renderUI({ + shinyWidgets::radioGroupButtons(ns('view7'), label = NULL, + choices = c('What happened', 'Compare'), + individual = T, + selected = 'Compare' + ) + }), + renderUI({ + selectInput(ns('viz7'), label = NULL, + choices = c('Plot', 'Table') + ) + }), + renderUI({ + if(input$viz7 == 'Plot'){ + renderImage({ + if(input$view7 == 'Compare') path <- 'www/learn/fundemental/plots/cf2.png' + if(input$view7 != 'Compare') path <- 'www/learn/fundemental/plots/factual2.png' + list(src = app_sys('app', path), + contentType = 'image/png', + width = 800, + height = 500) + }, deleteFile = F) + }else{ + reactable::renderReactable({ + reactable::reactable(combined[, c('runner', 'est.ITE', 'ITE')], + defaultPageSize = 20, + class = 'small', + theme = reactable::reactableTheme( + cellPadding = "1px 6px" + ), + columns = list( + runner = reactable::colDef(footer = 'Average'), + est.ITE = reactable::colDef(footer = 12.14), + ITE = reactable::colDef( + show = input$view7 == 'Compare', + footer = 12.75, + style = list(background = 'black', + color = 'white'), + footerStyle = list(background = 'black', + color = 'white') + ) + ), + defaultColDef = reactable::colDef( + footerStyle = list(fontWeight = "bold"), + ) + ) + + }) + } + }) + + ) + + return(items) + }) + + }) +} + +## To be copied in the UI +# mod_version A_ui("version A_1") + +## To be copied in the server +# mod_version A_server("version A_1") diff --git a/thinkCausal/R/mod_learn_versionC.R b/thinkCausal/R/mod_learn_versionC.R new file mode 100644 index 00000000..c88abb33 --- /dev/null +++ b/thinkCausal/R/mod_learn_versionC.R @@ -0,0 +1,31 @@ +#' versionC UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_learn_versionC_ui <- function(id){ + ns <- NS(id) + tagList( + + ) +} + +#' versionC Server Functions +#' +#' @noRd +mod_learn_versionC_server <- function(id){ + moduleServer( id, function(input, output, session){ + ns <- session$ns + + }) +} + +## To be copied in the UI +# mod_versionC_ui("versionC_1") + +## To be copied in the server +# mod_versionC_server("versionC_1") diff --git a/thinkCausal/R/mod_quiz.R b/thinkCausal/R/mod_quiz.R index f1a8f1a4..f2a481dd 100644 --- a/thinkCausal/R/mod_quiz.R +++ b/thinkCausal/R/mod_quiz.R @@ -6,6 +6,9 @@ ### cannot change this logic --> first incorrect answer stops the quiz and puts the user in the article ### ### requires learning.css style sheet in /www folder ### +# post_treatment mod is the current working example + +# TODO: move to separate R package #' quiz UI Function #' @@ -17,7 +20,8 @@ #' #' @importFrom shiny NS tagList mod_quiz_ui <- function(id){ - ns <- NS(id) + ns <- NS(id) # parent module + tagList( # shinyjs::useShinyjs(), div( @@ -31,7 +35,8 @@ mod_quiz_ui <- function(id){ #' quiz Server Functions #' #' @noRd -mod_quiz_server <- function(id, id_parent = character(0), question_texts, question_prompts, correct_answers, message_correct, message_wrong, message_skipped, embed_quiz = TRUE){ +# mod_quiz_server <- function(id, id_parent = character(0), question_texts, question_prompts, correct_answers, graders = NULL, message_correct, message_wrong, message_skipped, embed_quiz = TRUE, sandbox_mode = FALSE){ +mod_quiz_server <- function(id, id_parent = character(0), questions, message_correct, message_wrong, message_skipped, embed_quiz = TRUE, sandbox_mode = FALSE){ moduleServer( id, function(input, output, session){ # ns <- session$ns ns <- NS(NS(id_parent)(id)) @@ -44,16 +49,38 @@ mod_quiz_server <- function(id, id_parent = character(0), question_texts, questi # add css class to the quiz container if embedding if (isTRUE(embed_quiz)) shinyjs::addClass(id = 'quiz-container', class = 'quiz-embedded') + # resample the questions if in sandbox mode + if (isTRUE(sandbox_mode)){ + # number of questions + n <- 50L + + # sample indices for replicating the questions + indices <- sample(seq_along(questions), size = n, replace = TRUE) + questions <- questions[indices] + # question_prompts <- question_prompts[indices] + # correct_answers <- correct_answers[indices] + } + + # add headers to question texts + # question_texts <- quiz_format_question_texts(questions) + for (i in seq_along(questions)){ + # print(questions[[i]]@question) + questions[[i]]@question <- quiz_format_question_text(questions[[i]]@question, i) + } + # set the current state and potential values store <- reactiveValues( state = 'quiz-question-1', - states = c(paste0('quiz-question-', seq_along(question_texts)), 'quiz-complete'), - question_texts = question_texts, - question_prompts = question_prompts, - correct_answers = correct_answers, - responses = rep(NA, length(question_texts) + 1), + states = c(paste0('quiz-question-', seq_along(questions)), 'quiz-complete'), + questions = questions, + # question_prompts = question_prompts, + # correct_answers = correct_answers, + # graders = graders, + # responses = rep(NA, length(question_texts) + 1), + is_correct = rep(FALSE, length(questions)), ui_html = NULL, - skipped = FALSE + skipped = FALSE, + sandbox_mode = isTRUE(sandbox_mode) ) # reset quiz @@ -62,11 +89,13 @@ mod_quiz_server <- function(id, id_parent = character(0), question_texts, questi store <- quiz_set_state(store, variable = 'current-state', value = 'quiz-question-1') # remove any responses - store$responses <- rep(NA, length(question_texts) + 1) + # store$responses <- rep(NA, length(questions) + 1) + store$questions <- questions store <- quiz_set_state(store, variable = 'quiz-skipped', value = FALSE) + store$is_correct <- rep(FALSE, length(questions)) }) - # skip quiz + # skip quiz / finish quiz observeEvent(input$skip_button, { store <- quiz_set_state(store, variable = 'current-state', value = 'quiz-complete') store <- quiz_set_state(store, variable = 'quiz-skipped', value = TRUE) @@ -120,8 +149,9 @@ mod_quiz_server <- function(id, id_parent = character(0), question_texts, questi # record answers store <- quiz_set_state(store, variable = 'current-response', value = input$answers) - # is the answer correct + # is the answer correct and record it is_correct <- quiz_is_current_correct(store) + store <- quiz_set_state(store, 'current-correct', is_correct) # grade it delay_in_ms <- 2000 @@ -140,8 +170,14 @@ mod_quiz_server <- function(id, id_parent = character(0), question_texts, questi add_red_x(ns = ns, id = 'quiz-container', element = 'h3') # change the state + # if in sandbox mode, go to next question otherwise end here shinyjs::delay(delay_in_ms, { - store <- quiz_set_state(store, variable = 'current-state', value = 'quiz-complete') + if (quiz_in_sandbox_mode(store)){ + new_state <- quiz_get_state(store, variable = 'next-state') + store <- quiz_set_state(store, variable = 'current-state', value = new_state) + } else { + store <- quiz_set_state(store, variable = 'current-state', value = 'quiz-complete') + } }) } }) @@ -163,13 +199,13 @@ mod_quiz_server <- function(id, id_parent = character(0), question_texts, questi #' See the post-treatment learning module for a working example. #' #' @param store a list formatted like in the example -#' @param variable one of c('current-question', 'current-answers', 'current-correct-answer', 'next-state', 'current-response') +#' @param variable one of c('current-question', 'current-correct-answer', 'next-state', 'current-response') #' @param state one of c('quiz-question-1', ..., 'quiz-question') #' #' @return depends on function #' @noRd #' -#' @author Joe Marlo +#' @author Joseph Marlo #' #' @examples #' \dontrun{ @@ -186,10 +222,12 @@ mod_quiz_server <- function(id, id_parent = character(0), question_texts, questi #' question_prompts = question_prompts, #' correct_answers = correct_answers, #' responses = c('yes', NA, NA), -#' skipped = FALSE +#' skipped = FALSE, +#' sandbox_mode = FALSE #' ) #' quiz_get_state(store, 'current-question') #' } +#' @noRd #' @describeIn quiz_get_state a getter function for the state machine quiz_get_state <- function(store, variable = NULL, state = NULL){ if (is.null(state)) state <- store$state @@ -197,27 +235,41 @@ quiz_get_state <- function(store, variable = NULL, state = NULL){ if (!(state %in% store$states)) stop('state not in store$states') if (variable == 'current-question'){ - return(store$question_texts[store$states == state][[1]]) - } - if (variable == 'current-answers'){ - return(store$question_prompts[store$states == state][[1]]) + return(store$questions[store$states == state][[1]]@question) } + # if (variable == 'current-answers'){ + # return(store$question_prompts[store$states == state][[1]]) + # } if (variable == 'current-correct-answer'){ - return(store$correct_answers[store$states == state][[1]]) + # return(store$correct_answers[store$states == state][[1]]) + return(store$questions[store$states == state][[1]]@answerCorrectDisplay) + } + if (variable == 'current-grader'){ + # return(store$graders[store$states == state][[1]]) + return(store$questions[store$states == state][[1]]@grader) + } + if (variable == 'current-correct'){ + return(store$is_correct[store$states == state]) } if (variable == 'next-state'){ return(store$states[min(length(store$states), match(state, store$states) + 1)]) } if (variable == 'current-response'){ - return(store$responses[store$states == state][[1]]) + # return(store$responses[store$states == state][[1]]) + return(store$questions[store$states == state][[1]]@answerUser[[1]]) # there's some weird indexing that happens with the lists } if (variable == 'quiz-skipped'){ return(store$skipped) } + if (variable == 'sandbox-mode'){ + return(store$sandbox_mode) + } } +#' @noRd #' @describeIn quiz_get_state a setter function for the state machine quiz_set_state <- function(store, variable, value, state = NULL){ + if (is.null(state)) state <- quiz_get_state(store) if (is.null(value)) value <- character(0) @@ -225,53 +277,88 @@ quiz_set_state <- function(store, variable, value, state = NULL){ store$state <- value } if (variable == 'current-response'){ - store$responses[store$states == state] <- list(value) + # store$responses[store$states == state] <- list(value) + # store$questions[store$states == state][[1]]@answerUser[[1]] <- value + store$questions[[which(store$states == state)]]@answerUser[[1]] <- value # there's some weird indexing that happens with the lists } if (variable == 'quiz-skipped'){ if (!is.logical(value)) stop('value must logical for "quiz-skipped" variable') store$skipped <- value } + if (variable == 'current-correct'){ + state_index <- store$states[store$states != 'quiz-complete'] + store$is_correct[state_index == state] <- value + } return(store) } -#' @describeIn quiz_get_state check that an answer matches a response, agnostic of ordering +#' @noRd +#' @describeIn quiz_get_state Backup function to check that an answer matches a response, agnostic of ordering quiz_is_answer_correct <- function(answer, key){ if (length(answer) != length(key)) return(FALSE) if(!is.numeric(answer)) is_correct <- purrr::map2_lgl(answer, key, function(resp, key) base::setequal(resp, key)) if(is.numeric(answer)) is_correct <- purrr::map2_lgl(answer, key, function(resp, key) between(resp, key-.1, key+.1)) - is_correct <- all(is_correct) + is_correct <- isTRUE(all(is_correct)) return(is_correct) } +#' @noRd #' @describeIn quiz_get_state check that current-response is correct quiz_is_current_correct <- function(store){ current_response <- unname(quiz_get_state(store, variable = 'current-response')) current_correct_answer <- unname(quiz_get_state(store, variable = 'current-correct-answer')) - is_correct <- quiz_is_answer_correct(current_response, current_correct_answer) + + # if there is a grader function, use it. Otherwise use the generic one defined above + current_grader <- quiz_get_state(store, 'current-grader') + if (shiny::isTruthy(current_grader)){ + is_correct <- current_grader(current_response) + } else { + is_correct <- quiz_is_answer_correct(current_response, current_correct_answer) + } return(is_correct) } +#' @noRd +#' @describeIn quiz_get_state check that recorded answers are correct and return a boolean vector +quiz_check_is_each_correct <- function(store){ + return(store$is_correct) +} + +#' @noRd #' @describeIn quiz_get_state check that all recorded answers are correct quiz_is_all_correct <- function(store) { - tryCatch({ - # extract responses and correct answers - responses <- unname(store$responses[-(length(store$question_texts) + 1)]) - correct_answers <- unname(store$correct_answers) - - # remove names - responses <- purrr::map(responses, unname) - correct_answers <- purrr::map(correct_answers, unname) - - # check if they are the same - is_identical <- purrr::map2_lgl(responses, correct_answers, quiz_is_answer_correct) - is_identical <- all(is_identical) - - return(is_identical) - }, - error = function(e) FALSE) + return(isTRUE(all(quiz_check_is_each_correct(store)))) +} + +#' @noRd +#' @describeIn quiz_get_state Check if the quiz in sandbox mode +quiz_in_sandbox_mode <- function(store){ + isTRUE(quiz_get_state(store, 'sandbox-mode')) } +#' @noRd +#' @describeIn quiz_get_state Add a header denoting the question number +# quiz_format_question_texts <- function(questions){ +# purrr::map2(questions, seq_along(questions), function(q_text, i) { +# htmltools::tagList( +# htmltools::h4("Practice what you've learned"), +# htmltools::hr(), +# htmltools::h3(glue::glue("Question {i}")), # h3 required for checkmark/red x placement +# q_text@question +# ) +# }) +# } +quiz_format_question_text <- function(question, i){ + htmltools::div( + htmltools::h4("Practice what you've learned"), + htmltools::hr(), + htmltools::h3(glue::glue("Question {i}")), # h3 required for checkmark/red x placement + question + ) +} + +#' @noRd #' @describeIn quiz_get_state UI to show once the quiz is completed quiz_ui_quiz_complete <- function(store, ns, message_correct, message_wrong, message_skipped){ @@ -287,18 +374,88 @@ quiz_ui_quiz_complete <- function(store, ns, message_correct, message_wrong, mes html_content <- tagList(br(), add_message_wrong(message_wrong)) } - # add restart button + # render the report table + grade_report <- quiz_ui_quiz_complete_report(store) + + # render the restart button + restart_button <- actionButton( + inputId = ns('restart_button'), + label = 'Restart quiz', + class = 'restart-button' + ) + + # put it all together html_content <- tagList( html_content, - actionButton(inputId = ns('restart_button'), - label = 'Restart quiz', - class = 'restart-button'), + grade_report, + restart_button, br(), br(), hr(), br() ) return(html_content) } +#' @noRd +#' @describeIn quiz_get_state Quiz score and table of correct answers to show at the end +quiz_ui_quiz_complete_report <- function(store){ + + in_sandbox <- quiz_in_sandbox_mode(store) + + # grade answers and convert into icons + icon_right <- shiny::icon('check') |> as.character() + icon_wrong <- shiny::icon('times') |> as.character() + answers <- quiz_check_is_each_correct(store) + answers_icons <- c(icon_wrong, icon_right)[answers + 1] + + # format question labels + question_label <- paste0('Question ', seq_along(store$questions)) + + # calculate score and format user's answers + # if in sandbox mode, score is only for non skipped items + answers_user_print <- purrr::map(store$questions, ~.x@answerUserDisplay(.x@answerUser[[1]])) + answers_user_na <- purrr::map(store$questions, ~.x@answerUser[[1]]) |> is.na() # assumes NAs are skipped questions + + score <- ifelse( + in_sandbox, + mean(answers[!answers_user_na]), + mean(answers) + ) + if(is.na(score)) score <- 0 + skip_label <- '[skipped]' + answers_user_print[answers_user_na] <- skip_label + + + # format correct answers + answers_correct_print <- purrr::map_chr(store$questions, ~.x@answerCorrectDisplay) + + # put everything in a table + grade_tbl <- tibble::tibble( + icon = answers_icons, + label = question_label, + `Your Answer` = answers_user_print, + `Correct Answer` = answers_correct_print + ) |> + dplyr::filter(`Your Answer` != skip_label) |> + reactable::reactable( + columns = list( + icon = reactable::colDef(name = '', html = TRUE, width = 40), + label = reactable::colDef(name = '', width = 115), + `Your Answer` = reactable::colDef(align = 'right'), + `Correct Answer` = reactable::colDef(align = 'right') + ) + ) + + # add score to top of table + grade_report <- htmltools::tagList( + br(), + htmltools::h4(glue::glue('Score: {scales::percent_format()(score)}')), + grade_tbl + ) + + return(grade_report) +} + +#' @noRd #' @describeIn quiz_get_state UI to show for each question quiz_ui_question <- function(store, ns){ @@ -309,7 +466,7 @@ quiz_ui_question <- function(store, ns){ quiz_get_state(store, 'current-question'), # question answer UI (e.g. radiobuttons, sortable divs, etc.) - quiz_get_state(store, 'current-answers'), + # quiz_get_state(store, 'current-answers'), # button to submit answer actionButton(inputId = ns('submit_button'), @@ -317,15 +474,65 @@ quiz_ui_question <- function(store, ns){ class = 'submit-button'), # button to skip quiz - actionButton(inputId = ns('skip_button'), - label = 'Skip quiz', - class = 'skip-button') + actionButton( + inputId = ns('skip_button'), + label = ifelse(quiz_in_sandbox_mode(store), 'Finish quiz', 'Skip quiz'), + class = 'skip-button' + ) ) return(html_content) } +# classes ----------------------------------------------------------------- + +# class for quizes +setClass('quizQuestion', slots = list( + question = 'shiny.tag', + answerUser = 'list', + answerUserDisplay = 'function', # how to print the user answer in the report + answerCorrectDisplay = 'character', # how to print the correct answer in the report + grader = 'function' # function that compares user answer to the correct answer +)) + +verify_question_structure <- function(question){ + + if (!isTRUE(isS4(question))) cli::cli_abort('Must be an S4 object') + if (!isTRUE(inherits(question, 'quizQuestion'))) cli::cli_abort('Must be an S4 object with class quizQuestion') + + if (!isTRUE(inherits(question@question, 'shiny.tag'))) cli::cli_abort('`question` must be of class shiny.tag. Preferably generated from htmltools::div().') + + if (!isTRUE(inherits(question@answerUserDisplay, 'function'))) cli::cli_abort('`answerUserDisplay` must be a function that accepts one argument and returns a character.') + if (!isTRUE(inherits(question@answerCorrectDisplay, 'character'))) cli::cli_abort('`answerCorrectDisplay` must be a character.') + if (!isTRUE(inherits(question@grader, 'function'))) cli::cli_abort('`grader` must be a function that accepts one argument and returns a boolean') + + # verify args + + + return(invisible(TRUE)) +} + +# TODO: +setClass('quizMessages', slots = list( + correct = 'character', + wrong = 'character', + skipped = 'character' +)) + +# +# setClass('answerCorrect', slots = list( +# answer = 'list', +# display = 'character', +# grader = 'function' +# )) +# +# setClass('answerUser', slots = list( +# answer = 'list', +# display = 'character' +# )) + + # helpers ----------------------------------------------------------------- scroll_to_div <- function(ns = NULL, id = 'quiz-container'){ diff --git a/thinkCausal/R/mod_reproduce.R b/thinkCausal/R/mod_reproduce.R index 58d0ee3e..9094e69d 100644 --- a/thinkCausal/R/mod_reproduce.R +++ b/thinkCausal/R/mod_reproduce.R @@ -20,7 +20,7 @@ mod_reproduce_ui <- function(id){ outputId = ns('analysis_results_button_download'), label = 'Download R script', style = 'max-width: 300px', - class = if (isTRUE(golem::app_prod())) 'btn-disabled' + class = if (golem::app_prod()) 'btn-disabled' ), br(), br(), bs4Dash::box( @@ -42,7 +42,7 @@ mod_reproduce_server <- function(id, store){ ns <- session$ns # print the log - # the log is created by appending text descriptions of events to store$log + # NOTE: the log is created by appending text descriptions of events to store$log output$settings_log_text <- renderText({ log <- store$log if (length(log) == 0) log <- "No logged events to display" @@ -71,9 +71,10 @@ mod_reproduce_server <- function(id, store){ content <- function(filename) { - # this is unstable so stop here for now - if (isTRUE(options('golem.app.prod')[[1]])) req(FALSE) + # this is unstable so stop here for now in prod + req(golem::app_dev()) + # model must have fit to generate the script req(store$analysis$model$fit_good) # go to a temp dir to avoid permission issues diff --git a/thinkCausal/R/utils_global.R b/thinkCausal/R/utils_global.R index 09aa7d71..ae9761f9 100644 --- a/thinkCausal/R/utils_global.R +++ b/thinkCausal/R/utils_global.R @@ -11,7 +11,14 @@ module_ids <- list( home = 'learning_home', randomization = 'learning_randomization', post_treatment = 'learning_post_treatment', + selection = 'learning_variable_selection', + colinearity = 'learning_colinearity', estimands = 'learning_estimands', + estimands2 = 'learning_estimands2', + versionA = 'learn_versionA', + versionB = 'learn_versionB', + fundamental = 'learning_fundamental', + rand_dist = 'learning_randomization_dist', bias_efficiency = 'learning_bias_efficiency', rct_covariates = 'learning_rct_covariates', ignorability = 'learning_ignorability', diff --git a/thinkCausal/dev/02_dev.R b/thinkCausal/dev/02_dev.R index da0eb6e2..84d83ff3 100644 --- a/thinkCausal/dev/02_dev.R +++ b/thinkCausal/dev/02_dev.R @@ -34,16 +34,17 @@ usethis::use_package('shinyWidgets', min_version = '0.7.4') usethis::use_package('reactable', min_version = '0.3.0') usethis::use_package('sortable', min_version = '0.4.5') usethis::use_package('readr') -usethis::use_package('Hmisc', min_version = '4.7.0') usethis::use_package('openxlsx', min_version = '4.2.5') -usethis::use_package('readstata13', min_version = '0.10.0') usethis::use_package('patchwork', min_version = '1.1.1') usethis::use_package('shinybrowser', min_version = '1.0.0') usethis::use_package('shinydisconnect', min_version = '0.1.0') usethis::use_package('htmltools') usethis::use_package('jsonlite') usethis::use_package('waiter') +usethis::use_dev_package('shinyFeedback', remote = 'merlinoa/shinyFeedback') +usethis::use_dev_package('ggdark', remote = 'nsgrantham/ggdark') +usethis::use_dev_package('shinyQuiz', remote = 'github::priism-center/shinyQuiz') usethis::use_dev_package('plotBart', remote = 'github::priism-center/plotBart') usethis::use_package('bartCause', min_version = '1.0.6') @@ -108,6 +109,11 @@ golem::add_css_file("learn-potential-outcomes", dir = 'inst/app/www/learn/potent # scrollytell example golem::add_module(name = 'learn_scrolly_example', with_test = FALSE) +# estimands 2 +golem::add_module(name = "learn_estimands3", with_test = FALSE) +golem::add_module(name = "learn_choose", with_test = FALSE) + + ## Add helper functions ---- ## Creates fct_* and utils_* golem::add_fct("ui", with_test = FALSE) @@ -121,6 +127,7 @@ golem::add_fct('convert', with_test = TRUE) golem::add_utils('utils', with_test = TRUE) golem::add_fct('model', with_test = TRUE) + ## External resources ## Creates .js and .css files at inst/app/www golem::add_js_file("ui", dir = 'inst/app/www/js') diff --git a/thinkCausal/inst/app/www/css/analysis-select-input.css b/thinkCausal/inst/app/www/css/analysis-select-input.css new file mode 100644 index 00000000..35b4f558 --- /dev/null +++ b/thinkCausal/inst/app/www/css/analysis-select-input.css @@ -0,0 +1,14 @@ +.form-control-feedback { + position: absolute; + top: 0; + right: 0; + z-index: 2; + display: block; + width: 34px; + height: 34px; + line-height: 34px; + text-align: center; + pointer-events: none; +} + + diff --git a/thinkCausal/inst/app/www/css/reactable.css b/thinkCausal/inst/app/www/css/reactable.css index d2abe199..1d1d547a 100644 --- a/thinkCausal/inst/app/www/css/reactable.css +++ b/thinkCausal/inst/app/www/css/reactable.css @@ -2,3 +2,4 @@ background: #ae4ec2; color: #fff; } + diff --git a/thinkCausal/inst/app/www/css/thinkCausal.css b/thinkCausal/inst/app/www/css/thinkCausal.css index 7290d9fb..f3d15236 100644 --- a/thinkCausal/inst/app/www/css/thinkCausal.css +++ b/thinkCausal/inst/app/www/css/thinkCausal.css @@ -29,6 +29,14 @@ a { } +.label-primary{ + background-color: #ae4ec2 !important; +} + +.bg-primary{ + background-color: #ae4ec2 !important; +} + .btn { background-color: rgba(48, 47, 66, 0) !important; border-radius: 3; @@ -137,5 +145,9 @@ footer > a:hover{ .help-link:hover { color: #fff !important; } - +.small { + font-size: 60%; + padding-top: 0 !important; + padding-bottom: 0 !important; +} diff --git a/thinkCausal/inst/app/www/learn/colinearity/markdowns/intro.md b/thinkCausal/inst/app/www/learn/colinearity/markdowns/intro.md new file mode 100644 index 00000000..9131518a --- /dev/null +++ b/thinkCausal/inst/app/www/learn/colinearity/markdowns/intro.md @@ -0,0 +1,9 @@ +# Colinearity + +Even if two or more pre-treatment variables are highly correlated, they both should be included in the analysis. **Concerns about colinearity (high correlation between covariates) is not a valid reasons to exclude variables from a causal analysis**. +
+
+Despite these recommendations, including highly correlated variables in an analysis makes many researchers uncomfortable because this contradicts advice given in some introductory statistics courses. +
+
+We'll use a hypothetical study about the effects of wearing hyperShoes (a high performance running shoe) on running times, to explore how including or not including highly correlated variables impacts the conclusion of a causal analysis. diff --git a/thinkCausal/inst/app/www/learn/colinearity/markdowns/section1.md b/thinkCausal/inst/app/www/learn/colinearity/markdowns/section1.md new file mode 100644 index 00000000..fd043608 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/colinearity/markdowns/section1.md @@ -0,0 +1,8 @@ +### The Study + +This hyperShoe study is an *observational study* on 500 professional runners from a recent race. This race required that every runner complete to two separate qualifying races (`qualify1` and `qualify2`). + +hyperShoes are a new product and both qualifying races took place before hyperShoes were available to any runners. **This means both qualifying races must be pre-treatment variables**. We'll talk about pre-treatment vs post-treatment variable later, for now all you need to know is that **adjusting for post-treatment variables is a bad idea**. + + + diff --git a/thinkCausal/inst/app/www/learn/colinearity/markdowns/section2.md b/thinkCausal/inst/app/www/learn/colinearity/markdowns/section2.md new file mode 100644 index 00000000..eb04c9c4 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/colinearity/markdowns/section2.md @@ -0,0 +1,11 @@ +Comparing the two qualifying times, we see that times from the first qualifying race (`qualify1`) and the second qualifying race (`qualify2`) have a correlation of .85. +
+
+This is a really high correlation! +
+
+In observational studies, it is crucial we adjust for all confounders, but you also may have heard in introductory statistics courses that we should avoid including variables that are highly correlated (multiple-colinearity) in a statistical model. +
+
+We want to know the causal effect of hyperShoes on running times but it's unclear what we should or shouldn't adjust for in our analysis. + diff --git a/thinkCausal/inst/app/www/learn/colinearity/markdowns/section3.md b/thinkCausal/inst/app/www/learn/colinearity/markdowns/section3.md new file mode 100644 index 00000000..f74df115 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/colinearity/markdowns/section3.md @@ -0,0 +1,8 @@ +Every choice about including or not including covariates should be made based on whether or not it will be helpful or harmful to our estimate of the causal effect of hyperShoes on running times. + +The problem is that we without knowing the true causal effect of hyperShoes on running times we can't see whether or not including a covariate is helpful or harmful. + +Because this is a hypothetical study, we have the power to see the true causal effect of hyperShoes on running times. + +You can flip back and forth between our view of the data as Researchers (what we can see in real causal inference problems) and what we could see if we were an oracle with the power or seeing all potential outcomes. + diff --git a/thinkCausal/inst/app/www/learn/colinearity/plots/p1.png b/thinkCausal/inst/app/www/learn/colinearity/plots/p1.png new file mode 100644 index 00000000..630b2175 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/colinearity/plots/p1.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_1.md b/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_1.md index ecc4f651..a4dfd14a 100644 --- a/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_1.md +++ b/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_1.md @@ -1,4 +1,3 @@ - # Causal estimands Let's revisit the HyperShoe example from the potential outcomes module; a new high performance running shoe called the HyperShoe is released with the claim that wearing the shoe causes faster marathon running times than standard running shoes. We have collected data from 10 runners. 5 of the runners wore HyperShoes and 5 of the runners wore standard shoes. @@ -8,5 +7,3 @@ What might we want to learn about the effect of the shoes on these runners? Idea The **average treatment effect (ATE)** provides the average of all of the individual level causal effects of HyperShoes across all 10 of the runners in our sample. We saw in the potential outcomes module that there can be individual differences in the causal effect of HyperShoes. Some runners had a huge benefit from HyperShoes while others had no benefit at all. The average treatment effect masks these individual level differences and instead gives us an idea of the general trend. We work with average treatment effects because they can be estimated with more precision. **The average treatment effect still relies on within-person comparisons.** This is different from simply comparing the average running times between the observed treatment group and the observed control group. We'll walk through calculating the ATE to make these ideas more concrete. - -
diff --git a/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_ate.md b/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_ate.md index 46033ecb..839091b4 100644 --- a/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_ate.md +++ b/thinkCausal/inst/app/www/learn/estimands/markdowns/estimands_ate.md @@ -43,11 +43,11 @@ Notice the ATE is the same as when we averaged Individual Causal Effects of all

Potential outcomes table

-We can also think of the ATE within a potential outcomes table, you can hover over the graph or the table for a closer look! Using a potential outcomes table has the benifit of displaying the data in way that may be more conducive to making calculations by hand. +We can also think of the ATE within a potential outcomes table, you can hover over the graph or the table for a closer look! Using a potential outcomes table has the benefit of displaying the data in way that may be more conducive to making calculations by hand.

The average treatment effect is a summary of the entire samples within person comparisons. Remember you can calculate the ATE by taking the average of all 10 runner Individual Causal Effects or by taking the difference of the average y1 and average y0.

-Remember that calculating the ATE requiors knowing each runner's factual and counterfactual observations. For now, keep imagining that you have access to both potential outcomes (both y1 and y0) for all 10 runners. +Remember that calculating the ATE requires knowing each runner's factual and counterfactual observations. For now, keep imagining that you have access to both potential outcomes (both y1 and y0) for all 10 runners.

















diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/intro.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/intro.md new file mode 100644 index 00000000..005e15fc --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/intro.md @@ -0,0 +1,9 @@ +# Choosing an estimand with overlap + +When there is complete overlap for either the treated group or the control group, overlap can help inform your choice of a causal estimand. To understand more about the connection between overlap and choosing an estimand in observational studies we'll use a variation on our running example of the causal effect of HyperShoes on running times: + +Imagine a team of researchers attended a large marathon. As each runner crossed the finish line they recorded whether that runner wore HyperShoes or standard shoes as well as the runner's finishing time. To participate in the marathon, each runner was required to run in a qualifying race, this race took place before HyperShoes were available to any runners. The variable `qualifying time` represents each runner's time from the qualification race. For the sake of this example we'll imagine that `qualifying time` is the only confounder. + + + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section1.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section1.md new file mode 100644 index 00000000..0d96726f --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section1.md @@ -0,0 +1,8 @@ +### The Marathon Data + +Visualizing the data from the marathon, we can see clear differences between runners who wore HyperShoes and runners who did not. + +Only runners with the fast qualifying times wore HyperShoes! In fact, there are no runners with qualifying times slower than about 145 minutes that wore HyperShoes. As we'll see, this will impact our ability to estimate different estimands (the ATT, ATC or ATE). + +Let's begin by considering the Average treatment effect of the treated (ATT). + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section10.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section10.md new file mode 100644 index 00000000..3bf0e51d --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section10.md @@ -0,0 +1,5 @@ +For the majority of the control group, there are no similar runners that wore HyperShoes!! This is a big problem for us. + +Without any similar runners we have nothing to gauge what would have happened to runners with slower `qualifying times` if they had worn HyperShoes. + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section11.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section11.md new file mode 100644 index 00000000..787193b7 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section11.md @@ -0,0 +1,6 @@ +### Infinite Possible Counterfactuals + +We could imagine an infinite number of possible counterfactuals. + +Let's consider some of the possibilities! + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section12.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section12.md new file mode 100644 index 00000000..efbadef4 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section12.md @@ -0,0 +1,4 @@ +We could easily imagine that the effect of HyperShoes is the same for slower runners as it is for fast runners! + +Perhaps the mechanism behind HyperShoes would work the same regardless of runners' skills! + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section13.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section13.md new file mode 100644 index 00000000..c9a9da70 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section13.md @@ -0,0 +1,5 @@ +We could just as easily imagine a situation where hyperShoes work even better for slower runners than they do for fast runners! + +Maybe the hyperShoe works by improving running technique and the fastest runners already have mastered their technique so they get a smaller benefit from hyperShoes compared to slower runners that have much more room for improvement. + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section14.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section14.md new file mode 100644 index 00000000..e6665faf --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section14.md @@ -0,0 +1,4 @@ +It's just as likely that hyperShoes may only work for fast runners and actually cause slower runners to run even slower! + +It's possible that hyperShoes require high levels of fitness to use properly. For fast runners, who are very fit, this is not a problem but slower runners are less fit and cannot use the hyperShoe as intended causing them to run even slower. + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section15.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section15.md new file mode 100644 index 00000000..c650e23e --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section15.md @@ -0,0 +1,12 @@ +### We just dont know... + +Without any data-points to represent counterfactuals, the three possible stories we imagined are all equally plausible. + +**The lack of data-points to represent counterfactuals is called lack of complete overlap**. + +Because we lack overlap for large sections of the control group so we can't estimate the ATC in a reliable way. + + + + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section16.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section16.md new file mode 100644 index 00000000..a0b61bf0 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section16.md @@ -0,0 +1,7 @@ +### What about the ATE? + +We were able to estimate the ATT without any issues, but had problems estimating the ATC because of lack of complete overlap. We haven't considered the ATE yet. + +We'll return to our complete marathon running data and consider whether or not we can easily estimate the ATE. + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section17.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section17.md new file mode 100644 index 00000000..41f064ee --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section17.md @@ -0,0 +1,5 @@ +### The ATE + +To estimate the ATE, we need counterfactuals for both the runners that wore HyperShoes and the runners that did not wear HyperShoes! + +For the ATE, our goal is estimating the difference between wearing HyperShoes and not wearing HyperShoes for every runner in our sample. diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section18.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section18.md new file mode 100644 index 00000000..0ad51960 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section18.md @@ -0,0 +1,5 @@ +A subset of all the runners in our sample wore HyerShoes. For these runners we need to know what would have happened if they had not worn hyperShoes. + +But these are not all of the runners in our sample! + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section19.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section19.md new file mode 100644 index 00000000..c562a5de --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section19.md @@ -0,0 +1,4 @@ +The remainder of runners in our sample did not wear hyerShoes. To estimate the ATE, we also need to know what would have happened to these runners if they had worn hyperShoes. + + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section2.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section2.md new file mode 100644 index 00000000..2d19c351 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section2.md @@ -0,0 +1,6 @@ +### The ATT + +For the ATT, our goal is to estimate whether wearing HyperShoes caused these runners (red points) to run faster than they would have ran had they not worn HyperShoes. + +The ATT is the average causal effect of HyperShoes for the runners that actually wore HyperShoes. + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section20.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section20.md new file mode 100644 index 00000000..c22c4a15 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section20.md @@ -0,0 +1,9 @@ +### Potential Outcomes: ATE + +Let's put all of our data into a potential outcomes table. This will help us think about the meaning of the ATE. + +For the runners that wore HyperShoes (Z = 1), we can observe `Y1` values but are missing the `Y0` values. + +For the runners that did not wear HyperShoes (Z = 0), we can observe `Y0` values but are missing the `Y1` values. + +To estimate the ATE, we need to fill in the missing `Y0` values for runners that wore HyperShoes and the missing `Y1` values for runners that did not wear HyperShoes. diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section21.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section21.md new file mode 100644 index 00000000..06323849 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section21.md @@ -0,0 +1,5 @@ +We have a problem! Like the ATC, there is no overlap of the control group among higher values of `qualifying time` and without overlap we have no way of estimating counterfactuals for slower runners in the control group. + +In observational studies, the ATE is the most difficult average causal effect to estimate because you need complete overlap for both the treated group and the control group. + +In this example, because we did not have overlap for the ATC we will not have overlap for the ATE. diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section22.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section22.md new file mode 100644 index 00000000..fbfb1537 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section22.md @@ -0,0 +1,12 @@ +### Partial Overlap + +It is possible that you may only have partial overlap like the data shown here. + +Here we have overlap for both treated and control runners for the middle region of `qualifying times` but there is no overlap for treated runners with low `qualifying times` and there is no overlap for control runners with high `qualifying times`. + +Here is an example where there is not overlap for the ATE, ATT or ATC! + +There are no control runners with low `qualifying times` and no treated runners with high `qualifying times`. + +How should we proceed when we have not overlap at all? + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section23.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section23.md new file mode 100644 index 00000000..d70e5e3a --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section23.md @@ -0,0 +1,10 @@ +### No Overlap + +Here is an example where there is no overlap for estimating the ATE, ATT or ATC! + +There are no control runners with low `qualifying times` and no treated runners with high `qualifying times`. + +How should we proceed when we have not overlap at all? + + + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section3.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section3.md new file mode 100644 index 00000000..f9dbaa15 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section3.md @@ -0,0 +1,7 @@ +### Potential Outcomes: ATT + +Thinking about the ATT in terms of potential outcomes, we can observe every runner’s `Y1` because all of these runners are in the treated group. However, we are missing every runner’s `Y0`! + +Our problem is that we need a way to consider what would have happened to this group of runners if they had not worn HyperShoes. + +How can we proceed? diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section4.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section4.md new file mode 100644 index 00000000..398ce4db --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section4.md @@ -0,0 +1,3 @@ +In the marathon data, some runners did not wear HyperShoes but look very similar to the runners that did in terms of `qualifying time`! + +We can use information from these runners as a proxy for what would have happened to runners in the treated group if they did not have HyperShoes! diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section5.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section5.md new file mode 100644 index 00000000..40c6fe00 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section5.md @@ -0,0 +1,4 @@ +We'll ignore all the runners who do not resemble the treatment group. + +It may feel uncomfortable to disregard so much data, but remember the runners we are ignoring had much slower `qualifying times` than runners that wore HyperShoes and would not do a good job of representing a counterfactual for our treated group. + diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section6.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section6.md new file mode 100644 index 00000000..3a06c20c --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section6.md @@ -0,0 +1,5 @@ +### Filling in missing Y0 values + +We can use a statistical model like Bayesian Additive Regression Trees (BART) or linear regression to fill in our missing `Y0` values. + +Here we'll use BART, the statistical model used in the thinkCausal analyses. The red line represents our best estimate of what would have happened to each runner in the treatment group had they not worn HyperShoes! If you'd like to learn more about how statistical models are used to predict counterfactuals, check out the module on the fundamental problem of causal inference. diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section7.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section7.md new file mode 100644 index 00000000..bf4d3fd2 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section7.md @@ -0,0 +1,5 @@ +### What about the ATC? + +What if we are not interested in the ATT and wanted to estimate the average treatment effect of the controls (ATC)? + +We'll return to the original marathon running data and explore estimating the ATC. diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section8.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section8.md new file mode 100644 index 00000000..a06155f8 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section8.md @@ -0,0 +1,7 @@ +### The ATC + +The ATC is the average causal effect of HyperShoes for the runners that did not wear HyperShoes. + +When estimating the ATC, our goal is to understand whether or not the runners that did not wear HyperShoe would have ran faster if they had worn HyperShoes. + +Each blue point represents a runner that did not wear HyperShoes. We are only interested in comparing the blue points to what would have happened if each of those blue points had worn HyperShoes. diff --git a/thinkCausal/inst/app/www/learn/estimands2/markdowns/section9.md b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section9.md new file mode 100644 index 00000000..24994398 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/estimands2/markdowns/section9.md @@ -0,0 +1,7 @@ +### Potential Outcomes: ATC +If we took all the points from the last figure and put them in a potential outcomes table, we'd see that the ATC has the opposite problem of the ATT. + +For the ATC, we can observe every runners value of `Y0`, but we are missing every single value of `Y1`. + +To represent our missing `Y1` values, lets try to use the technique we did last time. This time we will use information from the treatment group to serve as conterfatuals for the control group. + diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/no_overlap.png b/thinkCausal/inst/app/www/learn/estimands2/plots/no_overlap.png new file mode 100644 index 00000000..3f776ca5 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/no_overlap.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p1.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p1.png new file mode 100644 index 00000000..494d1533 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p1.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p10.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p10.png new file mode 100644 index 00000000..b112240e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p10.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p11.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p11.png new file mode 100644 index 00000000..a7cd135e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p11.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p12.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p12.png new file mode 100644 index 00000000..0754a1bf Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p12.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p13.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p13.png new file mode 100644 index 00000000..3df13c41 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p13.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p14.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p14.png new file mode 100644 index 00000000..454ed0b5 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p14.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p15.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p15.png new file mode 100644 index 00000000..b112240e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p15.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p16.2.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p16.2.png new file mode 100644 index 00000000..367565d1 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p16.2.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p16.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p16.png new file mode 100644 index 00000000..494d1533 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p16.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p17.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p17.png new file mode 100644 index 00000000..a7cd135e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p17.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p18.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p18.png new file mode 100644 index 00000000..ff8d9087 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p18.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p19.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p19.png new file mode 100644 index 00000000..db7020fa Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p19.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p2.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p2.png new file mode 100644 index 00000000..d846ea3a Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p2.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p20.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p20.png new file mode 100644 index 00000000..0b5052da Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p20.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p21.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p21.png new file mode 100644 index 00000000..b112240e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p21.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p22.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p22.png new file mode 100644 index 00000000..f76d9757 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p22.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p23.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p23.png new file mode 100644 index 00000000..48b58bb2 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p23.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p24.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p24.png new file mode 100644 index 00000000..875278ee Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p24.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p25.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p25.png new file mode 100644 index 00000000..b9a2fee6 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p25.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p26.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p26.png new file mode 100644 index 00000000..50f18710 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p26.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p3.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p3.png new file mode 100644 index 00000000..89203e35 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p3.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p4.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p4.png new file mode 100644 index 00000000..51772bd7 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p4.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p5.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p5.png new file mode 100644 index 00000000..087b29d5 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p5.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p6.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p6.png new file mode 100644 index 00000000..494d1533 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p6.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p7.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p7.png new file mode 100644 index 00000000..470f5e72 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p7.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p8.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p8.png new file mode 100644 index 00000000..470f5e72 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p8.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/p9.png b/thinkCausal/inst/app/www/learn/estimands2/plots/p9.png new file mode 100644 index 00000000..b112240e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/p9.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/partial_overlap.png b/thinkCausal/inst/app/www/learn/estimands2/plots/partial_overlap.png new file mode 100644 index 00000000..6041e5f6 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/partial_overlap.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/quiz1.png b/thinkCausal/inst/app/www/learn/estimands2/plots/quiz1.png new file mode 100644 index 00000000..59b43154 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/quiz1.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/quiz2.png b/thinkCausal/inst/app/www/learn/estimands2/plots/quiz2.png new file mode 100644 index 00000000..a1966038 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/quiz2.png differ diff --git a/thinkCausal/inst/app/www/learn/estimands2/plots/quiz3.png b/thinkCausal/inst/app/www/learn/estimands2/plots/quiz3.png new file mode 100644 index 00000000..af702d2c Binary files /dev/null and b/thinkCausal/inst/app/www/learn/estimands2/plots/quiz3.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/equations/equation1.md b/thinkCausal/inst/app/www/learn/fundemental/equations/equation1.md new file mode 100644 index 00000000..4e6517d4 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/equations/equation1.md @@ -0,0 +1 @@ +$$\frac{(283 + 278 + 280 + 284)}{4} = 281$$ diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/intro.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/intro.md new file mode 100644 index 00000000..a358a0a9 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/intro.md @@ -0,0 +1,9 @@ +A new high performance running shoe that has been introduced with the claim that wearing hyperShoes causes runners to faster than they would have run without wearing hyperShoes. + +Let's imagine a sinlge runner Sal. For Sal,the causal effect of wearing hyperShoes on running time is the difference between Sal's running time if they had worn hyperShoes (`Y1`) and Sal's running time if they had not worn hyperShoes (`Y0`). Sal's running time with hyperShoes (`Y1`) and Sal's running time without hyperShoes (`Y0`) are potential outcomes that depend on whether or not Sal wears hyperShoes. + +The only problem with this is that Sal can not wear both Shoes at once! Sal **either** wore or did not wear hyperShoes. This is the fundamental problem of causal inference: a causal effect is the difference between potential outcomes but we can only observe a single potential outcome for a given individual. + +The fundamental problem of causal inference does not only apply to Sal. Suppose we have a sample of 20 runners from a recent marathon. We'll use this sample to explore how we can proceed with causal inference despite the fundamental problem of causal inference. + + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/scratch.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/scratch.md new file mode 100644 index 00000000..ea2b294a --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/scratch.md @@ -0,0 +1,16 @@ +
+
+Collecting more data may seem to be a simple solution. If we are missing counter-factual outcomes for each of our 20 runners, why not just have each runner re-run the race with the opposite treatment assignment. Suppose we schedule a follow-up race a week after the original race. + +In this follow-up race, runners that originally wore hyperShoes will not wear hyperShoes and runners that did not wear hyperShoes will wear hyperShoes. +
+
+The problem with this is that many things will be different in the follow-up race. After the initial 26 mile race, the runners will be tiered and likely not fully recovered a week later. How will we know if the difference between times is due to the hyperShoe or not being fully recovered? + +To avoid the issue of fatigue, we could hold the follow-up race 6 months after the original race but by doing this we have introduced other factors that could explain differences in running times. Holding the follow-up race 6 months later means the weather during the race will be considerably different than the original race. It is also possible that the runners may have changes how they train since the original race. Each runner will also be 6 months older. These factors along with a nearly infinite amount of other variable will be different between the two races. +
+
+Another problem with is approach is that it requiters that we are able to convince each of our 20 runners to come back an run another race. In practice, such follow-up is extremely difficult and we are likely to lose track of many runners along the way. +
+
+Collecting more data does not seem like a good solution to the fundamental problem of causal inference, how can we proceed? diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section1.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section1.md new file mode 100644 index 00000000..bfed26c0 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section1.md @@ -0,0 +1,20 @@ +### Observed Running Data +For each runner, we have collected data on whether they wore hyperShoes or did not wear hyperShoes, their race time `Y` and how many prior races they have participated in. +
+
+The fundamental problem of causal inference is we are missing data for either `Y1` (what the runners time would have been if they had worn hyperShoes) or `Y0` (what the runners time would have been if they had not worn hyperShoes). +
+
+`Y`, the observed running time, is the potential outcome that actually happened! +
+
+In this example, there are two potential outcomes: + +`Y1` What would have happened with hyperShoes? +`Y0` What would have happened without hyperShoes? + +The potential outcome we observe is called the factual outcome and the potential outcome we do not observe is the counter-factual outcome. +
+
+Let's consider a few specific runners. + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section10.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section10.md new file mode 100644 index 00000000..cefc6184 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section10.md @@ -0,0 +1,2 @@ +Now we can plug the average into each missing `Y1` value for runners' with 0 prior races. + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section11.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section11.md new file mode 100644 index 00000000..d2810874 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section11.md @@ -0,0 +1,2 @@ +Now we've filled in all the missing potential outcomes for runners with 0 prior races! + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section12.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section12.md new file mode 100644 index 00000000..0efe6bcb --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section12.md @@ -0,0 +1,2 @@ +We can fill in all the remaining missing counter factual outcomes by repeating this process for runners with 1, 2 and 3 prior races. + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section13.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section13.md new file mode 100644 index 00000000..d4a8f179 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section13.md @@ -0,0 +1,12 @@ +### 1 prior race +We will apply the same statagy as before but now we will move on to filling in counter-factual outcomes from runners with 1 prior race. + +**Filling in Y0** +We can fill in the missing `Y0` value for runner 7 by taking the average `Y0` value of runner 2 and runner 3. + +$$\frac{(281 + 279)}{2} = 280$$ + +**Filling in Y1** +To fill in the missing Y1 values for runner 2 and runner 3 we will use the average `Y1` value of runner 1. + +$$\frac{(273)}{1} = 273$$ diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section14.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section14.md new file mode 100644 index 00000000..a9502f65 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section14.md @@ -0,0 +1,4 @@ +### Practice: +#### Runners with 2 prior races + +Using the strategy we used for runners with 1 and 2 prior races to fill in counter factual outcomes for runners with 3 prior races. diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section15.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section15.md new file mode 100644 index 00000000..179b800a --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section15.md @@ -0,0 +1,7 @@ +### Practice: +#### Runners with 3 prior races + +We'll keep practicing by filling in the counter factual outcomes for runners with 3 prior races.
+
+Again we'll use the potential outcomes we can observe to predict the counter factual outcomes we can't observe. + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section16.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section16.md new file mode 100644 index 00000000..9d21aa9f --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section16.md @@ -0,0 +1,7 @@ +### Filled in Data + +Now we have filled in all the missing counter factual values with predictions for what would have happened if each runner had received the opposite treatment assignment. +
+
+Consider runner 1, using the `Y0` values of runners with the same number of prior races as runner 1 we predicted that if runner 1 had not worn hyperShoes they would have had a running time of 250. + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section17.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section17.md new file mode 100644 index 00000000..ea45ac34 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section17.md @@ -0,0 +1,16 @@ +### Estimating Causal Effects: +**Individual Treatment Effects** + +Now that each runner has a value for `Y1` and `Y0` we can estimate the Individual Treatment Effect (ITE) by taking the difference between `Y1` and `Y0` for each runner. +
+
+We'll consider runner 1, to *estimate* the causal effect of hyperShoes for runner 1 we take the difference between what runner 1's running time was when they wore HyperShoes (`Y1` = 224) and our prediction for what runner 1's time would have been if they had not worn hyperShoe (`Y0` = 250). +
+
+$\text{runner 1 estimated ITE} = 224 - 250 = -26$ +
+
+Repeating this for all 20 runners gives us an estimate ITE for each runner! +
+
+For all the details about Individual Treatment Effects check out the potential outcomes module. diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section18.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section18.md new file mode 100644 index 00000000..1317daf4 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section18.md @@ -0,0 +1,18 @@ +### Estimating Causal Effects: +**Average Treatment Effect** + +Now that we have filled in (imputed) all of our missing counter-factual outcomes we can *estimate* the average treatment effect. +
+
+**In this sample of runners the estimated average treatment effect of hyperShoes is -12.2.** +
+
+We can estimate the average treatment effect by taking the average of all 20 of the estimated individual treatment effects (ITE) or by taking the difference between the average of all 20 `Y1` values (256.4) and the average of all 20 `Y0` values (268.55). +
+
+Both give us the same result! For all of details about average treatment effects check out the causal estimands module! +
+
+-12.2 is only an estimate of the true ATE. **How do we know if this estimate is actually close to the true ATE?** + + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section19.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section19.md new file mode 100644 index 00000000..272b1e96 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section19.md @@ -0,0 +1,4 @@ +### title here + +How close is our *estimated* average treatment effect and our *estimated* ITEs to the the true values? + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section2.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section2.md new file mode 100644 index 00000000..cecb15d7 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section2.md @@ -0,0 +1,12 @@ +#### Runner 1 wore hyperShoes. +For runner 1: +The running time with hyperShoes (`Y1`) is the factual outcome. +
+
+What the running time would have been without hyperShoes (`Y0`) is the counter-factual outcome. +
+
+To know the causal effect of hyperShoes for Runner 1, we need take the difference between `Y1` and `Y0`. +
+
+The fundamental problem of causal inference is that we don't know what runner 1's time would have been if they had not worn hyperShoes. diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section3.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section3.md new file mode 100644 index 00000000..ec6052a5 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section3.md @@ -0,0 +1,12 @@ +#### Runner 2 did not wear hyperShoes. +For runner 2: +The running time without hyperShoes (`Y0`) is the factual outcome. +
+
+What the running time would have been with hyperShoes (`Y1`) is the counter-factual outcome. +
+
+To know the causal effect of hyperShoes for Runner 2, we need take the difference between `Y1` and `Y0`. +
+
+The fundamental problem of causal inference is that we don't know what runner 1's time would have been if they had not worn hyperShoes. diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section4.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section4.md new file mode 100644 index 00000000..530bec1b --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section4.md @@ -0,0 +1,8 @@ +### Addressing the problem +The fundamental problem of causal inference is a missing data problem. We will always be missing the counter-factual outcomes. How can we proceed if we will always be missing half of the data we need? +
+
+To move forward with causal inference we will need to fill in the missing counter-factual outcomes. +
+
+We'll do this by using the potential outcomes we can observe to predict what would have happened if a runner had received the opposite treatment assignment. diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section5.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section5.md new file mode 100644 index 00000000..5d7378e8 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section5.md @@ -0,0 +1,15 @@ +We'll start by filling-in the missing `Y0` values for the runners who have 0 prior races. +
+
+We are missing 3 `Y0` values (runner 4, runner 8 and runner 9). +
+
+But we do know the `Y0` values for runner 6, runner 13, runner 15 and runner 16. +
+
+To fill in the 3 missing `Y0` values, we can use what we know about the 4 `Y0` values we can observe. +
+
+What is the best way to turn the 4 `Y0` values we know into predictions for the 3 `Y0` values we don't know? + + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section6.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section6.md new file mode 100644 index 00000000..b4cc9577 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section6.md @@ -0,0 +1,13 @@ +### Taking the mean +The best predictions come from taking averages. +
+
+We can take the average `Y0` of the 4 runners with 0 prior races and use that average to predict what `Y0` would have been for the 3 runners with 0 prior races with missing `Y0` values. +
+
+Taking the average of the 4 `Y0` values we can observe gives us 281: + +$$\frac{(284 + 283 + 280 + 278)}{4} = 281$$ + + + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section7.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section7.md new file mode 100644 index 00000000..27bd2239 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section7.md @@ -0,0 +1,2 @@ +We can plug the average into each missing `Y0` value for runners' with 0 prior races. + diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section8.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section8.md new file mode 100644 index 00000000..b106d3f8 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section8.md @@ -0,0 +1,12 @@ +Now we will consider the missing `Y1` values for the runners who have 0 prior races. +
+
+For `Y1` we have the opposite problem: +
+We can observe the `Y1` values for runner 4, runner 8 and runner 9. +
+
+We are missing `Y1` values for runner 6, runner 13, runner 15 and runner 16. +
+
+We'll use the same approach as before, this time we will use the average of the 3 `Y1` values we can observe to predict what the 4 missing `Y1` values would have been. diff --git a/thinkCausal/inst/app/www/learn/fundemental/markdowns/section9.md b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section9.md new file mode 100644 index 00000000..0b5a4b87 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/fundemental/markdowns/section9.md @@ -0,0 +1,4 @@ +The average of the 3 observed `Y1` values is 270. +
+
+$$\frac{(266 + 272 + 273)}{3} = 270$$ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/cf1.png b/thinkCausal/inst/app/www/learn/fundemental/plots/cf1.png new file mode 100644 index 00000000..78a2d30b Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/cf1.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/cf2.png b/thinkCausal/inst/app/www/learn/fundemental/plots/cf2.png new file mode 100644 index 00000000..605a95c1 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/cf2.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/factual1.png b/thinkCausal/inst/app/www/learn/fundemental/plots/factual1.png new file mode 100644 index 00000000..6413e5f6 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/factual1.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/factual2.png b/thinkCausal/inst/app/www/learn/fundemental/plots/factual2.png new file mode 100644 index 00000000..9d5d1f7d Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/factual2.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p1.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p1.png new file mode 100644 index 00000000..8c050b01 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p1.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p2.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p2.png new file mode 100644 index 00000000..12c9e636 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p2.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p3.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p3.png new file mode 100644 index 00000000..6cbf9401 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p3.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p4.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p4.png new file mode 100644 index 00000000..7844eec4 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p4.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p5.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p5.png new file mode 100644 index 00000000..89d65754 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p5.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p6.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p6.png new file mode 100644 index 00000000..6a134488 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p6.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p6.rds b/thinkCausal/inst/app/www/learn/fundemental/plots/p6.rds new file mode 100644 index 00000000..52569d1b Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p6.rds differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p7.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p7.png new file mode 100644 index 00000000..958aa2b1 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p7.png differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p7.rds b/thinkCausal/inst/app/www/learn/fundemental/plots/p7.rds new file mode 100644 index 00000000..99456f9e Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p7.rds differ diff --git a/thinkCausal/inst/app/www/learn/fundemental/plots/p_pre4.png b/thinkCausal/inst/app/www/learn/fundemental/plots/p_pre4.png new file mode 100644 index 00000000..9582b663 Binary files /dev/null and b/thinkCausal/inst/app/www/learn/fundemental/plots/p_pre4.png differ diff --git a/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_2.md b/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_2.md index 422908e4..09367d30 100644 --- a/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_2.md +++ b/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_2.md @@ -2,6 +2,6 @@ When `bugs` **is not included** in the analysis, the causal effect of the new fertilizer is estimated by comparing the average pounds of tomatoes from plants that received fertilizer (colored in red) against the average pounds of tomatoes from plants that did not receive the new fertilizer (colored in blue). -The results of this analysis, which does not control for post-treatment variables, found that receiving fertilizer caused plants to produce an average of **1.595 more pounds of fruit**, than they would have produced had they not received the new fertilizer. +The results of this analysis, which does not control for post-treatment variables, found that receiving fertilizer caused plants to produce an average of **1.51 more pounds of fruit**, than they would have produced had they not received the new fertilizer. diff --git a/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_3.md b/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_3.md index b133fb2c..a1e96e95 100644 --- a/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_3.md +++ b/thinkCausal/inst/app/www/learn/post-treatment/markdowns/post_treatment_3.md @@ -1,3 +1,3 @@ When `bugs` **is included** in the analysis, the causal effect of the new fertilizer is estimated by comparing the average height of plants that received the new fertilizer (colored in red) against the average height and plants that did not receive the new fertilizer (colored in blue) **that is made within groups of plants that had bugs and did not have bugs**. -The results of this analysis, which does control for post-treatment variables, found that receiving fertilizer caused plants to produce an average of **1.51 more pounds of fruit**, than they would have produced had they not received the new fertilizer +The results of this analysis, which does control for post-treatment variables, found that receiving fertilizer caused plants to produce an average of **-.18 fewer pounds of fruit**, than they would have produced had they not received the new fertilizer diff --git a/thinkCausal/inst/app/www/learn/variable_selection/markdowns/intro.md b/thinkCausal/inst/app/www/learn/variable_selection/markdowns/intro.md new file mode 100644 index 00000000..e890ca61 --- /dev/null +++ b/thinkCausal/inst/app/www/learn/variable_selection/markdowns/intro.md @@ -0,0 +1,12 @@ +# Variable Selection + +For causal inference problems, the recommended approach to variable selection is to **include any pre-treatment covariate that could be predictive of the outcome variable**. + +You may have heard that including many variable in a single analysis is problematic because of co-linearity between variables or overfitting the model. In causal inference problems, co-linearity is not a problem to worry about. + +When you are using thinkCausal for a causal analysis, you do not need to worry about overfitting because algorithm used by thinkCausal automatically prevents overfitting. + +In these two learning modules you can learn about what co-linearity and overfitting are and why they are not reasons to exclude variables from a causal analysis. + + + diff --git a/thinkCausal/inst/app/www/md/help.md b/thinkCausal/inst/app/www/md/help.md index bdb2da3e..21f8a4e2 100644 --- a/thinkCausal/inst/app/www/md/help.md +++ b/thinkCausal/inst/app/www/md/help.md @@ -4,35 +4,117 @@ This is still under development


-### Study design -The name of your treatment, the units of the outcome variable, and the participants in your study are all optional fields. These fields will populate the automatic interpretations at the end of the analysis. +### Upload data +thinkCausal can load in .csv, .txt, .xlsx (Excel), .spss (SPSS), .sav (SPSS), .dta (STATA) or .sas (SAS) files. +
+ +If you are uploading a .txt file then the delimiter will also need to be specified (usually this is a tab or comma). + +thinkCausal assumes that variables are represented as columns and rows are values of corresponding variables. + +If you have nested or multi-level data, thinkCausal will assumes your data is in the long form. + +If your data does not include a header (variable/column names) row then uncheck the 'Data contains a header row' checkmark and you will be able to rename your columns on the 'Select data' page. + + + + -Example inputs for each are: -- Treatment: "**job training program**" -- Units: "**dollars**" -- Participants: "**low-income households**" +If you are using the weblink, upload files are limited to 10mb. If you are using thinkCausal locally, this does not apply.
-#### Unsure about your causal estimand? -Nisl vel pretium lectus quam id leo. Vitae et leo duis ut diam. Varius vel pharetra vel turpis nunc eget lorem. Nisl purus in mollis nunc sed. Phasellus faucibus scelerisque eleifend donec pretium vulputate sapien. Semper risus in hendrerit gravida rutrum. + +### Variable Selection +#### Select Outcome and Treatment + +Does z cause y? y is the outcome variable and z is the treatment variable. + +To select an outcome from your uploaded data you can click the corresponding box and choose the outcome variable you are interested in studying. + +You will repeat this process for a treatment variable as well. + +**What types of variables can be outcome variables?** + +At this point in time, thinkCausal can analyze outcome variables that are either continuous variables or binary variables. + +**What types of variables can be a treatment?** + +At this point in time, thinkCausal can only analyze binary treatment variables. In the future we plan to expand to accommodate additional treatment levels variables. + +**Example: Choosing an outcome and treatment for the hyperShoe:** + +Suppose a hypothetical sporting company has released a new shoe called the hyperShoe, you are interested in knowing whether or not wearing hyperShoes causes runners to run faster in the Detroit marathon than they would have ran had they not worn hyperShoes? + +In this example hyperShoes is the treatment variable and running times in the Detroit marathon is outcome variable. The hyperShoe is the cause we are studying and running time in the marathon is the effect of the cause we want to know! + +**Learning Module: Potential Outcomes** + +You can learn more about what a cause is, and the difference between treatment and outcome variables in the potential outcomes learning module: - Learn more about causal estimands + Learn more about potential outcomes -
+#### Study Design + +Different study designs make different assumptions. thinkCausal needs to know the design of your study so that it can inform you about the assumptions you are making in your analysis. + +thinkCausal supports three different study designs: + - Observational Studies (Non-Random Treatment) + - Completely Randomized Experiments + - Block Randomized Experiments + + +If you treatment variable has not been randomly assigned your study design is an observational study. + +If your treatment variable has been randomly assigned across the whole data set your study design is a completely randomized experiment. + +If your treatment variable has been randomly assigned within groups (blocks) based on another variable or variables, your study design is a blocked randomized experiment. + + +**Observational Studies (Non-Random Treatment):** + +In observational studies, the treatment variable is not randomly assigned and individuals may self select into receiving or not receiving the treatment. In thinkCausal studies without any sort of randomization of the treatment are considered observational studies. + +Sometimes it is not possible to conduct a randomized study. Consider a study on the causal effects of attending collect on income at age 30. It would be unethical to randomly assign students to attend or not attend college. Yet, understanding the effect of college on income is an important policy question! + +Observational studies have imbalance between the treatment group and the control group. In our college example, on average, students that attend college may come from wealthier families and students who do not attend college may come from poorer families. Differences in the average family wealth between students that attend and don't attend college is an example of imbalance. + +thinkCausal can estimate the causal effects of observational studies + + + + +**Completely Randomized Experiment:** + +In a completely randomized experiment, the treatment variable is randomly assigned. If everyone in the study has the same probability of receiving the treatment then the study is a completely randomized experiment. + +Consider the hyperShoe, a new type of running shoe released with the claim that wearing hyperShoes causes runners to run faster marathons. If we recruited a group of runners to participate in our study, and flipped a coin to determine if each runner would wear hyperShoes or not wear hyperShoes then this would be a completely randomized experiment because every runners has a .5 probability of wearing hyperShoes and a .5 probability of not wearing hyperShoes. + +The probability of receiving the treatment does not have to .5! If each runner was assigned a .4 probability of receiving the hyperShoe and a .6 probability of not receiving the hyperShoe our study would still be a completely randomized experiment. + +The important detail of what makes a study a completely randomized experiment is that **every** participant has the same probability of receiving the treatment and the same probability of receiving the control. + + +**Block Randomized Experiment:** + +In a block randomized experiment the treatment variable is randomly assigned within blocks defined by one or more other variables. + +Using the hyperShoes as our example, suppose a small subset of the runners in our sample are professional runners and the remainder of runners in our sample are amateur runners. + +In a block randomized experiment, the randomization of the treatment assignment takes place within groups (blocks) defined by another variable (in this example the other variable is professional status). In a block randomized experiment we could randomize 60% of the professional runners to receive the hyperShoes and 50% of the amateur runners to receive the hyperShoes. + +Notice that within the two blocks (professionals and amateurs) each runners has the same probability of receiving the treatment. + +In block randomized experiments it is important to always adjust for the variable you have blocked on! -#### Unsure about your study design? -Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Sit amet massa vitae tortor condimentum lacinia quis vel. Commodo sed egestas egestas fringilla. Sed velit dignissim sodales ut. Ac odio tempor orci dapibus ultrices in iaculis nunc. Ut sem viverra aliquet eget sit amet tellus. Sit amet venenatis urna cursus eget nunc scelerisque viverra mauris. Fusce id velit ut tortor. -Ipsum dolor sit amet consectetur. Id eu nisl nunc mi ipsum. Ut aliquam purus sit amet luctus venenatis lectus. Sed augue lacus viverra vitae. Mattis vulputate enim nulla aliquet porttitor. Risus quis varius quam quisque. Arcu odio ut sem nulla. Nunc sed id semper risus in hendrerit gravida. -
#### Survey weights -Diam vel quam elementum pulvinar etiam non quam. Vel risus commodo viverra maecenas accumsan. Tristique senectus et netus et malesuada fames ac turpis egestas. Aliquam faucibus purus in massa tempor nec feugiat nisl. Morbi tempus iaculis urna id volutpat lacus laoreet non curabitur. +Sometimes our data comes from surveys that are not representative of the population we are inferences about.
@@ -41,24 +123,29 @@ Risus in hendrerit gravida rutrum quisque non. Fermentum posuere urna nec tincid
-### Data -Data should be rectangular, wide data and can be a .csv, .txt, .xlsx, .spss, or .dta file. If you are uploading a .txt file then the delimiter will also need to be specified (usually this is a tab or comma). If your data does not include a header row then uncheck the 'Data contains a header row' checkmark and you will be able to rename your columns on the 'Select data' page. - - -Upload files are limited to 10mb. - -
+#### Select covariates +**Which variables should I include?** -#### Upload data -Each column of your dataset must be matched to one of these roles depending on study design: Covariate, Treatment, Outcome, Block, Post-treatment, or Exclude. These roles are auto-populated based on the column name and column values. You can change the roles by dragging-and-dropping the column names to each respective bucket. Treatment and Response should contain only one column respectively. Please exclude any ID columns or other irrelevant columns from your dataset. +Include all **pre-treatment** variables that you believe could predict the outcome in the analysis. thinkCausal estimates casual effects using Bayesian Additive Regression Trees (BART), BART automatically prevents over-fitting and can accommodate many covariates. Some causal inference studies include over 300 variables as covariates. -ID, index, and post-treatment variables are excluded from the analysis. +**Post-treatment variables should not be included as covariates in the model.** A post-treatment variable is any variable that could plausibly be be influenced by the treatment. Learn more about post-treatment variables +**ID variables should not be included as covariates in the model.** ID variables are variables that represent row numbers or participant IDs and do not predict the outcome variable. + + +**How do I select variables?** + +Use the drag-and-drop to include additional variables in the analysis. You may click multiple variables to drag-and-drop a group of variables. + +You can move all the variables in your dataset by clicking "Move all covariates to include box". + +**After you have selected variables to include in the analysis click on the "Save variable selection & continue" button. +