R Shiny - Dynamic download link in datatable - r

I want to add a download link in each row of a datatable in shiny.
So far I have
server <- function(input, output) {
v<-eventReactive(input$button,{
temp<-data.frame(TBL.name=paste("Data ",1:10))
temp<-cbind(
temp,
#Dynamically create the download and action links
Attachments=sapply(seq(nrow(temp)),function(i){as.character(downloadLink(paste0("downloadData_",i),label = "Download Attachments"))})
)
})
# Table of selected dataset ----
output$table <- renderDataTable({
v()
}, escape = F)}
ui <- fluidPage(
sidebarPanel(
actionButton("button", "eventReactive")
),
mainPanel(
dataTableOutput("table")
)
)
I have the download links in the table for each row. Now I want to add a different file location for each row. For example, each download link will result in a download of a different zip-folder. Can I use downloadHandler for this?

I do not believe you can embed downloadButtons/downloadLinks directly in a datatable. However, you can create hidden downloadLinks that get triggered by links embedded in your table. This produces the same end result. To do so you must:
Dynamically generate downloadLinks/downloadButtons.
Use css to set their visibility to hidden.
Embed normal links/buttons in the table
Set the onClick field of these links to trigger the corresponding hidden downloadLink.
Here is code from an example using the mtcars dataset.
library(tidyverse)
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.hiddenLink {
visibility: hidden;
}
"))
),
dataTableOutput("cars_table"),
uiOutput("hidden_downloads")
)
server <- function(input, output, session) {
data <- mtcars
lapply(1:nrow(data), function(i) {
output[[paste0("downloadData", i)]] <- downloadHandler(
filename = function() {
paste("data-", i, ".csv", sep="")
},
content = function(file) {
write.csv(data, file)
}
)
})
output$hidden_downloads <- renderUI(
lapply(1:nrow(data), function(i) {
downloadLink(paste0("downloadData", i), "download", class = "hiddenLink")
}
)
)
output$cars_table <- renderDataTable({
data %>%
mutate(link = lapply(1:n(),
function(i)
paste0('<a href="#" onClick=document.getElementById("downloadData',i, '").click() >Download</a>')
))
}, escape = F)
}
shinyApp(ui, server)

Since each downloadLink label must correspond to a name in output, I don't think there is a way to create an arbitrary set of downloads using the standard Shiny download* functions.
I solved this using DT and javascript. DT allows javascript to be associated with a datatable. The javascript can then tell Shiny to send a file to the client and the client can force the data to be downloaded.
I created a minimal example gist. Run in RStudio with:
runGist('b77ec1dc0031f2838f9dae08436efd35')

Safari is not supporting .click() anymore since v12.0. Hence, I adapted the hidden link solution from abanker with the dataTable/actionButton described by P Bucher, and the .click() workaround described here. Here is the final code:
library(shiny)
library(shinyjs)
library(DT)
# Random dataset
pName <- paste0("File", c(1:20))
shinyApp(
ui <- fluidPage( useShinyjs(),
DT::dataTableOutput("data"),
uiOutput("hidden_downloads") ),
server <- function(input, output) {
# Two clicks are necessary to make the download button to work
# Workaround: duplicating the first click
# 'fClicks' will track whether click is the first one
fClicks <- reactiveValues()
for(i in seq_len(length(pName)))
fClicks[[paste0("firstClick_",i)]] <- F
# Creating hidden Links
output$hidden_downloads <- renderUI(
lapply(seq_len(length(pName)), function(i) downloadLink(paste0("dButton_",i), label="")))
# Creating Download handlers (one for each button)
lapply(seq_len(length(pName)), function(i) {
output[[paste0("dButton_",i)]] <- downloadHandler(
filename = function() paste0("file_", i, ".csv"),
content = function(file) write.csv(c(1,2), file))
})
# Function to generate the Action buttons (or actionLink)
makeButtons <- function(len) {
inputs <- character(len)
for (i in seq_len(len)) inputs[i] <- as.character(
actionButton(inputId = paste0("aButton_", i),
label = "Download",
onclick = 'Shiny.onInputChange(\"selected_button\", this.id, {priority: \"event\"})'))
inputs
}
# Creating table with Action buttons
df <- reactiveValues(data=data.frame(Name=pName,
Actions=makeButtons(length(pName)),
row.names=seq_len(length(pName))))
output$data <- DT::renderDataTable(df$data, server=F, escape=F, selection='none')
# Triggered by the action button
observeEvent(input$selected_button, {
i <- as.numeric(strsplit(input$selected_button, "_")[[1]][2])
shinyjs::runjs(paste0("document.getElementById('aButton_",i,"').addEventListener('click',function(){",
"setTimeout(function(){document.getElementById('dButton_",i,"').click();},0)});"))
# Duplicating the first click
if(!fClicks[[paste0("firstClick_",i)]])
{
click(paste0('aButton_', i))
fClicks[[paste0("firstClick_",i)]] <- T
}
})
}
)

