R ShinyApp 中的多个受限滑块

Question

我正在尝试构建一个带有多个滑块的闪亮应用程序来控制几个受约束的权重（即它们应该加起来为 1）。我的外行尝试低于“有效”，但当其中一个参数采用极值（0 或 1）时会陷入无限循环。

我尝试过使用反应式缓存，但之后只有第一个要修改的滑块会被“观察”。很少有随机的隔离调用让我无处可去。我仍然需要完全掌握更新流程的工作原理。 ：/

我已经看到了两个互补滑块的实现，但似乎未能将其推广到许多人。

任何帮助将不胜感激！ 最好的， 马丁

---

library(shiny)

states <- c('W1', 'W2', 'W3')
cache <- list()
hotkey <- ''
forget <- F

ui =pageWithSidebar(
  headerPanel("Test 101"),
  sidebarPanel(
  sliderInput(inputId = "W1", label = "PAR1", min = 0, max = 1, value = 0.2),
  sliderInput(inputId = "W2", label = "PAR2", min = 0, max = 1, value = 0.2),
  sliderInput(inputId = "W3", label = "PAR3", min = 0, max = 1, value = 0.6)
  ),
  mainPanel()
)

server = function(input, output, session){

  update_cache <- function(input){

    if(length(cache)==0){
      for(w in states)
      cache[[w]] <<- input[[w]]
    } else if(input[[hotkey]] < 1){

      for(w in states[!(states == hotkey)]){

        if(forget==T){
          newValue <- (1-input[[hotkey]])/(length(states)-1)
        } else{
          newValue <- cache[[w]] * (1 - input[[hotkey]])/(1-cache[[hotkey]])
        }
        cache[[w]] <<- ifelse(is.nan(newValue),0,newValue)
      }

      forget <<- F
      cache[[hotkey]] <<- input[[hotkey]]

    } else{
      for(w in states[!(states == hotkey)]){
        cache[[w]] <<- 0
      }
      forget <<- T
    }

  }

  # when water change, update air
  observeEvent(input$W1,  {
    hotkey <<- "W1"
    update_cache(input)

    for(w in states[!(states == hotkey)]){
      updateSliderInput(session = session, inputId = w, value = cache[[w]])
    }
  })

  observeEvent(input$W2,  {
    hotkey <<- "W2"
    update_cache(input)
    for(w in states[!(states == hotkey)]){
      updateSliderInput(session = session, inputId = w, value = cache[[w]])
    }
  })

  observeEvent(input$W3,  {
    hotkey <<- "W3"
    update_cache(input)
    for(w in states[!(states == hotkey)]){
      updateSliderInput(session = session, inputId = w, value = cache[[w]])
    }
  })

}

shinyApp(ui = ui, server = server)

Answer 1

这里是关于更新逻辑的解决方案：

library(shiny)

consideredDigits <- 3
stepWidth <- 1/10^(consideredDigits+1)

ui = pageWithSidebar(
  headerPanel("Test 101"),
  sidebarPanel(
    sliderInput(inputId = "W1", label = "PAR1", min = 0, max = 1, value = 0.2, step = stepWidth),
    sliderInput(inputId = "W2", label = "PAR2", min = 0, max = 1, value = 0.2, step = stepWidth),
    sliderInput(inputId = "W3", label = "PAR3", min = 0, max = 1, value = 0.6, step = stepWidth),
    textOutput("sliderSum")
  ),
  mainPanel()
)

server = function(input, output, session){

  sliderInputIds <- paste0("W", 1:3)
  sliderState <- c(isolate(input$W1), isolate(input$W2), isolate(input$W3))
  names(sliderState) <- sliderInputIds

  observe({
    sliderDiff <- round(c(input$W1, input$W2, input$W3)-sliderState, digits = consideredDigits)
    if(any(sliderDiff != 0)){
      diffIdx <- which(sliderDiff != 0)
      if(length(diffIdx) == 1){
        diffID <- sliderInputIds[diffIdx]
        sliderState[-diffIdx] <<- sliderState[-diffIdx]-sliderDiff[diffIdx]/2
        if(any(sliderState[-diffIdx] < 0)){
          overflowIdx <- which(sliderState[-diffIdx] < 0)
          sliderState[-c(diffIdx, overflowIdx)] <<- sum(c(sliderState[-diffIdx]))
          sliderState[overflowIdx] <<- 0
        }
        for(sliderInputId in sliderInputIds[!sliderInputIds %in% diffID]){
          updateSliderInput(session, sliderInputId, value = sliderState[[sliderInputId]])
        }
        sliderState[diffIdx] <<- input[[diffID]]
      }
    }
    output$sliderSum <- renderText(paste("Sum:", sum(c(input$W1, input$W2, input$W3))))
  })

}

shinyApp(ui = ui, server = server)

主要问题是要注意滑块的步宽。如果所有滑块具有相同的步长，并且您尝试拆分一个滑块的用户更改并将其传递给另外两个滑块，则一旦用户选择仅更改一个步骤，他们将无法显示该更改（需要更新两个相关的滑块，半步），因为它低于它们的分辨率。在我的回答中，我只考虑了更改 > 步宽，这会导致舍入错误，但可以解决上述问题。您可以通过增加考虑的数字来减少此错误。

Answer 2

在 update_cache 中将热键设为本地可以避免递归：

library(shiny)

states <- c('W1', 'W2', 'W3')
cache <- list()
hotkey <- ''
forget <- F

ui =pageWithSidebar(
  headerPanel("Test 101"),
  sidebarPanel(
    sliderInput(inputId = "W1", label = "PAR1", min = 0, max = 1, value = 0.2),
    sliderInput(inputId = "W2", label = "PAR2", min = 0, max = 1, value = 0.2),
    sliderInput(inputId = "W3", label = "PAR3", min = 0, max = 1, value = 0.6)
  ),
  mainPanel()
)

server = function(input, output, session){

  update_cache <- function(input, hotkey){

    if(length(cache)==0){
      for(w in states)
        cache[[w]] <<- input[[w]]
    } else if(input[[hotkey]] < 1){

      for(w in states[!(states == hotkey)]){

        if(forget==T){
          newValue <- (1-input[[hotkey]])/(length(states)-1)
        } else{
          newValue <- cache[[w]] * (1 - input[[hotkey]])/(1-cache[[hotkey]])
        }
        cache[[w]] <<- ifelse(is.nan(newValue),0,newValue)
      }

      forget <<- F
      cache[[hotkey]] <<- input[[hotkey]]

    } else{
      for(w in states[!(states == hotkey)]){
        cache[[w]] <<- 0
      }
      forget <<- T
    }

  }

  # when water change, update air
  observeEvent(input$W1,  {
    update_cache(input, "W1")
    for(w in states[!(states == hotkey)]){
      updateSliderInput(session = session, inputId = w, value = cache[[w]])
    }
  })

  observeEvent(input$W2,  {
    update_cache(input, "W2")
    for(w in states[!(states == hotkey)]){
      updateSliderInput(session = session, inputId = w, value = cache[[w]])
    }
  })

  observeEvent(input$W3,  {
    update_cache(input, "W3")
    for(w in states[!(states == hotkey)]){
      updateSliderInput(session = session, inputId = w, value = cache[[w]])
    }
  })

}

shinyApp(ui = ui, server = server)