要因配置サーベイ実験でのロングデータの作り方：水準をランダムに生成する場合
太郎丸 博
2024-11-29
要因配置サーベイ実験では、要因や水準の数が増えると、理論上考えられる組み合わせの数も増えていき、実験計画や質問紙の構造も複雑になる場合がある。このような問題に対処する方法の一つに、水準をランダムに生成するという方法がある。このような場合のデータの構造について概説し、R で読み込んでロングフォーマットに変換するやり方を述べる。
1 質問の構造
1.1 deck へのランダム割り当て
2要因3水準の場合、組み合わせは \(3^2=9\) なので、すべての組み合わせについて一人の人に尋ねることが可能であるが、4要因 4水準なら \(4^4=256\) 通りになり、一人の人にすべての組み合わせについて尋ねることは不可能である。直行計画ならば \(16\) の組み合わせで済むが、交互作用効果について知りたい場合はもっとたくさん質問する必要がある。そこで、あらかじめ尋ねたいヴィネットをいくつかのグループに分け（これらのグループを deck と呼んでおく）、回答者をランダムにどれかの deck に割り当てる、という方法がある。たいていの場合これでよいと思うが、尋ねたいヴィネットや deck の数が増えるとやはりかなり煩雑である。
1.2 水準のランダム生成
そこで、いっそのことオンライン調査で水準そのものをランダムに生成してしまう、という方法がある。私たちが行ったパイロット調査を単純化したものを例に説明しよう。以下が質問
以下の写真のように（写真は割愛）フリルやレースを多用した西洋のお姫様風の服装は、ロリータファッションと呼ばれますが、ロリータファッションやミニスカートの女性が以下のような行動をしたら、あなたはどの程度不適切だと思いますか。
- XX 歳の女性が YYY で街を歩く
- XX 歳の女性が YYY でロックコンサートに参加する
- XX 歳の女性が YYY でスタジアムでサッカーを観戦する
- XX 歳の女性教師が YYY で小学生に授業をする
- XX 歳の女性市会議員が YYY で市議会に参加する
- XX 歳の女性事務員が YYY でオフィスで働く
- XX 歳の女性営業社員が YYY で取引先と商談する
選択肢は、「不適切だと思う」、「どちらかというと不適切だと思う」、「どちらとも言えない」、「どちらかというと不適切ではないと思う」、「不適切ではないと思う」の5択
XX には 18～50 の整数のうちどれかが等確率で代入されるとする。実際の調査では市議会議員は25～50、事務員は 22～50歳のように項目によって年齢の下限が異なるが、話が複雑になるので 18～50歳に統一した例で考える。YYY には「ロリータファッション」と「ミニスカート」のいずれかがそれぞれ 1/2 の確率で代入される。ただし YYY には 「ロリータファッション」と「ミニスカート」のいずれも 1 回以上は代入される。つまり、「ミニスカート」についてばかり尋ねられて、「ロリータファッション」については尋ねられないような人が出ないようにしてある。
この要因配置サーベイ実験の要因は、年齢、ファッション、TPO (Time, Place, and Occasion) の 3 つで、年齢の水準数は 33、ファッションの水準が 2 つ、TPO が 7 つである。これらの組み合わせは、\(33\times 2 \times 7 = 462\) 通りで、一人当たり 7 つの組み合わせ（ヴィネット）を評価するので、まったく同じヴィネットに割り当てられる回答者は平均で \(1000/(33\times 2) =15.2\) 人ということになる。
1番目と2番目のヴィネット（質問項目）に関してデータの構造を示したのが、表1 である。以下のスクリプトは表1 を作るもの。
# データの読み込み
d0 <- read.csv("C:/Users/taroh/Dropbox/AestheticLabor/WebSurvey2024/data20240321.csv")
# 性別
d0$ sex <- factor(d0$q1, labels = c("男", "女")) # "その他" を選んだ人がいなかった
# 年齢
d0$ age <- d0$q2t
# 1番目の質問項目に代入する年齢とファッションをあらわす変数を作る
d0$ q30x1age <- d0$ bg30a1 + 15 # 1 = 16歳、2 = 17歳 ... 35 = 50 歳のようなコードが入力されている
d0$ q30x1fashon <- factor(d0$ bg30a2, labels = c("ロリータ", "ミニスカ"))
# 2番目の質問項目に代入する年齢とファッション
d0$ q30x2age <- d0$ bg30b1 + 15
d0$ q30x2fashon <- factor(d0$ bg30b2, labels = c("ロリータ", "ミニスカ"))
# 解説用のデータを作成。興味ない人は無視してよい
sample.data <- subset(d0, select = c(No, sex, age, q30x1age, q30x1fashon, q30_1, q30x2age, q30x2fashon, q30_2))
sample.data$ q30_1 <- factor(sample.data$ q30_1,
labels = c("不適切", "どちらか不適切", "どちらとも", "どちらか適切", "適切"))
sample.data$ q30_2 <- factor(sample.data$ q30_2,
labels = c("不適切", "どちらか不適切", "どちらとも", "どちらか適切", "適切"))
library(knitr)
kable(
head(sample.data),
caption = "表1 項目1, 2に代入された年齢とファッション、それに対する回答",
col.names = c(
"回答者ID", "回答者性別", "回答者年齢", "項目1年齢", "項目1ファッション",
"項目2回答", "項目2年齢", "項目2ファッション", "項目2回答")
)| 回答者ID | 回答者性別 | 回答者年齢 | 項目1年齢 | 項目1ファッション | 項目2回答 | 項目2年齢 | 項目2ファッション | 項目2回答 |
|---|---|---|---|---|---|---|---|---|
| 5 | 男 | 24 | 50 | ロリータ | どちらとも | 18 | ミニスカ | どちらとも |
| 7 | 男 | 35 | 35 | ミニスカ | 適切 | 47 | ロリータ | 適切 |
| 8 | 女 | 39 | 47 | ロリータ | どちらとも | 22 | ミニスカ | どちらとも |
| 9 | 男 | 23 | 46 | ミニスカ | 不適切 | 20 | ロリータ | 不適切 |
| 10 | 女 | 33 | 27 | ロリータ | 適切 | 47 | ミニスカ | どちらとも |
| 11 | 男 | 24 | 24 | ミニスカ | 適切 | 48 | ロリータ | 適切 |
1行目を見ると ID = 5 の回答者には、以下のようなヴィネットが提示されたことがわかる。
- 50 歳の女性が ロリータファッション で街を歩く
- 18 歳の女性が ミニスカート でロックコンサートに参加する
同様にして、2行目の ID = 7 の回答者には、以下のようなヴィネットが提示された。
- 50 歳の女性が ロリータファッション で街を歩く
- 18 歳の女性が ミニスカート でロックコンサートに参加する
このように、代入された年齢とファッションがコード（数値）として bg30a1, bg30a2, bg30b1, bg30b2 といった変数に記録されており、それらから、誰にどんなヴィネットが提示されたか再現できるというわけである。
2 ロングフォーマットへの変換
データの構造がわかれば、reshape() を使ってロングフォーマットに変換するだけである。ただ、データの構造が本論とは若干異なるので、注意が必要である。
sample.data.long <- reshape(
sample.data,
direction = "long",
varying = list(c("q30x1age", "q30x2age"), # 代入された年齢
c("q30x1fashon", "q30x2fashon"), # 代入されたファッション
c("q30_1", "q30_2")), # 回答
timevar = "TPO", # 項目を示す変数名の指定. デフォルトは "time"
v.names = c("q30age", "q30fashion", "q30answer") # 代入された年齢、ファッション、回答の変数名. 省略可
)
sample.data.long <- sample.data.long [order(sample.data.long$No), ] # No の順に並べ替え
head(sample.data.long, 10)## No sex age TPO q30age q30fashion q30answer id
## 1.1 5 男 24 1 50 ロリータ どちらとも 1
## 1.2 5 男 24 2 18 ミニスカ どちらとも 1
## 2.1 7 男 35 1 35 ミニスカ 適切 2
## 2.2 7 男 35 2 47 ロリータ 適切 2
## 3.1 8 女 39 1 47 ロリータ どちらとも 3
## 3.2 8 女 39 2 22 ミニスカ どちらとも 3
## 4.1 9 男 23 1 46 ミニスカ 不適切 4
## 4.2 9 男 23 2 20 ロリータ 不適切 4
## 5.1 10 女 33 1 27 ロリータ 適切 5
## 5.2 10 女 33 2 47 ミニスカ どちらとも 53 分析例
# 学歴
d0$edu <- d0$q5
d0$edu [d0$q5 == 4 | d0$q5 == 5] <- 3 # 短大、高専、専門学校をひとまとめに
d0$edu <- factor(d0$edu, labels = c("中", "高", "短大", "大", "院"))
table(d0$edu)##
## 中 高 短大 大 院
## 49 386 203 331 31# 項目3～7の年齢
d0$ q30x3age <- d0$ bg30c1 + 15
d0$ q30x4age <- d0$ bg30d1 + 21
d0$ q30x5age <- d0$ bg30e1 + 24
d0$ q30x6age <- d0$ bg30f1 + 21
d0$ q30x7age <- d0$ bg30g1 + 21
summary(
d0 [,
grep("x.age", names(d0)) # d0の変数名のうち "x.age" （正規表現では "." は任意の一字）を含むものが何列目にあるか示すベクトルを返す
]
)## q30x1age q30x2age q30x3age q30x4age q30x5age q30x6age q30x7age
## Min. :16.00 Min. :16.00 Min. :16.00 Min. :22.00 Min. :25.00 Min. :22.00 Min. :22
## 1st Qu.:24.00 1st Qu.:23.75 1st Qu.:24.00 1st Qu.:29.00 1st Qu.:31.00 1st Qu.:29.00 1st Qu.:29
## Median :33.00 Median :33.00 Median :32.00 Median :36.00 Median :37.00 Median :36.00 Median :36
## Mean :32.84 Mean :32.75 Mean :32.76 Mean :35.84 Mean :37.17 Mean :35.94 Mean :36
## 3rd Qu.:42.00 3rd Qu.:42.00 3rd Qu.:42.00 3rd Qu.:43.00 3rd Qu.:43.25 3rd Qu.:43.00 3rd Qu.:43
## Max. :50.00 Max. :50.00 Max. :50.00 Max. :50.00 Max. :50.00 Max. :50.00 Max. :50d01 <- subset(
d0,
select = c(
No, sex, age, edu,
q30x1age, q30x2age, q30x3age, q30x4age, q30x5age, q30x6age, q30x7age,
bg30a2, bg30b2, bg30c2, bg30d2, bg30e2, bg30f2, bg30g2,
q30_1, q30_2, q30_3, q30_4, q30_5, q30_6, q30_7)
)
dim(d01)## [1] 1000 25names(d01)## [1] "No" "sex" "age" "edu" "q30x1age" "q30x2age" "q30x3age" "q30x4age" "q30x5age"
## [10] "q30x6age" "q30x7age" "bg30a2" "bg30b2" "bg30c2" "bg30d2" "bg30e2" "bg30f2" "bg30g2"
## [19] "q30_1" "q30_2" "q30_3" "q30_4" "q30_5" "q30_6" "q30_7"d01L <- reshape(
d01,
direction = "long",
varying = list(5: 11, 12: 18, 19:25), # 変数は、何列目かを示す数値で指定してもよい
timevar = "tpo",
v.names = c("q30age", "q30fashion", "q30answer")
)
dim(d01L)## [1] 7000 9d01L <- d01L [order(d01L$ No), ]
head(d01L, 10)## No sex age edu tpo q30age q30fashion q30answer id
## 1.1 5 男 24 高 1 50 1 3 1
## 1.2 5 男 24 高 2 18 2 3 1
## 1.3 5 男 24 高 3 23 2 3 1
## 1.4 5 男 24 高 4 40 1 3 1
## 1.5 5 男 24 高 5 25 2 3 1
## 1.6 5 男 24 高 6 37 1 3 1
## 1.7 5 男 24 高 7 36 1 3 1
## 2.1 7 男 35 短大 1 35 2 5 2
## 2.2 7 男 35 短大 2 47 1 5 2
## 2.3 7 男 35 短大 3 21 2 5 2d01L$ q30fashion <- factor(d01L$ q30fashion, labels = c("ロリータ", "ミニスカ"))
d01L$ improper <- 5 - d01L$q30answer # 数値が大きくなるほど不適切
d01L$tpo <- factor(d01L$tpo, labels = c("街歩", "ロック", "サッカー", "授業", "議会", "オフィス", "商談"))
d01L$ agec <- cut(
d01L$ age,
19.5 + 5 * (0:8),
labels = c("20-24", "25-29", "30-34", "35-39",
"40-44", "45-49", "50-54", "55-59"))
library(gplots)
par(mfrow = c(6, 1), mar= c(2.5, 2.5, 2.5, 0), cex.main = 1.5, cex.axis = 1.5)
plotmeans(improper ~ tpo, data = d01L, main = "TPO 別")
plotmeans(improper ~ q30fashion, data = d01L, main = "ファッション別")
plotmeans(improper ~ q30age, data = d01L, main = "ヴィネットで示された年齢別", n.label = FALSE)
plotmeans(improper ~ sex, data = d01L, main = "回答者が男か女か別")
plotmeans(improper ~ agec, data = d01L, main = "回答者の年齢別")
plotmeans(improper ~ edu, data = d01L, main = "回答者の学歴別")
図1 TPO別・不適切判断の平均値
library(lme4)
lm1 <- lmer(
improper ~ tpo + q30fashion + I(q30age -34) + I((q30age -34) ^2) +
sex + scale(age, scale = FALSE) + I(scale(age, scale = FALSE) ^2) +
relevel(edu, ref = "高") + (1 | No),
data = d01L)library(texreg)
knitreg(lm1, caption = "表2 不適切さ判断の回帰分析（マルチレベル・モデル）", caption.above = TRUE)| Model 1 | |
|---|---|
| (Intercept) | 1.05*** |
| (0.08) | |
| tpoロック | -0.15*** |
| (0.04) | |
| tpoサッカー | 0.12** |
| (0.04) | |
| tpo授業 | 1.33*** |
| (0.04) | |
| tpo議会 | 1.25*** |
| (0.04) | |
| tpoオフィス | 0.99*** |
| (0.04) | |
| tpo商談 | 1.33*** |
| (0.04) | |
| q30fashionミニスカ | -0.16*** |
| (0.02) | |
| q30age - 34 | 0.02*** |
| (0.00) | |
| (q30age - 34)^2 | -0.00 |
| (0.00) | |
| sex女 | 0.29*** |
| (0.06) | |
| scale(age, scale = FALSE) | 0.01** |
| (0.00) | |
| scale(age, scale = FALSE)^2 | 0.00 |
| (0.00) | |
| relevel(edu, ref = “高”)中 | -0.02 |
| (0.14) | |
| relevel(edu, ref = “高”)短大 | -0.00 |
| (0.08) | |
| relevel(edu, ref = “高”)大 | 0.09 |
| (0.07) | |
| relevel(edu, ref = “高”)院 | 0.14 |
| (0.18) | |
| AIC | 20873.30 |
| BIC | 21003.52 |
| Log Likelihood | -10417.65 |
| Num. obs. | 7000 |
| Num. groups: No | 1000 |
| Var: No (Intercept) | 0.78 |
| Var: Residual | 0.85 |
| ***p < 0.001; **p < 0.01; *p < 0.05 | |