Merge pull request #50 from r-causal/cleanup-post-nyc

Author: malcolmbarrett

exercises/05-pscores-exercises.qmd

@@ -4,6 +4,7 @@ format: html
 ---
 
 ```{r}
+#| label: setup
 library(tidyverse)
 library(broom)
 library(touringplans)
@@ -20,7 +21,7 @@ We are interested in examining the relationship between whether there were "Extr
 
 Below is a proposed DAG for this question.
 
-*Knit this document to see the DAG or refer to the slides*.
+*Render this document to see the DAG or refer to the slides*.
 
 ```{r}
 set.seed(1234)
@@ -82,7 +83,7 @@ Here's a data dictionary of the variables we need in the `seven_dwarfs` data set
 
 ## Your Turn
 
-*After updating the code chunks below, change `eval = TRUE` before knitting.*
+*After updating the code chunks below, change `eval: true` before rendering*
 
 Now, fit a propensity score model for `extra_magic_morning` using the above proposed confounders.
 

exercises/06-pscores-weighting-exercises.qmd renamed to exercises/06-pscores-using-exercises.qmd

@@ -1,10 +1,11 @@
 ---
-title: "Propensity Score Weighting"
+title: "Using Propensity Scores"
 format: html
 ---
 
 
-```{r setup}
+```{r}
+#| label: setup
 library(tidyverse)
 library(broom)
 library(touringplans)
@@ -32,7 +33,7 @@ seven_dwarfs_prop <- propensity_model |>
 
 ## Your Turn 1 (Matching)
 
-_After updating the code chunks below, change `eval = TRUE` before knitting._
+*After updating the code chunks below, change `eval: true` before rendering*
 
 Create at "matched" data set using the same propensity score model as above and a caliper of 0.2.
 
@@ -51,7 +52,7 @@ matched_df <- ___(matched_dwarfs)
 
 ## Your Turn 2 (Weighting)
 
-_After updating the code chunks below, change `eval = TRUE` before knitting._
+*After updating the code chunks below, change `eval: true` before rendering*
 
 Add the ATE weights to the data frame, `seven_dwarfs_prop`
 
@@ -76,16 +77,6 @@ Stretch Goal 2:
 
 Update the code below to examine the distribution of the weighted sample. **HINT** the part that needs to be updated is the `weight` parameter in two of the `geom_mirror_histogram()` call.
 
-```{r}
-#| eval: false
-seven_dwarfs_prop_wide <- seven_dwarfs_prop |>
-  pivot_wider(
-    names_from = extra_magic_morning, 
-    values_from = .fitted, 
-    names_prefix = "extra_magic_morning_p"
-  )
-```
-
 
 ```{r}
 #| eval: false

exercises/07-pscores-diagnostics-exercises.qmd

@@ -5,10 +5,12 @@ format: html
 
 
 ```{r}
+#| label: setup
 library(tidyverse)
 library(broom)
 library(touringplans)
 library(halfmoon)
+library(propensity)
 ```
 
 We are interested in examining the relationship between whether there were "Extra Magic Hours" in the morning (the **exposure**) and the average wait time for the Seven Dwarfs Mine Train the same day between 9am and 10am (the **outcome**).
@@ -28,12 +30,12 @@ propensity_model <- glm(
 
 seven_dwarfs_ps <- propensity_model |>
   augment(type.predict = "response", data = seven_dwarfs) |>
-  mutate(w_ate = 1 / ifelse(extra_magic_morning == 0, 1 - .fitted, .fitted))
+  mutate(w_ate = wt_ate(.fitted, extra_magic_morning))
 ```
 
 ## Your Turn 1
 
-_After updating the code chunks below, change `eval = TRUE` before knitting._
+*After updating the code chunks below, change `eval: true` before rendering*
 
 Calculate the standardized mean differences with and without weights
 

exercises/08-outcome-model-exercises.qmd

@@ -5,6 +5,7 @@ format: html
 
 
 ```{r}
+#| label: setup
 library(tidyverse)
 library(broom)
 library(touringplans)
@@ -18,7 +19,7 @@ We are interested in examining the relationship between whether there were "Extr
 
 ## Your turn
 
-_After updating the code chunks below, change `eval = TRUE` before knitting._
+*After updating the code chunks below, change `eval: true` before rendering*
 
 Create a function called `ipw_fit` that fits the propensity score model from Exercise 03, incorporates the ATE weights calculated in Exercise 04, and fits a weighted outcome model.
 

exercises/09-continuous-exposures.qmd

@@ -8,6 +8,7 @@ format: html
 library(tidyverse)
 library(broom)
 library(touringplans)
+library(propensity)
 ```
 
 For this set of exercises, we'll use propensity scores for continuous exposures.

