r - 避免依赖于更新的 slider 值的计算的双重执行

Question

背景:在 Shiny 应用程序中，我有 (i) 数据输入文本区域和 (ii) slider 。 slider 的值和端点由数据更新，因为 slider 范围应适合数据的比例。随后的耗时计算同时使用文本区域中的数据和 slider 中的值。

问题:当数据改变时，耗时的计算会执行两次，首先使用 slider 的前一个值(而不是 slider 的更新值) )，然后第二次使用 slider 的更新值。我的目的是让它只执行一次，使用 slider 的更新值而不是 slider 的先前值。

一个最小的示例:下面的 R 代码通过尽可能小的设置演示了问题。只需复制并粘贴到 RStudio 中，然后单击“运行应用程序”。您将在屏幕底部看到输出:几秒钟后显示 4025，几秒钟后显示 50。单击“重新加载”再次观看。初始输出(即 4025)无关紧要。仅预期最终输出(即 50)。

其他细微差别: slider 处于去抖延迟状态，因此其运动不会立即触发耗时的计算。用户应该能够暂时移动 slider ，而不会立即触发计算。这对于应用程序很重要，但与双重执行问题无关。数据 textAreaInput 使用 actionButton，因此输入文本不会立即触发计算。同样，这对于应用程序很重要，但与双重执行问题无关。

提前感谢您的建议!

library(shiny)
library(magrittr) # for pipe operator, %>%, used with debounce().
debounceDelay = 2000 # milliseconds

ui <- fluidPage(
  titlePanel("Data affect Slider, both affect Subsequent Long Computation"),
  sidebarLayout(
    sidebarPanel(
      # Data input:
      textAreaInput( inputId="dataText" , 
                     label="Type data, then click Submit:" , 
                     value="10 20 30 40" ,
                     width="200px" ,
                     height="100px" ) ,
      actionButton( inputId="dataSubmit" , 
                    label="Submit Data" ) ,
      # Slider input, to be updated by data:
      sliderInput( inputId = "slider1" ,
                   label = HTML("Constant to Add to Mean of Data 
                                (after debounce delay):") ,
                   min=3000 , max=5000 , value=4000 , 
                   round=FALSE , step=1 , ticks=FALSE )
    ) , # end sidebarPanel
    mainPanel(
      textOutput("theOutput")
    )
  ) # end sidebarLayout
) # end ui fluidPage

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

  # Parse data values out of data text:
  theData = reactive({
    input$dataSubmit # establish dependency on dataSubmit button
    yText = isolate(input$dataText) # remove dependency on dataText
    y = as.numeric(unlist(strsplit(yText,"\\s+")[[1]]))
    if ( any(is.na(y)) | length(y) < 2 ) {
      y=c(-12.3, 45.6, 78.9) # arbitrary replacement values
      updateTextAreaInput( session ,
                           inputId="dataText" ,
                           value=paste(as.character(y),collapse=" ") )
    }
    return( y )
  }) 
  # Computation on data for using in slider update:
  upUI <- reactive({
    low = min( theData() )
    val = median( theData() )
    high = max( theData() )
    return( list( low=low , val=val , high=high ) )
  })
  # Update slider based on data values:
  observe({
    updateSliderInput( session , inputId="slider1" , 
                       min=upUI()$low , 
                       max=upUI()$high , 
                       value=upUI()$val )
  })

  # Debounce the slider value so it doesn't instantly trigger a cascade of long
  # computations
  sliderValue <- reactive({
    return( input$slider1 )
  }) %>% debounce(debounceDelay)

  # Compute output:
  output$theOutput <- renderText({
    Sys.sleep(3) # simulate lengthy computation time
    return( paste( "Time-consuming computation...
        Mean of data plus slider value: " ,
        mean(theData()) + sliderValue() ) ) 
  }) # end of renderText

} # end server

shinyApp(ui = ui, server = server)

针对 @ismirsehregal 回复的初始版本的修订:

使用 eventReactive( input$runComp , { ...long城计算... } ) 的建议来保护长计算，我修改了我的初始脚本。不再需要对 slider 值进行反跳，因为 slider 不会触发长计算。据我所知，也没有必要有 req(theData(), sliderValue())。我还在计算部分添加了一个 if(){}else{} 来检查无效的文本数据输入。这个修改后的脚本构成了该问题的一种解决方案。

library(shiny)

