---
title: "Total and High-Density Lipoprotein Cholesterol in Adults: United States, August 2021–August 2023"
subtitle: Using R with NHANES
author: Cubicle 3253
format:
html:
code-tools: true
echo: false
embed-resources: true
linestretch: 1.1
page-layout: full
---
This document replicates the first 2 figures in a
<a href="https://www.cdc.gov/nchs/products/databriefs/db515.htm">
NCHS Data Brief</a> examining total and high-density lipoprotein
cholesterol in U.S. adults.
```{r}
#| message: false
library(apexcharter)
library(dplyr)
library(haven)
library(srvyr)
library(survey)
library(surveytable)
library(viridisLite)
set_opts(mode = "NCHS", output = "gt")
create_figure <- function(df) {
apex(df, aes(x = by_var, y = p, fill = grp_var),
type = "column",
height = "540px", width = "100%") |>
ax_colors(colors = viridis(4, begin = 0.2, end = 0.8)) |>
ax_xaxis(labels = list(style = list(fontSize = "14px"))) |>
ax_yaxis(title = list(text = "Percent", style = list(fontSize = "16px", fontWeight = 400)),
labels = list(formatter = format_num(".0f"), style = list(fontSize = "14px"))) |>
ax_dataLabels(enabled = TRUE,
formatter = format_num(".1f"),
offsetY = -18,
style = list(fontWeight = 400, colors = rep("#000", 12))) |>
ax_tooltip(y = list(formatter = format_num(".1f", suffix = "%"))) |>
ax_legend(position = "top") |>
ax_plotOptions(bar = bar_opts(columnWidth = "85%",
dataLabels = list(position = "top")))
}
```
```{r}
DEMO_L <- read_xpt("https://wwwn.cdc.gov/Nchs/Data/Nhanes/Public/2021/DataFiles/DEMO_L.xpt") |>
select(SEQN, RIAGENDR, RIDAGEYR, SDMVSTRA, SDMVPSU) |>
mutate(
RIAGENDR = case_match(RIAGENDR,
1 ~ "Men",
2 ~ "Women"),
RIAGENDR = factor(RIAGENDR),
RIDAGEYR = case_match(RIDAGEYR,
20:39 ~ "20 to 39",
40:59 ~ "40 to 59",
60:80 ~ "60 and older"),
RIDAGEYR = factor(RIDAGEYR))
TCHOL_L <- read_xpt("https://wwwn.cdc.gov/Nchs/Data/Nhanes/Public/2021/DataFiles/TCHOL_L.XPT") |>
select(SEQN, WTPH2YR, LBXTC) |>
mutate(high_tc = if_else(LBXTC >= 240, TRUE, FALSE))
HDL_L <- read_xpt("https://wwwn.cdc.gov/Nchs/Data/Nhanes/Public/2021/DataFiles/HDL_L.XPT") |>
select(SEQN, LBDHDD) |>
mutate(low_hdl = if_else(LBDHDD < 40, TRUE, FALSE))
One <- DEMO_L |>
left_join(TCHOL_L, by = "SEQN") |>
left_join(HDL_L, by = "SEQN")
NHANES <- One |>
filter(!is.na(RIDAGEYR), !is.na(high_tc)) |>
as_survey_design(id = SDMVPSU, strata = SDMVSTRA, nest = TRUE, weight = WTPH2YR)
```
::: {.panel-tabset}
### Figure 1
<h3>Prevalence of high total cholesterol in adults age 20 and older, by sex and age group:
United States, August 2021-August 2023</h3>
```{r}
#| output: asis
NHANES |>
group_by(interact(by_var = RIAGENDR, grp_var = RIDAGEYR)) |>
cascade(
p = survey_mean(high_tc, proportion = TRUE) * 100,
.fill = "Total") |>
mutate(
by_var = factor(by_var, levels = c("Total", "Men", "Women")),
grp_var = if_else(grp_var == "Total", "20 and older", grp_var),
grp_var = factor(grp_var, levels = c("20 and older", "20 to 39", "40 to 59", "60 and older"))) |>
arrange(by_var, grp_var) |>
create_figure()
```
<details>
<summary>
Data tables for Figure 1
</summary>
```{r}
#| output: asis
set_survey(NHANES)
tab("high_tc")
tab_subset("high_tc", "RIDAGEYR")
men <- survey_subset(NHANES, RIAGENDR == "Men", "Men")
set_survey(men)
tab("high_tc")
tab_subset("high_tc", "RIDAGEYR")
women <- survey_subset(NHANES, RIAGENDR == "Women", "Women")
set_survey(women)
tab("high_tc")
tab_subset("high_tc", "RIDAGEYR")
```
</details>
### Figure 2
<h3>Prevalence of low high-density lipoprotein cholesterol in adults age 20 and older,
by sex and age group: United States, August 2021-August 2023</h3>
```{r}
#| output: asis
NHANES |>
group_by(interact(by_var = RIAGENDR, grp_var = RIDAGEYR)) |>
cascade(
p = survey_mean(low_hdl, proportion = TRUE) * 100,
.fill = "Total") |>
mutate(
by_var = factor(by_var, levels = c("Total", "Men", "Women")),
grp_var = if_else(grp_var == "Total", "20 and older", grp_var),
grp_var = factor(grp_var, levels = c("20 and older", "20 to 39", "40 to 59", "60 and older"))) |>
arrange(by_var, grp_var) |>
create_figure()
```
<details>
<summary>
Data tables for Figure 2
</summary>
```{r}
#| output: asis
set_survey(NHANES)
tab("low_hdl")
tab_subset("low_hdl", "RIDAGEYR")
men <- survey_subset(NHANES, RIAGENDR == "Men", "Men")
set_survey(men)
tab("low_hdl")
tab_subset("low_hdl", "RIDAGEYR")
women <- survey_subset(NHANES, RIAGENDR == "Women", "Women")
set_survey(women)
tab("low_hdl")
tab_subset("low_hdl", "RIDAGEYR")
```
</details>
:::