使用 Shiny 在反应性环境中更新绘图的最佳方式

Question

我想显示使用两个图的模拟动画。

一个是模拟的“人口”视图，其中点代表个体。在模拟的每一步，我都想在一个圆圈内绘制随机点，将这些点保留在下一代中。当两类个体中任意一个的出现频率达到1或0时，模拟停止。
另外一张是频率图，y轴是频率，x轴是代数。理想情况下，我希望此图在每一代都扩展并在频率达到 1/0 时停止。

我的第一个问题是我无法让 reactiveTimer() 正常工作。它不会自我更新，或者如果它会回到起点而不“记住”以前的状态。

我的第二个问题是，如果我在条件中使用 if 语句来保持模拟继续进行，它只会在按下 run 后迭代单代。或者，如果我使用 while 循环，它将直接转到最后一代，跳过模拟的所有中间部分。

我的第三个问题是我无法在反应环境中生成 data.frame 以便我可以绘制每一代之后的频率。

代码：

library(shiny)
library(ggplot2)

# function to make a circle data.frame
# 
circleFun <- function(center=c(0,0), diameter=10, npoints=100){
    r = diameter / 2
    tt = seq(0,2*pi,length.out = npoints)
    xx = center[1] + r * cos(tt)
    yy = center[2] + r * sin(tt)
    return(data.frame(x = xx, y = yy))
}

# ui
ui <- fluidPage(
    titlePanel("Genetic Drift Simulator"),
    sidebarLayout(
        sidebarPanel(
                # Input: select from menu
                numericInput(inputId = "population_size",
                          label = "Population size:",
                          value = 10,
                          step = 10),
                sliderInput(inputId = "initial_frequency",
                          label = "Initial frequency of allele 1:",
                          min = 0,
                          max = 1,
                          step = 0.1,
                          value = 0.5),
                actionButton(inputId = "run",
                            label = "Run simulation"),
                actionButton(inputId = "reset",
                        label = "Reset values")
                ),
        mainPanel(
            fluidRow(
                column(4,
                    verbatimTextOutput("text")
                    )
                ),
            fluidRow(
                column(8,
                    plotOutput("pop_plot")
                    )
                ),
            fluidRow(
                column(8,
                    plotOutput("freq_plot")
                    )
                )
            )
        )
    )

server <- function(input, output, session) {

    waits <- reactiveValues(timer = reactiveTimer(Inf))

    returns <- reactiveValues(
        z=NULL,
        x=NULL,
        y=NULL,
        freq=NULL,
        circle=NULL,
        i=NULL
        )

    frequencies <- reactiveValues(df=NULL)

    observe({
        returns$z=rbinom(input$population_size, 1, input$initial_frequency)
        returns$x=rnorm(input$population_size)
        returns$y=rnorm(input$population_size)
        returns$freq=input$initial_frequency
        returns$circle=circleFun()
        returns$i=0

        frequencies$df = data.frame(x=returns$i, y=returns$i)
    })

    population <- reactive({
        data.frame(x=returns$x, y=returns$y, z=returns$z)
    })

    grow_freq <- function(df, x, y){
        rbind(df, c(x,y))
    }

    grow <- reactive({
        frequencies$df = grow_freq(frequencies$df, returns$i, returns$freq)
    })

    drift <- reactive({
        returns$z = sample(returns$z, replace=T)
        # random locations
        returns$x = rnorm(input$population_size)
        returns$y = rnorm(input$population_size)
        # calculate frequency
        returns$freq = sum(returns$z == 1)/input$population_size
        # increase to next generation
        returns$i = returns$i+1
    })

    observeEvent(input$run, {
        if (returns$freq < 1 & returns$freq > 0){
            # observeEvent(reactiveTimer(200), {
                drift()
                grow()
            # })
        }
        # else {
        #     waits$timer <- reactiveTimer(Inf)
        # }
    })

    observeEvent(input$reset, {
        timer = reactiveTimer(Inf)

        returns$z = rbinom(input$population_size, 1, input$initial_frequency)
        returns$x = rnorm(input$population_size)
        returns$y = rnorm(input$population_size)
        returns$freq = input$initial_frequency
        returns$circle=circleFun(center=c(0,0), diameter=10, npoints=100)
        returns$i = 0

        frequencies$df = data.frame(x=returns$i, y=returns$i)
    })

    output$text <- renderText({
        text = paste("Population size: ",input$population_size,"\n",
                    "Frequency allele 1: ",returns$freq,"\n",
                    "Generation: ",returns$i, sep="")
        print(text)
        })

    output$pop_plot <- renderPlot({
        ggplot(data=population(), aes(x, y)) +
            geom_point(aes(color=factor(z)), size=5, alpha=0.7) +
            geom_path(data=returns$circle, color="black", size=2) +
            scale_color_brewer(type="qual", palette=1, name="allele") +
            theme(axis.title=element_blank(), axis.text=element_blank()) +
            theme(legend.title=element_text(size=16), legend.text=element_text(size=14))
        },
        height = 400, width = 450)

    output$freq_plot <- renderPlot({
        ggplot(data=frequencies$df, aes(x, y)) +
            geom_point() +
            geom_line() +
            ylim(0,1)
        },
        height = 300, width = 500)

}

