More style questions using formattable - r

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
))

Related

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])))

Calendar Heatmap in R

Looking to create a gt/reactable table in R that serves as a calendar heatmap. Something just like the one found on this site https://glin.github.io/reactable/articles/cookbook/cookbook.html. When I try to replicate that code, I get an error: "only defined on a data frame with all numeric-alike variables." I made Year a factor variable and do not want to color that column. Here is the code I tried + the dput output:
BuYlRd <- function(x) rgb(colorRamp(c("#7fb7d7", "#ffffbf", "#fc8d59"))
(x), maxColorValue = 255)
reactable(
bls,
defaultColDef = colDef(
style = function(value) {
if (!is.numeric(value)) return()
normalized <- (value - min(bls)) / (max(bls) - min(bls))
color <- BuYlRd(normalized)
list(background = color)
},
format = colFormat(digits = 2),
minWidth = 50
),
columns = list(
.rownames = colDef(name = "Year", sortable = TRUE, align =
"left")
),
bordered = TRUE
)
dput(head(bls))
structure(list(year = structure(1:3, .Label = c("2018", "2019",
"2020"), class = "factor"), January = c(329.5, 329.6, 327.5),
February = c(354.4, 328.5, 323.7), March = c(354.4, 324,
324.9), April = c(348.7, 326.9, 319.8), May = c(340.2, 321,
320.7), June = c(338, 316.1, 320.4), July = c(342.3, 317.3,
319), August = c(346.8, 317.3, 317.2), September = c(344.9,
317.3, 317), October = c(342.4, 318.2, 317.3), November =
c(334.4,
317.3, 328.2), December = c(335.5, 317.4, 328.7)), row.names =
c(NA,
-3L), class = c("tbl_df", "tbl", "data.frame"))
A solution could be to put the year column into the rownames of your dataset, and removing the year column thereafter :
bls=as.data.frame(bls)
rownames(bls)=bls$year
bls=bls[,-1]
reactable(
bls,
defaultColDef = colDef(
style = function(value) {
if (!is.numeric(value)) return()
normalized <- (value - min(bls)) / (max(bls) - min(bls))
color <- BuYlRd(normalized)
list(background = color)
},
format = colFormat(digits = 2),
minWidth = 50
),
columns = list(
.rownames = colDef(name = "Year", sortable = TRUE, align =
"left")
),
bordered = TRUE
)

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

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

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?

R Leaflet - use date or character legend labels with colorNumeric() palette

I have a dataset with lat/lon and a timestamp. I want the color of the markers to show time with a continous palette. I am using colorNumeric() with julian dates earlier created using julian(x, "2015-01-01").
data = structure(list(timestamp = structure(c(1434056453, 1434148216, 1434153635, 1434245436, 1434358840,
1434364288, 1434369611, 1434461435, 1434466830, 1434558725), class = c("POSIXct", "POSIXt"), tzone = ""),
lon = c(-119.8777, -119.9614, -119.8769, -119.8775, -120.2283,
-120.2285, -119.8429, -120.0954, -120.3957, -120.4421),
lat = c(34.4041,34.376, 34.4061, 34.4021, 34.4696,
34.4697, 34.1909, 34.4328, 34.4554, 34.4456),
ID = as.factor(c("Z11","Z05","Z01", "Z04", "Z11", "Z04","Z01","Z05","Z05","Z11"))),
.Names = c("timestamp", "lon", "lat", "ID"),
row.names = c(1:10),
class = "data.frame")
data$julian = as.numeric(julian(data$timestamp, origin = "2015-01-01"))
pal = colorNumeric( palette = rainbow(7), domain = data$julian)
m = leaflet(data)
m %>% addTiles() %>%
addCircles(~lon, ~lat, color = ~pal(julian)) %>%
addLegend("bottomright", pal = pal, values = ~julian, title = "Time", opacity = 1)
The legend shows the labels as numeric, julian dates: I want them to show as "proper" dates in a format like "2015-01-01" or similar.
To do this, I use as.Date(x, origin=as.Date("2015-01-01")) but it does not work when I insert it into addLegend() with addLegend(pal = pal, values = ~julian,
labFormat = labelFormat(transform = ~as.Date(julian, origin=as.Date("2015-01-01"))))
Is there a way to modify legend labels so that they show dates and/or characters?
From the leaflet page on legends:
You can also conveniently customize the label appearance by passing labFormat=labelFormat(). labelFormat() has parameters that customize the separator between ranges, the number of digits to render, and prefix/suffix for each label. If your label formatting needs extend beyond what labelFormat() can provide, you can also use a custom function as the labFormat argument; see the Details section in ?addLegend for a description.
Therefore, we can modify the source code for the labelFormat function to include a custom function to convert dates
myLabelFormat = function(
prefix = '', suffix = '', between = ' – ', digits = 3, big.mark = ',',
transform = identity, dates = FALSE ## new 'dates' argument
) {
formatNum = function(x) {
format(
round(transform(x), digits), trim = TRUE, scientific = FALSE,
big.mark = big.mark
)
}
## added 'formatDate' function
formatDate = function(x) {
d = as.Date(x, origin="1970-01-01")
}
function(type, ...) {
switch(
type,
numeric = (function(cuts) {
if(dates){
## will format numbers into dates if dates == TRUE
paste0(formatDate(cuts))
}else{
paste0(prefix, formatNum(cuts), suffix)
}
})(...),
bin = (function(cuts) {
n = length(cuts)
paste0(prefix, formatNum(cuts[-n]), between, formatNum(cuts[-1]), suffix)
})(...),
quantile = (function(cuts, p) {
n = length(cuts)
p = paste0(round(p * 100), '%')
cuts = paste0(formatNum(cuts[-n]), between, formatNum(cuts[-1]))
# mouse over the legend labels to see the values (quantiles)
paste0(
'<span title="', cuts, '">', prefix, p[-n], between, p[-1], suffix,
'</span>'
)
})(...),
factor = (function(cuts) {
paste0(prefix, as.character(transform(cuts)), suffix)
})(...)
)
}
}
Which, as #Nice points out can be shortened to
myLabelFormat = function(...,dates=FALSE){
if(dates){
function(type = "numeric", cuts){
as.Date(cuts, origin="1970-01-01")
}
}else{
labelFormat(...)
}
}
With this new function we can call it as normal
data = structure(list(timestamp = structure(c(1434056453, 1434148216, 1434153635, 1434245436, 1434358840,
1434364288, 1434369611, 1434461435, 1434466830, 1434558725), class = c("POSIXct", "POSIXt"), tzone = ""),
lon = c(-119.8777, -119.9614, -119.8769, -119.8775, -120.2283,
-120.2285, -119.8429, -120.0954, -120.3957, -120.4421),
lat = c(34.4041,34.376, 34.4061, 34.4021, 34.4696,
34.4697, 34.1909, 34.4328, 34.4554, 34.4456),
ID = as.factor(c("Z11","Z05","Z01", "Z04", "Z11", "Z04","Z01","Z05","Z05","Z11"))),
.Names = c("timestamp", "lon", "lat", "ID"),
row.names = c(1:10),
class = "data.frame")
data$julian <- as.numeric(as.Date(data$timestamp))
library(leaflet)
pal = colorNumeric( palette = rainbow(7), domain = data$julian)
m = leaflet(data)
m %>% addTiles() %>%
addCircles(~lon, ~lat, color = ~pal(julian)) %>%
addLegend("bottomright", pal = pal, values = ~julian,
title = "Time", opacity = 1,
labFormat = myLabelFormat(dates=TRUE))

Resources