# ============================================================ # Tidyverse Lab Exercises — TDEE Calculator *** SOLUTION KEY *** # Total Daily Energy Expenditure with Real NHANES Data # Yen-Yi Ho Lab — STAT, University of South Carolina # ============================================================ # # Dataset: NHANES (National Health and Nutrition Examination Survey) # Package: NHANES install.packages("NHANES") # # Mifflin-St Jeor BMR equation: # Male BMR = 10×W(kg) + 6.25×H(cm) − 5×A(yr) + 5 # Female BMR = 10×W(kg) + 6.25×H(cm) − 5×A(yr) − 161 # TDEE = BMR × Activity Factor (AF) # # Activity Factors: # Sedentary (no exercise) AF = 1.200 # Lightly Active (1–2 days/wk) AF = 1.375 # Moderately Active (3–4 days/wk) AF = 1.550 # Very Active (5–6 days/wk) AF = 1.725 # Extra Active (7 days/wk) AF = 1.900 # ============================================================ # SETUP ------------------------------------------------------- library(tidyverse) library(NHANES) # install.packages("NHANES") if needed data(NHANES) glimpse(NHANES) # ============================================================ # EXERCISE 1 — Clean the Data # ============================================================ nhanes_clean <- NHANES |> select(ID, Gender, Age, Weight, Height, PhysActive, PhysActiveDays) |> filter(Age >= 18) |> drop_na(Gender, Age, Weight, Height, PhysActive, PhysActiveDays) |> distinct(ID, .keep_all = TRUE) nrow(nhanes_clean) # typically ~2,600 unique adults # ============================================================ # EXERCISE 2 — Compute BMR # ============================================================ nhanes_bmr <- nhanes_clean |> mutate( bmr = case_when( Gender == "male" ~ 10 * Weight + 6.25 * Height - 5 * Age + 5, Gender == "female" ~ 10 * Weight + 6.25 * Height - 5 * Age - 161 ) ) nhanes_bmr |> group_by(Gender) |> summarize(mean_bmr = mean(bmr) |> round(1)) # Expected: males ~1750–1800, females ~1450–1500 kcal/day # ============================================================ # EXERCISE 3 — Assign Activity Factor # ============================================================ nhanes_af <- nhanes_bmr |> mutate( activity_level = case_when( PhysActive == "No" ~ "Sedentary", PhysActiveDays %in% 1:2 ~ "Lightly Active", PhysActiveDays %in% 3:4 ~ "Moderately Active", PhysActiveDays %in% 5:6 ~ "Very Active", PhysActiveDays == 7 ~ "Extra Active" ), af = case_when( PhysActive == "No" ~ 1.200, PhysActiveDays %in% 1:2 ~ 1.375, PhysActiveDays %in% 3:4 ~ 1.550, PhysActiveDays %in% 5:6 ~ 1.725, PhysActiveDays == 7 ~ 1.900 ) ) nhanes_af |> count(activity_level, sort = TRUE) # ============================================================ # EXERCISE 4 — Compute TDEE # ============================================================ nhanes_tdee <- nhanes_af |> mutate( tdee = bmr * af ) |> mutate(across(c(bmr, tdee), round, 1)) nhanes_tdee |> select(Gender, Age, Weight, Height, activity_level, bmr, af, tdee) |> slice_sample(n = 8) # ============================================================ # EXERCISE 5 — BMI & Weight Status # ============================================================ nhanes_full <- nhanes_tdee |> mutate( bmi = Weight / (Height / 100)^2, weight_status = case_when( bmi < 18.5 ~ "Underweight", bmi < 25.0 ~ "Normal", bmi < 30.0 ~ "Overweight", TRUE ~ "Obese" # catch-all for >= 30 ) ) |> mutate(bmi = round(bmi, 1)) nhanes_full |> count(weight_status) # Discussion: Overweight and Obese together typically exceed 60% in NHANES # ============================================================ # EXERCISE 6 — TDEE Summary by Sex & Activity Level # ============================================================ nhanes_full |> group_by(Gender, activity_level) |> summarize( n = n(), mean_tdee = round(mean(tdee), 1), sd_tdee = round(sd(tdee), 1), min_tdee = min(tdee), max_tdee = max(tdee), .groups = "drop" ) |> arrange(Gender, desc(mean_tdee)) # Discussion: Extra Active males can exceed 3,500 kcal/day on average. # The gap between Sedentary and Extra Active is ~900–1,100 kcal. # ============================================================ # EXERCISE 7 — Extreme Cases # ============================================================ # Part A nhanes_full |> slice_max(tdee, n = 3) |> select(Gender, Age, Weight, Height, activity_level, bmi, weight_status, tdee) nhanes_full |> slice_min(tdee, n = 3) |> select(Gender, Age, Weight, Height, activity_level, bmi, weight_status, tdee) # Part B nhanes_full |> slice_max(tdee, n = 3) |> pull(weight_status) |> unique() # High TDEE individuals tend to be heavier (Overweight/Obese) # because weight drives both BMR and body size. # ============================================================ # EXERCISE 8 — Grand Pipeline (single chain, no intermediate objects) # ============================================================ NHANES |> select(ID, Gender, Age, Weight, Height, PhysActive, PhysActiveDays) |> filter(Age >= 18) |> drop_na(Gender, Age, Weight, Height, PhysActive, PhysActiveDays) |> distinct(ID, .keep_all = TRUE) |> mutate( bmr = case_when( Gender == "male" ~ 10 * Weight + 6.25 * Height - 5 * Age + 5, Gender == "female" ~ 10 * Weight + 6.25 * Height - 5 * Age - 161 ), activity_level = case_when( PhysActive == "No" ~ "Sedentary", PhysActiveDays %in% 1:2 ~ "Lightly Active", PhysActiveDays %in% 3:4 ~ "Moderately Active", PhysActiveDays %in% 5:6 ~ "Very Active", PhysActiveDays == 7 ~ "Extra Active" ), af = case_when( PhysActive == "No" ~ 1.200, PhysActiveDays %in% 1:2 ~ 1.375, PhysActiveDays %in% 3:4 ~ 1.550, PhysActiveDays %in% 5:6 ~ 1.725, PhysActiveDays == 7 ~ 1.900 ), tdee = bmr * af, bmi = Weight / (Height / 100)^2, weight_status = case_when( bmi < 18.5 ~ "Underweight", between(bmi, 18.5, 24.9) ~ "Normal", between(bmi, 25, 29.9) ~ "Overweight", bmi >= 30 ~ "Obese" ) ) |> mutate(across(c(bmr, tdee, bmi), round, 1)) |> group_by(Gender, weight_status, activity_level) |> summarize( n = n(), mean_tdee = round(mean(tdee), 1), median_tdee = median(tdee), .groups = "drop" ) |> filter(n >= 10) |> arrange(Gender, weight_status, desc(mean_tdee)) # ============================================================ # VISUALISATION — ggplot2 Insights [Bonus — SOLUTIONS] # ============================================================ # Ordered factor helpers activity_order <- c("Sedentary", "Lightly Active", "Moderately Active", "Very Active", "Extra Active") weight_order <- c("Underweight", "Normal", "Overweight", "Obese") sex_colours <- c("male" = "#276DC3", "female" = "#C45C5C") # ---------------------------------------------------------- # PLOT 1 — TDEE Distribution by Activity Level (Box plot) # ---------------------------------------------------------- nhanes_full |> mutate(activity_level = factor(activity_level, levels = activity_order)) |> ggplot(aes(x = activity_level, y = tdee, fill = Gender)) + geom_boxplot(alpha = 0.7, outlier.size = 0.5) + scale_fill_manual(values = sex_colours) + labs( title = "TDEE Distribution by Activity Level and Sex", x = "Activity Level", y = "TDEE (kcal / day)", fill = "Sex" ) + theme_minimal() + theme(axis.text.x = element_text(angle = 30, hjust = 1)) # Insight: Moving from Sedentary to Extra Active adds ~900–1,100 kcal/day. # Males consistently show higher median TDEE at every activity level. # ---------------------------------------------------------- # PLOT 2 — Weight Status Count by Sex (Dodged Bar Chart) # ---------------------------------------------------------- nhanes_full |> count(Gender, weight_status) |> mutate(weight_status = factor(weight_status, levels = weight_order)) |> ggplot(aes(x = weight_status, y = n, fill = Gender)) + geom_col(position = "dodge", alpha = 0.85) + geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.3, size = 3) + scale_fill_manual(values = sex_colours) + labs( title = "Weight Status Distribution by Sex", x = "Weight Status", y = "Count", fill = "Sex" ) + theme_minimal() # Insight: Overweight is the single largest category in NHANES adults. # Obese and Overweight together exceed Normal weight for both sexes, # reflecting the US obesity epidemic captured in this survey. # ---------------------------------------------------------- # PLOT 3 — Mean TDEE Heatmap (Weight Status × Activity Level) # ---------------------------------------------------------- nhanes_full |> group_by(weight_status, activity_level) |> summarize(mean_tdee = round(mean(tdee), 0), .groups = "drop") |> mutate( weight_status = factor(weight_status, levels = weight_order), activity_level = factor(activity_level, levels = activity_order) ) |> ggplot(aes(x = activity_level, y = weight_status, fill = mean_tdee)) + geom_tile(colour = "white", linewidth = 0.5) + geom_text(aes(label = mean_tdee), colour = "white", fontface = "bold", size = 3.5) + scale_fill_gradient(low = "#aecde8", high = "#0d3b6e") + labs( title = "Mean TDEE (kcal/day) by Weight Status & Activity Level", x = "Activity Level", y = "Weight Status", fill = "Mean TDEE" ) + theme_minimal() + theme(axis.text.x = element_text(angle = 30, hjust = 1)) # Insight: The darkest cell (highest TDEE) is Obese × Extra Active — # a heavy person who exercises daily burns the most calories. # The lightest cell is Underweight × Sedentary — the lowest demand. # Activity level creates larger between-column variation than weight # status creates between-row variation, suggesting exercise is the # dominant lever for increasing TDEE. # ============================================================ # END OF LAB — SOLUTION KEY # ============================================================