How to print gt_tbl tables side by side with knitr kable - r

I would like to create beautiful tables with gt package and put three of them side by side using knitr function kable. It does not work as expected. The gt_tbl object is a list and kable prints all elements separately. Is there a way to have nice side by side gt tables? The output format is bookdown / markdown html.
library(tidyverse)
library(gt)
cars <- head(mtcars) %>%
gt() %>%
tab_header(
title = "Mtcars"
)
flowers <- head(iris) %>%
gt() %>%
tab_header(
title = "Iris"
)
knitr::kable(list(cars, flowers))
I also tried this solution Combine multiple gt tables to single one plot which does not yield any good solution. Perhaps gtsave, ggdraw and draw_image can be modified. But I didn't find a good scaling parameter.
library(tidyverse)
library(gt)
crosssection <- data.frame(id = c(1:6),
year = rep(2016,6),
income = c(20,15,35,10,76,23))
repeatedcross <- data.frame(id = c(1:6),
year = c(rep(2015,3),rep(2016,3)),
income = c(20,15,35,10,76,23))
paneldata <- data.frame(id = c(rep(1,3), rep(2,3)),
year = rep(c(2014:2016),2),
income = c(20,15,35,10,76,23))
cs <- crosssection %>%
gt() %>%
tab_header(
title = "Cross-Section" # #subtitle = "Cross-Section"
)
rc <- repeatedcross %>%
gt() %>%
tab_header(
title = "Repeated Cross-Section"
)
pd <- paneldata %>%
gt() %>%
tab_header(
title = "Paneldata"
)
cs %>% gtsave("p11.png", path = "Data/")
rc %>% gtsave("p12.png", path = "Data/")
pd %>% gtsave("p13.png", path = "Data/")
library(cowplot)
p111 <- ggdraw() + draw_image("Data/p11.png", scale = 0.8)
p112 <- ggdraw() + draw_image("Data/p12.png", scale = 0.8)
p113 <- ggdraw() + draw_image("Data/p13.png", scale = 0.8)
plot_grid(p111, p112, p113)
Those tables would clearly fit sidy by side when space between them is optimally used.
After applying the suggestion fixing scale parameter and setting nrow=1 tables are still misaligned in the Viewer pane, as well as the markdown files.
p111 <- ggdraw() + draw_image("Data/p11.png", scale = 0.7)
p112 <- ggdraw() + draw_image("Data/p12.png", scale = 0.96)
p113 <- ggdraw() + draw_image("Data/p13.png", scale = 0.7)
plot_grid(p111, p112, p113, nrow = 1)

You were near the result, I have only finished it for you.
In most cases we should control the scale parameter manually.
Code:
library(gt)
library(tidyverse)
crosssection <- data.frame(id = c(1:6),
year = rep(2016,6),
income = c(20,15,35,10,76,23))
repeatedcross <- data.frame(id = c(1:6),
year = c(rep(2015,3),rep(2016,3)),
income = c(20,15,35,10,76,23))
paneldata <- data.frame(id = c(rep(1,3), rep(2,3)),
year = rep(c(2014:2016),2),
income = c(20,15,35,10,76,23))
cs <- crosssection %>%
gt() %>%
tab_header(
title = "Cross-Section" # #subtitle = "Cross-Section"
)
rc <- repeatedcross %>%
gt() %>%
tab_header(
title = "Repeated Cross-Section"
)
pd <- paneldata %>%
gt() %>%
tab_header(
title = "Paneldata"
)
cs %>% gtsave("marco1.png")
rc %>% gtsave("marco2.png")
pd %>% gtsave("marco3.png")
library(cowplot)
p111 <- ggdraw() + draw_image("marco1.png", scale = 0.7)
p112 <- ggdraw() + draw_image("marco2.png", scale = 0.96)
p113 <- ggdraw() + draw_image("marco3.png", scale = 0.7)
plot_grid(p111, p112, p113, nrow = 1)
Output:
In Rmarkdown looks nice with these settings:

Related

flextable and gtsummary: Title font is different from body font with save_as_docx()

