Setting the width of formattable() object - html

I am using the formattable package (AWESOME PACKAGE) to do some conditional formatting on a table of data that I have web scraped. I want to put the resulting object in a html document side by side with another formattable() table. I can't, however, figure out how to set the width of the table(either in the function or in the knitr chunk), and consequently how to put the two objects side by side.
Here is my code. I realize it is sloppy. Can someone help me put two of the same table side by side in .rmd knitting to html? It will in reality be two different formattable() tables but it doesn't really matter for this purpose.
library(formattable, quietly = T)
library(rvest, quietly = T)
#Part 1: Air pollution forecast from sparetheair.org
#read the page
#0-50 Good Green
#51-100 Moderate Yellow
#101-150 Unhealthy for Sensitive Groups Orange
#151-200 Unhealthy Red
#201-300 Very Unhealthy Purple --> Also red for simplicity
air_quality <- read_html("http://sparetheair.org/stay-informed/todays- air-quality/five-day-forecast")
#Scrape table
box <- html_nodes(air_quality,"div div .f5day")
content <- html_text(box)
#Text cleaning, removing artifacts
fulltext <- gsub("\n"," ",content)
fulltext1 <- gsub("\n"," ",fulltext)
fulltext2 <- gsub("\r"," ", fulltext1)
fulltext3 <- gsub("\t"," ", fulltext2)
#split the string into a character vector of strings
mytext <- unlist(strsplit(fulltext3," "))
#Leave empty spaces out,
wholething <- mytext[mytext != ""]
#vector of days
Days <- wholething[1:5]
#character data for table construction
wholedata <- wholething[6:69]
#a subset of Oakland related data
baydata <- wholedata[13:26]
#convert to data frame exactly as it is on website
mydf <- data.frame(rbind(baydata[5:9], baydata[10:14]), row.names=c("AQI","PMI"))
#transposed data frame (tidy data, observations in rows, variables in cols)
tmydf <- data.frame(cbind(Days, baydata[5:9], baydata[10:14]), row.names = NULL, stringsAsFactors = F)
#replace the names of the new df with the webscraped days of the week
names(tmydf) <- c("Day","AQI","PMI")
tmydf$PMI <- gsub("PM","",tmydf$PMI)
#Print to an html table the resulting dataframe
#eventually this will have some color coding or reactive element
#focus only on numeric variables
smaller <- tmydf[1:2,]
#Coerce to numeric
smaller$AQI <- as.numeric(smaller$AQI)
smaller$PMI <- as.numeric(smaller$PMI)
#Format ouput based on scale above
nicetable <- formattable(smaller,
list(
AQI = formatter("span", style = x ~
ifelse(x <= 50, style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "green",
color = "white", font.weight = "bold"),
ifelse(x <= 100, style(display = "block",`border-radius` = "4px",
padding = "0 4px", background = "yellow",
color ="white", font.weight = "bold"),
style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "red",
color = "white", font.weight = "bold") ) ) ),
PMI = formatter("span",style = x ~
ifelse(x == 2.5, style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "red",
color = "white", font.weight = "bold"),
style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "green",
color = "white", font.weight = "bold") ) )
)
)
nicetable
GithubRepo

