Несколько ограниченных ползунков в 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)

Основная проблема заключается в том, чтобы позаботиться о шаге ползунков.Если все ползунки имеют одинаковую ширину шага, и вы пытаетесь разделить изменение пользователя одного ползунка и передать его двум другим, они не смогут отобразить это изменение, когда пользователь решит изменить только один шаг (потребуется обновитьдва зависимых ползунка с полшага), потому что это ниже их разрешения.Согласно моему ответу, я принимаю во внимание только изменения> stepwidth, которые вызывают ошибки округления, но обходят вышеупомянутую проблему.Вы можете уменьшить эту ошибку, увеличив количество рассматриваемых цифр.

Answer 2

Превращение вашей горячей клавиши в local_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)