Save DT table with additional information (Shiny) - shiny

I was wondering if it is possible to save DT table content together with some additional information which is not part of the data frame/table like app version number, date of execution, sliderInput value etc.
Thank you!
Reprex below:
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1)
),
mainPanel(
DT::dataTableOutput("table")
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
}
shinyApp(ui = ui, server = server)

You could save the contents of the data frame and the other information in a list and then save the list.
Or, any R object can have attributes which are completely arbitrary and under your control. You could set attributes of the data frame to record the information you want.
Personally, I'd use the list approach, purely because I don't like attributes.
Here's a suggestion in response to OP's request below.
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1),
actionButton("saveRds", "Save to Rds"),
actionButton("loadRds", "Load from Rds")
),
mainPanel(
DT::dataTableOutput("table"),
wellPanel(h4("Current data"), verbatimTextOutput("text")),
wellPanel(h4("File data"), verbatimTextOutput("loadedData"))
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
listInfo <- reactive({
list("data"=dfr, "version"="WebApp Version 1.0", "runDate"=date(), "sliderValue"=input$range)
})
output$text <- renderPrint({
listInfo()
})
observeEvent(input$saveRds, {
saveRDS(listInfo(), "data.Rds")
})
fileData <- reactive({
req(input$loadRds)
readRDS("data.Rds")
})
output$loadedData <- renderPrint({
fileData()
})
}
shinyApp(ui = ui, server = server)
The way you implement "save to file" will depend on the file format: Excel files will clearly have different requirements to PDF files, for example. As a minimum effort demonstation, I've created "Save to Rds" and "Load from RDS" buttons in the sidebar and added a verbatimTextOutput to display the contents of the file when it's loaded. [I'm not sufficiently familiar with DT to know how to add the buttons in the table toolbar.]
OP's effort was pretty close: it's just that writing a list to CSV file takes a little more effort than just calling write.csv...

Related

Subset the datatable by multiple user input filter separated by comma

I am quite new to R shiny and I am trying to build a small shiny app but I don't know where I went wrong.
I am trying to get multiple user input via text area to filter my table output. Moreover, i want to control the columns to show in the table as well. Code is running fine for showing the columns but it is working only with one input value in the text area, it is not working with multiple user inputs.
I want to filter the table output with multiple user inputs as well.
For example for this code snippet it should return table when I write "honda,audi,bmw" in the text area input.
library(shiny)
library(shinyWidgets)
library(DT)
df <-mtcars
#ui
shinyApp(
ui = fluidPage(
titlePanel("Trial 1"),
sidebarLayout(
sidebarPanel(
#to take multiple user input
textAreaInput(
"text_input",
label = "Write multiple input separated by comma"
),
#to slect the columns to be added
pickerInput(
inputId = "somevalue",
label = "Columns to add",
choices = colnames(df),
options = list(`actions-box` = TRUE),
multiple = TRUE
),
#action button tot show the table
actionBttn(
"show_table",
label = "Show",
size = "sm",
color = "default",
block = TRUE
),
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Table", DT::dataTableOutput("table")),
tabPanel("Summary", verbatimTextOutput("summary"))
)
)
)
),
server = function(input, output,session) {
data <- observeEvent(input$show_table,{
text_input <- trimws(strsplit(input$text_input, ",")[[1]])
output$summary <- renderPrint({
summary(data())
})
output$table <- DT::renderDT({
df_sub <- df[df$make %chin% input$text_input, input$somevalue]
#df_sub = df[ ,input$somevalue]
datatable(df_sub,
caption = "PLease enter the changes by double clicking the cell",
editable = 'cell')
})
})
}
)
There isn't a 'make' variable in the data. I guess you refer to the first word of the row name as the make of the car. Then the strings you entered could be matched with the make of the car.
server = function(input, output,session) {
data <- observeEvent(input$show_table,{
brand <- word(rownames(df), 1)
text_input <- strsplit(input$text_input, ",")[[1]]
df_sub <- df[brand %in% text_input, input$somevalue]
output$summary <- renderPrint({
summary(df_sub)
})
output$table <- DT::renderDT({
datatable(df_sub,
caption = "PLease enter the changes by double clicking the cell",
editable = 'cell')
})
output$test <- renderText({
text_input
})
})}

Remove unwanted white space when rendering leaflet or plot in Shiny

