Новый функционал для кнопки confirmSweetAlert в Shiny - PullRequest
0 голосов
/ 25 мая 2020

Мне нужна помощь по следующему вопросу: исполняемый код ниже генерирует кластеры и показывает в таблице, какие отрасли являются частью каждого кластера. Кроме того, при запуске Shiny отображается предупреждение, созданное с помощью confirmSweetAlert, чтобы показать, какая отрасль исключена из создания кластеров. Если вы нажмете кнопку «Подтвердить», таблица вывода будет сгенерирована с исключением отрасли 5 для этого примера. Однако я хотел бы добавить функциональность в кнопку «Еще нет», чтобы при нажатии указанное свойство не исключалось, то есть отрасль 5 для этого примера. Вы можете помочь мне? Исполняемый код ниже.

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)

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...