I am trying to print regression tables to Microsoft Word files with gtsummary and flextable. However, despite specifying the styling whenever possible, the title of the table prints in a different font than the rest of the table. I want everything to be in Times New Roman/APA Style, but the title font keeps printing in Cambria. Outside of R, my default Microsoft Word font is Calibri.
I know there are other packages that can print regression tables to Microsoft Word, but I prefer gtsummary and flextable because my actual data is multiply imputed and I have found that gtsummary and flextable work well with multiply imputed data. This is a small issue, but any help is appreciated.
library(tidyverse)
library(gtsummary)
library(flextable)
packageVersion("gtsummary")
#> [1] '1.5.1'
packageVersion("flextable")
#> [1] '0.6.11.4'
# theme based on https://github.com/idea-labs/comsldpsy
apa_theme <- function (ft) {
ft %>%
flextable::font(fontname = "Times New Roman", part = "all") %>%
flextable::fontsize(size = 12, part = "all") %>%
flextable::align(align = "left", part = "all") %>%
flextable::align(align = "center", part = "header") %>%
flextable::rotate(rotation = "lrtb", align = "top", part = "body") %>%
flextable::border_remove() %>%
flextable::hline_top(border = officer::fp_border(width = 2), part = "all") %>%
flextable::hline_bottom(border = officer::fp_border(width = 2), part = "all") %>%
flextable::autofit()
}
set_flextable_defaults(font.family = "Times New Roman")
m1 <- lm(response ~ trt, data = trial) %>% tbl_regression()
m2 <- lm(response ~ trt + marker, data = trial) %>% tbl_regression()
m3 <- lm(response ~ trt + marker + age, data = trial) %>% tbl_regression()
tbl_merge(
tbls = list(m1, m2, m3)) %>%
modify_table_styling(align = "left") %>%
modify_caption("Why is the title in a different font?") %>%
as_flex_table() %>%
apa_theme() %>%
flextable::save_as_docx(path = "~/Desktop/weird_table.docx")
I was able to achieve the desired result by using flextable::add_header_lines instead of gtsummary::modify_caption and by revising apa_theme().
library(tidyverse)
library(gtsummary)
library(flextable)
# theme based on https://github.com/idea-labs/comsldpsy
apa_theme <- function (ft) {
ft %>%
flextable::font(fontname = "Times New Roman", part = "all") %>%
flextable::fontsize(size = 12, part = "all") %>%
flextable::align(align = "left", part = "body") %>%
flextable::align(align = "center", part = "header") %>%
flextable::rotate(rotation = "lrtb", align = "top", part = "body") %>%
flextable::border_remove() %>%
flextable::hline_top(border = officer::fp_border(width = 2),
part = "all") %>%
flextable::hline_bottom(border = officer::fp_border(width = 2),
part = "all") %>%
flextable::hline(i = 1, border = officer::fp_border(width = 1), part = "header") %>%
flextable::set_table_properties(layout = "autofit")
}
m1 <- lm(response ~ trt, data = trial) %>% tbl_regression()
m2 <- lm(response ~ trt + marker, data = trial) %>% tbl_regression()
m3 <- lm(response ~ trt + marker + age, data = trial) %>% tbl_regression()
tbl_merge(
tbls = list(m1, m2, m3)) %>%
modify_table_styling(align = "left") %>%
as_flex_table() %>%
add_header_lines(values = "Table looks better overall", top = TRUE) %>%
apa_theme() %>%
flextable::save_as_docx(path = "~/Desktop/good_table.docx")

Flexdashboard Shiny - output not showing the complete output after knitting