I'll try to explain in the code, but to specify a width we just need to manually convert formattable to a htmlwidget with as.htmlwidget(). This should also work in rmarkdown.
library(formattable, quietly = T)
library(rvest, quietly = T)
#Part 1: Air pollution forecast from sparetheair.org
#read the page
#0-50 Good Green
#51-100 Moderate Yellow
#101-150 Unhealthy for Sensitive Groups Orange
#151-200 Unhealthy Red
#201-300 Very Unhealthy Purple --> Also red for simplicity
air_quality <- read_html("http://sparetheair.org/stay-informed/todays-air-quality/five-day-forecast")
#Scrape table
box <- html_nodes(air_quality,xpath="//div//div[contains(#class, 'f5day')]")
content <- html_text(box)
#Text cleaning, removing artifacts
fulltext <- gsub("\n"," ",content)
fulltext1 <- gsub("\n"," ",fulltext)
fulltext2 <- gsub("\r"," ", fulltext1)
fulltext3 <- gsub("\t"," ", fulltext2)
#split the string into a character vector of strings
mytext <- unlist(strsplit(fulltext3," "))
#Leave empty spaces out,
wholething <- mytext[mytext != ""]
#vector of days
Days <- wholething[1:5]
#character data for table construction
wholedata <- wholething[6:69]
#a subset of Oakland related data
baydata <- wholedata[13:26]
#convert to data frame exactly as it is on website
mydf <- data.frame(rbind(baydata[5:9], baydata[10:14]), row.names=c("AQI","PMI"))
#transposed data frame (tidy data, observations in rows, variables in cols)
tmydf <- data.frame(cbind(Days, baydata[5:9], baydata[10:14]), row.names = NULL, stringsAsFactors = F)
#replace the names of the new df with the webscraped days of the week
names(tmydf) <- c("Day","AQI","PMI")
tmydf$PMI <- gsub("PM","",tmydf$PMI)
#Print to an html table the resulting dataframe
#eventually this will have some color coding or reactive element
#focus only on numeric variables
smaller <- tmydf[1:2,]
#Coerce to numeric
smaller$AQI <- as.numeric(smaller$AQI)
smaller$PMI <- as.numeric(smaller$PMI)
#Format ouput based on scale above
nicetable <- formattable(smaller,
list(
AQI = formatter("span", style = x ~
ifelse(x <= 50, style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "green",
color = "white", font.weight = "bold"),
ifelse(x <= 100, style(display = "block",`border-radius` = "4px",
padding = "0 4px", background = "yellow",
color ="white", font.weight = "bold"),
style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "red",
color = "white", font.weight = "bold") ) ) ),
PMI = formatter("span",style = x ~
ifelse(x == 2.5, style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "red",
color = "white", font.weight = "bold"),
style(display = "block",`border-radius` = "4px",
padding = "0 4px",background = "green",
color = "white", font.weight = "bold") ) )
)
)
nicetable
# so what happens is a formattable object
# gets converted to an htmlwidget
# for viewing when interactive
# to specify a width
# we have to do the htmlwidget conversion ourselves
# with as.htmlwidget
as.htmlwidget(nicetable, width=200)
# just use shiny to get helper fluid functions
library(shiny)
library(htmltools)
browsable(
tagList(
fluidRow(
column(
width = 6,
as.htmlwidget(nicetable)
),
column(
width = 6,
as.htmlwidget(nicetable)
)
)
)
)

Related

DT table in Shiny (overriding custom css) - How to color the whole row based on a value in a specific column?

I am trying to color the top two rows differently from the rest of the table as it contains control samples. The table is made using DT for Shiny app.
Desired output:
Actual output:
The code:
output$table <- renderDataTable({
dt <- dt %>% datatable(rownames=FALSE, class="table table-hover row-border", extensions = c( 'FixedHeader'),
options = list( scrollX = TRUE, pageLength = -1,dom = 'Btpl', ordering = TRUE,
dom="ft",
lengthMenu = list(c(10,25,-1),
c(10,25,"All")),
columnDefs = list(list(visible=FALSE, targets=c(7,8)))
)) %>%
formatStyle('Sample',
fontWeight ='bold',
backgroundColor = styleEqual(c("Positive control", "Negative control"),
c("#fcf4d9", "#fcf4d9")))
})
I have tried adding target = "row" argument but it doesn't work. I also tried to use styleRow() instead of styleEqual() but this resulted in error "coercion of NA values".
Update:
The default bakcground colors are specified in tags$style that is why it doesn't work using format style:
tags$style(HTML(sprintf('table.dataTable tbody tr {background-color: %1$s !important; color: %2$s !important;}',
table_col,font_col_dark)))
I am not that familiar with this expression, but is it possible to specify the bakcground color for controls in tags instead?
Adding target = 'row' should be the solution:
Code:
# Data
dt <- tibble(Well = 1:5, Sample = c("Positive control", "Negative control", "Sample 1", "Sample 2", "Sample 3"), Result = 10:14)
# Table
dt %>% datatable(rownames=FALSE, class="table table-hover row-border", extensions = c( 'FixedHeader'),
options = list( scrollX = TRUE, pageLength = -1,dom = 'Btpl', ordering = TRUE,
dom="ft",
lengthMenu = list(c(10,25,-1),
c(10,25,"All")),
columnDefs = list(list(visible=FALSE, targets=c(7,8)))
)) %>%
formatStyle('Sample',
fontWeight ='bold',
target = 'row',
backgroundColor = styleEqual(c("Positive control", "Negative control"),
c("#fcf4d9", "#fcf4d9")))
Update:
You might control the background color by using some helper vectors instead:
# Data
dt <- tibble(Well = 1:5, Sample = c("Positive control", "Negative control", "Sample 1", "Sample 2", "Sample 3"), Result = 10:14)
# Helper
id_helper <- unique(dt$Sample)
color_helper <- ifelse(id_helper %in% c("Positive control", "Negative control"), '#fcf4d9', 'blue')
# Table
dt %>% datatable(rownames=FALSE, class="table table-hover row-border", extensions = c( 'FixedHeader'),
options = list( scrollX = TRUE, pageLength = -1,dom = 'Btpl', ordering = TRUE,
dom="ft",
lengthMenu = list(c(10,25,-1),
c(10,25,"All")),
columnDefs = list(list(visible=FALSE, targets=c(7,8)))
)) %>%
formatStyle('Sample',
fontWeight ='bold',
target = 'row',
backgroundColor = styleEqual(id_helper,
color_helper))

