цикл по одному списку при выборке другого

Question

Я пытаюсь смоделировать процесс спаривания птиц друг с другом.Я смоделировал популяцию самцов и самок («agents_for_pairing»), и процесс должен работать следующим образом:

1) Если день сезона размножения («день») равен дате самцадоступен (aDate), тогда самец может размножаться в этот день или в любой день после него.

2) Если самка также доступна (aDate = day [i]), тогда она случайным образом выбирает доступного самца(еще не спарено и также доступно).Если доступно несколько самок и самцов, код должен проходить по каждой самке и связывать ее с самцом в этот конкретный день.

3) Если самка готова к размножению, но самцы не доступны, то еедоступная дата увеличивается на единицу (aDate + 1), и она пытается снова на следующий день (и процесс повторяется до тех пор, пока она не объединится в пару).

4) После того, как отдельные лица объединены в пару, они принимают идентификатор своего партнера и своихизменения статуса (в паре == ИСТИНА).

Я делю популяцию на самок и самцов, затем перебираю каждый день сезона размножения и каждую доступную самку (если есть).Мой код выглядит следующим образом:

library(tidyverse)

'%ni%' <- Negate('%in%')

agents_for_pairing <- tribble(
  ~id, ~mateID, ~sex, ~paired, ~aDate,
  34, NA, 'F', FALSE, 86,
  56, NA, 'F', FALSE, 90,
  14, NA, 'F', FALSE, 90,
  113, NA, 'M', FALSE, 86,
  2, NA, 'M', FALSE, 89,
  23, NA, 'M', FALSE, 87
)  
agents_for_pairing

# split into list by sex
agents_for_pairing <- agents_for_pairing %>%
  mutate(mateID = as.numeric(mateID)) %>%
  split(.$sex)
agents_for_pairing

day <- seq(86, 90, by=1) # days to loop through

for (i in seq_along(day)) { # for each day

  print(day[i])

    if (nrow(agents_for_pairing$F %>% filter(aDate == day[i] & paired == FALSE)) < 1) { # if there are no females available

      print('no females available') # do nothing but print this message

    } else {

      for (j in 1:nrow(agents_for_pairing$F %>% filter(aDate == day[i] & paired == FALSE))) { # go through female that is ready to breed

        if (nrow(agents_for_pairing$M %>% filter(id %ni% (agents_for_pairing$F$mateID) & aDate <= day[i] & paired == FALSE)) > 0) { # find a male that hasn't been taken yet & available

        mate <- sample_n(agents_for_pairing$M %>% filter(id %ni% (agents_for_pairing$F$mateID) & aDate <= day[i] & paired == FALSE), size=1, replace=FALSE) # randomly sample one mate

        agents_for_pairing$F[j,]$mateID <- mate[[1]] # make it your mate
        agents_for_pairing$F[j,]$paired <- TRUE # change status to paired now

        agents_for_pairing$M <- agents_for_pairing$M %>% # make sure paired male has same status and adopts female id
          mutate(
            mateID = case_when(
              id == mate$id ~ agents_for_pairing$F[j,]$id,
              TRUE ~ mateID
            ),
            paired = case_when( 
              mateID > 0 ~ TRUE, # males without a mate remain unpaired
              TRUE ~ FALSE
              )
            )

      } else {

        agents_for_pairing$F[j,]$paired <- FALSE # if no males available, remain unpaired
        agents_for_pairing$F <- agents_for_pairing$F %>%
            mutate(
              aDate = case_when(
                aDate == day[i] & paired == FALSE ~ aDate + 1, # and increase date available by a day
                TRUE ~ aDate
                )
              )
      }
    }
  }
}

agents_for_pairing

Где-то, кажется, в коде есть ошибка ... не все женщины способны к соединению, даже если мужчин достаточно:

$F
# A tibble: 3 x 5
     id mateID sex   paired aDate
  <dbl>  <dbl> <chr> <lgl>  <dbl>
1    34     23 F     TRUE      86
2    56      2 F     TRUE      90
3    14     NA F     FALSE     90

$M
# A tibble: 3 x 5
     id mateID sex   paired aDate
  <dbl>  <dbl> <chr> <lgl>  <dbl>
1   113     34 M     TRUE      86
2     2     56 M     TRUE      89
3    23     34 M     TRUE      87

Это более сложный цикл for, чем я пытался в прошлом, и мне интересно, есть ли проблема с индексацией?Я думаю, что во втором цикле for, где я пытаюсь соединить каждую доступную самку, я могу неправильно назначить свою половинку ... какой-нибудь совет?Должно выглядеть примерно так:

$F
# A tibble: 3 x 5
id mateID sex   paired aDate
<dbl>  <dbl> <chr> <lgl>  <dbl>
1    34     113 F     TRUE      86
2    56      2 F     TRUE      90
3    14     23 F     FALSE     90

$M
# A tibble: 3 x 5
id mateID sex   paired aDate
<dbl>  <dbl> <chr> <lgl>  <dbl>
1   113     34 M     TRUE      86
2     2     56 M     TRUE      89
3    23     14 M     TRUE      87

Answer 1

Это была интересная проблема для работы.Я никогда не выяснял, что не так с вашим кодом, но вот мой.

library(tidyverse)

Я маркирую ваш agents for pairing как state:

state1 <- tribble(
  ~id, ~sex, ~aDate, ~mateID,
  34, 'F', 86, NA,
  56, 'F', 90, NA,
  14, 'F', 90, NA,
  113, 'M', 86, NA,
  2, 'M', 89, NA,
  23, 'M', 87, NA
)

minday <- min(state1$aDate)
maxday <- max(state1$aDate)

days <- seq(minday, maxday, 1)

Определите stateframe объект, который будет содержать все эволюции:

stateframe <- rep(NA, length(days)) %>% as.list()

Называет состояния "днем":

names(stateframe) <- c(minday:maxday)

Первый кадр состояния - это начальный df, который вы дали:

stateframe[[1]] <- state1

Вспомогательная функция whichAvailable.Выходные данные - это список id с, которые доступны в зависимости от состояния и пола:

whichAvailable <- function(date, mysex){ # date is in seq_along(days), sex as character M / F
return(
  stateframe[[date]] %>%
  mutate(available = ifelse(aDate <= as.numeric(names(stateframe[date])) &
                              is.na(mateID), TRUE, FALSE)) %>%
  filter(sex == mysex, available == TRUE) %>%
    select(id) %>%
    unlist() %>%
    as.numeric()
  )
}

Внешняя последовательность проходит по дням, внутренняя последовательность проходит по одному и тому же фрейму данных, пока не будет найдено больше пар.

for (i in seq_along(days)) {
  availablePairings <- c(length(whichAvailable(i, "F")), length(whichAvailable(i, "M")))
  # loop through day `i` until no more pairings can be found
  if (all(availablePairings > 0)) {
    # mate all available males and females
    for (j in 1:max(availablePairings)) {
      maleid <- whichAvailable(i,"M")[[1]] # pick the first male in the list
      femaleid <- whichAvailable(i, "F")[[1]] # pick the first female in the list
      stateframe[[i]][stateframe[[i]]$id == maleid,]$mateID <- femaleid
      stateframe[[i]][stateframe[[i]]$id == femaleid,]$mateID <- maleid
    }
  } 
  stateframe[[i + 1]] <- stateframe[[i]]
}

Результат:

> stateframe[[5]]
# A tibble: 6 x 4
     id sex   aDate mateID
  <dbl> <chr> <dbl>  <dbl>
1    34 F        86    113
2    56 F        90      2
3    14 F        90     23
4   113 M        86     34
5     2 M        89     56
6    23 M        87     14