Causality

Task 1: SDO, ATE and Randomization

📂 1. 데이터 불러오기 및 변수 생성

• 데이터 다운로드 링크. read.csv()를 사용하여 데이터를 불러오기.

• 변수 설명

  • group_dummy: 처치를 받았는지 여부 (1 = 처치군, 0 = 통제군).
    
  • Y0: 처치를 받지 않았을 경우의 잠재적 결과 \((Y_i^0)\).
    
  • Y1: 처치를 받았을 경우의 잠재적 결과 \((Y_i^1)\).

• 다음 변수들을 생성하시오.

  • 관측된 결과 \(Y_i = D_i \times Y_i^1 + (1 - D_i) \times Y_i^0\)
  • 개별 처치 효과 \(\delta_i = Y_i^1 - Y_i^0\)

link <- "https://chung-jiwoong.github.io/FMB819-Slides/chapter_causality/data/toy_data_2.csv"
toy_data <- read.csv(link)

library(tidyverse)

toy_data <- toy_data %>%
    mutate(Y = Y1 * group_dummy + (1 - group_dummy) * Y0,
           delta = Y1 - Y0)

📊 2. ATE 및 SDO 계산

• ATE (Average Treatment Effect) 계산하시오.
• SDO (Simple Difference in Mean Outcomes) 계산하시오.
• Bias가 존재하는가? 크기는 얼마나 큰가?

ATE = mean(toy_data$delta)
ATE

## [1] 2.10418

treatment_mean <- mean(toy_data$Y[toy_data$group == "treatment"])
control_mean <- mean(toy_data$Y[toy_data$group == "control"])
SDO <- treatment_mean - control_mean

SDC가 ATE보다 약 50%정도 큽니다.

🔀 3. 무작위 배정된 데이터에서 SDO 계산

• 새로운 데이터 다운로드 링크. 이 데이터에서는 동일한 개인을 임의로 무작위 배정(random assignment)하였음.

• \(Y_i\) 재계산 하시오. 새로운 처치 배정에 맞춰 다시 계산해야 함.

• 무작위 배정에서 SDO 계산

  • 편향이 거의 0에 가까워야 함.
    
  • 하지만 정확히 0이 되지 않는 이유는 무엇일까?

link_rand <- "https://chung-jiwoong.github.io/FMB819-Slides/chapter_causality/data/toy_data_random.csv"
toy_data_random <- read.csv(link_rand)

toy_data_random <- toy_data_random %>%
    mutate(Y = Y1 * group_random_dummy + (1 - group_random_dummy) * Y0)

SDO_random = mean(toy_data_random$Y[toy_data_random$group_random == "treatment"]) - mean(toy_data_random$Y[toy_data_random$group_random == "control"])
SDO_random

## [1] 2.047158

ATE - SDO_random

## [1] 0.05702187

편향은 0.057와 같습니다. 이는 0이 아닙니다. 그 이유는 표본 크기가 충분히 크지 않아 두 그룹 간 차이에 존재하는 무작위 변동성을 완전히 상쇄할 수 없기 때문입니다.

📌 4. (Optional) 편향 요소 확인

1. 선택 편향(Selection Bias) 계산하시오.
   
2. 이질적 처치 효과 편향(Heterogeneous Treatment Effect Bias) 계산하시오.
   
3. 아래 식이 성립하는지 확인: \[ SDO = ATE + \text{Selection Bias} + \text{Heterogeneous Treatment Effect Bias} \]

selection_bias = mean(toy_data$Y0[toy_data$group == "treatment"]) - mean(toy_data$Y0[toy_data$group == "control"])

het_trt_effect_bias = (1 - sum(toy_data$group == "treatment") / nrow(toy_data)) * (mean(toy_data$delta[toy_data$group == "treatment"]) - mean(toy_data$delta[toy_data$group == "control"]))

SDO

## [1] 3.208584

ATE + selection_bias + het_trt_effect_bias

## [1] 3.208584

Task 2: STAR data

📂 1. 데이터 불러오기: 데이터 다운로드 링크
- 데이터를 star_df 객체에 저장. 변수 설명 도움말 확인.
(📌데이터가 재구성(reshaped)되어, 변수명 끝의 “k”, “1” 등의 숫자는 무시.)

star_df = read_csv("https://chung-jiwoong.github.io/FMB819-Slides/chapter_causality/data/star_data.csv")

🔍 2. 데이터의 기본 정보 확인

• 관찰 단위(Unit of observation)는 무엇인가?

str(star_df)

관측단위는 학생-학급 (student-grade).

• 1. 랜덤 학급 배정(random class assignment): star, (ii) 학생의 학년(class grade): grade, (iii) 결과 변수(outcomes of interest): read & math

