I want to increase the size of highchart on clicking the zoom button. I tried using the code below to increase the size but so far I have not been able to achieve what I want to do. I actually wanted the highchart to expand and occupy the full page on clicking the zoom button. I have written the following code so far but it does not seem to work. Can anyone tell me what I am doing wrong?
require(shiny)
require(rCharts)
ui <- fluidPage(
tags$script('Shiny.addCustomMessageHandler("ZoomPlot", function(variableName){
document.getElementById(variableName).style.height = "1000px";
});
'),
headerPanel("Test app"),
actionButton("test", "Zoom"),
div(class = "chart-container", showOutput("viz", "highcharts"))
)
server <- shinyServer(function(input, output, session) {
output$viz <- renderChart2({
a <- highchartPlot(Sepal.Length ~ Sepal.Width, data=iris)
a
})
observeEvent(input$test,{
session$sendCustomMessage(type = 'ZoomPlot', message = "viz")
})
})
shinyApp(ui, server)
You can do it using only server side like
server <- shinyServer(function(input, output, session) {
hh=reactive({
if(input$test>0 ) {1000}else{400}
})
output$viz <- renderChart2({
a <- highchartPlot(Sepal.Length ~ Sepal.Width, data=iris)
a$set(height = hh()
)
a
})
})
Related
I'm trying to make an app which shows some data after the user clicks a point. It works, except that when the data is longer than the window the scrollbar shows up, resizing the plot and erasing the data. How to make the data show and stay?
Below the code of a minimal example.
library(shiny)
library(tidyr)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
req(input$plot_click)
np <- nearPoints(mtcars, input$plot_click) %>%
pull(gear)
mtcars %>%
filter(gear == np)
})
}
shinyApp(ui = ui, server = server)
The problem here is, that once the vertical scrollbar shows up the plotOutput is resized and therefore re-rendered, this results in input$plot_click being reset to NULL causing an empty table.
We can use req()'s cancelOutput parameter to avoid this behaviour.
Please see ?req:
cancelOutput: If TRUE and an output is being evaluated, stop processing as usual but instead of clearing the output, leave it in
whatever state it happens to be in.
library(shiny)
library(tidyr)
library(dplyr)
library(ggplot2)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
req(input$plot_click, cancelOutput = TRUE)
np <- nearPoints(mtcars, input$plot_click) %>% pull(gear)
if(length(np) > 0){
mtcars %>% filter(gear == np)
} else {
NULL
}
})
}
shinyApp(ui = ui, server = server)
Based on this question I would like to also change the background color of the modebar when hovering over it.
I looked in the css, but couldn't find or change the relevant part.
Here's a small shinyApp to test around:
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("plotly")
)
server <- function(input, output, session) {
output$plotly <- renderPlotly({
plot_ly(data = mtcars) %>%
add_markers(x=~mpg, y=~disp) %>%
layout(plot_bgcolor='transparent', paper_bgcolor='transparent')
})
}
shinyApp(ui, server)
I made it transparent but then the options are also invisible so I added a color and activecolor, see here. Feel free to change as necessary.
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("plotly")
)
server <- function(input, output, session) {
output$plotly <- renderPlotly({
plot_ly(data = mtcars) %>%
add_markers(x=~mpg, y=~disp) %>%
layout(plot_bgcolor='transparent', paper_bgcolor='transparent',
modebar=list(bgcolor='transparent', color='blue', activecolor='green'))
})
}
shinyApp(ui, server)
Referencia = [https://plotly.com/javascript/reference/layout/#layout-modebar][1]
layout = {
title: '',
modebar: {
orientation: 'h',
bgcolor: '#ffffff',
color:'red',
activecolor:'red',
position: 'left'
}}
enter image description here
This is my first Shiny app, and I just got the basics working to where it allows the user to select from a dropdown menu of clients, then a dropdown menu of test codes to receive a plot of the results for the selected test.
I'd like the second dropdown menu to be updated with the available test codes for that client (all are not present for each client). Also, I would like to be able to hover over the point in the plot and receive more information from the row in the original dataframe.
I've looked into tooltips and the nearPoints() function, but I'm not sure if these can be used on this data since it is manipulated. I'm not sure if at this point it would be easier to import the data in a different way (it will ultimately need to accept either excel files or .csv). Thanks for any help that you would be able to provide, please let me know if there is any other supporting info I can give.
Here is my code:
library(shiny)
library(scales)
library(ggplot2)
labData <-
read.table("MockNLData.csv",
header=TRUE, sep=",")
#convert '<10' and '<20' results
labData$ModResult <- labData$Result
levels(labData$ModResult)[levels(labData$ModResult)=="<10"]
<- "0"
levels(labData$ModResult)[levels(labData$ModResult)=="<20"]
<- "0"
#convert results to scientific notation
SciNotResult <-
formatC(as.numeric(as.character(labData$ModResult)),
format="e", digits=2)
ui <- fluidPage(
headerPanel("Dilution History"),
sidebarLayout(
sidebarPanel(
selectInput(inputId="client", label="Select Client
Name", choices=levels(labData$Client.Name)
),
selectInput(inputId="test", label="Select Test Code",
choices=levels(labData$Analysis))
),
mainPanel(
plotOutput("line", hover="plot_hov"),
verbatimTextOutput("info"))
)
)
server <- function(input, output) {
#selected client into data frame
selDF <- reactive({labData[labData[,1]==input$client,]
})
#selected test code into data frame
subsetDF <- reactive({selDF()[selDF()[,5]==input$test,]
})
#points to be plotted
points <-
reactive({as.numeric(levels(subsetDF()$ModResult))
[subsetDF()$ModResult]
})
#plot
output$line <- renderPlot({
qplot(seq_along(points()), points(), xlab ="Index",
ylab ="Result")
})
#hover information
output$info <- renderText({
paste0("x=", input$plot_hov$x, "\ny=",
input$plot_hov$y)
})
}
shinyApp(ui = ui, server = server)
Here is what the data looks like:
MockNLData.csv
EDIT: I figured out updating the menu with updateSelectInput()
In the future, make sure you share a reproducible example :)
Since your code is not reproducible please find below something you can understand and adapt to your case.
On your first question, if I understand correctly, you want to programatically generate a dropdown (selectInput) which is perfectly do-able. *Inputs are, in essence, just HTML content which you can dynamically generate, just like your plots. You do so with uiOutput (in your ui) and renderUI in your server.
library(shiny)
ui <- fluidPage(
selectInput("dataset", "Select a dataset", choices = c("cars", "mtcars")),
uiOutput("column"), # dynamic column selector
verbatimTextOutput("selected_column")
)
server <- function(input, output, session){
data <- reactive({
if(input$dataset == "cars")
return(cars)
else
return(mtcars)
})
output$column <- renderUI({
# build your selectInput as you normally would
selectInput("column_selector", "Select a column", choices = colnames(data()))
})
output$selected_column <- renderPrint({
# use input$column_selector!
print(input$column_selector)
})
}
shinyApp(ui, server)
On your second question, what you want is an interactive plot. There are numerous packages that will let you do that in R and Shiny. Below are some examples, by no means a comprehensive list:
plotly which will also let you make your ggplot2 charts interactive
highcharter another great, well tested library
echarts4r ECharts for R.
billboarder billboard.js for R and Shiny
Below is an example using highcharter. They all follow the same principle within Shiny, an *Output function coupled with a render* function.
library(shiny)
library(highcharter)
ui <- fluidPage(
highchartOutput("chart")
)
server <- function(input, output, session){
output$chart <- renderHighchart({
hchart(mpg, "scatter", hcaes(x = displ, y = hwy, group = class))
})
}
shinyApp(ui, server)
EDIT
Following your question on the flashing error. You need to require (req) the required input. When launching the app below the error will flash, uncomment the req(input$y) line and it'll go away.
library(shiny)
ui <- fluidPage(
uiOutput("sel"),
plotOutput("plot")
)
server <- function(input, output){
output$sel <- renderUI({
numericInput("y", "N:", value = 200, min = 5, max = 1000, step = 100)
})
output$plot <- renderPlot({
# req(input$y)
hist(runif(input$y, 1, 10))
})
}
shinyApp(ui, server)
In essence, since your plot relies on a dynamically generating input for a fraction of second that input is not available as it is being rendered, using req prevents that.
What I understand from your problem above are:
You want to make next dropdown menu based on what the user have chosen from previous dropdown menu.
When the mouse over the point on the plot, it will show row value.
So, here i will give you reproducible example and i hope it is useful for you.
In this example I use Rabbit dataset from library MASS.
To filter data for next dropdown menu, I use filter from library
dplyr (See line 30).
I use reactive expression to manage next dropdown menu (See line
29).
I use nearPoints() to manage hover point (See line 55).
library(shiny)
library(MASS)
library(dplyr)
library(ggplot2)
ui <- fluidPage(
titlePanel("Rabbit dataset from MASS library"),
fluidRow(
column(4, selectInput("var",
"Animal:",
unique(sort(Rabbit$Animal)))),
column(4, uiOutput("selected_var")),
column(4, uiOutput("selected_var1")),
column(12, plotOutput("selected_var2", hover = "plot_hover")),
column(12, verbatimTextOutput("info"))
)
)
server <- function(input, output) {
###FILTER NEXT DROPDOWN MENU BASED ON PREVIOUS SELECTED BY USER
dataset3 <- reactive({
unique(Rabbit %>% filter(Animal == input$var) %>% select(Treatment))
})
output$selected_var <- renderUI({
selectInput("var1", "Treatment:", c(dataset3()))
})
dataset4 <- reactive({
Rabbit %>% filter(Animal == input$var) %>% filter(Treatment == input$var1) %>% select(Run)
})
output$selected_var1 <- renderUI({
selectInput("var2", "Run:", c(dataset4()))
})
####
output$selected_var2 <- renderPlot({
ggplot(Rabbit %>% filter(Animal == input$var) %>% filter(Treatment == input$var1) %>% filter(Run == input$var2), aes(x = BPchange, y = Dose)) + geom_point()
})
###HOVER POINT USING nearPoints()
output$info <- renderPrint({
nearPoints(Rabbit %>% filter(Animal == input$var) %>% filter(Treatment == input$var1) %>% filter(Run == input$var2), input$plot_hover)
})
}
shinyApp(ui = ui, server = server)
I am developing an application in shiny.In shiny, I am rendering a simple plot using the action button. I have included a download button to download the the plot that is now in UI. from my code(plot3)
I tried the below code, to save the image, but I am getting an error
plotInput not found.
Could any one suggest where i am going wrong.
Below is my code for reference.
UI:
ui <- tabItem(tabName = "models2",
fluidPage(
fluidRow(
infoBoxOutput("overview")
),
fluidRow(
actionButton("result1","Generate Result"),
downloadButton('downloadPlot','Download Plot'),
plotOutput("plot3")
)
))
SERVER
server <- function(input,output,session{
output$overview <- renderValueBox({
valueBox(
paste("91"),"Overview",icon=icon("hourglass"),
color="green"
)
})
observeEvent(input$result1,{
output$plot3 <- renderPlot({
ggplot(data=timedata, aes(x=dat1, y=yes, group=3))+
geom_point(shape=1)+
coord_cartesian(xlim=c(dat1_xlowlim,dat1_xhighlim))+
labs(title="Probability",x="Date",y="True probability")
})
})
output$downloadPlot <- downloadHandler(
filename = function(){paste(input$plot3,'.png',sep='')},
content = function(plot3){
ggsave(plot3,plotInput())
}
)
})
Also, to note my shiny and R studio are in R environment.
library(shiny)
library(shinydashboard)
ui <- tabItem(tabName = "models2",
fluidPage(
fluidRow(
infoBoxOutput("overview")
),
fluidRow(
actionButton("result1","Generate Result"),
downloadButton('downloadPlot','Download Plot'),
plotOutput("plot3")
)
))
server <- function(input,output,session){
output$overview <- renderValueBox({
valueBox(
paste("91"),"Overview",icon=icon("hourglass"),
color="green"
)
})
data <- reactiveValues()
observeEvent(input$result1,{
data$plot <- ggplot(data=iris, aes(x=Sepal.Length, y=Sepal.Width))+
geom_point(shape=1)})
output$plot3 <- renderPlot({ data$plot })
output$downloadPlot <- downloadHandler(
filename = function(){paste("input$plot3",'.png',sep='')},
content = function(file){
ggsave(file,plot=data$plot)
}
)
}
shinyApp(ui, server)
#Mikz
I don't have enough reputation to follow your comment. Thus, I create a new anwser but wish to answer your question 'why app closes automatically?'.
I had same issue when I develop shiny app on rstudio-server of my company. My app will close by itself after a while. However, same app run on my local laptop don't have this issue.
After my research, I believe it caused by timeout setting (default is 60 seconds). I also use function ~~Sys.sleep()~~ to test this default time. I found the solution works for me from this blog .
The idea is using WebSocket to trigger app every 50 seconds. In this way, you don't need to ask technique guy to adjust setting on server level.
I've recently started learning Shiny and am developing my first practice app. For some reason, my app doesn't take up the entire browser window but is cutoff about half way. The page can still scroll down to see the rest of the output but there is a high fold for some reason. Below is my code:
library(foreign)
library(dplyr)
library(shiny)
library(dplyr)
library(ggplot2)
library(shinythemes)
thesis <- read.csv("thesis.csv", stringsAsFactors = T)
ui <- fluidPage(theme = shinytheme("cerulean"),
# Application title
titlePanel("Annual Prices by City"),
# Sidebar with choice selected
sidebarLayout(
sidebarPanel(
selectInput("city","City",as.character(thesis$city)),
tableOutput("table")
),
# Show a time series line plot
mainPanel(
textOutput("cityheader"),
plotOutput("plot", width="100%")
)
)
)
server <- function(input, output, session) {
df <- reactive({
thesis %>%
select(city, year, price) %>%
filter(city == input$city)
})
output$plot <- renderPlot({
ggplot(df(), aes(x=year, y=price)) +
labs(title=input$city, x="Year", y="Annual Avg Price") +
geom_line(col="blue")
}, height=400, width = 700)
output$table <- renderTable({
df()
})
output$cityheader <- renderText({
input$city
})
}
shinyApp(ui=ui,server=server)
Here is a screenshot of the white space:
Screenshot of the Shiny App
UPDATE:
Here is what it looks like from within the viewer's pane in Rstudio:
Rstudio Screenshot
Thanks.
I had the same issue, try
shinyApp(ui = ui, server = server, options = list(height = 1080))