Link selectInput with sliderInput in shiny

Question

Friends, I would like my selectInput to be linked to the number of clusters that appear in my output table. In other words, it appears divided into 5 clusters. In selectInput I would like it to show as follows:

Select the cluster

1

2

3

4

5

That is, my selectinput will depend on my sliderInput. How can I do this? My executable code is below:

library(shiny)
library(ggplot2)
library(rdist)
library(geosphere)
library(kableExtra)
library(readxl)
library(tidyverse)
library(DT)

#database
df<-structure(list(Properties = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35), Latitude = c(-23.8, -23.8, -23.9, -23.9, -23.9,  -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, -23.9, 
                                                                                                                                                 + -23.9, -23.9, -23.9, -23.9, -23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9,-23.9), Longitude = c(-49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.6, -49.7, 
                                                                                                                                                                                                                                                                                                     + -49.7, -49.7, -49.7, -49.7, -49.6, -49.6, -49.6, -49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6,-49.6), Waste = c(526, 350, 526, 469, 285, 175, 175, 350, 350, 175, 350, 175, 175, 364, 
                                                                                                                                                                                                                                                                                                                                                                                                                                                                          + 175, 175, 350, 45.5, 54.6,350,350,350,350,350,350,350,350,350,350,350,350,350,350,350,350)), class = "data.frame", row.names = c(NA, -35L))

function.clustering<-function(df,k,Filter1,Filter2){

  if (Filter1==2){
    Q1<-matrix(quantile(df$Waste, probs = 0.25)) 
    Q3<-matrix(quantile(df$Waste, probs = 0.75))
    L<-Q1-1.5*(Q3-Q1)
    S<-Q3+1.5*(Q3-Q1)
    df_1<-subset(df,Waste>L[1]) 
    df<-subset(df_1,Waste<S[1])
  }

  #cluster
  coordinates<-df[c("Latitude","Longitude")]
  d<-as.dist(distm(coordinates[,2:1]))
  fit.average<-hclust(d,method="average") 


  #Number of clusters
  clusters<-cutree(fit.average, k) 
  nclusters<-matrix(table(clusters))  
  df$cluster <- clusters 

  #Localization
  center_mass<-matrix(nrow=k,ncol=2)
  for(i in 1:k){
    center_mass[i,]<-c(weighted.mean(subset(df,cluster==i)$Latitude,subset(df,cluster==i)$Waste),
                       weighted.mean(subset(df,cluster==i)$Longitude,subset(df,cluster==i)$Waste))}
  coordinates$cluster<-clusters 
  center_mass<-cbind(center_mass,matrix(c(1:k),ncol=1)) 

  #Coverage
  coverage<-matrix(nrow=k,ncol=1)
  for(i in 1:k){
    aux_dist<-distm(rbind(subset(coordinates,cluster==i),center_mass[i,])[,2:1])
    coverage[i,]<-max(aux_dist[nclusters[i,1]+1,])}
  coverage<-cbind(coverage,matrix(c(1:k),ncol=1))
  colnames(coverage)<-c("Coverage_meters","cluster")

  #Sum of Waste from clusters
  sum_waste<-matrix(nrow=k,ncol=1)
  for(i in 1:k){
    sum_waste[i,]<-sum(subset(df,cluster==i)["Waste"])
  }
  sum_waste<-cbind(sum_waste,matrix(c(1:k),ncol=1))
  colnames(sum_waste)<-c("Potential_Waste_m3","cluster")

  #Output table
  data_table <- Reduce(merge, list(df, coverage, sum_waste))
  data_table <- data_table[order(data_table$cluster, as.numeric(data_table$Properties)),]
  data_table_1 <- aggregate(. ~ cluster + Coverage_meters + Potential_Waste_m3, data_table[,c(1,7,6,2)], toString)

  #Scatter Plot
  suppressPackageStartupMessages(library(ggplot2))
  df1<-as.data.frame(center_mass)
  colnames(df1) <-c("Latitude", "Longitude", "cluster")
  g<-ggplot(data=df,  aes(x=Longitude, y=Latitude,  color=factor(clusters))) + geom_point(aes(x=Longitude, y=Latitude), size = 4)
  Centro_View<- g +  geom_text(data=df, mapping=aes(x=eval(Longitude), y=eval(Latitude), label=Waste), size=3, hjust=-0.1)+ geom_point(data=df1, mapping=aes(Longitude, Latitude), color= "green", size=4) + geom_text(data=df1, mapping = aes(x=Longitude, y=Latitude, label = 1:k), color = "black", size = 4)
  plotGD<-print(Centro_View + ggtitle("Scatter Plot") + theme(plot.title = element_text(hjust = 0.5)))

  return(list(
    "Data" = data_table_1,
    "Plot" = plotGD,
    "Coverage" = coverage
  ))
}

