Displaying multiple dygraphs on a grid in R-Markdown - r

Following the conversation here, is there a way to organize the output dygraphs in a grid? To Have one or more graph in a row.
The code below would generate 4 dygraphs arranged vertically.
Is there a way to organize them in a 4x4 grid?
I tried using tags$div but it wraps all the graphs in one div.
Is there a way to apply a CSS property such as display: inline-block; to each dygraph widget? or any other better method?
```{r}
library(dygraphs)
library(htmltools)
makeGraphs = function(i){
dygraph(lungDeaths[, i], width = 300, height = 300, group = "lung-deaths")%>%
dyOptions(strokeWidth = 3) %>%
dyRangeSelector(height = 20)
}
lungDeaths <- cbind(mdeaths, fdeaths, ldeaths, mdeaths)
res <- lapply(1:4, makeGraphs )
htmltools::tagList(tags$div(res, style = "width: 620px; padding: 1em; border: solid; background-color:#e9e9e9"))
```
Current output screenshot:

I think I figured it out, not sure its the best solution, but adding a wrapper div with a display:inline-block; property seems to work quite well.
I just added this line to the function that generates each dygraph:
htmltools::tags$div(theGraph, style = "padding:10px; width: 250px; border: solid; background-color:#e9e9e9; display:inline-block;")
so the updated code looks like this:
```{r graphs}
library(dygraphs)
library(htmltools)
makeGraphs = function(i){
theGraph <- dygraph(lungDeaths[, i], width = 400, height = 300, group = "lung-deaths")%>%
dyOptions(strokeWidth = 3) %>%
dyRangeSelector(height = 20)
htmltools::tags$div(theGraph, style = "padding:10px; width: 450px; border: solid; background-color:#e9e9e9; display:inline-block;")
}
lungDeaths <- cbind(mdeaths, fdeaths, ldeaths, mdeaths)
res <- lapply(1:4, makeGraphs )
htmltools::tagList(res)
```
Output Screenshot:

Related

Select plotly charts via drop-down list

