R 链接选择带滑块的输入输入输入

朋友们，我希望我的selectInput链接到我的输出表中显示的集群数量。 换言之，它似乎分为5个簇。在selectInput中，我希望它显示如下：

选择群集

一,

二,

三,

四,

五,

也就是说，我的selectinput将取决于我的sliderInput。我该怎么做？我的可执行代码如下：

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)

---

您非常熟悉更新表达式。您只需要：

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

另一种方法是使用

uiOutput/renderUI

。在

ui

中，我们可以放置一个占位符，而不是创建一个空的selectInput：

uiOutput("select_clusters")

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

然后在服务器中，我们填充此占位符：

uiOutput("select_clusters")

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

但是，如果您需要这样做，我认为使用

renderUI

方法更有意义，并提供了灵活性。这可能看起来像：

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)

})

---

您非常熟悉更新表达式。您只需要：

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

另一种方法是使用

uiOutput/renderUI

。在

ui

中，我们可以放置一个占位符，而不是创建一个空的selectInput：

uiOutput("select_clusters")

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

然后在服务器中，我们填充此占位符：

uiOutput("select_clusters")

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

但是，如果您需要这样做，我认为使用

renderUI

方法更有意义，并提供了灵活性。这可能看起来像：

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)

})

---

您的示例是可复制的，但不是最小的。虽然它不是很长，但没有必要在开始时显示所有函数。我建议您缩短示例（例如使用

mtcars

等数据）。也就是说，我想您正在寻找

update*

函数（在您的例子中，请参见

updateSelectInput

），谢谢您的回复。我将在接下来的问题中进行调整。如果我在updateSelectInput上正确的话，您只能在上面看到我的更新。我只留下最有趣的部分来更新selectInput。您的示例是可复制的，但不是最小的。虽然它不是很长，但没有必要在开始时显示所有函数。我建议您缩短示例（例如使用

mtcars

等数据）。也就是说，我想您正在寻找

update*

函数（在您的例子中，请参见

updateSelectInput

），谢谢您的回复。我将在接下来的问题中进行调整。如果我在updateSelectInput上正确的话，您只能在上面看到我的更新。我只留下最有趣的部分来更新selectInput。非常感谢Teofil。成功了。还有一个简单的问题，上面例子中我的观察结果完全取决于我的滑块。但是如果碰巧它也依赖于filter1，filter2，例如，观察者会是怎样的？非常感谢你的解释Hi Teofil，对我兄弟的这个问题有什么想法吗：你好Teofil，你好吗？请你看看这个问题：谢谢！非常感谢泰奥菲尔。成功了。还有一个简单的问题，上面例子中我的观察结果完全取决于我的滑块。但是如果碰巧它也依赖于filter1，filter2，例如，观察者会是怎样的？非常感谢你的解释Hi Teofil，对我兄弟的这个问题有什么想法吗：你好Teofil，你好吗？请你看看这个问题：谢谢！