ui <- fluidPage(
  titlePanel("Data affect Slider, both affect Subsequent Long Computation"),
  sidebarLayout(
    sidebarPanel(
      # Data input:
      textAreaInput( inputId="dataText" , 
                     label=HTML( "<b>Type data here.</b> <small>(Must be at least two numeric values separated by whitespace.)</small>" ) , 
                     value="10 20 30 40" ,
                     width="200px" ,
                     height="100px" ) ,
      # Slider input, to be updated by data:
      sliderInput( inputId = "slider1" ,
                   label = HTML("<b>Select constant to add to mean of data.</b> <small>(Slider settings will change if data change.)</small>") ,
                   min=NA , max=NA , value=NA , 
                   round=FALSE , step=1 , ticks=FALSE ),
      HTML("<p>Click the button to start the time-consuming computation:") ,
      actionButton( inputId="runComp" , 
                    label="Start Computation" )
    ) , # end sidebarPanel
    mainPanel(
      textOutput("theOutput")
    )
  ) # end sidebarLayout
) # end ui fluidPage

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

  theDataDefault = c(-1, 1)

  # Parse data values out of data text:
  theData = reactive({
    yText = input$dataText
    y = as.numeric(unlist(strsplit(yText,"\\s+")[[1]]))
    return( y )
  }) 
  # Computation on data for using in slider update:
  upUI <- reactive({
    if ( any(is.na(theData())) | length(theData()) < 2 ) {
      y = theDataDefault 
    } else {
      y = theData()
    }
    low = min( y )
    val = mean( range( y ) )
    high = max( y )
    return( list( low=low , val=val , high=high ) )
  })
  # Update slider based on data values:
  observe({
    updateSliderInput( session , inputId="slider1" , 
                       min=upUI()$low , 
                       max=upUI()$high , 
                       value=upUI()$val )
  })

  # Compute output:
  textOut <- eventReactive( input$runComp, {
    if ( any(is.na(theData())) | length(theData()) < 2 ) {
      return( "ERROR: Data must be at least two numeric values (no letters) separated by whitespace (no commas, etc.)." ) 
    } else {
      Sys.sleep(3) # simulate lengthy computation time
      return( paste( "Time-consuming computation...
                   Mean of data plus slider value: " ,
                     mean( theData()) + input$slider1 ) ) 
    }
  })

  output$theOutput <- renderText({
    textOut()
  }) 

} # end server

shinyApp(ui = ui, server = server)

Answer 1

请检查这是否符合您的期望:

现在 slider 的初始值为NA，因此您可以通过req()阻止初始显示。此外，我在 renderText 中隔离了 theData() 以避免它被触发两次(仅监听 slider 的变化)。

library(shiny)
library(magrittr) # for pipe operator, %>%, used with debounce().
debounceDelay = 2000 # milliseconds

ui <- fluidPage(
  titlePanel("Data affect Slider, both affect Subsequent Long Computation"),
  sidebarLayout(
    sidebarPanel(
      # Data input:
      textAreaInput( inputId="dataText" , 
                     label="Adapt slider data:" , 
                     value="10 20 30 40" ,
                     width="200px" ,
                     height="100px" ) ,
      # Slider input, to be updated by data:
      sliderInput( inputId = "slider1" ,
                   label = HTML("Constant to Add to Mean of Data 
                                (after debounce delay):") ,
                   min=NA , max=NA , value=NA , 
                   round=FALSE , step=1 , ticks=FALSE ),
      actionButton( inputId="runComp" , 
                    label="Start Computation" )
    ) , # end sidebarPanel
    mainPanel(
      textOutput("theOutput")
    )
  ) # end sidebarLayout
) # end ui fluidPage

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

  # Parse data values out of data text:
  theData = reactive({
    yText = input$dataText
    y = as.numeric(unlist(strsplit(yText,"\\s+")[[1]]))
    if ( any(is.na(y)) | length(y) < 2 ) {
      y=c(-12.3, 45.6, 78.9) # arbitrary replacement values
      updateTextAreaInput( session ,
                           inputId="dataText" ,
                           value=paste(as.character(y),collapse=" ") )
    }
    return( y )
  }) 
  # Computation on data for using in slider update:
  upUI <- reactive({
    low = min( theData() )
    val = median( theData() )
    high = max( theData() )
    return( list( low=low , val=val , high=high ) )
  })
  # Update slider based on data values:
  observe({
    updateSliderInput( session , inputId="slider1" , 
                       min=upUI()$low , 
                       max=upUI()$high , 
                       value=upUI()$val )
  })

  # Debounce the slider value so it doesn't instantly trigger a cascade of long
  # computations
  sliderValue <- reactive({
    return( input$slider1 )
  }) %>% debounce(debounceDelay)

  # Compute output:
  textOut <- eventReactive(input$runComp, {
    req(theData(), sliderValue())
    Sys.sleep(3) # simulate lengthy computation time
    print(paste(Sys.time(), "Time-consuming computation..."))
    return( paste( "Time-consuming computation...
        Mean of data plus slider value: " ,
                   mean(theData()) + sliderValue() ) ) 
  })

  output$theOutput <- renderText({
    textOut()
  }) # end of renderText

} # end server

