I've finally made my dream table with kableExtra, but it's doing very weird things with kable_styling(latex_options=c("repeat_header")), where it's writing the headings over my column labels. Here I'm using the example dataset diamonds. It is also moving the first column below where it should be (red arrows in picture).
(Also can't download LaTex because of work authorization issues, so that's not an option)
Thanks for all the help!
library(knitr)
library(kableExtra)
library(dplyr)
options(
knitr.table.toprule = '\\toprule',
knitr.table.midrule = '\\midrule',
knitr.table.bottomrule = '\\bottomrule'
)
df1 <- read.csv("diamonds.csv")
a11<-df1%>%
group_by(cut, color, clarity)%>%
summarize_at( .vars=c("price"),
.funs=~mean(.,na.rm=TRUE)) %>%
mutate(sort = 3)
b11<-df1%>%
group_by(cut, color) %>%
summarize_at( .vars=c("price"),
.funs=~mean(.,na.rm=TRUE)) %>%
mutate(clarity="", sort = 2) %>%
select(cut, color, clarity,everything())
c11<-df1 %>%
group_by(cut) %>%
summarize_at( .vars=c("price"),
.funs=~mean(.,na.rm=TRUE)) %>%
mutate(color="", clarity= "", sort = 1) %>%
select(cut, color,everything())
table3<-rbind(a11,b11,c11)
table3%>%
arrange(cut, color, clarity) %>%
select(-sort)%>%
filter(price>=3000)%>%
kbl(
caption = "Table",
longtable=T, booktabs=T) %>%
add_header_above(header = c("Table 1." = 4))%>%
kable_styling(latex_options=c("repeat_header"))%>%
kable_paper(full_width = F) %>%
column_spec(1, bold = T) %>%
column_spec(3, italic = T) %>%
collapse_rows(columns = 1:3, valign = "top")
Related
I am trying to get a table for my dataset that only shows rows which are above a certain value, but which still uses the numbers in those rows to get the means for the supersets. using the df diamonds, i have the following code. What I want is for all rows with column price less than 3000 to NOT show up, but to still have them figure into the means of price for superset rows of cut and color.
Kind of a separate question, but I'm also trying to figure out how to make it so that if there were to be only one row in any of the subset rows, then they would be on the same line as the superset rows- such as if cut Fair had only one color
library(knitr)
library(kableExtra)
df <- diamonds
a11<-df%>%
group_by(cut, color, clarity)%>%
summarize_at( .vars=c("price"),
.funs=~mean(.,na.rm=TRUE)) %>%
mutate(sort = 3)
b11<-df%>%
group_by(cut, color) %>%
summarize_at( .vars=c("price"),
.funs=~mean(.,na.rm=TRUE)) %>%
mutate(clarity="", sort = 2) %>%
select(cut, color, clarity,everything())
c11<-df %>%
group_by(cut) %>%
summarize_at( .vars=c("price"),
.funs=~mean(.,na.rm=TRUE)) %>%
mutate(color="", clarity= "", sort = 1) %>%
select(cut, color,everything())
table3<-rbind(a11,b11,c11)
table3%>%
arrange(cut, color, clarity) %>%
select(-sort)%>%
kbl(
caption = "Table",
longtable=T
) %>%
kable_paper(full_width = F) %>%
column_spec(1, bold = T) %>%
column_spec(3, italic = T) %>%
collapse_rows(columns = 1:3, valign = "top")%>%
add_header_above(header = c("Diamonds" = 4))```
I am using flextable and officer in my shiny app to allow users to create powerpoint slides from the app. I am having a bit of a problem with flextable adjusting itself to the dimensions of the placeholder specified in the slide master of my ppt template.
Also I am aware that autofit in flextable does not work for pptx.
Below are two examples, in the first example (with the mtcars data) the table seems to be fine in terms of automatically adjusting the font sizes to match the width and height given.
df <- as_tibble(mtcars, rownames = "cars") %>%
mutate(Date = as.Date("2020-01-01"))
select(-4,5)
flextable::flextable(df) %>%
fit_to_width(max_width = 5.928819) %>%
height(height = 4.6319444/nrow(df)) %>%
color(i=~str_detect(cars,"Merc"), j=~cars, color = "red", part = "body") %>%
bg(i = ~str_detect(cars,"Merc"), j=~cars, bg="black", part = "body") %>%
color(i=~str_detect(cars,"Hornet"), j=~cars, color = "blue", part = "body") %>%
color(i=~mpg < 20, j=~mpg, color = "green", part = "body") %>%
#my_theme() %>%
print(preview = "pptx")
However in the second example with the air quality data the table is always longer that the height specified and the font size does not automatically adjust. Can anyone shed light on why one table works but the other doesnt?
df4 <- mutate(airquality, Ozone = 1000*Ozone) %>%
head(30) %>%
mutate(word = "ABCDEF")
flextable::flextable(df4) %>%
fit_to_width(max_width = 5.9288199) %>%
height(height =4.6319444/(nrow(df4))) %>%
add_header_row(top = TRUE, values = c("quality", "time", "rand"), colwidths = c(4,2,1)) %>%
add_footer_lines("some text can go here") %>%
colformat_num(j=~Ozone, big.mark = ",") %>%
colformat_double(j=~Wind, suffix = " $") %>%
vline_left(border = fp_border(color = "red", style="solid", width = 1)) %>%
vline_right(border = fp_border(color = "red", style="solid", width = 1)) %>%
vline(j=~Temp, border = fp_border()) %>%
set_header_labels(Temp = "Temperature") %>%
#hrule(rule = "exact", part = "body") %>%
print(preview = "pptx")
How can you control line thickness in html outputs using flextable? It looks fine in the RStudio viewer. I think this might not have to do with flextable and might just be a problem with however flextable gets turned to HTML, but not sure where that occurs.
library(dplyr)
library(flextable)
library(officer)
iris %>% head(n=4) %>% flextable() %>%
bg(bg = "#00557F", part = "header") %>%
bold(part = "header") %>%
color( color = "white", part = "header") %>%
border_outer(border = big_border, part = "all" ) %>%
border_inner_h( border = std_border, part = "all" ) %>%
border_inner_v( border = std_border, part = "all" ) %>%
autofit() %>% save_as_html(path = 'ex.html')
I am loving flextable however, incorporating it within my workflow is causing issues in that I am not able to write general purpose functions.
I want a function that would automatically highlight the header and the last row of the table. I am able to do this but I have to specify the name of the first column name. This is simply too much work, is there a work around?
library(tidyverse)
require(flextable)
require(rlang)
# Function that works
my_table <- function(x){
require(flextable)
require(rlang)
x %>%
flextable() %>%
# Header colour and bold
bg(bg = "#e05297", part = "header") %>%
flextable::color(color = "white", part = "header") %>%
# Last row bold and highlight
bold(i = ~rowname == "Total", bold = TRUE) %>%
bg(i = ~rowname == "Total",
bg = "grey",
part = "body")
}
mtcars %>%
rownames_to_column() %>%
adorn_totals("row") %>%
my_table()
# This is a general purpose function which is not working
my_table <- function(x){
require(flextable)
require(rlang)
first_col_name <- colnames(x) %>% .[1]
x %>%
flextable() %>%
# Header colour and bold
bg(bg = "#e05297", part = "header") %>%
flextable::color(color = "white", part = "header") #%>%
# Last row bold and highlight
bold(i = ~eval(rlang::sym(first_col_name)) == "Total", bold = TRUE) %>%
bg(i = ~eval(rlang::sym(first_col_name)) == "Total",
bg = "grey",
part = "body")
}
Any ideas how to make the general purpose my_table function to work
i argument also accepts position (row number) of the dataframe to highlight so you may use nrow to get the last row in the dataframe.
library(flextable)
library(janitor)
my_table <- function(x){
x %>%
flextable() %>%
# Header colour and bold
bg(bg = "#e05297", part = "header") %>%
flextable::color(color = "white", part = "header") %>%
bold(i = nrow(x), bold = TRUE) %>%
bg(i = nrow(x),bg = "grey",part = "body")
}
mtcars %>%
rownames_to_column() %>%
adorn_totals("row") %>%
my_table()
I'd like to generate a set of gt table objects in a grid or side-by-side. For example, the code below uses the group_by argument to vertically separate them. But what if I wanted them separated side-by-side?
mtcars2 <-
mtcars %>%
mutate(good_mpg = ifelse(mpg > 20, "Good mileage", "Bad mileage"),
car_name = row.names(.))
mtcars2 %>%
group_by(good_mpg) %>%
slice_max(order_by = hp, n=5) %>%
arrange(hp) %>%
select(car_name, hp) %>%
gt() %>%
data_color(columns = c("hp"),
colors = col_numeric(palette = "Blues",
domain = c(0, 400)))
You can do this by using as_raw_html() for the internal tables, and fmt_markdown(columns = TRUE) in the top-level table.
hp_table <- function(x){
gt(x) %>%
data_color(columns = c("hp"),
colors = col_numeric(palette = "Blues",
domain = c(0, 400))) %>%
tab_options(column_labels.hidden = TRUE) %>%
as_raw_html() # return as html
}
good_mpg_table <-
mtcars %>%
mutate(good_mpg = ifelse(mpg > 20, "Good mileage", "Bad mileage"),
car_name = row.names(.)) %>%
filter(good_mpg == "Good mileage") %>%
head(5) %>%
arrange(hp) %>%
select(car_name, hp) %>%
hp_table()
bad_mpg_table <-
filter(good_mpg == "Bad mileage") %>%
head(5) %>%
arrange(hp) %>%
select(car_name, hp) %>%
hp_table()
data_tables <- data.frame(good_table = good_mpg_table,
bad_table = bad_mpg_table)
data_tables %>%
gt() %>%
fmt_markdown(columns = TRUE) %>% #render cell contents as html
cols_label(good_table = "High mileage",
bad_table = "Low mileage")
#Daniel, thank you for sharing this! This can come in handy.
To make the code a little bit more compact you could use group_map (or do) to generate the two tables within the dplyr workflow, then join them as you did:
library(dplyr)
library(gt)
library(scales)
hp_table <- function(x){
gt(x) %>%
data_color(columns="hp",
colors=col_numeric(palette="Blues", c(0, 400))) %>%
tab_options(column_labels.hidden = TRUE) %>%
as_raw_html()
}
mtcars %>%
mutate(good_mpg = ifelse(mpg > 20, "Good mileage", "Bad mileage"),
car_name = row.names(.)) %>%
arrange(hp) %>%
group_by(relevel(factor(good_mpg), "Good mileage")) %>%
slice_head(n=5) %>%
select(car_name, hp) %>%
group_map(~ hp_table(.x)) %>%
data.frame(.) %>%
setNames(., c("High mileage", "Low mileage")) %>%
gt() %>%
fmt_markdown(columns = TRUE)