我对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)')
))
对于“验证”列，我进行了一个watchEvent来更改外观
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)
有什么想法吗？
非常感谢您！