rBokeh dynamic plot size - r

I am trying to create an rBokeh plot as an output in my Shiny app with rbokehOutput('plot') in the ui and
output$plot <- renderRbokeh({
figure() %>%
ly_hexbin(x,y)
})
in the server part. I'd like the size of the plot to be dynamic in a sense that it should dynamically resize to fill the entire plot window. I've been playing with the height and width arguments, both in the ui and server parts, but have not been able to make it work; I also tried using sizing_mode = "stretch_both" in the server part. When I display the plot in RStudio without Shiny, the plot does not fill the entire plot window either, it keeps its square shape and aspect ratio. I would like it to behave like a normal R plot, i.e. when I enlarge the plot window, the plot automatically resizes to fill the full window. I found this link, but it only deals with Python implementation. Ideally, I would like the height in Shiny to be fixed at 500px and the width to change dynamically based on the (size of) browser.
Minimal working example:
library(shiny)
library(rbokeh)
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
sliderInput('numpoint', 'Number of points to plot', min = 10, max = 1000, value = 200)
),
mainPanel(
rbokehOutput('plot', width = "98%", height = "500px")
)
)
)
server <- function(input, output) {
output$plot <- renderRbokeh({
x <- seq(1, 100, length = input$numpoint)
y <- rnorm(input$numpoint, sd = 5)
figure() %>%
ly_hexbin(x,y)
})
}
shinyApp(ui, server)
Updated MWE:
library(shiny)
library(rbokeh)
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
sliderInput('numpoint', 'Number of points to plot', min = 10, max = 1000, value = 200)
),
mainPanel(
fluidRow(
column(12,
rbokehOutput('plot', height = "800px")
)
),
fluidRow(
column(12,
plotOutput('plot1', height = "800px")
)
)
)
)
)
server <- function(input, output) {
output$plot <- renderRbokeh({
x <- seq(1, 100, length = input$numpoint)
y <- rnorm(input$numpoint, sd = 5)
figure(width = 1800, height = 800) %>%
ly_hexbin(x,y)
})
output$plot1 <- renderPlot({
x <- seq(1, 100, length = input$numpoint)
y <- rnorm(input$numpoint, sd = 5)
plot(x,y)
})
}
shinyApp(ui, server)

Updating my answer..
I've added width and height into my call to figure() and the plot now re-sizes responsively.
library(shiny)
library(rbokeh)
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
sliderInput('numpoint', 'Number of points to plot', min = 10, max = 1000, value = 200)
),
mainPanel(
rbokehOutput('plot', width = "100%", height = "800px")
)
)
)
server <- function(input, output) {
output$plot <- renderRbokeh({
x <- seq(1, 100, length = input$numpoint)
y <- rnorm(input$numpoint, sd = 5)
figure(width = 1800, height = 800) %>%
ly_hexbin(x,y)
})
}
shinyApp(ui, server)
Is this what you wanted?