I want the user of my Shiny app to be able to choose between two types of plots by clicking on radiobuttons in the Events panel. The code I have written works, but the page leaves a huge white space when going from "Map" to "Plot". Is there any way to get rid of the white space and position the plot at the very top?
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
}else{
shinyjs::enable("range")
}
})
output$plot <- renderPlot({
if (input$plotType == "l") {
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
}
})
output$map <- renderLeaflet({
if ( input$plotType == "m") {
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
}
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
There is a big space because the map html object still exists, but is empty. To avoid this, I created and observeEvent that hides or show the map output depending on input value. I did the same thing with the plot, in cas you need to add others elements below it.
Please note that there are others solutions (conditionalPanel for example), I am just giving you the one I think is the simpliest here.
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
# hide or show map and plot
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
shinyjs::hide("map")
shinyjs::show("plot")
}
if(input$plotType == "m"){
shinyjs::enable("range")
shinyjs::show("map")
shinyjs::hide("plot")
}
})
output$plot <- renderPlot({
req(input$plotType == "l") # good practice to use req instead of if
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
})
output$map <- renderLeaflet({
req(input$plotType == "m")
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)

R Shiny: Updating proxy table column headers in ObserveEvent

I would like to update column headers in an R Shiny proxy table. The app should:
Launch with original column header names (e.g. "Do","Re","Mi","Fa","So")
Change those column headers in the proxy table to something else when the user clicks an action button (e.g. "y1","y2","y3","y4","y5")
Shiny has a convenient updateCaption() method that allows for a similar behavior for proxy table captions. I'd like to do something similar with table column headers for proxy tables. Here's my attempt.
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
actionButton(
"updatebutton",
label = "Update Table",
style = "margin-right: 5px;"
),
DT::dataTableOutput("myplot")
),
)
server <- function(input, output) {
mycolumnnames <-c("Do","Re","Mi","Fa","So")
myothercolumnnames <- c("y1","y2","y3","y4","y5")
output$myplot <- DT::renderDataTable({
DF <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
datatable(DF, colnames = mycolumnnames,
caption="Original caption")
})
proxy <- DT::dataTableProxy("myplot")
observeEvent(input$updatebutton, {
updateCaption(proxy, caption="Look, I am a NEW caption!")
DF <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
# names(DF) <- myothercolumnnames # This doesn't work
proxy %>% replaceData(DF)
})
}
shinyApp(ui = ui, server = server)
Edit1: Now uses dataTableProxy()
I took away all the things related to color background so I could focus on your problem.
First, I declare some values outside shiny: your data.frame and two vectors for the column names. Then I assign the column names as the first vector.
Inside the app, I retrieve the data as a reactiveVal(), and update its colnames whenever the button is pressed
library(shiny)
library(DT)
mycolumnnames <-c("Do","Re","Mi","Fa","So")
myothercolumnnames <- c("y1","y2","y3","y4","y5")
DF <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
colnames(DF) <- mycolumnnames
ui <- fluidPage(
fluidRow(
actionButton(
"updatebutton",
label = "Update Table",
style = "margin-right: 5px;"
),
DT::dataTableOutput("myplot")
),
)
server <- function(input, output) {
df <- reactiveVal(DF)
output$myplot <- DT::renderDataTable({
datatable(df(), caption="Original caption")
})
observeEvent(input$updatebutton, {
new_data <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
if(!input$updatebutton %% 2 == 0 ){
colnames(new_data) <- myothercolumnnames
} else {
colnames(new_data) <- mycolumnnames
}
df(new_data)
proxy1 <- DT::dataTableProxy("myplot")
updateCaption(proxy1, caption="Look, I am a NEW caption!")
replaceData(proxy1, df())
})
}
shinyApp(ui = ui, server = server)
So whenever you press the button, the colnames are changed between the two vectors.

Is there a good way to merge data based on a drop down menu in R?

I have been trying to merge data with another data set based on input from a drop down. I have just started learning R and have run into some problems and want to know if there is a better way of going about this.
I am getting an error that it cannot coerce class c(ReactiveExpr, reactive) to a data frame.
library(shiny)
library(plyr)
library(dplyr)
library(xlsx)
server <- function(input, output){
annotation1 <- read.xlsx("input1.xlsx", sheetIndex = 1, header = TRUE)
annotation2 <- read.xlsx("input2.xlsx", sheetIndex = 1, header = TRUE)
data_input <- eventReactive(input$userfile, {
df <- read.xlsx(input$userfile$datapath, sheetIndex = 1, header = TRUE)
})
output$data_input <- renderTable(data_input())
output$annotation <- renderTable(annotation)
data_species <- c("Set1", "Set2")
# Drop-down selection box for which data set
output$choose_species <- renderUI ({
selectInput("species", "Species", as.list(data_species))
})
output$mergeddata <- renderTable({
if(input$species == "Set1"){
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
}
else if(input$species == "Set2"){
eventReactive("Set2",({left_join(data_input(), annotation2, by = c("Column1" = "Column1"))}))
}
})
}
ui <- fluidPage(
titlePanel(
div("Test")
),
sidebarLayout(
sidebarPanel(
fileInput("userfile", "Input File", multiple =FALSE,
buttonLabel = "Browse Files", placeholder = "Select File"),
uiOutput("choose_species"),
uiOutput("choose_annotations"),
),
mainPanel(
tableOutput("mergeddata"),
br()
),
),
)
# Run the application
shinyApp(ui = ui, server = server)
In general, you approach seems ok. The error you get is from the line
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
An eventReactive returns an (unevaluated) reactive expression which you try to render as data.frame with renderTable. To circumvent this, you could use:
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))()
However, here you don't need eventReactive, because your reactivity comes from input$species (you want to change the table output based on this input). Therefore, you can just use:
output$mergeddata <- renderTable({
if(input$species == "Set1"){
merge_data <- annotation1
} else {
merge_data <- annotation2
}
left_join(data_input(), merge_data, by = c("Column1"))
})