Stripe effect in formattable(), shadow in light gray every other row. R

I was wondering, does anyone know how to achieve the "stripe" style seen in kableExtra? That is to shadow in light gray odd rows but not even rows? Something like the following picture:
Given my code using formattable, I am going to export the table to a pdf document, so I would like to know If I can achieve that effect? is it possible? I tried modifying td's, tr's but the actual cells were very strangely shaded creating an undesired effect. This is the current code I got and its output:
library("htmltools")
library("webshot")
library(formattable)
DF <- data.frame(Ticker=c("", "", "", "IBM", "AAPL", "MSFT"),
Name=c("Dow Jones", "S&P 500", "Technology",
"IBM", "Apple", "Microsoft"),
Value=accounting(c(15988.08, 1880.33, 50,
130.00, 97.05, 50.99)),
Change=percent(c(-0.0239, -0.0216, 0.021,
-0.0219, -0.0248, -0.0399)))
################################## FUNCTIONS ##################################
unit.scale = function(x) (x - min(x)) / (max(x) - min(x))
export_formattable <- function(f, file, width = "100%", height = NULL,
background = "white", delay = 0.2)
{
w <- as.htmlwidget(f, width = width, height = height)
#Remove row height!
w <- htmlwidgets::prependContent(w, tags$style("td { padding: 0px !Important;}"))
path <- html_print(w, background = background, viewer = NULL)
url <- paste0("file:///", gsub("\\\\", "/", normalizePath(path)))
webshot(url,
file = file,
selector = ".formattable_widget",
delay = delay)
}
###############################################################################
FT <- formattable(DF, align =c("l","c","r","c"), list(
Name=formatter("span",
style = x ~ ifelse(x == "Technology", style(font.weight = "bold"), NA)), #NOT APPLIED when we output to PNG with the function!
#Value = color_tile("white", "orange"),
Value = color_bar("orange" , fun = unit.scale
),
Change = formatter("span",
style = x ~ style(color = ifelse(x < 0 , "red", "green"), "font.size" = "18px"),
x ~ icontext(ifelse(x < 0, "arrow-down", "arrow-up"), x)
)),
table.attr = 'style="font-size: 18px; font-family: Calibri";\"')
FT
#OUTPUT the table in the document as an image!
export_formattable(FT,"/outputpath/FT.png")
Thanks in advance!
You can use .table-striped inside the table.attr argument to add zebra-striping to any table row.
Code
FT <- formattable(DF, align =c("l","c","r","c"), list(
Name=formatter("span",
style = x ~ ifelse(x == "Technology", style(font.weight = "bold"), NA)), #NOT APPLIED when we output to PNG with the function!
#Value = color_tile("white", "orange"),
Value = color_bar("orange" , fun = unit.scale
),
Change = formatter("span",
style = x ~ style(color = ifelse(x < 0 , "red", "green"), "font.size" = "18px"),
x ~ icontext(ifelse(x < 0, "arrow-down", "arrow-up"), x)
)),
table.attr = 'class=\"table table-striped\" style="font-size: 18px; font-family: Calibri"')
Table

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.

