Обновить кнопку действия в кадре данных - PullRequest
Новая
       19

Обновить кнопку действия в кадре данных

0 голосов
/ 26 июня 2019

В моем фрейме данных у меня есть кнопка действия, и я хотел бы, чтобы она изменила цвет, метку, но также увеличила значение "да" в моей базе данных, которое я могу загрузить после. 

shinyInput <- function(FUN, len, id, ...) {
    inputs <- character(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(FUN(paste0(id, i), ...))
    }
    inputs
    }

    df <- reactiveValues(data = data.frame(
    validation = shinyInput(actionButton, 1, id = "button_",
                            label = "Check",
                            style = "color: white; background-color: #222D32",
                            onclick = 'Shiny.onInputChange(\"select_button\", this.id)')
  ))

А для кнопки обновления 

observeEvent(input$select_button, {
    selectedRow <- as.character("yes")
    updateSelectInput(session, inputId = "f_check", choices = c("All", selectedRow))
    updateActionButton(session, inputId = "button_", label = "Yes")
  })

Вот весь код. 

library(DT)
library(readODS)
library(dplyr)
library(shinydashboard)
library(shinyWidgets)
library(shiny)
library(shinyjs)

base <- read_ods("base.ods")

createLink <- function(val) {
  sprintf('<a href= "%s" target="_blank" class="btn btn-primary">Fiches données</a>',val)
}

ui <- dashboardPage(
  dashboardHeader(title ="MobiDiag"),

  dashboardSidebar(

    tags$head(tags$style(HTML('.logo {
                                background-color: #8eb06a !important;
                                }
                                .navbar {
                                background-color: #a7cd7f !important;
                                }'
    ))),

    h4(strong("Critères de sélection"), align="center"),

    prettyCheckboxGroup("territoire", "Territoire",
                        thick = TRUE,
                        shape = "curve",
                        animation = "pulse",
                        choices = c("Communes centrales" = "Communes.centrales", "Communes pôles urbain" = "Communes.poles.urbain", "Communes secondaires" = "Communes.secondaires", "Communes rurales" = "Communes.rurales", "Ensemble territoire" = "Ensemble.territoire", "Périmètre élargit" = "Perimetre.elargit")),
    prettyCheckboxGroup("doc", "Documents de planification existants",
                        thick = TRUE,
                        shape = "curve",
                        animation = "pulse",
                        choices = c("Volet mobilité SCOT" = "Volet.mobilite.SCOT", "PDU obligatoire" = "PDU.obligatoire", "PGD volontaire" = "PGD.volontaire", "PLUI","Plan de mobilité rurale" = "Plan.mobilite.rurale", "PCAET", "PLUIHD")),

    actionButton("submit", ("Extraction")),

  ),

  dashboardBody(
    fluidPage(

      useShinyjs(),
      inlineCSS(list(.green = "background: #A7CD7F")),
      actionButton(inputId = "button_", label = "test"),

      mainPanel(width = 12,
                tabsetPanel(

                  tabPanel("Extraction",
                           fluidRow(
                             br(),

                             column(width=2,
                                    selectInput("f_st",
                                                "Sous-thèmes :",
                                                "")
                             ),
                             column(width=2,
                                    selectInput("f_don",
                                                "Données :",
                                                "")
                             ),
                             column(width=2,
                                    selectInput("f_check",
                                                "Validation :",
                                                "")
                             ),
                             column(width=2,
                                    selectInput("f_doc",
                                                "Documents de planification :",
                                                "")
                             ),
                             column(width=12, DT::dataTableOutput("Synthese"))

                           )
                  ),

                  tabPanel("Statistiques",
                           fluidRow(
                             br(),
                             valueBoxOutput("mdbox", width = 2),
                             valueBoxOutput("tcbox", width = 2),
                             valueBoxOutput("atcbox", width = 2),
                             valueBoxOutput("crbox", width = 2),
                             valueBoxOutput("marchbox", width = 2),
                             valueBoxOutput("stabox", width = 2),
                             valueBoxOutput("peibox", width = 2),
                             valueBoxOutput("mmbox", width = 2),
                             valueBoxOutput("terbox", width = 2)
                           )
                  ),

                  tabPanel("Ajout de données",
                           fluidRow(
                             br(),
                             selectInput("sous.themes.insert","Sous-Thèmes :", c("", unique(as.character(base$sous.themes)))),
                             textInput("donnees.insert","Données :"),

                             actionButton("insert", ("Ajout"))
                           )
                  ),

                  tabPanel("Aide",
                           fluidRow(br(),
                                    "Documentation sur l'outil"
                           )
                  )
                )
      ))))