shinyApp(ui = ui, server = server)

<小时/>

编辑:这是一个(基于时间的)解决方案，可解决 @JohnK.Kruschke 所描述的预期行为。我个人更喜欢上述解决方案(如果主机 PC 因外部环境而变慢，这可能会失败，但在我的测试过程中它有效)。

library(shiny)
library(magrittr) # for pipe operator, %>%, used with debounce().
debounceDelay = 2000 # milliseconds

ui <- fluidPage(
  titlePanel("Data affect Slider, both affect Subsequent Long Computation"),
  sidebarLayout(
    sidebarPanel(
      # Data input:
      textAreaInput(
        inputId = "dataText" ,
        label = "Type data, then click Submit:" ,
        value = "10 20 30 40" ,
        width = "200px" ,
        height = "100px"
      ) ,
      p(actionButton(inputId = "dataSubmit" ,
                   label = "Submit Data")) ,
      # Slider input, to be updated by data:
      sliderInput(
        inputId = "slider1" ,
        label = HTML("Constant to Add to Mean of Data
                                (after debounce delay):") ,
        min=3000 , max=5000 , value=4000 ,
        round = FALSE ,
        step = 1 ,
        ticks = FALSE
      )
    ) ,
    # end sidebarPanel
    mainPanel(textOutput("theOutput"))
  ) # end sidebarLayout
) # end ui fluidPage

server <- function(input, output, session) {
  sliderUpdates <- reactiveValues(latestProgrammatic = Sys.time(), timeDiff = 0)

  # Parse data values out of data text:
  theData = reactive({
    input$dataSubmit# establish dependency on dataSubmit button
    yText = isolate(input$dataText) # remove dependency on dataText
    y = as.numeric(unlist(strsplit(yText, "\\s+")[[1]]))
    if (any(is.na(y)) | length(y) < 2) {
      y = c(-12.3, 45.6, 78.9) # arbitrary replacement values
      updateTextAreaInput(session ,
                          inputId = "dataText" ,
                          value = paste(as.character(y), collapse = " "))
    }
    return(y)
  })
  # Computation on data for using in slider update:
  upUI <- reactive({
    low = min(theData())
    val = median(theData())
    high = max(theData())
    return(list(
      low = low ,
      val = val ,
      high = high
    ))
  })
  # Update slider based on data values:
  observeEvent(upUI(), {
    sliderUpdates$latestProgrammatic <- Sys.time()
    print(paste("Programmatic slider update was triggered:" , sliderUpdates$latestProgrammatic))
    updateSliderInput(
      session ,
      inputId = "slider1" ,
      min = upUI()$low ,
      max = upUI()$high ,
      value = upUI()$val
    )
  })

  # Debounce the slider value so it doesn't instantly trigger a cascade of long
  # computations
  sliderValue <- reactive({
    latestUnkown <- Sys.time()
    print(paste("Slider was updated:" , latestUnkown))
    sliderUpdates$timeDiff <- latestUnkown - sliderUpdates$latestProgrammatic

    req(input$slider1)
    return(input$slider1)
  }) %>% debounce(debounceDelay)

  # Compute output:
  output$theOutput <- renderText({
    req(theData(), sliderValue(), req(isolate(sliderUpdates$timeDiff)))

    print(paste("Elapsed time since the last programmatic slider update:", isolate(sliderUpdates$timeDiff)))
    if(isolate(sliderUpdates$timeDiff) > 0.2){
      Sys.sleep(3) # simulate lengthy computation time
      return(
        paste(
          "Time-consuming computation...
        Mean of data plus slider value: " ,
          mean(theData()) + sliderValue()
        )
      )
    } else {
      NULL
    }

  }) # end of renderText

} # end server

shinyApp(ui = ui, server = server)