I am using GT package in R to create tables for my diploma thesis and I ran into a problem. The diploma is to be written in the czech language.
When GT draws the table it does not display the letter ě properly and shows e instead.
The code for GT table:
desc_sex[,2:ncol(desc_sex)] %>% gt(rowname_col = "sex"
) %>% tab_stubhead(
label = html("Kategorie")
) %>% cols_align(
align = "center",
columns = everything()
) %>% cols_label(
n = html("n"),
procent = html("%")
) %>% tab_row_group(
label = html("<b>Sledované regiony celkem"),
rows = 7:9
) %>% tab_row_group(
label = html("<b>Krajský soud v Ostravě"),
rows = 4:6
) %>% tab_row_group(
label = html("<b>Městský soud v Praze"),
rows = 1:3
) %>% summary_rows(
groups = T,
fns = list(
Celkem = ~sum(.)),
formatter = fmt_number,
decimals = 0
)
Here are the data in CSV compliant format:
"reg_reside","sex","n","procent","single"
"MSPH","Muž",93,46.5,52
"MSPH","Žena",83,41.5,34
"MSPH","Manželský pár",24,12,0
"KSOS","Muž",113,56.5,51
"KSOS","Žena",68,34,30
"KSOS","Manželský pár",19,9.5,0
"Celkem","Muž",206,51.5,103
"Celkem","Žena",151,37.8,64
"Celkem","Manželský pár",43,10.8,0
Here is how the output looks in GT - the mistake is in Ostrave (should be Ostravě) and Mestsky (should be Městský):
You can try using html entities like i.e. ě = ě
desc_sex[,2:ncol(desc_sex)] %>%
gt(rowname_col = "sex") %>%
tab_stubhead(label = html("Kategorie")) %>%
cols_align(align = "center",columns = everything()) %>%
cols_label(n = html("n"),
procent = html("%")) %>%
tab_row_group(label = html("<b>Sledované regiony celkem"),
rows = 7:9) %>%
tab_row_group(label = html("<b>Krajský soud v Ostravě"),
rows = 4:6) %>%
tab_row_group(label = html("<b>Městský soud v Praze"),
rows = 1:3) %>%
summary_rows(groups = T,
fns = list(Celkem = ~sum(.)),
formatter = fmt_number,
decimals = 0)
Related
I have the following table.
I would like to put yellow highlight only in the cells in the "my_sum" row when the value is greater than 0. How can I do this for grouped data? I assume some type of function to recognize the grouping in the data put into the tab_style?
Here is my reprex
library(gt)
library(tidyverse)
tibble(cars = c("honda", "honda",
"ford", "ford"),
mpg = c(24, 22,
NA, NA),
wt = c(NA, NA,
3432, 4234)
) %>%
group_by(cars) %>%
gt() %>%
fmt_missing(columns = everything(),
missing_text = "") %>%
summary_rows(
groups = TRUE,
columns = c(mpg:wt),
fns = list("my_sum" = ~sum(., na.rm = TRUE)),
missing_text = "",
formatter = fmt_number,
decimals = 0
) %>%
grand_summary_rows(
columns = c(mpg:wt),
fns = list("my_big_sum" = ~sum(., na.rm = TRUE)),
missing_text = "",
formatter = fmt_number,
decimals = 0
) %>%
tab_options(
row_group.font.weight = "bold"
) %>%
tab_style(
style = list(
cell_fill(color = "#d4ebf2")
),
locations = cells_grand_summary(
columns = c("mpg", "wt")
)
) %>%
tab_style(
style = list(
cell_fill(color = "#FFFFE0")
),
locations = cells_summary(
columns = c("mpg", "wt")
)
)
this answer is a bit hacky and manual but it works. first you save your table as an object. then you can directly access the table styles and manually modify them.
library(gt)
library(tidyverse)
tibble(cars = c("honda", "honda",
"ford", "ford"),
mpg = c(24, 22,
NA, NA),
wt = c(NA, NA,
3432, 4234)
) %>%
group_by(cars) %>%
gt() %>%
fmt_missing(columns = everything(),
missing_text = "") %>%
summary_rows(
groups = TRUE,
columns = c(mpg:wt),
fns = list("my_sum" = ~sum(., na.rm = TRUE)),
missing_text = "",
formatter = fmt_number,
decimals = 0 ) %>%
grand_summary_rows(
columns = c(mpg:wt),
fns = list("my_big_sum" = ~sum(., na.rm = TRUE)),
missing_text = "",
formatter = fmt_number,
decimals = 0
) %>%
tab_options(
row_group.font.weight = "bold"
) %>%
tab_style(
style = list(
cell_fill(color = "#d4ebf2")
),
locations = cells_grand_summary(
columns = c("mpg", "wt")
)
) %>%
tab_style(
style = list(
cell_fill(color = "#FFFFE0")
),
locations = cells_summary(
columns = c("mpg", "wt"),
rows = "my_sum" )
) -> t1
x1 <- t1$`_styles`$styles[4]
x2 <- t1$`_styles`$styles[3]
x2[[1]]$cell_fill$color <- "#FFFFFF"
t1$`_styles`$styles[3] <- x1
t1$`_styles`$styles[4] <- x2
t1$`_styles`$styles[6] <- x1
t1$`_styles`$styles[5] <- x2
I have created a gt table and I want to have a row at the bottom of the table with the sum of all the columns. I want to position this so that the row label "total" sits within an existing column (the column catchment in my example) rather than out to the side. How do I do this?
library(gt) # package for making tables
library(tidyverse)
library(webshot)
webshot::install_phantomjs()
Lake_name <- c("Okareka", "Okaro", "Okataina", "Rerewhakaaitu", "Rotokakahi", "Rotomahana", "Tarawera", "Tikitapu")
Lake_labels <- c("\u14ckareka", "\u14ckaro", "\u14ckataina", "Rerewhakaaitu", "Rotokakahi", "Rotomahana", "Tarawera", "Tikitapu")
#define catchment areas
LIDAR_areas <- c(19778484, 3679975, 62923350, 52941258, 19195848, 83698343, 145261086, 5728184) # m^2
White_SW_areas <- c(19963914.610, 3675087.968, 66900327.220, 54581284.030, 19207814.960, 83724917.460, 144895034.400, 5689356.743)
White_GW_areas <- c(12485786, 3675525, 70924376, 15180499, 13491567, 101632751, 159285183, 5604187)
Catchment_Areas <- as_tibble(cbind(Lake_labels, LIDAR_areas, White_SW_areas, White_GW_areas))
Catchment_Areas$LIDAR_areas <- as.numeric(Catchment_Areas$LIDAR_areas)
Catchment_Areas$White_SW_areas <- as.numeric(Catchment_Areas$White_SW_areas)
Catchment_Areas$White_GW_areas <- as.numeric(Catchment_Areas$White_GW_areas)
f <- function(x){(x/1000000)}
Catchment_Areas <- Catchment_Areas %>% mutate(across(c(LIDAR_areas, White_GW_areas, White_SW_areas), f))
Catchment_Areas_Table <-
Catchment_Areas %>%
gt() %>%
tab_header(title = md("**Catchment Areas (m<sup>2</sup> x 10<sup>6</sup>)**")) %>%
fmt_number(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), decimals = 2) %>%
cols_align(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), align = "right") %>%
cols_label(Lake_labels = "Catchment", LIDAR_areas = "Surface Water (LIDAR)", White_SW_areas = "Surface Water (White 2020)", White_GW_areas = "Groundwater (White 2020)") %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("bottom"),
color = "black",
weight = px(2)
)#,
#cell_fill(color = "grey")
),
locations = list(
cells_column_labels(
columns = gt::everything()
)
)
) %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("top"),
color = "black",
weight = px(2)
)#,
#cell_fill(color = "grey")
),
locations = list(
cells_title()
)
)
Catchment_Areas_Table %>% summary_rows(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), fns = list(Total = "sum"))
Option 1: Move your "Catchment"/Lake_labels column into `gt(rowname_col = "Lake_labels"), this moves them into the "stub" and aligns with the summary calculations.
Option 2: Pre-calculate the summary rows ahead of time. This means you can treat the summary row as another other cell value.
Reprex below (note that I converted your dataframe to a tribble so it's more compact to reprex, datapasta::tribble_paste() is amazing for this):
library(gt) # package for making tables
library(tidyverse)
library(webshot)
Catchment_Areas <- tibble::tribble(
~Lake_labels, ~LIDAR_areas, ~White_SW_areas, ~White_GW_areas,
"Ōkareka", 19.778484, 19.96391461, 12.485786,
"Ōkaro", 3.679975, 3.675087968, 3.675525,
"Ōkataina", 62.92335, 66.90032722, 70.924376,
"Rerewhakaaitu", 52.941258, 54.58128403, 15.180499,
"Rotokakahi", 19.195848, 19.20781496, 13.491567,
"Rotomahana", 83.698343, 83.72491746, 101.632751,
"Tarawera", 145.261086, 144.8950344, 159.285183,
"Tikitapu", 5.728184, 5.689356743, 5.604187
)
### Option 1
Catchment_Areas_Table <-
Catchment_Areas %>%
gt(rowname_col = "Lake_labels") %>%
tab_header(title = md("**Catchment Areas (m<sup>2</sup> x 10<sup>6</sup>)**")) %>%
fmt_number(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), decimals = 2) %>%
cols_align(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), align = "right") %>%
cols_label(Lake_labels = "Catchment", LIDAR_areas = "Surface Water (LIDAR)",
White_SW_areas = "Surface Water (White 2020)", White_GW_areas = "Groundwater (White 2020)") %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("bottom"),
color = "black",
weight = px(2)
) # ,
# cell_fill(color = "grey")
),
locations = list(
cells_column_labels(
columns = gt::everything()
)
)
) %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("top"),
color = "black",
weight = px(2)
)
),
locations = list(
cells_title(),
cells_stub(rows = 1)
)
) %>%
summary_rows(
columns = c(LIDAR_areas, White_GW_areas, White_SW_areas),
fns = list(Total = "sum")
)
#> Warning in if ((loc$groups %>% rlang::eval_tidy()) == "title") {: the condition
#> has length > 1 and only the first element will be used
gtsave(Catchment_Areas_Table, "rowname_tab.png")
### Option 2
# Create summary ahead of time, add to bottom of the existing df.
Catchment_Areas_Sum <- Catchment_Areas %>%
add_row(
Catchment_Areas %>%
summarise(across(LIDAR_areas:last_col(), sum)) %>%
mutate(Lake_labels = "Total")
)
Catchment_Areas_Table_Sum <-
Catchment_Areas_Sum %>%
gt() %>%
tab_header(title = md("**Catchment Areas (m<sup>2</sup> x 10<sup>6</sup>)**")) %>%
fmt_number(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), decimals = 2) %>%
cols_align(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), align = "right") %>%
cols_label(Lake_labels = "Catchment", LIDAR_areas = "Surface Water (LIDAR)",
White_SW_areas = "Surface Water (White 2020)", White_GW_areas = "Groundwater (White 2020)") %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("bottom"),
color = "black",
weight = px(2)
)
),
locations = list(
cells_column_labels(
columns = gt::everything()
)
)
) %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("top"),
color = "black",
weight = px(2)
)
),
locations = list(
cells_title()
)
) %>%
tab_style(
style = cell_borders(
sides = c("top"), color = "black", weight = px(2)
),
locations = list(
cells_body(rows = Lake_labels == "Total")
)
)
#> Warning in if ((loc$groups %>% rlang::eval_tidy()) == "title") {: the condition
#> has length > 1 and only the first element will be used
gtsave(Catchment_Areas_Table_Sum, "pre_sum_tab.png")
Created on 2021-10-29 by the reprex package (v2.0.1)
I am trying to use both hc_motion and hc_drilldown within a highcharter map.
I can manage to get the hc_motion working with the full map, and also a drilldown from a larger area to its smaller ones (UK Region to Local Authority in this instance).
However, after drilling-down and zooming back out again, the hc_motion is now frozen.
Why is this and is there anyway around it? Or are hc_motion and hc_drilldown not compatible?
While in this instance the drilldown is static, if it possible hc_motion within each drilldown would be ideal, although will no even bother trying if even a static can't be incorporated without affecting the hc_motion.
Anyway, example code is below, thanks!
region_lad_lookup = read_csv("https://opendata.arcgis.com/api/v3/datasets/6a41affae7e345a7b2b86602408ea8a2_0/downloads/data?format=csv&spatialRefId=4326") %>%
clean_names() %>%
select(
region_code = rgn21cd,
region_name = rgn21nm,
la_name = lad21nm,
la_code = lad21cd,
value = fid
) %>%
inner_join(
read_sf("https://opendata.arcgis.com/api/v3/datasets/21f7fb2d524b44c8ab9dd0f971c96bba_0/downloads/data?format=geojson&spatialRefId=4326") %>%
clean_names() %>%
filter(grepl("^E", lad21cd)) %>%
select(la_code = lad21cd),
by = "la_code"
)
region_map = read_sf("https://opendata.arcgis.com/api/v3/datasets/bafeb380d7e34f04a3cdf1628752d5c3_0/downloads/data?format=geojson&spatialRefId=4326") %>%
clean_names() %>%
select(
area_code = rgn18cd,
area_name = rgn18nm
) %>%
st_as_sf(crs = 27700) %>%
sf_geojson() %>%
fromJSON(simplifyVector = F)
year_vec = c(2015, 2016, 2017, 2018, 2019)
region_data = region_lad_lookup %>%
select(
area_code = region_code,
area_name = region_name
) %>%
distinct() %>%
crossing(year_vec) %>%
mutate(
value = runif(nrow(.)),
drilldown = tolower(area_name)
)
region_vec = region_data %>%
select(area_name) %>%
distinct() %>%
pull()
get_la_map = function(data, region_val){
data = data %>%
filter(region_name == region_val) %>%
select(
area_code = la_code,
area_name = la_name,
geometry
) %>%
st_as_sf(crs = 27700) %>%
sf_geojson() %>%
fromJSON(simplifyVector = F)
return(data)
}
get_la_data = function(data, region_val){
data = data %>%
filter(region_name == region_val) %>%
select(
area_name = la_name,
area_code = la_code,
value
)
return(data)
}
get_region_map_list = function(region_val){
output = list(
id = tolower(region_val),
data = list_parse(get_la_data(region_lad_lookup, region_val)),
mapData = get_la_map(region_lad_lookup, region_val),
name = region_val,
value = "value",
joinBy = "area_name"
)
return(output)
}
region_ds = region_data %>%
group_by(area_name) %>%
do(
item= list(
area_name = first(.$area_name),
sequence = .$value,
value = first(.$value),
drilldown = first(.$drilldown)
)
) %>%
.$item
highchart(type = "map") %>%
hc_add_series(
data = region_ds,
mapData = region_map,
value = "value",
joinBy = "area_name",
borderWidth = 0
) %>%
hc_colorAxis(
minColor = "lightblue",
maxColor = "red"
) %>%
hc_motion(
enabled = TRUE,
axisLabel = "year",
series = 0,
updateIterval = 200,
magnet = list(
round = "floor",
step = 0.1
)
) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = lapply(region_vec, get_region_map_list)
)
I am new in R & have created some Classification models. By using those I need to display tick & cross against approved and rejected customers based Class column.
I picked up a piece of code from somewhere that helps in creating star Ratings against each and it uses gt package
dataframe
df_test <- cbind(prob = predict(model_ranger_py, newdata = test, type = "prob")[,"yes"],
Class = y_test) %>%
rename(Class = y)
df_test
############ output #############
prob Class
<dbl> <fctr>
3 0.4906592 no
6 0.6123333 no
12 0.3746750 no
14 0.4906592 no
22 0.7820000 yes
24 0.5333956 no
29 0.5281762 no
45 0.7413333 no
46 0.7413333 no
50 0.5333956 no
53 0.5333956 no
54 0.7560000 yes
57 0.4906592 no
59 0.5281762 no
62 0.7413333 no
64 0.6626619 no
68 0.4906592 no
74 0.7413333 no
75 0.5333956 yes
76 0.5333956 no
Reference code to create star ratings by using gt & fontawesome packages (this works)
library(tidyverse)
library(gt)
library(htmltools)
library(fontawesome)
Creating function
rating_stars5 <- function(rating, max_rating = 5){
rounded_rating <- floor(rating + 0.5)
stars <- lapply(seq_len(max_rating), function(i){
if(i <= rounded_rating){
fontawesome::fa("star", fill = "orange")
} else{
fontawesome::fa("star", fill = "grey")
}
})
label <- sprintf("%s out of %s", rating, max_rating)
# label <- glue("{rating} out of {max_rating}")
div_out <- div(title = label, "aria-label" = label, role = "img", stars)
as.character(div_out) %>%
gt::html()
}
Applying function on dataframe
df_test %>%
# creating customerid based on row index
mutate(customerid = row.names(.)) %>%
# converting to 5 bins to match 5 stars
mutate(rating = cut_number(prob, n =5) %>% as.numeric()) %>%
mutate(rating = map(rating, rating_stars5)) %>%
arrange(customerid) %>%
# to limit the number of rows in rmarkdown rendered doc
head(n = 15) %>%
gt() %>%
tab_header(title = gt::md("__BankMarketing Term Plan Customer Response Likelyhood__")) %>%
tab_spanner(
label = gt::html("<small>High Stars = higher chances</small>"),
columns = vars(customerid, prob, Class)
) %>%
# table styling to reduce text size
tab_style(
style = cell_text(size = px(12)),
locations = cells_body(
columns = vars(customerid, prob, Class)
)
) %>%
cols_label(
customerid = gt::md("__CUSTOMER__")
)
This creates a nice html table:
Issue:
In above html table instead of Star Ratings I am trying to get tick/cross based on yes/no from class column but unable to do it. This is what I have tried:
# 1. creating function
rating_yes_no <- function(Class){
check_cross <- lapply(Class, function(i){
if(i == "yes"){
fontawesome::fa("check", fill = "green")
} else{
fontawesome::fa("times", fill = "red")
}
})
label <- sprintf("%s", check_cross)
# label <- glue("{check_cross} ")
div_out <- div(title = label, "aria-label" = label, role = "img", check_cross)
as.character(div_out) %>%
gt::html()
}
# 2. Applying function
df_test %>%
mutate(customerid = row.names(.)) %>%
mutate(class_rating = map(class_rating, rating_yes_no)) %>%
arrange(customerid) %>%
# to limit the number of rows in rmarkdown rendered doc
head(n = 15) %>%
gt() %>%
tab_header(title = gt::md("__BankMarketing Term Plan Customer Response Likelyhood__")) %>%
tab_spanner(
label = gt::html("<small>High Stars = higher chances</small>"),
columns = vars(customerid, prob, Class)
) %>%
# table styling to reduce text size
tab_style(
style = cell_text(size = px(12)),
locations = cells_body(
columns = vars(customerid, prob, Class)
)
) %>%
cols_label(
customerid = gt::md("__CUSTOMER__")
)
Had some silly mistakes, below code worked:
rating_yes_no <- function(Class){
check_cross <- lapply(Class, function(i){
if(i == "yes"){
fontawesome::fa("check", fill = "green")
} else{
fontawesome::fa("times", fill = "red")
}
})
label <- sprintf("%s", Class)
# label <- glue("{rating} out of {max_rating}")
div_out <- div(title = label, "aria-label" = label, role = "img", check_cross)
as.character(div_out) %>%
gt::html()
}
df_test %>%
mutate(customerid = row.names(.)) %>%
mutate(class_rating = map(Class, rating_yes_no)) %>%
arrange(customerid) %>%
# to limit the number of rows in rmarkdown rendered doc
head(n = 15) %>%
gt() %>%
tab_header(title = gt::md("__BankMarketing Term Plan Customer Response Likelyhood__")) %>%
tab_spanner(
label = gt::html("<small>High Stars = higher chances</small>"),
columns = vars(customerid, prob, Class)
) %>%
# table styling to reduce text size
tab_style(
style = cell_text(size = px(12)),
locations = cells_body(
columns = vars(customerid, prob, Class)
)
) %>%
cols_label(
customerid = gt::md("__CUSTOMER__")
)
I need to create table with same footnote being placed in both header and body of the table, I cannot figure out how to make it happen using flextable, what I can create is something as below:
library(flextable)
library(dplyr)
library(tidyr)
data(iris)
iris %>%
as_tibble %>%
gather(.,key = variable,value = value,-Species) %>%
group_by(Species,variable) %>%
summarise(value=formatC(mean(value),digits = 2,format = 'f')) %>%
ungroup %>%
spread(.,key = variable,value = value) %>%
flextable %>%
footnote(.,part = 'header',i = 1,j = c(2:5),
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE) %>%
footnote(.,part = 'body',i = c(1:3),j = 1,
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE)
Currently I created two footnotes with the same statement for header and body, I wonder if I can merge the two statements into one.
Thanks!
(I did not imagine footnotes would be repeated when this function has been implemented but) by using merge_v, you can merge them if identical:
library(flextable)
library(dplyr)
library(tidyr)
data(iris)
iris %>%
as_tibble %>%
gather(.,key = variable,value = value,-Species) %>%
group_by(Species,variable) %>%
summarise(value=formatC(mean(value),digits = 2,format = 'f')) %>%
ungroup %>%
spread(.,key = variable,value = value) %>%
flextable %>%
footnote(.,part = 'header',i = 1,j = c(2:5),
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE) %>%
footnote(.,part = 'body',i = c(1:3),j = 1,
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE) %>%
merge_v(part = "footer")