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)
Related
So I'm trying to make cross tables for multi-response questions with both frequency and counts using expss. I am able to get the result I need by running the following code:
library(expss)
set.seed(1998)
expss_output_viewer()
# Example data set
x <- c("A","B","C")
area <- rep(x,each = 10)
p <- sample(c(0,1),30,replace = T)
q <- sample(c(0,1),30,replace = T)
r <- sample(c(0,1),30,replace = T)
mrdata <- data.frame(area,p,q,r)
# Creating the Table
mrdata %>%
tab_significance_options(keep = "none", sig_labels = NULL, subtable_marks = "greater", mode = "append") %>%
tab_cols(total(), mdset(p,q,r)) %>%
tab_cells(area) %>%
tab_stat_cases(label = "cases") %>%
tab_stat_cpct_responses(label = "%",total_row_position = "none") %>%
tab_pivot(stat_position = "inside_columns") %>% set_caption("Table 1")
However, seeing as this is a lot of code for a single table, I wanted to wrap it into a function to be able to create the tables quickly and without much clutter. I've tried doing it like this:
mrtable <- function(input,rowvar,colvars,capt ="Table 1") {
input %>%
tab_significance_options(keep = "none", sig_labels = NULL, subtable_marks = "greater", mode = "append") %>%
tab_cols(total(), mdset(colvars)) %>%
tab_cells(rowvar) %>%
tab_stat_cases(label = "cases") %>%
tab_stat_cpct_responses(label = "%",total_row_position = "none") %>%
tab_pivot(stat_position = "inside_columns") %>% set_caption(capt)
}
mrtable(input = mrdata,colvars = c(p,q,r),rowvar = area)
Running the function above returns:
Error: 'cro': all variables should be of the same length or length 1.
I can't figure out why it fails. Any help would be appreciated.
EDIT:
got it to work :
mrtable <- function(input,rowvar,...,capt ="Table 1") {
input %>%
tab_significance_options(keep = "none", sig_labels = NULL, subtable_marks = "greater", mode = "append") %>%
tab_cols(total(), mdset(...)) %>%
tab_cells(rowvar) %>%
tab_stat_cases(label = "cases") %>%
tab_stat_cpct_responses(label = "%",total_row_position = "none") %>%
tab_pivot(stat_position = "inside_columns") %>% set_caption(capt)
}
mrtable(input = mrdata,rowvar = area,p,q,r,capt = "Tab")
I want to highlight all lines going to a node/marker on a map in mapview. In the example code here, the nodes represent capital cities. Upon hovering on one of the cities, I would like all 4 lines going to/from that city to become highlighted. The hover option inside mapview had no effect, when I tried it. Thanks.
library(dplyr)
library(readr)
library(janitor)
library(sp)
library(purrr)
cc = read_csv("http://techslides.com/demos/country-capitals.csv")
nodes =
cc %>%
clean_names() %>%
mutate(capital_latitude = as.numeric(capital_latitude)) %>%
select(capital_name, capital_longitude, capital_latitude) %>%
filter(capital_name %in% c("Warsaw", "El-Aaiún", "Jamestown", "Antananarivo", "Manama"))
edges =
full_join(
nodes %>% rename(from = capital_name, from_lon = capital_longitude, from_lat = capital_latitude) %>% mutate(index = 1),
nodes %>% rename(to = capital_name, to_lon = capital_longitude, to_lat = capital_latitude) %>% mutate(index = 1),
by = "index") %>%
mutate(from_to = paste(from, "_", to)) %>%
filter(from != to) %>%
select(-index) %>%
rowwise() %>%
mutate(capital_lines = pmap(list(from_lon = from_lon, from_lat = from_lat, to_lon = to_lon, to_lat = to_lat, from_to = from_to),
function(from_lon, from_lat, to_lon, to_lat, from_to) {
Line(cbind(c(from_lon, to_lon),
c(from_lat, to_lat))) %>%
Lines(., ID = from_to)}
)) %>%
mutate(capital_lines = list(SpatialLines(list(capital_lines))))
mapview(nodes, xcol = "capital_longitude", ycol = "capital_latitude") +
mapview(do.call(rbind, edges$capital_lines))
library(mapview)
mapviewOptions(fgb = FALSE)
mapview(shp, highlight = leaflet::highlightOptions(color = "red", weight = 2, sendToBack = TRUE))
This works for me.
See details in https://github.com/r-spatial/mapview/issues/392.
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")
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 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)
)