Смоделируйте двумерное случайное блуждание по сетке в R и постройте график с помощью ggplot

Я искал простой код, который мог бы имитировать двумерное случайное блуждание по сетке (используя R), а затем отображать данные, используя ggplot.

В частности, меня интересовало случайное блуждание от нескольких позиций (5 точек) в 2D-сетке до центра квадратной сетки. Это просто для целей визуализации.

И моя идея заключалась в том, чтобы нанести результаты с ggplot на дискретную сетку (как смоделированная), возможно, с использованием функции geom_tile.

Есть ли у вас какие-либо предложения для уже существующего кода, которым я мог бы легко манипулировать?


person CafféSospeso    schedule 06.05.2021    source источник
comment
Не могли бы вы уточнить, что вы хотите сделать? Можете ли вы привести пример того, как это будет выглядеть?   -  person VitaminB16    schedule 06.05.2021
comment
Что-то похожее на это econometricsbysimulation.com/2012/ 08/, но в сетке.   -  person CafféSospeso    schedule 06.05.2021
comment
Почему geom_tile()?   -  person VitaminB16    schedule 06.05.2021


Ответы (3)


РЕДАКТИРОВАТЬ ----

После разговора с OP я пересмотрел код, включив в него вероятность шага. Это может привести к тому, что ходьба станет стационарной гораздо чаще. В более высоких измерениях вам нужно будет уменьшить коэффициент prob, чтобы компенсировать большее количество вариантов.

наконец, моя функция не учитывает абсолютное расстояние, она рассматривает только точки на сетке, которые находятся в пределах определенного размера шага во всех измерениях. Например, гипотетически, в позиции c(0,0) с помощью этой функции можно перейти в c(1,1). Но я предполагаю, что это связано со связностью сети.

Если OP хочет рассматривать только узлы, которые находятся в пределах 1 (по расстоянию) от текущей позиции, используйте следующую версию move_step()

move_step <- function(cur_pos, grid, prob = 0.04, size = 1){
  opts <- grid %>%
    rowwise() %>%
    mutate(across(.fns = ~(.x-.env$cur_pos[[cur_column()]])^2,
                  .names = '{.col}_square_diff')) %>%
    filter(sqrt(sum(c_across(ends_with("_square_diff"))))<=.env$size) %>%
    select(-ends_with("_square_diff")) %>%
    left_join(y = mutate(cur_pos, current = TRUE), by = names(grid)) 
  new_pos <- opts %>%
    mutate(weight = case_when(current ~ 1-(prob*(n()-1)), #calculate chance to move, 
                              TRUE ~ prob),               #in higher dimensions, we may have more places to move
           weight = if_else(weight<0, 0, weight)) %>%    #thus depending on prob, we may always move.
    sample_n(size = 1, weight = weight) %>%
    select(-weight, -current)
  new_pos
}
library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(ggplot2)
library(gganimate)

move_step <- function(cur_pos, grid, prob = 0.04, size = 1){
  opts <- grid %>%
    filter(across(.fns =  ~ between(.x, .env$cur_pos[[cur_column()]]-.env$size, .env$cur_pos[[cur_column()]]+.env$size))) %>%
    left_join(y = mutate(cur_pos, current = TRUE), by = names(grid)) 
  new_pos <- opts %>%
    mutate(weight = case_when(current ~ 1-(prob*(n()-1)), #calculate chance to move, 
                              TRUE ~ prob),               #in higher dimensions, we may have more places to move
           weight = if_else(weight<0, 0, weight)) %>%    #thus depending on prob, we may always move.
    sample_n(size = 1, weight = weight) %>%
    select(-weight, -current)
  new_pos
}

sim_walk <- function(cur_pos, grid, grid_prob = 0.04, steps = 50, size = 1){
  iterations <- cur_pos
  for(i in seq_len(steps)){
    cur_pos <- move_step(cur_pos, grid, prob = grid_prob, size = size)
    iterations <- bind_rows(iterations, cur_pos)
  }
  iterations$i <- 1:nrow(iterations)
  iterations
}

origin <- data.frame(x = 0, y =0)
small_grid <- expand.grid(x = -1:1, y = -1:1)
small_walk <- sim_walk(cur_pos = origin,
                       grid = small_grid)

ggplot(small_walk, aes(x, y)) +
  geom_path() +
  geom_point(color = "red") +
  transition_reveal(i) +
  labs(title = "Step {frame_along}") +
  coord_fixed()

