R: Modifying an R Markdown Tutorial - html

I am working with the R programming language.
I have the following 8 plots have been made beforehand and saved as HTML files in my working directory:
library(plotly)
Red_A <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "red")) %>%
layout(title = 'Red A')
Red_B <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "red")) %>%
layout(title = 'Red B')
Blue_A <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "blue")) %>%
layout(title = 'Blue A')
Blue_B <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "red")) %>%
layout(title = 'Blue B')
htmlwidgets::saveWidget(as_widget(Red_A), "Red_A.html")
htmlwidgets::saveWidget(as_widget(Red_B), "Red_B.html")
htmlwidgets::saveWidget(as_widget(Blue_A), "Blue_A.html")
htmlwidgets::saveWidget(as_widget(Blue_B), "Blue_B.html")
My Question: Using this template over here (https://testing-apps.shinyapps.io/flexdashboard-shiny-biclust/) - I would like to make a flexdashboard that allows the user to select (from two dropdown menus) a "color" and a "letter" - and then render one of the corresponding graphs (e.g. col = Red & letter = B -> "Red B"). I would then like to be able to save the final product itself as an HTML file. This would look something like this:
I tried to write the Rmarkdown Code for this problem by adapting the tutorial:
---
title: "Plotly Graph Selector"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
Inputs {.sidebar}
selectInput("Letter", label = h3("Letter"),
choices = list("A" = 1, "B" = 2),
selected = 1)
selectInput("Color", label = h3("Color"),
choices = list("Red" = 1, "Blue" = 2),
selected = 1)
How can I continue with this?
Note
I know that it is possible to load HTML files into a dashboard that have been made beforehand, e.g.
# https://stackoverflow.com/questions/73467711/directly-loading-html-files-in-r
<object class="one" type="text/html" data="Red_A.html"></object>
<object class="one" type="text/html" data="Red_B.html"></object>
<object class="one" type="text/html" data="Blue_A.html"></object>
<object class="one" type="text/html" data="Blue_B.html"></object>

You could use iframe with renderUI to render the HTML files locally using addResourcePath with the location of your files. With paste0 and paste your could dynamically create the html files to select them. Here is some reproducible code:
---
title: "Plotly Graph Selector"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
self_contained: false
runtime: shiny
---
```{r global, include=FALSE}
```
Inputs {.sidebar}
-----------------------------------------------------------------------
```{r}
selectInput("Letter", label = h3("Letter"),
choices = c("A", "B"),
selected = "A")
selectInput("Color", label = h3("Color"),
choices = c("Red", "Blue"),
selected = "Red")
```
Row
-----------------------------------------------------------------------
```{r}
addResourcePath("Downloads", "~/Downloads")
renderUI({
color <- input$Color
letter <- input$Letter
tags$iframe(
seamless="seamless",
src=paste0("Downloads/", paste0(paste(color, letter, sep = "_"), ".html")),
width = 600,
height = 400)
})
```
Output:
If you want to remove the border around the plot, you could add frameBorder = "0" in your iframe call like this:
```{r}
addResourcePath("Downloads", "~/Downloads")
renderUI({
color <- input$Color
letter <- input$Letter
tags$iframe(
seamless="seamless",
src=paste0("Downloads/", paste0(paste(color, letter, sep = "_"), ".html")),
width = 600,
height = 400,
frameBorder = "0")
})
```
Output:
Using getwd() with basename like this:
```{r}
addResourcePath(basename(getwd()), getwd())
renderUI({
color <- input$Color
letter <- input$Letter
tags$iframe(
seamless="seamless",
src=paste0(basename(getwd()), "/", paste0(paste(color, letter, sep = "_"), ".html")),
width = 600,
height = 400,
frameBorder = "0")
})
```

Related

Table title on a different page when using a flextable object in a officedown document

I'm trying to put together a document where a "Tables" section will be found at the end of it. There, all the tables that I will have cited throughout the document will be shown.
My problem is that whenever I have a long table spanning several pages, the table title is left alone on one page and the table follows on the next page. This occurs in both portrait and landscape mode.
My question is: What Can I do with that so that table titles are found just above their associated tables, on the same page?
Here is a snapshot of the problem:
In portrait mode, the table is ok when showing only the first few lines (using the r head() function, left), while the whole table is incorrect (two pages on the right).
The same applies in landscape mode.
And here is the reproducible example.
```
---
output: officedown::rdocx_document
---
```
```{r setup, echo=F, message=F, warning=F}
knitr::opts_chunk$set(echo = F,
collapse = T,
fig.align = "center",
fig.width = 6,
fig.height = 8,
fig.cap = T,
fig.pos = "!h",
message = F,
warning = F)
library(magrittr) # for using the %>%
library(dplyr)
library(officedown)
library(officer)
library(flextable)
# portrait section
portrait <- prop_section(type = "continuous")
# landscape section
landscape <- prop_section(page_size = page_size(orient = "landscape"), type = "continuous")
# Function for setting widths
FitFlextableToPage <- function(ft, pgwidth = 6){
ft_out <- ft %>% autofit()
ft_out <- width(ft_out, width = dim(ft_out)$widths*pgwidth /(flextable_dim(ft_out)$widths))
return(ft_out)
}
set.seed(12345) # for reproducibility when setting table1
```
```{r, echo = F}
# Creation of table1
years <- 1990:2022
table1 <- tibble(year = years,
dat1 = sample(rnorm(n = 1000, 0, 2), size = length(years), replace = T)) %>%
mutate(year = as.character(year),
dat2 = dat1 * 10,
dat3 = dat1 * 1000)
#table1
```
# portrait table
```{r}
foot <- "Preliminary data." # footnote
col_names <- c("Year", "Column 1", "Column 2", "Column 3") # table headers
# Setting the footnote
cor <- which(with(table1, year %in% 2021:2022))
# length(cor) # 2
# Headers
names(table1) <- col_names
```
```{r table1, tab.cap = "Header of table1 in portrait style."}
table1 %>% head() %>% flextable() %>% autofit()
```
\newpage
```{r table2, tab.cap = "All of table1 in portrait style + footnote."}
table1 %>%
flextable() %>%
footnote(i = cor, j = 1, value = as_paragraph(foot),
ref_symbols = "a", part = "body")
block_section(portrait) # end of portrait section
```
# landscape table
Let's put these same tables on a landscape page.
```{r table3, tab.cap = "Header of table1 in landscape style."}
table1 %>% head() %>% flextable() %>% autofit()
```
\newpage
```{r table4, tab.cap = "All of table1 in landscape style + footnote."}
table1 %>%
flextable() %>%
footnote(i = cor, j = 1, value = as_paragraph(foot),
ref_symbols = "a", part = "body") %>%
FitFlextableToPage(pgwidth = 9.5)
block_section(landscape) # end of landscape section
```
# New section in portrait style
bla bla bla.
As David Gohel kindly replied, the chunk option ft.keepnext was the key here and needed to be set to FALSE in the example. This was done by adding an extra argument in the opts_chunk$set() at the beginning of the script, such as:
knitr::opts_chunk$set(echo = F,
collapse = T,
fig.align = "center",
fig.width = 6,
fig.height = 8,
fig.cap = T,
fig.pos = "!h",
message = F,
warning = F,
ft.keepnext = F) # the argument added

Several lines with different style in Caption in both html and docx - flextable

I need to show data caption, computer name and period in the header of table.
I have also requirements: zebra theme, merging cells if needed. That's why I chose flextable.
Here is my code:
library(officer) # border settings library
library(flextable) # drawing tables library
library(dplyr)
Caption <- "<b><big>Computer01.domain.com</big></b><br>Network Interface<br>Gbit Total/sec<br><small>2021-05-14 18:04 to 2021-05-25 13:29</small>"
bold_border <- fp_border(color="gray", width =2)
std_border <- fp_border(color="gray")
stub <- "2021-05-14 01:40 to 2021-05-17 08:26"
table_data <- data.frame (
Instance = c("Intel[R] Ethernet 10G",
"Intel[R] Ethernet Converged Network Adapter _1",
"Intel[R] Ethernet Converged Network Adapter _2",
"Intel[R] Ethernet 10G",
"Intel[R] Gigabit"),
Max = c(2.45, 2.41, 2.29, 2.17, 0),
Avg = c(0.15, 0.15, 0.15, 0.17, 0)
)
table <- table_data %>% flextable() %>%
set_caption(caption = Caption , html_escape = F) %>%
bg(bg = "#579FAD", part = "header") %>%
color(color = "white", part = "header") %>%
theme_zebra(
odd_header = "#579FAD",
odd_body = "#E0EFF4",
even_header = "transparent",
even_body = "transparent"
) %>%
set_table_properties(width = 1, layout = "autofit") %>%
hline(part="all", border = std_border ) %>%
vline(part="all", border = std_border ) %>%
border_outer( border = bold_border, part = "all" ) %>%
fix_border_issues() %>%
set_header_labels(
values = list(Instance = InstanceName ) ) %>%
flextable::font (part = "all" , fontname = "Calibri")
save_as_docx( table, path = file.path("c:\\temp", "test01.docx") )
save_as_html (table, path = file.path("c:\\temp", "test01.html"))
Here is what I got in html which is okay for me:
But in docx format my header style is not applied:
How can I create header like I did for html that can be saved to both html and docx?
If I have to create separate tables - one for html, other for docx - it's not so good but acceptable options. That case my question how to create header I made in html but for docx format?

R: saving multiple html widgets together

I am using the R programming language. I am interested in learning how to save several "html widgets" together. I have been able to manually create different types of html widgets:
#widget 1
library(htmlwidgets)
library(leaflet)
library(RColorBrewer)
# create map data
map_data <- data.frame(
"Lati" = c(43.6426, 43.6424, 43.6544, 43.6452, 43.6629), "Longi" = c(-79.3871, -79.3860, -79.3807, -79.3806, -79.3957),
"Job" = c("Economist", "Economist", "Teacher", "Teacher", "Lawyer"),
"First_Name" = c("John", "James", "Jack", "Jason", "Jim"),
"Last_Name" = c("Smith", "Charles", "Henry", "David", "Robert"),
"vehicle" = c("car", "van", "car", "none", "car")
)
kingdom <- c("Economist", "Lawyer", "Teacher")
my_palette <- brewer.pal(3, "Paired")
factpal <- colorFactor(my_palette, levels = kingdom)
groups <- unique(map_data$Job)
# finalize map
map <- leaflet(map_data) %>%
addTiles(group = "OpenStreetMap") %>%
addCircleMarkers(~Longi, ~Lati, popup = ~Job,
radius = 10, weight = 2, opacity = 1, color = ~factpal(Job),
fill = TRUE, fillOpacity = 1, group = ~Job
)
widget_1 = map %>%
addLayersControl(overlayGroups = groups, options = layersControlOptions(collapsed = FALSE)) %>%
addTiles() %>%
addMarkers(lng = ~Longi,
lat = ~Lati,
popup = ~paste("Job", Job, "<br>",
"First_Name:", First_Name, "<br>",
"Last_Name:", Last_Name, "<br>", "vehicle:", vehicle, "<br>"))
widget 2:
##### widget 2
library(plotly)
library(ggplot2)
p_plot <- data.frame(frequency = c(rnorm(31, 1), rnorm(31)),
is_consumed = factor(round(runif(62))))
p2 <- p_plot %>%
ggplot(aes(frequency, fill = is_consumed)) +
geom_density(alpha = 0.5)
widget_2 = ggplotly(p2)
widget 3:
#####widget_3
today <- Sys.Date()
tm <- seq(0, 600, by = 10)
x <- today - tm
y <- rnorm(length(x))
widget_3 <- plot_ly(x = ~x, y = ~y, mode = 'lines', text = paste(tm, "days from today"))
widget 4:
####widget_4
library(igraph)
library(dplyr)
library(visNetwork)
Data_I_Have <- data.frame(
"Node_A" = c("John", "John", "John", "Peter", "Peter", "Peter", "Tim", "Kevin", "Adam", "Adam", "Xavier"),
"Node_B" = c("Claude", "Peter", "Tim", "Tim", "Claude", "Henry", "Kevin", "Claude", "Tim", "Henry", "Claude")
)
graph_file <- data.frame(Data_I_Have$Node_A, Data_I_Have$Node_B)
colnames(graph_file) <- c("Data_I_Have$Node_A", "Data_I_Have$Node_B")
graph <- graph.data.frame(graph_file, directed=F)
graph <- simplify(graph)
nodes <- data.frame(id = V(graph)$name, title = V(graph)$name)
nodes <- nodes[order(nodes$id, decreasing = F),]
edges <- get.data.frame(graph, what="edges")[1:2]
widget_4 = visNetwork(nodes, edges) %>% visIgraphLayout(layout = "layout_with_fr") %>%
visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)
From here, I found another stackoverflow post where a similar question was asked: Using R and plot.ly, how to save multiples htmlwidgets to my html?
In this post, it explains how to save several html widgets together - the person who answered the question wrote a function to do so:
library(htmltools)
save_tags <- function (tags, file, selfcontained = F, libdir = "./lib")
{
if (is.null(libdir)) {
libdir <- paste(tools::file_path_sans_ext(basename(file)),
"_files", sep = "")
}
htmltools::save_html(tags, file = file, libdir = libdir)
if (selfcontained) {
if (!htmlwidgets:::pandoc_available()) {
stop("Saving a widget with selfcontained = TRUE requires pandoc. For details see:\n",
"https://github.com/rstudio/rmarkdown/blob/master/PANDOC.md")
}
htmlwidgets:::pandoc_self_contained_html(file, file)
unlink(libdir, recursive = TRUE)
}
return(htmltools::tags$iframe(src= file, height = "400px", width = "100%", style="border:0;"))
}
I tried using this function to save the 4 widgets together:
save_tags(widget_1, widget_2, widget_3, widget_4)
But doing so, I got the following error:
Error in dirname(file) : a character vector argument expected
Is there a straightforward and simple way for saving multiple html widgets together?
Thanks
NOTE: I know that you can use the combineWidgets() function in R:
library(manipulateWidget)
combineWidgets(widget_1, widget_2, widget_3, widget_4)
However, I am working with a computer that has no internet access or USB ports. This computer has a pre-installed copy of R with limited libraries (it has all the libraries used throughout my question except "manipulateWidget"). I am looking for the simplest way to save multiple html widgets together (e.g. is this possible in base R)?
Thanks
If format doesn't matter too much, you can merge the widgets using tagList and save them directly:
htmltools::save_html(tagList(widget_1, widget_2, widget_3, widget_4), file = "C://Users//Me//Desktop//widgets.html")
(It goes without saying that you will need to edit the filepath!)
If you want to control the layout of the widgets, you can wrap each in a div, and then style those:
doc <- htmltools::tagList(
div(widget_1, style = "float:left;width:50%;"),
div(widget_2,style = "float:left;width:50%;"),
div(widget_3, style = "float:left;width:50%;"),
div(widget_4, style = "float:left;width:50%;")
)
htmltools::save_html(html = doc, file = "C://Users//Me//Desktop//widgets.html")

