R ShinyApp中的多个受约束滑块

我正在尝试构建一个有多个滑块的闪亮应用程序，以控制多个受约束的权重（即，它们的总和应为1）。我的外行在下面的尝试“有效”，但当其中一个参数取极值（0或1）时，它会进入无限循环

我尝试使用反应式缓存，但只有第一个要修改的滑块会在之后被“观察”。没有几个随机的电话让我一事无成。我仍然需要完全掌握更新流程的工作原理：/

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

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

---

库（闪亮）
状态将热键设置为本地更新\u缓存可避免递归：

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)

库（闪亮）
states以下是关于更新逻辑的解决方案：

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)

库（闪亮）
深思熟虑的数字感谢@Ismirsehegal的帮助！尽管您的建议中已经没有了长期存在的递归，但它仍然没有按预期工作。当任何变量取极值（0或1）时，其中两个变量会向下/向上波动至0.5，并在短暂的更新循环后保持不变。似乎需要修改更新/忘记逻辑…我没有花任何时间看那个逻辑，因为我不知道你想要什么。我只是想有三个互补的滑块（即三个值加起来总是1），请检查我的第二个答案。嗨！不幸的是，这里的逻辑也不完全正确。有时会遇到大于1的总值（三个滑块值之和）。事实上，我发现一个非常类似的问题很久以前在这里被问过：。最初的解决方案似乎适合我（尽管没有使用我心目中的dinamicUI方法）。事实上，它与这里的代码非常相似（使用'observe（{}'而不是我的'observeEvent（{}'调用）。非常感谢您的输入@ismirsehregal，非常感谢。啊。。是的，我明白了（在某些情况下是这样的），我没有花足够的时间测试它。但很高兴看到你找到了解决办法。溴
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)