Кнопка "Скрыть", созданная с помощью модулей внутри сервера
У меня есть приложение, которое имеет много tabItem
s и для каждого из них я указываю, какие файлы должны быть помещены в определенный каталог (в приведенном ниже примере я использую getwd()), чтобы приложение могло запускать определенные процедуры.
Эти файлы будут перечислены в "таблице" вместе с кнопками и другими функциями.
Время от времени файл создается в одном tabItem
будет использоваться в качестве входных данных в другом.. и я хотел бы скрыть кнопку, созданную динамически в модуле для этого файла в tabItem
который использует файл в качестве входных данных.
Я нашел, как это можно сделать из модуля, но я хотел бы знать, возможно ли это сделать с сервера.
Вот небольшая версия этого приложения с тем, что я пробовал:
## global ----
library(shiny)
library(shinydashboard)
library(shinyBS)
library(shinyjs)
find_file_flex <- function(dir, extension, name_pattern, temp.rm=FALSE) {
files <- list.files(dir, pattern = name_pattern)
exts <- stringr::str_sub(files, -nchar(extension))
files <- files[exts == extension]
if(temp.rm) {
temp <- stringr::str_detect(files, pattern = "^([~][$])")
files <- files[!temp]
}
if (length(files) == 1){
file.path(dir, files)
} else if (length(files) > 1) {
date <- gsub(pattern = "-", replacement = "", basename(dir))
time_start <- unlist(gregexpr(pattern = date, files))
times <- stringr::str_sub(files, time_start, time_start + 13)
file.path(dir, files[times == max(times)])
} else { NA }
}
## dir_files ----
dir_files <- list(
file1 = list(
name_pattern = "-name_pattern1",
extension = ".txt",
sep = ";",
dec = ".",
label = "File1"
),
file2 = list(
name_pattern = "-name_pattern2",
extension = ".txt",
sep = ";",
dec = ".",
label = "File2"
)
)
## files_ui ----
files_ui <- tagList(
file1 = list(
button_icon = icon("download"),
info_modal_content = div("1. Much info! Such knowledge!")
),
file2 = list(
button_icon = icon("refresh"),
info_modal_content = div("2. Much info! Such knowledge!")
)
)
## chores_info ----
chores_info <- list(
home = list(
label = "Homez!",
input = c("file1","file2"),
output = "file2"
)
)
## modules ----
tr_fileOutput <- function(id) {
ns <- NS(id)
tagList(
tagList(
tags$tr(
# id = ns("tr"),
tags$td(uiOutput(ns("info_actionLink")), colspan = "1"),
tags$td(uiOutput(ns("labelLink")), colspan = "7"),
tags$td(uiOutput(ns("button")), colspan = "1")
),
tags$tr(
tags$td(uiOutput(ns("warn")), colspan = "10")
)
),
uiOutput(ns("info_modal"))
)
}
tr_file <- function(input, output, session, file, path) {
ns <- session$ns
file_path <- reactive({
invalidateLater(2000, session)
obj <- dir_files[[file]]
if(is.null(obj$dir)) obj$dir <- path()
find_file_flex(obj$dir, obj$extension, obj$name_pattern, temp.rm = TRUE)
})
output$info_actionLink <- renderUI({
actionLink(ns("info_actionLink"), label = NULL, icon = icon("info-circle"))
})
output$labelLink <- renderUI({
label <- dir_files[[file]]$label
if(is.na(file_path())) return(label)
actionLink(ns("labelLink"), label = label)
})
output$button <- renderUI({
icon <- files_ui[[file]]$button_icon
if(is.null(icon)) return(NULL)
bsButton(ns("button"), label = NULL, icon = icon,
size = "extra-small", class = "bvmf-blue")
})
output$info_modal <- renderUI({
content <- files_ui[[file]]$info_modal_content
title <- dir_files[[file]]$name_pattern
title <- div("Give me the Info ", tags$small(span("(", title, ")")))
bsModal(ns("info_modal"), title = title, trigger = NULL, content)
})
# trigger info_modal
observeEvent(input[["info_actionLink"]],
toggleModal(session, "info_modal", toggle = "open"))
# hyperlink para o labelLink
observeEvent(input[["labelLink"]], shell.exec(file_path()))
}
table_filesOutput <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns("info_modal")),
htmlOutput(ns("table"))
)
}
table_files <- function(input, output, session, files, path) {
ns <- session$ns
observe({
lapply(files, function(file) {
callModule(module = tr_file, id = file,
file = file, path = path)
})
})
output$table <- renderUI({
x <- lapply(files, function(file) tr_fileOutput(ns(file))[1] )
tags$table(x, id = ns("table"), style = "width: 100%;")
})
output$info_modal <- renderUI({
lapply(files, function(file) tr_fileOutput(ns(file))[2] )
})
}
## ui ----
ui <- dashboardPage(
skin = "blue",
dashboardHeader(
title = format(Sys.Date(), "%d/%m/%Y")
),
dashboardSidebar(
sidebarMenu(
id = "sidebarMenu",
menuItem("Home", tabName = "home", icon = icon("home"))
)
),
dashboardBody(
id = "dashboardBody",
useShinyjs(),
tabItems(
tabItem(
tabName = "home",
column(
width = 3,
wellPanel(
table_filesOutput("home-input")
),
wellPanel(
table_filesOutput("home-output")
)
)
)
)
)
)
## server ----
server <- shinyServer(function(input, output, session) {
date <- reactive({ Sys.Date() })
dir_date <- reactive({ getwd() })
callModule(table_files, "home-input",
files = chores_info[["home"]]$input, path = dir_date)
callModule(table_files, "home-output",
files = chores_info[["home"]]$output, path = dir_date)
observe({
# not sure why this is not hiding the button :(
hide("home-input-file2-button")
})
# code to deal with buttons and such
session$onSessionEnded(stopApp)
})
## ----
shinyApp(ui = ui, server = server)