How to insert greek letter delta (∆) into header of flextable object? - r

I am using RMarkdown to create a word document (I need the output to be in .docx format).
I'd like to use flextable (or any other package) to format my headers properly.
I'm trying to get the greek symbol delta (∆) to display properly... it seems possible because in the help pages here (https://davidgohel.github.io/flextable/articles/format.html#display-function) the author successfully uses \u03BC to insert the "μ" symbol (and I can too if I use his code, below), but I can't get it to work for delta using \u2206 or \u0394, if I replace \u03BC with either code below. The code I'm using produces this table, but I want to replace the highlighted bit with delta.
This is what I get when I try, for example, \u2206.
Any suggestions?
library(flextable)
if( require("xtable") ){
mat <- round(matrix(c(0.9, 0.89, 200, 0.045, 2.0), c(1, 5)), 4)
mat <- xtable(mat)
ft <- xtable_to_flextable(x = mat, NA.string = "-")
print(ft$col_keys)
ft <- flextable::display(ft, i = 1, col_key = "X1",
pattern = "{{val}}{{pow}}", part = "header",
formatters = list(val ~ as.character("R"), pow ~ as.character("2") ),
fprops = list(pow = fp_text(vertical.align = "superscript", font.size = 8))
)
ft <- flextable::display(ft, i = 1, col_key = "X2",
pattern = "{{val}}{{pow}}", part = "header",
formatters = list(val ~ as.character("\u03BC"), pow ~ as.character("x") ),
fprops = list(pow = fp_text(vertical.align = "superscript", font.size = 8))
)
ft <- flextable::display(ft, i = 1, col_key = "rowname",
pattern = "{{val}}{{pow}}", part = "body",
formatters = list(val ~ as.character("y"), pow ~ as.character("t-1") ),
fprops = list(pow = fp_text(vertical.align = "subscript", font.size = 8))
)
ft <- set_header_labels(ft, X3 = "F-stat", X4 = "S.E.E", X5 = "DW", rowname = "")
ft <- autofit(ft)
ft
}
Update
I am getting closer thanks to a helpful suggestion from David, but (not being very familiar with flextable) I am getting strange behaviour when I try to modify the header in the way suggested:
library(magrittr)
library(flextable)
library(officer)
AICtable <- data.frame(Model = "test", Parameters = 9, AICc = 4000, dAICc = 0, w = 1)
v.epi.aic <- flextable(AICtable) %>%
font(fontname = "Times New Roman", part = "all") %>%
flextable::display(col_key = "dAICc", part = "header",
pattern = "{{D}}{{A}}{{cbit}}",
formatters = list(D ~ as.character("D"),
A ~ as.character("AIC"),
cbit ~ as.character("c") ),
fprops = list(D = fp_text(font.family = "Symbol"),
A = fp_text(font.family = "Times New Roman"),
cbit = fp_text(vertical.align = "subscript")))
v.epi.aic
Notice that column headers are now duplicated, and "AIC" appears before the "∆". The column names should be:
Model, Parameters, AICc, ∆AICc, w (and the "c" in the ∆AICc should be a subscript).

Please use "\u394" instead of "\u0394" to generate the capital delta symbol

Related

Is it possible to create a stratified table (tbl_strata) using tbl_svysummary()?

I am pretty new to survey data and gtsumarry package.
I'm trying to create a stratified table from the survey data using the following code, and I get the error "Error: Problem with mutate() input tbl".
# Reading the subset of the data
fileUrl <- "https://raw.github.com/Shadi-Sadie/Paper-1-Cancer-Screening-and-Immigrants/master/Cleaned%20Data/subset.csv"
SData<-read.csv( fileUrl , header = TRUE, sep ="," )
# Setting the weight
options( "survey.replicates.mse" = TRUE)
svy <- svrepdesign(repweights = "PWGTP[0-9]+",
weights = ~PWGTP,
combined.weights = TRUE,
type = "JK1",
scale = 4/80, rscales = rep(1, 80),
data = SData)
# creating the table
SData %>%
select(CITG, HICOV, ESRG , EXPANSION) %>%
tbl_strata(
strata = CITG,
.tbl_fun =
~ .x %>% tbl_svysummary(
by = EXPANSION,
include = c(CITG, HICOV, ESRG , EXPANSION),
label = list(CITG ~ "Nativity",
HICOV~ "Any health insurance",
ESRG~ "Employment",
EXPANSION ~ "Expansion" )
)
)
If it is possible to use tbl_svysummary() with the tbl_strata() could anyone tell me where I'm doing wrong?
Thanks for updating with a reproducible post. I made the following changes:
You were passing the data frame to tbl_strata() and it needed to be updated to the survey design object.
The stratifying variable should no be listed in the tbl_summary(include=) argument.
Happy Porgramming!
library(gtsummary)
packageVersion("gtsummary")
#> [1] '1.6.0'
fileUrl <- "https://raw.github.com/Shadi-Sadie/Paper-1-Cancer-Screening-and-Immigrants/master/Cleaned%20Data/subset.csv"
SData <- read.csv(fileUrl, header = TRUE, sep = ",")
# Setting the weight
options("survey.replicates.mse" = TRUE)
svy <- survey::svrepdesign(
repweights = "PWGTP[0-9]+",
weights = ~PWGTP,
combined.weights = TRUE,
type = "JK1",
scale = 4 / 80, rscales = rep(1, 80),
data = SData
)
# creating the table
tbl <-
svy %>%
tbl_strata(
strata = CITG,
.tbl_fun =
~ .x %>% tbl_svysummary(
by = EXPANSION,
include = c(HICOV, ESRG, EXPANSION),
label = list(
HICOV = "Any health insurance",
ESRG = "Employment",
EXPANSION = "Expansion"
)
)
)
Created on 2022-05-01 by the reprex package (v2.0.1)

R Table Conditional Format applied to cells within a row

I'm trying to apply conditional formatting based on data within a row. I've tried a number of libraries including DT, Reactablefmtr and formatter. The idea is to put it into shiny to present table of findings.
How do I make this function more dynamic to not call it for each row but reference it to the norm variable?
# the table
fin_ratios <- data.frame(
descr = c("Ratio 1", "Ratio 2"),
norm = c(10, 20),
`2021` = c(11, 19),
`2022` = c(9, 21)
)
The code to style the table:
library(formattable)
custom_color_tile <- function (x, x_norm = 10) {
formatter("span",
style = x ~ style(display = "block",
padding = "0 4px",
`color` = "white",
`border-radius` = "4px",
`background-color` = ifelse(x >= x_norm, "green", "red")))
}
fin_ratios %>%
formattable(
list(
area(col = 3:4, row = 1) ~ custom_color_tile(x_norm = 10),
area(col = 3:4, row = 2) ~ custom_color_tile(x_norm = 20)
)
)
Your function is already working. Instead of using single values for x_norm, you can use the norm variable as a vector fin_ratios$norm.
formattable(fin_ratios,
list(area(col = 3:4) ~ custom_color_tile(x_norm = fin_ratios$norm)))
You may just pay attention, if you want to color certain rows. Than you have to select the rows of the norm variable as well.
# color just first row
formattable(fin_ratios,
list(area(col = 3:4,
row = 1) ~ custom_color_tile(x_norm = fin_ratios$norm[1])))

How can I make a collapse with glue package using RMarkdown?

I've been trying to automate the results of some df table in latex using the glue and stargazer packages, but I haven't had any results (what I want is for the meaning "^{*}" to appear next to each value as it is in the table) to use then RMarkdown.
What I want to get:
My current ugly and error-prone fix:
library(dplyr)
library(glue)
library(stargazer)
X1 = c(4.70e1, 4.72e1, 4.76e1, 2.73e20)
X2 = c(4.67e1, 4.69e1, 4.77e1, 2.05e20)
tab.out = data.frame(X1, X2)
tab.out$max<-apply(tab.out, 1, max)
one = "1"
n.tab = tab.out %>%
mutate(test1 = if_else(tab.out$X2 < tab.out$max,
glue("\\textsuperscript{*} is $<<one>>$.", .open = "<<", .close = ">>"), #It doesn't work with ^{*}
glue("")))
Note: one was just to test the collapse because I tried glue_data as well as glue_collapse and it didn't work.
On the other hand, assuming the collapse works, how would I do to debug the latex code right? Because I tried with stargazer, xtable and textreg but in each of the functions it doesn't recognize "\, }, ^{*}".
n.tab = n.tab[c(1,2,4)]
stargazer(n.tab, summary = F, header = F)
What I got ?
I achieved this using the paste0 function as mentioned here and on the recommendation of #stefan but now I would like to automate the same function for n-columns
library(dplyr)
col.nam = c("AIC(n)", "HQ(n)", "SC(n)", "FPE(n)")
tab.out = data.frame(col.nam, X1, X2)
n.tab = tab.out %>%
mutate(test1 = if_else(tab.out$X1 < tab.out$X2,
paste0(X1,"$^{*}$"),
paste0(X1)),
test2 = if_else(tab.out$X2 < tab.out$X1,
paste0(X2,"\\textsuperscript{*}"),
paste0(X2)))%>%
select(col.nam, test1, test2)
colnames(n.tab) = c("Parámetros", "Lag 1", "Lag 2")
print(xtable::xtable(n.tab,
header = F,
caption = "asdasdasdasd",
label="table:tb1",
caption.placement = "top",
align="llcc"),
hline.after = c(-1,0),
include.rownames=FALSE,
include.colnames = TRUE,
add.to.row = list(pos = list(nrow(n.tab)),
command = paste("\\hline \n",
"\\multicolumn{3}{l}{\\footnotesize{$^{*}$Indica el orden de retraso seleccionado}} \\\\",
"\\multicolumn{3}{l}{\\footnotesize{\\textit{Elaboración: Los autores}}}",
sep = "")), comment=FALSE,
sanitize.text.function = function(x){x})

More style questions using formattable

In the table below, how do I remove the line between the Canada row and the World row?
Also, how do I remove the bold from the column headers (ie 1980, 2019, Change)?
This is different than the proposed link in that I wonder if there is a solution that is of the form:
# Define styles
row_emphasis <- formatter("span", style = ~style("font.weight" = "bold", "font.size" = "18px"))
make_non_bold <- formatter("span", style = "font-style:italic; font-weight:normal")
# Apply styles
formattable(can_world_table, list(
area(row = 1) ~ row_emphasis,
# column headers # ~ make_non_bold
))
As for the part about removing the lines between rows, the suggested answer below does not address my issue. This code adds another line between Canada and the header row line:
row_emphasis <- formatter("span", style = ~style("font.weight" = "bold", "font.size" = "18px", "border-top: 1px solid green"))
library(tidyverse)
library(formattable)
target_year = 1980
current_year = 2019
can_target = 20.464
can2019 = 37.786
world_target = 6123
world2019 = 7456
can_change <- (can2019 - can_target) / can_target
world_change <- (world2019 - world_target) / world_target
can_world_table <- tibble(
region = c("Canada", "World"),
ty = c(round(can_target, digits = 0), round(world_target, digits = -2)),
cy = c(can2019, round(world2019, digits = -2)),
change = percent(c(can_change, world_change), 0)
) %>%
set_names(c("", target_year, current_year, "Change"))
can_world_table
can_world_table <- tibble(
region = c("Canada", "World"),
ty = c(can_target, format(round(world_target, digits = -2), big.mark = ",")),
cy = c(can2019, format(round(world2019, digits = -2), big.mark = ",")),
change = percent(c(can_change, world_change), 0)
) %>%
set_names(c(" ", target_year, current_year, "Change"))
row_emphasis <- formatter("span", style = ~style("font.weight" = "bold", "font.size" = "18px"))
formattable(can_world_table, list(
area(row = 1) ~ row_emphasis
))

HeatMap: how to cluster only the rows and keep order of the heatmap's column labels as same as in the df?

I wanna plot a heatmap and cluster only the rows (i.e. genes in this tydf1).
Also, wanna keep order of the heatmap's column labels as same as in the df (i.e. tydf1)?
Sample data
df1 <- structure(list(Gene = c("AA", "PQ", "XY", "UBQ"), X_T0_R1 = c(1.46559502, 0.220140568, 0.304127515, 1.098842127), X_T0_R2 = c(1.087642983, 0.237500819, 0.319844338, 1.256624804), X_T0_R3 = c(1.424945196, 0.21066267, 0.256496284, 1.467120048), X_T1_R1 = c(1.289943948, 0.207778662, 0.277942721, 1.238400358), X_T1_R2 = c(1.376535013, 0.488774258, 0.362562315, 0.671502431), X_T1_R3 = c(1.833390311, 0.182798731, 0.332856558, 1.448757569), X_T2_R1 = c(1.450753714, 0.247576125, 0.274415259, 1.035410946), X_T2_R2 = c(1.3094609, 0.390028842, 0.352460646, 0.946426593), X_T2_R3 = c(0.5953716, 1.007079177, 1.912258811, 0.827119776), X_T3_R1 = c(0.7906009, 0.730242116, 1.235644748, 0.832287694), X_T3_R2 = c(1.215333041, 1.012914813, 1.086362205, 1.00918082), X_T3_R3 = c(1.069312467, 0.780421013, 1.002313082, 1.031761442), Y_T0_R1 = c(0.053317766, 3.316414959, 3.617213894, 0.788193798), Y_T0_R2 = c(0.506623748, 3.599442788, 1.734075583, 1.179462912), Y_T0_R3 = c(0.713670106, 2.516735845, 1.236204882, 1.075393433), Y_T1_R1 = c(0.740998252, 1.444496448, 1.077023349, 0.869258744), Y_T1_R2 = c(0.648231834, 0.097957459, 0.791438659, 0.428805547), Y_T1_R3 = c(0.780499252, 0.187840968, 0.820430227, 0.51636582), Y_T2_R1 = c(0.35344654, 1.190274584, 0.401845911, 1.223534348), Y_T2_R2 = c(0.220223951, 1.367784148, 0.362815405, 1.102117612), Y_T2_R3 = c(0.432856978, 1.403057729, 0.10802472, 1.304233845), Y_T3_R1 = c(0.234963735, 1.232129062, 0.072433381, 1.203096462), Y_T3_R2 = c(0.353770497, 0.885122768, 0.011662112, 1.188149743), Y_T3_R3 = c(0.396091395, 1.333921747, 0.192594116, 1.838029829), Z_T0_R1 = c(0.398000559, 1.286528398, 0.129147097, 1.452769794), Z_T0_R2 = c(0.384759325, 1.122251177, 0.119475721, 1.385513609), Z_T0_R3 = c(1.582230097, 0.697419716, 2.406671502, 0.477415567), Z_T1_R1 = c(1.136843842, 0.804552001, 2.13213228, 0.989075996), Z_T1_R2 = c(1.275683837, 1.227821594, 0.31900326, 0.835941568), Z_T1_R3 = c(0.963349308, 0.968589683, 1.706670339, 0.807060135), Z_T2_R1 = c(3.765036263, 0.477443352, 1.712841882, 0.469173869), Z_T2_R2 = c(1.901023385, 0.832736132, 2.223429427, 0.593558769), Z_T2_R3 = c(1.407713024, 0.911920317, 2.011259223, 0.692553388), Z_T3_R1 = c(0.988333629, 1.095130142, 1.648598854, 0.629915612), Z_T3_R2 = c(0.618606729, 0.497458337, 0.549147265, 1.249492088), Z_T3_R3 = c(0.429823986, 0.471389536, 0.977124788, 1.136635484)), row.names = c(NA, -4L ), class = c("data.table", "data.frame"))
Scripts used
library(dplyr)
library(stringr)
library(tidyr)
gdf1 <- gather(df1, "group", "Expression", -Gene)
gdf1$tgroup <- apply(str_split_fixed(gdf1$group, "_", 3)[, c(1, 2)],
1, paste, collapse ="_")
library(dplyr)
tydf1 <- gdf1 %>%
group_by(Gene, tgroup) %>%
summarize(expression_mean = mean(Expression)) %>%
spread(., tgroup, expression_mean)
#1 heatmap script is being used
library(tidyverse)
tydf1 <- tydf1 %>%
as.data.frame() %>%
column_to_rownames(var=colnames(tydf1)[1])
library(gplots)
library(vegan)
randup.m <- as.matrix(tydf1)
scaleRYG <- colorRampPalette(c("red","yellow","darkgreen"),
space = "rgb")(30)
data.dist <- vegdist(randup.m, method = "euclidean")
row.clus <- hclust(data.dist, "aver")
heatmap.2(randup.m, Rowv = as.dendrogram(row.clus),
dendrogram = "row", col = scaleRYG, margins = c(7,10),
density.info = "none", trace = "none", lhei = c(2,6),
colsep = 1:3, sepcolor = "black", sepwidth = c(0.001,0.0001),
xlab = "Identifier", ylab = "Rows")
#2 heatmap script is being used
df2 <- as.matrix(tydf1[, -1])
heatmap(df2)
Also, I want to add a color key.
It is still unclear to me, what the desired output is. There are some notes:
You don't need to use vegdist() to calculate distance matrix for your hclust() call. Because if you check all(vegdist(randup.m, method = "euclidian") == dist(randup.m)) it returns TRUE;
Specifying Colv = F in your heatmap.2() call will prevent reordering of the columns (default is TRUE);
Maybe it is better to scale your data by row (see the uncommented row);
Your call of heatmap.2() returns the heatmap with color key.
So summing it up - in your first script you just miss the Colv = F argument, and after a little adjustment it looks like this:
heatmap.2(randup.m,
Rowv = as.dendrogram(row.clus),
Colv = F,
dendrogram = "row",
#scale = "row",
col = scaleRYG,
density.info = "none",
trace = "none",
srtCol = -45,
adjCol = c(.1, .5),
xlab = "Identifier",
ylab = "Rows"
)
However I am still not sure - is it what you need?

Resources