Shinydashboard: height issue even using fluidRow - r

I need to make a very professional Shinyapp, but the end of the body of the app ends in the middle of the last plot.
I found this other question, but it's solution (use fluidRow) doesn't work in my case:
https://stackoverflow.com/questions/46259208/shiny-dashboard-mainpanel-height-issue
What could be wrong?
All data is reproducible.
## app.R ##
library(shiny)
library(shinydashboard)
library(dygraphs)
library(plotly)
library(readr)
ui <- dashboardPage(
dashboardHeader(title = "Monitoramento Banco de Dados"),
dashboardSidebar(
sliderInput("DateInput", "Periodo", -30, 0, c(-15, 0), pre = "D.")
),
dashboardBody(
fluidRow(
dygraphOutput("plot1"),
br(),
plotlyOutput("plot")
)
)
)
server <- function(input, output) {
output$plot1 <- renderDygraph({
lungDeaths <- cbind(ldeaths, mdeaths, fdeaths)
dyRangeSelector(dygraph(lungDeaths, main = "Deaths from Lung Disease (UK)"), dateWindow = c("1974-01-01", "1980-01-01"))
})
sesiones_por_fuente <- reactive({
#sesiones_ga <- read_csv("www/ga-sesiones-lc-20180824.csv", skip = 0)
sesiones_ga <- read_csv("https://www.dropbox.com/s/w2ggnb0p4mz2nus/sesiones-2018.csv?dl=1", skip = 0)
sesiones_ga <- sesiones_ga %>%
group_by(date, sources) %>%
summarise(sessions = sum(sessions)) %>%
filter(sources != "spam")
})
m <- list(
l = 120,
r = 120,
b = 100,
t = 100,
pad = 20
)
output$plot <- renderPlotly({
plot_ly(sesiones_por_fuente(), x = ~sessions, y = ~sources, type = 'bar',
width = 1200, height = 500, orientation = 'h') %>%
layout(title = "Sesiones por mes",
xaxis = list(title = ""),
yaxis = list(title = ""),
margin = m) %>%
layout(hovermode = 'compare',
separators = ',')
})
}
shinyApp(ui, server)

So I had to inspect the HTML produced by Shiny. And its results that the plotly graphs are rendered in a div (produced by the server.R file) an this div is inside another div (produced by ui.R).
So, if the inner div, produced by the sever.R file, is bigger than the div produced by the ui.R file that produces that layout error.
So, if you have this in the server.R (notice the height argument of 500px in the plot_ly fun()):
output$plot <- renderPlotly({
sesiones_fuente <- sesiones_por_fuente() %>%
filter(date > input$dateRange[1], date < input$dateRange[2]) %>%
group_by(sources) %>%
summarise(sessions = sum(sessions))
plot_ly(sesiones_fuente, x = ~sessions, y = ~sources, type = 'bar',
width = 1200, height = 500, orientation = 'h') %>%
layout(title = "Sesiones por mes",
xaxis = list(title = ""),
yaxis = list(title = ""),
margin = m)
})
You need to used the argument height=500px in plotlyOutput or a Fluidrow of the same height in ui.R:
plotlyOutput of height 500px:
fluidRow(
column(12, offset = 1,
plotlyOutput("plot_sesiones_por_mes", height = "500px"))),
br(),
fluidRow of height 500px:
fluidRow(style = "height:500px",
column(12, offset = 1,
plotlyOutput("plot_sesiones_por_mes"))),
br(),

Related

R Shiny plotly horizontal legend doesnt fit properly when box is small