Inside of your ui body, you can add the following code:
# This will dynamically set the width of the rBokeh plots
tags$head(tags$script('var dimension = [0, 0];
$(document).on("shiny:connected", function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
'))
Then you can use the dynamic size as an input oject like
figure(width = input$dimension[1], height = input$dimension[2],

Related

Color an area with a sliderInput in a shiny app

I have this small example app adapted from the web:
library( shiny )
library( shinyWidgets )
ui <- fluidPage(
tags$br(),
noUiSliderInput(
inputId = "noui2", label = "Slider vertical:",
min = 0, max = 1000, step = 50,
value = c(100, 400), margin = 100,
orientation = "vertical",
width = "100px", height = "300px"
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
}
shinyApp(ui, server)
Then I load an image as background like:
I am wondering if there is a way to color the specific area hight between 100 and 400 (given by the slider) in the borders of the figure like:
Below please find an approach using plotly's filled area plots:
library(shiny)
library(plotly)
library(shinyWidgets)
DF <- data.frame(
x = c(cos(seq(0.01, 10, 0.01)) * 1000:1 + 1000, cos(seq(0.01, 10, 0.01)) * 1000:1 + 1500),
y = rep(1:1000, 2),
id = c(rep("trace_1", 1000), rep("trace_2", 1000))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("plot")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
plotDF <- reactive({
plotDF <- DF[DF$y %in% input$noui2[1]:input$noui2[2], ]
plotDF$id <- paste0("filtered_", plotDF$id)
plotDF
})
output$plot <- renderPlotly({
fig <- plot_ly(
rbind(DF, plotDF()),
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("black"),
fillcolor = 'red',
showlegend = FALSE
) |> style(fill = 'tonexty', traces = 2)
})
}
shinyApp(ui, server)
This is somewhat of a first attempt, the alignment is not perfect but it gets the idea across. Note the plotting box is still there to get a bit more insight what happens while aligning.
library( shiny )
library( shinyWidgets )
ui <- fluidPage(
tags$br(),
fluidRow(
column(2,noUiSliderInput(
inputId = "noui2", label = "Slider vertical:",
min = 0, max = 1000, step = 50,
value = c(100, 400), margin = 100,
orientation = "vertical",
width = "100px", height = "300px"
)),column(10,plotOutput("plot",height = "330px"))
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
output$plot<-renderPlot({
par(mar=c(0,0,1.5,0))
plot(type='n',0:1*1000,0:1*1000, xlab='', ylab='', xaxt='n', yaxt='n')
rect(100, 1000-input$noui2[2], 300,1000-input$noui2[1] , col='red')
})
}
shinyApp(ui, server)

How to update value of sliderInput with height value from draggable plot?

I'm trying to get the value of a resizable plot (using shinyjqui) and use it to update the sliderInput. I am able to get the value however, but I'm unable to update it to the sliderInput. I tried using observe and observeEvent but I'm stuck.
Code
library(shiny)
library(shinyjqui)
library(ggplot2)
ui <- fluidPage(
tags$p("Height value from draggable plot"),
verbatimTextOutput('size_obj'),
# textInput("plotsize", label = "Plot height", value = "300"),
sliderInput("plotsize", label = "Plot height", value = 300, min = 200, max = 500),
tabsetPanel(
id = 'tabs',
tabPanel(
title = 'ggplot',
jqui_resizable(plotOutput('gg'))
)
)
)
server <- function(input, output, session) {
output$gg <- renderPlot({
ggplot(mtcars, aes(x = cyl, y = mpg)) + geom_point()
},
height=exprToFunction(as.numeric(input$plotsize))
)
# observe({
# size_obj()
# updateTextInput(session, "plotsize", value = size_obj())
# })
output$size_obj <- renderPrint({
name <- paste0('gg', '_size')
cat(#sprintf('%s(height: %s',
# input$tabs,
input[[name]]$height)
# input[[name]]$width))
})
}
shinyApp(ui, server)
If you drag the plot from the bottom right, you will notice the verbatimTextOutput change. Once the drag event is over, it goes to the default value. I would like to reverse this and make it so that the slider changes to the value of the verbatimTextOutput so that when I drag to a different height, the sliderInput updates to the new height value.
You want to do this:
library(shiny)
library(shinyjqui)
library(ggplot2)
ui <- fluidPage(
tags$p("Height value from draggable plot"),
verbatimTextOutput('size_obj'),
# textInput("plotsize", label = "Plot height", value = "300"),
sliderInput("plotsize", label = "Plot height", value = 300, min = 200, max = 500),
tabsetPanel(
id = 'tabs',
tabPanel(
title = 'ggplot',
jqui_resizable(plotOutput('gg', height = "300px"))
)
)
)
server <- function(input, output, session) {
name <- paste0('gg', '_size')
height <- reactive({
if(is.null(input[[name]]$height)) 300
else as.numeric( input[[name]]$height)
})
output$gg <- renderPlot({
updateTextInput(session, "plotsize", value = height())
ggplot(mtcars, aes(x = cyl, y = mpg)) + geom_point()
},
height=exprToFunction(height())
)
# observe({
# size_obj()
# updateTextInput(session, "plotsize", value = size_obj())
# })
output$size_obj <- renderPrint({
cat(#sprintf('%s(height: %s',
# input$tabs,
input[[name]]$height)
# input[[name]]$width))
})
}
shinyApp(ui, server)

shiny renderPlot with dynamic height

Problem
I want to change the height of a rendered plot dynamically, so that if it contains a lot of data points more space is allocated to the plot. Content below the plot should then simply be moved.
The height argument of renderPlot can be used for that, but then the plot overflows into the next element and I want to avoid that.
I can circumvent that by using uiOutput, but I was wondering whether I can get the same behaviour without falling back on renderUI?
Expected Outcome
I would like the div below my plot to be moved when the plot sizes changes, without using renderUI
Screenshots
Div does not move
Overflow into div
Code
library(shiny)
library(ggplot2)
ui <- fluidPage(
fluidRow(
column(width = 2, sliderInput("n", "Number of Rows:", 1, 49, 10)),
column(width = 10, plotOutput("plot"))
),
fluidRow( ## the plot oevrflows into this div when the plot grows
column(width = 12, div(style = "background:red; height: 100px"))
),
fluidRow(
column(width = 10, offset = 2, uiOutput("ui"))
),
fluidRow( ## this div is properly moved down as the plot grows
column(width = 12, div(style = "background:red; height: 100px"))
)
)
server <- function(input, output, session) {
data <- reactive(data.frame(id = factor(1:input$n, 1:input$n),
y = rpois(input$n, 200)))
output$plot <- renderPlot(
qplot(id, y, geom = "col", fill = y, data = data()) +
coord_flip(), height = function() 20 * NROW(data())
)
output$ui <- renderUI(plotOutput("plot2", height = 20 * NROW(data())))
output$plot2 <- renderPlot(
qplot(id, y, geom = "col", fill = y, data = data()) +
coord_flip()
)
}
You can write plotOutput("plot", height = "auto") in the ui part. The default height of plotOutput are fixed 400 pixels. By setting height="auto" the plot automatically adjusts to the content.

R Shiny Flexdashboard ValueBox in Column layout

I need to align some elements in a column layout in a Shinydashboard which combines some elements from flexdashboard. Here's the code:
library(shiny)
library(shinydashboard)
library(flexdashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(),
dashboardBody(
column(3,flexdashboard::valueBoxOutput("ValueBox")),
#flexdashboard::valueBoxOutput("ValueBox"),
column(3,plotOutput("plot1",height = 150)),
column(6,h3("Gauges"),
fluidRow(
column(3,flexdashboard::gaugeOutput("Gauge1")),
column(3,flexdashboard::gaugeOutput("Gauge2"))
)
)
)
)
server <- function(input, output) {
output$ValueBox <- renderValueBox({
shinydashboard::valueBox(
value = 100,
subtitle = "Value",
icon = icon("area-chart"),
color = "aqua"
)
})
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata
hist(data)
})
output$Gauge1 <- flexdashboard::renderGauge({
gauge(60, min = 0, max = 100, symbol = "%")
})
output$Gauge2 <- flexdashboard::renderGauge({
gauge(25, min = 0, max = 100, symbol = "%")
})
}
shinyApp(ui, server)
This produces the output where the value box only fills approximately a third of the space designed for it:
When I change the valueBoxOutput to be outside of a column (comment out the first and uncomment the second line in the dashboardBody), the valuebox does fill the full allocated space, but the "Gauge" output is forced on another line rather than to the right:
How do I force the "combination" of the two approaches so that the result looks something like this?
I have tried the following without success:
Use the shinydashboard::valueBoxOutput instead
Utilize the width argument of column as well as valueBoxOutput commands
After experimenting with column widths based on ismirsehregal's answer, I have discovered what the issue was.
The UI part is correct and both ways are capable of producing the result. The issue was that the definition inside renderValueBox did not specify the width argument, which was by default set to 4 and represents the relative width compared to the parental environment. Thus, in the first case, the box takes 4/12 of the column of width 3. In the second case, the output had a width of 4+3+6=13, which is higher than 12 and hence was broken into two lines.
The following definition solves the problem:
output$ValueBox <- renderValueBox({
shinydashboard::valueBox(
value = 100,
subtitle = "Value",
icon = icon("area-chart"),
color = "aqua",
width = 12
)
})
The width = 12 sets the box to fill out the whole width of the parental environment, which in this case is a column of width 3. One can also use width = 3 directly and drop out the column definition, but the first way is preferred as the width of all three elements is specified in the UI rather than the server.
This works for me:
library(shiny)
library(shinydashboard)
library(flexdashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(),
dashboardBody(
flexdashboard::valueBoxOutput("ValueBox", width = "100%"), # Edit %
#flexdashboard::valueBoxOutput("ValueBox"),
column(4,plotOutput("plot1",height = 150)),
column(4,h3("Gauges"),
fluidRow(
column(6,flexdashboard::gaugeOutput("Gauge1")),
column(6,flexdashboard::gaugeOutput("Gauge2"))
)
)
)
)
server <- function(input, output) {
output$ValueBox <- renderValueBox({
shinydashboard::valueBox(
value = 100,
subtitle = "Value",
icon = icon("area-chart"),
color = "aqua"
)
})
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata
hist(data)
})
output$Gauge1 <- flexdashboard::renderGauge({
gauge(60, min = 0, max = 100, symbol = "%")
})
output$Gauge2 <- flexdashboard::renderGauge({
gauge(25, min = 0, max = 100, symbol = "%")
})
}
shinyApp(ui, server)
So here is the preferred way based on Radek Janhuba's insights - setting the appropriate width while rendering (for everyone going here later):
library(shiny)
library(shinydashboard)
library(flexdashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(),
dashboardBody(
column(4,flexdashboard::valueBoxOutput("ValueBox")),
column(4,plotOutput("plot1",height = 150)),
column(4,h3("Gauges"),
fluidRow(
column(6,flexdashboard::gaugeOutput("Gauge1")),
column(6,flexdashboard::gaugeOutput("Gauge2"))
)
)
)
)
server <- function(input, output) {
output$ValueBox <- renderValueBox({
shinydashboard::valueBox(
value = 100,
subtitle = "Value",
icon = icon("area-chart"),
color = "aqua",
width = 12
)
})
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata
hist(data)
})
output$Gauge1 <- flexdashboard::renderGauge({
gauge(60, min = 0, max = 100, symbol = "%")
})
output$Gauge2 <- flexdashboard::renderGauge({
gauge(25, min = 0, max = 100, symbol = "%")
})
}
shinyApp(ui, server)