Embedding flextable in outlook with rdcomclient

I am facing the following issue: I created a beautiful flextable from a dataframe in R, which I would like to send via email. I use htmltools_value to get the HTML code of the flextable. Now I am able to embed this as htmlbody in my email which works in a sense that I succesfully send the email. However, the email is losing all the colors and borders with rest of the formatting still as defined in the flextable. Anyone faced similar issues or has an idea what could be the problem?
require(flextable)
require(RDCOMClient)
header_col2 <- c("","","", "", "2nd header", "2nd header","More headers", "More headers", "More headers", "More headers")
dfTest <- mtcars[c(1:6),c(1:10)]
ft <- flextable(dfTest)
ft <- add_header_row(ft,values = header_col2,top = T,colwidths = c(rep(1,10))) ft <- merge_h(ft, part = "header")
ft <-bold(ft, bold=T, part="header")
ft <-theme_zebra(ft,odd_header = 'red', even_header = 'grey', odd_body = 'lightblue', even_body = "white")
ft <- color(ft, color = "white", part = "header")
ft <- bold(ft, bold = TRUE, part = "header")
ft <- fontsize(ft, size = 11, part = "header")
std_border = fp_border(color="white", width = 1.5)
big_border = fp_border(color="gray", width = 1)
ft <- border_outer(ft, part="all", border = big_border )
ft <- border_inner_v(ft, part="header", border = std_border )
body <- htmltools_value(ft)
# or body <- format(ft, type = "html")
OutApp <- COMCreate("Outlook.Application")
outMail = OutApp$CreateItem(0)
outMail[["To"]] = "test#test.com"
outMail[["subject"]] = "TEST"
outMail[["HTMLbody"]] = body
outMail$Send()

Convert html output to image

I'm using R formattable package to render some data frames but the output is html ( it opens the browser after I run the script ).
The thing is I'm trying to render those tables under PowerBI which accepts R scripts but need the output to be an image (like a ggplot) not html. But I don't know how I can do it.
I've looked into R2HTML and htmlwidgets packages but I still didn't find a solution with those. ( I may have made some mistakes ).
Here is the dummy code I'm working with:
library(formattable)
DF <- data.frame(Ticker=c("", "", "", "IBM", "AAPL", "MSFT"),
Name=c("Dow Jones", "S&P 500", "Technology",
"IBM", "Apple", "Microsoft"),
Value=accounting(c(15988.08, 1880.33, NA,
130.00, 97.05, 50.99)),
Change=percent(c(-0.0239, -0.0216, 0.021,
-0.0219, -0.0248, -0.0399)))
DF
## Ticker Name Value Change
## 1 Dow Jones 15,988.08 -2.39%
## 2 S&P 500 1,880.33 -2.16%
## 3 Technology NA 2.10%
## 4 IBM IBM 130.00 -2.19%
## 5 AAPL Apple 97.05 -2.48%
## 6 MSFT Microsoft 50.99 -3.99%
formattable(DF, list(
Name=formatter(
"span",
style = x ~ ifelse(x == "Technology",
style(font.weight = "bold"), NA)),
Value = color_tile("white", "orange")
Change = formatter(
"span",
style = x ~ style(color = ifelse(x < 0 , "red", "green")),
x ~ icontext(ifelse(x < 0, "arrow-down", "arrow-up"), x))))
formattable(DF, list(
Name = formatter(
"span", style = x ~ ifelse(x == "Technology", style(font.weight = "bold"), NA)
),
Value = color_tile("white", "orange"),
Change = formatter(
"span", style = x ~ style(color = ifelse(x < 0 , "red", "green")),
x ~ icontext(ifelse(x < 0, "arrow-down", "arrow-up"), x)))
) -> w
htmlwidgets::saveWidget(as.htmlwidget(w), "/some/dir/table.html", selfcontained = TRUE)
webshot::webshot(url = "/some/dir/table.html", file = "/some/dir/table.png",
vwidth = 1000, vheight = 275)
The width/height is not necessarily going to come out precisely as what's specified and you'll need to do some manual guessing for it (or load up magick and see if you can auto-clip using it).
This relies on phantomjs and you may not be able to get your IT and/or security groups to enable the use of it.