Normally the legend of a plotly plot is positioned right to the plot. When added to a box in Shiny its scales well with the legend, no matter how small the box is...however when the legend is placed horizontally, the legend covers the plot when the box is scaled too small. Why is this? And how can I fox this?
Code plot:
x1 <- rnorm(50)
x2 <- rnorm(10)
fig <- plot_ly()
fig <- fig %>%
add_histogram(x = ~x1, name = "X1", marker = list(color = "red")
) %>%
add_histogram(x = ~x2, name = "X2", marker = list(color ="#blue")
) %>%
layout(legend = list(orientation = "h",
traceorder= 'normal',
xanchor = "center",
x = 0.5)
)
Code Shiny app:
ui <- dashboardPage(dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(
title = "test",
width = 4,
height = "auto",
plotlyOutput("plot1", height = "360px"),
inline = F
)
))
server <- function(input, output, session) {
output$plot1 <- renderPlotly({
fig
})
}
shinyApp(ui, server)
I used a combination of the margin parameter of plotly's layout, and the y parameter of the legend to generate the output below.
Code:
library(tidyverse)
library(shiny)
library(shinydashboard)
library(plotly)
x1 <- rnorm(50)
x2 <- rnorm(10)
# THIS CHANGE
m <- list(
l = 10,
r = 10,
b = 100,
t = 10,
pad = 20
)
fig <- plot_ly()
fig <- fig %>%
add_histogram(x = ~x1, name = "X1", marker = list(color = "red")
) %>%
add_histogram(x = ~x2, name = "X2", marker = list(color ="#blue")
) %>%
layout(legend = list(orientation = "h",
traceorder= 'normal',
xanchor = "center",
x = 0.5,
y = -0.3), # THIS CHANGE
margin = m # THIS CHANGE
)
ui <- dashboardPage(dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(
title = "test",
width = 4,
height = "auto",
plotlyOutput("plot1", height = "360px"),
inline = F
)
))
server <- function(input, output, session) {
output$plot1 <- renderPlotly({
fig
})
}
shinyApp(ui, server)

R shiny: How to copy data derived from plotly_selection events into a data frame/table and update each time by pressing an actionButton?

I'm putting together a shiny app to play around with some athlete GPS data. Essentially, I'm looking to structure my script so that each time the user selects an area of interest on the plotly plot and the "Add" actionButton is clicked, the table below will add the calculated Start_time, Time_at_peak, Max_velocity, Time_to_peak, and Distance_to_peak values.
The issue can be seen in the GIF below: - Once the area of interest is selected and the "Add" button clicked, the first values seem correct. However, when the user selects a second area of interest to add to the table, it overwrites the initial entry and will keep overwriting each time a new selection is made. This is seemingly because because the code is inside the observeEvent(event_data("plotly_selected"), which, confusingly, it needs to be in order to calculate the variables of interest.
I'm currently a little stumped and can't seem to find any relevant information. As such, any guidance would be greatly appreciated!
Here is a we transfer link to some test data that can be uploaded to the app: https://wetransfer.com/downloads/5a7c5da5a7647bdbe133eb3fdac79c6b20211119052848/afe3e5
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
x_df <- data.frame(Start_time = character(1), Time_at_peak = character(1), Max_velocity = integer(1),
Time_to_peak = integer(1), Distance_to_peak = integer(1))
x_df$Start_time <- as.character("0:00:00.0")
x_df$Time_at_peak <- as.character("0:00:00.0")
x_df$Max_velocity <- as.integer(0)
x_df$Time_to_peak <- as.integer(0)
x_df$Distance_to_peak <- as.integer(0)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(event_data("plotly_selected"), {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
values <- reactiveValues()
values$df <- x_df
addData <- observe({
if(input$Add > 0) {
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
values$df <- isolate(rbind(values$df, newLine))}
})
output$testing <- renderDataTable({values$df})
})
})
))
I've managed to figure it out and thought I'd post an answer rather than delete the question - just in case someone out there is looking to do a similar thing and they are unsure how to do it.
Firstly, I removed the pre-populated table x_df from the beginning - it was no longer required.
Although I thought the code needed to sit inside the observeEvent(event_data("plotly_selected") to function correctly, it did not - thankfully, because that was at the root of the issue. Instead, I used observeEvent(input$Add, { (which is the correct code to use as opposed to if(input$Add > 0)) to anchor the event to the click of the Add button.
The values <- reactiveValues() was placed outside the observeEvent() and an IF statement was used to either add the data to the values$df data frame on it's own if it was the first selection, or bind it to the existing saved data.
Here's the new code and a GIF demonstrating.
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
values <- reactiveValues(df_data = NULL)
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(input$Add, {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
if (is.null(values$df)){
values$df <- newLine}
else {
values$df <- isolate(rbind(values$df, newLine))}
output$testing <- renderDataTable({values$df})
})
})
))

