Р: Динамическое обновление вероятности переворачивания блина
Я работаю с языком программирования R.
Я пытаюсь смоделировать эксперимент «переворачивание блинов на сковороде» со следующими условиями:
- Каждый ход существует вероятность 0,5, что блин будет «выбран для переворачивания» (например, представьте, что вы случайно встряхиваете сковороду и надеетесь, что блин перевернется).
- Если блин действительно перевернут, существует вероятность 0,5, что он упадет орлом, и вероятность 0,5, что он упадет решкой.
- На каждом ходу мы записываем совокупное количество наблюдаемых орлов и решек — если блин не выбран для переворачивания, то сторона, на которой блин находится в данный момент, вносит свой вклад в совокупное число.
Вот моя попытка смоделировать эксперимент по переворачиванию блинов:
set.seed(123)
#turns
n <- 100
# selection probabilities
selected <- rbinom(n, 1, 0.5)
coin_flip <- rbinom(n, 1, 0.5)
# base data frame
df <- data.frame(turn_number = 1:n,
selected = ifelse(selected == 1, "yes", "no"),
current_result = ifelse(selected == 1, ifelse(coin_flip == 1, "heads", "tails"), "not_selected"))
# previous_result column
df$previous_result <- c("not_selected", df$current_result[-n])
# new column for most recent non "not_selected" result
df$most_recent_non_not_selected <- df$current_result
for(i in 2:n) {
if (df$most_recent_non_not_selected[i] == "not_selected") {
df$most_recent_non_not_selected[i] <- df$most_recent_non_not_selected[i-1]
}
}
# set most_recent_non_not_selected to NA when the coin is selected
df$most_recent_non_not_selected[df$selected == "yes"] <- NA
# add new column that merges current_result and most_recent_non_not_selected
df$merged_result <- ifelse(is.na(df$most_recent_non_not_selected), df$current_result, df$most_recent_non_not_selected)
# add new columns for cumulative counts of "heads" and "tails"
df$cumulative_heads <- cumsum(df$merged_result == "heads")
df$cumulative_tails <- cumsum(df$merged_result == "tails")
Результат выглядит следующим образом и кажется правильным (т. е. один из столбцов совокупного счета всегда увеличивается):
turn_number selected current_result previous_result most_recent_non_not_selected merged_result cumulative_heads cumulative_tails
1 no not_selected not_selected not_selected not_selected 0 0
2 yes tails not_selected <NA> tails 0 1
3 no not_selected tails tails tails 0 2
4 yes heads not_selected <NA> heads 1 2
5 yes tails heads <NA> tails 1 3
Мой вопрос: Сейчас я пытаюсь добавить в эту симуляцию еще одну деталь, чтобы сделать ее более реалистичной.
- Представьте себе, что чем дольше блин лежит на сковороде, не разбираясь, он начинает подгорать и прилипать к сковороде, и его становится гораздо труднее перевернуть. Хочу сделать так, чтобы при каждом повороте блин не выбирался, вероятность его выбора для переворачивания уменьшалась на 0,01. Однако если нам удастся его выбить, счетчик обнулится и вернется к значению 0,5.
- Представьте, что та сторона, которая готовится больше, тоже тяжелее. Таким образом, когда блин переворачивается, вероятность того, что он приземлится на более тяжелую сторону, зависит от совокупных соотношений. Например, если cumulative_heads=1 и cumulative_tails=3, вероятность того, что блин выпадет решкой, в 3 раза выше, чем орлом.
Может кто-нибудь показать мне, как добавить эти детали в мою симуляцию?
Спасибо!
Допустим, блин не переворачивается с первого раза. На следующем ходу его выбирают для переворота. Совокупное количество орлов равно 1, а совокупное количество решок равно 0. Совокупное соотношение составляет 1/0 = бесконечность. Блинчик непереворачивается. (Ну, вы можете перевернуть его, но он всегда выпадет орлом.) Я думаю, вам нужно изменить правило «отношений», чтобы допускать нули без нарушения.
Одним из потенциальных способов решения этой проблемы было бы придать соотношению немного «массы» 50/50, скажем, начать совокупный подсчет с 10 каждый.
@gregor thomas: спасибо за ответ! Я согласен с вашими комментариями... Я готов изменить эту проблему, чтобы она имела другие ограничения и упростила ее решение. Пожалуйста, не стесняйтесь сделать это. Спасибо!
Ответы 1
Я сделал функцию для этого. Единственный аргумент — n, количество витков. Вместо того, чтобы сначала создавать весь фрейм данных, вам нужно создать только одну строку, а затем перебирать каждую строку, обновляя вероятности на каждой итерации. Для дополнительной детализации № 2 я использую коэффициенты, но вы можете использовать и другие методы, например апостериорный анализ Байеса.
require(dplyr)
set.seed(3210)
pancake_flip <- function(n) {
# Initialise
df <- data.frame(turn_number = 1,
p.selected=0.5,
p.flip=0.5,
selected = "no",
current_result = "not_selected",
cum.heads = 0,
cum.tails = 0)
# Iterate
for(i in 2:n){
if (i==2){
# Initial values
cum.heads <- 0
cum.tails <- 0
previous_result <- "not selected"
# Initial probabilities
p.selected <- 0.5
p.flip <- 0.5
} else {
# Extra detail 1: Update selected probability
if (current_result= = "not_selected") {
p.selected <- p.selected - 0.01
# Check probability - it cannot fall below 0
if (p.selected<0) stop("The pancake is burnt to a crisp")
} else {
# Reset initial probabilities
p.selected <- 0.5
}
# Extra detail #2: Adjust flip probabilities based on cumulative sums
odds <- (1 + cum.heads)/(1 + cum.tails)
p.flip <- odds/(1 + odds)
}
# Simulation
selected <- rbinom(1, 1, p.selected)
coin_flip <- rbinom(1, 1, p.flip)
selected = ifelse(selected == 1, "yes", "no")
current_result <- ifelse(selected == "yes",
ifelse(coin_flip == 1, "heads", "tails"),
"not_selected")
# Save the current result if the pancake was flipped
# If the pancake is not selected for flipping,
# the side the pancake is currently on contributes towards the cumulative numbers.
if (selected= = "yes") previous_result <- current_result
if (current_result= = "heads") {
cum.heads <- cum.heads + 1
} else if (current_result= = "tails") {
cum.tails <- cum.tails + 1
} else if (current_result= = "not_selected") {
if (previous_result= = "heads") cum.heads <- cum.heads + 1
if (previous_result= = "tails") cum.tails <- cum.tails + 1
}
# Update data frame
df <- rbind(df, data.frame(turn_number=i,
p.selected=p.selected,
p.flip=p.flip,
selected=selected,
current_result=current_result,
cum.heads=cum.heads,
cum.tails=cum.tails))
}
df
}
Вызовите функцию и просмотрите первые и последние 5 строк.
df2 <- pancake_flip(n=100)
dplyr::slice(df2, c(1:5, 95:100))
turn_number p.selected p.flip selected current_result cum.heads cum.tails
1 1 0.50 0.5000000 no not_selected 0 0
2 2 0.50 0.5000000 no not_selected 0 0
3 3 0.49 0.5000000 no not_selected 0 0
4 4 0.48 0.5000000 yes heads 1 0
5 5 0.50 0.6666667 yes heads 2 0
6 95 0.50 0.4731183 no not_selected 43 49
7 96 0.49 0.4680851 no not_selected 43 50
8 97 0.48 0.4631579 no not_selected 43 51
9 98 0.47 0.4583333 no not_selected 43 52
10 99 0.46 0.4536082 no not_selected 43 53
11 100 0.45 0.4489796 yes heads 44 53
@ Эдвард: большое спасибо за ответ! Я хотел спросить вас об одной вещи... не могли бы вы добавить в окончательный ответ два столбца, в которых записаны вероятности в каждой строке? Большое спасибо!
Конечно. Проверьте исправленный ответ.
@ Эдвард: Большое спасибо за эти обновления! Просто чтобы уточнить: «п.флип» — это вероятность выпадения орла, верно?
Не могли бы вы объяснить этот комментарий: «Для дополнительной детали №2 я использую коэффициенты»? Большое спасибо!
Конечно. Вы сказали: «...когда блин переворачивается, вероятность того, что он приземлится на более тяжелую сторону, зависит от совокупных соотношений». Шансы связаны с вероятностью. А соотношение совокупных сумм двух конкурирующих событий сродни вероятности того, что одно событие произойдет по сравнению с другим. Наконец, вероятность наступления одного события определяется как «шанс / (1 + шанс)».
Да, p.flip — это вероятность выпадения «орла», поскольку у вас был current_result <- ifelse(selected == "yes", ifelse(coin_flip == 1, "heads", "tails"), "not_selected")
Приготовленная сторона светлее, так как влага удалена, но это придирка в контексте слова «представьте». Предназначен ли вывод также для сигнализации «когда» блин следует перевернуть?