Related

How to reactively and repeatedly render the same type of object with an action button in R shiny?

The code at the bottom is taken from an example in https://shiny.rstudio.com/articles/modules.html though I de-modularized it so I can understand something more basic. With this code, each click of the action button renders a counter which counts the number of clicks. Fine.
Instead of counting the number of clicks in the same output of verbatimTextOutput() as the code currently works, I'd like each click to be represented as a new output of verbatimTextOutput(). See illustration below which shows what I'm trying to derive, assuming the user clicks the action button 3 times. I don't know how many times the user will click the action button so there's no way to pre-set or hard-code the number of outputs and assign output names such as output$out1, output$output2, etc. Is there a way to reactively generate the outputs names, as a I naively attempted in the below code with output$"paste(out,count())" and verbatimTextOutput("paste(out,count())") (without the quote marks, I only put them in so the example code would work)? If this is possible this could be a way to achieve the results I am seeking.
Illustration:
Code:
library(shiny)
newOutput <- function(x,y){verbatimTextOutput("paste(out,count())")}
ui <- fluidPage(uiOutput("uiButton"))
server <- function(input,output,session){
count <- reactiveVal(0)
observeEvent(input$button, {count(count() + 1)})
output$"paste(out,count())" <- renderText({count()})
count
output$uiButton <-
renderUI(
tagList(
actionButton("button", label = "Click me"),
newOutput()
)
)
}
shinyApp(ui, server)
This is an alternative approach using insertUI.
Compared to #stefan's renderUI based solution it has the advantage, that the UI elements are rendered only once. Using renderUI every element is re-rendered on button click, accordingly things will slow down depending on the number of elements.
library(shiny)
ui <- fluidPage(
actionButton("add", "Add UI")
)
server <- function(input, output, session) {
observeEvent(input$add, {
output_name <- paste0("out_", input$add)
output[[output_name]] <- renderText({
isolate(input$add)
})
insertUI(
selector = ifelse(input$add == 0L, "#add", paste0("#", "out_", input$add-1)),
where = "afterEnd",
ui = verbatimTextOutput(output_name)
)
}, ignoreNULL = FALSE)
}
shinyApp(ui, server)
Also check ?removeUI.
Adapting this example to dynamically create graphs to your example you could do:
library(shiny)
library(purrr)
newOutput <- function(x) {
verbatimTextOutput(x)
}
ui <- fluidPage(
actionButton("button", label = "Click me"),
uiOutput("uiText")
)
server <- function(input, output, session) {
count <- reactiveVal(0)
observeEvent(input$button, {
count(count() + 1)
i <- count()
output_name <- paste("out", i)
output[[output_name]] <- renderText({
i
})
})
output$uiText <- renderUI({
out_list <- map(seq_len(count()), ~ {
tagList(
newOutput(paste("out", .x))
)
})
tagList(out_list)
})
}
shinyApp(ui, server)

Hide and Show Download Button Using Shiny Modularity

