Question

我正在尝试构建一个具有多个滑块的Shiny App，以控制多个受约束的权重（即它们的总和应为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

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

@Override
public void onCreate(Bundle savedInstanceState) {
    ...
    aSpinner.setSelection(1, true);
    new Handler().postDelayed(() -> bSpinner.setSelection(1, true), 50);
}

Answer 2

以下是有关更新逻辑的解决方案：

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)

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

R ShinyApp中的多个约束滑块

2 个答案: