how to apply selectively borders to an existing xlsx using openxlsx - openxlsx

The objective is to apply borders to parts of a table using openxlsx. Next I will show the desired output, builded in a way that is not the desired one: printing parts of the table and formating it in each step:
library(openxlsx)
library(tidyverse)
set.seed(15)
###create workbook
wb <- createWorkbook()
addWorksheet(wb, "test2")
#Sample a portion of iris to make it short
iris%>%dplyr::sample_n(15)->sample_iris
#split according to Species
sample_iris%>%filter(Species %in% "setosa")->p1
sample_iris%>%filter(Species %in% "versicolor")->p2
sample_iris%>%filter(Species %in% "virginica")->p3
##write each part and apply borders
writeData(wb, 1,p1, startRow = 1, startCol = 1,borders = "surrounding",borderStyle="thick")
writeData(wb, 1,p2, startRow = 1+dim(p1)[1], startCol = 1,borders = "surrounding",colNames =F,borderStyle="thick")
writeData(wb, 1,p3, startRow = 1+dim(p1)[1]+dim(p2)[1], startCol = 1,borders = "surrounding",colNames =F,borderStyle="thick")
saveWorkbook(wb, "test2.xlsx", overwrite = TRUE)
So "test2.xlsx" is the desired output. The thing is how to achieve it not by generating the file, but to modify an existing file. I mean, if the file "test1.xlsx" is created by
write.xlsx(sample_iris, file = "test1.xlsx")
then, how to apply borders as desired on the already existing file?
Thanks for any guide on this

Next is the code to do the task:
rm(list=ls())
library(tidyverse)
library(openxlsx)
my_borders<-function(wb,sheet_name,a2,vartobrd,borderStyle="thick"){
btop<-createStyle(border=c("top"),borderStyle=borderStyle)
bleft<-createStyle(border=c("left"),borderStyle=borderStyle)
bright<-createStyle(border=c("right"),borderStyle=borderStyle)
bbottom<-createStyle(border=c("bottom"),borderStyle=borderStyle)
blb<-createStyle(border=c("left","bottom"),borderStyle=borderStyle)
bbr<-createStyle(border=c("bottom","right"),borderStyle=borderStyle)
length_box<-dim(a2)[2]
floor_bx<-1:length_box%>%.[-c(1,length_box)]
a2$rnum<-1:dim(a2)[1]
a2%>%group_by_(vartobrd)%>%summarise(min=min(rnum),max=max(rnum))->box_lm
box_lm<-as.data.frame(box_lm)
for(i in seq_along(box_lm[,vartobrd])){
box_lm%>%filter_(paste0(vartobrd, "%in%","'", box_lm[i,vartobrd], "'"))%>%
select(min,max)->minmax_lm
side_indx<-minmax_lm$min:minmax_lm$max
cornerindx<-length(side_indx)
side_indx_sin_corn<-1:(cornerindx-1)
side_cels<-side_indx[side_indx_sin_corn]
nside_cels<-length(side_cels)
corner<-side_indx[cornerindx]
addStyle(wb, sheet=sheet_name, style = bleft, rows=side_cels+1, cols=rep(1,nside_cels))
addStyle(wb, sheet=sheet_name, style = bbottom, rows=rep(minmax_lm$max,length_box-2)+1, cols=floor_bx)
addStyle(wb, sheet=sheet_name, style = bright, rows=side_cels+1, cols=rep(length_box,nside_cels))
addStyle(wb, sheet=sheet_name, style = blb, rows=corner+1, cols=1)
addStyle(wb, sheet=sheet_name, style = bbr, rows=corner+1, cols=length_box)
}
}
#####test the solution
wb <- openxlsx::createWorkbook()
openxlsx::addWorksheet(wb, sheetName = 1)
openxlsx::freezePane(wb, sheet = 1, firstActiveRow = 2)
openxlsx::writeData(wb, x=iris, sheet = 1, colNames =T)
my_borders(wb,sheet_name=1,a2=iris,borderStyle="thick",vartobrd="Species")
openXL(wb)
I appreciate any comments on this.

Related

How to source a locally stored image for embedding into a table cell in R Shiny?