How can I make a highcharter time serie graph inside a box in shiny?

How can I make a highcharter time series graph inside a box in shiny? I'm trying to make a chart like this one in shiny. Does anyone know how?
Website: http://www.piaschile.cl/mercado/benchmarking-internacional/
You could start with the sample shiny app
library("shiny")
library("highcharter")
data(citytemp)
ui <- fluidPage(
h1("Highcharter Demo"),
fluidRow(
column(width = 4, class = "panel",
selectInput("type", label = "Type", width = "100%",
choices = c("line", "column", "bar", "spline")),
selectInput("stacked", label = "Stacked", width = "100%",
choices = c(FALSE, "normal", "percent")),
selectInput("theme", label = "Theme", width = "100%",
choices = c(FALSE, "fivethirtyeight", "economist",
"darkunica", "gridlight", "sandsignika",
"null", "handdrwran", "chalk")
)
),
column(width = 8,
highchartOutput("hcontainer",height = "500px")
)
)
)
server = function(input, output) {
output$hcontainer <- renderHighchart({
hc <- hc_demo() %>%
hc_rm_series("Berlin") %>%
hc_chart(type = input$type)
if (input$stacked != FALSE) {
hc <- hc %>%
hc_plotOptions(series = list(stacking = input$stacked))
}
if (input$theme != FALSE) {
theme <- switch(input$theme,
null = hc_theme_null(),
darkunica = hc_theme_darkunica(),
gridlight = hc_theme_gridlight(),
sandsignika = hc_theme_sandsignika(),
fivethirtyeight = hc_theme_538(),
economist = hc_theme_economist(),
chalk = hc_theme_chalk(),
handdrwran = hc_theme_handdrawn()
)
hc <- hc %>% hc_add_theme(theme)
}
hc
})
}
shinyApp(ui = ui, server = server)
You could also refer to the following links to get started with :
https://datascienceplus.com/making-a-shiny-dashboard-using-highcharter-analyzing-inflation-rates/
http://jkunst.com/highcharter/shiny.html

R Plotly extendTraces: Change to incremental and clear data

I am trying out the R Streaming example for extendTraces on Plotly. I am trying to add a functionality to the chart such that it would clear all the data as the browser starts stalling after some time (eg., an actionButton, etc). Is there a way to stop the trace and clear the trace/data on a second click of the actionButton ? Alternatively, is it possible to make the chart incremental, such that the entire data isn't getting stored locally.
https://plot.ly/r/streaming/#streaming-in-r
library(shiny)
library(plotly)
rand <- function() {
runif(1, min=1, max=9)
}
ui <- fluidPage(
includeCSS("styles.css"),
headerPanel(h1("Streaming in Plotly: Multiple Traces", align = "center")),
br(),
div(actionButton("button", "Extend Traces"), align = "center"),
br(),
div(plotlyOutput("plot"), id='graph')
)
server <- function(input, output, session) {
p <- plot_ly(
type = 'scatter',
mode = 'lines'
) %>%
add_trace(
y = c(rand(),rand(),rand()),
line = list(
color = '#25FEFD',
width = 3
)
) %>%
add_trace(
y = c(rand(),rand(),rand()),
line = list(
color = '#636EFA',
width = 3
)
) %>%
layout(
yaxis = list(range = c(0,10))
)
output$plot <- renderPlotly(p)
observeEvent(input$button, {
while(TRUE){
Sys.sleep(1)
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("extendTraces", list(y=list(list(rand()), list(rand()))), list(1,2))
}
})
}
shinyApp(ui, server)
Thanks in advance,
Raj.
Hi maybe you could do something like this?
library(shiny)
library(plotly)
library(shinyjs)
rand <- function() {
runif(1, min=1, max=9)
}
ui <- fluidPage(
# includeCSS("styles.css"),
headerPanel(h1("Streaming in Plotly: Multiple Traces", align = "center")),
br(),
div(actionButton("button", "Extend Traces"),actionButton("buttonReset", "Reset Traces"), align = "center"),
br(),
div(plotlyOutput("plot"), id='graph'),
useShinyjs()
)
server <- function(input, output, session) {
values <- reactiveValues()
values$p <- plot_ly(
type = 'scatter',
mode = 'lines'
) %>%
add_trace(
y = c(rand(),rand(),rand()),
line = list(
color = '#25FEFD',
width = 3
)
) %>%
add_trace(
y = c(rand(),rand(),rand()),
line = list(
color = '#636EFA',
width = 3
)
) %>%
layout(
yaxis = list(range = c(0,10))
)
output$plot <- renderPlotly({values$p})
observe({
invalidateLater(1000, session)
req(input$button > 0)
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("extendTraces", list(y=list(list(rand()), list(rand()))), list(1,2))
})
observeEvent(input$buttonReset,{
values$p <- plot_ly(
type = 'scatter',
mode = 'lines'
) %>%
add_trace(
y = c(rand(),rand(),rand()),
line = list(
color = '#25FEFD',
width = 3
)
) %>%
add_trace(
y = c(rand(),rand(),rand()),
line = list(
color = '#636EFA',
width = 3
)
) %>%
layout(
yaxis = list(range = c(0,10))
)
runjs("Shiny.onInputChange('button',0)")
})
}
shinyApp(ui, server)
Hope this helps!!