R shiny error: Error in html tools::validateCssUnit(height); CSS units must be a single-element numeric or character vector

Am learning to use R shiny and I am trying to create a heatmap that allows the user to specify the height in plotlyOutput to prevent labels from being clumped together. My minimal working code:
library(shiny)
library(plotly)
ui <- fluidPage(
titlePanel("Heatmap"),
sidebarLayout(
sidebarPanel(
sliderInput("mapHeight",
"Heatmap Height",
min = 500,
max = 1000,
value =500),
sliderInput("L", "left adjust", min = 0, max =900, value = 80)
),
mainPanel(plotlyOutput("heatmap"))
)
)
server <- function(input, output) {
output$heatmap <- renderPlotly({
p<- heatmaply(mtcars, plot_method = "plotly")%>%
layout(margin = list(l = input$L, r =50 , t=0, b=90))
#not sure why this is being ignored
ggplotly(p, height = input$mapHeight)
})
}
shinyApp(ui = ui, server = server)
The constraint is related to the heatmaply package, the solution below is temporary while plotly continues to accept the height argument in layout.
Warning: Specifying width/height in layout() is now deprecated.
Please specify in ggplotly() or plot_ly()
You could approach the developer on their GitHub and raise and issue or better yet a pull request with the changes you propose. For the time being, the solution below works with Plotly 4.7.1.
app.R
library(shiny)
library(heatmaply)
ui <- fluidPage(
titlePanel("Heatmap"),
sidebarLayout(
sidebarPanel(
sliderInput("mapHeight", "Heatmap Height",
min = 500, max = 1000, value = 500),
sliderInput("L", "left adjust", min = 0, max = 900, value = 80)
),
mainPanel(plotlyOutput("heatmap"))
)
)
server <- function(input, output) {
output$heatmap <- renderPlotly({
heatmaply(mtcars) %>%
layout(margin = list(l = input$L, r = 50, t = 0, b = 90),
height = input$mapHeight)
})
}
shinyApp(ui = ui, server = server)

Resources