server = function(input, output, session) {

  output$mdbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Mode doux"),
      "Modes doux",
      icon = icon("bicycle"),
      color = "olive"
    )
  })

  output$tcbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Transports en commun"),
      "Transports en commun",
      icon = icon("bus"),
      color = "orange"
    )
  })

  output$atcbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Autres transports collectifs"),
      "Autre transports collectifs",
      icon = icon("bus"),
      color = "maroon"
    )
  })

  output$crbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Circulation routière"),
      "Circulation routière",
      icon = icon("car"),
      color = "red"
    )
  })

  output$marchbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Marchandise"),
      "Marchandise",
      icon = icon("dolly-flatbed"),
      color = "yellow"
    )
  })

  output$stabox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Stationnement"),
      "Stationnement",
      icon = icon("parking"),
      color = "purple"
    )
  })

  output$peibox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Pôles d'échanges et intermodalité"),
      "Pôles d'échanges et intermodalité",
      icon = icon("arrows-alt"),
      color = "navy"
    )
  })

  output$mmbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Management de la mobilité"),
      "Management de la mobilité",
      icon = icon("map-marked"),
      color = "blue"
    )
  })

  output$terbox <- renderValueBox({
    valueBox(
      sum(FinalData()$sous.themes == "Caractéristiques du territoire"),
      "Caractéristiques du territoire",
      icon = icon("globe"),
      color = "light-blue"
    )
  })

  shinyInput <- function(FUN, len, id, ...) {
    inputs <- character(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(FUN(paste0(id, i), ...))
    }
    inputs
  }

  df <- reactiveValues(data = data.frame(
    validation = shinyInput(actionButton, 1,
                            id = "button_",
                            label = "Check",
                            onclick = 'Shiny.onInputChange(\"select_button\", this.id)',
                            stringsAsFactors = FALSE),
    lien_fiches = createLink(base$fiches.donnees)[1]
  ))

  create_rules <- reactive({
    paste(c(input$territoire, input$doc), "== 'Oui'",  collapse = " | ")
  })

  FinalData <- eventReactive(input$submit,{
    if(is.null(c(input$territoire, input$doc)))
      return()
    else (base %>% filter_(create_rules()))
  })

  fdt <- eventReactive(input$submit,{
    tmp_fdt <- cbind(FinalData()[1:2], df$data)
    colnames(tmp_fdt) <- c("Sous-thèmes", "Données", "Validation", "Fiches données")
    tmp_fdt
    })

  filter <- reactive({
    filtered_data <- fdt()
    if (input$f_st != "Tous" & input$f_don == "Tous"){
      filtered_data <- filtered_data[FinalData()$sous.themes == input$f_st,]
    }
    if (input$f_don != "Tous" & input$f_st == "Tous"){
      filtered_data <- filtered_data[FinalData()$donnees == input$f_don,]
    }
    if (input$f_st != "Tous" & input$f_don != "Tous"){
      filtered_data <- filtered_data[FinalData()$sous.themes == input$f_st & FinalData()$donnees == input$f_don,]
    }
    return(filtered_data)
  })

  output$Synthese <-  DT::renderDT(DT::datatable({

    filter()

  },

  escape = FALSE,
  selection = "none",
  extensions="Buttons",
  options = list(
    pageLength = 10,

    initComplete = JS(
      "function(settings, json) {",
      "$(this.api().table().header()).css({'background-color': '#1A242F', 'color': '#fff'});",
      "}"),

    dom="Bfrtip",
    buttons =  list(list(
      extend = "collection",
      filename = "Extraction",
      buttons = c("copy", "csv", "excel", "pdf"),
      text = "Télécharger la sélection")
    ),
    language = list(paginate = 
                      list('next'="suivant", 
                           'previous'="précédent"),
                    info = "Pages de _PAGE_ à _PAGES_",
                    search = "Rechercher",
                    infoFiltered = "(filtre des _MAX_ lignes)")
              )
  ))

  observe({
    updateSelectInput(session, inputId = "f_st", choices = c("Tous", FinalData()$sous.themes))
    updateSelectInput(session, inputId = "f_don", choices = c("Tous", FinalData()$donnees))
    updateSelectInput(session, inputId = "f_doc", choices = c("Tous", input$doc))
  })

  observeEvent(input$select_button, {
      addCssClass(id = "button_", class = "green")
      updateSelectInput(session, inputId = "f_check", choices = c("Tous", "Ok", "Check"))
  })

}

shinyApp(UI, server)

На текущей странице я сделал 'тестовую' кнопку действия, чтобы попробовать addCssClass, и она работает, но не с кнопкой действия во фрейме данных.

Спасибо

...