Change google maps heatmap options in shiny

I am using googleway library in Shiny R.
The heatmap displays correctly, but I cannot change the heatmap options. If I uncomment the block code where I try to change options, the app crashes.
Here is the part of the code that works, with the offending lines commented out.
library(googleway)
library(magrittr)
library(shiny)
library(shinydashboard)
# Define UI for app
header1 <- dashboardHeader(
title = "My Dashboard"
)
sidebar1 <- dashboardSidebar(
sidebarMenu(
fileInput("file0", "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",".csv")),
sliderInput("opacity", "Opacity:",
min = 0, max = 1,
value = 0.5, step = 0.05),
sliderInput("radius", "Radius:",
min = 0, max = 50,
value = 25),
sliderInput("blur", "Blur:",
min = 0, max = 1,
value = 0.75, step = 0.05),
sliderInput("maxvalue", "MaxValue:",
min = 0, max = 1,
value = 1, step = 0.05)
) #sidebarMenu
) #dashboardSidebar
body1 <- dashboardBody(
fluidRow(
tabBox(
title = "TabBox Title 1",
id = "tabset1", height = "400px", width = 11,
selected = "Tab1",
tabPanel("Tab1",
google_mapOutput("Map1")
),
tabPanel("Tab2", "Tab content 2")
) #box
) #fluidRow
) #dashboardBody
ui <- dashboardPage(header1, sidebar1, body1)
# Define data
df <- data.frame(lat = c(14.61),
lon = c(-90.54),
weight = c(100))
# Define SERVER logic
server <- function(input, output, session) {
map_key <- "my_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
## plot the map
output$Map1 <- renderGoogle_map({
google_map(key = map_key, data = df, zoom = 2, search_box = F) %>%
add_heatmap(weight = "weight") #%>%
#add_traffic()
}) #renderGoogle_map
observeEvent(input$opacity, {
# THIS PART IS COMMENTED OUT BECAUSE THE APP CRASHES
# google_map_update(map_id = "Map1") %>%
# update_heatmap(data = df, option_opacity = input$opacity)
}) #observeEvent
} #server
# Run app
shinyApp(ui, server)
Your help with this will be greatly appreciated! :)
You can use a reactive({}) to carry the input$opacity value and pass it directly to add_heatmap() to achieve the opacity responsiveness.
This can still be done inside the google_map_update(), but you'd have to clear the heatmap layer first, otherwise you'd just be adding layers on top of each other.
server <- function(input, output, session) {
map_key <- "your_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
opacity <- reactive({
return(input$opacity)
})
## plot the map
output$Map1 <- renderGoogle_map({
google_map(key = map_key, data = df, zoom = 2, search_box = F) %>%
add_heatmap(weight = "weight") #%>%
#add_traffic()
}) #renderGoogle_map
observeEvent(input$opacity, {
google_map_update(map_id = "Map1") %>%
clear_heatmap() %>%
add_heatmap(data = df, option_opacity = opacity())
})
}
} #server

Resources