The below code does a terrific job of rendering a web-sourced image in a cell of the rhandsontable. However, I'd like swap that image with a jpg image I have stored on my computer. I've tried modifying the below as.character(img(src = "...")) to reflect the local directory and filename, with no luck.
Any suggestions for a straightforward way to do this?
I searched for solutions, for example, Display locally-stored image in R Shiny, but they look rather involved given what I thought is the simplicity of what I'm trying to do. Certainly accessing your local drive is easier than reaching out to the Web via API.
Here's the painfully simple image I want to upload (shrunken of course):
Code:
library(magrittr)
library(htmlwidgets)
library(rhandsontable)
library(shiny)
DF = data.frame(
Col_1 = c("Row 1"),
Col_Help = c(
as.character(img(
src = "https://images.plot.ly/language-icons/api-home/python-logo.png",
title = "My first help text",
style = "width: 50px;")
)
),
text = c("Row 1 does xxx"),
stringsAsFactors = FALSE
)
ui <- fluidPage(br(),rHandsontableOutput('my_table'))
server <- function(input, output, session) {
output$my_table <- renderRHandsontable({
rhandsontable::rhandsontable(
DF,
allowedTags = "<em><b><strong><a><big><img>"
) %>%
hot_cols(colWidths = c(200, 80)) %>%
hot_col(1:2, renderer = htmlwidgets::JS("safeHtmlRenderer")) %>%
hot_cols(colWidths = ifelse(names(DF) != "text", 100, 0.1))
})
}
shinyApp(ui, server)
Put your file, say question_mark.jpg in the www folder of your shiny app, and then adjust your DF definition as below:
DF = data.frame(
Col_1 = c("Row 1"),
Col_Help = c(
as.character(img(
src = "question_mark.jpg",
title = "My first help text",
style = "width: 50px;")
)
),
text = c("Row 1 does xxx"),
stringsAsFactors = FALSE
)
Output:

Is it possible to arrange graphs and filters in an R plot output?