So far I made a Shiny app that has three inputs connected to the database and a final download button. Everything works well except the download button. The actual data downloading part works but I want to add one last logic that hides the download button if myvars$input3 is empty:
observe({
if (is.null(myvars$var3)) {shinyjs::hide("???")}
else {shinyjs::show("???")}
})
server_tab2.R:
Function1 dropdownTab2Server:
Defined the date range logic with id daterange_tab2
Defined the last input dropdown logic with id var_list_tab2
Function2 downloadTab2Server:
Defined the logic for download button
server.R: (This part is not working)
Want to only show the download button if the third input (myvars$input3) is not empty
ui_tab2.R: Defined the three inputs explained in ui.R:
var_lab_tab2: A static dropdown input with only two choices Choice1 and Choice2
daterange_tab2_ui: A date range
subid_dropdown_tab2_ui: The last dropdown input that depends on the first two
##### server_tab2.R
#### Function 1 - A dropdown input dependent on the date range
dropdownTab2Server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
rv <- reactiveValues()
output$daterange_tab2_ui <- renderUI({
req(input$var_lab_tab2)
dateRangeInput(ns("daterange_tab2"), "Date Range:", start = min_max_date_df$min_date, end = min_max_date_df$max_date) # Retrieved from "global.R"
})
unique_lists_tab2 <- reactive({
sql <- glue_sql("
SELECT
DISTINCT list AS unique_list
FROM table1
WHERE date BETWEEN date ({dateid1_tab2*}) AND date ({dateid2_tab2*})
",
dateid1_tab2 = input$daterange_tab2[1],
dateid2_tab2 = input$daterange_tab2[2],
.con = pool
)
dbGetQuery(pool, sql)
})
output$subid_dropdown_tab2_ui <- renderUI({
req(input$daterange_tab2[1], input$daterange_tab2[2])
shinyWidgets::pickerInput(
ns("var_list_tab2"),
"Stations:",
choices = unique_lists_tab2(),
multiple = T
)
})
observe({
rv$var1 <- input$daterange_tab2[1]
rv$var2 <- input$daterange_tab2[2]
rv$var3 <- input$var_list_tab2
})
return(rv)
}
)
}
#### Function 2 - download button
downloadTab2Server <- function(id, df, filename) {
moduleServer(id, function(input, output, session) {
output$downloadbttn_tab2 <- downloadHandler(
filename = function() {
paste0(filename, ".xlsx")
},
content = function(file) {
WriteXLS::WriteXLS(df, file)
}
)
}
)
}
##### server.R => Struggling with this part
function(input, output, session) {
dropdownTab2Server("dropdown_ui_tab2")
myvars <- dropdownTab2Server("dropdown_ui_tab2")
### download button layout => Struggling with this part
observe({
if (is.null(myvars$var3)) {shinyjs::hide("???")}
else {shinyjs::show("???")}
})
downloadTab2Server(
id = "download_ui_tab2",
df = fake_data(), # reactive
filename = "data"
)
}
##### ui_tab2.R
downloadTab2UI <- function(id) {
ns <- NS(id)
tagList(
shinyWidgets::pickerInput(
ns("var_lab_tab2"),
"ID:",
choices = c("Choice1", "Choice2"), multiple = T
),
uiOutput(ns("daterange_tab2_ui")),
uiOutput(ns("subid_dropdown_tab2_ui")),
downloadButton(ns("downloadbttn_tab2"), "Download Data")
)
}
##### ui.R
downloadTab2UI("download_ui_tab2")
You could the following in the main server part (I've changed it to an observeEvent because I think it's easier to reason what exactly it listens to):
observeEvent(myvars$var3, {
if (is.null(myvars$var3)) {shinyjs::hide("download_ui_tab2-downloadbttn_tab2")}
else {shinyjs::show("download_ui_tab2-downloadbttn_tab2")}
}, ignoreNULL = FALSE)
You need to prefix the download button id with the correct namespace, in your case "download_ui_tab2".
However, this is not great style as you need to manually handle the namespace. A cleaner solution would be to pass myvars to the downloadTab2Server module as an argument and then have the observeEvent in the module code. Then you can directly use downloadbttn_tab2 and don't need to manually prefix the namespace.

Reactives Evaluation in a Loop

I am trying to create a number of tabs based on some list and create similar fields in those tabs with their own identity. Can we create and use reactives like
eval(paste0("Updated_files_list_",Some_List[k], "()"))
I have used following code and one location but that will be different for different tabs it seems that reactives are created for the lists but I am unable to either assign values to it or call it -
Some_List <- list("AGG", "CMP1", "CMP2")
Some_Long_List <- list("Aggregated Things", "Component 1", "Component 2")
sidebar <- dashboardSidebar(
do.call(sidebarMenu, c(lapply(1:length(Some_List), function(i) {
menuItem(Some_Long_List[i], tabName = paste0(Some_List[i],"_tab"))
}))))
uibody <- dashboardBody(
do.call(tabItems, c(lapply(1:length(Some_List), function(i) {
tabItem(tabName = paste0(Some_List[i],"_tab"), h2(Some_Long_List[i]),
fluidPage(fluidRow(column(3,
dateInput(paste0("ME_DATE_output_",Some_List[i]),label=h2("Select a Date"), value="2020-05-29"))
,column(9,column(verbatimTextOutput(paste0("file_path_",Some_List[i])),width=12),hr(),
selectInput(paste0('select_file_',Some_List[i]),'Select a File to display', choices=NULL),hr(),
column(dataTableOutput(paste0('selected_table_',Some_List[i])),width=12)))))
}))))
ui = dashboardPage(dashboardHeader(title = "Results"), sidebar, uibody)
server = function(input, output, session) {
# Location for Source Inputs
Some_loc <- "K:/Outputs"
lapply (1:length(Some_List), function(k){
ME_DATE_GUI <- reactive({input[[paste0("ME_DATE_output_",Some_List[k])]]})
# Files Path
output[[paste0("file_path_",Some_List[k])]] <- renderPrint({ req(Some_loc) })
# Updated Files list
assign(paste0("Updated_files_list_",Some_List[k]), reactive({
lf_some <- list.files(Some_loc,full.names = TRUE)
names(lf_some) <- basename(lf_some)
lf_some
}))
# Fetch selection of file
observeEvent(eval(paste0("Updated_files_list_",Some_List[k], "()")), {
updateSelectInput(session, paste0("select_file_",Some_List[k]), choices=eval(paste0("Updated_files_list_", Some_List[k],"()")))
})
# Display Selected file
output[[paste0("selected_table_",Some_List[k])]] <- renderDataTable({
req(input[[paste0("select_file_", Some_List[k])]])
read.csv(input[[paste0("select_file_", Some_List[k])]], header=T)
})
})
}
shinyApp(ui, server)
In the selectInput field, I can see Update_files_list_AGG(), ("AGG", "CMP1" and "CMP2" in respective tabs) but not the list of files in the assigned location. The error I get is Error: cannot open the connection

