r - 使用 actionButton 链接图像和外观

Question

我在 R 中的程序有点卡住了。我用 Button 操作创建了 2 列。

第一个必须允许我通过单击按钮来验证一行。问题是我无法更改按钮的外观。

第二个必须通过单击向我显示 PDF。这些文件存储在与脚本 R 相同的位置的 www 文件夹中，文件名存储在我一开始调用的基本文件的列中。但它向我显示了一个“未找到”窗口。

我的 2 列存储在反应值中：

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, {
      updateActionButton(session, inputId = "button_",label = "OK", style = "color: white; background-color: #a2db99")
    })

对于“lien_fiches”列，我创建了一个函数以在 www 文件夹中显示 pdf 文件

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

并从我的基地调用“fiches.donnees”列中的文件名

df <- reactiveValues(data = data.frame(
      lien_fiches = createLink("fiches.donnees")
    ))

这是我的整个代码：

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

#Lecture du fichier
base <- read_ods("base.ods")

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

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

    #Mise de en forme de la Sidebar
    dashboardSidebar(

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

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

      #Liste des critères de sélection
      prettyCheckboxGroup("territoire", "Territoire",
                          thick = TRUE, 
                          shape = "curve", 
                          animation = "pulse", 
                          choices = c("Communes.centrales", "Communes.poles.urbain", "Communes.secondaires", "Communes.rurales", "Ensemble.territoire", "Perimetre.elargit")),
      prettyCheckboxGroup("doc", "Documents de planification existants",
                          thick = TRUE, 
                          shape = "curve", 
                          animation = "pulse",
                          choices = c("Volet.mobilite.SCOT", "PDU.obligatoire", "PGD.volontaire", "PLUI", "Plan.mobilite.rurale", "PCAET", "PLUIHD")),

      #Et le miracle fut !
      actionButton("submit", ("Extraction"))
    ),

      #Mise en forme de la page principale
      dashboardBody(
        fluidPage(


          #Onglets Extraction et Ajout de données
          mainPanel(width = 12,
            tabsetPanel(

              #Onglet Extraction
              tabPanel("Extraction",
                fluidRow(
                  br(),
                  #Liste des différents filtres possibles sur le résultat
                  column(width=3,
                         selectInput("f_st",
                                     "Sous-thèmes :",
                                     "")
                  ),
                  column(width=3,
                         selectInput("f_don",
                                     "Données :",
                                     "")
                  ),
                  column(width=3,
                         selectInput("f_check",
                                     "Validation :",
                                     "")
                  ),
                  column(width=3,
                         selectInput("f_doc",
                                     "Documents de planification :",
                                     "")
                  ),
                  column(width=12, DT::dataTableOutput("Synthese"))

                )
              ),

            #Onglet Ajout de données (on utilise pas pour le moment)
            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"))
              )
            ),

            #Onglet Aide (on utilise pas pour le moment)
            tabPanel("Aide",
                     fluidRow(br(),
                              "Documentation sur l'outil"
                     )
            )
      )
  ))))

  server = function(input, output, session) {

    #Definition de la commande shinyInput pour le bouton
    shinyInput <- function(FUN, len, id, ...) {
      inputs <- character(len)
      for (i in seq_len(len)) {
        inputs[i] <- as.character(FUN(paste0(id, i), ...))
      }
      inputs
    }

    #Création de la colonne bouton
    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)'),
      lien_fiches = createLink("fiches.donnees")
    ))

    #Création de la règle de filtre a partir des critères
    create_rules <- reactive({
      paste(c(input$territoire, input$doc), "== 'Oui'",  collapse = " | ")
    })

    #Méthode pour le click
    FinalData <- eventReactive(input$submit,{
      if(is.null(c(input$territoire, input$doc)))
        return()
      else (base %>% filter_(create_rules()))
    })

    #Rendu de la table d'extraction
    output$Synthese <-  DT::renderDT(DT::datatable({

      #Assemblage de l'extraction et de la colonne boutton
      fdt <- cbind(FinalData()[1:2], df$data)

      #Validation des filtres du tableau
      if (input$f_st != "Tous") {
        fdt <- fdt[fdt$sous.themes == input$f_st,]
      } else fdt$sous.themes

      if (input$f_don != "Tous") {
        fdt <- fdt[fdt$donnees == input$f_don,]
      } else fdt$donnees

      if (input$f_doc != "Tous") {
        fdt <- fdt[input$doc == input$f_doc,]
      } else input$doc

      #Renomme les colonnes
      colnames(fdt) <- c("Sous-thèmes", "Données", "Validation", "Fiches données")

      #Affiche le tableau
      fdt

        },

        #Argument sans quoi la colonne bouton n'apparait pas !!!!
        escape = FALSE,

        extensions="Buttons",
         options = list(

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

          #Paramètrage des boutons d'export
          dom="Bfrtip",
          buttons =  list(list(
            extend = "collection",
            filename = "Extraction",
            buttons = c("copy", "csv", "excel", "pdf"),
            text = "Télécharger la sélection")
            ))
        ))


    #Mise à jour des filtres du tableau
    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))
    })

    #Evenement lié au click bouton
    observeEvent(input$select_button, {
      selectedRow <- as.character("Oui")
      updateSelectInput(session, inputId = "f_check", choices = c("Tous", selectedRow))
      updateActionButton(session, inputId = "button_",label = "OK", style = "color: white; background-color: #a2db99")
    })

}

shinyApp(ui, server)

任何想法 ？

非常感谢！

标签： rshiny