I have created a small dashboard using bscols( from the crosstalkpackage. It consists of plotly graphs and their respective filter_checkboxes.
It looks pretty messy now, as the filters are not vertically aligned with their corresponding plots.
HTML_graphic
As indicated, I would like the first two checkbox sets to appear next to the second line graph (nothing to appear next to the first line graph); and the second two checkbox sets to appear next to the third line graph.
Also, I would like to create some vertical space between the three elements, as indicated by the brown and black horizontal lines.
The best solution would be to set the height of the html elements inside the bscols() command. Because in the future, I would like to programmatically save multiple of these outputs using htmltools::save_html.
The next best would be to have the output of that command somehow converted to html and add html code like line breaks or heights.
Neither I know how to do.
I came across this related question but it is unanswered: Arrange crosstalk graphs via bscols
Any suggestions on how to solve my problem?
My code
{r 002_Auto App Doc Vol_Invoice group delta plot - plot code, echo = FALSE}
# Setup of the legend for invoice plot
invoice_plot_legend <- list(
font = list(
family = "sans-serif",
size = 12,
color = "#000"),
title = list(text="<b> Delta previous month by division </b>"),
bgcolor = "#E2E2E2",
bordercolor = "#FFFFFF",
borderwidth = 2,
layout.legend = "constant",
traceorder = "grouped")
# The Shared Data format is needed for crosstalk to be able to filter the dataset upon clicking the checkboxes (division filters):
shared_invoice <- SharedData$new(Auto_App_Doc_Vol_invoiceg_plotting_tibble)
shared_invoice_KPI <- SharedData$new(Auto_App_Doc_Vol_KPI)
shared_abs <- SharedData$new(Auto_App_Doc_Vol_plotting_tibble_diff_abs)
# Setup of a bscols html widget; widths determines the widths of the input lists (here, 2: the filters, 10: the plot and legend)
# Overall KPI and invoice group plot
library(htmlwidgets)
crosstalk::bscols(
widths = c(2, 10),
list(
crosstalk::filter_checkbox("Division",
label = "Division",
sharedData = shared_invoice,
group = ~Division),
crosstalk::filter_checkbox("Rechnungsgruppe",
label = "Invoice group",
sharedData = shared_invoice,
group = ~Rechnungsgruppe),
crosstalk::filter_checkbox("Rechnungsgruppe",
label = "Invoice group",
sharedData = shared_abs,
group = ~Rechnungsgruppe),
crosstalk::filter_checkbox("Division",
label = "Division",
sharedData = shared_abs,
group = ~Division)
)
,
list(
plot_ly(data = shared_invoice_KPI, x = ~Freigabedatum_REAL_YM, y = ~KPI_current_month, meta = ~Division,
type = "scatter",
mode = "lines+text",
text = ~KPI_current_month,
textposition='top center',
hovertemplate = "%{meta}",
color = ~Diff_KPI_pp)
%>%
layout(legend = invoice_plot_legend,
title = "Automatically Approved Document Volume",
xaxis = list(title = 'Release date'),
yaxis = list(title = '%'))
,
plot_ly(data = shared_invoice, x = ~Freigabedatum_REAL_YM, y = ~n,
type = "scatter",
mode = "lines",
text = ~Rechnungsgruppe_effort,
hoverinfo = "y+text",
color = ~Difference_inline
)
%>%
layout(legend = invoice_plot_legend,
title = " ",
xaxis = list(title = 'Release date'),
yaxis = list(title = '# of Approved Documents'))
,
plot_ly(data = shared_abs, x = ~Freigabedatum_REAL_YM, y = ~n,
type = "scatter",
mode = "lines",
text = ~Lieferantenname,
hoverinfo = "y+text",
color = ~Lieferantenname_text
)
%>%
layout(legend = vendor_plot_legend,
title = "by vendor absolute delta previous month all documents",
xaxis = list(title = 'Release date'),
yaxis = list(title = '# of Approved Documents w/ & w/o effort')
)
)
)
Thank you so much!

R ggplot2 not display unicode font from dataframe correctly

Please help check this issue and recommend any library to make it work. I have used showtext library but not help.
Sample Data & Code
category_name total_readers
មនោសញ្ចេតនា​ 267867
ស្នេហា 239880
ព្រឺព្រួច 222031
អាថ៌កំបាំង 127858
គុននិយម 101888
df %>%
ggplot(aes(area = total_readers, fill = category_name, label = category_name)) +
geom_treemap() + theme(legend.position = "bottom", ) +
geom_treemap_text(fontface = "italic", colour = "white", place = "centre", grow = FALSE)

R markdown: download a html table to an excel file

I have a R markdown where I built a table and I want to add the option to download the table to a excel file.
kable(MyTable) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed",
"responsive")) %>%
scroll_box(width = "900px", height = "500px")
You could always try using DT::datatable to get export buttons
MyTable %>%
DT::datatable(
extensions = 'Buttons',
options = list(dom = 'Bfrtip',
buttons = c('excel', "csv")))

How to replace code in <head> sections of all HTML documents in a directory using R

I'm looking for an efficient way to modify the code between<head> </head> tags for a large number of .html documents that are all stored in the same folder.
R is mandotory since this is part of an rmarkdown classroom project and I'd like the code to be understood by students.
For my purpose, it would be sufficient to overwrite every document header with the same lines which, e.g., adjust CSS or links .js files.
I tried to do this in R using functions like readLines() and writeLines() in conjunction with regular expressions but that seems overly cumbersome. I'd like to have a more elegant and specific solution that makes use of the DOM.
I just realized, that you wanted to replace all child nodes. Here is the code to achieve that.
The script uses lapply to open each file, parse the XML code, remove all child nodes of head and adds a script element with the argument src to it.
Replace all child nodes
library(XML)
files <- list.files(full.names = T, pattern = "*.html")
lapply(files, function(f) {
content <- xmlInternalTreeParse(f, isHTML = T)
# get head node
headNode <- getNodeSet(content, path = "//head")
# remove all child nodes
do.call(removeChildren, args = list(kids = names(xmlChildren(headNode[[1]])), node = headNode[[1]]))
# create new nodes
newNode <- newXMLNode("script", attrs = list(src = "myScript.js"))
# add new nodes
addChildren(headNode[[1]], newNode)
saveXML(doc = content, file = f)
})
Append a new node
library(XML)
files <- list.files(full.names = T, pattern = "*.html")
lapply(files, function(f) {
content <- xmlInternalTreeParse(f, isHTML = T)
headNode <- getNodeSet(content, path = "//head")
newNode <- newXMLNode("script", attrs = list(src = "myScript.js"))
addChildren(headNode[[1]], newNode)
saveXML(doc = content, file = f)
})