I wrote a loop that made 10 graphs in R:
library(plotly)
for (i in 1:10)
{
d_i = data.frame(x = rnorm(100,100,100), y = rnorm(100,100,100))
title_i = paste0("title_",i)
p_i = plot_ly(data = d_i, x = ~x, y = ~y) %>% layout(title = title_i)
htmlwidgets::saveWidget(as_widget(p_i), paste0("plot_",i, ".html"))
}
I have this code (Input menu contents do not overflow row box in flexdashboard) that makes a dashboard in R:
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
```
Column {data-width=100}
-----------------------------------------------------------------------
### Window 1
```{r}
selectInput("project", label = NULL, choices = c("A","B","C","D"))
```
Column {data-width=400}
-----------------------------------------------------------------------
### Chart B
```{r}
renderPlot({
plot(rnorm(1000), type = "l", main = paste("Project:",input$project, " Data:", input$data))
})
```
I would like to adapt this code so that the drop down menu allows the user to load the previously created graph/html file (e.g. from "My Documents") that is being searched for. For example, if the user searches for "plot_7", then plot_7 is displayed.
I tried the following code:
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
```
Column {data-width=100}
-----------------------------------------------------------------------
### Window 1
```{r}
plots = rep("plot", 10)
i = seq(1:100)
choice = paste0(plots, "_",i)
selectInput("project", label = NULL, choices = choice)
```
Column {data-width=400}
-----------------------------------------------------------------------
### Chart B
```{r}
renderPlot({
<object class="one" type="text/html" data="plot_i.html"></object>
})
```
But this returns the following error:
Error: <text<:2:1 unexpected '<'
1: renderPlot({
2:<
^
Can someone please show me how I can fix this? And is it possible to do this WITHOUT shiny? (i.e. only in flexdashboard)
Thank you!
This answers your next question:
Just a question: In the first answer you provided, you were able to "type in" which plot you wanted to see. In the second answer, you can only "scroll". Is there a way to add the "type in" which plot you want to see for the second answer?
Short answer: yes
... and how to do that?
I actually tried to use selectize.js in an ironic full circle of sorts, but it didn't work out...violence was considered...but it's an inanimate object...so...ya, I lost by default
This uses the JS library/package (whatever they call it for that language) select2.
flexdashboard is SUPER FUN! It really didn't want me to add this library with JS (that would have been too easy, ya know? So this puppy had to get added to the YAML.
The YAML to make this work.
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
extra_dependencies: !expr list(htmltools::htmlDependency('select2.min.js', '1.0', src = list(href = 'https://cdn.jsdelivr.net/npm/select2#4.1.0-rc.0/dist'), script='js/select2.min.js', all_files = FALSE, style = 'css/select2.min.css'))
---
By default, it will look like this.
I figured your very next question would be about appearance... so I jumped the gun.
As far as I understand it, (I'm new to select2), when widening the search box, you have to move the dropdown arrow, which accounts for the first 3 of the entries in this CSS.
The next two are for highlighting when you mouse over in the dropdown. By default, the previous selection is highlighted grey, and the currently hovered-over is highlighted light blue. I added these so that you could change the colors if you wanted to.
The final call in CSS is setting the font family. I chose the default family in Plotly (so they matched).
```{css}
.select2-container--default .select2-selection--single{
min-height: 40px;
padding: 6px 6px;
width: 175px;
position: relative;
}
.select2-container--default .select2-selection--single .select2-selection__arrow {
right: 0px;
width: 20px;
min-height: 34px; /* parent min-height, minus top padding 40 - 6 */
position: absolute;
}
.select2-dropdown { /* the chunk requires 'important' */
width: 175px !important; /* so they're the same width */
top: 50%;
padding: 6px; 12px;
}
.select2-container--default .select2-results__option--highlighted[aria-selected] {
background-color: #F5F0E3;
color: black; /* in dropdown, item hovered on bg and text */
} /* default is background-color: #5897fb; default blue */
.select2-container--default .select2-results__option--selected {
background-color: #fbfaf5;
color: black; /* in dropdown, PREVIOUS selection bg and text */
} /* default background-color: #ddd; yucky grey */
option {
font-family: verdana; /* to match plotly */
}
```
Creating the plot list, the dropdown, and rendering the plots in R code didn't change.
The JS didn't change that much.
/* doesn't catch that the first plot is default; set manually */
setTimeout(function(){
$('select').select2(); /* connect to the select2 library */
plt = document.querySelectorAll('div.plotly.html-widget');
for(i = 0; i < plt.length; i++) {
if(i === 0) {
plt[i].style.display = 'block';
} else {
plt[i].style.display = 'none';
}
}
}, 200) /* run once; allow for loading*/
/* goes with the dropdown; this shows/hides plots based on dropdown */
function getPlot(opt) {
plt = document.querySelectorAll('div.plotly.html-widget');
for(i = 0; i < plt.length; i++) { /* switched to plt from opt here */
opti = opt.options[i];
if(opti.selected) {
plt[i].style.display = 'block';
} else {
plt[i].style.display = 'none'
}
}
}
That all gives you this.
All the code altogether.
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
extra_dependencies: !expr list(htmltools::htmlDependency('select2.min.js', '1.0', src = list(href = 'https://cdn.jsdelivr.net/npm/select2#4.1.0-rc.0/dist'), script='js/select2.min.js', all_files = FALSE, style = 'css/select2.min.css'))
---
```{r setup, include=FALSE}
library(flexdashboard)
library(plotly)
library(tidyverse)
library(htmltools)
library(shinyRPG) # devtools::install_github("RinteRface/shinyRPG")
plts <- vector(mode = "list") # store plot list
for (i in 1:10) {
d_i = data.frame(x = rnorm(100,100,100), y = rnorm(100,100,100))
title_i = paste0("title_",i)
plts[[i]] <- plot_ly( # make a list of objects; no .html
data = d_i, x = ~x, y = ~y, height = 400,
mode = "markers", type = "scatter") %>%
layout(title = title_i)
}
```
```{css}
.select2-container--default .select2-selection--single{ /* outer container of dropdown */
min-height: 40px;
padding: 6px 6px;
width: 175px;
position: relative;
}
.select2-container--default .select2-selection--single .select2-selection__arrow {
right: 0px;
width: 20px;
min-height: 34px; /* parent min-height, minus top padding 40 - 6 */
position: absolute;
}
.select2-dropdown { /* the chunk requires 'important' */
width: 175px !important; /* so they're the same width */
top: 50%;
padding: 6px; 12px;
}
.select2-container--default .select2-results__option--highlighted[aria-selected] {
background-color: #F5F0E3;
color: black; /* in dropdown, item hovered on bg and text */
} /* default is background-color: #5897fb; default blue */
.select2-container--default .select2-results__option--selected {
background-color: #fbfaf5;
color: black; /* in dropdown, PREVIOUS selection bg and text */
} /* default background-color: #ddd; yucky grey */
option {
font-family: verdana; /* to match plotly */
}
```
Column {data-width=100}
-----------------------------------------------------------------------
### Window 1 {data-height=500}
```{r makeGoodChoices}
opts <- choice <- paste0("plot_", 1:100) # this line replaces last 3 lines
namedChoices = setNames(opts, choice)
newInput <- rpgSelect( # <----- I'm new; the dropdown
"selectBox",
NULL,
namedChoices,
multiple = F)
newInput$children[[2]]$attribs$onchange <- "getPlot(this)"
newInput # add dropdown to webpage
```
<!--- make space between dropdown and plot --->
<div id="plots" style="margin-top:3rem; margin-bottom:3rem;">
```{r dynoPlots,results='asis'}
tagList(plts) # print every plot (so they're all in the HTML)
```
</div>
```{r giveItUp,results='asis',engine='js'}
/* doesn't catch that the first plot is default, set manually */
setTimeout(function(){
$('select').select2(); /* connect to the select2 library */
plt = document.querySelectorAll('div.plotly.html-widget');
for(i = 0; i < plt.length; i++) {
if(i === 0) {
plt[i].style.display = 'block';
} else {
plt[i].style.display = 'none';
}
}
}, 200) /* run once; allow for loading*/
/* goes with the dropdown; this shows/hides plots based on dropdown */
function getPlot(opt) {
plt = document.querySelectorAll('div.plotly.html-widget');
for(i = 0; i < plt.length; i++) { /* switched to plt from opt here */
opti = opt.options[i];
if(opti.selected) {
plt[i].style.display = 'block';
} else {
plt[i].style.display = 'none'
}
}
}
```
This isn't exactly what you're looking for. This doesn't import the file. I'm still going to try to figure that part out.
I'm still trying to make the external file call work. Right now, it just wasn't to give me the literal HTML. I've tried a few approaches. I'm sure it's being a pain because this is probably not a good way to do this. For example, each plot will bring in the full HTML, which means that if there were 100 plots, you've got the entire plotly.js 100 times. (Whoa!)
If you're set on using external files and planning on rendering them in RMD, especially when using Shiny, you may want to consider an approach that keeps them R objects, like Rda or RData. That will use a LOT less memory.
In this version, I've only created the plots as objects (not saved, external files).
This is modified from your question. It creates an object for each for iteration.
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
library(plotly)
library(tidyverse)
library(htmltools)
for (i in 1:10) {
d_i = data.frame(x = rnorm(100,100,100), y = rnorm(100,100,100))
title_i = paste0("title_",i)
# p_i = plot_ly(data = d_i, x = ~x, y = ~y) %>% layout(title = title_i)
assign(paste0("plot_", i, ".html"), # name them plot_1.html, plot_2.html and so on
plot_ly(data = d_i, x = ~x, y = ~y, height = 400) %>%
layout(title = title_i))
# not using right now!
# htmlwidgets::saveWidget(as_widget(p_i), paste0("plot_",i, ".html"))
}
# htmlwidgets::saveWidget(as_widget(plot_1.html), "plot_1.html") # created for testing
```
I've modified your called to selectInput, as well. I made this a named vector, so that you would have plot_1.html called when the user picked plot_1.
I've kept your code in there, so you can see what's changed.
```{r makeGoodChoices}
# plots = rep("plot", 10)
# i = seq(1:100)
# choice = paste0(plots, "_",i)
choice = paste0("plot_", 1:100) # this line replaces last 3 lines
opts <- paste0(choice, ".html")
namedChoices = setNames(opts, choice)
# selectInput("project", label = NULL, choices = choice) # originally
selectInput("project", label = NULL, choices = namedChoices)
```
Since this is an R object (not an external file), this is how you would call the plots from the dropdown.
```{r dynoPlots}
renderPlotly(get(input$project)) # show me!
```
The RMarkdown altogether
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(shiny)
library(plotly)
library(tidyverse)
library(htmltools)
for (i in 1:10) {
d_i = data.frame(x = rnorm(100,100,100), y = rnorm(100,100,100))
title_i = paste0("title_",i)
# p_i = plot_ly(data = d_i, x = ~x, y = ~y) %>% layout(title = title_i)
assign(paste0("plot_", i, ".html"), # name them plot_1.html, plot_2.html and so on
plot_ly(data = d_i, x = ~x, y = ~y, height = 400) %>%
layout(title = title_i))
# not using right now!
# htmlwidgets::saveWidget(as_widget(p_i), paste0("plot_",i, ".html"))
}
# htmlwidgets::saveWidget(as_widget(plot_1.html), "plot_1.html") # created for testing
```
Column {data-width=100}
-----------------------------------------------------------------------
### Window 1 {data-height=500}
```{r makeGoodChoices}
# plots = rep("plot", 10)
# i = seq(1:100)
# choice = paste0(plots, "_",i)
choice = paste0("plot_", 1:100) # this line replaces last 3 lines
opts <- paste0(choice, ".html")
namedChoices = setNames(opts, choice)
# selectInput("project", label = NULL, choices = choice) # originally
selectInput("project", label = NULL, choices = namedChoices)
```
```{r dynoPlots}
renderPlotly(get(input$project)) # show me!
```
I decided to make this an entirely different answer because it really is a different question.
This is based on the assumption that you won't import external files. This does not use Shiny runtime, but does the same thing as above.
BTW, I didn't check if selectInput would work, I went with shinyRPG because I knew it would work.
Here's a summary of changes from the answer to your original question:
dropped shiny: runtime from YAML
dropped library(shiny)
added library(shinyRPG)
dropped plot names (they're in a list now)
added list to store plots; sent plots to list when created
dropped .html from dropdown option names (they can be anything you want now)
rpgSelect replaced selectInput
added JS to connect plots to the dropdown
Here's what the bare bones looks like (almost exactly the same)
All of the code to make this happen with notes in the code for explanation. If anything is unclear, let me know.
---
title: "Test Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
---
```{r setup, include=FALSE}
library(flexdashboard)
library(plotly)
library(tidyverse)
library(htmltools)
library(shinyRPG) # devtools::install_github("RinteRface/shinyRPG")
plts <- vector(mode = "list") # stores plots
for (i in 1:10) {
d_i = data.frame(x = rnorm(100,100,100), y = rnorm(100,100,100))
title_i = paste0("title_",i)
plts[[i]] <- plot_ly( # make a list of objects
data = d_i, x = ~x, y = ~y, height = 400,
mode = "markers", type = "scatter") %>%
layout(title = title_i)
}
```
Column {data-width=100}
-----------------------------------------------------------------------
### Window 1 {data-height=500}
```{r makeGoodChoices}
opts <- choice <- paste0("plot_", 1:100) # this line replaces last 3 lines
namedChoices = setNames(opts, choice)
newInput <- rpgSelect( # <----- I'm new; the drop down (used same args)
"selectBox",
NULL,
namedChoices,
multiple = F)
newInput$children[[2]]$attribs$onchange <- "getPlot(this)"
newInput # add dropdown to webpage
```
<!--- make space between dropdown and plot --->
<div id="plots" style="margin-top:3rem; margin-bottom:3rem;">
```{r dynoPlots,results='asis'}
tagList(plts) # print every plot (so they're all in the HTML)
```
</div>
```{r giveItUp,results='asis',engine='js'}
/* doesn't catch that the first plot is default, set manually */
setTimeout(function(){
plt = document.querySelectorAll('div.plotly.html-widget');
for(i = 0; i < plt.length; i++) {
if(i === 0) {
plt[i].style.display = 'block';
} else {
plt[i].style.display = 'none';
}
}
}, 200) /* run once; allow for loading*/
/* goes with the drop down; this shows/hides plots based on drop down */
function getPlot(opt) {
plt = document.querySelectorAll('div.plotly.html-widget');
for(i = 0; i < opt.length; i++) {
opti = opt.options[i];
if(opti.selected) {
plt[i].style.display = 'block';
} else {
plt[i].style.display = 'none'
}
}
}
```

Is it possible in R to hide plotly subplots using a dropdown

I am trying generating series of small plotly plots based on a group in a data.frame and then using plotly::subplot() to bind them together. I would like to then use a dropdown filter to only display some of the subplots.
So far (using the plotly docs https://plotly.com/r/map-subplots-and-small-multiples/ and this answer https://stackoverflow.com/a/66205810/1498485) I can create the plots and the buttons and show and hide the contents of the subplots.
But I cannot figure out how to hide/reset the axis so only the selected subplot is displayed. Below is a minimised example of what I am doing.
# create data
df <- expand.grid(group = LETTERS[1:4],
type = factor(c('high','med','low'), levels = c('high','med','low')),
date = seq(as.Date('2020-01-01'), Sys.Date(), 'month')) %>%
mutate(value = abs(rnorm(nrow(.)))) %>%
group_by(group)
# define plot function
create_plots <- function(dat){
legend <- unique(dat$group) == 'A'
plot_ly(dat, x = ~date) |>
add_lines(y = ~value, color = ~type, legendgroup = ~type, showlegend = legend) %>%
add_annotations(
text = ~unique(group),
x = 0.1,
y = 0.9,
yref = "paper",
xref = "paper",
xanchor = "middle",
yanchor = "top",
showarrow = FALSE,
font = list(size = 15)
)
}
# create buttons to filter by group (based on https://stackoverflow.com/a/66205810/1498485)
buttons <- LETTERS[1:4] |>
lapply(function(x){
list(label = x,
method = 'update',
args = list(list(
name = c('high', 'med', 'low'),
visible = unlist(Map(rep, x == LETTERS[1:4], each = 3))
)))
})
# generate subplots
df %>%
do(mafig = create_plots(.)) %>%
subplot(nrows = 2) %>%
layout(
updatemenus = list(
list(y = 0.8,
buttons = buttons))
)
Yes, but as far as I know, you'll have to go beyond the Plotly package. This solution uses the libraries htmltools and shinyRPG. (It is not a Shiny app!)
I don't think that shinyRPG is a cran package. (It wasn't when I obtained it.) To download this package use this.
devtools::install_github("RinteRface/shinyRPG")
I'm using this library to make the selection box. Instead of a dropdown, I used a multiple selection box (you can select one to many plots at the same time).
The first thing I did was comment out the layout options for the plots and assign them to an object.
# generate subplots
so <- df %>%
do(mafig = create_plots(.)) %>%
subplot(nrows = 2) #%>%
# layout(
# updatemenus = list(
# list(y = 0.8,
# buttons = buttons))
# )
The only other change I made to the original subplot object was to change the default height. I used this percentage because the selection box is given 15% of the space (width-wise).
so[["sizingPolicy"]][["defaultHeight"]] <- "80%"
Next is the selection box.
When it comes to the options, I have c(setNames(1:4, LETTERS[1:4])) This reflects as A, B, C, and D in the selection options, because you have that labeled on the graphs. You can change this to anything. The matching names have no bearing on connecting the selection to the plot. However, the values 1:4 do. If you change this, it will impact the selection success.
tagSel <- rpgSelect(
"selectBox",
"Selections:",
c(setNames(1:4, LETTERS[1:4])), # left is values, right is labels
multiple = T)
tagSel$attribs$class <- 'select'
tagSel$children[[2]]$attribs$class <- "mutli-select"
tagSel$children[[2]]$attribs$onchange <- "getOps(this)"
With browsable, I combined the selection box, the Javascript, and the JQuery that connects the selection with the plots visibility, some styling options, and the subplots.
If it seems like a lot, the vast majority is actually for beautification. (That's almost everything in the style tags.)
I added a lot of comments in the JS, but if something's unclear, let me know.
browsable(tagList(list(
tags$head(
tags$script(HTML("function getOps(sel) { /* activate select */
$plts = $('svg g.cartesianlayer').find('g.subplot'); /* find plots */
$labs = $('svg g.infolayer').find('g.annotation'); /* find plot labels */
$plts.addClass('plotter'); /* add opacity to plots */
$labs.addClass('plotter'); /* add opacity to subplot labels */
for(i = 0; i < sel.length; i++) { /* look through options */
opt = sel.options[i];
j = opt.value;
if ( opt.selected ) {
$plts.filter(':nth-child(' + j + ')').removeClass('plotter-inact');
$labs[i].firstChild.classList.remove('plotter-inact');
} else {
$plts.filter(':nth-child(' + j + ')').addClass('plotter-inact');
$labs[i].firstChild.classList.add('plotter-inact');
}
}
}")),
tags$style(".plotter {opacity: 1;}
.plotter-inact {opacity: 0;}
.select {
position: relative; width: 13ch;
border: 2px solid #003b70;
margin: 0 2px; cursor: pointer;
border-radius: 5px; font-size: 1.1em;
text-align: center; line-height: 1.25em;
}
#selectBox {
background-color: #003b70;
width: 10ch; text-align: center;
color: white; font-weight: bold;
line-height: 1.25em;
}
.yaLeft {
position: relative;
float: left; width: 85%;
height: 100vh;
}
.yaRight {
float: right; width: 15%;
}")),
div(div(class = "yaLeft", so),
div(class = "yaRight", tagSel)))))

Using a colored timevis timeline in a Shiny app

I'm using the package 'timevis' to create a timeline in my RShiny dashboard app. I want to visualize some planned deadlines of when to check machines for their maintenance. In the timeline, both executed checks and planned checks are visible. To visualize these different checks, I want to give it different colors (green for executed and red for planned). I succeeded to do this in a test environment, but when I copy the code in my dashboard, the colors are not visible (all blocks are just standard blue).
This is my code:
test:
timevisData <- data.frame(content = tijdlijntabel$machine_nr,
start = tijdlijntabel$onderhoud_datum,
group = tijdlijntabel$onderhoud_type,
style = tijdlijntabel$style)
groups <- data.frame(id = c("Klep", "Reinigen", "Zeeppomp"), content = c("Klep", "Reinigen", "Zeeppomp"))
timevis(data = timevisData, groups = groups, showZoom = TRUE, options = list(editable = TRUE)) %>%
setWindow(Sys.Date() %m-% months(1), Sys.Date() %m+% months(1))
The timevisData dataframe contains: the machine_nr (displayed in the timeline blocks), the date of the check, the type of check (3 types of checks) and the style (the color: "border-color: red; color: white; background-color: red" or "border-color: green; color: white; background-color: green").
In this screenshot, the first part of the data is shown:
enter image description here
This is an example of how I want my timeline to be in the dashboard:
enter image description here
This is the code of my dashboard:
ui.R:
fluidPage(
h3("Overzicht uitgevoerde en voorgestelde onderhoudsbeurten"),
timevisOutput("timeline_aalst")
),
server.R:
output$timeline_aalst <- renderTimevis({
groups <- data.frame(id = c("Klep", "Reinigen", "Zeeppomp"), content = c("Klep", "Reinigen", "Zeeppomp"))
timevis(data = timevisData, groups = groups, showZoom = TRUE, options = list(editable = TRUE)) %>%
setWindow(Sys.Date() %m-% months(1), Sys.Date() %m+% months(1))
})
As mentioned in the comments, it is very helpful when sample data is provided (as part of a minimal working example).
Here I tried to recreate an example you can work from. You might want to take advantage of className to provide items with individual CSS styles. I added tags$style to your ui based on what you described for red and green.
library(shiny)
library(timevis)
library(lubridate)
timevisData <- data.frame (
id = 1:3,
content = c("Klep", "Reinigen", "Zeeppomp"),
group = c("Klep", "Reinigen", "Zeeppomp"),
start = c("2020-12-10", "2020-12-16", "2020-12-30"),
end = NA,
className = c("green_style", "green_style", "red_style")
)
groups <- data.frame(
id = c("Klep", "Reinigen", "Zeeppomp"),
content = c("Klep", "Reinigen", "Zeeppomp")
)
ui <- fluidPage(
title = "Testing with className",
h3("Overzicht uitgevoerde en voorgestelde onderhoudsbeurten"),
tags$head(
tags$style(HTML(".red_style { border-color: red; color: white; background-color: red; }
.green_style { border-color: green; color: white; background-color: green; }
"))
),
timevisOutput("timeline_aalst")
)
server <- function (input, output, session) {
output$timeline_aalst <- renderTimevis ({
timevis (data = timevisData, groups = groups, showZoom = TRUE, options = list(editable = TRUE)) %>%
setWindow(Sys.Date() %m-% months(1), Sys.Date() %m+% months(1))
})
}
shinyApp(ui = ui, server = server)
Output

How to customize hover text for plotly boxplots in R

I understand how to customize the hover text for scatter plots in plotly, but box plots do not accept the 'text' attribute. Warning message: 'box' objects don't have these attributes: 'text'. I have over 300 x-axis variables and there are numbered samples(1-50) in two groups(A or B) that I want to plot together in the same box plot, then I'd like to differentiate between the sample numbers and groups through hover text when moving the cursor over outliers. I'd like to have my custom data labels instead of the automatic quartile labels. Is that possible with plotly boxplots?
library(plotly)
library(magrittr)
plot_ly(melt.s.data,
x = ~variable,
y = ~value,
type = 'box',
text = ~paste("Sample number: ", Sample_number,
'<br>Group:', Group)) %>%
layout(title = "Individual distributions at each x")
Here is some sample data showing only 5 x variables (but the code should work when extrapolated to my 300)...
#sample data
set.seed(456)
#Group A
sample.data_a <- data.frame(Class = "red", Group = "A",
Sample_number = seq(1,50,by=1),
x1= rnorm(50,mean=0, sd=.5),
x2= rnorm(50,mean=0.5, sd=1.5),
x3= rnorm(50,mean=5, sd=.1),
x4= rnorm(50,mean=0, sd=3.5),
x5= rnorm(50,mean=-6, sd=.005))
#Group B
sample.data_b <- data.frame(Class = "red", Group = "B",
Sample_number = seq(1,50,by=1),
x1= rnorm(50,mean=0, sd=5.5),
x2= rnorm(50,mean=0.5, sd=7.5),
x3= rnorm(50,mean=5, sd=.01),
x4= rnorm(50,mean=0, sd=.5),
x5= rnorm(50,mean=-6, sd=2.05))
#row Bind groups
sample.data <- rbind(sample.data_a, sample.data_b)
#melting data to have a more graphable format
library(reshape2)
melt.s.data<-melt(sample.data, id.vars=c("Class", "Group","Sample_number"))
The following are similar questions:
Here it seems like it is not possible.
This question is similar, but only wants to add relevant quartile info.
And this question is only about a single point in plotly boxplots.
It's possible with Shiny.
library(plotly)
library(shiny)
library(htmlwidgets)
# Prepare data ----
set.seed(456)
#Group A
sample.data_a <- data.frame(Class = "red", Group = "A",
Sample_number = seq(1,50,by=1),
x1= rnorm(50,mean=0, sd=.5),
x2= rnorm(50,mean=0.5, sd=1.5),
x3= rnorm(50,mean=5, sd=.1),
x4= rnorm(50,mean=0, sd=3.5),
x5= rnorm(50,mean=-6, sd=.005))
#Group B
sample.data_b <- data.frame(Class = "red", Group = "B",
Sample_number = seq(1,50,by=1),
x1= rnorm(50,mean=0, sd=5.5),
x2= rnorm(50,mean=0.5, sd=7.5),
x3= rnorm(50,mean=5, sd=.01),
x4= rnorm(50,mean=0, sd=.5),
x5= rnorm(50,mean=-6, sd=2.05))
#row Bind groups
sample.data <- rbind(sample.data_a, sample.data_b)
#melting data to have a more graphable format
melt.s.data <- reshape2::melt(sample.data,
id.vars=c("Class", "Group", "Sample_number"))
# Plotly on hover event ----
addHoverBehavior <- c(
"function(el, x){",
" el.on('plotly_hover', function(data) {",
" if(data.points.length==1){",
" $('.hovertext').hide();",
" Shiny.setInputValue('hovering', true);",
" var d = data.points[0];",
" Shiny.setInputValue('left_px', d.xaxis.d2p(d.x) + d.xaxis._offset);",
" Shiny.setInputValue('top_px', d.yaxis.l2p(d.y) + d.yaxis._offset);",
" Shiny.setInputValue('dy', d.y);",
" Shiny.setInputValue('dtext', d.text);",
" }",
" });",
" el.on('plotly_unhover', function(data) {",
" Shiny.setInputValue('hovering', false);",
" });",
"}")
# Shiny app ----
ui <- fluidPage(
tags$head(
# style for the tooltip with an arrow (http://www.cssarrowplease.com/)
tags$style("
.arrow_box {
position: absolute;
pointer-events: none;
z-index: 100;
white-space: nowrap;
background: CornflowerBlue;
color: white;
font-size: 13px;
border: 1px solid;
border-color: CornflowerBlue;
border-radius: 1px;
}
.arrow_box:after, .arrow_box:before {
right: 100%;
top: 50%;
border: solid transparent;
content: ' ';
height: 0;
width: 0;
position: absolute;
pointer-events: none;
}
.arrow_box:after {
border-color: rgba(136,183,213,0);
border-right-color: CornflowerBlue;
border-width: 4px;
margin-top: -4px;
}
.arrow_box:before {
border-color: rgba(194,225,245,0);
border-right-color: CornflowerBlue;
border-width: 10px;
margin-top: -10px;
}")
),
div(
style = "position:relative",
plotlyOutput("myplot"),
uiOutput("hover_info")
)
)
server <- function(input, output){
output$myplot <- renderPlotly({
plot_ly(melt.s.data,
type = "box",
x = ~variable, y = ~value,
text = paste0("<b> group: </b>", melt.s.data$Group, "<br/>",
"<b> sample: </b>", melt.s.data$Sample_number, "<br/>"),
hoverinfo = "y") %>%
onRender(addHoverBehavior)
})
output$hover_info <- renderUI({
if(isTRUE(input[["hovering"]])){
style <- paste0("left: ", input[["left_px"]] + 4 + 5, "px;", # 4 = border-width after
"top: ", input[["top_px"]] - 24 - 2 - 1, "px;") # 24 = line-height/2 * number of lines; 2 = padding; 1 = border thickness
div(
class = "arrow_box", style = style,
p(HTML(input$dtext,
"<b> value: </b>", formatC(input$dy)),
style="margin: 0; padding: 2px; line-height: 16px;")
)
}
})
}
shinyApp(ui = ui, server = server)
A possible solution might be using ggplot2 package and adding an invisible scatterplot to your boxplot:
library(ggplot2)
library(plotly)
gg_box <- melt.s.data %>%
ggplot(aes(x=variable, y=value, text=paste("Group:",Group, "\n",
"Class:", Class))) +
geom_boxplot()+
#invisible layer of points
geom_point(alpha = 0)
gg_box %>%
ggplotly()
You need to play a little bit with your cursor to see the additional labels.

How to change the color background of a box (level 3 header/building block of flexdashboard)?

I'm trying to build an HTML dashboard with multiple pages and all sorts of different elements using gauges, tables, charts from highcharter package, charts from ggplot2 package, images, etc.
I'm trying to change the background color of some elements. I've tried doing this using the built-in arguments of charts and tables, I've tried using div and setting style=background-color: #dddddd (Hex code for the grey I'm trying to use) and I've tried playing around with CSS style with something like:
<style type="text/css">
.chart-title { /* chart_title */
background-color: #dddddd;
</style>
However, I'm not familiar with CSS and couldn't find the correct substitution to ".chart-title" to get what I need. I tried using "body", "h3", "header", "box". I managed to change some colors but not where I needed them to change.
I pasted below a piece of my Dashboard and corresponding Print Screen of the result.
HOME
=======================================================================
Row {data-height=400}
-------------------------------------------------------------------------------------------------------------
### Productivity {.no-title}
```{r fig.width=1.5}
df1<-data.frame(Factory = c('<img src="seta4.png" height=60></img>', "150t/h"))
div(datatable(df1, rownames=FALSE, options = list(ordering=FALSE, scrollY = "150px", scrollX=FALSE, dom='t', autowidth=TRUE,
#columnDefs = list(list(width='5px', targets=c(1,2,3))),
columnDefs=list(list(className='dt-center', targets=c(0)))), escape = FALSE) %>%
formatStyle(names(df1), textAlign = 'center' ) %>%
formatStyle(names(df1), backgroundColor='rgb(221,221,221)', color='rgb(0,0,0)') %>%
formatStyle(names(df1), `font-size` ='15px'),
style="font-size:12px; font-weight:Bold; background-color: #dddddd")
```
### Occupation {.no-title}
```{r fig.width=2}
rate <- ocupacao[1]
div(gauge(rate, min = 0, max = 100, symbol = '%', gaugeSectors(
success = c(0, 39), warning = c(40, 79), danger = c(80, 100)
)), style="background-color: #dddddd")
```
### Ferro {.no-title}
```{r fig.width=3}
df1<-data.frame(Ferroviario = c('<img src="trem.png" height=60></img>', "30Kt"))
div(datatable(df1, rownames=FALSE, options = list(ordering=FALSE, scrollY = "150px", scrollX=FALSE, dom='t', autowidth=TRUE,
#columnDefs = list(list(width='5px', targets=c(1,2,3))),
columnDefs=list(list(className='dt-center', targets=c(0)))), escape = FALSE) %>%
formatStyle(names(df1), textAlign = 'center' ) %>%
formatStyle(names(df1), backgroundColor='rgb(221,221,221)', color='rgb(0,0,0)') %>%
formatStyle(names(df1), `font-size` ='15px'),
style="background-color: #dddddd; font-size:12px, font-weight:Bold")
```
Dashboard:
As you can see, I'm not getting the result I wanted. I wanted the boxes in the top row to have all grey backgrounds, but the most I can get is that only part of the background is grey and the edges/remaining parts are still white.
Is there any way to do this?

Resources