When I knitting the following code in Flexdashboard in R Markdown file, the entire file is not giving output on the entire page, however when I run the code chunk individually it is showing the correct output.
I have tried adjusting Column {width } as well, but nothing is happening.
title: "By sachin"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
library(flexdashboard)
Page 1
Column {data-width=650}
Chart A
library(dplyr)
library(tidyverse)
library(ggplot2)
df <- read.csv("data.csv")
#view(df)
df1 <- subset(df, select = c("year","dem","all_pass"))
#str(df1)
df1$dem <- as.character(df1$dem)
df1$dem = factor(df1$dem, levels = c(0,1),
labels = c("Democrat","Republic"))
#view(df2)
#colnames(df2)<-c("Year","Party","All Bills Passed")
df2 <-df1 %>% group_by(year,dem) %>% summarise_at(vars(all_pass),funs(sum(. , na.rm = TRUE)))
#df2 <-df1 %>% group_by(year,dem ) %>% summarise_at(vars(all_pass),funs(sum(. , na.rm = TRUE)))
ggplot(df2, aes(x=year, fill = dem )) + geom_area(aes(y = all_pass))+labs(y = "All Bills Passed", x = "Year", title = "Number of bills passed since 1980")
Page 2
Column {data-width=500}
Chart B
library(dplyr)
library(tidyverse)
library(broom)
library(ggplot2)
library(plotly)
#install.packages("jtools")
library(jtools)
df <- read.csv("data.csv")
df <- filter(df, df$congress==110)
#view(df)
df3 <- subset(df, select = c(dem, all_pass,votepct))
#view(df3)
#df3 <- filter(df3, dem ==0 & dem ==1)
#view(df3)
df3$dem <- as.character(df3$dem)
df3$dem = factor(df3$dem, levels = c(0,1),
labels = c("Democrat","Republic"))
#view(df3)
#fit<- lm(formula = votepct~dem,df3)
ggplot(df3, aes(x=votepct,y = all_pass, fill = dem,colour = dem )) + geom_point(aes(y = all_pass),size=3)+labs(y = "All Pass", x = "votepct", title = "Passage and Vote Pct , 110th Congress")+ geom_smooth(method="lm")
#df4 <-df3 %>% group_by(dem) %>% summarise_at(vars(all_pass),funs(sum(. , na.rm = TRUE)))
#view(df4)
#abline(fit)
#effect_plot(fit, pred = "dem",interval = TRUE, plot.points = TRUE)
#(fit, pred = votepct, interval = TRUE, plot.points = TRUE)
Column {data-width=500}
Chart C
library(dplyr)
library(tidyverse)
library(broom)
library(ggplot2)
library(plotly)
#install.packages("jtools")
library(jtools)
df <- read.csv("data.csv")
df <- filter(df, df$congress==110)
#view(df)
df5 <- subset(df, select = c(dem, all_pass,dwnom1))
#view(df5)
#df3 <- filter(df3, dem ==0 & dem ==1)
#view(df3)
df5$dem <- as.character(df5$dem)
df5$dem = factor(df5$dem, levels = c(0,1),
labels = c("Democrat","Republic"))
#view(df5)
fit<- lm(formula = all_pass~dwnom1,df5)
ggplot(df5, aes(x=dwnom1,y = all_pass, fill = dem,colour = dem )) + geom_point(aes(y = all_pass),size=3)+labs(y = "All Pass", x = "DW Nominate", title = "Passage and Ideology , 110th Congress")+geom_smooth(method="lm")
Page 3
Column {data-width=650}
Chart D
library(ggplot2)
library(plotly)
library(dplyr)
library(shiny)
ui <- basicPage(
h1("Total bills passed by state delegation, 110th Congress"),
selectizeInput(inputId = "bins",
label = "Choose State",
choices = state.abb,
multiple = TRUE),
plotOutput("plot")
)
server <- function(input, output) {
df <-
tibble(all_pass = sample(1:500, 350),
st_name = rep(state.abb, 7))
output$plot <- renderPlot({
req(input$bins)
df |>
filter(st_name %in% input$bins) |>
ggplot(aes(y = all_pass,x=st_name )) +
geom_bar(stat = "sum")
})
}
shinyApp(ui = ui, server = server)

Showing two labels over a polygon in leaflet in R