📊 3. 데이터 크기 및 결측값(NA) 분석

• 총 관측치 수는 몇 개인가? 원래에는 학생별로 관측단위였는데, 학년-학생 단위로 데이터를 재구조화하였기 때문에 NA 값이 많음. 또한 NA는 여러 가지 이유로 실험을 떠나게 된 학생들임.

# 총 관측치 수 확인
nrow(star_df)

# 결측값 개수 확인
sum(is.na(star_df))

# 결측값이 포함된 변수 확인
colSums(is.na(star_df))

🚀 4. 결측값 처리 (NA 제거)

• 다음 코드 실행하여 결측값이 없는 경우만 유지:

star_df <- star_df[complete.cases(star_df),] # 또는
star_df <- na.omit(star_df)

📈 5. 무작위 배정 확인 (Balancing Checks)

• 랜덤 배정이 잘 이루어졌는지 확인하기 위해, 그룹별 기초 통계량을 계산.
• 다음 항목별 평균 비율(%)을 학년별(grade) 및 처치군별(treatment class)로 비교: 1️⃣ 여학생 비율 (percentage of girls), 2️⃣ 아프리카계 미국인 비율 (percentage of African Americans), 3️⃣ 무료 급식 대상 비율 (percentage of free lunch qualifiers)을 살펴보자.

(📌 힌트: 다음 코드로 여학생 비율 계산 가능 (dplyr 활용 필요): share_female = mean(gender == "female") * 100.)

star_df %>%
    group_by(grade, star) %>%
    summarise(
        share_female = mean(gender == "female") * 100,
        share_african_american = mean(ethnicity == "afam") * 100,
        share_free_lunch = mean(lunch == "free") * 100)

## # A tibble: 12 × 5
## # Groups:   grade [4]
##    grade star         share_female share_african_american share_free_lunch
##    <chr> <chr>               <dbl>                  <dbl>            <dbl>
##  1 1     regular              48.7                   37.3             51.5
##  2 1     regular+aide         47.8                   29.8             50.8
##  3 1     small                48.6                   31.9             47.9
##  4 2     regular              48.3                   36.7             50.6
##  5 2     regular+aide         47.7                   33.8             48.2
##  6 2     small                49.1                   33.3             46.6
##  7 3     regular              48.9                   35.2             49.7
##  8 3     regular+aide         47.2                   34.3             49.1
##  9 3     small                50.1                   31.6             46.8
## 10 k     regular              48.5                   28.5             46.0
## 11 k     regular+aide         48.8                   32.2             49.3
## 12 k     small                48.0                   30.2             46.7

Task 3

📌 1. 아래 코드를 실행하여 1학년(grade == “1”)이며, 일반 학급(regular) 또는 소규모 학급(small)에 속한 학생들만 선택.

star_df_1_small <- star_df %>%
    filter(star %in% c("small","regular") & grade == "1")

📊 2. 두 그룹의 평균 수학 점수 및 차이 계산 (Base R 사용)

mean_small = mean(star_df_1_small$math[star_df_1_small$star == "small"])
mean_small

## [1] 539.0885

mean_regular = mean(star_df_1_small$math[star_df_1_small$star == "regular"])
mean_regular

## [1] 526.4434

ATE = mean_small - mean_regular
ATE

## [1] 12.64506

🔄 3. 더미 변수 생성: 소규모 학급(small) = 1 (TRUE), 일반 학급(regular) = 0 (FALSE) 힌트: treatment = (star == "small").

star_df_1_small <- star_df_1_small %>%
    mutate(treatment = (star == "small"))
table(star_df_1_small$treatment)

## 
## FALSE  TRUE 
##  2359  1786

📈 4. 회귀 분석 실행

❓ 5. 결과 해석: 회귀 분석 결과가 2번 질문에서 구한 평균 차이와 일치하는가?

절편은 통제 집단(즉, 일반 크기의 학급)에 속한 1학년 학생들의 예상 수학 점수를 의미합니다. 즉, 통제 집단에 속한 1학년 학생들의 예상 수학 점수는 526.44점입니다. 이는 질문 2에서 계산된 동일한 평균과 계수를 비교하면 직접 확인할 수 있습니다.

기울기 계수는 실험 집단과 통제 집단에 속한 1학년 학생들의 예상 수학 점수 차이를 나타냅니다. 즉, 소규모 학급에 속한 1학년 학생들은 일반 크기의 학급 학생들보다 평균적으로 12.65점 더 높은 점수를 받을 것으로 예상됩니다. 이 계수 역시 질문 2에서 계산된 평균 차이와 비교할 수 있습니다.