# 教學習作：如何運用模擬研究解析小樣本研究的證據力

## 實驗參數

Panayotov (2019) 的原始論文是以cc授權的開放取用論文，不確定有事前預先註冊，未提供原始資料。論文作者測試BMI值屬於肥胖區間的14位成年人，分派到實驗組與控制組各7人。兩組參與者進行八週體重控制課程，飲食菜單與運動課表相同，實驗組的處置是被告知菜單是低卡飲食，控制組則告知確實資訊。論文作者假設實驗組經過八週課程，能減重約6公斤(“Theoretically this should cause a weight loss of about 6 kg in 8 weeks.”)。

Panayotov的測量指標有體重(kg)、體脂肪比例(%)、BMI(kg/m^2)，在課程開始(baseline)與課程結束(final)兩個時間測量。減重效用的檢驗方式是以t檢定，確認兩組參與者在兩個時間的各項指標差異，顯著水準是0.05，論文未註明檢定方式是單尾(one tail)或雙尾(two tail)。統計資訊如下表。

## 模擬資料測試

weight_dat <- sim_design(
n = 7,                       ## 受試者人數
within =  list(cond = c("baseline", "final")),  ## 獨變項設定
mu = data.frame(baseline=112.98, final=103.73), ## 基準及結束平均值
sd = data.frame(baseline=19.93, final=17.89),   ## 基準及結束標準差
r=0.5,
dv="weight",
empirical=TRUE,
long = TRUE
)

get_params(weight_dat) %>% knitr::kable()

n var baseline final mean sd
7 baseline 1.0 0.5 112.98 19.93
7 final 0.5 1.0 103.73 17.89

# paired-samples t-test
t.test(weight ~ cond, weight_dat, paired = TRUE)

##
##  Paired t-test
##
## data:  weight by cond
## t = 1.2886, df = 6, p-value = 0.245
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
##  -8.314993 26.814993
## sample estimates:
## mean of the differences
##                    9.25


analyse <- function(data) {
t.test(weight ~ cond, data, paired = TRUE) %>%
broom::tidy()
}


weight_dat <- sim_design(
n = 7,
within =  list(cond = c("baseline", "final")),
mu = data.frame(baseline=112.98, final=103.73),
sd = data.frame(baseline=19.93, final=17.89),
r=0.5,
dv="weight",
#  empirical=TRUE,
long = TRUE,
rep=1000
)


weight_sim <- weight_dat %>%
mutate(analysis = map(data, analyse)) %>%
select(-data) %>%
unnest(analysis)


rep estimate statistic p.value parameter conf.low conf.high method alternative
1 10.685707 2.5782957 0.0418653 6 0.5445184 20.826896 Paired t-test two.sided
2 3.560315 1.7130931 0.1375304 6 -1.5250927 8.645723 Paired t-test two.sided
3 1.312591 0.2122573 0.8389334 6 -13.8190195 16.444202 Paired t-test two.sided
4 2.109562 0.3506974 0.7378000 6 -12.6094312 16.828555 Paired t-test two.sided
5 14.168492 1.9477947 0.0993623 6 -3.6306383 31.967622 Paired t-test two.sided
6 12.328009 2.2493344 0.0655011 6 -1.0828702 25.738888 Paired t-test two.sided

weight_power <- weight_sim %>%
mutate(sig = p.value < .05) %>%
summarise(power = mean(sig)) %>%
pull(power)


## 減重效用考驗力估計

### 體重

r_cand <- seq(.1,.9,.1)

weight_dat_list <- map(r_cand,
function(x) sim_design(
n = 7,                       ## 受試者人數
within =  list(cond = c("baseline", "final")),  ## 獨變項設定
mu = data.frame(baseline=112.98, final=103.73), ## 基準及結束平均值
sd = data.frame(baseline=19.93, final=17.89),   ## 基準及結束標準差
r = x,                                 ## 基準及結束相關係數
dv="weight",
long = TRUE,
rep=1000
)) %>%
set_names(nm=r_cand)


weight_sim_power <- NULL
for(i in 1:length(weight_dat_list)){
weight_sim_power <- c(weight_sim_power,weight_dat_list[[i]] %>%
mutate(analysis = map(data, analyse)) %>%
select(-data) %>%
unnest(analysis) %>%
mutate(sig = p.value < .05) %>%
summarise(power = mean(sig)) %>%
pull(power))
}

names(weight_sim_power) <- r_cand
knitr::kable(t(weight_sim_power))

0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9
0.131 0.149 0.136 0.17 0.182 0.227 0.278 0.404 0.662

### 體脂肪比例

r_cand <- seq(.1,.9,.1)

