I'm trying to write a little app that will allow the user to make a scatterplot, select a subset of points on the plot, then output a table in .csv format with just those selected points. I figured out how to get the page up and running and how to select points using brushedPoints. The table with selected points appears but when I press the Download button, the error "Reading objects from shinyoutput object not allowed." appears. Am I unable to download the table that I can visually see on the screen as a .csv? If so, is there a workaround?
I've recreated the problem using the iris dataset below. Any help figuring out why I cannot download the table of displayed rows would be greatly appreciated.
data(iris)
ui <- basicPage(
plotOutput("plot1", brush = "plot_brush"),
verbatimTextOutput("info"),mainPanel(downloadButton('downloadData', 'Download'))
)
server <- function(input, output) {
output$plot1 <- renderPlot({
ggplot(iris,aes(x=Sepal.Width,y=Sepal.Length)) +
geom_point(aes(color=factor(Species))) +
theme_bw()
})
output$info <- renderPrint({
brushedPoints(iris, input$plot_brush, xvar = "Sepal.Width", yvar = "Sepal.Length")
})
output$downloadData <- downloadHandler(
filename = function() {
paste('SelectedRows', '.csv', sep='') },
content = function(file) {
write.csv(output$info, file)
}
)
}
shinyApp(ui, server)
The issue is that the output object is generating all of the web display stuff as well. Instead, you need to pull the data separately for the download. You could do it with a second call to brushedPoints in the download code. Better, however, is to use a reactive() function to do it just once, then call that everywhere that you need it. Here is how I would modify your code to make that work:
data(iris)
ui <- basicPage(
plotOutput("plot1", brush = "plot_brush"),
verbatimTextOutput("info"),mainPanel(downloadButton('downloadData', 'Download'))
)
server <- function(input, output) {
output$plot1 <- renderPlot({
ggplot(iris,aes(x=Sepal.Width,y=Sepal.Length)) + geom_point(aes(color=factor(Species))) + theme_bw()
})
selectedData <- reactive({
brushedPoints(iris, input$plot_brush)
})
output$info <- renderPrint({
selectedData()
})
output$downloadData <- downloadHandler(
filename = function() {
paste('SelectedRows', '.csv', sep='') },
content = function(file) {
write.csv(selectedData(), file)
}
)
}
shinyApp(ui, server)
(Note, with ggplot2, you do not need to explicitly set xvar and yvar in brushedPoints. So, I removed it here to increase the flexibility of the code.)
I am not aware of any "lasso" style free drawing ability in shiny (though, give it a week -- they are constantly adding fun tools). However, you can mimic the behavior by allowing user to select multiple regions and/or to click on individual points. The server logic gets a lot messier, as you need to store the results in a reactiveValues object to be able to use it repeatedly. I have done something similar to allow me to select points on one plot and highlight/remove them on other plots. That is more complicated than what you need here, but the below should work. You may want to add other buttons/logic (e.g., to "reset" the selections), but I believe that this should work. I did add a display of the selection to the plot to allow you to keep track of what has been selected.
data(iris)
ui <- basicPage(
plotOutput("plot1", brush = "plot_brush", click = "plot_click")
, actionButton("toggle", "Toggle Seletion")
, verbatimTextOutput("info")
, mainPanel(downloadButton('downloadData', 'Download'))
)
server <- function(input, output) {
output$plot1 <- renderPlot({
ggplot(withSelected()
, aes(x=Sepal.Width
, y=Sepal.Length
, color=factor(Species)
, shape = Selected)) +
geom_point() +
scale_shape_manual(
values = c("FALSE" = 19
, "TRUE" = 4)
, labels = c("No", "Yes")
, name = "Is Selected?"
) +
theme_bw()
})
# Make a reactive value -- you can set these within other functions
vals <- reactiveValues(
isClicked = rep(FALSE, nrow(iris))
)
# Add a column to the data to ease plotting
# This is really only necessary if you want to show the selected points on the plot
withSelected <- reactive({
data.frame(iris
, Selected = vals$isClicked)
})
# Watch for clicks
observeEvent(input$plot_click, {
res <- nearPoints(withSelected()
, input$plot_click
, allRows = TRUE)
vals$isClicked <-
xor(vals$isClicked
, res$selected_)
})
# Watch for toggle button clicks
observeEvent(input$toggle, {
res <- brushedPoints(withSelected()
, input$plot_brush
, allRows = TRUE)
vals$isClicked <-
xor(vals$isClicked
, res$selected_)
})
# pull the data selection here
selectedData <- reactive({
iris[vals$isClicked, ]
})
output$info <- renderPrint({
selectedData()
})
output$downloadData <- downloadHandler(
filename = function() {
paste('SelectedRows', '.csv', sep='') },
content = function(file) {
write.csv(selectedData(), file)
}
)
}
shinyApp(ui, server)
Related
My app allows the user to generate some plots and save them as png.
I want the app as well to update a csv file based on some inputs made into the app by the user.
For example purposes, I created a toy app that generates a csv file in a given folder.
In both cases, the app doesn't display any error message or info, but it doesn't store any file anywhere.
library(shiny)
library(ggplot2)
library(AlphaPart)
ui <- fluidPage(
selectInput("var1","Select var1", choices = names(iris)),
selectInput("var2","Select var2", choices = names(iris)),
plotOutput("myplot"),
downloadLink("downloadPlot", label = icon("download")))
server <- function(input, output, session) {
data <- reactive(iris)
var1 <- reactive({input$var1})
var2 <- reactive({input$var2})
# Genearte plot
draw_boxplot <- function(data, var1, var2){
ggplot(data=data(), aes(x=.data[[input$var1]], y = .data[[input$var2]]))+
geom_boxplot()
}
plot1 <- reactive({
req(data(), input$var1, input$var2)
draw_boxplot(data(), var1(), var2())
})
output$myplot <- renderPlot({
plot1()
})
#Download
output$downloadPlot <- downloadHandler(
filename = function() {
return("Plot.png")
},
content = function(file) {
png(file)
print(plot1())
dev.off()
})
#Write csv
eventReactive(input$downloadPlot, {
dat <- as.data.frame(c(input$num_var_1, input$num_var_2))
write.csv(dat, "C:/dat.csv", row.names = FALSE)
})
}
shinyApp(ui, server)
library(shiny)
library(ggplot2)
library(AlphaPart)
library(spsComps)
ui <- fluidPage(
selectInput("var1","Select var1", choices = names(iris)),
selectInput("var2","Select var2", choices = names(iris)),
plotOutput("myplot"),
downloadLink("downloadPlot", label = icon("download")))
server <- function(input, output, session) {
data <- reactive(iris)
var1 <- reactive({input$var1})
var2 <- reactive({input$var2})
# Genearte plot
draw_boxplot <- function(data, var1, var2){
ggplot(data=data(), aes(x=.data[[input$var1]], y = .data[[input$var2]]))+
geom_boxplot()
}
plot1 <- reactive({
req(data(), input$var1, input$var2)
draw_boxplot(data(), var1(), var2())
})
output$myplot <- renderPlot({
plot1()
})
#Download
downloaded <- reactiveVal(0)
output$downloadPlot <- downloadHandler(
filename = function() {
return("Plot.png")
},
content = function(file) {
png(file)
print(plot1())
dev.off()
on.exit({spsComps::incRv(downloaded)})
})
#Write csv
observeEvent(downloaded(), {
dat <- as.data.frame(c(input$num_var_1, input$num_var_2))
utils::write.csv(dat, "dat.csv", row.names = FALSE)
print("File saved")
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
Unfortunately, you can't observe download event. So here we do, introduce another reactiveVal which we can change inside the download event so we will know if the download button has been clicked.
spsComps::incRv is a short hand function for downloaded(isolate(downloaded()) + 1), so it increase the reactiveVal every time by one.
use on.exit on the end to make sure this happens only when the plot is successful.
Instead of using eventReactive, observeEvent should be used since you are not returning any value but just write a file.
I have a scatterplot in a shiny dashbaord and would like to generate two different tables by selecting/highlighting different areas of the scatterplot. I am currently able to generate a single table by selecting/highlighting an area, however am not sure how to make this work for two tables/selections (or if that is even possible).
Any help or advice would be greatly appreciated. Thankyou
Sample code to generate a shiny dashboard with a scatterplot and highlight/generate a single table is provided below (and was taken from here)
Some more detail : Ideally this process would be achieved by manually selecting/dragging an area over some points, generating the first table and then manually selecting/dragging an area over a different subset of points and generating the second table. After this, if another area is selected, it resets the first selection and table and then the next selection would reset the second selection and table.
ui <- fluidPage(
plotOutput("plot", brush = "plot_brush"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
brushedPoints(mtcars, input$plot_brush)
})
}
shinyApp(ui=ui, server=server)
Maybe this might be helpful. You can track which table (1 or 2) in reactiveValues as well as the data for each table. Let me know if this is what you had in mind. If you wanted to maintain the previous selection in the plot, I would think you may need to manually place a rectangle. A github issue allowing for multiple selections of brushed points is an open issue (enhancement). Alternatively, you could tag points for each table based on this approach.
library(shiny)
ui <- fluidPage(
plotOutput("plot", brush = "plot_brush"),
h2("Table 1"),
tableOutput("data1"),
h2("Table 2"),
tableOutput("data2")
)
server <- function(input, output, session) {
rv <- reactiveValues(table = 1,
data1 = NULL,
data2 = NULL)
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
my_data <- eventReactive(input$plot_brush, {
if (rv$table == 1) {
rv$table <- 2
rv$data1 <- input$plot_brush
} else {
rv$table <- 1
rv$data2 <- input$plot_brush
}
return(rv)
})
output$data1 <- renderTable({
brushedPoints(mtcars, my_data()$data1)
})
output$data2 <- renderTable({
brushedPoints(mtcars, my_data()$data2)
})
}
shinyApp(ui=ui, server=server)
I'm simply looking to return a user-produced plot (built in ggplot) or a data table from an app built from modules and a plotting helper function. I've seen many posts about downloadHandler being very finicky and there even appears to be open issues with some of downloadHandler's behaviours. The odd behaviour I'm getting, which I haven't seen posts about, is that it returns an html page of my app instead of the plot, regardless of how I try to save the plot (i.e., using pdf/png devices, ggsave(), etc.), or whether I use suspendWhenHidden. I can run the plot saving code external to Shiny and it works fine. I'm running all of this from the browser (Firefox, though Chrome does the same) on a mac, with recently updated everything.
Example code below.
Modules:
library(shiny)
library(ggplot2)
# UI module
modUI <- function(id, label="inputvalues") {
ns <- NS(id)
tagList(
numericInput(ns("mean"), "Mean",value = NULL),
numericInput(ns("sd"),"Std. Dev.",value = NULL),
actionButton(ns("draw"),"Draw plot"),
downloadButton(ns("dlPlot"), "Download Plot")
)
}
# Server Logic module
mod <- function(input, output, session) {
x <- reactiveValues(data=NULL)
observeEvent(input$draw, {
x$data <- rnorm(100,input$mean,input$sd)
})
return(list(dat = reactive({x$data}),
m = reactive({input$mean}),
s = reactive({input$sd})
)
)
}
Plotting helper function:
showPlot <- function(data, m, s) {
d <- data.frame(data)
p <- ggplot(d, aes(x=d, y=d)) +
geom_point() +
geom_vline(xintercept=m)
p
}
UI and Server calls:
ui <- navbarPage("Fancy Title",id = "tabs",
tabPanel("Panel1",value = 1,
sidebarPanel(
modUI("input1")
),
mainPanel(plotOutput("plot1"))
)
)
server <- function(input, output, session) {
y <- callModule(mod, "input1")
output$plot1 <- renderPlot({
if (is.null(y$dat())) return()
showPlot(data.frame(y$dat()), y$m(), y$s())
})
output$dlPlot <- downloadHandler(
filename="~Plot_Download.pdf",
content=function(file){
pdf(filename, file)
p
dev.off()
}
)
}
shinyApp(ui, server)
Thanks as always for any help!
Finally figured out an answer to this, based in large part on this post. The answer is to create a server module specifically for the download (which can take the session and namespace info), and then to call that module in the server. Additional and updated code below:
The new download module:
dlmodule <- function(input, output, session) {
output$dlPlot <- downloadHandler(
filename="Plot_Download.pdf",
content=function(file){
ggsave(file, device = pdf, width = 7,height = 5,units = "in",dpi = 200)
}
)
}
The updated server call:
server <- function(input, output, session) {
y <- callModule(mod, "input1")
output$plot1 <- renderPlot({
if (is.null(y$dat())) return()
showPlot(data.frame(y$dat()), y$m(), y$s())
})
dl.y <- callModule(dlmodule, "input1")
}
Everything else stays the same.
I am using plot_click to interrogate a graph in Shiny and would like the conditional panel to show 2 bits of information. However at the moment, the conditional panel shows 'NA' until i perform the plot click, how do i make this disappear?
library(ggplot2)
library(shiny)
# make some data
df <- data.frame(ID=c(1,2),x=c(33,7),y=c(50,16),name=c("Tom","Bill"),link=c("https://mylink.com","https://anotherlink.com"), stringsAsFactors=FALSE)
# Shiny app
ui <- basicPage(
plotOutput("plot", click = "plot_click"),
verbatimTextOutput("selection"),
conditionalPanel("!is.na(output.nametext)",
h4(textOutput("nametext")),
h4(textOutput("urltext")))
)
server <- function(input, output,session) {
output$plot <- renderPlot({
ggplot(data=df,aes(x=x,y=y))+
geom_point()+
scale_x_continuous(limits = c(0, 68))+
scale_y_continuous(limits = c(0, 52.5))
})
output$selection <- renderPrint({
nearPoints(df, input$plot_click)
})
info <- reactive({
t <- as.data.frame(nearPoints(df, input$plot_click))
s <- t[1,4]
u <- t[1,5]
list(s=s,u=u)
})
output$nametext <- renderText({info()$s})
output$urltext <- renderText({info()$u})
}
runApp(shinyApp(ui, server), launch.browser = TRUE)
in the conditionalPanel in the UI, i've tried !is.na(output.nametext), output.nametext != null, output.nametext==true, plot_click==true, plot_click!=null and more. None of them remove the NA that exists before i perform the click.
One solution would be to simply use:
output$nametext <- renderText({
if(!is.na(info()$s)){
info()$s
}
})
You could also use the space to inform the user he should click a point to see information:
output$urltext <- renderText({
if(!is.na(info()$s)){
info()$u
}else{
print("Click on a point to get additional information")
}
})
I've been stuck on this problem for two days now, and I would love some help from people much smarter than me. I am using a package called "shinyTable"(https://github.com/trestletech/shinyTable), and I am having a hard time manipulating it. Basically, how can I make this table change its size based on input$rows IF I click on the "submit" button?Here is a working code w/o the "submit" button:
library(shinythemes)
library(shiny)
library(shinyTable)
ui <- fluidPage(theme = shinytheme("slate"),titlePanel(HTML("<h1> <font face=\"Rockwell Extra Bold\" color=\"#b42000\"><b><b>R/Econ</b></b></font> <font face=\"Lucida Calligraphy\" colsor=\"white\" >Model</font></h1>")),
sidebarLayout(
sidebarPanel(
numericInput("rows", label = h3("Number of Rows"), value = 20),
numericInput("cols", label = h3("Number of Columns"), value = 2)
),
mainPanel(
htable("tbl")
)
)
)
server <- function(input, output)
{
output$tbl <- renderHtable({
if (is.null(input$tbl)){
# Seed the element with some data initially
tbl <- data.frame(list(num1=1:input$rows,
num2=(1:input$rows)*20,
letter=LETTERS[1:(input$rows)]))
cachedTbl <<- tbl
print(tbl)
return(tbl)
} else{
cachedTbl <<- input$tbl
print(input$tbl)
return(input$tbl)
}
})
}
shinyApp(ui = ui, server = server)
Now, I want the table's size to change dynamically when my input$rows or input$cols changes. I cannot for the life of me figure out how to make this work. I tried the following:
myx<-eventReactive (input$submit, {
output$tbl <- renderHtable({
if (is.null(input$tbl)){
tbl <- data.frame(list(num1=1:input$rows,
num2=(1:input$rows)*20,
letter=LETTERS[1:(input$rows)]))
cachedTbl <<- tbl
print(tbl)
return(tbl)
} else{
cachedTbl <<- input$tbl
print(input$tbl)
return(input$tbl)
}
})
})
But this doesn't work. My thought process was that if the submit button is clicked, it would recreate the table. I want input$rows to change the size of the table, but neither my changing the size nor my clicking on a submit button does anything. In fact, adding eventReactive changes the table to where it has no values, and no values can be inputted. I'm honestly lost. I tried other variations of this such as this:
myx<-eventReactive (input$submit, {
if (is.null(input$tbl)){
tbl <- data.frame(list(num1=1:input$rows,
num2=(1:input$rows)*20,
letter=LETTERS[1:(input$rows)]))
cachedTbl <<- tbl
print(tbl)
return(tbl)
} else{
cachedTbl <<- input$tbl
print(input$tbl)
}
})
#-------
# myx2<-eventReactive (cachedTbl, {
# })
output$tbl <- renderHtable({
tbl<<-myx()
print(data.frame(tbl))#Tried and failed using myx()
return(data.frame(tbl))
})
In doing this, I thought I can make the table reactive and then pass it to renderHTable. All these attempts share the fact that I'm trying to make things reactive.
How can I make this table change its size based on input$rows IF I click on the "submit" button? Please help!
This should get you started. As per my comment, you should use rhandsontable. This package uses the same underlying JS library, handsontable.JS, but it is well supported and it is on Cran (disclaimer: I'm a minor contributor to this package).
The working example below is based on rhandsontable. For simplicity I've only implemented the change of the number of rows.
Please take into account that I haven't implemented any type of caching mechanism, either to a global variable, or to a reactive variable, as it wasn't necessary, but it can easily be added.
This is the only example that I know of a library working in shiny where there is an output$something linked to an input$something.
In this case the input$tbl in the code refer to the table, but to be converted to a data frame it needs to be transformed by the convenience function hot_to_r (handsontable to R).
I am sure you are already familiar with this: you use hot_to_r(input$tbl) to check if the user has changed anything in the displayed table (assuming it is not read-only). shinyTable has a much more complicated mechanism, but it is prone to races.
library(shinythemes)
library(shiny)
library(rhandsontable)
ui <- fluidPage(theme = shinytheme("slate"),titlePanel(HTML("<h1> <font face=\"Rockwell Extra Bold\" color=\"#b42000\"><b><b>R/Econ</b></b></font> <font face=\"Lucida Calligraphy\" colsor=\"white\" >Model</font></h1>")),
sidebarLayout(
sidebarPanel(
numericInput("rows", label = h3("Number of Rows"), value = 20),
numericInput("cols", label = h3("Number of Columns"), value = 2)
),
mainPanel(
rHandsontableOutput("tbl")
)
)
)
server <- function(input, output, session) {
data = reactive({
if (is.null(input$tbl)) {
DF <- data.frame(num1 = 1:input$rows, bool = TRUE, nm = LETTERS[1:input$rows],
dt = seq(from = Sys.Date(), by = "days", length.out = input$rows),
stringsAsFactors = F)
} else if(nrow(hot_to_r(input$tbl)) == input$rows) {
DF <- hot_to_r(input$tbl)
} else {
DF <- data.frame(num1 = 1:input$rows, bool = TRUE, nm = LETTERS[1:input$rows],
dt = seq(from = Sys.Date(), by = "days", length.out = input$rows),
stringsAsFactors = F)
}
DF
})
output$tbl <- renderRHandsontable({
if (is.null(input$rows) | is.null(input$cols)) return()
df = data()
if (!is.null(df))
rhandsontable(df, stretchH = "all")
})
}
shinyApp(ui = ui, server = server)
Please let me know if this works for you, else I'll do my best to change it as per your needs.