r - 遍历一个列表,同时对另一个列表进行采样
问题描述
我试图模拟鸟类相互配对的过程。我模拟了一群男性和女性('agents_for_pairing'),该过程的工作方式是:
1) 如果繁殖季节的日期('day')等于雄性的可用日期(aDate),则雄性可以在当天或之后的任何一天繁殖。
2)如果女性也有空(aDate = day[i]),那么它随机选择一个可用的男性(还没有配对并且也有空)。如果有多个女性和男性可用,则代码应循环遍历每个女性并在该特定日期将其与男性配对。
3) 如果雌性已准备好繁殖但没有雄性可用,则其可用日期增加一 (aDate + 1) 并在第二天再次尝试(并且该过程重复直到配对)。
4) 一旦个人配对,他们就会接受他们伴侣的身份和他们的状态变化(配对 == TRUE)。
我将种群分为雌性和雄性,然后循环浏览繁殖季节的每一天,以及每个可用的雌性(如果有的话)。我的代码如下所示:
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
解决方案
这是一个有趣的问题。我从来没有弄清楚你的代码有什么问题,但这是我的。
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
给定状态和性别可用的 s 列表:
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
推荐阅读
- r - R:dplyr 按行号排列
- javascript - 如果使用“then and catch”而不是“async/await”,这段代码会是什么样子?
- javascript - 找不到未定义的属性“过滤器”
- c - 计算平方根的自定义程序未显示任何输出
- javascript - JS中的公式为游戏中的不同分支创建体验目标
- animation - 是否有一种“简单”的方式在 Python 中为散点图设置动画?
- android - 在 Android Emulator 上从 Flutter 请求 ASP.Net Core 3.1 的请求主机名无效
- swift - 为什么 URL 会话不会按应有的顺序执行?
- php - Laravel 更新表单
- kotlin - 当我们应该在 android 中创建新布局时