exercises/10-g-computation-exercises.qmd

@@ -8,6 +8,7 @@ format: html
 library(tidyverse)
 library(broom)
 library(touringplans)
+library(propensity)
 
 seven_dwarfs <- seven_dwarfs_train_2018 |>
   filter(hour == 9)

exercises/11-tipr.qmd

@@ -4,6 +4,7 @@ format: html
 ---
 
 ```{r}
+#| label: setup
 library(tipr)
 ```
 

exercises/13-quartets.qmd

@@ -4,6 +4,7 @@ format: html
 ---
 
 ```{r}
+#| label: setup
 library(quartets)
 ```
 

slides/raw/01-causal_modeling_whole_game.html

@@ -406,7 +406,7 @@ <h1 class="title">Causal Modeling in R: Whole Game</h1>
 <section id="section" class="slide level2" data-background-color="#23373B">
 <h2></h2>
 <ol type="1">
-<li class="fragment">Specify causal question</li>
+<li class="fragment">Specify causal question (e.g.&nbsp;target trial)</li>
 <li class="fragment">Draw assumptions (causal diagram)</li>
 <li class="fragment">Model assumptions (e.g.&nbsp;propensity score)</li>
 <li class="fragment">Analyze propensities (diagnostics)</li>
@@ -493,6 +493,10 @@ <h3 id="what-do-i-need-to-control-for">What do I need to control for?</h3>
 
 
 <img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-7-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<section class="slide level2">
+
+
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-8-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section id="multivariable-regression-whats-the-association" class="slide level2">
 <h2>Multivariable regression: what’s the association?</h2>
 <div class="cell" data-layout-align="center">
@@ -557,23 +561,23 @@ <h3 id="diagnose-your-model-assumptions"><strong>diagnose your model assumptions
 <section id="whats-the-distribution-of-weights" class="slide level2">
 <h2>What’s the distribution of weights?</h2>
 
-<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-11-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-12-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section id="what-are-the-weights-doing-to-the-sample" class="slide level2">
 <h2>What are the weights doing to the sample?</h2>
 
-<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-12-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-13-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section id="what-are-the-weights-doing-to-the-sample-1" class="slide level2">
 <h2>What are the weights doing to the sample?</h2>
 
-<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-13-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-14-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section class="slide level2">
 
 
-<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-15-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-16-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section class="slide level2">
 
 
-<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-16-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-17-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section id="section-8" class="slide level2 center" data-background-color="#23373B">
 <h2></h2>
 <h3 id="estimate-the-causal-effects"><strong>estimate the causal effects</strong></h3>
@@ -712,7 +716,7 @@ <h2>Using {rsample} to bootstrap our causal effect</h2>
 </div></section><section id="section-10" class="slide level2 center">
 <h2></h2>
 
-<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-25-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
+<img data-src="01-causal_modeling_whole_game_files/figure-revealjs/unnamed-chunk-26-1.png" style="width:80.0%" class="r-stretch quarto-figure-center"></section>
 <section id="section-11" class="slide level2 center" data-background-color="#23373B">
 <h2></h2>
 <h3 id="our-causal-effect-estimate-3.5-kg-95-ci-2.4-kg-4.4-kg"><em>Our causal effect estimate: <strong>3.5 kg (95% CI 2.4 kg, 4.4 kg)</strong></em></h3>
@@ -724,8 +728,8 @@ <h3 id="review-the-quarto-file-later"><strong>Review the Quarto file… later!</
 <section id="resources" class="slide level2" data-background-color="#23373B">
 <h2>Resources</h2>
 <h3 id="causal-inference-comprehensive-text-on-causal-inference.-free-online."><a href="https://www.hsph.harvard.edu/miguel-hernan/causal-inference-book/">Causal Inference</a>: Comprehensive text on causal inference. Free online.</h3>
-<h3 id="causal-inference-notebook-r-code-to-go-along-with-causal-inference"><a href="http://causalinferencebookr.netlify.com">Causal Inference Notebook</a>: R code to go along with Causal Inference</h3>
 <h3 id="bootstrap-confidence-intervals-with-rsample"><a href="https://rsample.tidymodels.org/articles/Applications/Intervals.html">Bootstrap confidence intervals with {rsample}</a></h3>
+<h3 id="r-causal-our-github-org-with-r-packages-and-examples"><a href="https://github.com/r-causal">R-causal</a>: Our GitHub org with R packages and examples</h3>
 <div class="footer footer-default">
 
 </div>

slides/raw/01-causal_modeling_whole_game.qmd

