I am attempting to indent text in the stub for a GT table. Some of the text in the stub is quite long and wraps across multiple lines. When I apply an indentation to the stub, the second (and subsequent) lines of the text are not indented. I simply want to indent the entire wrapped text of the stub.
Here is a reproducible example:
library(dplyr)
library(gt)
library(tidyr)
# Get vectors of 2-letter country codes for
# each region of Oceania
Australasia <- c("AU", "NZ")
Melanesia <- c("NC", "PG", "SB", "VU")
Micronesia <- c("FM", "GU", "KI", "MH", "MP", "NR", "PW")
Polynesia <- c("PF", "WS", "TO", "TV")
# Create a gt table based on a preprocessed `countrypops`
countrypops %>%
filter(country_code_2 %in% c(
Australasia, Melanesia, Micronesia, Polynesia)
) %>%
filter(year %in% c(1995, 2005, 2015)) %>%
mutate(region = case_when(
country_code_2 %in% Australasia ~ "Australasia",
country_code_2 %in% Melanesia ~ "Melanesia",
country_code_2 %in% Micronesia ~ "Micronesia",
country_code_2 %in% Polynesia ~ "Polynesia",
)) %>%
pivot_wider(names_from = year, values_from = population) %>%
arrange(region, desc(`2015`)) %>%
select(-starts_with("country_code")) %>%
gt(
rowname_col = "country_name",
groupname_col = "region"
) %>%
tab_style(
style = list(
cell_text(indent = pct(8))
),
locations = cells_stub()
) %>%
cols_width(country_name ~ 150)
Picture of incorrectly indented table:
How can I apply indenting consistently across the stub rows?
Intend (text-indent) only applies to the first line, for multiple lines use padding-left, e.g.
countrypops %>%
filter(country_code_2 %in% c(
Australasia, Melanesia, Micronesia, Polynesia)
) %>%
filter(year %in% c(1995, 2005, 2015)) %>%
mutate(region = case_when(
country_code_2 %in% Australasia ~ "Australasia",
country_code_2 %in% Melanesia ~ "Melanesia",
country_code_2 %in% Micronesia ~ "Micronesia",
country_code_2 %in% Polynesia ~ "Polynesia",
)) %>%
pivot_wider(names_from = year, values_from = population) %>%
arrange(region, desc(`2015`)) %>%
select(-starts_with("country_code")) %>%
gt(
rowname_col = "country_name",
groupname_col = "region"
) %>%
tab_style(
style = "padding-left:30px;",
locations = cells_stub()
) %>%
cols_width(country_name ~ 150)
Related
I am trying to process a inputed data file by running calculations and organizing it. I then want to use that data in a couple of output functions to display a table and several plots. The problem I am having is how to store these variables so that I can just run ggplotly or select to get the desired data I want to display to the user. I am confused how to use reactive and was wondering if I am doing this right at all.
library(shiny)
library(readr)
library(fs)
library(tidyverse)
library(broom)
library(readxl) # to read in excel files
library(ggpubr) # for stat_cor function to plot linear model equations on graph
library(inflection) # to uses ese function to ID inflection point
library(plotly) # for interactive plots
library(gridExtra) # to combine plots
library(knitr) # to print tables
curves_dataframe_names <- c("dose_number","volume_mL", "mV", "pH", "Graphic", "Temp", "Letter" , "Time")
ui <- fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput("file1", "Choose RPT File",
multiple = TRUE,
accept = c("text/rpt",
"text/comma-separated-values,text/plain",
".RPT")),
tags$hr(),
),
mainPanel(
tableOutput("contents"),
)
)
)
server <- function(input, output) {
proccess_data <- function(input) {
reactive ({
req(input$file1)
ALL_CURVES_FRAME1 <-
input$file1$datapath %>%
map_dfr(read_table, .id = "file_name", skip = 1, col_names = curves_dataframe_names)%>%
mutate(
file_id = case_when(grepl("Report", dose_number) ~ mV),
result = case_when(grepl("Result:", dose_number) ~ volume_mL),
#endpt_vol_mL = case_when(grepl("End" , dose_number) ~ pH),
#end_pt_ph = case_when(grepl("pH Fixed End Point: ", X1) ~ gsub("pH Fixed End Point: ", "", X1)),
init_ph = case_when(grepl("Initial", dose_number) ~ Graphic),
fin_ph = case_when(grepl("Initial", dose_number) ~ Letter),
Method = case_when(grepl("Method", dose_number) ~ paste(mV, pH, Graphic)),
date = case_when(grepl("Time", dose_number) ~ paste(Graphic, Temp, Letter))) %>% select(-Graphic, -Temp, -Letter)
ALL_CURVES_FRAME1$date = gsub(",", "", ALL_CURVES_FRAME1$date)
ALL_CURVES_FRAME1$date = as.Date(ALL_CURVES_FRAME1$date, format = "%b%d%Y")
file_ids <- ALL_CURVES_FRAME1 %>% select(file_name, file_id) %>% mutate(file = file_id) %>% select(file_name, file) %>% unique() %>% na.omit()
results <- ALL_CURVES_FRAME1 %>% select(file_name, result) %>% mutate(result_mL = result) %>% select(file_name, result_mL) %>% unique() %>% na.omit()
init_phs <- ALL_CURVES_FRAME1 %>% select(file_name, init_ph) %>% mutate(init_phs = init_ph) %>% select(file_name, init_phs) %>% unique() %>% na.omit()
fin_phs <- ALL_CURVES_FRAME1 %>% select(file_name, fin_ph) %>% mutate(fin_phs = fin_ph) %>% select(file_name, fin_phs) %>% unique() %>% na.omit()
methods <- ALL_CURVES_FRAME1 %>% select(file_name, Method) %>% mutate(method = Method) %>% select(file_name, method) %>% unique() %>% na.omit()
date <- ALL_CURVES_FRAME1 %>% select(file_name, date) %>% mutate(date_analyzed = date) %>% select(file_name, date_analyzed) %>% unique() %>% na.omit()
ALL_CURVES_FRAME <- full_join(ALL_CURVES_FRAME1, file_ids) %>% full_join(results) %>% full_join(init_phs) %>% full_join(fin_phs) %>% full_join(date) %>% select(-result, -file_name, -file_id, -Method, -init_ph, -fin_ph, -date) %>% rename(init_ph = init_phs, fin_ph = fin_phs, file_id = file) %>% filter(!is.na(Time))
raw_data_summary <- ALL_CURVES_FRAME %>% select(date_analyzed, result_mL, file_id) %>% unique()
metadata <- read_excel("~/Google Drive/My Drive/Houlton_Cornell/TitrationData/Autotitration Metadata Sheet.xlsx", sheet = "Growth Chamber Titrations") %>% select(file_id = report_ID , pot_name, date_collected, stock_date_created, date_lab_measured, tube, experiment_num, sample_grams = sample_vol_mL_g, amount_DI_added_mL, result_mL = endpt_vol_mL, process) %>% mutate(std_mL = 0) %>% filter(process == "yes") #not bringing in: pre_pH, sample_name
ALL_CURVES_FRAME$result_mL <- as.double(ALL_CURVES_FRAME$result_mL)
mapping_info <- read_excel("~/Google Drive/My Drive/Houlton_Cornell/Growth Chamber/Growth Chamber Notes.xlsx", sheet = "Mapping_info")
samples <-left_join(metadata, ALL_CURVES_FRAME, by = c("file_id", "result_mL"))
#b.Select Standards
standards_info <- read_excel("~/Google Drive/My Drive/Houlton_Cornell/TitrationData/Autotitration Metadata Sheet.xlsx", sheet = "Stock Solution", skip = 1)
standards_wt <- standards_info %>% select(stock_date_created = Date_Created, std_wt = Bicarbonate_mg)
standards <- samples %>% filter(stock_date_created != "NA") %>% right_join(standards_wt) %>% select(-experiment_num, -date_collected) %>% mutate(standard_name = paste(pot_name, tube, date_lab_measured)) %>% select(-date_lab_measured)
n_standards <- standards %>% filter(dose_number == "0") %>% unique()
#c.Remove bad Titration Curves
standards$pH <- as.numeric(standards$pH)
standards$volume_mL <- as.numeric(standards$volume_mL)
bad_curves_estimated <- standards %>%
mutate(
pH_change = pH - lag(pH)
) %>% filter(pH <5.8) %>% filter(pH_change > 0)%>% select(standard_name) %>% unique() %>% print()
#d. Calculate derivatives
# extrapolate extra data points for low dose curves
extrapolated_vol <- standards %>% group_by(standard_name) %>%
mutate(
n_dose = n()
) %>% filter(n_dose < 20) %>% mutate(
middle_pH = (pH + lag(pH)) / 2,
middle_mL = (volume_mL + lag(volume_mL))/2,
extrapolated = "yes"
) %>% select(-pH, -volume_mL, -n_dose) %>% rename (volume_mL = middle_mL, pH = middle_pH) %>% na.omit()
standards <- standards %>% bind_rows(extrapolated_vol) %>% group_by(standard_name)
#calculate derivatives of pH
all_curves_derived <- standards %>%
mutate(
dv = volume_mL - lag(volume_mL), # change in volume
dpH = abs(pH - lag(pH)), # change in pH
dpH_per_dv = dpH/dv, # 1st deriv, change in pH per change in vol
d2pH = dpH_per_dv - lag(dpH_per_dv), # change in 1st deriv
d2pH_per_dvsq = d2pH/dv^2 #2nd deriv, change in change of pH per change in vol
)
#e.Calculate bicarbonate and compare
#Calculate equivalence point based on derivative
derivative_eq1 <- all_curves_derived %>% group_by(standard_name) %>% filter(pH<6) %>%
mutate(
derivative_eq = case_when(dpH_per_dv == max(dpH_per_dv, na.rm = TRUE) ~ volume_mL)
) %>% select(standard_name, derivative_eq) %>% na.omit()
#Calculate bicarbonate
derivative_eq_first <- left_join(derivative_eq1, all_curves_derived) %>% mutate(
curve_alk_mg_L = ((50044 * derivative_eq*.1/sample_grams)*1.22)) %>% ungroup()
#Calculate for comparisons
standard_check() <- derivative_eq_first %>% select(pot_name, standard_name, derivative_eq, stock_date_created, sample_grams, tube, date_analyzed, std_wt, curve_alk_mg_L) %>% unique() %>% group_by(date_analyzed) %>% mutate(
daily_mean = mean(curve_alk_mg_L),
daily_std_dev = sd(curve_alk_mg_L)
) %>% ungroup() %>% mutate(
analyzed_actual_diff = curve_alk_mg_L - std_wt
)
standard_check_2<- standard_check() %>% select(pot_name, date_analyzed, tube, std_wt, curve_alk_mg_L, daily_mean, daily_std_dev, analyzed_actual_diff) %>% kable()
return(standard_check_2)
}) }
output$contents <- renderTable({
return(proccess_data(input))})
}
shinyApp(ui = ui, server = server)
I have a set of two dataframes that both contain duplicates but need to be merged into one big dataframe in order to use it as input for an ML algorithm.
Connecting the two dataframes is a big problem in the first place. Furthermore, it is difficult to predict multiple classes from the resulting dataset.
Since the original dataset has its origin in the medical field and is confidential, I added a fictional (though realistic) example code for a reproduction of the problem below.
library(data.table)
library(dplyr)
library(tidyr)
data1 <- data.table("color" = c("green", "green", "red", "red", "blue", "blue", "blue", "red", "pink"),
"type" = c("SUV", "SUV", "SEDAN", "SEDAN", "SEDAN", "TRUCK", "TRUCK", "CABRIO", "CABRIO"),
"NUM_SEATS" = c(4,4,5,4,4,3,3,2,2),
"MODELL_ID" = c("xyz", "xyz", "abc", "abc", "abc", "rtz", "rtz", "ghj", "ghj"))
data2 <- data.table("BRAND" = c("VW", "VW", "VW", "AUDI", "AUDI", "BMW", "BMW", "GM", "GM"),
"year_quarter" = c("20173", "20173", "20174", "20174", "20171", "20181", "20162", "20172", "20192"),
"MODELL_ID" = c("xyz", "xyz", "abc", "abc", "abc", "rtz", "rtz", "ghj", "ghj"))
data1 <- data1 %>% group_by(MODELL_ID) %>% mutate(time = row_number()) %>% ungroup()
data2 <- data2 %>% group_by(MODELL_ID) %>% mutate(time = row_number()) %>% ungroup()
data1_temp <- data1 %>% pivot_wider(names_from = time, values_from = c(-MODELL_ID), names_sort = TRUE, names_sep = "-")
data2_temp <- data2 %>% pivot_wider(names_from = time, values_from = c(-MODELL_ID), names_sort = TRUE, names_sep = "-")
data_join <- inner_join(data1_temp, data2_temp, by = c("MODELL_ID")) %>% select(-starts_with(c("n.", "time"))) %>% pivot_wider(names_from = "MODELL_ID", values_from = "MODELL_ID", names_prefix = "MODELL_ID-") %>% as.matrix()
data_join[is.na(data_join)] <- "0"
x_data <- data_join %>% as.data.table() %>% select(-starts_with("MODELL_ID-"))
y_data <- data_join %>% as.data.table() %>% select(starts_with("MODELL_ID-"))
x_data # input (unvectorized)
y_data # output (unvectorized)
x_data %>% data.matrix()-1 # input (vectorized)
y_data %>% data.matrix()-1 # output (vectorized)
X is my input (x_data), Modell_ID (y_data) my output. I want my ML solution to predict all possible Modell_IDs when given a row of X.
It would be great to get some advise on how to actually implement a solution for this. Every approach so far (Feed-Forward Net, etc.) has not delivered noticeable results...
I am really looking for a game-changing command, approach, example code rather than just superficial tips.
I got this code from someone else and so only know the basic framework. However, to reproduce this you would open a new R markdown document, delete everything below the YAML, and then paste in this. The items in bold below have to be moved to the left for this to knit.
My question is this, how would I bring the United States into the table as a 11th item? Would I do this action in the jolts section or the subtable? United states is code "00". Every state has a two digit state code with the US being "00"
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(tidyverse)
library(readxl)
library(data.table)
library(tigris)
library(lubridate)
library(kableExtra)
library(zoo)
knitr::opts_chunk$set(echo = FALSE)
state_filter <- "Nevada"
all_state <- states(resolution = "20m", cb = TRUE) %>%
mutate(fips_num = as.integer(STATEFP)) %>%
filter(fips_num %in% c(1:56)) %>%
shift_geometry()
jolts_import <- fread("https://download.bls.gov/pub/time.series/jt/jt.data.1.AllItems")
jolts_series <- fread("https://download.bls.gov/pub/time.series/jt/jt.series")
jolts_states <- fread("https://download.bls.gov/pub/time.series/jt/jt.state")
jolts_elements <- fread("https://download.bls.gov/pub/time.series/jt/jt.dataelement")
jolts <- jolts_import %>%
filter(period != "M13") %>%
select(-c(footnote_codes)) %>%
left_join(jolts_series %>% select(-footnote_codes), by = "series_id") %>%
left_join(jolts_states %>% select(-c(display_level:sort_sequence)), by = "state_code") %>%
left_join(jolts_elements %>% select(-c(display_level:sort_sequence)), by =
"dataelement_code") %>%
filter(area_code == 0, sizeclass_code == 0, industry_code == 0) %>%
select(-c(area_code, sizeclass_code, industry_code)) %>%
mutate(date = ymd(paste(year, str_remove(period, "M"), "01", sep="-")))%>%
filter(!(state_code %in% c("MW", "NE", "SO", "WE"))) %>%
mutate(ratelevel_code = case_when(
ratelevel_code == "L" ~ "Level",
ratelevel_code == "R" ~ "Rate",
TRUE ~ "Other"),
periodname = format(date, "%B"),
value = if_else(ratelevel_code == "Rate", value/100, value*1000)) %>%
group_by(state_text, dataelement_code, ratelevel_code, seasonal) %>%
mutate(lag_1mo = lag(value, 1),
lag_12mo = lag(value, 12),
change_1mo = value - lag_1mo,
change_12mo = value - lag_12mo,
avg_12mo = rollapplyr(data = value, width = 12, FUN = mean, partial = TRUE)) %>%
ungroup() %>%
group_by(dataelement_code, ratelevel_code, seasonal, date) %>%
mutate(rank_value = floor(rank(-value)),
rank_1mo = floor(rank(-change_1mo)),
rank_12mo = floor(rank(-change_12mo))
)
subtitle <- paste0("Data for ",state_filter,", ",format(max(jolts$date), "%B %Y"))
jolts_state <- all_state %>%
left_join(jolts, by = c("NAME" = "state_text"))
**```**
---
subtitle: '`r subtitle`'
---
\newpage
<div class = "row">
### Hire Rate
<div class>
**```{r}**
data_filter <- "HI"
data_text <- jolts_elements %>% filter(dataelement_code == data_filter) %>%
pull(dataelement_text) %>% str_to_title()
sub_table <- jolts %>%
ungroup() %>%
filter(
rank_value <= 5 | rank_value >= 47 | state_text == "United States",
date == max(date),
seasonal == "S",
dataelement_code == data_filter,
ratelevel_code == "Rate"
) %>%
select(state_text, value, lag_1mo, lag_12mo, rank_value) %>%
arrange(rank_value)
sub_table %>%
mutate(value = scales::percent(value, accuracy = 0.1),
lag_1mo = scales::percent(lag_1mo, accuracy = 0.1),
lag_12mo = scales::percent(lag_12mo, accuracy = 0.1)) %>%
kable(col.names = c("State","Current","Prior Month","Prior Year","Rank"), align = "lcccr") %>%
kable_paper("hover", full_width = F, position = "float_left", font_size = 12) %>%
row_spec(row = which(sub_table$state_text == state_filter), background = "#005a9c", bold = TRUE, color = "white")
So the solution is two parts.
First, put the following code in after the four jolts elements.
jolts_states <- jolts_states%>%mutate(state_text = if_else(state_text == "Total
US", "United States", state_text))
second, one needs to modify the sub table code with the following
rank_value <= 5 | rank_value >= 47 | state_code == "00",
I am using the WHO dataset in R and currently having trouble collapsing the age section into five groups as seen in this picture.
I have pasted a copy of my code below, anything helps.
names(who) <- str_replace(names(who), "newrel", "new_rel")
who2 <- who %>%
gather("codes", "case", 5:60) %>%
select(-iso2, -iso3) %>%
separate(codes, c("new", "type", "sexage"), sep = "_") %>%
select(-new) %>%
separate(sexage, into = c("sex", "age"), sep = 1,convert=TRUE)
who2 %>%
filter(!is.na(case)) %>%
group_by(year, sex, age) %>%
mutate(cases = sum(case)) %>%
mutate(age = factor(age, levels=c("14","1524", "2534","3544","4554","5564","65"),ordered=TRUE)) %>% mutate(age = fct_recode(age, "0-14" = "14", "15-24" = "1524", "25-34" = "2534", "35-44" = "3544", "45-54" = "4554", "55-64" = "5564", "65+" = "65")) %>%
ggplot() +
geom_line(mapping = aes(x = year, y = cases, color = age)) +
facet_wrap(~sex)
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)