R Shiny中使用observe出现无限循环问题求助

问题描述 #

我想要实现一个植物种群的选择模拟，使用Shiny库编写了R代码，但取消注释observe中的t <- selection_nat(t)语句后，程序陷入无限循环。

原代码 #

server <- function(input, output) {
  n_pop <- reactiveVal()
  tab <- reactiveVal()
  
  S <- 0.5
  avantage_eau <- 1.1
  generation <- 0
  generation_max <- 10

  phenotype <- c("AB", "Ab", "aB", "ab")

  #Constructeur
  creer_plante <- function(type, age) {
    plante <- list(type = type, age = age)
    class(plante) <- "plante"
    return(plante)
  }

  #Getteurs
  get_type <- function(plante) {
    return(plante$type)
  }

  get_age <- function(plante) {
    return(plante$age)
  }

  #Affichage
  afficher_pheno_plantes <- function(tableau) {
    pie(table(sapply(tableau, get_type)))
  }

  afficher_age_plantes <- function(tableau) {
    pie(table(sapply(tableau, get_age)))
  }


  #Fonction
  vieillir <- function(plante) {
    return(creer_plante(get_type(plante), get_age(plante) + 1))
  }
  

  selection_nat <- function(tableau){
    tab_temp <- list()
    for (i in 1:n_pop()) {
      if (grepl("B", get_type(tableau[[i]]))) {
        if (runif(1) < S * avantage_eau) {
          tab_temp <- append(tab_temp, list(vieillir(tableau[[i]])))
        }
      } else {
        if (runif(1) < S) {
          tab_temp <- append(tab_temp, list(vieillir(tableau[[i]])))
        }
      }
    }
    return(tab_temp)
  }

  creation_tab <- function() {
    tab_temp <- list()
    for (i in 1:n_pop()) {
      nouvelle_plante <- creer_plante(phenotype[sample(1:4, 1)], 0)
      tab_temp <- append(tab_temp, list(nouvelle_plante))
    }
    return(tab_temp)
  }

  observe({
    n_pop(input$n)
    tab(creation_tab())

    t <- tab()
    while (generation < generation_max) { 
      # t <- selection_nat(t)
      n_pop(length(t))
      if (n_pop() == 0) {
        break
      }
      generation <- generation + 1
      
    }
    tab(t)
  })

  output$distPlot <- renderPlot({
    par(mfrow = c(2, 1))
    afficher_age_plantes(tab())
    afficher_pheno_plantes(tab())
    # cat(length(tab()), "plantes vivantes\n")
  })
}

问题原因 #

1. Reactive值触发循环：observe中修改了n_pop和tab这两个reactiveVal，而reactiveVal的更新会再次触发observe执行，形成无限循环。
2. 全局变量未重置：generation是全局变量，每次observe触发时不会重置为0，导致generation < generation_max的条件可能一直成立，循环无法终止。
3. 函数依赖reactive值：selection_nat函数中使用n_pop()获取种群数量，但n_pop是reactiveVal，在循环中修改它会引发额外的reactive触发。

解决方案 #

1. 将generation改为局部变量，在每次observe执行时重置为0，避免全局状态残留。
2. 模拟过程中使用局部变量存储种群数据，完成所有代的模拟后再一次性更新reactiveVal，避免中途触发observe重复执行。
3. 修改selection_nat函数，直接使用传入的种群列表长度，而非依赖n_pop()。

修改后的代码 #

server <- function(input, output) {
  n_pop <- reactiveVal()
  tab <- reactiveVal()
  
  S <- 0.5
  avantage_eau <- 1.1
  generation_max <- 10

  phenotype <- c("AB", "Ab", "aB", "ab")

  #Constructeur
  creer_plante <- function(type, age) {
    plante <- list(type = type, age = age)
    class(plante) <- "plante"
    return(plante)
  }

  #Getteurs
  get_type <- function(plante) {
    return(plante$type)
  }

  get_age <- function(plante) {
    return(plante$age)
  }

  #Affichage
  afficher_pheno_plantes <- function(tableau) {
    pie(table(sapply(tableau, get_type)))
  }

  afficher_age_plantes <- function(tableau) {
    pie(table(sapply(tableau, get_age)))
  }


  #Fonction
  vieillir <- function(plante) {
    return(creer_plante(get_type(plante), get_age(plante) + 1))
  }
  

  selection_nat <- function(tableau){
    tab_temp <- list()
    # 使用传入的tableau长度，而非依赖n_pop()
    pop_length <- length(tableau)
    for (i in 1:pop_length) {
      if (grepl("B", get_type(tableau[[i]]))) {
        if (runif(1) < S * avantage_eau) {
          tab_temp <- append(tab_temp, list(vieillir(tableau[[i]])))
        }
      } else {
        if (runif(1) < S) {
          tab_temp <- append(tab_temp, list(vieillir(tableau[[i]])))
        }
      }
    }
    return(tab_temp)
  }

  creation_tab <- function(pop_size) {
    tab_temp <- list()
    for (i in 1:pop_size) {
      nouvelle_plante <- creer_plante(phenotype[sample(1:4, 1)], 0)
      tab_temp <- append(tab_temp, list(nouvelle_plante))
    }
    return(tab_temp)
  }

  observe({
    # 获取输入的种群大小
    current_n <- input$n
    # 初始化种群
    current_tab <- creation_tab(current_n)
    
    # 初始化局部变量generation，避免全局状态问题
    generation <- 0
    while (generation < generation_max && length(current_tab) > 0) { 
      # 执行自然选择
      current_tab <- selection_nat(current_tab)
      generation <- generation + 1
    }
    
    # 模拟完成后一次性更新reactive值
    n_pop(length(current_tab))
    tab(current_tab)
  })

  output$distPlot <- renderPlot({
    par(mfrow = c(2, 1))
    afficher_age_plantes(tab())
    afficher_pheno_plantes(tab())
  })
}

关键改动说明 #

• selection_nat函数：不再依赖n_pop()，直接使用传入的种群列表长度，避免reactive值的不必要触发。
• creation_tab函数：新增pop_size参数，直接使用输入值而非依赖n_pop()，减少reactive依赖。
• observe块：
  • 使用局部变量current_n和current_tab存储模拟过程中的数据，中途不更新reactiveVal，直到模拟完成后一次性更新。
  • 将generation改为局部变量，每次observe执行时重置为0，确保每次模拟都从第0代开始。
  • 循环条件加入length(current_tab) > 0，提前终止空种群的模拟。

内容的提问来源于stack exchange，提问作者Clément Raspail