@@ -92,9 +92,17 @@ nhefs_complete_uc |>
 
 ```{r}
 #| echo: false
-#| fig.height: 5.5
+#| fig.width: 9
 library(ggdag)
 # set up DAG
+coords <- time_ordered_coords(
+  list(
+    c("active", "age", "education", "exercise", "race", "sex", "smokeintensity", 
+"smokeyrs", "wt71"),
+    "qsmk",
+    "wt82_71"
+  )
+)
 smk_wt_dag <- dagify(
   # specify causes of quitting smoking and weight gain:
   qsmk ~ sex + race + age + education + 
@@ -104,6 +112,7 @@ smk_wt_dag <- dagify(
   # specify causal question:
   exposure = "qsmk", 
   outcome = "wt82_71",
+  coords = coords,
   # set up labels:
   # here, I'll use the same variable names as the data set, but I'll label them
   # with clearer names
@@ -128,7 +137,7 @@ smk_wt_dag <- dagify(
     "smokeyrs" = "yrs of\nsmoking"
   )
 ) |>
-  tidy_dagitty(layout = "star")
+  tidy_dagitty()
 
 smk_wt_dag |>
   filter(name %in% c("qsmk", "wt82_71")) |>
@@ -142,7 +151,7 @@ smk_wt_dag |>
 
 ```{r}
 #| echo: false
-#| fig.height: 5.5
+#| fig.width: 9
 smk_wt_dag |>
   ggdag(text = FALSE, use_labels = "label") +
   ylim(min(smk_wt_dag$data$y) - 0.25, max(smk_wt_dag$data$y) + 0.25) +  
@@ -154,6 +163,80 @@ smk_wt_dag |>
 
 ### What do I need to control for?
 
+---
+
+```{r}
+#| echo: false
+#| fig.width: 15
+library(ggokabeito)
+glyph <- function(data, params, size) {
+    data$shape <- 15
+    data$size <- 12
+    ggplot2::draw_key_point(data, params, size)
+}
+
+smk_wt_dag |>
+    dag_paths() |>
+    mutate(
+        effects = case_when(
+            set == "1" & path == "open path" ~ "true effect",
+            path == "open path" ~ "confounding effect",
+            TRUE ~ NA_character_
+        ),
+        effects = factor(effects, c("true effect", "confounding effect"))
+    ) |>
+    ggplot(aes(x = x, y = y, xend = xend, yend = yend, color = effects, alpha = path)) +
+    geom_dag_edges(aes(edge_alpha = path, edge_colour = effects), show.legend = FALSE) +
+    geom_dag_point(
+        data = function(.x) dplyr::filter(.x, is.na(path)),
+        key_glyph = glyph
+    ) +
+    geom_dag_point(
+        data = function(.x) dplyr::filter(.x, !is.na(path)),
+        key_glyph = glyph
+    ) +
+    facet_wrap(vars(fct_inorder(factor(set)))) +
+    expand_plot(
+        expand_x = expansion(c(0.25, 0.25)),
+        expand_y = expansion(c(0.1, 0.1))
+    ) +
+    theme_dag() +
+    theme(
+        legend.position = "top",
+        legend.spacing.x = unit(8, "mm"),
+        legend.text = element_text(size = rel(2.5)),
+        legend.box.margin = margin(b = 20),
+        strip.text = element_blank()
+    ) +
+    coord_cartesian(clip = "off") +
+    scale_alpha_manual(
+        drop = FALSE,
+        values = c("open path" = 1),
+        na.value = .5,
+        breaks = "open path"
+    ) +
+    ggraph::scale_edge_alpha_manual(
+        drop = FALSE,
+        values = c("open path" = 1),
+        na.value = .5,
+        breaks = "open path"
+    ) +
+    scale_color_okabe_ito(
+        name = NULL,
+        na.value = "grey90",
+        order = c(3, 6),
+        breaks = c("true effect", "confounding effect")
+    ) +
+    scale_edge_color_okabe_ito(
+        name = NULL,
+        na.value = "grey90",
+        order = c(3, 6),
+        breaks = c("true effect", "confounding effect")
+    ) +
+    guides(alpha = "none", edge_alpha = "none")
+```
+
+
 ---
 
 ```{r}
@@ -291,7 +374,7 @@ plot_df <- nhefs_complete_uc |>
 #| echo: false
 #| fig.height: 5.5
 ggplot(
-  data = plot_df |> filter(method == "wts"),
+  data = plot_df |> filter(method == "observed"),
   aes(x = abs(smd), y = variable, group = method, color = method, fill = method)
 ) +
   geom_line(orientation = "y", size = 1) +