insert Hyperlink to DT table in Shiny

I want to insert a hyperlink to DT table in shiny.
To save the loading time, I want to insert hyperlinks to current view (input$table_rows_current).
I have tired with observing but I don't know how to specify where to insert hyperlink and how?
Any help much appreciated.
Here is the sample code:
library(shiny)
createLink <- function(val) {
sprintf('<a href="https://www.google.com/#q=%s" target="_blank" >%s</a>',val,val)
}
ui <- fluidPage(
titlePanel("Table with Links!"),
sidebarLayout(
sidebarPanel(
h4("Click the link in the table to see
a google search for the car.")
),
mainPanel(
dataTableOutput('table1')
)
)
)
server <- function(input, output) {
output$table1 <- renderDataTable({
dt <- datatable(mtcars, escape=FALSE, selection = 'none') %>% formatStyle(0, cursor = 'pointer')
})
observe({
List <- input$table1_rows_current
List <- createLink(List)
return(List)
})
}
shinyApp(ui, server)
The function createLink is not working because you missed one val:
Corrected:
createLink <- function(val,val) {
sprintf('<a href="https://www.google.com/#q=%s' target="_blank" >%s</a>',val,val)
}
Then you can use createLink() as below:
input$table1_rows_current = createLink(input$table1_rows_current,
input$table1_rows_current)
It will show you embedded link column.

Unbinding in module

I am creating a shiny module that inputs a dataset, and outputs a DataTable with the data and a numeric input. I know that with inputs in DataTables you need to bind and unbind the elements with javascript each time the table is redrawn or else you will only be able to read the values from the initial table. (https://groups.google.com/forum/#!topic/shiny-discuss/ZUMBGGl1sss) I don't know if the issue is with namespaces, but I can't seem to get the elements of the table to succesfully unbind inside a module. Here is my code:
library(shiny)
library(DT)
# module UI
dtInputUI <- function(id) {
ns <- NS(id)
tbl <- DT::dataTableOutput(ns("tbl"))
btn <- actionButton(ns("btn"),"Submit")
scrpt1 <- tags$script(HTML(
"Shiny.addCustomMessageHandler('display', function(html) {
var w=window.open();
$(w.document.body).html(html);})"
))
# doesn't appear to work properly
scrpt2 <- tags$script(HTML(paste0(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")))
tagList(
btn,tbl,scrpt1,scrpt2
)
}
# module server
dtInput <- function(input, output, session, data) {
ns <- session$ns
# numeric inputs
form <- reactive({
n <- nrow(data())
inputs <- character(n)
for (i in seq_len(n)) {
inputs[i] <- as.character(numericInput(
ns(paste0("Form",i)),value=0,label=NULL)
)
}
session$sendCustomMessage('unbind-DT',ns("tbl"))
data.frame(data(), RATE=inputs)
})
# datatable
output$tbl <- DT::renderDataTable(form(),
server=FALSE,escape=FALSE,selection='none',
rownames=FALSE,options=list(
paging=FALSE,
bInfo=0,
bSort=0,
bfilter=0,
preDrawCallback=DT::JS(
'function() {Shiny.unbindAll(this.api().table().node());}'),
drawCallback=DT::JS(
'function(settings) {Shiny.bindAll(this.api().table().node());}')
))
vals <- reactive({
unlist(lapply(seq_len(nrow(data())),function(i) {
value <- ifelse(is.null(input[[paste0("Form",i)]]),NA,input[[paste0("Form",i)]])
}))
})
# generate webpage when button clicked
observeEvent(input$btn, {
HTML <- paste0("<p>",paste0(vals(),collapse=" </p> <p>"),"</p>")
session$sendCustomMessage("display",HTML)
})
}
ui <- fluidPage(
mainPanel(
selectInput("choose","Choose data",choices=c("mtcars","iris")),
dtInputUI("example")
)
)
server <- function(input, output, session) {
dat <- reactive({
req(input$choose)
get(input$choose)
})
callModule(dtInput,"example",reactive(dat()))
}
shinyApp(ui, server)
Enter anything in the inputs and press the button and a webpage with the inputs is created. Change the dataset, enter different info in the inputs, and press the button again and you get the same info as before, which tells me that the old inputs didn't successfully unbind.
Any idea what I am doing wrong?
Thanks

Resources