shinyApp(ui = ui, server = server)

Answer 1

您注意到的三个问题已在以下代码中得到解决。我将您的第一个 observe 更改为 observeEvent。请注意，您需要在模拟结束时点击重置。

# ui
ui <- fluidPage(
  titlePanel("Genetic Drift Simulator"),
  sidebarLayout(
    sidebarPanel(
      # Input: select from menu
      numericInput(inputId = "population_size",
                   label = "Population size:",
                   value = 10,
                   step = 10),
      sliderInput(inputId = "initial_frequency",
                  label = "Initial frequency of allele 1:",
                  min = 0,
                  max = 1,
                  step = 0.1,
                  value = 0.5),
      actionButton(inputId = "run",
                   label = "Run simulation"),
      actionButton(inputId = "reset",
                   label = "Reset values")
    ),
    mainPanel(
      fluidRow(
        column(4,
               verbatimTextOutput("text")
        )
      ),
      fluidRow(
        column(8,
               plotOutput("pop_plot")
        )
      ),
      fluidRow(
        column(8,
               plotOutput("freq_plot")
        )
      )
    )
  )
)

server <- function(input, output, session) {

  # Anything that calls autoInvalidate will automatically invalidate every 2 seconds.
  autoInvalidate <- reactiveTimer(2000)
  #waits <- reactiveValues(timer = reactiveTimer(Inf))

  returns <- reactiveValues(
    z=NULL,
    x=NULL,
    y=NULL,
    freq=NULL,
    circle=NULL,
    i=NULL
  )

  frequencies <- reactiveValues(df=NULL)
  #observe({
  observeEvent(list(input$population_size,input$initial_frequency), {
    returns$z=rbinom(input$population_size, 1, input$initial_frequency)
    returns$x=rnorm(input$population_size)
    returns$y=rnorm(input$population_size)
    returns$freq=input$initial_frequency
    returns$circle=circleFun()
    returns$i=0

    frequencies$df = data.frame(x=returns$i, y=returns$i)
  })

  population <- reactive({
    data.frame(x=returns$x, y=returns$y, z=returns$z)
  })

  grow_freq <- function(df, x, y){
    rbind(df, c(x,y))
  }

  grow <- reactive({
    frequencies$df <- grow_freq(frequencies$df, returns$i, returns$freq)
  })

  drift <- reactive({
    returns$z = sample(returns$z, replace=T)
    # random locations
    returns$x = rnorm(input$population_size)
    returns$y = rnorm(input$population_size)
    # calculate frequency
    returns$freq = sum(returns$z == 1)/input$population_size
    # increase to next generation
    returns$i = returns$i+1
  })

  observeEvent(list(input$run,autoInvalidate()), {

    if (returns$freq < 1 & returns$freq > 0){
      # observeEvent(reactiveTimer(200), {
      drift()
      grow()
      # })
    }
    # else {
    #   waits$timer <- reactiveTimer(200)
    # }
  })

  observeEvent(input$reset, {
    #timer = reactiveTimer(Inf)

    returns$z = rbinom(input$population_size, 1, input$initial_frequency)
    returns$x = rnorm(input$population_size)
    returns$y = rnorm(input$population_size)
    returns$freq = input$initial_frequency
    returns$circle=circleFun(center=c(0,0), diameter=10, npoints=100)
    returns$i = 0

    frequencies$df = data.frame(x=returns$i, y=returns$i)
  })

  output$text <- renderText({
    text = paste("Population size: ",input$population_size,"\n",
                 "Frequency allele 1: ",returns$freq,"\n",
                 "Generation: ",returns$i, sep="")
    print(text)
  })

  output$pop_plot <- renderPlot({
    autoInvalidate()
    ggplot(data=population(), aes(x, y)) +
      geom_point(aes(color=factor(z)), size=5, alpha=0.7) +
      geom_path(data=returns$circle, color="black", size=2) +
      scale_color_brewer(type="qual", palette=1, name="allele") +
      theme(axis.title=element_blank(), axis.text=element_blank()) +
      theme(legend.title=element_text(size=16), legend.text=element_text(size=14))
  },
  height = 400, width = 450)

  output$freq_plot <- renderPlot({
    autoInvalidate()
    ggplot(data=frequencies$df, aes(x, y)) +
      geom_point() +
      geom_line() +
      ylim(0,1)
  },
  height = 300, width = 500)

}

shinyApp(ui = ui, server = server)

Answer 2

我对已接受答案的编辑被拒绝，因此我将修改后的代码发布在这里作为答案。原因是我没有回答 OP 的问题。这很奇怪，因为 OP 是我。

简而言之：

我从图中删除了 reactiveTimer 个函数。
计数器现在在按下 运行 按钮后启动，而不是自动启动。
修复了第二个图上初始频率设置为 0 而不是 0.5 的错误
删除了模拟块上的 else 语句以允许 reset 按钮工作。