I am mapping out zip code areas in leaflet and coloring the polygon based on the Dealer.
Dealer Zipcodes geometry
A 32505 list(list(c(.....)))
B 32505 ....
This code is used to create the colors, labels, and the map.
factpal <- colorFactor(topo.colors(5), data$Dealer)
labels <- paste0("Zip Code: ",data$Zipcodes, ", Dealer: ", data$Dealer)
leaflet(data) %>%
addTiles() %>%
addPolygons( color = ~factpal(Dealer),),
label = labels) %>%
leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright")
When the zip code (and thus the geometry) are the same between two dealers, only one label is visible, though it is clear colors are overlapping. All I want is for that label to somehow show the info for both dealers in that zip code. Please let me know if there is code missing you need, or clarification needed.
Not sure whether you could have multiple tooltips but to show all Dealers in the tooltip you could change your labels such that they include all dealer names per zip code, e.g. making use of dplyr you could do:
library(leaflet)
library(dplyr)
factpal <- colorFactor(topo.colors(5), data$Dealer)
data <- data %>%
group_by(Zipcodes) %>%
mutate(labels = paste(Dealer, collapse = ", "),
labels = paste0("Zip Code: ", Zipcodes, ", Dealer: ", labels))
leaflet(data) %>%
addTiles() %>%
addPolygons(
color = ~factpal(Dealer),
label = ~labels,
weight = 1
) %>%
# leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(
pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright"
)
DATA
nycounties <- rgdal::readOGR("https://eric.clst.org/assets/wiki/uploads/Stuff/gz_2010_us_050_00_20m.json")
nycounties_sf <- sf::st_as_sf(nycounties)
nycounties_sf_n <- nycounties_sf %>%
filter(STATE == "01") %>%
select(Zipcodes = COUNTY, geometry)
data <- list(
A = sample_n(nycounties_sf_n, 40),
B = sample_n(nycounties_sf_n, 40),
C = sample_n(nycounties_sf_n, 40),
D = sample_n(nycounties_sf_n, 40)
)
data <- purrr::imap(data, ~ mutate(.x, Dealer = .y))
data <- do.call("rbind", data)

Correlation doesn't work when variable is selected from selectInput but runs perfectly fine otherwise

