【第２章因果関係】練習問題2.8.2「同性婚に関する意見の変化」
１．データセット・元論文の紹介
（１）データセット
・第２章の練習問題に取り組む際に必要になるデータセットは、第１章の練習問題と同様に以下のリンク先からダウンロードできる。
（２）元論文
・この練習問題の元論文を参考のためリンクを貼っておく。
２．練習問題2.8.2「同性婚に関する意見の変化」
（１）【研究１】ランダム化の適切性の確認
＜平均・中央値＞
①各グループの同性婚への評価SSMの平均は殆ど同じ値（差は0.1未満）
1)No Contact： 3.043
2)Same-Sex Marriage Script by Gay Canvasser：3.025
3)Same-Sex Marriage Script by Straight Canvasser：3.1
②各グループのSSMの中央値は、全く同じ「3」になっている
＜ヒストグラム・まとめ＞
①SSMのヒストグラムの形状も各グループで殆ど同じ
②ランダム化は、適切に行われていると考えられる
> gay <- read.csv("gay.csv")
> dim(gay)
[1] 69592 4
> gay.first <- gay[gay$study == 1 & gay$wave == 1,]
> summary(gay.first)
study treatment wave ssm
Min. :1 No Contact :5238 Min. :1 Min. :1.000
1st Qu.:1 Recycling Script by Gay Canvasser :1046 1st Qu.:1 1st Qu.:1.000
Median :1 Recycling Script by Straight Canvasser :1039 Median :1 Median :3.000
Mean :1 Same-Sex Marriage Script by Gay Canvasser :1151 Mean :1 Mean :3.053
3rd Qu.:1 Same-Sex Marriage Script by Straight Canvasser:1033 3rd Qu.:1 3rd Qu.:5.000
Max. :1 Max. :1 Max. :5.000
> tapply(gay.first$ssm,gay.first$treatment,summary)
$`No Contact`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 3.043 5.000 5.000
$`Recycling Script by Gay Canvasser`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 3.131 5.000 5.000
$`Recycling Script by Straight Canvasser`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 3.013 5.000 5.000
$`Same-Sex Marriage Script by Gay Canvasser`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 3.025 5.000 5.000
$`Same-Sex Marriage Script by Straight Canvasser`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.0 1.0 3.0 3.1 5.0 5.0
> par(mfrow = c(1,3))
> hist(gay.first$ssm[gay$treatment == "No Contact"],freq = FALSE ,
+ breaks = seq(from = 0.5,to = 5.5, by =1),xlab = "SSM",main "1th No contact")
> hist(gay.first$ssm[gay$treatment == "Same-Sex Marriage Script by Gay Canvasser"],freq = FALSE ,
+ breaks = seq(from = 0.5,to = 5.5, by =1),xlab = "SSM",main = "1th Gay Canvasser")
> hist(gay.first$ssm[gay$treatment == "Same-Sex Marriage Script by Straight Canvasser"],freq = FALSE ,
+ breaks = seq(from = 0.5,to = 5.5, by =1),xlab = "SSM",main = "1th Straight Canvasser")
（２）【研究１】第２波調査の平均トリートメント効果
＜計算の前提＞
①第１派調査のグループ別のSSM平均値を計算（hoge1）
②第２波調査のみのデータでグループ別のSSM平均値を計算（hoge2）
③第１波調査と第２波調査におけるグループ別の平均値の差を求める
＜結果の確認＞
①コントロールグループの平均値は殆ど変化は無い（差は0.0031）
②ゲイの訪問員が同性婚台本を使った場合、平均は約0.114上昇
③ストレートの訪問員が同性婚台本を使った場合、平均は約 0.062上昇
> gay.second <- gay[gay$study == 1 & gay$wave == 2,]
> summary(gay.second)
study treatment wave ssm
Min. :1 No Contact :4670 Min. :2 Min. :1.000
1st Qu.:1 Recycling Script by Gay Canvasser : 940 1st Qu.:2 1st Qu.:1.000
Median :1 Recycling Script by Straight Canvasser : 935 Median :2 Median :3.000
Mean :1 Same-Sex Marriage Script by Gay Canvasser :1018 Mean :2 Mean :3.068
3rd Qu.:1 Same-Sex Marriage Script by Straight Canvasser: 902 3rd Qu.:2 3rd Qu.:5.000
Max. :1 Max. :2 Max. :5.000
> hoge1 <- tapply(gay.first$ssm,gay.first$treatment,mean,na.rm = TRUE)
> hoge1 <- as.data.frame(hoge1)
> hoge2 <- tapply(gay.second$ssm,gay.second$treatment,mean,na.rm = TRUE)
> hoge2 <- as.data.frame(hoge2)
> hoge1
hoge1
No Contact 3.042764
Recycling Script by Gay Canvasser 3.130975
Recycling Script by Straight Canvasser 3.013474
Same-Sex Marriage Script by Gay Canvasser 3.025195
Same-Sex Marriage Script by Straight Canvasser 3.099710
> hoge2
hoge2
No Contact 3.039615
Recycling Script by Gay Canvasser 3.107447
Recycling Script by Straight Canvasser 3.004278
Same-Sex Marriage Script by Gay Canvasser 3.139489
Same-Sex Marriage Script by Straight Canvasser 3.161863
> hoge2 - hoge1
hoge2
No Contact -0.003149853
Recycling Script by Gay Canvasser -0.023528335
Recycling Script by Straight Canvasser -0.009196420
Same-Sex Marriage Script by Gay Canvasser 0.114293712
Same-Sex Marriage Script by Straight Canvasser 0.062152944（３）【研究１】同性婚台本を使わない場合の効果
＜トリートメントグループの追加目的＞
①ゲイ又はストレートの訪問員による同性婚台本での処置の場合、その
トリートメント効果は「①ゲイの訪問員との接触」と「②同性婚台本
との接触」の２つに分けられることが考えられる。
②上記①の効果のみを把握するため、トリートメントグループに「リサ
イクル台本」を使用した場合を追加したと思われる。
＜結果の確認＞
①ゲイの訪問員の場合、同性婚台本とリサイクル台本によるSSM平均値
の差は約0.032と非常に小さい。
②ストレートの訪問員の場合、同性婚台本とリサイクル台本によるSSM
平均値の差は約0.1.57と大きい。
③外集団（今回の場合ゲイ）との接触であれば、接触時の内容（今回の
場合、同性婚台本とリサイクル台本）は関係なく、接触仮説が成立す
る可能性がある。
④一方で、外集団でなくとも（今回の場合ストレート）、接触の内容が
外集団に関する内容（今回の場合同性婚台本）であれば、外集団への
評価は改善する可能性がある。
> hoge2[4,] - hoge2[2,]
[1] 0.03204239
> hoge2[5,] - hoge2[3,]
[1] 0.1575845（４）【研究１】戸別訪問の持続効果
＜トリートメント効果の持続性の条件＞
①SSMを変えうる要因が同じように各グループに生じていること
②グループ（コントロール・トリートメント）間の平均に差があること
③グループ間の平均の差が時間の経過で減衰していないこと
＜結果の確認＞
①前提として持続性の条件の内②は成立していると仮定
②ゲイの訪問員が同性婚台本を使用した場合、第７波調査時点でもコン
ロールグループの平均と差があり、その差は処置前の第１波より大き
く、第２波調査に近い水準のため、持続性を確認できる。
③ストレートの訪問員が同性婚台本を使用した場合、第７波時点でコン
トロールグループの平均と殆ど差は無い。また、その差は、処置前の
第１波調査より小さくなっているため持続性を確認できない。
> hoge3 <- tapply(gay$ssm[gay$study==1 & gay$wave == 3],gay$treatment[gay$study==1 & gay$wave == 3],mean,na.rm = TRUE)
> hoge3 <- as.data.frame(hoge3)
> hoge4 <- tapply(gay$ssm[gay$study==1 & gay$wave == 4],gay$treatment[gay$study==1 & gay$wave == 4],mean,na.rm = TRUE)
> hoge4 <- as.data.frame(hoge4)
> hoge5 <- tapply(gay$ssm[gay$study==1 & gay$wave == 5],gay$treatment[gay$study==1 & gay$wave == 5],mean,na.rm = TRUE)
> hoge5 <- as.data.frame(hoge5)
> hoge6 <- tapply(gay$ssm[gay$study==1 & gay$wave == 6],gay$treatment[gay$study==1 & gay$wave == 6],mean,na.rm = TRUE)
> hoge6 <- as.data.frame(hoge6)
> hoge7 <- tapply(gay$ssm[gay$study==1 & gay$wave == 7],gay$treatment[gay$study==1 & gay$wave == 7],mean,na.rm = TRUE)
> hoge7 <- as.data.frame(hoge7)
> hogehoge <- cbind(hoge1,hoge2,hoge3,hoge4,hoge5,hoge6,hoge7)
> colnames(hogehoge) <- c("wave1","wave2","wave3","wave4","wave5","wave6","wave7")
> hogehoge
wave1 wave2 wave3 wave4 wave5
No Contact 3.042764 3.039615 3.046273 3.035946 3.174272
Recycling Script by Gay Canvasser 3.130975 3.107447 3.138542 3.135737 3.252470
Recycling Script by Straight Canvasser 3.013474 3.004278 2.964021 3.023109 3.068736
Same-Sex Marriage Script by Gay Canvasser 3.025195 3.139489 3.127639 3.128571 3.322167
Same-Sex Marriage Script by Straight Canvasser 3.099710 3.161863 3.106681 3.123142 3.272827
wave6 wave7
No Contact 3.091973 3.313747
Recycling Script by Gay Canvasser 3.202213 3.431944
Recycling Script by Straight Canvasser 3.036585 3.165969
Same-Sex Marriage Script by Gay Canvasser 3.178408 3.373116
Same-Sex Marriage Script by Straight Canvasser 3.155488 3.271210
> hogehoge <- t(hogehoge)
> par(mfrow=c(1,3))
> plot(hogehoge[,1],type = "b",pch=16,xlab = "wave",ylab = "SSM mean",ylim = c(3,3.4),main = "No Contact")
> plot(hogehoge[,4],type = "b",pch=16,xlab = "wave",ylab = "SSM mean",ylim = c(3,3.4),main = "Gay Canvasse")
> plot(hogehoge[,5],type = "b",pch=16,xlab = "wave",ylab = "SSM mean",ylim = c(3,3.4),main = "Straight Canvasser")
> hogehoge[,4] - hogehoge[,1]
wave1 wave2 wave3 wave4 wave5 wave6 wave7
-0.01756893 0.09987463 0.08136612 0.09262577 0.14789543 0.08643548 0.05936835
> hogehoge[,5] - hogehoge[,1]
wave1 wave2 wave3 wave4 wave5 wave6 wave7
0.05694517 0.12224797 0.06040800 0.08719659 0.09855523 0.06351524 -0.04253721
> par(mfrow=c(1,2))
> plot(hogehoge[,4] - hogehoge[,1],type = "b",pch=18,xlab = "wave",ylab = "Diff SSM mean",ylim = c(-0.05,0.15),main = "Diff No Contact and Gay")
> plot(hogehoge[,5] - hogehoge[,1],type = "b",pch=18,xlab = "wave",ylab = "Diff SSM mean",ylim = c(-0.05,0.15),main = "Diff No Contact and Straight")
（５）【研究２】ランダム化の適切性の確認
＜平均・中央値＞
①グループ間の同性婚への評価SSMの平均に差がない（差は0.002）
1)No Contact： 2.97
2)Same-Sex Marriage Script by Gay Canvasser：2.972
②各グループのSSMの中央値は、全く同じ「3」になっている
＜ヒストグラム・まとめ＞
①SSMのヒストグラムも各グループで殆ど同じ形状になっている
②概ねランダム化は適切と思われる
> gay.study2 <- gay[gay$study == 2,]
> summary(gay.study2)
study treatment wave ssm
Min. :2 No Contact :5098 Min. :1.000 Min. :1.000
1st Qu.:2 Recycling Script by Gay Canvasser : 0 1st Qu.:2.000 1st Qu.:1.000
Median :2 Recycling Script by Straight Canvasser : 0 Median :3.000 Median :3.000
Mean :2 Same-Sex Marriage Script by Gay Canvasser :5287 Mean :3.122 Mean :3.044
3rd Qu.:2 Same-Sex Marriage Script by Straight Canvasser: 0 3rd Qu.:4.000 3rd Qu.:5.000
Max. :2 Max. :7.000 Max. :5.000
> tapply(gay.study2$ssm[gay.study2$wave==1],gay.study2$treatment[gay.study2$wave==1],summary)
$`No Contact`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.00 1.00 3.00 2.97 5.00 5.00
$`Recycling Script by Gay Canvasser`
NULL
$`Recycling Script by Straight Canvasser`
NULL
$`Same-Sex Marriage Script by Gay Canvasser`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 2.972 5.000 5.000
$`Same-Sex Marriage Script by Straight Canvasser`
NULL
> hist(gay.study2$ssm[gay.study2$treatment == "No Contact"],freq = FALSE ,
+ breaks = seq(from = 0.5,to = 5.5, by =1),xlab = "SSM",main = "2th No contact")
> hist(gay.study2$ssm[gay.study2$treatment == "Same-Sex Marriage Script by Gay Canvasser"],freq = FALSE ,
+ breaks = seq(from = 0.5,to = 5.5, by =1),xlab = "SSM",main = "2th Gay Canvasser")
（６）【研究２】平均トリートメント効果
＜研究２内での比較＞
①コントロールグループの平均値は2.992
②ゲイの訪問員が同性婚台本を使った場合、平均値は3.116
③グループ間の平均値の差は、0.124
＜研究１との比較＞
①研究１の第２波調査における、コントロールグループとゲイの訪問員
が同性婚台本を使った場合、平均の差は約0.114
②研究２の平均値との差は0.01で、近い値になっている
> tapply(gay.study2$ssm[gay.study2$wave == 2],gay.study2$treatment[gay.study2$wave == 2],summary,na.rm = TRUE)
$`No Contact`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 2.992 5.000 5.000
$`Recycling Script by Gay Canvasser`
NULL
$`Recycling Script by Straight Canvasser`
NULL
$`Same-Sex Marriage Script by Gay Canvasser`
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.000 1.000 3.000 3.116 5.000 5.000
$`Same-Sex Marriage Script by Straight Canvasser`
NULL
（７）【研究２】戸別訪問の持続効果
①ゲイの訪問員が同性婚台本を使用した場合、第７波調査時点でもコン
ロールグループの平均と差があり、その差は処置前の第１波より大き
く、第２波調査よりも大きいため、持続性を確認できる。
> wave1 <- tapply(gay.study2$ssm[gay.study2$wave==1],gay.study2$treatment[gay.study2$wave==1],mean,na.rm = TRUE)
> wave1 <- as.data.frame(wave1)
> wave2 <- tapply(gay.study2$ssm[gay.study2$wave==2],gay.study2$treatment[gay.study2$wave==2],mean,na.rm = TRUE)
> wave2 <- as.data.frame(wave2)
> wave3 <- tapply(gay.study2$ssm[gay.study2$wave==3],gay.study2$treatment[gay.study2$wave==3],mean,na.rm = TRUE)
> wave3 <- as.data.frame(wave3)
> wave4 <- tapply(gay.study2$ssm[gay.study2$wave==4],gay.study2$treatment[gay.study2$wave==4],mean,na.rm = TRUE)
> wave4 <- as.data.frame(wave4)
> wave7 <- tapply(gay.study2$ssm[gay.study2$wave==7],gay.study2$treatment[gay.study2$wave==7],mean,na.rm = TRUE)
> wave7 <- as.data.frame(wave7)
> hogehoge2 <- cbind(wave1,wave2,wave3,wave4,0,0,wave7)
> colnames(hogehoge2) <- c("wave1","wave2","wave3","wave4","wave5","wave6","wave7")
> hogehoge2 <- t(hogehoge2)
> par(mfrow=c(1,3))
> plot(hogehoge2[,1],type = "b",pch=16,xlab = "wave",ylab = "SSM mean",ylim = c(2.9,3.4),main = "2th No Contact")
> plot(hogehoge2[,4],type = "b",pch=16,xlab = "wave",ylab = "SSM mean",ylim = c(2.9,3.4),main = "2th Gay Canvasse")
> plot(hogehoge2[,4] - hogehoge2[,1],type = "b",pch=18,xlab = "wave",ylab = "Diff SSM mean",ylim = c(0,0.35),main = "2th Diff No Contact and Gay")
３．練習問題を解いた感想
・コントロールグループとトリートメントグループへの割当てが、適切にランダムに行われていれば、グループ間の記述統計を比較することで、トリートメント効果を簡単に確認できるので非常に便利だと思う。
・繰り返し処理を行うfor文のコーディングに習熟したい。Rはfor文の処理が苦手で、多様すると処理に多くの時間を要することは知っている。ただ、練習問題レベルのデータであれば、大して負荷がかからないと思う。同じようなコードを羅列することがあるので、for文でスマートに対処したい。
この記事が気に入ったらサポートをしてみませんか？