Skip to content

Commit

Permalink
Merge pull request #88 from opensafely/viv3ckj/refactor-rmd-code
Browse files Browse the repository at this point in the history 
Viv3ckj/refactor code (part 2)
  • Loading branch information
@viv3ckj
viv3ckj authored Dec 23, 2024
2 parents c3ca045 + 0eaba2f commit fa12372
Show file tree
Hide file tree
Showing 7 changed files with 1,155 additions and 1,214 deletions.
131 changes: 131 additions & 0 deletions lib/functions/create_tables.R
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,131 @@
# Function to create clinical pathways table
create_clinical_pathways_table <- function(title) {
data <- tibble(
Condition = c(
"Uncomplicated Urinary Tract Infection",
"Shingles",
"Impetigo",
"Infected Insect Bites",
"Acute Sore Throat",
"Acute Sinusitis",
"Acute Otitis Media"
),
Age = c(
"16 to 64 years",
"18 years and over",
"1 year and over",
"1 year and over",
"5 years and over",
"12 years and over",
"1 to 17 years"
),
Sex = c(
"Female",
"Any",
"Any",
"Any",
"Any",
"Any",
"Any"
),
Exclusions = c(
"Pregnant individuals, urinary catheter, recurrent UTI (2 episodes in last 6 months, or 3 episodes in last 12 months)",
"Pregnant individuals",
"Bullous impetigo, recurrent impetigo (2 or more episodes in the same year), pregnant individuals under 16 years",
"Pregnant individuals under 16 years",
"Pregnant individuals under 16 years",
"Immunosuppressed individuals, chronic sinusitis (symptoms lasting more than 12 weeks), pregnant individuals under 16 years",
"Recurrent acute otitis media (3 or more episodes in 6 months or four or more episodes in 12 months), pregnant individuals under 16 years"
)
)

data %>%
gt() %>%
tab_header(
title = title
# subtitle = "Inclusion and exclusion criteria for clinical pathway/conditions"
) %>%
cols_label(
Condition = "Condition",
Age = "Age Range",
Sex = "Sex",
Exclusions = "Exclusions"
) %>%
tab_options(
table.font.size = "medium",
heading.title.font.size = "large",
heading.subtitle.font.size = "small"
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_column_labels(columns = everything())
)
}

# Function to create pharmacy first service codes table
create_pf_service_codes_table <- function(title) {
data <- tibble(
codelist = c(
"Community Pharmacist (CP) Consultation Service for minor illness (procedure)",
"Pharmacy First service (qualifier value)"
),
code = c(
"1577041000000109",
"983341000000102"
)
)

data %>%
gt() %>%
tab_header(
title = title,
# subtitle = "Codelist descriptions and their respective SNOMED codes"
) %>%
cols_label(
codelist = md("**Codelist Description**"),
code = md("**SNOMED Code**")
) %>%
tab_options(
table.font.size = "medium",
heading.title.font.size = "large",
heading.subtitle.font.size = "small"
)
}

create_clinical_conditions_codes_table <- function(title) {
data <- tibble(
condition = c(
"Acute otitis media",
"Herpes zoster",
"Acute sinusitis",
"Impetigo",
"Infected insect bite",
"Acute pharyngitis",
"Uncomplicated urinary tract infection"
),
code = c(
"3110003",
"4740000",
"15805002",
"48277006",
"262550002",
"363746003",
"1090711000000102"
)
)
data %>%
gt() %>%
tab_header(
title = title
# subtitle = "Clinical conditions and their corresponding SNOMED codes"
) %>%
cols_label(
condition = md("**Clinical Condition**"),
code = md("**SNOMED Code**")
) %>%
tab_options(
table.font.size = "medium",
heading.title.font.size = "large",
heading.subtitle.font.size = "small"
)
}
52 changes: 4 additions & 48 deletions lib/functions/load_opensafely_outputs.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,53 +36,9 @@ df_measures <- tidy_measures(
pf_measures_groupby_dict = pf_measures_groupby_dict
)

df_measures$ethnicity <- factor(
df_measures$ethnicity,
levels = c(
"White",
"Mixed",
"Asian or Asian British",
"Black or Black British",
"Chinese or Other Ethnic Groups",
"Missing"
),
ordered = TRUE
)

df_measures$age_band <- factor(
df_measures$age_band,
levels = c(
"0-19",
"20-39",
"40-59",
"60-79",
"80+",
"Missing"
),
ordered = TRUE
)

df_measures$region <- factor(
df_measures$region,
levels = c(
"East",
"East Midlands",
"London",
"North East",
"North West",
"South East",
"South West",
"West Midlands",
"Yorkshire and The Humber",
"Missing"
),
ordered = TRUE
)

df_measures <- df_measures %>%
mutate(sex = factor(sex,
levels = c("female", "male"),
labels = c("Female", "Male")
))
# str(df_measures$ethnicity)
# str(df_measures$age_band)
# str(df_measures$region)
# str(df_measures$sex)