I am calculating correlation for each country between Number of Daily Covid Cases & Daily Vaccination.
There are two df, one for Confirmed Cases & other for Vaccinations:
library(tidyverse)
library(lubridate)
library(glue)
library(scales)
library(tidytext)
library(shiny)
library(shinydashboard)
file_url1 <- "https://raw.githubusercontent.com/johnsnow09/covid19-df_stack-code/main/ts_all_long4.csv"
file_url2 <- "https://raw.githubusercontent.com/johnsnow09/covid19-df_stack-code/main/vaccination_data.csv"
ts_all_long <- read.csv(url(file_url1))
vaccination_data <- read.csv(url(file_url2))
ts_all_long <- ts_all_long %>%
mutate(date = as.Date(date))
vaccination_data <- vaccination_data %>%
mutate(date = as.Date(date))
When I use above data to run correlation in rmarkdown then it works:
ts_all_long %>%
left_join(y = vaccination_data,
by = c("Country.Region" = "location", "date", "continent", "iso3c" = "iso_code")) %>%
na.omit() %>%
group_by(Country.Region) %>%
summarise(COR = cor(Confirmed_daily, total_vaccinations),
total_vaccinations_per_hundred = first(total_vaccinations_per_hundred)) %>%
arrange(COR) %>%
na.omit() %>%
slice(c(1:15, ( n()-14): n() ))
Issue: When I use this inside shiny with SelectInput at total_vaccinations to make dynamic Parameter then it gives this error:
Problem with summarise() input COR. [31mx[39m incompatible
dimensions [34mi[39m Input COR is cor(Confirmed_daily, as.numeric(input$id_vaccination_type)). [34mi[39m The error
occurred in group 2: Country.Region = "Argentina".
ui
fluidRow(
style = "border: 1px solid gray;",
h3("Vaccination to Cases Correlation Analysis"),
column(4, style = "border: 1px solid gray;",
selectInput(inputId = "id_vaccination_type", label = "Choose Vaccination Parameter",
choices = c("total_vaccinations","people_vaccinated","people_fully_vaccinated"),
selected = "total_vaccinations")
),
column(8, style = "border: 1px solid gray;",
plotOutput("top_corr_countries", height = "550px") #
)
Server
corr_data <- reactive({
corr_data <- ts_all_long %>%
left_join(y = vaccination_data,
by = c("Country.Region" = "location", "date", "continent", "iso3c" = "iso_code")) %>%
na.omit() %>%
group_by(Country.Region) %>%
summarise(COR = cor(Confirmed_daily, as.numeric(input$id_vaccination_type)) ,
total_vaccinations_per_hundred = first(total_vaccinations_per_hundred)) %>%
na.omit() %>%
arrange(COR) %>%
na.omit() %>%
slice(c(1:15, ( n()-14): n() ))
})
output$top_corr_countries <- renderPlot({
corr_data() %>%
ggplot(aes(x = COR ,
y = fct_reorder(Country.Region, -COR),
col = COR > 0)) +
geom_point(aes(size = total_vaccinations_per_hundred)) +
geom_errorbarh(height = 0, size = 1, aes(xmin = COR, xmax = 0)) +
geom_vline(xintercept = 0, col = "midnightblue", lty = 2, size = 1) +
theme(
panel.grid.major = element_blank(),
legend.position = "NULL") +
labs(title = glue("Top Countries by +/- Correlation with Vaccination as of {max(vaccination_data$date)}"),
subtitle = "Size is proportional to Vaccination per Population",
y = "", x = "Correlation",
caption = "Data source: covid19.analytics
Created by: ViSa")
})
NOTE: I have also published this problem in another link but it sounds more complex in there so I have tried to rephrase it in this one to make it simpler.
Other post: Unable to renderPlot on adding a selectInput option for variable in shiny which runs perfectly fine otherwise
input$id_vaccination_type is a character string of the variable you want to select.
To actually select thevalues of that variable you can turn the name of the variable into a symbol and evaluate it, for example with the bang-bang operator !!.
So one solution would be:
cor(Confirmed_daily, as.numeric(!! sym(input$id_vaccination_type))
I'm not sure if this will make your app work (I can't download the csv files on github and would prefer dput for a minimal example), but it should solve this specific problem.
There are other solutions to this problem. One is to use get instead of !! sym(input)). The other is to use varSelectInput, which returns actual names and not strings (so here the problem should not arise in the first place).

Plotly GGplot - plot reponsive

The code output is a plot that I would like it be responsive, to adjust according to window dimension.
Using just ggplot gives me the result desired but I want to use the interactive tooltip of plotly, but when I do the figure is not responsive.
Is there any fix that it could work ? The code is bellow. I really appreciate any help !
library(dplyr)
library(ggplot2)
library(lubridate)
library(plotly)
df <- data.frame(matrix(c("2017-09-04","2017-09-05","2017-09-06","2017-09-07","2017-09-08",103,104,105,106,107,17356,18022,17000,20100,15230),ncol = 3, nrow = 5))
colnames(df) <- c("DATE","ORDER_ID","SALES")
df$DATE <- as.Date(df$DATE, format = "%Y-%m-%d")
df$SALES <- as.numeric(as.character(df$SALES))
df$ORDER_ID <- as.numeric(as.character(df$ORDER_ID))
TOTALSALES <- df %>% select(ORDER_ID,DATE,SALES) %>% mutate(weekday = wday(DATE, label=TRUE)) %>% mutate(DATE=as.Date(DATE)) %>% filter(!wday(DATE) %in% c(1, 7) & !(DATE %in% as.Date(c('2017-01-02','2017-02-27','2017-02-28','2017-04-14'))) ) %>% group_by(day=floor_date(DATE,"day")) %>% summarise(sales=sum(SALES)) %>% data.frame()
TOTALSALES <- ggplot(TOTALSALES ,aes(x=day,y=sales,text=paste('Vendas (R$):', format(sales,digits=9, decimal.mark=",",nsmall=2,big.mark = "."),'<br>Data: ',format(day,"%d/%m/%Y"))))+ geom_point(colour = "black", size = 1)+stat_smooth() +labs(title='TOTAL SALES',x='dias',y='valor')+ scale_x_date(date_minor_breaks = "1 week")
m <- list(
l = 120,
r = 2,
b = 2,
t = 50,
pad = 4
)
TOTALSALES <- ggplotly(TOTALSALES,tooltip = c("text")) %>% config(displayModeBar = F) %>% layout(autosize = F, width = 1000, height = 500, margin = m,xaxis = list(
zeroline = F
),
yaxis = list(
hoverformat = '.2f'
))
TOTALSALES

Resources