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.
Related
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)
My goal is that user uploads an Excel file. Then, the user selects which sheets wants to be summarised, after the selection has been updated. I have managed to update selectInput with the name of the sheets but I have not been able to find\understand how to summarise based on what the sheet selected by the user. Thanks for any help.
library(shiny)
library(shinythemes)
library(data.table)
library(ggplot2)
library(dplyr)
library(readxl)
not_sel <- "Not Selected"
# Define UI for application that draws a histogram
ui <- fluidPage('MAIN TITLE',
theme = shinytheme('flatly'),
tabsetPanel(
sidebarLayout(
sidebarPanel(
fileInput('files','Import File', accept = c('.csv','.xlsx'),
multiple = F),
actionButton('boton1', 'Load', icon = icon('table')),
br(),
selectInput("indices", "Select SHEET:", choices = c(not_sel))
),
mainPanel(
tabsetPanel(
tabPanel('Data',
tableOutput('tabla'),
tableOutput('cabeza')),
tabPanel('Stats',
# selectInput('var01', 'Variable to summarise', choices = c(not_sel)),
tableOutput('stats')),
)
)
)
)
)
##############
server <- function(input, output, session) {
options(shiny.maxRequestSize=10*1024^2)
df <- eventReactive(input$boton1, {
req(input$files)
if(is.null(input$files))return(NULL)
# else{
read_excel(input$files$datapath)
# }
})
# Sheets of file uploaded
sheets_name <- reactive({
if (!is.null(input$files)) {
return(excel_sheets(path = input$files$datapath))
} else {
return(NULL)
}
})
# Update inputSelector with sheet names
observeEvent(df(),{
choices <- c(sheets_name())
updateSelectInput(inputId = "indices", choices = choices)
})
# DATA Tab
## This will show the name of the file
output$tabla <- renderTable({
input$files$name
})
## This Shows the head() but it is only showing the first sheet
output$cabeza <- renderTable({
tabla <- as_tibble(bind_cols(Date = format(as.Date(df()$Date),"%Y-%m-%d"),
Close.Price = df()$Close))
head(tabla)
})
# HERE is where I do not know how to calculate based on selection
# Table for STATS
output$stats <- renderTable({
datos <- df()
Value <- c(round(mean(datos$Close,na.rm = T),2)
)
Statistic <- c("Mean")
data.table(Statistic, Value)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to assume that by knowing how to calculate mean based on the sheet selected, I. can replicate the code for the top rows (head()) shown in the Data Panel.
If I missed a similar question asked, I would appreciate any link and I will try the solution proposed first.
As I cannot share the file, this is how the file would look:
After working with this answer I made my app work. If there is a 'cleaner'/'better' answer, I will be happy to read.
Following the recommendation in the linked answer my server ended up like this:
ui <-fluidPage{
#My UI stayed the same with the exception of adding
uiOutput("dropdownUI") #Whererever I needed to appear
}
server <- function(input, output, session) {
...ANSWER FROM THE LINK...
## STATS Tab
output$stats <- renderTable({
Values <- c(round(mean(Dat()[,2],na.rm = T),2)
)
Statistics <- c("Mean")
data.table(Statistics, Values)
})
}
I need to generate dynamically user interface in my shiny App. This involves inserting rpivotTable to UI page under some conditions with insertUI. I found that I can successfully do it only ones. After removing the element and inserting it again it do not appear. The issue is with rpivotTable only. All other interface elements like dataTable, actionButton so on work well. Here is the sample code reproducing the issue:
library(shiny)
library(rpivotTable)
ui<- fluidPage(title="test page",
actionButton("A","insert pivot"),
actionButton("B","remove pivot")
)
server<- function (input, output, session)
{
ds<-data.frame(a="1",b="2")
observeEvent(input$A,{
cat("insert\n")
insertUI(selector="#B",
where="afterEnd",
ui=rpivotTableOutput("C"),
immediate = T)
output$C <- renderRpivotTable({ rpivotTable(data = ds) })
})
observeEvent(input$B,{
cat("remove\n")
removeUI(selector="div#C",immediate = T)
})
}
shinyApp(ui,server)
Any advises how to solve this?
This question was posted also as an issue in rpivotTable GitHub and was answered there with the solution code below:
library(shiny)
library(rpivotTable)
ui<- fluidPage(title="test page",
actionButton("A","insert pivot"),
actionButton("B","remove pivot"),
div(id = 'placeholder')
)
server<- function (input, output, session)
{
ds<-data.frame(a="1",b="2")
inserted <- c()
observeEvent(input$A, {
btn <- input$A
id <- paste0('txt', btn)
insertUI(
selector = '#placeholder',
## wrap element in a div with id for ease of removal
ui = div(
rpivotTable(ds),
id = id
))
inserted <<- c(id, inserted)
})
observeEvent(input$B, {
removeUI(
## pass in appropriate div id
selector = paste0('#', inserted[length(inserted)])
)
inserted <<- inserted[-length(inserted)]
})
}
shinyApp(ui,server)
I assume the solution is basically to use new unique Id for each new insertUI.
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
}
})
}
)
I have a shinyTable in a shiny app. It is editable, but because of a submitButton elsewhere in the app the edits are not saved until the button is pressed. If more than one change is made and the button is pressed only the last change is saved.
My question is how can I get it to save all the changes that have been made ?
Perhaps there is a way that I can get at the contents of the whole table in the UI so I can workaround ?
Or would I be better off using shinysky or something else ?
Below is a reproducible example based on an example from the package. You'll see that if you make 2 changes to the upper table and then press the button only the 2nd change gets copied to the lower table.
library(shiny)
library(shinyTable)
server <- function(input, output, session) {
rv <- reactiveValues(cachedTbl = NULL)
output$tbl <- renderHtable({
if (is.null(input$tbl)){
#fill table with 0
tbl <- matrix(0, nrow=3, ncol=3)
rv$cachedTbl <<- tbl
print(tbl)
return(tbl)
} else{
rv$cachedTbl <<- input$tbl
print(input$tbl)
return(input$tbl)
}
})
output$tblNonEdit <- renderTable({
rv$cachedTbl
})
}
ui <- shinyUI(pageWithSidebar(
headerPanel("Simple Shiny Table!"),
sidebarPanel(
helpText(HTML("A simple editable matrix with an update button.
Shows that only most recent change is saved.
<p>Created using shinyTable."))
),
# Show the simple table
mainPanel(
#editable table
htable("tbl"),
#update button
submitButton("apply table edits"),
#to show saved edits
tableOutput("tblNonEdit")
)
))
shinyApp(ui = ui, server = server)
Thanks for your time.
Andy
Following advice from Joe Cheng at RStudio on a related question, it appears that submitButton is not advised and can cause pain.
Switching to actionButton and isolate was relatively straightforward in this simple example and in my application.
Solution below.
library(shiny)
library(shinyTable)
server <- function(input, output, session) {
rv <- reactiveValues(cachedTbl = NULL)
output$tbl <- renderHtable({
if (is.null(input$tbl)){
#fill table with 0
tbl <- matrix(0, nrow=3, ncol=3)
rv$cachedTbl <<- tbl
return(tbl)
} else{
rv$cachedTbl <<- input$tbl
return(input$tbl)
}
})
output$tblNonEdit <- renderTable({
#add dependence on button
input$actionButtonID
#isolate the cached table so it only responds when the button is pressed
isolate({
rv$cachedTbl
})
})
}
ui <- shinyUI(pageWithSidebar(
headerPanel("shinyTable with actionButton to apply changes"),
sidebarPanel(
helpText(HTML("A simple editable matrix with a functioning update button.
Using actionButton not submitButton.
Make changes to the upper table, press the button and they will appear in the lower.
<p>Created using shinyTable."))
),
# Show the simple table
mainPanel(
#editable table
htable("tbl"),
#update button
actionButton("actionButtonID","apply table edits"),
#to show saved edits
tableOutput("tblNonEdit")
)
))
shinyApp(ui = ui, server = server)