プレゼミ第二回課題

課題1

Q1 『予想通りに不合理―行動経済学が明かす「あなたがそれを選ぶわけ」』『不合理だからうまくいく―行動経済学で見る欲望と衝動の謎』『ずる―嘘とごまかしの行動経済学』『やる気の科学―パフォーマンスを最大化する行動心理学』

米国南東部の自動車保険会社が第4著者の監督のもとで実施したフィールド実験である。顧客は、自分の保険に加入している最大4台の車両について、走行距離計の値を報告することを求められた。また、顧客はランダムに、フォームの最上部または最下部に「提供している情報は真実であることを約束する」という文言への署名を求められた。その結果、「上に署名」条件に割り当てられた顧客は、「最下に署名」条件に割り当てられた顧客よりも、平均して2,400マイル多く走行したと報告した。

Anomaly 1：数値が不自然にきれいである。保険データであれば申告額や走行距離には端数が含まれるはずだが、数字が丸められており、統計的に不自然な滑らかさが見られた。

Anomaly 2：変数同士の相関が不自然である。自然データであれば誤差やランダム性によって崩れるはずの複数の変数が、極めて高い相関を示していた。

Anomaly 3：偽装乱数特有の分布が観察された。数字の繰り返しを避ける、ばらつきが均等になりすぎるなど、人為的に生成された乱数に典型的なパターンが見られた。

Anomaly 4：同じ被験者が似た値を複数回出している。本来は個別に異なるはずの値が非常に近かったり、小数点以下の挙動が一致していたりするなど、実際の個別データでは起こりにくい現象が確認された。

Q4 私たちがすべきことはデータの公開である。今回の捏造は、データが公開されたことによって発覚した。もし、より多くの研究でデータ公開が進めば、不正はより早期に、かつ容易に検出できるようになると考えられる。

課題2

dat <- read_xlsx("第二回課題/DrivingdataAll with font.xlsx")

Table1

dat %>%
  group_by(condition) %>%
  summarize(
    baseline_mean = mean(baseline_average),
    baseline_sd   = sd(baseline_average),
    update_mean   = mean(update_average),
    update_sd     = sd(update_average)
  ) %>%
  kable()

condition	baseline_mean	baseline_sd	update_mean	update_sd
Sign Bottom	75034.50	50265.35	98705.14	51934.76
Sign Top	59692.71	49953.51	85791.10	51701.31

Figure1

dat %>%
  mutate(diff_car1 = update_car1 - baseline_car1) %>%
  ggplot(aes(x = diff_car1)) +
  geom_histogram(fill = "blue", color = "black", bins = 50) +
  coord_cartesian(xlim = c(0, 100000))

Figure2

p1 <- dat %>%
  mutate(diff_car1 = update_car1 - baseline_car1) %>%
  ggplot(aes(x = diff_car1)) + geom_histogram(fill = "blue", color = "black",bins = 50)


p2 <- dat %>%
  mutate(diff_car2 = update_car2 - baseline_car2) %>%
  ggplot(aes(x = diff_car2)) + geom_histogram(fill = "brown", color = "black",bins = 50)


p3 <- dat %>%
  mutate(diff_car3 = update_car3 - baseline_car3) %>%
  ggplot(aes(x = diff_car3)) + geom_histogram(fill = "green", color = "black", bins = 50)


p4 <- dat %>%
  mutate(diff_car4 = update_car4 - baseline_car4) %>%
  ggplot(aes(x = diff_car4)) + geom_histogram(fill = "white", color = "black",bins = 50)


(p1 + p2) / (p3 + p4)

## Warning: Removed 7839 rows containing non-finite outside the scale range
## (`stat_bin()`).

## Warning: Removed 12211 rows containing non-finite outside the scale range
## (`stat_bin()`).

## Warning: Removed 13161 rows containing non-finite outside the scale range
## (`stat_bin()`).

Figure4

t1 <- c(dat$baseline_car1, dat$baseline_car2, dat$baseline_car3, dat$baseline_car4)
t2 <- c(dat$update_car1,   dat$update_car2,   dat$update_car3,   dat$update_car4)


t1_last <- str_sub(as.character(t1), -1, -1) |> as.numeric()
t2_last <- str_sub(as.character(t2), -1, -1) |> as.numeric()


T1 <- ggplot(data.frame(value = t1_last), aes(x = value)) +
  geom_bar(aes(y = after_stat(prop)), fill = "dimgray") +
  scale_x_continuous(breaks = 0:9) +
  labs(x = "last_digit_Time1", y = "Prop") +
  ylim(0, 0.25)


T2 <- ggplot(data.frame(value = t2_last), aes(x = value)) +
  geom_bar(aes(y = after_stat(prop)), fill = "dimgray") +
  scale_x_continuous(breaks = 0:9) +
  labs(x = "last_digit_Time2", y = "Prop") +
  ylim(0, 0.25)


T1 + T2

## Warning: Removed 33211 rows containing non-finite outside the scale range
## (`stat_count()`).
## Removed 33211 rows containing non-finite outside the scale range
## (`stat_count()`).

プレゼミ第二回課題

水谷桃子

2025-12-18