mass_dat_list <- map(r_cand,
function(x) sim_design(
n = 7,                       ## 受試者人數
within =  list(cond = c("baseline", "final")),  ## 獨變項設定
mu = data.frame(baseline=39.38, final=35.98), ## 基準及結束平均值
sd = data.frame(baseline=4.10, final=4.46),   ## 基準及結束標準差
r = x,                                 ## 基準及結束相關係數
dv="mass",
long = TRUE,
rep=1000
)) %>%
set_names(nm=r_cand)

analyse <- function(data) {
t.test(mass ~ cond, data, paired = TRUE) %>%
broom::tidy()
}


mass_sim_power <- NULL
for(i in 1:length(mass_dat_list)){
mass_sim_power <- c(mass_sim_power,mass_dat_list[[i]] %>%
mutate(analysis = map(data, analyse)) %>%
select(-data) %>%
unnest(analysis) %>%
mutate(sig = p.value < .05) %>%
summarise(power = mean(sig)) %>%
pull(power))
}

names(mass_sim_power) <- r_cand
knitr::kable(t(mass_sim_power))

0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9
0.255 0.294 0.309 0.353 0.428 0.512 0.609 0.753 0.966

### BMI

r_cand <- seq(.1,.9,.1)

BMI_dat_list <- map(r_cand,
function(x) sim_design(
n = 7,                       ## 受試者人數
within =  list(cond = c("baseline", "final")),  ## 獨變項設定
mu = data.frame(baseline=34.62, final=31.73), ## 基準及結束平均值
sd = data.frame(baseline=3.27, final=2.89),   ## 基準及結束標準差
r = x,                                 ## 基準及結束相關係數
dv="BMI",
long = TRUE,
rep=1000
)) %>%
set_names(nm=r_cand)

analyse <- function(data) {
t.test(BMI ~ cond, data, paired = TRUE) %>%
broom::tidy()
}


BMI_sim_power <- NULL
for(i in 1:length(BMI_dat_list)){
BMI_sim_power <- c(BMI_sim_power,BMI_dat_list[[i]] %>%
mutate(analysis = map(data, analyse)) %>%
select(-data) %>%
unnest(analysis) %>%
mutate(sig = p.value < .05) %>%
summarise(power = mean(sig)) %>%
pull(power))
}

names(BMI_sim_power) <- r_cand
knitr::kable(t(BMI_sim_power))

0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9
0.348 0.382 0.432 0.471 0.527 0.645 0.761 0.885 0.994

BMI測量的模擬資料分析結果顯示，前後測量相關性達到0.9時，相同條件的再現成功率可達到95%。需注意前後測量的高相關性，代表兩個時間的測量不是獨立事件。

## 目標來源

2021/6/3 我從哇賽心理學臉書粉絲團，得知王思恒醫師發表在天下雜誌的 科學證實：用想的也能變瘦？，這篇文章出自王醫師在隔一天上市的新書一分鐘健瘦身教室（2）的第一章。我注意到其中的文字描述符合“驚奇卻不堪一擊的小研究”條件。截圖摘要文章內容如下：

## 可思考的議題

Ritchie (2020) 指出今日研究者受到各種偏離科學精神的現實誘因，製造科學研究報告的動機並非單純是擴展人類知識領域。這類動機經常導致偏頗的“研究策略”，最極端的是造假、抄襲等學術不端行為，更多研究者採用的策略是設計能得到新奇發現的小樣本研究，而且今日的同儕評審系統，以及研究經費補助單位都提供如 Panayotov (2019) 這種研究出線機會。

### 給讀者的判斷建議

1. 參與者人數不達百人。越強調心理誘發條件的研究，效應量通常被高估，至少要百人才有起碼的證據力。

2. 研究報告的測量變項不只一種。研究程序可不斷重現的研究通常只關注少數幾種測量的變化，小樣本或初次嘗試的研究經常收集各種測量資料。

3. 研究報告的原始論文能不能公開取用？有沒有公開資料？沒有公開資料給小樣本研究開了一道墮落的方便之門：不符合假設的測量資料可以隱藏起來。這就是挑賣相好的(cherry picking)的研究策略，相對地我們能合理懷疑這項研究的證據力。

#### 參考文獻

Baker, Monya. 2016. “1,500 Scientists Lift the Lid on Reproducibility.” Nature News 533 (7604): 452. https://doi.org/gdgzjx.

DeBruine, Lisa. 2021. Faux: Simulation for Factorial Designs. Zenodo. https://doi.org/10.5281/zenodo.2669586.

Panayotov, Valentin Stefanov. 2019. “Studying a Possible Placebo Effect of an Imaginary Low-Calorie Diet.” Frontiers in Psychiatry 10: 550. https://doi.org/10.3389/fpsyt.2019.00550.

Ritchie, Stuart. 2020. Science Fictions: How Fraud, Bias, Negligence, and Hype Undermine the Search for Truth. First edition. New York: Metropolitan Books ; Henry Holt and Company.

Singal, Jesse. 2021. The Quick Fix: Why Fad Psychology Can’t Cure Our Social Ills.