在闪亮中将 selectInput 与 sliderInput 链接起来
Posted
技术标签:
【中文标题】在闪亮中将 selectInput 与 sliderInput 链接起来【英文标题】：Link selectInput with sliderInput in shiny 【发布时间】：2020-08-16 23:10:13 【问题描述】：朋友们，我希望我的 selectInput 与出现在我的输出表中的簇数相关联。 换句话说，它似乎分为 5 个集群。在 selectInput 我希望它显示如下：
选择集群
1
2
3
4
5
也就是说，我的 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)
非常感谢各位朋友！
新更新
我插入了 updateSelectiInput 函数（代码如下），这样我就设法放置了相应数量的集群。但是，我想以列表的形式保留它，而不是像我在开头描述的那样是 5：
observeEvent(input$Slider,
updateSelectInput(session,'select',
choices=unique(df[df==input$Slider]))
)
【问题讨论】：
您的示例是可重现的，但不是最小的。虽然不是很长，但没必要一开始就展示你所有的功能。我建议您缩短示例（例如使用mtcars 之类的数据）。也就是说，我认为您正在寻找 update* 函数（在您的情况下为 updateSelectInput，请参见 here 例如）
感谢朋友的回复。我将在接下来的问题中进行调整。如果我在 updateSelectInput 上是对的，您只能在上面看到我的更新。我只留下最有趣的部分来更新 selectInput。
【参考方案1】：
你真的很接近更新表达式。您只需要：
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)
)
编辑
要使observeEvent（或eventReactive）对多个输入做出反应，请将输入或反应包裹在c() 中：
observeEvent(c(input$SLIDER, input$FILTER),
updateSelectInput(session,'select',
choices=unique(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)
)
一般来说，使用update*Input 函数，您只能更新现有的小部件，不能删除它。但是如果集群数 = 1，那么您根本不需要选择输入。使用renderUI，如果条件需要，您可以使用空的 html 容器 (div()) 来“隐藏”selectInput：
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()
)
【讨论】：
非常感谢 Teofil。有效。还有一个快速的问题，上面示例中的 observeEvent 完全取决于我的 Slider。但是如果碰巧它也依赖于filter1，filter2，例如observeEvent会怎么样？ 非常感谢您的解释 嗨 Teofil，我兄弟的这个问题有什么想法：***.com/questions/63092033/… 你好 Teofil，你好吗？请您看一下这个问题：***.com/questions/65207873/… 谢谢！以上是关于在闪亮中将 selectInput 与 sliderInput 链接起来的主要内容，如果未能解决你的问题，请参考以下文章
闪亮的 selectInput 'Select All' 层次结构
如何通过闪亮的 selectInput 动态选择数据帧的子集？
在闪亮的 R 中使用 selectInput 来选择和过滤行，而不是选择列