New functionality for confirmSweetAlert button in Shiny

[Jovani]

I would like help with the following question: The executable code below generates clusters and shows in a table which industries are part of each cluster. In addition, an alert made by confirmSweetAlert is being displayed when running Shiny to show which industry is being excluded from generating the clusters. If you press the "Confirm" button, the output table is generated with industry 5 being excluded for this example. However, I would like to insert a functionality in the "Not Yet" button, that when pressed, the designated property is not excluded, that is, industry 5 for this example. Can you help me? The executable code is below.

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.8, -49.8, -49.5,-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
  k=4
  coordinates<-df[c("Latitude","Longitude")]
  d<-as.dist(distm(coordinates[,2:1]))
  fit.average<-hclust(d,method="average") 
  clusters<-cutree(fit.average, k) 
  nclusters<-matrix(table(clusters))  
  df$cluster <- clusters 
  coordinates$cluster<-clusters
  
  #Location
  location<-matrix(nrow=k,ncol=2)
  location=matrix(c(-23.8, -23.9, -23.9, -23.8, -49.8, -49.8, -49.8, -49.8),nrow=k,ncol=2)
  location<-cbind(location,matrix(c(1:k),ncol=1)) 
   
  #Coverage
  coverage=matrix(c(0,0,0,0),nrow=k,ncol=1)
  coverage<-cbind(coverage,matrix(c(1:k),ncol=1))
  colnames(coverage)<-c("Coverage","cluster")
  
  #Sum of Waste from clusters
  sum_waste=matrix(c(13809,469,285,456),nrow=k,ncol=1)
  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(
      
      actionButton("reset", "Reset"),
    ),
    
    mainPanel(
      DTOutput("tabela")
    )))

server <- function(input, output, session) {
  
  
  confirmed_status <- reactiveVal(FALSE)
  
  Modelcl<-reactive(function.cl(df))
  
  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)
    } 
  })
  
  output$tabela <- renderDataTable({
    req(confirmed_status())
    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)
  })
  
  observeEvent(input$reset, {
   confirmed_status(FALSE)
  })
}

shinyApp(ui = ui, server = server)

[hadley]

You're most likely to get helpful if you can make your code smaller, focussing on the precise problem you are experiencing. You can see some advice for that in https://mastering-shiny.org/action-workflow.html#making-a-minimal-reprex

[Jovani]

Thanks, I adjusted the code above and tried to make it as "friendly" as possible.

[daattali]

Cross-posted on stackoveflow: https://stackoverflow.com/questions/62008422/new-functionality-for-confirmsweetalert-button-in-shiny

[hadley]

@jovani your example uses 8 packages. Do you truly believe all 8 packages are related to the problem at hand?

[hadley]

I made a much simpler reprex for you:

library(shiny)
library(geosphere)
library(shinyWidgets)

# 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.8, -49.8, -49.5, -49.8, -49.8),
  Waste = c(526, 350, 526, 469, 285, 433, 456)
), class = "data.frame", row.names = c(NA, -7L))

function.cl <- function(df, k = 4) {
  # 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)

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

  # Location
  location <- matrix(nrow = k, ncol = 2)
  location <- matrix(c(-23.8, -23.9, -23.9, -23.8, -49.8, -49.8, -49.8, -49.8), nrow = k, ncol = 2)
  location <- cbind(location, matrix(c(1:k), ncol = 1))

  # Coverage
  coverage <- matrix(c(0, 0, 0, 0), nrow = k, ncol = 1)
  coverage <- cbind(coverage, matrix(c(1:k), ncol = 1))
  colnames(coverage) <- c("Coverage", "cluster")

  # Sum of Waste from clusters
  sum_waste <- matrix(c(13809, 469, 285, 456), nrow = k, ncol = 1)
  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)

  list(
    excluded = ind_exclude,
    data = data_table_1
  )
}

ui <- fluidPage(
  selectInput("exclude", "Exclude industries", c("Yes", "No")),
  textOutput("excluded"),
  tableOutput("tabela")
)

server <- function(input, output, session) {
  clustering <- function.cl(df)
  output$excluded <- renderPrint(clustering$excluded)

  cluster_data <- reactive({
    data <- clustering$data
    if (input$exclude == "Yes") {
      industries <- strsplit(data$Industries, ", ")
      drop <- sapply(industries, function(x) clustering$excluded %in% as.numeric(x))
      data <- data[!drop, ]
    }
    data[order(data$cluster), c(1, 4, 2, 3)]
  })

  output$tabela <- renderTable(cluster_data())
}

shinyApp(ui, server)

The problem turned out to be with your function.cl() — it didn't offer any way to choose to not exclude an industry, so obviously without that there's nothing your app can do. I hacked in a simple fix, and tied it to a selectInput() so you could see the basic idea.

I also made a short movie about the process. I'll publish that tomorrow.

[Jovani]

Hadley, thanks so much for the tips. I will wait.

[hadley]

[Jovani]

I was very happy that you did the minimal reprex for my example. I watched the video, it was really good. Thanks for the lessons, I understood better what you meant now, in relation to minimizing the code as much as possible to make a reproducible example. I will check your code and try to adjust mine. Thank you again Hadley.