I have a set of charts and several tables on a Shiny pages. What would be the best way to create a download button to allow user download all of them to one file (i.e pdf). I tried grid.arrange but I am not sure how to convert the highchart objects to grobs objects.
Samples of outputs are below:
library("shiny")
library("highcharter")
data(citytemp)
ui <- fluidPage(
fluidRow(
column(width = 8,
highchartOutput("hcontainer1",height = "500px")),
column(width = 8,
highchartOutput("hcontainer2",height = "500px")),
column(width = 8,
highchartOutput("hcontainer3",height = "500px")),
column(width = 12,dataTableOutput("table"))
)
)
server = function(input, output) {
output$hcontainer1 <- renderHighchart({
hc <- highcharts_demo() %>%
hc_rm_series("Berlin") %>%
hc_chart(type = "line")
hc
})
output$hcontainer2 <- renderHighchart({
hc <- highcharts_demo() %>%
hc_rm_series("Berlin") %>%
hc_chart(type = "bar")
hc
})
output$hcontainer3 <- renderHighchart({
hc <- highcharts_demo() %>%
hc_rm_series("Berlin") %>%
hc_chart(type = "column")
hc
})
output$table <- renderDataTable({
dt <- data.frame(iris[1:10,])
dt
})
}
shinyApp(ui = ui, server = server)
Just try putting a download button at each column. I am unable to install highcharter now so I didn't fully test the code. Let me know if you are having issues -
column(width = 8,
highchartOutput("hcontainer1",height = "500px"), downloadButton("downloadplot1", label = "Download"))
Write a separate function for generating the plot -
gen_plot <- function(series_name, chart_type){
hc <- highcharts_demo() %>%
hc_rm_series(series_name) %>%
hc_chart(type = chart_type)
hc
}
Now in server -
output$downloadplot1 <- downloadHandler(filename ="1.png",
content = function(file) {
png(file, width=800, height=800)
gen_plot("Berlin", "line")
dev.off()
},
contentType = "image/png")
Related
In the relatively simple shiny application below I select a point on load. Once the user chooses a new number in the selector I'd like highcharter to select that point instead. In other words, if the user selects 1 then then it should select the 1st point.
Suggestions for how to do this?
library(shiny)
library(highcharter)
ui <- function(){
div(
selectInput('id', label = 'select', choices = 1:3, selected = 2),
highchartOutput("plot")
)
}
server <- function(session, input, output){
output$plot <- renderHighchart({
hc <- highchart() %>%
hc_chart(events = list(load = JS("function(){this.series[0].points[2].select()}"))) %>%
hc_add_series(data.frame(x = 1:3, y = 1:3), "scatter", hcaes(x, y)) %>%
hc_plotOptions(
allowPointSelect = TRUE
)
hc
})
observeEvent(input$id, {
# Here I'd like to send a message to the highchart
# to select the chosen point
})
}
shinyApp(ui, server)
This can be done using hcpxy_update_point function in the development version of {highcharter} (remotes::install_github("jbkunst/highcharter")).
Be sure to use the correct id for the chart which in this case is plot.
More examples in https://jbkunst.shinyapps.io/02-proxy-functions/.
library(shiny)
library(highcharter)
ui <- function(){
div(
selectInput('id', label = 'select', choices = 1:3, selected = 2),
highchartOutput("plot")
)
}
server <- function(session, input, output){
output$plot <- renderHighchart({
hc <- highchart() %>%
hc_chart(events = list(load = JS("function(){this.series[0].points[2].select()}"))) %>%
hc_add_series(
data.frame(x = 1:3, y = 1:3),
"scatter",
hcaes(x, y),
id = "someid",
) %>%
hc_plotOptions(
allowPointSelect = TRUE
)
hc
})
observeEvent(input$id, {
id_0_based <- as.numeric(input$id) - 1
highchartProxy("plot") %>%
# set all points unselected `selected = FALSE`
hcpxy_update_point(id = "someid", 0:2, selected = FALSE) %>%
# then set to selected the _selected_ point
hcpxy_update_point(
id = "someid",
id_point = id_0_based,
selected = TRUE
)
})
}
shinyApp(ui, server)
I have a application that has a reative table(based on 2 selectInputs) and a graph. The data for graph is taken from reactive table.
So both graph and table is using the same data. So while constructing a graph, can I observe what the table is having.
Or should I read the same table again in the graph?
I mean should we call head(iris,n = as.numeric(input$rows)) again twice below?
Example,
library(shiny)
library(DT)
library(rAmCharts)
ui <- fluidPage(
selectInput("rows","Rows",c(1:150)),
dataTableOutput("input_table"),
amChartsOutput("barplot",width = 750, height = 500)
)
server <- function(input, output, session) {
output$input_table <- renderDataTable({
new_iris <- head(iris,n = as.numeric(input$rows))
datatable(new_iris)
})
output$barplot <- renderAmCharts({
new_iris1 <- head(iris,n = as.numeric(input$rows)) ## should i call this again???????? Cannot we use from rendertable?
new_iris1 <- new_iris1 %>% group_by(Species) %>% summarise(total = sum(Petal.Length))
pipeR::pipeline(
amBarplot(
x = "Species",
y = "total",
ylab = "X",
xlab = "Y",
data = new_iris1,
labelRotation = 90
),
setChartCursor()
)
})
}
shinyApp(ui, server)
You may want to put your data object in a reactive expression so you can see what is being rendered, like so, this way you can access data() later on in your app
library(shiny)
library(DT)
library(dplyr)
library(rAmCharts)
ui <- fluidPage(
selectInput("rows","Rows",c(1:150)),
dataTableOutput("input_table"),
amChartsOutput("barplot",width = 750, height = 500)
)
server <- function(input, output, session) {
data <- eventReactive(input$rows,{
head(iris,n = as.numeric(input$rows))
})
output$input_table <- renderDataTable({
datatable(data())
})
output$barplot <- renderAmCharts({
new_iris1 <- data()
new_iris1 <- new_iris1 %>% group_by(Species) %>% summarise(total = sum(Petal.Length))
pipeR::pipeline(
amBarplot(
x = "Species",
y = "total",
ylab = "X",
xlab = "Y",
data = new_iris1,
labelRotation = 90
),
setChartCursor()
)
})
}
shinyApp(ui, server)
My question is related to this post. By clicking on a bar in a bar plot I want to display the selected category. When rewriting the code into modules I do not get the expected result (i.e. display the category in text field), instead nothing happens not even an error message pops up. What am I doing wrong?
library(shiny)
library(highcharter)
myModuleUI <- function(id){
ns <- NS(id)
fluidPage(
column(width = 8, highchartOutput(ns("hcontainer"), height = "500px")),
column(width = 4, textOutput(ns("text")))
)
}
myModule <- function(input, output, session){
a <- data.frame(b = LETTERS[1:10], c = 11:20, d = 21:30, e = 31:40)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.category]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_xAxis(categories = a$b) %>%
hc_add_series(name = "c", data = a$c) %>%
hc_add_series(name = "d", data = a$d) %>%
hc_add_series(name = "e", data = a$e) %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction))) %>%
hc_chart(type = "column")
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2], ".")
})
observeEvent(input$legendClicked, {
outputText <<- paste0("You clicked into the legend and selected series ", input$legendClicked, ".")
})
output$text <- renderText({
outputText
})
}
ui <- shinyUI(fluidPage(
myModuleUI("myMod")
))
server <- function(input, output){
callModule(myModule, "myMod")
}
The thing with modules is that you need to pass the namespace. If you get the namespace in the beginning of your module ns <- session$ns and then adjust the JavaScript function like this
canvasClickFunction <- JS(paste0("function(event) {Shiny.onInputChange('", ns('canvasClicked'), "', [this.name, event.point.category]);}"))
legendClickFunction <- JS(paste0("function(event) {Shiny.onInputChange('", ns('legendClicked'), "', this.name);}"))
your code should work.
I need to be able to add another trace to a plot after a mouse click. I am using R's web framework Shiny to display the plot in a web browser. The series I want to add is dots or any series at this point.
I need to draw lines on the plot also. I want to click a starting point and a ending and a line pass through the clicked points.
This is what I have so far.
#############To Update
#if (!require("devtools"))
#install.packages("devtools")
#devtools::install_github("jbkunst/highcharter")
library("shiny")
library("highcharter")
dots<-hc_add_series_scatter(cars$speed, cars$dist)
hc_base <- highchart() %>%
hc_xAxis(categories = citytemp$month) %>%
hc_add_series(name = "Tokyo", data = citytemp$tokyo)
ui <- fluidPage(
h2("Viewer"),
fluidRow(
h3(""), highchartOutput("hc_1", width = "100%", height = "800px"),
h3("Click"), verbatimTextOutput("hc_1_input2")
)
)
server = function(input, output) {
output$hc_1 <- renderHighchart({
hc_base %>%
hc_add_theme(hc_theme_ffx())%>%
hc_tooltip(backgroundColor="skyblue",crosshairs = TRUE, borderWidth = 5, valueDecimals=2)%>%
hc_add_event_series(series="dots", event = "click")
})
output$hc_1_input2 <- renderPrint({input$hc_1_click })
}
shinyApp(ui = ui, server = server)
Any help would be greatly appreciated.
This could be one way of doing it:
library(shiny)
library(highcharter)
hc_base <- highchart() %>%
hc_xAxis(categories = citytemp$month) %>%
hc_add_series(name = "Tokyo", data = citytemp$tokyo)
ui <- fluidPage(
h2("Viewer"),
fluidRow(
h3(""), highchartOutput("hc_1", width = "100%", height = "800px"),
h3("Click"), verbatimTextOutput("hc_1_input2")
)
)
server = function(input, output) {
output$hc_1 <- renderHighchart({
hc_base %>%
hc_add_theme(hc_theme_ffx())%>%
hc_tooltip(backgroundColor="skyblue",crosshairs = TRUE, borderWidth = 5, valueDecimals=2)%>%
hc_add_event_point(event = "click")
})
observeEvent(input$hc_1_click,{
output$hc_1 <- renderHighchart({
hc_base %>%
hc_add_theme(hc_theme_ffx())%>%
hc_tooltip(backgroundColor="skyblue",crosshairs = TRUE, borderWidth = 5, valueDecimals=2)%>%
hc_add_series_scatter(cars$speed, cars$dist)
})
})
output$hc_1_input2 <- renderPrint({input$hc_1_click })
}
shinyApp(ui = ui, server = server)
Hope it helps!
I am trying to run the code below on two R versions, and do not have the same display. I want to display one value ('10') with one category only ('Feb') and this is not working for one of the versions, here you can see the output comparison:
And here is the code :
library("shiny")
library("highcharter")
data(citytemp)
ui <- fluidPage(
h1("Highcharter EXAMPLE"),
fluidRow(
column(width = 8,
highchartOutput("hcontainer",height = "500px")
),
selectInput("option", label = "", width = "100%",
choices = c("Tokyo", "NY"))
)
)
server <- function(input, output) {
data <- citytemp[,c("month","tokyo","new_york")]
data = data[data$month%in%c("Dec","Jan","Feb","Mar"),]
choose_Option <- reactive({
sort_option <- input$option
if(sort_option=="Tokyo"){
data = data[order(data$tokyo),]
}
else{
data = data[order(data$new_york),]
}
return(data)
})
output$hcontainer <- renderHighchart({
data = choose_Option()
data = data[data$month=="Feb",]
chart <- highchart() %>%
hc_chart(type = "bar") %>%
hc_title(text = "Monthly Average Temperature for main cities") %>%
hc_subtitle(text = "Source: WorldClimate.com") %>%
hc_xAxis(categories = data$month) %>%
hc_yAxis(title = list(text = "Temperature (C)"),stackLabels=list(enabled=FALSE))%>%
hc_plotOptions(
series=list(stacking="normal"))
hc <- chart %>% hc_add_series(yAxis=0,name="Tokyo",data = 10,colorByPoint=TRUE,dataLabels = list(enabled = TRUE) )
return(hc)
})
}
shinyApp(ui = ui, server = server)
Do you have any suggestions about how I could correct my display in the version 3.2.0 ? Thank you, best regards, Madzia