Ограничить несколько слайдеров в блестящем виде до 100

Question

Я боролся с этим весь день и вроде как решил (ужасный хак). Однако опыт не является гладким и показывает побочные эффекты.

Мне нужны три ползунка с ограниченным диапазоном от 0 до 100, чтобы их сумма всегда была равна 100.

Это скриншот того, как это выглядит

Вот блестящий код server.R.

library(shiny)

oldState<-NULL
newState<-NULL

getState<-function(input) c(input$slider1, input$slider2, input$slider3)

# Define server logic required
shinyServer(function(input, output, session) {

  observe({
    newState<<-getState(input)
    i<-which(oldState-newState != 0)[1]
    if(!is.na(i)){
      rem <- 100-newState[i]
      a<-sum(newState[-i])
      if(a==0) newState[-i]<<-rem/length(newState[-i])
      else newState[-i]<<-rem*(newState[-i]/a)
      for(j in 1:length(newState))
        if(j!=i)
          updateSliderInput(session, paste0("slider", j), value=newState[j])
    }
    oldState<<-newState
  })

  output$restable <- renderTable({
    myvals<-getState(input)
    myvals<-c(myvals, sum(myvals))
    data.frame(Names=c("Slider 1", "Slider 2", "Slider 3", "Sum"),
               Values=myvals)
  })
})

и вот блестящий код ui.R

library(shiny)

# Define UI for application
shinyUI(pageWithSidebar(

  # Application title
  headerPanel("Sliders should sum to 100!"),

  # Sidebar with sliders whos sum should be constrained to be 100
  sidebarPanel(
    sliderInput("slider1", "Slider 1: ", min = 0, max = 100, value = 40, step=1),
    sliderInput("slider2", "Slider 2: ", min = 0, max = 100, value = 30, step=1),
    sliderInput("slider3", "Slider 3: ", min = 0, max = 100, value = 30, step=1)
  ),

  # Create table output
  mainPanel(
    tableOutput("restable")
  )
))

Теперь это делает в значительной степени то, что должно, за исключением двух вещей:

• Это похоже на взлом, то есть должен быть лучший способ сделать это
• Когда я перемещаю ползунок в положение, он иногда переходит в немного более низкое или более высокое положение. Понятия не имею почему.

Как мне исправить эти две проблемы?

Answer 1

Я думаю, что использование dynamicUI может решить вашу проблему.

Если вы знаете, что должно быть ровно 3 входа, сумма которых равна 1, то вы можете ограничить своего пользователя только двумя входами ползунка и сделать 2-й вход ползунка зависимым от первого, как показано ниже. Используя ваш код шаблона:

server.R

library(shiny)

# Define server logic required
shinyServer(function(input, output) {

  output$slider2 <- renderUI {
    sliderInput("slider2", "Slider 2", min = 0,  max = 100 - input$slider1, value = 0)  
  })

  output$restable <- renderTable({
    myvals<- c(input$slider1, input$slider2, 100-input$slider1-input$slider2)
    data.frame(Names=c("Slider 1", "Slider 2", "Slider 3"),
               Values=myvals)
  })
})

Ключ здесь renderUI функция, которая ищет input$slider1 значение, чтобы ограничить значение slider2 (и поэтому slider3)

ui.R

library(shiny)

# Define UI for application
shinyUI(pageWithSidebar(

  # Application title
  headerPanel("Sliders should sum to 100!"),

  # Sidebar with sliders whos sum should be constrained to be 100
  sidebarPanel(
    sliderInput("slider1", "Slider 1: ", min = 0, max = 100, value = 0, step=1),
    uiOutput("slider2")
  ),

  # Create table output
  mainPanel(
    tableOutput("restable")
  )
))

Как видно (если вы косите) на прикрепленном изображении, slider2 ограничено до 0-35, один раз slider1 был установлен на 65.

Answer 2

Все эти мысли полезны, но мой инстинкт состоит в том, чтобы использовать tagList. Алгоритм работает следующим образом:

1. Сохраните все ползунки в списке тегов
2. Пусть n будет длиной списка тегов
3. Заполнить все виджеты слайдера из списка тегов
4. Если виджет слайдера изменяется (на сервере) под observe {...} , определите, какой виджет.
5. Пусть x будет 100 минус значение виджета, измененного из списка тегов (3) и (4).
6. Установите для свойства value остальных ползунков в списке тегов значение x/(n-1).

Надеюсь это поможет. Обновим код как можно скорее.

Answer 3

Я наткнулся на эту тему, пытаясь реализовать то же самое. Я разработал решение, основанное на псевдокоде, изложенном bmc выше, и решил поделиться им.

использую три разных вызовы, чтобы принудительно настроить два других ползунка при изменении одного из ползунков. При (автоматической) настройке двух других ползунков я задаю их соотношение таким же, как до события, при этом гарантируя, что они суммируются с остатком, оставшимся после того, как пользователь вручную настроит один ползунок.

Это продемонстрировано ниже с использованием интерактивного документа Rmarkdown, но это также должно быть перенесено и в стандартные блестящие приложения.

      ---
title: "Force Sliders to Sum to 100"
output: html_document
runtime: shiny
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)
library(shiny)
```

```{r inputs}
sliderInput("s1", "Slider 1", min = 0, max = 100, value = 50, step = 0.1)
sliderInput("s2", "Slider 2", min = 0, max = 100, value = 25, step = 0.1)
sliderInput("s3", "Slider 3", min = 0, max = 100, value = 25, step = 0.1)

# when s1 changes, adjust other two to fill the remainder with the same ratio as they currently have
observeEvent(input$s1, {
  remaining <- 100 - input$s1
  p_remaining_s2 <- input$s2/(input$s2 + input$s3)
  p_remaining_s3 <- input$s3/(input$s2 + input$s3)
  updateSliderInput(inputId = "s2", value = remaining * p_remaining_s2)
  updateSliderInput(inputId = "s3", value = remaining * p_remaining_s3)
})

# when s2 changes, do the same
observeEvent(input$s2, {
  remaining <- 100 - input$s2
  p_remaining_s1 <- input$s1/(input$s1 + input$s3)
  p_remaining_s3 <- input$s3/(input$s1 + input$s3)
  updateSliderInput(inputId = "s1", value = remaining * p_remaining_s1)
  updateSliderInput(inputId = "s3", value = remaining * p_remaining_s3)
})

# when s3 changes, do the same
observeEvent(input$s3, {
  remaining <- 100 - input$s3
  p_remaining_s1 <- input$s1/(input$s1 + input$s2)
  p_remaining_s2 <- input$s2/(input$s1 + input$s2)
  updateSliderInput(inputId = "s1", value = remaining * p_remaining_s1)
  updateSliderInput(inputId = "s2", value = remaining * p_remaining_s2)
})
```

```{r outputs}
renderTable({
  data.frame(
    Slider = c("1", "2", "3", "sum"), 
    Value = c(input$s1, input$s2, input$s3, input$s1 + input$s2 + input$s3)
  )
})
```