可以在 here 中找到 ShinyApp 的示例。

# ui
ui <- fluidPage(
    titlePanel("Genetic Drift Simulator"),
    sidebarLayout(
        sidebarPanel(
            # Input: select from menu
            numericInput(inputId = "population_size",
            label = "Population size:",
            value = 10,
            step = 10),
            sliderInput(inputId = "initial_frequency",
            label = "Initial frequency of allele 1:",
            min = 0,
            max = 1,
            step = 0.1,
            value = 0.5),
            actionButton(inputId = "run",
            label = "Run simulation"),
            actionButton(inputId = "reset",
            label = "Reset values")
        ),
        mainPanel(
            fluidRow(
                column(4,
                    verbatimTextOutput("text")
                )
            ),
            fluidRow(
                column(8,
                    plotOutput("pop_plot")
                )
            ),
            fluidRow(
                column(8,
                    plotOutput("freq_plot")
                )
            )
        )
    )
)

server <- function(input, output, session) {

    # Anything that calls autoInvalidate will automatically invalidate.
    autoInvalidate <- reactiveValues(timer=NULL)

    returns <- reactiveValues(
        z=NULL,
        x=NULL,
        y=NULL,
        freq=NULL,
        circle=NULL,
        i=NULL
    )

    frequencies <- reactiveValues(df=NULL)

    observeEvent(list(input$population_size,input$initial_frequency), {
        returns$z=rbinom(input$population_size, 1, input$initial_frequency)
        returns$x=rnorm(input$population_size)
        returns$y=rnorm(input$population_size)
        returns$freq=input$initial_frequency
        returns$circle=circleFun()
        returns$i=0

        frequencies$df = data.frame(x=returns$i, y=returns$freq)

        autoInvalidate$timer = reactiveTimer(Inf)

    })

    population <- reactive({
        data.frame(x=returns$x, y=returns$y, z=returns$z)
    })

    grow_freq <- function(df, x, y){
        rbind(df, c(x,y))
    }

    grow <- reactive({
        frequencies$df <- grow_freq(frequencies$df, returns$i, returns$freq)
    })

    drift <- reactive({
        returns$z = sample(returns$z, replace=T)
        # random locations
        returns$x = rnorm(input$population_size)
        returns$y = rnorm(input$population_size)
        # calculate frequency
        returns$freq = sum(returns$z == 1)/input$population_size
        # increase to next generation
        returns$i = returns$i+1
    })

    observeEvent(input$run, {
        autoInvalidate$timer = reactiveTimer(1000) # changed to 1 second
        drift()
        grow()
    })

    observeEvent(autoInvalidate$timer(), {
        if (returns$freq < 1 & returns$freq > 0 & returns$i != 0){
            autoInvalidate$timer()
            drift()
            grow()
        }
        # else if (returns$freq == 0 | returns$freq == 1) {
        #     autoInvalidate$timer = reactiveTimer(Inf)
        # }
    })

    observeEvent(input$reset, {
        returns$z = rbinom(input$population_size, 1, input$initial_frequency)
        returns$x = rnorm(input$population_size)
        returns$y = rnorm(input$population_size)
        returns$freq = input$initial_frequency
        returns$circle=circleFun(center=c(0,0), diameter=10, npoints=100)
        returns$i = 0

        frequencies$df = data.frame(x=returns$i, y=returns$freq)

        autoInvalidate$timer = reactiveTimer(Inf)
    })

    output$text <- renderText({
        #autoInvalidate$timer()
        text = paste("Population size: ",input$population_size,"\n",
        "Frequency allele 1: ",returns$freq,"\n",
        "Generation: ",returns$i, sep="")
        print(text)
    })

    output$pop_plot <- renderPlot({
        #autoInvalidate$timer()
        ggplot(data=population(), aes(x, y)) +
        geom_point(aes(color=factor(z)), size=5, alpha=0.7) +
        geom_path(data=returns$circle, color="black", size=2) +
        scale_color_brewer(type="qual", palette=1, name="allele") +
        theme(axis.title=element_blank(), axis.text=element_blank()) +
        theme(legend.title=element_text(size=16), legend.text=element_text(size=14))
    },
    height = 400, width = 450)

    output$freq_plot <- renderPlot({
        #autoInvalidate$timer()
        if (dim(frequencies$df)[1] == 1){
            ggplot(data=frequencies$df, aes(x, y)) +
            geom_hline(yintercept=0.5) +
            geom_point() +
            labs(x="generation",y="frequency") +
            ylim(0,1)
        } else {
            ggplot(data=frequencies$df, aes(x, y)) +
            geom_hline(yintercept=0.5) +
            geom_point() +
            geom_line() +
            labs(x="generation",y="frequency") +
            ylim(0,1)
        }
    },
    height = 300, width = 500)

}

shinyApp(ui = ui, server = server)

使用 Shiny 在反应性环境中更新绘图的最佳方式

Best way to update plots within a reactive environment with Shiny

simulation

r

shiny