In sync sliderInput and textInput - r

Question

Consider the following shiny app:
library('shiny')
# User Interface/UI
ui <- fluidPage(
titlePanel(
'Slider and Text input update'
), # titlePanel
mainPanel(
# Slider input
sliderInput(
inputId = 'sliderValue',
label = 'Slider value',
min = 0,
max = 1000,
value = 500
), # sliderInput
# Text input
textInput(
inputId = 'textValue',
label = NULL
) # textInput
) # mainPanel
) # fluidPage
# Server logic
server <- function(input, output, session) {
observe({
# Update vertical depth text box with value of slider
updateTextInput(
session = session,
inputId = 'textValue',
value = input$sliderValue
) # updateTextInput
# updateSliderInput(
# session = session,
# inputId = 'sliderValue',
# value = input$textValue
# ) # updateSliderInput
}) # observe
}
# Run the application
shinyApp(ui = ui, server = server)
It allows the user to change the values of a slider (sliderInput), which updates the text in the text box (textInput):
I want these to work in sync. So, instead of just the above slider > text box interaction, I want the opposite as well: text box > slider.
If you uncomment the updateSliderInput component, the two widgets compete against one another; an update of the one leads to an update of the other which leads to an update of the other, ...
How can this be avoided while still making the two be in sync?

Answer 1

One way to do it would be using observeEvent for each input and adding a condition if(as.numeric(input$textValue) != input$sliderValue). This will help you from the inputs calling each others update functions recursively. Then your app would look something like this:
library('shiny')
# User Interface/UI
ui <- fluidPage(
titlePanel(
'Slider and Text input update'
), # titlePanel
mainPanel(
# Slider input
sliderInput(
inputId = 'sliderValue',
label = 'Slider value',
min = 0,
max = 1000,
value = 500
), # sliderInput
# Text input
textInput(
inputId = 'textValue',
value = 500,
label = NULL
) # textInput
) # mainPanel
) # fluidPage
# Server logic
server <- function(input, output, session)
{
observeEvent(input$textValue,{
if(as.numeric(input$textValue) != input$sliderValue)
{
updateSliderInput(
session = session,
inputId = 'sliderValue',
value = input$textValue
) # updateSliderInput
}#if
})
observeEvent(input$sliderValue,{
if(as.numeric(input$textValue) != input$sliderValue)
{
updateTextInput(
session = session,
inputId = 'textValue',
value = input$sliderValue
) # updateTextInput
}#if
})
}
# Run the application
shinyApp(ui = ui, server = server)

Answer 2

The above code can be modified a bit to fix the issue of application getting closed when the input in the test box is empty
library('shiny')
ui <- fluidPage(titlePanel('Slider and Text input update'),
mainPanel(
sliderInput(
inputId = 'sliderValue',
label = 'Slider value',
min = 0,
max = 1000,
value = 500
),
textInput(
inputId = 'textValue',
value = 500,
label = NULL
)
))
# Server logic
server <- function(input, output, session)
{
observeEvent(input$textValue, {
print(input$textValue)
if ((as.numeric(input$textValue) != input$sliderValue) &
input$textValue != "" & input$sliderValue != "")
{
updateSliderInput(
session = session,
inputId = 'sliderValue',
value = input$textValue
)
} else {
if (input$textValue == "") {
updateSliderInput(session = session,
inputId = 'sliderValue',
value = 0)
}
}
})
observeEvent(input$sliderValue, {
if ((as.numeric(input$textValue) != input$sliderValue) &
input$sliderValue != "" & input$textValue != "")
{
updateTextInput(
session = session,
inputId = 'textValue',
value = input$sliderValue
)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)

Answer 3

I am a little late to this discussion, but I have recently been having similar trouble. Only I was wanting to sync numeric inputs with slider values... Using the latest example posted here, I still had issues with infinite loops. I think that I finally found a solution to the infinite loops. Following on from Tinku's answer, I add a time delay in the part of the code where the numeric input is updated by the slider value. I believe that the slider value updates slightly slower than the numeric input, so if changing the numeric input too fast, the lag can become too much and looping occurs. I add the code below…. I set the lag to 0.3 s, which is good enough to avoid the infinite loops on my computer….
library('shiny')
library('shinyvalidate')
ui <- fluidPage(titlePanel('Slider and numeric input'),
mainPanel(
sliderInput(
inputId = 'sliderValue',
label = 'Slider value',
min = 0,
max = 1000,
value = 500,
step = 5,
),
numericInput(
inputId = 'numericValue',
min = 0,
max = 1000,
value = 500,
step = 5,
label = "Numeric value"
),
actionButton("Set", "Apply"),
textOutput("value") #Paste the 'Set' value
))
# Server logic
server <- function(input, output, session)
{
v <- reactiveValues()
#Register the current time
v$now = Sys.time()
v$when = Sys.time()
#The saved numeric value to use in further functions/plots
v$num = 500 # Initial value
observeEvent(input$numericValue, {
v$when = Sys.time()
req(input$numericValue)
if (input$numericValue != input$sliderValue)
{
updateSliderInput(
session = session,
inputId = 'sliderValue',
value = input$numericValue
)
}
})
observeEvent(input$sliderValue, {
v$now = Sys.time()
req(input$numericValue)
if (input$numericValue != input$sliderValue & v$now - v$when > 0.3) #I found 0.3 s a good lag to give (I believe that the slidervalue updates ~0.25 s slower than numericinput)
{
updateNumericInput(
session = session,
inputId = 'numericValue',
value = input$sliderValue
)
}
})
#Only update the reactive value (v$num) if within the specified numeric range....
isolate(
observeEvent(input$Set, {
i <- InputValidator$new()
i$add_rule("numericValue", sv_required(message = "Number must be provided"))
i$add_rule("numericValue", sv_gte(0))
i$add_rule("numericValue", sv_lte(1000))
i$enable()
req(i$is_valid())
v$num <- input$numericValue #Use this reactive value in further functions/plots.....
output$value <- renderText({paste("The syncronised value is:", v$num)})
})
)
}
# Run the application
shinyApp(ui = ui, server = server)