Related
In the following shiny app, the plotly package is used to create an interactive correlation heat map. When individual tiles are clicked, the corresponding scatter plot appears. One can then download the individual scatters by clicking download plot as png. But is there a way to download all the possible scatter plots at once without having to click each individual tile and save each individual one? Thank you
library(plotly)
library(shiny)
# compute a correlation matrix
correlation <- round(cor(mtcars), 3)
nms <- names(mtcars)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat"),
plotlyOutput("scatterplot")
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
plot_ly(x = nms, y = nms, z = correlation,
key = correlation, type = "heatmap", source = "heatplot") %>%
layout(xaxis = list(title = ""),
yaxis = list(title = ""))
})
output$selection <- renderPrint({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a cell in the heatmap to display a scatterplot"
} else {
cat("You selected: \n\n")
as.list(s)
}
})
output$scatterplot <- renderPlotly({
s <- event_data("plotly_click", source = "heatplot")
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(mtcars[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = ~x) %>%
add_markers(y = ~y) %>%
add_lines(y = ~yhat) %>%
layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plotly_empty()
}
})
}
shinyApp(ui, server)
You can use webshot to capture a static image of Plotly's HTML output using the instructions here: https://plot.ly/r/static-image-export/
An example for loop below generates random scatter plots from mtcars.
library(plotly)
library(webshot)
## You'll need to run the function the first time if you dont't have phantomjs installed
#webshot::install_phantomjs()
ColumnOptions <- colnames(mtcars)
for (i in seq_len(5)){
xCol <- sample(ColumnOptions,1)
yCol <- sample(ColumnOptions,1)
ThisFileName <- paste0("Scatter_",xCol,"_vs_",yCol,".png")
plot_ly(x = mtcars[[xCol]], y = mtcars[[yCol]], type = "scatter", mode = "markers") %>%
export(., file = ThisFileName)
}
However, if you're going to be potentially doing this dozens of times, the amount of computation required to go through the following steps really adds up.
Generate a JSON plotly object from R
Use htmlwidgets/htmltoolsto generate a self-contained HTML web page
Render that HTML as a browser would see it with an external program --webshot
Use webshot to render an image of that HTML and save it as a PNG
This isn't really a reflection of plotly being slow, but to make an analogy it's kind've like using an airplane to travel half a mile -- the plane gets you there, but if you need to make that trip more than a few times you should probably consider a car.
The plotly loop above takes 27 seconds to render 5 PNG images, but the alternative method below using ggplot2 takes 1.2 seconds.
library(ggplot2)
ColumnOptions <- colnames(mtcars)
for (i in seq_len(5)){
xCol <- sample(ColumnOptions,1)
yCol <- sample(ColumnOptions,1)
ThisFileName <- paste0("ggplot2_Scatter_",xCol,"_vs_",yCol,".png")
ggplot() +
geom_point(aes(x = mtcars[[xCol]], y = mtcars[[yCol]])) +
labs(x = xCol, y = yCol) -> ThisPlot
ggsave(plot = ThisPlot, filename = ThisFileName)
}
I'm in the process of creating my first Shiny app that returns a data table when a user interacts with a ggplot object (plot) with a mouse event. Using this example from RStudio, I've been able to produce something which filters and returns a data table (diamonds) based upon the position on the x-axis (cut). Its almost there... However, I have two outstanding issues that I have been unable to solve:
Is it possible to return a data table based upon a mouse event that is filtered by the y-axis (color) as well as the x-axis (cut)?
Following from (1), can the data table then be further filtered so that it returns only information from that facet (type)?
This is where I've got up to using reproducible code:
library(shiny)
library(dplyr)
library(ggplot2)
ui <- fluidPage(
fluidRow(
plotOutput("plot1", click = "plot1_click")),
fluidRow(column(width = 10, dataTableOutput("selected_rows"))))
server <- function(input, output) {
is.even <- function(x) x %% 2 == 0
plot <- diamonds %>%
mutate(cut = as.factor(cut)) %>%
mutate(colour = as.factor(color)) %>%
mutate(type = is.even(price)) %>%
group_by(type, color, cut) %>%
count()
output$plot1 <- renderPlot({
ggplot(plot, aes(x = cut, y = color, colour = type)) +
geom_point(aes(size = n)) +
facet_grid(~type) +
theme(legend.position = "none")
})
output$selected_rows <- renderDataTable({
if (is.null(input$plot1_click$x)) return()
keeprows <- round(input$plot1_click$x) == as.numeric(diamonds$cut)
diamonds[keeprows, ]
})
}
shinyApp(ui, server)
Any help would be much appreciated. Thanks in advance.
I believe this is possible if you do a bit more logic within output$selected_rows. To filter by the y variable, simply add a reference to input$plot1_click$y. For the facet (or panels), you'll want to use input$plot1_click$panelvar1:
keeprows_x <- round(input$plot1_click$x) == as.numeric(diamonds$cut)
keeprows_y <- round(input$plot1_click$y) == as.numeric(diamonds$color)
keeprows_panel <- input$plot1_click$panelvar1 == is.even(diamonds$price)
diamonds[keeprows_x & keeprows_y & keeprows_panel, ]
Note: I'm mimicing the logic for type with is.even(diamonds$price). You may want to see this github issue for further discussion and solutions.
I am new in R. now I am creating shiny app. R can read my dataset. with the comand myData <- read.csv("myData.csv"). however shinyServer file cannot read my data. and list no observation.
Could you guys help me what is the problem?
The Shinyapp provides interactive visulization for production of raw material in the world since 1900 to 2010 for every 10 years.
Also I keep getting this error:
"ERROR: 'breaks' are not unique"
The Code is here:
shinyUI(fluidPage(
checkboxInput("type", "Please Select production type:",
c("Aluminium", "Gold",
"Iron", "Silver", "Zinc")
),
sliderInput("year","Choose a Year",
min = 1910,
max = 2010,
value= 2010),
checkboxInput("Economy", "Please Select Economy Factor:",
c("Income Inequallity", "labourers Real Wage", "GDP", "Inflation")),
plotOutput("thisPlot"),
leafletOutput("myMap")
)
)
shinyServer:
myData <- read.csv("myData.csv")
shinyServer<- function(input,output){
output$myMap <- renderLeaflet({
temp <- which(myData$type == input$type &
myData$year == input$year)
myData <- myData[temp,]
pal <- colorQuantile("YlGn", myData$production, n = 9)
country_popup <- paste0("<strong>Estado: </strong>", myData$Country)
leaflet(data = myData) %>%
setView(46.227638, 2.213749, zoom = 2) %>%
addTiles() %>%
addPolygons( lng = ~myData$Long, lat = ~myData$Lat,
fillColor = ~pal(myData$production),
fillOpacity = 0.8,
color = "#BDBDC3",
weight = 1,
popup = country_popup)
})
}
the data is:
Names = c("id",
"Country", "type", "year", "production", "GDP", "Income", "Inflation",
"Laborer", "Lat", "Long"), class = "data.frame", row.names = c(NA,
-10670L))
head(myData)
id Country type year production GDP Income Inflation Laborer Lat
Long
1 1 Guyana Gold 1910 0.000000 0 42.43048 0 154.45527 4.860416
-58.9301
it seems that it does read the data but it does not show it. and i have a problem with creating the choropleth map. which it does not work now in my shiny.
Yeah, leaflet is finicky. I didn't have to make a lot of changes, you almost had it. One of the main problems was that your filter was usually yielding an empty dataframe which caused the markers not to show (of course).
This empty dataframe problem is also the cause for the "ERROR: 'breaks' are not unique" message since colorQuantile is getting a null input for its domain argument, which means it is doing an empty quantile, and all the breaks are zero and thus "not unique". This can also happen with highly skewed data. You should avoid calling it in that case - maybe fallback on colorBin, although detecting that can be a bit complicated.
The following changes were made.
Added some fake data.
Changed addPolygons to addCircleMarkers as addPolygons is for adding arbitray shapes that you specify.
Changed your checkBoxInput to checkBoxGroupInput as you didn't want a checkbox, you wanted a group of them.
Changed the filter clause to use myData$type %in% input$type instead of myData$type == input$type as you probably wanted membership.
truncated the input$year value as it might not give back an integer, but your year values are definitely integers.
Changed the border color to "black" so you could see it on the circle.
Note that the popup does not come on hover, you have to click on the circle.
removed the myData on the marker input as you have specified it on the leaflet call.
commented out the plotOutput as I don't know what you want to plot.
Here is the code - this should get you started:
library(shiny)
library(leaflet)
# fake-up some data
n <- 10000
countrylist <- c("Guyana","Venezuela","Columbia")
typelist <- c("Aluminium", "Gold","Iron", "Silver", "Zinc")
types <- sample(typelist,n,replace=T)
cntrs <- sample(countrylist,n,replace=T)
lat <- 2.2 + 50*runif(n)
long <- -46 + 50*runif(n)
year <- sample(1910:2010,n,replace=T)
prd <- 100*runif(n)
myData <- data.frame(Country=cntrs,type=types,year=year,production=prd,Long=long,Lat=lat)
u <- shinyUI(fluidPage(
checkboxGroupInput("type", "Please Select production type:",
c("Aluminium", "Gold","Iron", "Silver", "Zinc"),
selected=c("Gold","Silver")
),
sliderInput("year","Choose a Year",
min = 1910,
max = 2010,
value= 2010),
checkboxGroupInput("Economy", "Please Select Economy Factor:",
c("Income Inequallity", "labourers Real Wage", "GDP", "Inflation")),
# plotOutput("thisPlot"),
leafletOutput("myMap")
)
)
s <- function(input,output){
output$myMap <- renderLeaflet({
temp <- which(myData$type %in% input$type &
myData$year == trunc(input$year))
print(nrow(myData))
myData <- myData[temp,]
print(nrow(myData))
pal <- colorQuantile("YlGn", myData$production, n = 9)
country_popup <- paste0("<strong>Estado: </strong>", myData$Country)
leaflet(data = myData) %>%
setView(-46.227638, 2.213749, zoom = 2) %>%
addTiles() %>%
addCircleMarkers( lng = ~Long, lat = ~Lat,
fillColor = ~pal(myData$production),
radius = 6, # pixels
fillOpacity = 0.8,
color = "black",
weight = 1,
popup = country_popup)
})
}
shinyApp(u,s)
And this is the result:
I am using ggvis and have the following code with a selectInput on the UI side allowing the user to select which variable dictates fill and shape (inputId is fill and shape respectively). I want the plot to have the ability to have a constant fill or shape should the user choose. The else section of this code works exactly how I want, but when I select the option in the if statement the app crashes with the following error:
Error in eval: could not find function ":="
I know I have the syntax correct because if I suppress the legends and the if/else statement and specify the fill as constant (fill := "black") it works how I want it to.
Any help would be appreciated.
vis <- reactive({
fillvar <- prop("fill", as.symbol(input$fill))
shapevar <- prop("shape", as.symbol(input$shape))
filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
# Allows for points to be consistent if the user desires
if (input$fill == "All Points Black") {
fill := "black"}
else {
fill = fillvar}
,
if (input$shape == "All Points Circles") {
shape := "circle"}
else {
shape = shapevar}
,
key := ~ID
) %>%
# Adds legends to the Plot in designated locations
add_legend("fill", title = as.character(fillvar)) %>%
add_legend("shape", title = as.character(shapevar), properties = legend_props(legend = list(y=300))) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 400, duration = 0)
})
#Actually plots the data
vis %>% bind_shiny("plot1")
As I mentioned in a comment, you can create a variable for prop using an if statement. This allows you to bypass the issue of := by using either a constant or a variable directly in prop.
You get legends automatically. To control the placement when you have two legends (which will lead to an overlap), you can name your ggvis graph. This allows you to refer to add elements to the graphic in order to move the second legend down only when it is added based on logic and your shapevar and fillvar values.
Here's the code just for the reactive function.
vis <- reactive({
fillvar = "black"
if(input$fill != "All Points Black") {
fillvar = as.name(input$fill)
}
shapevar = "circle"
if(input$shape != "All Points Circles") {
shapevar = as.name(input$shape)
}
p1 = filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
prop("fill", fillvar),
prop("shape", shapevar),
key := ~ID
) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 400, duration = 0)
# Control addition of second legend using if() on p1 object
if(fillvar != "black" & shapevar != "circle") {
p1 %>% add_legend("shape", properties = legend_props(legend = list(y=300)))
}
else {
p1
}
})
The code now is functional with input from #aosmith as I want it to be if the legend is suppressed. However, when I do this, the legend for fill and shape overlap as this post addresses.
legends on ggvis graph are overlaping when using tooltip
The fix for that is to add in a legend which makes the plot disappear if the constant data visualization option is selected. I will post a new question to try and get this issue resolved.
UPDATE: The answer below solves the original issue, but #aosmith's answer fixed a second issue that arose after correcting the first issue as well.
My code with the corrected original issue, but containing an overlapping legend (corrected with #aosmith's answer) is below.
vis <- reactive({
# Allows for points to be consistent if the user desires
if (input$fill == "All Points Black") {
fillvar = "black"}
else {
fillvar <- as.symbol(input$fill)}
if (input$shape == "All Points Circles") {
shapevar = "circle"}
else {
shapevar <- as.symbol(input$shape)}
#Plot Data with Visualization Customization
xvar <- prop("x", as.symbol(input$x))
yvar <- prop("y", as.symbol(input$y))
filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
prop("fill", fillvar),
prop("shape", shapevar),
key := ~Shot_ID
) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 450, duration = 0)
})
#Actually plots the data
vis %>% bind_shiny("plot1")
I have read now the stackoverflow Q&A for several hours on various days and have also seen the latest specific Shiny debugging video from the Shiny developer conference (Jonathan McPherson):
Now the problem looks simple to me, but I went through lots of checks, revisions of the naming conventions and thought of various hypotheses: Making column titles starting with capital letters, calling the initial file similar to the template, renaming the column titles, ...
I like the interactive scatter plots from the Movie Gallery and would like to reproduce it with my own records, located in a cvs file, which I uploaded in my RStudio session with the name all_flexitime, which I understand now is not enough.
How do I connect or integrate my cvs file into the given template? I have renamed all necessary fields, I believe. The error I am getting says:
Error in eval(substitute(expr), envir, enclos) :
object 'Flexileave2015' not found
Flexileave2015 is, I believe, the first variable the server file is looking for to produce the scatter plot, but since the file needs to be found somewhere in the server file, it cannot find it there. I can see it in my Studio.
Can somebody confirm my understanding and possibly help, please.
My all_flexitime data frame is made of the following columns titles:
"Number", "First", "Last", "Contract", "Grade", "Flexileave2015", "Certifiedsickleave2015", "Uncertifiedsickleave2015", "Daysnotrecorded2015", "Excess2015".
My server.R is:
library(ggvis)
library(dplyr)
if (FALSE) library(RSQLite)
shinyServer(function(input, output, session) {
# Filter staff, returning a data frame
flexitimes <- reactive({
# Due to dplyr issue #318, we need temp variables for input values
flexileave2015 <- input$flexileave2015
certifiedsickleave2015 <- input$certifiedsickleave2015
uncertifiedsickleave2015 <- input$uncertifiedsickleave2015
daysnotrecorded2015 <- input$daysnotrecorded2015
excess2015 <- input$excess2015
# Apply filters
m <- all_flexitimes %>%
filter(
Flexileave2015 >= flexileave2015,
Excess2015 >= excess2015,
Certifiedsickleave2015 >= certifiedsickleave2015,
Uncertifiedsickleave2015 >= uncertifiedsickleave2015,
Daysnotrecorded2015 >= daysnotrecorded2015
) %>%
arrange(Flexileave2015)
# Optional: filter by Contract
if (input$contract != "All") {
contract <- paste0("%", input$contract, "%")
m <- m %>% filter(Contract %like% contract)
}
# Optional: filter by Grade
if (input$grade != "All") {
grade <- paste0("%", input$grade, "%")
m <- m %>% filter(Grade %like% grade)
}
# Optional: filter by Number
if (!is.null(input$number) && input$number != "") {
number <- paste0("%", input$number, "%")
m <- m %>% filter(Number %like% number)
}
# Optional: filter by Last Name
if (!is.null(input$last) && input$last != "") {
last <- paste0("%", input$last, "%")
m <- m %>% filter(Last %like% last)
}
m <- as.data.frame(m)
m
})
# Function for generating tooltip text
flexitime_tooltip <- function(x) {
if (is.null(x)) return(NULL)
if (is.null(x$Number)) return(NULL)
# Pick out the staff with this Number
all_flexitimes <- isolate(flexitimes())
flexitime <- all_flexitimes[all_flexitimes$Number == x$Number, ]
paste0("<b>", flexitime$First, flexitime$Last, "</b><br>",
flexitime$Grade, "<br>",
flexitime$Contract
)
}
# A reactive expression with the ggvis plot
vis <- reactive({
# Lables for axes
xvar_name <- names(axis_vars)[axis_vars == input$xvar]
yvar_name <- names(axis_vars)[axis_vars == input$yvar]
# Normally we could do something like props(x = ~BoxOffice, y = ~Reviews),
# but since the inputs are strings, we need to do a little more work.
xvar <- prop("x", as.symbol(input$xvar))
yvar <- prop("y", as.symbol(input$yvar))
flexitimes %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
key := ~ Number) %>%
add_tooltip(flexitime_tooltip, "hover") %>%
add_axis("x", title = xvar_name) %>%
add_axis("y", title = yvar_name) %>%
set_options(width = 500, height = 500)
})
vis %>% bind_shiny("plot1")
output$n_flexitimes <- renderText({ nrow(flexitimes()) })
})
The ui.R file is the following:
library(ggvis)
# For dropdown menu
actionLink <- function(inputId, ...) {
tags$a(href='javascript:void',
id=inputId,
class='action-button',
...)
}
shinyUI(fluidPage(
titlePanel("Overview of Flexitime usage"),
fluidRow(
column(3,
wellPanel(
h4("Filter"),
sliderInput("flexileave2015", "Flexileave 2015", 0, 14, 0, step = 1),
sliderInput("certifiedsickleave2015", "Certified sickleave 2015", 0, 230, 0, step = 1),
sliderInput("uncertifiedsickleave2015", "Uncertified sickleave 2015", 0, 13, 0, step = 1),
sliderInput("daysnotrecorded2015", "Days not recorded 2015", 0, 110, 0, step = 10),
sliderInput("excess2015", "Excess 2015", -100, 1500, 0, step = 50),
selectInput("contract", "Contract",
c("All", "Temporary Agent", "Contract Agent", "National Expert", "Interim")),
selectInput("grade", "Grade",
c("All", "AD05","AD06","AD07","AD08","AD09", "AD10","AD11", "AD12","AD13", "AD14","AD15","AST01","AST02","AST03","AST04","AST05","AST06","AST07",
"AST08","AST09","AST10","FGII.04","FGII.05","FGII.06","FGIII.08","FGIII.09","FGIII.10",
"FGIV.13","FGIV.14","FGIV.16","FGIV.18","SNE")),
textInput("number", "SAP Personnelnumber"),
textInput("last", "Initial of Last Name")
),
wellPanel(
selectInput("xvar", "X-axis variable", axis_vars, selected = "Flexileave2015"),
selectInput("yvar", "Y-axis variable", axis_vars, selected = "Uncertifiedsickleave2015"),
tags$small(paste0(
"Note: AD and AST are Temporary agent grades.",
" FG are Contract agent grades.",
" SNE is the only National expert grade.",
" Interims should not have an FG grade."
))
)
),
column(9,
ggvisOutput("plot1"),
wellPanel(
span("Number of staff members selected:",
textOutput("n_flexitimes")
)
)
)
)
))
I got external help for my shiny app, so I am posting how I sorted the problems in the end:
There was a spelling mistake for the all_flexitime data set, I changed it to be all_flexitimes.
In the preparatory work file (the one where I created the original database), I have made sure that the variables are read as characters and not as factors:
all_flexitimes$Grade <- as.character(all_flexitimes$Grade)
all_flexitimes$Contract <- as.character(all_flexitimes$Contract)
all_flexitimes$First <- as.character(all_flexitimes$First)
all_flexitimes$Last <- as.character(all_flexitimes$Last)
I have saved the all_flexitimes file into an .RData file via the following command, while I was in the RStudio working environment:
saveRDS(all_flexitimes, "all_flexitimes.RData")
In the global.R file I have added at the end the following line, so that the database can be read:
all_flexitimes <- readRDS("all_flexitimes.Rdata")
In the ui.file I used the following, as this was the safer option, as it avoids any misspelling:
selectInput("contract", "Contract",
c("All", sort(unique(all_flexitimes$Contract)))),
selectInput("grade", "Grade",
c("All", sort(unique(all_flexitimes$Grade)))),
In the server file, I have changed the manual filters to:
Optional: filter by Contract
if (input$contract != "All") {
contract <- paste0("%", input$contract, "%")
m <- m %>% filter(Contract == input$contract)
}
Optional: filter by Grade
if (input$grade != "All") {
grade <- paste0("%", input$grade, "%")
m <- m %>% filter(Grade == input$grade)
}
Optional: filter by Number
if (!is.null(input$number) && input$number != "") {
number <- paste0("%", input$number, "%")
m <- m %>% filter(Number == input$number)
}
Optional: filter by Last Name
if (!is.null(input$last) && input$last != "") {
last <- paste0("%", input$last, "%")
m <- m %>% filter(Last == input$last)