问题
Friends, I would like you to help me with the following question: The executable code below generates clusters and shows in a table which industries are part of each cluster. However, an alert made by confirmSweetAlert is being displayed when running Shiny to show which industry is being excluded from generating the clusters. ConfirmSweetAlert generates two buttons, the first is "Confirm" and the second is "Not yet". However, I would like to give functionality to "Confirm" that when you press, you no longer display the message at all times from which industry you will be excluded, because every time you change the clusters through the Slider, the same message appears through confirmSweetAlert. The "Not Yet" button functionality, I will develop later, but could you help me with the "Confirm" button, please?
library(shiny)
library(ggplot2)
library(rdist)
library(geosphere)
library(kableExtra)
library(tidyverse)
library(DT)
library(shinyWidgets)
function.cl<-function(df,k){
#database df
df<-structure(list(Industries = c(1,2,3,4,5,6,7),
Latitude = c(-23.8, -23.8, -23.9, -23.9, -23.9,-23.8,-23.8),
Longitude = c(-49.8, -49.8, -49.5, -49.8, -49.8,-49.8,-49.8),
Waste = c(526, 350, 526, 469, 285, 433, 456)), class = "data.frame", row.names = c(NA, -7L))
# Exclude long-distance industries
coordinates<-subset(df,select=c("Latitude","Longitude"))
d<-distm(coordinates[,2:1])
diag(d)<-1000000
min_distance<-as.matrix(apply(d,MARGIN=2,FUN=min))
limite<-mean(min_distance)+sd(min_distance)
search_vec <- function(mat, vec, dim = 1, tol = 1e-7, fun = all)
which(apply(mat, dim, function(x) fun((x - vec) > tol)))
ind_exclude<-search_vec(min_distance,limite,fun=any)
if(is_empty(ind_exclude)==FALSE){
for (i in 1:dim(as.array(ind_exclude))){
df<-subset(df,Industries!=ind_exclude[i])}}
#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
#Location
location<-matrix(nrow=k,ncol=2)
for(i in 1:k){
location[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
location<-cbind(location,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),location[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","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","cluster")
#Output table
data_table <- Reduce(merge, list(df, coverage, sum_waste))
data_table <- data_table[order(data_table$cluster, as.numeric(data_table$Industries)),]
data_table_1 <- aggregate(. ~ cluster + Coverage + Potential, data_table[,c(1,7,6,2)], toString)
return(list(
"IND" = ind_exclude,
"Data" = data_table_1
))
}
ui <- fluidPage(
titlePanel("Clustering "),
sidebarLayout(
sidebarPanel(
sliderInput("Slider", h3("Number of clusters"),
min = 2, max = 6, value = 4),
),
mainPanel(
DTOutput("tabela")
)))
server <- function(input, output, session) {
Modelcl<-reactive(function.cl(df,input$Slider))
output$ind <- renderTable({
IND <- ((Modelcl()[[1]]))
})
observe({
if(is_empty(Modelcl()[[1]])==FALSE){
confirmSweetAlert(
session = session,
inputId = "myconfirmation",
btn_labels = c("Confirm", "Not yet"),
text = tags$div(h5("The industry below is being excluded from clustering:"),
paste(Modelcl()[[1]], collapse = ", ")),
type="info"
)
}})
output$tabela <- renderDataTable({
data_table_1 <- req(Modelcl())[[2]]
x <- datatable(data_table_1[order(data_table_1$cluster), c(1, 4, 2, 3)],
options = list(
paging =TRUE,
pageLength = 5
)
)
return(x)
})
}
shinyApp(ui = ui, server = server)
Thank you very much!
回答1:
You can create a reactive flag (confirmed_status) that will change when you confirm via the sweetalert. It will default to false, and an observeEvent can be triggered by the result of your alert to change to true when confirmed button is pressed. Then, if you don't want to show the dialog box again after confirming, you can check confirmed_status in your observe before displaying it again. Let me know if this is the behavior you were looking for.
server <- function(input, output, session) {
confirmed_status <- reactiveVal(FALSE)
Modelcl<-reactive(function.cl(df,input$Slider))
output$ind <- renderTable({
IND <- ((Modelcl()[[1]]))
})
observe({
if(is_empty(Modelcl()[[1]])==FALSE && isFALSE(confirmed_status())){
confirmSweetAlert(
session = session,
inputId = "myconfirmation",
btn_labels = c("Confirm", "Not yet"),
text = tags$div(h5("The industry below is being excluded from clustering:"),
paste(Modelcl()[[1]], collapse = ", ")),
type="info"
)
}})
observeEvent(input$myconfirmation, {
if (isFALSE(input$myconfirmation)) {
confirmed_status(TRUE)
} else {
# Add here more for the "Not yet" condition
}
})
output$tabela <- renderDataTable({
data_table_1 <- req(Modelcl())[[2]]
x <- datatable(data_table_1[order(data_table_1$cluster), c(1, 4, 2, 3)],
options = list(
paging =TRUE,
pageLength = 5
)
)
return(x)
})
}
来源：https://stackoverflow.com/questions/61988758/functionality-for-the-confirm-button-that-confirmsweetalert-generates-in-shiny