ui <- bootstrapPage(
  navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
             "Clustering", 

             tabPanel("General Solution",

                      sidebarLayout(
                        sidebarPanel(
                          radioButtons("filtro1", h3("Select properties"),
                                       choices = list("All properties" = 1, 
                                                      "Exclude properties" = 2),
                                       selected = 1),

                          radioButtons("filtro2", h3("Coverage"),
                                       choices = list("Limite coverage" = 1, 
                                                      "No limite coverage" = 2
                                       ),selected = 1),
                          radioButtons("gasoduto", h3("Preference for the location"),
                                       choices = list("big production" = 1, 
                                                      "small production"= 2
                                       ),selected = 1),

                          tags$hr(),
                          tags$b(h3("Satisfied?")),
                          radioButtons("satisfaction","", choices = list("Yes" = 1,"No " = 2),selected = 1),
                          tags$b(h5("(a) Choose other filters")),
                          tags$b(h5("(b) Choose clusters")),  
                          sliderInput("Slider", h5(""),
                                      min = 2, max = 8, value = 5),
                          tags$hr(),
                          actionButton("reset", "Clean")
                        ),

                        mainPanel(
                          tabsetPanel(      
                            tabPanel("Solution", DTOutput("tabela"))))

                      )),

             tabPanel("Route and distance",
                      sidebarLayout(
                        sidebarPanel(
                          selectInput("select", label = h3("Select the cluster"),"")
                        ),
                        mainPanel(
                          tabsetPanel(
                          tabPanel("Distance", plotOutput(""))))
                      ))))

server <- function(input, output) {

  f1<-renderText({input$filter1})
  f2<-renderText({input$filter2})


  Modelclustering<-reactive(function.clustering(df,input$Slider,1,1))


  output$tabela <- renderDataTable({
    data_table_1 <- req(Modelclustering())[[1]]
    x <- datatable(data_table_1[order(data_table_1$cluster),c(1,4,2,3)],
                   options = list(columnDefs = list(list(className = 'dt-center', targets = 0:3)), 
                                  paging =TRUE,searching = FALSE,
                                  pageLength =  10,lenghtMenu=c(5,10,15,20),scrollx=T
                   ), rownames = FALSE)%>% formatRound(c(3:4), 2,mark = ",")%>%
      formatStyle(columns = c(3:4), 'text-align' = 'center')
    return(x)
  })

  output$ScatterPlot <- renderPlot({
    Modelclustering()[[2]]
  })

}

shinyApp(ui = ui, server = server)

Thank you very much friends!

NEW UPDATE

I inserted the updateSelectiInput function (code bellow), and that way I managed to put the corresponding number of clusters. However, I would like to leave it in the form of list, instead of being 5, as I described at the beginning:

observeEvent(input$Slider,{
  updateSelectInput(session,'select',
                    choices=unique(df[df==input$Slider]))
})

Your example is reproducible but not minimal. Though it is not very long, there is no need to show all your functions at the beginning. I suggest you shorten your example (using data like `mtcars` for example). That said, I think you are looking for the `update*` functions (in your case `updateSelectInput`, see [here](https://shiny.rstudio.com/reference/shiny/1.2.0/updateSelectInput.html) for example) — bretauv, May 02 '20 at 15:42
Thanks for the reply friend. I will adjust in the next questions. You could only see my update above, if I'm right on updateSelectInput. I left only the most interesting parts to update selectInput. — , May 02 '20 at 16:18

teofil · Accepted Answer · 2020-05-03T15:24:06.090

You were really close with the update expression. All you need there is:

  observeEvent(input$Slider,{
    updateSelectInput(session,'select',
                      choices=unique(1:input$Slider))
  })

Another approach is to use uiOutput/renderUI. In the ui, instead of creating an empty selectInput, we can put a placeholder:

uiOutput("select_clusters")

Then in the server, we populate this placeholder:

output$select_clusters <- renderUI({
  selectInput("select", label = h3("Select the cluster"), choices = 1:input$Slider)
})

Edit

To make an observeEvent (or eventReactive) react to multiple inputs, wrap the inputs or reactives in c():

observeEvent(c(input$SLIDER, input$FILTER),{
    updateSelectInput(session,'select',
                      choices=unique(1:input$Slider))
  })

But if you need to do that, I think it makes more sense, and gives flexibility, to go with the renderUI approach. This might look something like:

output$select_clusters <- renderUI({
   req(input$slider)
   req(input$filter)

   df2 <- df[df$something %in% input$filter, ]

  selectInput("select", 
              label = h3("Select the cluster"), 
              choices = df2$something)

})

In general, with the update*Input function, you can only update an existing widget, you can't remove it. But if the number of clusters = 1, then you do not need a select input at all. With renderUI you can use an empty HTML container (div()) to 'hide' the selectInput if the conditions require it:

what_to_do <- reactive({
   req(input$Slider)
   if (input$Slider == 1) {
      x <- div() 
   } else {
      x <- selectInput("select", 
                       label = h3("Select the cluster"), 
                       choices = 1:input$Slider)
   }

return(x)
})

output$select_clusters <- renderUI({
   what_to_do()
})

Thank you very much Teofil. It worked. One more quick question, my observeEvent in the example above depends exclusively on my Slider. But if by chance it also depended on filter1, filter2, for example, how would the observeEvent be? — , May 03 '20 at 13:39
Hi Teofil, any idea for this question of my brother: https://stackoverflow.com/questions/63092033/issue-involving-map-generation-in-shiny — , Jul 25 '20 at 20:58
Hello Teofil, how are you? Please, could you take a look at this question: https://stackoverflow.com/questions/65207873/evaluation-metrics-for-hierarchical-cluster-in-r Thanks! — , Dec 09 '20 at 00:43

Link selectInput with sliderInput in shiny

NEW UPDATE

1 Answers1

Linked