在R simmer仿真中动态修改DataFrame实现预约调度的问题

一、解决patient_id动态求值报错问题 #

你遇到的核心问题是将函数对象直接传入mutate，而非先求值得到具体患者ID值。simmer的属性获取需要在仿真事件上下文内执行，不能直接把get_attribute包装成函数作为列值传入tibble。

修正步骤：

1. 在assign_appointment函数内主动获取当前患者ID的具体值，而非包装成函数
2. 用simmer环境对象的$get_attribute()方法直接调用，确保在仿真上下文内求值

示例代码：

assign_appointment <- function(env) {
  # 直接获取当前患者ID的具体值
  p_id <- env$get_attribute("patient_id")
  
  # 筛选最早可用预约时段
  available_slot <- df_appointment_slots %>%
    filter(is_assigned == FALSE) %>%
    slice(1) %>%
    pull(slot_time)
  
  # 更新预约表：使用具体的p_id值而非函数
  df_appointment_slots <<- df_appointment_slots %>%
    mutate(
      is_assigned = ifelse(slot_time == available_slot, TRUE, is_assigned),
      patient_id = ifelse(slot_time == available_slot, p_id, patient_id)
    )
  
  return(available_slot)
}

二、自定义动态预约分配优化方案 #

simmer的核心逻辑是事件触发+资源调度，预约分配的关键是在患者到达后，按自定义规则匹配可用时段，并关联后续就诊事件。

1. 基础分配流程示例（最早可用时段） #

结合患者到达事件，完成预约分配并触发后续就诊流程：

# 定义患者轨迹
patient <- trajectory() %>%
  # 为到达患者分配ID（按到达顺序生成1-6）
  set_attribute("patient_id", function() {env$n_generated()}) %>%
  # 调用分配函数获取预约时段
  set_attribute("appt_slot", assign_appointment) %>%
  # 等待至预约时段
  timeout(function() {get_attribute(env, "appt_slot") - now(env)}) %>%
  # 占用医生资源就诊1小时
  seize("doctor") %>%
  timeout(1) %>%
  release("doctor")

# 初始化仿真环境
env <- simmer("clinic_sim") %>%
  add_resource("doctor", capacity = 1) %>%
  # 按第1-6小时分别添加患者
  add_generator("patient", patient, at(1:6)) %>%
  run(until = 21)

2. 进阶优化方向 #

（1）可配置分配规则

将分配规则抽离为独立函数，支持切换不同策略，比如优先匹配离患者到达时间最近的时段：

# 自定义规则：匹配离到达时间最近的可用时段
assign_closest_slot <- function(env, appt_env) {
  p_arrival <- now(env)
  p_id <- env$get_attribute("patient_id")
  df_slots <- appt_env$df_slots
  
  # 筛选并排序可用时段
  available_slot <- df_slots %>%
    filter(is_assigned == FALSE, slot_time >= p_arrival) %>%
    mutate(time_diff = abs(slot_time - p_arrival)) %>%
    arrange(time_diff) %>%
    slice(1) %>%
    pull(slot_time)
  
  # 更新预约状态
  appt_env$df_slots <- df_slots %>%
    mutate(
      is_assigned = ifelse(slot_time == available_slot, TRUE, is_assigned),
      patient_id = ifelse(slot_time == available_slot, p_id, patient_id)
    )
  
  return(available_slot)
}

（2）避免全局变量副作用

用专用环境存储预约状态，替代全局变量：

# 创建专用环境管理预约表
appt_env <- new.env()
appt_env$df_slots <- tibble(
  slot_time = c(1,2,3,4,5,11,12,14,15,19,20),
  is_assigned = FALSE,
  patient_id = NA_integer_
)

# 修改分配函数使用专用环境
assign_appointment <- function(env) {
  assign_closest_slot(env, appt_env)
}

（3）无可用时段的分流处理

添加逻辑处理预约已满的情况：

assign_closest_slot <- function(env, appt_env) {
  p_arrival <- now(env)
  p_id <- env$get_attribute("patient_id")
  df_slots <- appt_env$df_slots
  
  available_slot <- df_slots %>%
    filter(is_assigned == FALSE, slot_time >= p_arrival) %>%
    mutate(time_diff = abs(slot_time - p_arrival)) %>%
    arrange(time_diff) %>%
    slice(1) %>%
    pull(slot_time)
  
  # 无可用时段时返回NA
  if (is.na(available_slot)) {
    message(paste("患者", p_id, "无可用预约时段"))
    return(NA)
  }
  
  appt_env$df_slots <- df_slots %>%
    mutate(
      is_assigned = ifelse(slot_time == available_slot, TRUE, is_assigned),
      patient_id = ifelse(slot_time == available_slot, p_id, patient_id)
    )
  
  return(available_slot)
}

# 在患者轨迹中添加分流分支
patient <- trajectory() %>%
  set_attribute("patient_id", function() {env$n_generated()}) %>%
  set_attribute("appt_slot", assign_appointment) %>%
  # 无可用时段时结束流程
  branch(
    function() {is.na(get_attribute(env, "appt_slot"))},
    continue = FALSE,
    trajectory() %>% log_("无可用预约，患者离开")
  ) %>%
  timeout(function() {get_attribute(env, "appt_slot") - now(env)}) %>%
  seize("doctor") %>%
  timeout(1) %>%
  release("doctor") %>%
  log_("就诊完成")

内容的提问来源于stack exchange，提问作者Juan Alvarez