df_measures$age_band[is.na(df_measures$age_band)] <- "Missing"
103 changes: 89 additions & 14 deletions lib/functions/plot_measures.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,62 +29,98 @@ plot_measures <- function(
facet_wrap = FALSE,
facet_var = NULL,
colour_var = NULL,
shape_var = NULL,
colour_palette = NULL,
y_scale = NULL,
scale_measure = NULL,
shapes = NULL,
date_breaks = "1 month",
legend_position = "bottom") {
# Test if all columns expected in output from generate measures exist
expected_names <- c("measure", "interval_start", "interval_end", "ratio", "numerator", "denominator")
missing_columns <- setdiff(expected_names, colnames(data))
# expected_names <- c("measure", "interval_start", "interval_end", "ratio", "numerator", "denominator")
# missing_columns <- setdiff(expected_names, colnames(data))

if (length(missing_columns) > 0) {
stop("Data does not have expected column(s): ", paste(missing_columns, collapse = ", "), call. = FALSE)
}
# if (length(missing_columns) > 0) {
# stop("Data does not have expected column(s): ", paste(missing_columns, collapse = ", "), call. = FALSE)
# }

plot_tmp <- ggplot(
data,
aes(
x = {{ select_interval_date }},
y = {{ select_value }},
colour = {{ colour_var }},
group = {{ colour_var }}
group = {{ colour_var }},
shape = {{ colour_var }},
fill = {{ colour_var }}
)
) +
geom_point() +
geom_line(alpha = .5) +
geom_point(size = 2) +
geom_line(alpha = .3) +
geom_vline(
xintercept = lubridate::as_date("2024-02-01"),
linetype = "dotted",
colour = "orange",
linewidth = .7
) +
scale_x_date(
date_breaks = "1 month",
date_breaks = {{ date_breaks }},
labels = scales::label_date_short()
) +
guides(
color = guide_legend(nrow = guide_nrow)
color = guide_legend(nrow = guide_nrow),
shape = guide_legend(nrow = guide_nrow)
) +
labs(
title = title,
x = x_label,
y = y_label,
colour = guide_label,
shape = NULL,
fill = NULL
) +
theme(
legend.position = legend_position,
plot.title = element_text(hjust = 0.5)
plot.title = element_text(hjust = 0.5),
text = element_text(size = 14)
)

# Change colour based on specified colour palette
if (!is.null(colour_palette)) {
if (length(colour_palette) == 1 && colour_palette == "plasma") {
plot_tmp <- plot_tmp + scale_colour_viridis_d(option = "plasma", end = .75) +
geom_line(size = 0.5) +
geom_point(size = 2.5)
} else {
plot_tmp <- plot_tmp + scale_colour_manual(values = colour_palette)
}
} else {
plot_tmp <- plot_tmp + scale_colour_viridis_d(end = .75)
}

if (!is.null(shapes) && shapes == "condition_shapes") {
plot_tmp <- plot_tmp + scale_shape_manual(values = condition_shapes)
}

# Automatically change y scale depending selected value
if (rlang::as_label(enquo(select_value)) %in% c("numerator", "denominator")) {
scale_label <- rlang::as_label(enquo(scale_measure))
if (is.null(scale_measure)) {
plot_tmp <- plot_tmp + scale_y_continuous(
limits = c(0, NA),
labels = scales::label_number()
)
} else {
} else if (scale_measure == "rate") {
plot_tmp <- plot_tmp + scale_y_continuous(
limits = c(0, NA),
# scale = 1000 to calculate rate per 1000 people
labels = scales::label_number(scale = 1000)
)
} else if (scale_measure == "percent") {
plot_tmp <- plot_tmp + scale_y_continuous(labels = scales::percent)
} else {
plot_tmp <- plot_tmp + scale_y_continuous(
limits = c(0, NA),
labels = scales::label_number()
)
}

# Add facets if requested
Expand All @@ -94,12 +130,51 @@ plot_measures <- function(
plot_tmp <- plot_tmp +
facet_wrap(vars({{ facet_var }}), ncol = 2)
}
# Add y_scale to add option for free_y
if (!is.null(y_scale) && y_scale == "free_y") {
plot_tmp <- plot_tmp +
facet_wrap(~source, scales = "free_y")
}

plot_tmp
}

set_patchwork_theme <- function(patchwork_figure) {
patchwork_figure +
plot_annotation(tag_levels = "A") +
plot_layout(guides = "collect", widths = c(2, 1)) &
theme(
legend.position = "bottom",
text = element_text(size = 15),
strip.background = element_rect(size = 0),
strip.text.x = element_text(size = 13, face = "bold")
)
}

save_figure <- function(figure, width = 10, height = 6) {
# this uses the 'figure' argument as a string to later generate a filename
figure_name <- deparse(substitute(figure))
ggsave(
filename = here("released_output", "results", "figures", paste(figure_name, "png",sep = ".")),
figure,
width = width, height = height
)
}

# Colour palettes
gradient_palette <- c("#001F4D", "#0056B3", "#007BFF", "#66B3E2", "#A4D8E1", "grey")
region_palette <- c("red", "navy", "#018701", "#ffa600ca", "purple", "brown", "#f4a5b2", "cyan", "green", "grey")
ethnicity_palette <- c("#42db0188", "#0056B3", "#ff0000c2", "#a52a2a5a", "purple", "grey")
sex_palette <- c("red", "blue")
dark2_palette <- RColorBrewer::brewer.pal(n = 8, name = "Dark2")

# Custom shapes
condition_shapes <- c(
"Acute Sinusitis" = 15,
"Infected Insect Bite" = 19,
"UTI" = 4,
"Acute Otitis Media" = 23,
"Acute Pharyngitis" = 3,
"Herpes Zoster" = 17,
"Impetigo" = 8
)
Loading

0 comments on commit fa12372

Please sign in to comment.