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"))
})
```
Related
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'm trying to return the values associated with another one with renderValueBox For example:
If John return 4321
If Louis return 1234
If Marco return 30
The problem lies in this part of the function (f_1):
f_1 <- function(x) {
if (is.character(x)) {
df[1, 2] # it's wrong!
} else (NULL)
}
My code:
---
title: "Untitled"
runtime: shiny
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
library(tibble)
```
```{r}
name = c('John', 'Louis', 'Marco')
value = c(4321, 1234, 30)
df <- data.frame(name, value)
f_1 <- function(x) {
if (is.character(x)) {
df[1, 2] # it's wrong!
} else (NULL)
}
reac <- reactive({
tibble(
input$name,
input$value
)
})
pred <- reactive({
temp <- reac()
input$name
})
```
side1{.sidebar}
---------------------------------
**Control panel**
```{r}
selectInput(inputId = "name",
label="Names:",
choices = unique(df$name),
selected = "",
multiple=FALSE
)
```
calc1{}
---------------------------------
###
```{r}
renderValueBox({
expr = valueBox(
value = f_1(x = pred()),
caption = "Value",
color = "#008bbb",
icon = "fa-users"
)
})
```
Any idea? Thanks.
Change the f_1 function to
f_1 <- function(x) df$value[df$name == x]
I would like a shinyalert warning to appear when the user has no selections made on an input (i.e. when the length of input$vals equals zero. However, the code below is not working. Can anyone tell me what I'm doing wrong?
---
runtime: shiny
output:
html_document
---
```{r echo = F, message = F, warning = F, error = F}
library(shiny)
library(shinyalert)
library(tidyverse)
selectInput("vals", "Select", choices = c("a", "b"),
multiple = T, selected = "a")
observeEvent(input$vals, {
if(input$vals %>% length == 0) {
shinyalert("Select At Least One")
}
})
```
You can check on the length of the input with is.null
library(shiny)
library(shinyalert)
library(tidyverse)
ui <- fluidPage(
useShinyalert(),
selectInput("vals", "Select", choices = c("a", "b"),
multiple = T, selected = "a")
)
server <- function(input, output) {
observe({
if(is.null(input$vals)){
shinyalert('Select At Least One')}
})
}
shinyApp(ui, server)
To trigger observeEvent() even when input is NULL, you can set its ignoreNULL parameter to FALSE (default TRUE).
It is then better to set its ignoreInit parameter to TRUE (default FALSE), to prevent the trigger before the "a" element is selected.
---
output: html_document
runtime: shiny
---
```{r echo = F, message = F, warning = F, error = F}
library(shiny)
library(shinyalert)
library(tidyverse)
selectInput("vals", "Select", choices = c("a", "b"),
multiple = T, selected = "a")
observeEvent(input$vals, ignoreNULL = FALSE, ignoreInit = TRUE, {
if(input$vals %>% length == 0) {
shinyalert("Select At Least One")
}
})
```
I'm trying to make a reactive data table in R Shiny that has a button you can press to compile an RMarkdown document. Ultimately, I'm trying to combine the solutions from these two links:
R Shiny: Handle Action Buttons in Data Table and https://shiny.rstudio.com/articles/generating-reports.html. Here is what I have so far:
library(shiny)
library(shinyjs)
library(DT)
shinyApp(
ui <- fluidPage(
DT::dataTableOutput("data")
),
server <- function(input, output) {
useShinyjs()
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
df <- reactiveValues(data = data.frame(
Portfolio = c('Column1', 'Column2'),
Option_1 = shinyInput(downloadButton, 2, 'compile_', label = "Compile Document", onclick = 'Shiny.onInputChange(\"compile_document\", this.id)' ),
stringsAsFactors = FALSE,
row.names = 1:2
))
output$data <- DT::renderDataTable(
df$data, server = FALSE, escape = FALSE, selection = 'none', filter='top'
)
output$compile_document <- downloadHandler(
filename = "report.html",
content = function(file) {
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
params <- list(n = input$slider)
rmarkdown::render(tempReport, output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
}
)
Here is the RMarkdown document I'd like to compile:
---
title: "Dynamic report"
output: html_document
params:
n: NA
---
```{r}
# The `params` object is available in the document.
params$n
```
A plot of `params$n` random points.
```{r}
plot(rnorm(params$n), rnorm(params$n))
```
The pieces all seem to be there, but I can't connect the "Compile Document" button to the download handler.
Here is a way that does not use downloadHandler.
library(shiny)
library(DT)
library(base64enc)
library(rmarkdown)
js <- '
Shiny.addCustomMessageHandler("download", function(b64){
const a = document.createElement("a");
document.body.append(a);
a.download = "report.docx";
a.href = b64;
a.click();
a.remove();
})
'
buttonHTML <- function(i){
as.character(
actionButton(
paste0("button_", i), label = "Report",
onclick = sprintf("Shiny.setInputValue('button', %d);", i)
)
)
}
dat <- data.frame(
PortFolio = c("Column 1", "Column 2")
)
dat$Action <- sapply(1:nrow(dat), buttonHTML)
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
br(),
sliderInput("slider", "Sample size", min = 10, max = 50, value = 20),
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(dat, escape = -ncol(dat)-1)
})
observeEvent(input[["button"]], {
showNotification("Creating report...", type = "message")
tmpReport <- tempfile(fileext = ".Rmd")
file.copy("report.Rmd", tmpReport)
outfile <- file.path(tempdir(), "report.html")
render(tmpReport, output_file = outfile,
params = list(
data = dat[input[["button"]], -ncol(dat)],
n = input[["slider"]]
)
)
b64 <- dataURI(
file = outfile,
mime = "text/html"
)
session$sendCustomMessage("download", b64)
})
}
shinyApp(ui, server)
The rmd file:
---
title: "Dynamic report"
output: html_document
params:
data: "x"
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
Row contents:
```{r}
params$data
```
A plot of `params$n` random points:
```{r}
plot(rnorm(params$n), rnorm(params$n))
```
How can I avoid error messages in my flexdashboard chart notes when dynamic filtering and faceting creates problems in the data? For instance, here's an example where a select input causes there to be no data.
---
title: "Example"
runtime: shiny
output:
flexdashboard::flex_dashboard:
vertical_layout: fill
---
```{r}
library(tidyverse)
library(flexdashboard)
```
### Chart 1
```{r}
df <- fortify(forecast::gold)
fillCol(height = "100%", flex = c(1, NA),
plotOutput("plot", height = "100%"),
wellPanel(
tags$style(".well {background-color:#ffffff; border-color:#ffffff;}"),
radioButtons("myInput", label = NULL,
choices = list("All" = "all",
"Problematic filtering" = "filter"),
selected = "all", inline=T)
)
)
output$plot <- renderPlot({
ggplot(df, aes(x, y)) +
geom_line()
})
notes <- reactive({
if (input$myInput=="all") {
df %>%
summarise(mean = mean(y, na.rm=TRUE)) %>%
pull(mean)
} else {
df %>%
filter(x==0) %>%
summarise(mean = mean(y, na.rm=TRUE)) %>%
pull(mean)
}
})
# new attempt
notes_ <- reactive({
notes <- notes()
if (exists("notes") & !is.na(notes) & !is.nan(notes)) {
print(notes)
} else {
print("[not available]")
}
})
```
> The mean is `r notes_`.
Attempt
This prints "[not available]" (integrated above). Is there a better approach?
# new attempt
notes_ <- reactive({
notes <- notes()
if (exists("notes") & !is.na(notes) & !is.nan(notes)) {
print(notes)
} else {
print("[not available]")
}
})
```
> The mean is `r notes_`.
This prints "[not available]". Open to better solutions...
---
title: "Example"
runtime: shiny
output:
flexdashboard::flex_dashboard:
vertical_layout: fill
---
```{r}
library(tidyverse)
library(flexdashboard)
```
### Chart 1
```{r}
df <- fortify(forecast::gold)
fillCol(height = "100%", flex = c(1, NA),
plotOutput("plot", height = "100%"),
wellPanel(
tags$style(".well {background-color:#ffffff; border-color:#ffffff;}"),
radioButtons("myInput", label = NULL,
choices = list("All" = "all",
"Problematic filtering" = "filter"),
selected = "all", inline=T)
)
)
output$plot <- renderPlot({
ggplot(df, aes(x, y)) +
geom_line()
})
notes <- reactive({
if (input$myInput=="all") {
df %>%
summarise(mean = mean(y, na.rm=TRUE)) %>%
pull(mean)
} else {
df %>%
filter(x==0) %>%
summarise(mean = mean(y, na.rm=TRUE)) %>%
pull(mean)
}
})
notes_ <- reactive({
notes <- notes()
if (exists("notes") & !is.na(notes) & !is.nan(notes)) {
print(notes)
} else {
print("[not available]")
}
})
```
> The mean is `r notes_`.