Downloading the output from Shiny APP (need some advice)

I want to download the output of this App which I made but there is an error and when I open the downloaded data it is empty.I make a data set by output$other_val_show and I want to download it. Any advice?
The following code in for the UI section.
library(shiny)
library(quantreg)
library(quantregGrowth)
library(plotly)
library(rsconnect)
library(ggplot2)
library(lattice)
ui = tagList(
tags$head(tags$style(HTML("body{ background: aliceblue; }"))),
navbarPage(title="",
tabPanel("Data Import",
sidebarLayout(sidebarPanel( fileInput("file","Upload your CSV",multiple = FALSE),
tags$hr(),
h5(helpText("Select the read.table parameters below")),
checkboxInput(inputId = 'header', label = 'Header', value = FALSE),
checkboxInput(inputId = "stringAsFactors", "StringAsFactors", FALSE),
radioButtons (inputId = 'sep', label = 'Separator',
choices = c(Comma=',',Semicolon=';',Tab='\t', Space=''), selected = ',')
),
mainPanel(uiOutput("tb1"))
)),
tabPanel("Interval",
sidebarLayout(sidebarPanel(
uiOutput("model_select"),
uiOutput("var1_select"),
uiOutput("rest_var_select"),
#uiOutput("testText1"), br(),
#textInput("Smooting Parameter min value", "Smooting Parameter max value", value = "")
sliderInput("range", "Smooth Parameter range:",min = 0, max = 1000, value = c(0,100)),
downloadButton('downloadData', 'Download')
),
mainPanel(helpText("Selected variables and Fitted values"),
verbatimTextOutput("other_val_show")))),
tabPanel("Model Summary", verbatimTextOutput("summary")),
tabPanel("Scatterplot", plotOutput("scatterplot"))#, # Plot
#tabPanel("Distribution", # Plots of distributions
#fluidRow(
#column(6, plotOutput("distribution1")),
#column(6, plotOutput("distribution2")))
#)
,inverse = TRUE,position="static-top",theme ="bootstrap.css"))
The following code in for the Server section. (I want to download the output which is "gr" and I want to download it by downloadHandler function.
server<-function(input,output) {
data <- reactive({
lower <- input$range[1]
upper <- input$range[2]
file1 <- input$file
if(is.null(file1)){return()}
read.table(file=file1$datapath, sep=input$sep, header = input$header, stringsAsFactors = input$stringAsFactors)
})
output$table <- renderTable({
if(is.null(data())){return ()}
data()
})
output$tb1 <- renderUI({
tableOutput("table")
})
#output$model_select<-renderUI({
#selectInput("modelselect","Select Algo",choices = c("Reference Interval"="Model"))
#})
output$var1_select<-renderUI({
selectInput("ind_var_select","Select Independent Variable", choices =as.list(names(data())),multiple = FALSE)
})
output$rest_var_select<-renderUI({
checkboxGroupInput("other_var_select","Select Dependent Variable",choices =as.list(names(data()))) #Select other Var
})
output$other_val_show<-renderPrint({
input$other_var_select
input$ind_var_select
f<-data()
lower <- input$range[1]
upper <- input$range[2]
library(caret)
library(quantregGrowth)
dep_vars <- paste0(input$ind_var_select, collapse = "+")
after_tilde <- paste0("ps(", dep_vars, ", lambda = seq(",lower,",",upper,",l=100))")
dyn_string <- paste0(input$other_var_select, " ~ ", after_tilde)
Model<-quantregGrowth::gcrq(as.formula(dyn_string),tau=c(0.025,0.975), data=f)
temp <- data.frame(Model$fitted)
gr <- cbind(f, temp)
print(gr)
})
output$downloadData <- downloadHandler(
write.csv(gr, file, row.names = FALSE)
)
}
shinyApp(ui=ui,server=server)
It's hard to fully answer this without a minimal reproducibile example, but here's what I would try:
Create gr outside of renderPrint
Use gr() in downloadHandler
Rewrite downloadHandler to include content and filename arguments
Here's a minimal example with the same logic as your app, i.e. create a reactive dataframe which is both printed (renderPrint) and downloadable (downloadHandler).
library(shiny)
ui <- navbarPage(title = "Example",
tabPanel("First",
selectInput("fruit", "Fruit", c("apple", "orange", "pear")),
h4("Output from renderPrint:"),
textOutput("other_val_show"),
h4("Download Button: "),
downloadButton("downloadData")))
server <- function(input, output) {
gr <- reactive({
data.frame(fruit = input$fruit)
})
output$other_val_show <- renderPrint({
print(gr())
})
output$downloadData <- downloadHandler(
filename = "example.csv",
content = function(file) {
write.csv(gr(), file)
})
}
shinyApp(ui, server)
You define gr inside the scope of that renderPrint function so it isn't available to downloadHandler. You should define gr as a reactive value somewhere outside that function. That way, when you assign it in the renderPrint function, it will be accessible to the entire scope of your program.
In the future, it would be helpful to provide the text of any error messages you get - they are often quite helpful to solving problems.