交互作用効果の推定 2024
太郎丸 博
2024-12-11
1 例題
回帰係数の比較の資料を参考に、本調査の Q4 のデータを用い、女性的な趣味を好む男性に対する違和感が、趣味の担い手の年齢によってどのように異なるか分析しなさい。
1.1 例解
この課題は、違和感に対する趣味と年齢の交互作用効果を推定しろ、という課題である。まず、趣味の担い手が男性の場合 (Q4) に関して、趣味、年齢別に違和感の平均値をプロットし、その後、年齢別に違和感の回帰分析をする。
1.1.1 データの読み込みと変数の作成
ここはこれまでの課題と同じ。コピペして実行すればよい。
d0 <- read.csv("C:/Users/taroh/Dropbox/24G_Course/2024社会学実習性規範調査.csv", fileEncoding = "utf8", na.strings = "")
names.d0 <- names(d0) # 後で何かの役に立つかもしれないので名前を付けておく
d0$id <- 1 : nrow(d0)
## Q4 Q5 を分析する. 使わない変数は削除。回答者の性別や年齢、誕生月も要らないが、一応残す
d01 <- d0[, c(2 : 28, # フェイスシートと a票の Q4, Q5
40 : 63, # b票の Q4, Q5
75 : 98, # c票の Q4, Q5
115, 117)] # 大学と id
## ロングに変換
library(reshape2)
d01.long <- melt(
d01,
measure.vars = 4 : 75
)
dim(d01.long) # d0の行数 X 72（Q4のヴィネットの総数）だけ行数があるはず. 列は 7列（回答者に関する質問が 4, id, vignette, discomfort ）## [1] 14832 7d01.long <- d01.long [order(d01.long$id), ]
# head(d01.long)
names.d01.long <- names(d01.long) # これも何かの役に立つかもなので保存
# 書きやすい変数名に変更
names(d01.long) <- c("sex", "age", "birthmonth", "university",
"id", "vignette", "discomfort")
# 数値に変換
d01.long$ discomfort.n [d01.long$discomfort == "とても感じる" |
d01.long$discomfort == "とても違和感を感じる"] <- 3
d01.long$ discomfort.n [d01.long$discomfort == "少し感じる" |
d01.long$discomfort == "少し違和感を感じる"] <- 2
d01.long$ discomfort.n [d01.long$discomfort == "あまり感じない" |
d01.long$discomfort == "あまり違和感を感じない" ] <- 1
d01.long$ discomfort.n [d01.long$discomfort == "違和感を感じない"] <- 0# vignette の値の文字列が長すぎるので、同じ文言の繰り返しは削除
# sub("正規表現", "置換する文字列", "")
d01.long$vignette <- sub("\\.次のような男性について\\.あなたはどの程度違和感を感じますか\\.\\.", "違和感", d01.long$vignette)
d01.long$vignette <- sub("\\.次のような女性について\\.あなたはどの程度違和感を感じますか\\.\\.", "違和感", d01.long$vignette)
# 性別
otoko <- grepl("歳の男性", d01.long$ vignette)
d01.long$ sex.v <- factor(otoko, labels = c("女", "男"))
xtabs(~otoko + sex.v, d01.long)## sex.v
## otoko 女 男
## FALSE 7416 0
## TRUE 0 7416# 年齢（今回の課題では必要ないので省略可）
age10 <- grepl("10歳の", d01.long$ vignette)
age25 <- grepl("25歳の", d01.long$ vignette)
age45 <- grepl("45歳の", d01.long$ vignette)
age70 <- grepl("70歳の", d01.long$ vignette)
d01.long$ age.v [age10] <- 10
d01.long$ age.v [age25] <- 25
d01.long$ age.v [age45] <- 45
d01.long$ age.v [age70] <- 70
# それぞれの趣味に関するヴィネットかを示すダミー変数（今回の課題のためには、漫画、ロック、服の分だけ作ればよい）
anime <- grepl("アニメ", d01.long$ vignette) # 女児向けも男児向けも同じカテゴリに分類される点に注意
cafe <- grepl("カフェ巡り", d01.long$ vignette)
yoga <- grepl("ヨガ", d01.long$ vignette)
ballet <- grepl("バレエ", d01.long$ vignette)
manga <- grepl("漫画", d01.long$ vignette) # 同上
cloth <- grepl("服", d01.long$ vignette) # 同上
idol <- grepl("アイドル", d01.long$ vignette) # 同上
sweets <- grepl("お菓子", d01.long$ vignette)
baseball <- grepl("野球", d01.long$ vignette)
rugby <- grepl("ラグビー", d01.long$ vignette)
bike <- grepl("バイク", d01.long$ vignette)
mah.jongg <- grepl("麻雀", d01.long$ vignette)
rock <- grepl("ロックバンド", d01.long$ vignette) # 同上
# 趣味を示す因子の作成：これも今回の課題には必要ないので省略可
d01.long $taste [anime] <- "アニメ"
d01.long $taste [cafe] <- "カフェ巡り"
d01.long $taste [yoga] <- "ヨガ"
d01.long $taste [ballet] <- "バレエ"
d01.long $taste [manga] <- "漫画"
d01.long $taste [cloth] <- "服"
d01.long $taste [idol] <- "アイドル"
d01.long $taste [sweets] <- "お菓子作り"
d01.long $taste [baseball] <- "野球"
d01.long $taste [rugby] <- "ラグビー"
d01.long $taste [bike] <- "バイク"
d01.long $taste [mah.jongg] <- "麻雀"
d01.long $taste [rock] <- "ロックバンド"
d01.long$ taste <- factor(d01.long$ taste)age.temp <- substring(d01.long$age, 1, 2) # 1～2文字目だけとってくる
d01.long$age.n <- as.numeric(age.temp) # 数値に変換
d01.long$sex <- factor(d01.long$sex, levels = c("女性", "男性", "その他"))
d01.long$kyodai <- d01.long$university == "京都大学" # 京都大学の時 TRUE をとるダミー変数1.1.2 平均値のプロット
交互作用効果の推定や解釈は、煩雑なので平均値をグラフにしておくとわかりやすい。まず、グループ別に平均値を計算し、それらを matplot() でグラフにする。
# 趣味、担い手の年齢、担い手の男女別に違和感の平均値を計算
mean.discomfort <- tapply(
d01.long$ discomfort.n,
list(d01.long$ taste, d01.long$ age.v, d01.long$sex.v),
mean, na.rm= TRUE
)
mean.discomfort # 一方の性別だけに関して尋ねている趣味は NA になる## , , 女
##
## 10 25 45 70
## アイドル 0.04347826 0.11842105 0.3728814 0.8644068
## アニメ 0.32857143 0.73684211 1.1355932 1.6440678
## お菓子作り NA NA NA NA
## カフェ巡り NA NA NA NA
## バイク 0.74285714 0.28571429 0.3389831 0.6779661
## バレエ NA NA NA NA
## ヨガ NA NA NA NA
## ラグビー 0.81159420 1.03896104 1.1694915 1.6521739
## ロックバンド 0.24675325 0.04285714 0.2857143 0.5762712
## 服 0.59322034 0.47142857 1.1298701 1.2000000
## 麻雀 1.29870130 0.30000000 0.2711864 0.2857143
## 漫画 0.16949153 0.14285714 0.5000000 1.0909091
## 野球 0.20338983 0.55844156 0.9870130 1.1857143
##
## , , 男
##
## 10 25 45 70
## アイドル 0.5844156 0.66233766 1.0169492 1.3714286
## アニメ 0.8714286 1.66233766 1.8474576 2.2857143
## お菓子作り 0.3965517 0.32857143 0.6103896 0.4576271
## カフェ巡り 0.8813559 0.20779221 0.5571429 0.5194805
## バイク NA NA NA NA
## バレエ 0.5064935 0.57627119 1.0338983 1.5285714
## ヨガ 1.1857143 0.58441558 0.5762712 0.4571429
## ラグビー NA NA NA NA
## ロックバンド 0.1857143 0.06493506 0.1016949 0.2898551
## 服 1.5285714 1.84415584 2.1864407 2.3898305
## 麻雀 NA NA NA NA
## 漫画 0.7532468 1.15714286 1.7428571 1.8135593
## 野球 NA NA NA NAmean.male <- na.omit(mean.discomfort [, , 2]) # NA の趣味は削除し、男性が担い手の場合だけに限定
mean.male## 10 25 45 70
## アイドル 0.5844156 0.66233766 1.0169492 1.3714286
## アニメ 0.8714286 1.66233766 1.8474576 2.2857143
## お菓子作り 0.3965517 0.32857143 0.6103896 0.4576271
## カフェ巡り 0.8813559 0.20779221 0.5571429 0.5194805
## バレエ 0.5064935 0.57627119 1.0338983 1.5285714
## ヨガ 1.1857143 0.58441558 0.5762712 0.4571429
## ロックバンド 0.1857143 0.06493506 0.1016949 0.2898551
## 服 1.5285714 1.84415584 2.1864407 2.3898305
## 漫画 0.7532468 1.15714286 1.7428571 1.8135593
## attr(,"na.action")
## バイク ラグビー 麻雀 野球
## 5 8 11 13
## attr(,"class")
## [1] "omit"mean.male <- mean.male [order(rowMeans(mean.male)), ] # 全年齢の平均的な違和感で並べ替え
round(mean.male, 2)## 10 25 45 70
## ロックバンド 0.19 0.06 0.10 0.29
## お菓子作り 0.40 0.33 0.61 0.46
## カフェ巡り 0.88 0.21 0.56 0.52
## ヨガ 1.19 0.58 0.58 0.46
## アイドル 0.58 0.66 1.02 1.37
## バレエ 0.51 0.58 1.03 1.53
## 漫画 0.75 1.16 1.74 1.81
## アニメ 0.87 1.66 1.85 2.29
## 服 1.53 1.84 2.19 2.39# とりあえずざっくり作る
matplot(mean.male, type = "l") 
# 上のグラフではわかりにくすぎるので、わかりやすく修正
matplot(mean.male, type = "l", xaxt = "n") # xaxt = "n" で x 軸の描画を抑制
axis(1, at = 1 : nrow(mean.male), labels = rownames(mean.male)) # x 軸のラベルを mean.male の行の名前にしろ、という指示
legend("topleft", col= 1 : 4, lty = 1 : 4, legend = c("10歳", "25歳", "45歳", "70歳"))
男性ロックバンドやお菓子作りのように、平均的な違和感が全般に低い趣味の場合は、担い手の年齢による違和感の違いは非常に小さいが、少女漫画、女児向けアニメ、女性用の服が好きな男性に対しては、高齢であるほど違和感が大きいことがわかる。ヨガが例外的（10歳の男の子がヨガをするのは珍しいということだろう）。
1.1.3 グループ別に回帰分析
d01.long$taste <- relevel(d01.long$taste, ref = "ロックバンド")
d01.male <- subset(d01.long, sex.v == "男")
lm1 <- list()
lm1 [[1]] <- lm(discomfort.n ~ sex + I(age.n - 21) + kyodai + taste, data = d01.male, subset = age.v == 10)
lm1 [[2]] <- update(lm1 [[1]], , subset = age.v == 25)
lm1 [[3]] <- update(lm1 [[1]], , subset = age.v == 45)
lm1 [[4]] <- update(lm1 [[1]], , subset = age.v == 70)
library(texreg)
knitreg(lm1,
custom.model.names = c("10歳", "25歳", "45歳", "70歳"))| 10歳 | 25歳 | 45歳 | 70歳 | |
|---|---|---|---|---|
| (Intercept) | -0.02 | -0.12 | -0.10 | 0.11 |
| (0.12) | (0.11) | (0.13) | (0.13) | |
| sex男性 | 0.11 | 0.12 | 0.12 | 0.05 |
| (0.07) | (0.06) | (0.08) | (0.08) | |
| sexその他 | -0.29 | -0.36 | -0.32 | -0.58* |
| (0.27) | (0.37) | (0.20) | (0.25) | |
| age.n - 21 | -0.01 | 0.02 | -0.00 | 0.01 |
| (0.02) | (0.02) | (0.02) | (0.02) | |
| kyodaiTRUE | 0.19* | 0.15* | 0.24** | 0.22* |
| (0.08) | (0.07) | (0.08) | (0.09) | |
| tasteアイドル | 0.40** | 0.61*** | 0.86*** | 1.06*** |
| (0.14) | (0.13) | (0.16) | (0.16) | |
| tasteアニメ | 0.69*** | 1.59*** | 1.77*** | 1.99*** |
| (0.15) | (0.13) | (0.16) | (0.15) | |
| tasteお菓子作り | 0.19 | 0.27* | 0.46** | 0.21 |
| (0.15) | (0.14) | (0.15) | (0.16) | |
| tasteカフェ巡り | 0.63*** | 0.14 | 0.36* | 0.20 |
| (0.15) | (0.13) | (0.16) | (0.15) | |
| tasteバレエ | 0.32* | 0.50*** | 0.87*** | 1.16*** |
| (0.14) | (0.14) | (0.16) | (0.16) | |
| tasteヨガ | 0.97*** | 0.53*** | 0.43** | 0.13 |
| (0.15) | (0.13) | (0.16) | (0.16) | |
| taste服 | 1.31*** | 1.78*** | 2.07*** | 2.14*** |
| (0.15) | (0.13) | (0.16) | (0.16) | |
| taste漫画 | 0.57*** | 1.08*** | 1.61*** | 1.53*** |
| (0.14) | (0.14) | (0.16) | (0.16) | |
| R2 | 0.19 | 0.38 | 0.40 | 0.45 |
| Adj. R2 | 0.17 | 0.37 | 0.39 | 0.44 |
| Num. obs. | 599 | 642 | 542 | 579 |
| ***p < 0.001; **p < 0.01; *p < 0.05 | ||||
1.1.4 担い手が25歳と70歳の場合の回帰係数の比較
source("http://tarohmaru.web.fc2.com/R/FactorialSurveyExperiments/testRegCoefDifferences.R")
library(knitr)
kable(
welch.test(lm1 [[2]], lm1 [[4]]),
digits = 2)| differences of coefficients | z.values | p.values | sig | |
|---|---|---|---|---|
| (Intercept) | -0.23 | -1.33 | 0.18 | |
| sex男性 | 0.07 | 0.72 | 0.47 | |
| sexその他 | 0.22 | 0.50 | 0.62 | |
| I(age.n - 21) | 0.02 | 0.59 | 0.56 | |
| kyodaiTRUE | -0.07 | -0.61 | 0.54 | |
| tasteアイドル | -0.45 | -2.22 | 0.03 | * |
| tasteアニメ | -0.40 | -2.00 | 0.05 | * |
| tasteお菓子作り | 0.05 | 0.26 | 0.80 | |
| tasteカフェ巡り | -0.06 | -0.28 | 0.78 | |
| tasteバレエ | -0.66 | -3.12 | 0.00 | ** |
| tasteヨガ | 0.39 | 1.93 | 0.05 | |
| taste服 | -0.37 | -1.76 | 0.08 | |
| taste漫画 | -0.45 | -2.13 | 0.03 | * |
welch.test() は、最初に指定したモデルの回帰係数から、次に指定したモデルの回帰係数の値を引き、それらがゼロだという帰無仮説を検定するので、 男性アイドル、女児向けアニメ、バレエ、少女漫画が好きな男性については、25歳の場合よりも70歳のほうがさらに違和感が大きい、といえる。
厳密には、すべての年齢の組み合わせで、回帰係数の差を検定すべき、ということになろうが、煩雑なので、ここでは 25歳と70歳を比較した結果だけを示す。
2 練習問題
本調査の Q5 のデータを用い、男性的な趣味を好む女性に対する違和感が、趣味の担い手の年齢によってどのように異なるか分析しなさい。
2.1 解答例
結果のみ表示。
## 10 25 45 70
## アイドル 0.04347826 0.11842105 0.3728814 0.8644068
## アニメ 0.32857143 0.73684211 1.1355932 1.6440678
## バイク 0.74285714 0.28571429 0.3389831 0.6779661
## ラグビー 0.81159420 1.03896104 1.1694915 1.6521739
## ロックバンド 0.24675325 0.04285714 0.2857143 0.5762712
## 服 0.59322034 0.47142857 1.1298701 1.2000000
## 麻雀 1.29870130 0.30000000 0.2711864 0.2857143
## 漫画 0.16949153 0.14285714 0.5000000 1.0909091
## 野球 0.20338983 0.55844156 0.9870130 1.1857143
## attr(,"na.action")
## お菓子作り カフェ巡り バレエ ヨガ
## 3 4 6 7
## attr(,"class")
## [1] "omit"## 10 25 45 70
## ロックバンド 0.25 0.04 0.29 0.58
## アイドル 0.04 0.12 0.37 0.86
## 漫画 0.17 0.14 0.50 1.09
## バイク 0.74 0.29 0.34 0.68
## 麻雀 1.30 0.30 0.27 0.29
## 野球 0.20 0.56 0.99 1.19
## 服 0.59 0.47 1.13 1.20
## アニメ 0.33 0.74 1.14 1.64
## ラグビー 0.81 1.04 1.17 1.65
| 10歳 | 25歳 | 45歳 | 70歳 | |
|---|---|---|---|---|
| (Intercept) | -0.03 | -0.07 | 0.10 | 0.47** |
| (0.10) | (0.10) | (0.11) | (0.15) | |
| sex男性 | 0.14* | 0.07 | 0.24** | 0.21* |
| (0.06) | (0.06) | (0.07) | (0.09) | |
| sexその他 | 0.00 | -0.26 | -0.11 | -0.14 |
| (0.21) | (0.41) | (0.22) | (0.26) | |
| age.n - 21 | -0.03 | -0.01 | -0.02 | -0.02 |
| (0.02) | (0.01) | (0.02) | (0.02) | |
| kyodaiTRUE | 0.26*** | 0.10 | 0.06 | 0.03 |
| (0.07) | (0.06) | (0.08) | (0.10) | |
| tasteアイドル | -0.20 | 0.07 | 0.15 | 0.30 |
| (0.13) | (0.12) | (0.15) | (0.19) | |
| tasteアニメ | 0.07 | 0.67*** | 0.85*** | 1.05*** |
| (0.13) | (0.12) | (0.15) | (0.19) | |
| tasteバイク | 0.41** | 0.23 | 0.06 | 0.05 |
| (0.13) | (0.12) | (0.15) | (0.19) | |
| tasteラグビー | 0.53*** | 0.98*** | 0.90*** | 1.04*** |
| (0.13) | (0.12) | (0.15) | (0.18) | |
| taste服 | 0.33* | 0.43*** | 0.84*** | 0.63*** |
| (0.13) | (0.12) | (0.14) | (0.18) | |
| taste麻雀 | 1.07*** | 0.25* | 0.02 | -0.31 |
| (0.12) | (0.12) | (0.15) | (0.18) | |
| taste漫画 | -0.07 | 0.07 | 0.23 | 0.46** |
| (0.13) | (0.12) | (0.14) | (0.18) | |
| taste野球 | -0.03 | 0.51*** | 0.71*** | 0.58** |
| (0.13) | (0.12) | (0.14) | (0.18) | |
| R2 | 0.25 | 0.17 | 0.19 | 0.17 |
| Adj. R2 | 0.23 | 0.16 | 0.17 | 0.15 |
| Num. obs. | 578 | 649 | 573 | 559 |
| ***p < 0.001; **p < 0.01; *p < 0.05 | ||||
25歳と70歳の係数の差をとり、ゼロかどうか検定した結果。
| differences of coefficients | z.values | p.values | sig | |
|---|---|---|---|---|
| (Intercept) | -0.53 | -2.90 | 0.00 | ** |
| sex男性 | -0.13 | -1.28 | 0.20 | |
| sexその他 | -0.12 | -0.26 | 0.80 | |
| I(age.n - 21) | 0.01 | 0.38 | 0.71 | |
| kyodaiTRUE | 0.08 | 0.64 | 0.52 | |
| tasteアイドル | -0.23 | -1.04 | 0.30 | |
| tasteアニメ | -0.38 | -1.71 | 0.09 | |
| tasteバイク | 0.18 | 0.80 | 0.42 | |
| tasteラグビー | -0.06 | -0.28 | 0.78 | |
| taste服 | -0.20 | -0.91 | 0.36 | |
| taste麻雀 | 0.56 | 2.53 | 0.01 | * |
| taste漫画 | -0.39 | -1.85 | 0.06 | |
| taste野球 | -0.08 | -0.35 | 0.73 |