Creating label in leaflet map using htmltools produces tiny label

Creating a leaflet map. First step, specify the label. The code used on leaflet github puts
%>% lapply(htmltool::HTML)
after the sprintf() function. However, making it is creating the label as a type:"list" resulting in the error: "Error in sum(sapply(label, function(x) { : invalid 'type' (list) of argument"
So to try and get around this I just load the htmltools library and use the code
HTML(sprintf(...))
Doing this works and runs the map, however, the labels show up as small boxes with no information (see picture link below)
I can't tell if this is something to do with the code inside sprintf() or if this has to do with HTML().
The weird thing is that the %>% lapply method was working just fine, but something happened and now its giving the error mentioned above
Image with the small label shown as little white box
labels.dest2 <- sprintf("<div style = 'overflow-wrap: anywhere;'><strong>%s <br/>%s Destinations</div><br/>%s Euclidean Miles from LAX on average<br/>%s minutes between OD tweets </div><br/>%s Miles from LAX on average</div><br/>%s minutes from LAX on average</div>",
puma.spdf$NAME,
puma.spdf$Dest_pt_count,
puma.spdf$Avg_Euc_Dist_Mi,
puma.spdf$Avg_tweetTime,
puma.spdf$Avg_RtDist_Mi,
puma.spdf$Avg_RtTime_min) %>% lapply(htmltools::HTML)
leaflet() %>% addTiles() %>% etc...
FULL CODE HERE
## Map with OD data and travel stats ##
labels.dest2 <- HTML(sprintf("<div style = 'overflow-wrap: anywhere;'> <strong>%s <br/>%g Destinations</div><br/>%s Euclidean Miles from LAX on average<br/>%s minutes between OD tweets </div><br/>%s Miles from LAX on average</div><br/>%s minutes from LAX on average</div>",
puma.spdf$NAME,
puma.spdf$Dest_pt_count,
puma.spdf$Avg_Euc_Dist_Mi,
puma.spdf$Avg_tweetTime,
puma.spdf$Avg_RtDist_Mi,
puma.spdf$Avg_RtTime_min))
leaflet() %>% addTiles() %>%
setView(lng=-118.243683, lat=34.1, zoom = 9.35) %>%
addEasyButton(easyButton(
icon="fa-crosshairs", title = "Default View",
onClick=JS("function(btn, map) {var groupLayer = map.layerManager.getLayerGroup('Destinations (red)'); map.fitBounds(groupLayer.getBounds());}"))) %>%
addProviderTiles(providers$CartoDB.Positron,
group = "Grey") %>%
addProviderTiles(providers$OpenStreetMap.BlackAndWhite,
group = "OSM") %>%
# Add Polygons
# Destination data
addPolygons(data = puma.spdf,
group = "Destination Density",
fillColor = ~pal.dest(Dest_pt_count),
weight = 1,
opacity = 90,
color = "white",
dashArray = "3",
fillOpacity = 0.5,
highlight = highlightOptions(weight = 2,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE,
sendToBack = TRUE),
label = labels.dest2,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addLegend(values=puma.spdf$Dest_pt_count,
group = "Destination Density",
pal=pal.dest,
title="Destination Density (Dest per PUMA)",
position = "bottomright") %>%
# Add Points
addCircleMarkers(data = D.spdf,
radius = 2,
color = "red",
group = "Destinations (red)",
fillOpacity = 0.5) %>%
addCircleMarkers(data = O.spdf,
radius = 2,
color = "green",
group = "Origins (green)") %>%
# Add Layer Controls
addLayersControl(
baseGroups = c("OSM (default)", "Grey"),
overlayGroups = c("Destinations (red)", "Origins (green)","Destination Density"),
options = layersControlOptions(collapsed = FALSE)
)
The problem was that the first column puma.spdf$NAME was not part of the dataset and was throwing off the string.. check to make sure all the variables you want to show are actually part of the dataset.

Why is the layout of a graph from visnetwork in html too small

When I render the example-Rmd below, it looks like this (with Chrome, not really a difference to Firefox):
The figure is way too small and if I look at the "real" graphs I need, the height is too small and the ratio height-width is even worse.
Here is a reproducible example:
---
title: "Untitled"
author: "author"
date: "9 Mai 2018"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
## Example
Here is a line of text...................................................................................................................................................................................................................................................................
```{r echo=FALSE}
require(visNetwork, quietly = TRUE)
# minimal example
nodes <- data.frame(id = 1:20)
edges <- data.frame(from = sample(c(1:20), 10), to = sample(c(1:20), 10))
visNetwork(nodes, edges, width = "100%", height = "100%") %>%
visNodes() %>%
visOptions(highlightNearest = TRUE) %>%
visInteraction(navigationButtons = TRUE,
dragNodes = FALSE,
dragView = FALSE, zoomView = FALSE) %>%
visEdges(arrows = 'to')
```
Here is another line of text....................................................................................................................................................................................................................................................................
I expected to fix it using some chunk options, such as out.height or fig.height but for some reason they don't.
However you can set a fixed height for the widget itself, simply passing a number to the height argument that will be interpreted as pixels:
```{r echo=FALSE}
require(visNetwork, quietly = TRUE)
# minimal example
nodes <- data.frame(id = 1:20)
edges <- data.frame(from = sample(c(1:20), 10), to = sample(c(1:20), 10))
visNetwork(nodes, edges, width = "100%", height = 700) %>%
visNodes() %>%
visOptions(highlightNearest = TRUE) %>%
visInteraction(navigationButtons = TRUE,
dragNodes = FALSE,
dragView = FALSE, zoomView = FALSE) %>%
visEdges(arrows = 'to')
```