large_grid <- expand.grid(x = -10:10, y = -10:10)
large_walk <- sim_walk(cur_pos = origin,
                       grid = large_grid,
                       steps = 100)

ggplot(large_walk, aes(x,y)) +
  geom_path() +
  geom_point(color = "red") +
  transition_reveal(i)  +
  labs(title = "Step {frame_along}") +
  xlim(c(-10,10)) + ylim(c(-10,10))+
  coord_fixed()

large_walk %>% 
  count(x, y) %>%
  right_join(y = expand.grid(x = -10:10, y = -10:10), by = c("x","y")) %>%
  mutate(n = if_else(is.na(n), 0L, n)) %>%
  ggplot(aes(x,y)) +
  geom_tile(aes(fill = n)) +
  coord_fixed()

multi_dim_walk <- sim_walk(cur_pos = data.frame(x = 0, y = 0, z = 0),
                           grid =  expand.grid(x = -20:20, y = -20:20, z = -20:20),
                           steps = 100, size = 2)

library(cowplot)
plot_grid(
  ggplot(multi_dim_walk, aes(x, y)) + geom_path(),
  ggplot(multi_dim_walk, aes(x, z)) + geom_path(),
  ggplot(multi_dim_walk, aes(y, z)) + geom_path())

Создана 06 мая 2021 г. в пакете reprex (v1.0.0)

person Justin Landis    schedule 06.05.2021
comment
Это очень впечатляет и интересно. Я блуждал, думаете ли вы, что можно было бы включить вероятность шага движения ... что, например, каждый шаг имеет вероятность 4% для временного интервала = 1. Имеет ли это смысл для вас? - person CafféSospeso; 06.05.2021
comment
может быть, но я думаю, было бы полезно, если бы вы могли более конкретно указать в своем посте, что вы можете ожидать в симуляции. Каковы ограничения, может ли один шаг привести вас куда угодно в сетке (т.е. размер шага не важен). Или вы хотите, чтобы каждая позиция сетки имела разную вероятность в зависимости от времени или расстояния от текущей позиции. Эти детали могут кардинально изменить код - person Justin Landis; 06.05.2021
comment
Сначала я отвечу на ваши вопросы здесь, а затем обновлю свой пост. Ограничения таковы: размер шага = 1, и такой шаг происходит с заданной вероятностью px. Шаги происходят через дискретные интервалы времени. Каждая позиция сетки имеет одинаковую вероятность перемещения, но, учитывая, что я установил размер шага 1, тогда для каждой дискретной точки времени будет только один шаг, если предположить, что это произойдет (зависит от px). Стало немного яснее? Извините, если это не так, и я попробую еще раз. - person CafféSospeso; 06.05.2021
comment
Итак, если есть 3 позиции, на которые мы можем переместиться, и px = 0.04 (4%), то есть 12% шанс переместиться, а при изменении 88% он останется на текущей позиции? - person Justin Landis; 06.05.2021
comment
Да, точно. Для простоты я предполагаю, что есть 4 соседних позиции, за исключением краев или углов сетки, где доступно 3 и 2 позиции соответственно. - person CafféSospeso; 06.05.2021
comment
Не имеет отношения к тому, что вы сейчас обсуждаете, но могу ли я порекомендовать вам использовать + coord_fixed(1), чтобы установить оси ggplot в одном масштабе. Какое отличное решение, однако! - person VitaminB16; 06.05.2021
comment
повторный рендеринг репрекса сейчас. - person Justin Landis; 07.05.2021

Вот небольшой пример с циклом for. Отсюда вы можете просто настроить определение X_t и Y_t:

Xt = 0; Yt = 0
for (i in 2:1000)
{
  Xt[i] = Xt[i-1] + rnorm(1,0,1)
  Yt[i] = Yt[i-1] + rnorm(1,0,1)
}
df <- data.frame(x = Xt, y = Yt)
ggplot(df, aes(x=x, y=y)) + geom_path() + theme_classic() + coord_fixed(1)

введите здесь описание изображения

person VitaminB16    schedule 06.05.2021

Вот базовый вариант R с использованием Reduce + replicate + plot для процесса 2D-случайного блуждания.

set.seed(0)
plot(
  setNames(
    data.frame(replicate(
      2,
      Reduce(`+`, rnorm(99), init = 0, accumulate = TRUE)
    )),
    c("X", "Y")
  ),
  type = "o"
)

введите здесь описание изображения

person ThomasIsCoding    schedule 06.05.2021