Related
I am trying to get the searchPanes extension from DT to work in an rmarkdown file (https://rstudio.github.io/DT/extensions.html). I can get it to work with datatable but not with renderDataTable and reactive statement. Attached is a working example that one tab shows it working and the other tab showing the issue. Any advice/recommendation is appreciate.
My code:
---
title: "Filter_example"
output: flexdashboard::flex_dashboard
runtime: shiny
date: "`r Sys.Date()`"
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = F)
library(DT)
library(tidyverse)
```
# Sidebar {.sidebar data-width="200"}
```{r sidebar, echo=FALSE}
selectizeInput('color', label ='color', choices = diamonds$color ,
multiple = TRUE,
options = list(maxItems = 5,
placeholder = 'Search Here...'))
```
# Diamonds Are Forever
```{r echo=FALSE}
diamonds %>%
datatable(
rownames = F,
extensions = c("SearchPanes", "Select", "Buttons"),
options = list(
language = list(searchPanes = list(collapse = "Filter Rows")),
scrollX= "30vw",
scrollY = "45vh",
dom = "Blfrtip",
buttons = list("searchPanes")
),
selection = 'none'
)
```
# Diamonds Are Forever renderDataTable
```{r echo=FALSE}
diamonds_dd <- reactive({
if (is.null(input$color)){
diamonds
}
else if(!is.null(input$color)) {
diamonds %>%
filter(color %in% input$color)
}
})
DT::renderDataTable(diamonds_dd(),extensions = c("SearchPanes", "Select", "Buttons"),
options = list(
scrollX= "30vw",
scrollY = "45vh",
dom = "Blfrtip",
buttons = list("searchPanes"),
columnDefs = list(
list(searchPanes = list(show = FALSE), targets = 3:5),
list(searchPanes = list(controls = FALSE), targets = 0:2),
list(className = "dt-center", targets = 0:5)
)
),
selection = 'none'
)
```
You need server = FALSE.
DT::renderDataTable(
diamonds_dd(), extensions = c("SearchPanes", "Select", "Buttons"),
options = list(
scrollX= "30vw",
scrollY = "45vh",
dom = "Blfrtip",
buttons = list("searchPanes"),
columnDefs = list(
list(searchPanes = list(show = FALSE), targets = 3:5),
list(searchPanes = list(controls = FALSE), targets = 0:2),
list(className = "dt-center", targets = 0:5)
)
),
selection = 'none',
server = FALSE
)
However, this is not recommended for a large dataset like diamonds. It sends all rows to users which is unnecessary and takes a long time.
Update
renderdatatable doesnt show actionbutton, renderDT shows but not able to just download the table although i can see the actionbutton being triggered with cat statement
I'm new to markdown trying to build a markdown application which needs to download data depending on the action/download button. In my example below, id like to have a downloadButton or downloadLink to download the row contents of the download button row, if i click on the first action button then id like to download mtcars 1st row values for mpg, cyl, disp to a csv or excel.
I have a fairly large subset in the actual application so i can filter accordingly.
The problem is i am not getting an action button but just raw html in my DT, not sure if i am missing small details.
---
title: "Download data with download button"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(DT)
library(downloadthis)
library(dplyr)
```
```{r, echo=FALSE}
shinyInput <- function(FUN, n, id, ...) {
vapply(seq_len(n), function(i){
as.character(FUN(paste0(id, i), ...))
}, character(1))
}
downloadButtonRmd <- function (outputId, label = "Download", class = NULL, ...) {
tags$a(id = outputId, class = paste("btn btn-default shiny-download-link",
class), href = "", target = "_blank", download = NA,
icon("download"), label, ...)
}
tab <- data.frame(head(mtcars[1:3]))
tab <- tab %>% mutate(
dl1 = shinyInput(actionButton, nrow(.), 'button_', label = "Download", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
dl2 = shinyInput(downloadButtonRmd, nrow(.), 'button_', label = "Download",onclick = 'Shiny.onInputChange(\"select_button1\", this.id)' ))
# renderDataTable({
# tab %>%
# datatable(extensions = 'Buttons',
# options = list(dom = 'Blfrtip',
# buttons = c('copy', 'csv', 'excel', 'pdf', 'print'),
# lengthMenu = list(c(10,25,50,-1),
# c(10,25,50,"All"))))
# })
renderDT({
datatable(tab,
options = list(pageLength = 25,
dom = "rt"),
rownames = FALSE,
escape = FALSE)})
observeEvent(input$select_button1, {
selectedRow <<- as.numeric(strsplit(input$select_button1, "_")[[1]][2])
cat(input$select_button1)
downloadHandler(filename = "Academic Report.csv",
content = function(file) {write.csv(tab[selectedRow,1:3], file, row.names = FALSE)},
contentType = "text/csv")
})
```
I've read through these links and many others but i'm unable to get what I intended
RShiny Download Button Within RMarkdown
R Shiny: Handle Action Buttons in Data Table
Thanks
Here is a way with the downloadthis package.
---
title: "DT download row"
author: "Stéphane Laurent"
date: "21/03/2022"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(DT)
library(downloadthis)
htmltools::tagList( # for the icons
rmarkdown::html_dependency_font_awesome()
)
```
```{r}
dat <- mtcars
dat[["Download"]] <- vapply(1L:nrow(mtcars), function(i){
as.character(
download_this(
.data = mtcars[i, ],
output_name = paste0("mtcars - row ", i),
output_extension = ".csv",
button_label = "Download",
button_type = "primary",
icon = "fa fa-save",
csv2 = FALSE,
self_contained = TRUE
)
)
}, character(1L))
```
```{r}
datatable(
dat,
escape = FALSE,
options = list(
columnDefs = list(
list(targets = ncol(dat), orderable = FALSE),
list(targets = "_all", className = "dt-center")
)
)
)
```
Of course that won't work if you edit the table.
I have a shiny app like this:
library(shiny)
library(data.table)
tabledata <- data.table(a=1:4, b= 5:8)
ui <- fluidPage(
dataTableOutput("currenttable")
)
server <- function(input,output, session){
output$currenttable <- renderDataTable({tabledata},rownames = FALSE, extensions = 'Buttons',
options = list(dom = 'Bfrtip', buttons = c('copy', 'pdf'),
filename = "CurrentTable", header= "My Header", pageLength = nrow(tabledata))
)
}
shinyApp(ui, server)
The pdf button works, but only saves the file as "pdf.pdf" not "CurrentTable" and header is missing.
You'll need to bind the options to the pdf button. You can include filename and header options in this way.
From the DataTable pdf reference, header indicates whether the table header (i.e. column names) should be included in the exported table or not -- this can only be TRUE or FALSE, not a string. If you're looking for a title above the table, you could use the title option.
Here's your example:
library(shiny)
library(data.table)
library(DT)
tabledata <- data.table(a=1:4, b= 5:8)
ui <- fluidPage(
DT::dataTableOutput("currenttable")
)
server <- function(input,output, session){
output$currenttable <- renderDT({tabledata},
rownames = FALSE,
extensions = 'Buttons',
options = list(dom = 'Bfrtip',
pageLength = nrow(tabledata),
buttons = list(
list(extend = 'copy'),
list(extend = 'pdf',
filename = 'CurrentTable',
title = "My Title",
header = FALSE)
)
)
)
}
shinyApp(ui, server)
I have the following RMarkdown Shiny document:
---
title: "Title"
runtime: shiny
output:
flexdashboard::flex_dashboard:
vertical_layout: scroll
theme: bootstrap
orientation: rows
---
```{r setup, include=FALSE}
library(flexdashboard)
```
Rows {data-height=400}
-----------------------------------------------------------------------
### Table
``` {r show_table}
library(DT)
library(ggplot2)
renderDataTable( {
dat <- diamonds
},
extensions = c('Scroller','Buttons'),
class = 'compact cell-border stripe', rownames = FALSE,
filter = list( position = 'top', clear = FALSE, plain =TRUE ),
options = list(
deferRender = FALSE,
scrollY = 200,
scroller = TRUE,
dom = 'Bfrtip',
buttons = c('csv', 'excel')
)
)
```
Which produces this document:
After I download the Excel file, the number of rows is just ~90 lines
not complete 53,940 entries. Why is that and how can I fix it?
By default DT uses Server-side Processing so only the visible data are sent to the browser. That is why the Excel file only contains the visible data (if you remove scrollY = 200 and scroller = TRUE this becomes very clear).
To download all data you need to disable Server-side Processing by including server = FALSE, e.g.
class = 'compact cell-border stripe', rownames = FALSE,
server = FALSE,
filter = list( position = 'top', clear = FALSE, plain =TRUE ),
Unfortunately, this makes loading and browsing the table extremely slow (on my computer at least).
BTW: Your code depends on the diamonds dataset which is part of ggplot2.
I am trying to use rhandsontable to record user input and pass it to Shiny server end to further process.
Specifically, for the following code, I want to add one column to record user input and show the sum of the colum in a flexdashboard valueBox.
But somehow, the reativeValue does not appear reactive. Whatever I change the first column Vol_Percent, the valueBox does not change. Any suggestion? Thanks!
---
title: "Test"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: scroll
runtime: shiny
---
```{r global, include=FALSE}
packages <- c("flexdashboard", "readr", "dplyr", "rhandsontable", "shiny")
for (p in packages) {
library(p, character.only = TRUE, quietly = TRUE)
}
```
Column {.sidebar}
-----------------------------------------------------------------------
### Input and Control
```{r input_panel}
# Input file
fileInput(inputId = "file_property_input", label = "Upload Properties")
```
Row
-----------------------------------------------------------------------
### Properties
```{r property_table}
# Load input data file
values <- reactiveValues()
df_input <- reactive({
validate(need(input$file_property_input, message = FALSE))
input_file <- input$file_property_input
return(read_csv(input_file$datapath))
})
data <- reactive({
if(is.null(values[["data"]])) {
data <- cbind(Vol_Percent = rep(0, nrow(df_input())), data.frame(df_input()))
} else {
data <- values[["data"]]
}
values[["data"]] <- data
return(data)
})
renderRHandsontable({
rhandsontable(data(), search = TRUE, readOnly = TRUE, height = 400) %>%
hot_col("Vol_Percent", readOnly = FALSE) %>%
hot_cols(fixedColumnsLeft = 1) %>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE,
customOpts = list(
search = list(name = "Search",
callback = htmlwidgets::JS(
"function (key, options) {
var srch = prompt('Search criteria');
this.search.query(srch);
this.render();
}"))))
})
```
Row
-----------------------------------------------------------------------
### Input Validility
```{r input_valid}
renderValueBox({
info <- "Input Validated"
valueBox(value = info, icon = ifelse(info == "Input Validated", "fa-check", "fa-times"), color = ifelse(info == "Input Validated", "success", "danger"))
})
```
### Total Percentage
```{r information}
renderValueBox({
rate <- sum(values[["data"]]$Vol_Percent)
valueBox(value = rate, icon = ifelse(rate == 100, "fa-check", "fa-times"), color = ifelse(rate == 100, "success", "warning"))
})
```
I figured it out based on the example posted here
https://github.com/jrowen/rhandsontable/blob/master/inst/examples/rhandsontable_portfolio/server.R
Here is the updated code
---
title: "Test"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: scroll
runtime: shiny
---
```{r global, include=FALSE}
packages <- c("flexdashboard", "readr", "dplyr", "rhandsontable", "shiny")
for (p in packages) {
library(p, character.only = TRUE, quietly = TRUE)
}
```
Column {.sidebar}
-----------------------------------------------------------------------
### Input and Control
```{r input_panel}
# Input file
fileInput(inputId = "file_property_input", label = "Upload Properties")
```
Row
-----------------------------------------------------------------------
### Properties
```{r property_table}
# Load input data file
values <- reactiveValues(hot = NULL)
sum_percentage <- reactive({
return(sum(values[["hot"]]$Vol_Percent))
})
df_input <- reactive({
validate(need(input$file_property_input, message = FALSE))
input_file <- input$file_property_input
return(read_csv(input_file$datapath))
})
output$hot <- renderRHandsontable({
data <- NULL
if (is.null(values[["hot"]])) {
values[["hot"]] <- cbind(Vol_Percent = rep(0, nrow(df_input())), data.frame(df_input()))
}
if (!is.null(input$hot)) {
data <- hot_to_r(input$hot)
values[["hot"]] <- data
} else if (!is.null(values[["hot"]])) {
data <- values[["hot"]]
}
if (!is.null(data)) {
rhandsontable(data, search = TRUE, readOnly = TRUE, height = 400) %>%
hot_col("Vol_Percent", readOnly = FALSE) %>%
hot_cols(fixedColumnsLeft = 1) %>%
hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE,
customOpts = list(
search = list(name = "Search",
callback = htmlwidgets::JS(
"function (key, options) {
var srch = prompt('Search criteria');
this.search.query(srch);
this.render();
}"))))
}
})
rHandsontableOutput("hot")
```
Row
-----------------------------------------------------------------------
### Input Validility
```{r input_valid}
renderValueBox({
info <- "Input Validated"
valueBox(value = info, icon = ifelse(info == "Input Validated", "fa-check", "fa-times"), color = ifelse(info == "Input Validated", "success", "danger"))
})
```
### Total Percentage
```{r information}
renderValueBox({
rate <- ifelse(!is.null(sum_percentage()), sum_percentage(), 0)
valueBox(value = rate, icon = ifelse(rate == 100, "fa-check", "fa-times"), color = ifelse(rate == 100, "success", "warning"))
})
```