I'm having a problem with ggplotly objects simply not staying inside boxes with shiny and shinydashboard. Before something is plotted, everything is right. But when a plot is displayed, the box doubles its size and the plot stays on top.
It happens only with ggplotly. A common ggplot works fine.
I've made it reproducible with the iris dataset below.
ui.R
dashboardPage(dashboardHeader(title = "Title"),
dashboardSidebar(
sidebarMenu(
menuItem("Species Overview",
tabName = "species"),
menuItem(
pickerInput(
inputId = "species",
choices = species,
multiple = TRUE)))),
dashboardBody(
tabItems(
tabItem(tabName = "species",
fluidRow(
box(
title = "Plot1",
#width = 6,
id = "plot1",
plotlyOutput(
"plot1", width = "100%") ## box 1 with ggplotly object
),
box(
title = "Plot2",
id = "plot2",
#width = 6,
plotOutput(
"plot2", width = "100%") ## box 2 with ggplot object
))))))
server.R
shinyServer(function(input, output) {
v <- reactiveValues()
observe({
v$species <- input$species
})
species_selected <- reactive({
validate(
need(length(v$species) > 0, "Please select a species")
)
select_species(iris, v$species)})
plot1 = reactive({
plot_1(species_selected())
})
plot2 = reactive({
plot_2(species_selected())
})
output$plot1 = renderPlotly({
plot1() |> ggplotly() ##ggplot object
})
output$plot2 = renderPlot({
plot2() #ggplot object
})})
global.R
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
library(tidyverse)
#library(bs4Dash)
data(iris)
species = iris$Species |> unique() |> as.character()
select_species = function(df, species) {
df = df |>
filter(Species %in% species)
return(df)
}
plot_1 = function(df) {
df = df
p = df |>
ggplot(aes(x = Petal.Width, y = Petal.Length, color = Species)) +
geom_point()
return(p)
}
plot_2 = function(df) {
p = df |>
ggplot(aes(x = Sepal.Width, y = Sepal.Length, color = Species)) +
geom_point()
return(p)
}
And this is what happens:
I'm open to any suggestions. I've tried bs4dash, shinydashboard, shinydashboardPlus. Packages are all up to date.
You can specify the height of the box and display the plotly object as shown below.
box(
title = "Plot1",
#width = 6,
height = 460,
id = "plot1",
plotlyOutput(
"plot1", width = "100%", height="400px") ## box 1 with ggplotly object
),
Related
my question is related both to Is there a way to match the colors of a column in a ggplot bar chart to a different ggplot bar chart? and to ggplot conditional scale_fill_manual colors but I could not find the exact solution from either.
Is there a way to fill in a color scheme based on the column name? And then the other variables will be filled in by a default palette? So for example in my code below I would like Sepal.Length.Sum to be filled in by a specific color palette and then the rest of the data to be filled in by a default palette.
# 1.0 Loading Libraries ----
#install.packages("reshape2")
# tidyverse contains: dplyr, ggplot2, tidyr, stringr, forcats, tibble, purrr, readr
library(tidyverse)
# shiny integrates user interface elements and reactivity
library(shiny)
# shinydashboard allows us to actually build the dashboard
library(shinydashboard)
# shinyWidgets offers custom widgets and other components to enhance your shiny applications.
library(shinyWidgets)
# tidyquant for financial analysis. Has nice ggplot2 themes
library(tidyquant)
# DT is used for making tables
library(DT)
library(reshape2)
# 2.0 Load Data ----
# Here I am importing the data I need for analysis
data <- iris
# 3.0 Cleaning Data ----
iris_summed <- data %>%
group_by(Species) %>%
summarize(Petal.Width.Sum = sum(Petal.Width),
Petal.Length.Sum = sum(Petal.Length),
Sepal.Width.Sum = sum(Sepal.Width),
Sepal.Length.Sum = sum(Sepal.Length)) %>%
ungroup() %>%
reshape2::melt(measure.vars = c("Sepal.Length.Sum", "Sepal.Width.Sum", "Petal.Length.Sum", "Petal.Width.Sum"),
variable.name = "Characteristics") %>%
mutate(value = value %>% as.numeric()) %>%
rename(Numerical = value)
iris_palettes <- iris_summed %>%
distinct(Species, Characteristics) %>%
mutate(iris_fill = case_when(Species == "setosa" ~ "#33CCCC",
Species == "versicolor" ~ "#00A499",
Species == "virginica" ~ "#CC000"))
# 4.0 Shiny User Interface ----
# Here I am outlining just the UI part of the Shiny dashboard
ui <- dashboardPage(title = "Iris Data Evaulation", skin = "blue",
dashboardHeader(title = "Iris Dashboard"),
dashboardSidebar(
sidebarMenu(
sidebarSearchForm("searchtext", "buttonSearch", "Search"),
menuItem("Iris Dataset",
tabName = "iris_dataset",
icon = icon("fas fa-chart-bar"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "iris_dataset",
fluidRow(box(width = 3,
height = 400,
selectInput(inputId = "iris_id",
label = h5(strong("Iris Information")),
choices = unique(data$Species),
selected = "")),
box(width = 9,
height = 400,
h5(strong("Iris Breakdown")),
DT::dataTableOutput("iris_table"),
style = "height:400px; overflow-y: scroll"),
box(width = 12,
height = 400,
title = "Iris Chart",
status = "primary",
solidHeader = T,
plotOutput("iris_chart"))
)))))
# 5.0 Shiny Server ----
# Here I am outlining just the server part of the Shiny dashboard
server <- function(input, output, session) {
iris_tbl <- reactive({
data %>%
filter(Species %in% input$iris_id)
})
output$iris_table <- DT::renderDataTable({
iris_tbl()},
rownames = FALSE,
extensions = "FixedHeader",
options = list(
scrollX = TRUE,
scrollY = "450px",
autoWidth = TRUE,
fixedHeader = TRUE,
pageLength = 10,
lengthMenu = c(10, 15),
dom = "pt"
))
iris_filter <- reactive({
iris_summed %>%
filter(Species %in% input$iris_id)
})
output$iris_chart <- renderPlot({
plot_1 <- iris_filter()
if(isTRUE(plot_1$Characteristics) && plot_1$Characteristics == "Sepal.Length.Sum"){
actual_plot <- iris_filter() %>%
ggplot(aes(Species, Numerical, fill = Characteristics)) +
geom_col(width = 0.5) +
scale_fill_manual(values = iris_palettes) +
theme_tq()+
labs(
title = "Characteristics Per Iris Species",
x = "Iris Species",
y = "Iris Characteristics"
)}
else {
actual_plot <- iris_filter() %>%
ggplot(aes(Species, Numerical, fill = Characteristics)) +
geom_col(width = 0.5) +
scale_fill_tq() +
theme_tq()+
labs(
title = "Characteristics Per Iris Species",
x = "Iris Species",
y = "Iris Characteristics"
)
}
actual_plot
})
}
# 6.0 Connecting UI with Server ----
shinyApp(ui, server)
You were close. Try assigning the vector as values = iris_palettes$iris_fill. See below
actual_plot <- iris_filter() %>%
ggplot(aes(Species, Numerical, fill = Characteristics)) +
geom_col(width = 0.5) +
scale_fill_manual(values = iris_palettes$iris_fill) +
theme_tq()+
labs(
title = "Characteristics Per Iris Species",
x = "Iris Species",
y = "Iris Characteristics"
)}
Then you will get
In the reproducible code below plot 1 looks fine in terms of its width/height, but I'd like to expand plot 2 in terms of its height so the subplots don't seem so "squished" together. Does anyone have a suggestion on how to do that so it stays nicely within the card but expands responsively with the number of subplots? In this example, there are five subplots, but that could be any number (usually 2 to 7 or so).
library(shiny)
library(bslib)
library(shinyWidgets)
library(plotly)
card <- function(body, title) {
div(class = "card",
div(icon("chart-line", style = "color:white"), class = "card-header bg-success text-white text-center font-weight-bold", title),
div(class = "card-body d-flex justify-content-center", body)
)
}
ui <- fluidPage(
navbarPage(
theme = bs_theme(bootswatch = "flatly", version = 4),
title = 'Methods',
tabPanel('One'),
),
mainPanel(
h1('Hello World'),
uiOutput('p1'),
br(),
uiOutput('p2'),
)
)
server <- function(input, output) {
output$p1 <- renderUI({
fig <- plot_ly(data = iris, x = ~Sepal.Length, y = ~Petal.Length)
card(fig, 'Plot 1: Looks Good')
})
### I could do this
output$p2 <- renderUI({
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(economics, x = ~date, y = as.formula(paste0("~", var))) %>%
add_lines(name = var)
})
card(subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE), 'Plot 2: Too Squished')
})
}
shinyApp(ui, server)
We can use plotlyOutput and pass a height parameter corresponding to the number of subplots:
library(shiny)
library(bslib)
library(shinyWidgets)
library(plotly)
card <- function(body, title) {
div(class = "card",
div(icon("chart-line", style = "color:white"), class = "card-header bg-success text-white text-center font-weight-bold", title),
div(class = "card-body d-flex justify-content-center", body)
)
}
ui <- fluidPage(
navbarPage(
theme = bs_theme(bootswatch = "flatly", version = 4),
title = 'Methods',
tabPanel('One'),
),
mainPanel(
h1('Hello World'),
uiOutput('p1'),
br(),
uiOutput('p2'),
)
)
server <- function(input, output) {
output$p1 <- renderUI({
fig <- plot_ly(data = iris, x = ~Sepal.Length, y = ~Petal.Length)
card(fig, 'Plot 1: Looks Good')
})
output$plotlyOut <- renderPlotly({
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(economics, x = ~date, y = as.formula(paste0("~", var))) %>%
add_lines(name = var)
})
subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE)
})
output$p2 <- renderUI({
nSubplots <- length(setdiff(names(economics), "date"))
card(plotlyOutput("plotlyOut", height = paste0(nSubplots*200, "px")), 'Plot 2: Looks Good?')
})
}
shinyApp(ui, server)
I have a Shiny app below, in which I am drawing a scatter plot on iris dataset using libraries highchart, ggplot and plotly.
library(shiny)
library(shinydashboard)
library(highcharter)
library(shinyWidgets)
library(plotly)
library(ggplot2)
library(data.table)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
selectizeInput(inputId = "inp_species", label = "Select by:", choices = c("setosa", "versicolor", "virginica"), selected = "setosa"),
awesomeRadio(inputId = "radioTest", label = "Choose one:",
choices=c("High Charter" = "highcharter",
"Simple Plot" = "simple",
"Plotly" = "plotly"),
inline = FALSE, selected = "highcharter")
)
)
body <- dashboardBody(
fluidRow(
tabBox(
side = "right",
selected = "Tab1",
tabPanel("Tab1", "Tab content 1", uiOutput("tabset1Selected"))
)
),
)
shinyApp(
ui = dashboardPage(
dashboardHeader(title = "tabBoxes"),
siderbar,
body
),
server = function(input, output, session) {
iris_dt <- reactive({
iris_table = data.table(copy(iris))
iris_table[Species == input$inp_species]
})
render_content <- reactive({
req(input$radioTest)
print(input$radioTest)
if(input$radioTest=='highcharter'){
output$plot1 <- renderHighchart({
highchart() %>%
hc_add_series(iris_dt(), type = "scatter", hcaes(x = Petal.Width, y = Sepal.Length))
})
out <- highchartOutput("plot1")
}
else if(input$radioTest=='plotly'){
output$plot2 <- renderPlotly({
plot_ly(iris_dt(), x = ~ Petal.Width, y = ~ Sepal.Length)
})
out <- plotlyOutput("plot2")
}
else if(input$radioTest=='simple'){
output$plot3 <- renderPlot({
ggplot(iris_dt(), aes(x = Petal.Width, y = Sepal.Length)) + geom_point()
})
out <- plotOutput("plot3")
}
return(out)
})
# The currently selected tab from the first box
output$tabset1Selected <- renderUI({
render_content()
})
}
)
I am selecting the library to draw the chart dynamically using a selectInput box.
Here is the problem -
I select a species in selectInput box and the highchart library draws a scatter plot
Then I select plotly in the radio button section and the rendering is done using plotly.
I change the species in selectInput and plotly re-renders the plot
Now, when I click on highchart radio button, the plot of the earlier species (from cache) is drawn for a few seconds and then the chart of the selected species is drawn.
Question
Is there a way to clear or disable the cache so that the rendering delay does not happen?
We can disable the animation effect. Although it's not a solution for the problem, it could help in the meantime.
output$plot1 <- renderHighchart({
highchart() %>%
hc_add_series(
data = iris_dt(),
type = "scatter",
hcaes(x = Petal.Width, y = Sepal.Length)
) %>%
hc_plotOptions(
series = list(
animation = FALSE
)
)
})
I have this very simple shiny app
When input changes, the graph changes accordingly
When a point is selected within the graph the corresponding model is displayed on the right of the input text box
I would like to see the selection to be displayed inside the text box
Can anyone please point me in the right direction
Thanks for any help
require(ggplot2)
require(dplyr)
require(Cairo)
require(dplyr)
mtcars2 <- datasets::mtcars %>% rownames_to_column(var = 'model')
ui <- fluidPage(
fluidRow(
column(width = 3,
selectInput(inputId = '.model', label = 'input model', choices = mtcars2$model, selected = NULL)),
br(),br(),
column(width = 3,
textOutput('click_1A'), label = 'selected model')
),
fluidRow(
column(width = 8,
plotOutput("plot1", height = 350, brush = "plot_brush", click = "plot_click")),
)
)
server <- function(input, output) {
global <- reactiveValues(.model = NULL)
# scatter plot
output$plot1 <- renderPlot({
selected_model <- input$.model
ggplot(mtcars2, aes(x=mpg,y=disp), color = 'red') +
geom_point(size = 3, col = 'red') +
geom_point(data = filter(mtcars2, model == selected_model), col = 'blue', size = 5) +
theme_bw() +
theme(legend.position = 'none')
})
# MODEL name
output$click_1A <- renderText({
near_out <- nearPoints(mtcars2, input$plot_click, addDist = TRUE)
global$.model <- near_out %>%
pull(model)
})
}
shinyApp(ui, server)
Thanks #Ben
Here is the clean version of what was trying to achieve:
require(ggplot2)
require(tidyr)
require(tibble)
require(lubridate)
require(Cairo)
require(dplyr)
mtcars2 <- datasets::mtcars %>% rownames_to_column(var = 'model')
ui <- fluidPage(
fluidRow(
column(width = 3,
selectInput(inputId = '.model', label = 'input model', choices = mtcars2$model, selected = NULL)),
),
fluidRow(
column(width = 8,
plotOutput("plot1", height = 350, brush = "plot_brush", click = "plot_click")),
)
)
server <- function(input, output, session) {
global <- reactiveValues(.model = NULL)
# scatter plot
output$plot1 <- renderPlot({
selected_model <- input$.model
ggplot(mtcars2, aes(x=mpg,y=disp, label = model), color = 'red') +
geom_point(size = 3, col = 'red') +
geom_point(data = filter(mtcars2, model == selected_model), col = 'blue', size = 5) +
#geom_text() +
theme_bw() +
theme(legend.position = 'none')
})
observeEvent(
eventExpr = input$plot_click,
handlerExpr = {
selected_model <- nearPoints(mtcars2, input$plot_click, maxpoints = 1, addDist = F) %>% pull(model)
updateSelectInput(session, inputId = ".model", choices = mtcars2$model, selected = selected_model)}
)
}
shinyApp(ui, server)
If you run the R shiny script below, we get two boxes in a dashboard, the left box has a bar chart and right has a DT table, when I click on any bar of the chart using event_data("plotly_click"), I want the corresponding Employee to be displayed in the table besides, like when clicked on first bar, "r1" should be displayed in the table besides. I tried doing "user_cases$base1[d[3]]" but it throws an error as "Error: invalid subscript type 'list'". I will attach the snapshot for the reference, please help me with the same.
## app.R ##
library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
height2 = c(56,45,23,19,8)
base1 = c("r1","r4","r2","r5","r3")
user_cases = data.frame(base1,height2)
pp1 <<- ggplot(user_cases, aes(x = reorder(base1,-height2), y = height2)) +
geom_bar(stat = "identity", fill = "#3399ff" ) + scale_y_discrete(name
="Cases") + scale_x_discrete(name = "Employee")
ggplotly(pp1, tooltip="text",height = 392)
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
user_cases$base1[d[3]]
})
}
shinyApp(ui, server)
Dataset to be fetched
I am trying to fetch subset of the data from the patients dataset from bupaR library. The code for doing it is as follows:
patients_final <- patients[patients$employee == as.data.frame(
user_time$employee[as.numeric(d[3])])]
but the error I get is: "Can't use matrix or array for column indexing" attaching the snapshot for the help.
Have a look at the modified code, I have changed user_cases$base1[d[3]] to as.data.frame(user_cases$base1[as.numeric(d[3])])
## app.R ##
library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)
library(DT)
height2 = c(56,45,23,19,8)
base1 = c("r1","r4","r2","r5","r3")
user_cases = data.frame(base1,height2)
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
pp1 <<- ggplot(user_cases, aes(x = reorder(base1,-height2), y = height2)) +
geom_bar(stat = "identity", fill = "#3399ff" ) + scale_y_discrete(name
="Cases") + scale_x_discrete(name = "Employee")
ggplotly(pp1, tooltip="text",height = 392)
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
as.data.frame( user_cases$base1[as.numeric(d[3])])
})
}
shinyApp(ui, server)
The output is as below:
You can modify the dataframe output as per your requirement.
Hope it helps!