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.
Related
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
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")
I have one Rmarkdown document, that was given to me and worked fine with the person who given to me.
But when I do with my datas, I dont know what's going on, when I run the exactly code with script document works well, but when I try to knit to html, give me an error.
bhv_df <- plyr::ddply(bhv_df, ~segmentid, function(d){
d= bhv_df[bhv_df$segmentid == bhv_df$segmentid[1],
# predictions are made based on the mid time between start and end of the message
predObj <- crawl::crwPredict(object.crwFit = crawl_models_list[[d$segmentid[1]]], predTime = d$MidTime, speedEst=TRUE, flat=TRUE)
predObj_dives <- predObj[predObj$locType == "p",]
# reproject into lat/long, because the crawl models have been built in a mercator pacific centered CRS
coord_points <- predObj_dives
coordinates(coord_points) =~ mu.x + mu.y
proj4string(coord_points) <- CRS("+proj=merc +lon_0=0 +k=1 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs")
predObj_dives[c("lon", "lat")] <- coordinates(spTransform(coord_points, CRS("+proj=longlat +datum=WGS84")))
# calculate the lon360
return(cbind(d, predObj_dives[c("mu.x", "mu.y", "lon", "lat")]))
})
#load("./Outputs/crawl_argos_df.RData")
######### MERGE DIVE DATASET with CRAWL-derived MOUVEMENT DATA
bhv_df <- plyr::ddply(bhv_df, ~segmentid, function(d){ # for each tag dive data
cr <- crawl_argos_df[crawl_argos_df$segmentid == d$segmentid[1], ] # select the corresponding crawl track
fl <- filtered_argos_df_crawl[filtered_argos_df_crawl$segmentid == d$segmentid[1], ] # select the corresponding filtered track
d[c("lq_closest_filt","dt_closest_filt", "dist_closest_filt", "rel.angle","speed")] <- NA # add empty columns
for (i in 1:nrow(d)){ # for each dive...
fl$dist_diff <- as.vector(spDists(x = as.matrix(d[i,c("lon", "lat")]), y = as.matrix(fl[c("lon", "lat")]), longlat = T)) # distance calculated in km
fl$dt_diff <- as.numeric(difftime(d$MidTime[i], fl$time, units = "hours"))
d[i, "dt_closest_filt"] <- min(abs(fl$dt_diff)) # select the filtered position closest in time to the dive, time in hours
d[i, "dist_closest_filt"] <- fl[which(abs(fl$dt_diff) == min(abs(fl$dt_diff))), "dist_diff"][1] # retrieve the distance from this filtered position to the dive location (predicted by crawl)
d[i, "lq_closest_filt"] <- fl[which(abs(fl$dt_diff) == min(abs(fl$dt_diff))), "lq"][1] # argos quality of closest filtered argos position
cr$diff <- as.numeric(difftime(d$MidTime[i], cr$time, units = "hours")) # look at the time diff between this dive and all positions recorded in crawl for that same tag
d[i, c("rel.angle","speed")] <- cr[abs(cr$diff) == min(abs(cr$diff)), c("rel.angle", "speed")] # select closest position recorded when dive occurred
}
return(d)
})
bhv_df$depth_bin <- cut(bhv_df$DepthMean, seq(0, 700, 50))
ggplot(bhv_df[bhv_df$What == "Dive" & bhv_df$depth_range == "deep" & bhv_df$DepthMean < 1000,], aes(x = lon, y = lat)) +
stat_contour(data = bathyNOAA_df, aes(x, y, z=z), binwidth = 500, color = "grey60", size = 0.2) +
geom_tile(data = bathyNOAA_df_shallow[bathyNOAA_df_shallow$z >= 0, ], aes(x, y), fill = "grey10") +
geom_jitter(aes(fill = -DepthMean, size = DepthMean), col="black", alpha=0.8, pch = 21, width=0.1) +
scale_fill_viridis(option = "magma", name = "Dive Depth (m)", direction = 1, begin = 0.2) +
xlab("Longitude") +
ylab("Latitude") +
coord_fixed(xlim = c(-50, -26), ylim = c(-55, -15), expand = F)
The error (is it just at beginning of the code, at 4 line):
Erro: unexpected symbol in:
" predObj <- crawl::crwPredict(object.crwFit = crawl_models_list[[d$segmentid1]], predTime = d$MidTime, speedEst=TRUE, flat=TRUE)
predObj_dives"
And this:
I tryed to see if have conflicts, but apparently dont have
> conflicts()
[1] "lines" "cividis" "inferno" "magma" "plasma" "viridis" "viridis.map"
[8] "summary" "days" "hours" "minutes" "origin" "seconds" "show"
[15] "years" "hour" "isoweek" "mday" "minute" "month" "quarter"
[22] "second" "wday" "week" "yday" "year" "coerce" "coerce"
[29] "plot" "show" "summary" "%>%" "%>%" "%>%" "between"
[36] "count" "first" "intersect" "last" "setdiff" "union" "%>%"
[43] "flatten" "map" "transpose" "%>%" "add_row" "as_data_frame" "as_tibble"
[50] "data_frame" "data_frame_" "frame_data" "glimpse" "lst" "lst_" "tbl_sum"
[57] "tibble" "tribble" "trunc_mat" "type_sum" "enexpr" "enexprs" "enquo"
[64] "enquos" "ensym" "ensyms" "expr" "quo" "quo_name" "quos"
[71] "sym" "syms" "vars" "filter" "lag" "lines" "plot"
[78] "as.raster" "data" "Arith" "coerce" "Compare" "initialize" "show"
[85] "as.difftime" "body<-" "date" "intersect" "kronecker" "merge" "Position"
[92] "setdiff" "setequal" "split" "subset" "summary" "union"
>
Someone know what's going on?
Thanks!
After many tries, I removed one part of the code, and everything worked well
# I removed: d= bhv_df[bhv_df$segmentid == bhv_df$segmentid[1],
bhv_df <- plyr::ddply(bhv_df, ~segmentid, function(d){
# predictions are made based on the mid time between start and end of the message
predObj <- crawl::crwPredict(object.crwFit = crawl_models_list[[d$segmentid[1]]], predTime = d$MidTime, speedEst=TRUE, flat=TRUE)
predObj_dives <- predObj[predObj$locType == "p",]
# reproject into lat/long, because the crawl models have been built in a mercator pacific centered CRS
coord_points <- predObj_dives
coordinates(coord_points) =~ mu.x + mu.y
proj4string(coord_points) <- CRS("+proj=merc +lon_0=0 +k=1 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs")
predObj_dives[c("lon", "lat")] <- coordinates(spTransform(coord_points, CRS("+proj=longlat +datum=WGS84")))
# calculate the lon360
return(cbind(d, predObj_dives[c("mu.x", "mu.y", "lon", "lat")]))
})
######### MERGE DIVE DATASET with CRAWL-derived MOUVEMENT DATA
bhv_df <- plyr::ddply(bhv_df, ~segmentid, function(d){ # for each tag dive data
cr <- crawl_argos_df[crawl_argos_df$segmentid == d$segmentid[1], ] # select the corresponding crawl track
fl <- filtered_argos_df_crawl[filtered_argos_df_crawl$segmentid == d$segmentid[1], ] # select the corresponding filtered track
d[c("lq_closest_filt","dt_closest_filt", "dist_closest_filt", "rel.angle","speed")] <- NA # add empty columns
for (i in 1:nrow(d)){ # for each dive...
fl$dist_diff <- as.vector(spDists(x = as.matrix(d[i,c("lon", "lat")]), y = as.matrix(fl[c("lon", "lat")]), longlat = T)) # distance calculated in km
fl$dt_diff <- as.numeric(difftime(d$MidTime[i], fl$time, units = "hours"))
d[i, "dt_closest_filt"] <- min(abs(fl$dt_diff)) # select the filtered position closest in time to the dive, time in hours
d[i, "dist_closest_filt"] <- fl[which(abs(fl$dt_diff) == min(abs(fl$dt_diff))), "dist_diff"][1] # retrieve the distance from this filtered position to the dive location (predicted by crawl)
d[i, "lq_closest_filt"] <- fl[which(abs(fl$dt_diff) == min(abs(fl$dt_diff))), "lq"][1] # argos quality of closest filtered argos position
cr$diff <- as.numeric(difftime(d$MidTime[i], cr$time, units = "hours")) # look at the time diff between this dive and all positions recorded in crawl for that same tag
d[i, c("rel.angle","speed")] <- cr[abs(cr$diff) == min(abs(cr$diff)), c("rel.angle", "speed")] # select closest position recorded when dive occurred
}
return(d)
}) #warnings probably due to RT being equal to NA at beginning and end of the track
Thank you
Say I have two htmlwidgets
# Load energy projection data
# Load energy projection data
library(networkD3)
URL <- paste0(
"https://cdn.rawgit.com/christophergandrud/networkD3/",
"master/JSONdata/energy.json")
Energy <- jsonlite::fromJSON(URL)
# Plot
sankeyNetwork(Links = Energy$links, Nodes = Energy$nodes, Source = "source",
Target = "target", Value = "value", NodeID = "name",
units = "TWh", fontSize = 12, nodeWidth = 30)
and
library(leaflet)
data(quakes)
# Show first 20 rows from the `quakes` dataset
leaflet(data = quakes[1:20,]) %>% addTiles() %>%
addMarkers(~long, ~lat, popup = ~as.character(mag))
And I want to put them side by side in an html page. How can I do this? Could I use an iframe? Other?
There are lots of ways to answer this. Often sizing and positioning will vary based on who authored the htmlwidget, so you might need to experiment a little. The easiest way if you don't plan to use a CSS framework with grid helpers will be to wrap each htmlwidget in tags$div() and use CSS. You also might be interested in the very nice new flexbox-based dashboard package from RStudio http://github.com/rstudio/flexdashboard.
# Load energy projection data
# Load energy projection data
library(networkD3)
URL <- paste0(
"https://cdn.rawgit.com/christophergandrud/networkD3/",
"master/JSONdata/energy.json")
Energy <- jsonlite::fromJSON(URL)
# Plot
sn <- sankeyNetwork(Links = Energy$links, Nodes = Energy$nodes, Source = "source",
Target = "target", Value = "value", NodeID = "name",
units = "TWh", fontSize = 12, nodeWidth = 30,
width = "100%")
library(leaflet)
data(quakes)
# Show first 20 rows from the `quakes` dataset
leaf <- leaflet(data = quakes[1:20,]) %>% addTiles() %>%
addMarkers(~long, ~lat, popup = ~as.character(mag))
library(htmltools)
browsable(
tagList(list(
tags$div(
style = 'width:50%;display:block;float:left;',
sn
),
tags$div(
style = 'width:50%;display:block;float:left;',
leaf
)
))
)
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)
)
)
)
)