diff --git a/_projects/2025/100572191/100572191.Rmd b/_projects/2025/100572191/100572191.Rmd new file mode 100644 index 00000000..102813cf --- /dev/null +++ b/_projects/2025/100572191/100572191.Rmd @@ -0,0 +1,684 @@ +--- +title: "Evidence-Based Guide to Longevity" +description: | + This project analyzes factors that extend or shorten human lifespan, ranked by scientific evidence. The visualization ranks factors that extend or shorten human lifespan based on the strength of scientific evidence. + +categories: "2025" +author: Gaia Leuzzi +date: "`r Sys.Date()`" +output: + distill::distill_article: + self_contained: false + toc: true +--- + +## Introduction + +This project provides an insightful look into the factors that extend or shorten human lifespan, ranked by the strength of scientific evidence. Recreated from an original Information is Beautiful graphic, the data synthesizes findings from academic studies (e.g., Khaw KT, 2008) and major reports (BBC, NYT) alongside landmark research like The Okinawa Program, which investigates the habits of the world's longest-lived populations. By integrating clinical data with real-world longevity studies, the visualization offers a comparative view that separates well-supported health advice from less substantiated claims. + +{.external width=100%} + +## Limitations of the original graph + +One of the most notable strengths of the graph is its high aesthetic appeal, which immediately engages the viewer. It effectively communicates its objective, making an extremely interesting and complex topic—human longevity—accessible and intriguing to a broad audience. Overall, the visualization succeeds in sparking curiosity and encouraging readers to explore the factors that influence lifespan. + +While the graph is visually striking, it presents several limitations regarding data precision. The use of irregular, polygonal bars can be misleading, as it is not clear which part of the shape represents the effective value. Additionally, there is a discrepancy between the legend and the plot: the legend defines discrete color categories, yet the graph applies a continuous gradient, making exact values hard to interpret. Furthermore, while the factors are grouped by the strength of scientific evidence, they are not ordered by impact within those groups, which makes it difficult to compare them directly. Lastly, the icons used to distinguish between men and women are not immediately intuitive, potentially delaying the user's understanding of the demographic breakdowns. + +## Graph Replication + +### Setup and libraries + +We begin by setting up the R environment and loading the essential packages. We use "ggplot2" and "dplyr" for the core data manipulation and visualization tasks. To achieve the complex, non-standard layout of the original infographic, we rely on "cowplot" and "grid", which allow us to manipulate graphic objects directly. + +Since the visualization requires external PNG images for gender icons, we include "magick" for image processing. Lastly, we import the "Nunito" font family using showtext to replicate the specific typography of the original design. + +```{r setup} +knitr::opts_chunk$set(out.width="100%", fig.align="center", fig.showtext=TRUE) + +library(ggplot2) +library(forcats) +library(dplyr) +library(showtext) +library(cowplot) +library(magick) +library(grid) + +font_add_google("Nunito Sans", "nunito", regular.wt = 200) +font_add_google("Nunito", "nunito_title", regular.wt = 500) +font_add_google("Nunito", "nunito_subtitle", regular.wt = 200) +showtext_auto() + +my_data <- read.csv("KIB_longevity data.csv") +``` + + +### Data preparation + +We clean the dataset and prepare specific variables required for the custom geometry. First, we ensure the Years column is numeric and append a specific row for the "Ultimate Recipe," a humorous outlier that requires manual insertion. We also override the Science_strength values for specific interventions; this is a crucial step to ensure they map correctly to our custom color palette later, as the raw data does not perfectly align with the visual groups we want to create. + +To control the exact vertical ordering of the plot, we define levels_vec, a vector containing the interventions in the desired top-to-bottom order. We then calculate bar_offset and id_adj. These variables are mathematically derived to manage the vertical spacing between bars, allowing us to introduce gaps (e.g., separating "Keep smoking" from the rest) and shift specific bars like the "Ultimate Recipe" to avoid overlap. + +```{r data} +my_data_filtered <- my_data |> + mutate(Years = as.numeric(Years)) |> + add_row( + Intervention = "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat", + Years = 23, + Science_strength = 4 + ) + +my_data_filtered <- my_data_filtered |> + mutate( + Science_strength = case_when( + Intervention == "Be polygamous, maybe" ~ 1.2, + Intervention == "Go to church regularly" ~ 1.4, + Intervention == "Sit down" ~ 1.6, + Intervention == "More Pets" ~ 1.8, + Intervention == "Eat red meat" ~ 1.9, + Intervention == "Be rich" ~ 2.25, + Intervention == "Be a woman" ~ 2.4, + Intervention == "Suffer severe mental illness" ~ 2.5, + Intervention == "Become obese" ~ 2.6, + Intervention == "Keep smoking" ~ 2.7, + Intervention == "Quit" ~ 2.7, + TRUE ~ as.numeric(Science_strength) + ) + ) + +levels_vec <- c( + "Sleep too much", "Be optimistic", "Get promoted", "Live in a city", "Live in the country", + "Eat less food", "Have a long-lived maternal grandfather", "Hang out with women - a lot!", + "Be conscientious ", "Have more orgasms", "With close friends", "Be polygamous, maybe", + "Go to church regularly", "Sit down", "More Pets", "Eat red meat", "Avoid cancer", + "Avoid heart disease", "Be alcoholic", "Get health checks ", "Get married!", "Be rich", + "Be a woman", "Suffer severe mental illness", "Become obese", "Keep smoking", "Quit", + "Eat healthy", "Live healthily", "Have a long-lived sibling", "Exercise more", + "Live at high altitude", + "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat" +) + +my_data_filtered <- my_data_filtered |> + mutate( + Intervention = factor(Intervention, levels = rev(levels_vec)), + id = as.integer(Intervention), + Years_Capped = if_else(Intervention == "Suffer severe mental illness", -12, Years), + bar_offset = if_else( + Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat", + id - 0.8, + id + 0.2 + ) + ) + +id_quit <- my_data_filtered$id[my_data_filtered$Intervention == "Keep smoking"] + +my_data_filtered <- my_data_filtered |> + mutate( + id_adj = case_when( + Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat" ~ id - 1.5, + id >= id_quit ~ id - 1, + TRUE ~ id + ), + bar_offset = id_adj + ) +``` + +### Visual geometry construction + +This is the most technically complex section where we manually construct the polygon shapes instead of using standard bars. We use rowwise() to calculate coordinates for every single intervention. The logic defines horiz (the rectangular part of the bar) and diag_end (the angled tip), distinguishing between positive and negative years. + +For specific entries like "Have a long-lived maternal grandfather," we implement a loop that generates multiple small polygons with decreasing alpha values. This creates a custom "fading" visual effect that standard ggplot functions cannot produce. Finally, we initialize the ggplot object, adding geom_polygon for the bars and geom_text for the labels, ensuring the "Ultimate Recipe" gets unique styling. + +```{r plot, fig.width=7, fig.height=6.5, fig.showtext=TRUE} +poly_df <- my_data_filtered |> + rowwise() |> + mutate( + horiz = if_else(Years_Capped > 0, pmax(0, Years_Capped - 0.80), Years_Capped + 0.80), + diag_end = Years_Capped, + top = bar_offset + 0.45, + bottom = bar_offset - 0.45, + + base_fill = if_else( + Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat", + "#6b1786", + scales::col_numeric( + palette = c("#E5BB39", "#ea9038", "#8ECB9A"), + domain = range(c(1, 3)) + )(Science_strength) + ), + + poly = list({ + if (Intervention %in% c("Have a long-lived maternal grandfather", "Have a long-lived sibling")) { + n_fade <- 90 + split_ratio <- 0.35 + + x_split_top <- horiz * split_ratio + x_split_bot <- diag_end * split_ratio + + solid_part <- data.frame( + x = c(0, x_split_top, x_split_bot, 0), + y = c(top, top, bottom, bottom), + poly_id = paste0(id_adj, "_solid"), + fill_val = base_fill, + alpha_val = 1 + ) + + seq_steps <- seq(split_ratio, 1, length.out = n_fade + 1) + x_top_edge <- seq_steps * horiz + x_bot_edge <- seq_steps * diag_end + alphas <- seq(1, 0.05, length.out = n_fade) + + xs <- c() + ys <- c() + alpha_vec <- c() + ids <- c() + + for (i in 1:n_fade) { + xs <- c(xs, x_top_edge[i], x_top_edge[i+1], x_bot_edge[i+1], x_bot_edge[i]) + ys <- c(ys, top, top, bottom, bottom) + alpha_vec <- c(alpha_vec, rep(alphas[i], 4)) + ids <- c(ids, rep(paste0(id_adj, "_fade_", i), 4)) + } + + fade_part <- data.frame( + x = xs, y = ys, poly_id = ids, fill_val = base_fill, alpha_val = alpha_vec + ) + + bind_rows(solid_part, fade_part) + + } else { + data.frame( + x = c(0, horiz, diag_end, 0), + y = c(top, top, bottom, bottom), + poly_id = as.character(id_adj), + fill_val = base_fill, + alpha_val = 1 + ) + } + }) + ) |> + pull(poly) |> + bind_rows() + + +longevity_dt <- ggplot() + + geom_segment( + data = data.frame(x_val = seq(-10, 20, by = 5)), + aes( + x = x_val, xend = x_val, + y = max(poly_df$y) + 1, + yend = min(poly_df$y) - 1 + ), + color = "#FFB777", + linewidth = 0.2, + alpha = 0.8 + ) + + geom_polygon( + data = poly_df, + aes(x = x, y = y, group = poly_id, fill = fill_val, alpha = alpha_val), + color = NA + ) + + scale_alpha_identity() + + geom_segment( + data = data.frame(x_val = 0), + aes( + x = x_val, xend = x_val, + y = max(poly_df$y) + 1, + yend = min(poly_df$y) - 1 + ), + color = "gray6", + linewidth = 0.2 + ) + + geom_text( + data = my_data_filtered |> + filter(Intervention != "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"), + aes( + x = if_else(Years_Capped < 0, -0.2, 0.2), + y = bar_offset, + label = Intervention, + hjust = if_else(Years_Capped < 0, 1, 0) + ), + family = "nunito", + size = 2.1, + color = "black" + ) + + geom_text( + data = my_data_filtered |> + filter(Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"), + aes( + x = 0.2, + y = bar_offset, + label = Intervention, + hjust = 0 + ), + family = "nunito_bold", + size = 2.1, + color = "white", + fontface = "plain" + ) + + scale_color_manual(values = c("TRUE" = "white", "FALSE" = "black"), guide = "none") + + annotate( + "text", + x = -0.5, + y = my_data_filtered$bar_offset[ + my_data_filtered$Intervention == + "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat" + ], + label = "ULTIMATE RECIPE", + color = "#6b1786", + family = "nunito", + fontface = "bold", + hjust = 1, + size = 2.4 + ) + + scale_fill_identity() + + scale_y_continuous(NULL, breaks = NULL, labels = NULL) + + theme( + text = element_text(family = "nunito"), + legend.position = "none" + ) + +longevity_dt +``` + +### Axis and scale design + +We customize the X-axis to replicate the ruler-like aesthetic of the original graphic. We use scale_x_continuous with dup_axis() to display the years on both the top and bottom scales. To add precise tick marks that match the design, we overlay geom_point and geom_segment elements manually rather than relying on default ggplot ticks. + +Crucially, we set coord_cartesian(clip = "off"), which allows text labels and annotations to extend beyond the plotting area boundaries without being cut off. + +```{r axis, fig.width=7, fig.height=6.5, fig.showtext=TRUE} +longevity_dt <- longevity_dt + + scale_x_continuous( + limits = c(-25, 23), + breaks = seq(-10, 20, by = 5), + minor_breaks = seq(-12, 21, by = 1), + labels = function(x) ifelse(x == 0, expression(bold("YEARS")), as.character(x)), + sec.axis = dup_axis() + ) + + geom_point( + data = data.frame(x_val = seq(-10, 20, by = 1)) |> + dplyr::filter(x_val %% 5 != 0), + aes(x = x_val, y = max(poly_df$y) + 1.6), + shape = 16, + size = 0.1, + color = "black", + inherit.aes = FALSE + ) + + coord_cartesian(clip = "off") + +tick_data <- data.frame(x_val = seq(-10, 20, by = 5)) +longevity_dt <- longevity_dt + + geom_segment( + data = tick_data, + aes(x = x_val, xend = x_val, + y = max(poly_df$y) +1.45, + yend = max(poly_df$y) + 1.75), + color = "black", + linewidth = 0.1, + inherit.aes = FALSE + ) + +longevity_dt +``` + +### Theme and typographic styling + +We apply a minimalist theme to strictly control the visual output. We explicitly set the panel and plot backgrounds to white using element_rect. We remove all standard background grids, borders, and default axis titles using element_blank() to leave only the necessary data ink. + +Furthermore, we fine-tune the plot.margin and reduce the size of the axis text to ensure the layout remains compact and legible. + +```{r theme, fig.width=7, fig.height=6.5, fig.showtext=TRUE} +longevity_dt <- longevity_dt + + theme( + panel.background = element_rect(fill = "#FFFFFF", color = NA), + plot.background = element_rect(fill = "#FFFFFF", color = NA), + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + axis.title.x.top = element_blank(), + axis.title.x.bottom = element_blank(), + axis.title.y = element_blank(), + plot.margin = unit(c(0.2, 0.5, 0.1, 0.5), "cm"), + axis.text.y = element_blank(), + axis.ticks.x.top = element_blank(), + axis.ticks.x.bottom = element_blank(), + legend.position = "none", + axis.text.x = element_text(size = 5, margin = margin(t = -8)), + axis.text.x.top = element_text(size = 5, margin = margin(b = -8)) + ) + +longevity_dt +``` + +### Gender-specific icons + +We process the external PNG images for the gender icons here. Using magick, we read the files and scale the female icon to exactly match the dimensions of the male icon. Moreover, we use rasterGrob to convert these images into graphical objects compatible with the grid system. + +Finally, we filter the dataset to identify exactly which interventions require specific gender icons and calculate their coordinates to prepare them for placement. + +```{r icons, fig.width=7, fig.height=6.5, fig.showtext=TRUE} +male_icon <- image_read("man.png") +female_icon <- image_read("women.png") + +female_icon <- image_scale(female_icon, paste0(image_info(male_icon)$width, "x", image_info(male_icon)$height, "!")) + +male_grob <- rasterGrob(male_icon, interpolate = TRUE) +female_grob <- rasterGrob(female_icon, interpolate = TRUE) + +gender_icons <- my_data_filtered |> + filter(Intervention %in% c( + "Be optimistic", "Get promoted", "Have a long-lived maternal grandfather", + "Hang out with women - a lot!", "Have more orgasms", + "Be polygamous, maybe", "Be a woman" + )) |> + mutate( + icon_type = case_when( + Intervention %in% c("Get promoted", "Have a long-lived maternal grandfather", + "Hang out with women - a lot!", "Have more orgasms", "Be polygamous, maybe") ~ "male", + Intervention %in% c("Be optimistic", "Be a woman") ~ "female", + TRUE ~ "male" + ), + x_pos = -0.5, + y_pos = bar_offset + ) +``` + + +### Custom legend construction + +Because the standard ggplot legend cannot accommodate the specific layout of colored blocks and embedded images we need, we construct a custom legend from scratch using ggplot. We manually draw rectangles (annotate("rect")) for the "Strength of Science" categories to match the fill colors used in the main plot. + +We place the gender icon grobs directly into this legend object using annotation_custom to ensure the legend is fully self-contained. + +```{r legend, fig.width=7, fig.height=6.5, fig.showtext=TRUE} +legend_plot <- ggplot() + + annotate("rect", xmin = 11, xmax = 13.5, ymin = 39.8, ymax = 40.6, fill = "#E5BB39", color = NA) + + annotate("rect", xmin = 13.5, xmax = 16, ymin = 39.8, ymax = 40.6, fill = "#EA9038", color = NA) + + annotate("polygon", x = c(16, 18.2, 18.5, 16), y = c(40.6, 40.6, 39.8, 39.8), fill = "#8ECB9A", color = NA) + + annotate("text", x = 12.25, y = 40.2, label = "Suggestive", family = "nunito", size = 1.8, color = "#333333") + + annotate("text", x = 14.75, y = 40.2, label = "Good", family = "nunito", size = 1.8, color = "#333333") + + annotate("text", x = 17.2, y = 40.2, label = "Strong", family = "nunito", size = 1.8, color = "#333333") + + annotate("text", x = 18.5, y = 40.9, label = "STRENGTH OF SCIENCE", family = "nunito_bold", fontface = "bold", size = 2.5, color = "#333333", hjust = 1) + + annotate("text", x = 9.7, y = 40.2, label = "male / female specific", family = "nunito", size = 1.8, color = "#666666", hjust = 1) + + coord_cartesian(xlim = c(5, 20), ylim = c(39, 42)) + + theme_void() + +legend_plot <- legend_plot + + annotation_custom( + grob = female_grob, + xmin = 9.90, xmax = 10.55, + ymin = 39.55, ymax = 40.8 + ) + + annotation_custom( + grob = male_grob, + xmin = 10.4, xmax = 11.0, + ymin = 39.6, ymax = 40.8 + ) +``` + +### Annotations and explanatory notes + +We finalize the main plot by looping through the gender_icons dataframe and placing the grobs at the calculated coordinates. We then calculate dynamic positions for the explanatory text notes (notes_df); we use conditional logic to decide whether a note should be forced to the left or right to avoid overlapping with the bars. + +Additionally, we construct a specific, multi-segment annotation for "Mental Illness" to handle its unique positioning. + +```{r annotations, fig.width=7, fig.height=6.5, fig.showtext=TRUE} +icon_size <- 0.7 + +male_positions <- gender_icons |> filter(icon_type == "male") +female_positions <- gender_icons |> filter(icon_type == "female") +both_positions <- gender_icons |> filter(icon_type == "both") + +longevity_dt <- longevity_dt + + {if(nrow(male_positions) > 0) { + lapply(1:nrow(male_positions), function(i) { + annotation_custom( + grob = male_grob, + xmin = male_positions$x_pos[i] - icon_size/2, + xmax = male_positions$x_pos[i] + icon_size/2, + ymin = male_positions$y_pos[i] - icon_size/2, + ymax = male_positions$y_pos[i] + icon_size/2 + ) + }) + }} + + {if(nrow(female_positions) > 0) { + lapply(1:nrow(female_positions), function(i) { + annotation_custom( + grob = female_grob, + xmin = female_positions$x_pos[i] - icon_size/2, + xmax = female_positions$x_pos[i] + icon_size/2, + ymin = female_positions$y_pos[i] - icon_size/2, + ymax = female_positions$y_pos[i] + icon_size/2 + ) + }) + }} + +force_left_list <- c( + "Hang out with women - a lot!", "Be polygamous, maybe", "Sit down", "Eat healthy", + "Have a long-lived sibling", "Keep smoking", + "Live at a high altitude", "Be conscientious " +) + +right_exceptions <- c("Get promoted", "Have more orgasms", "Get health checks ", "Exercise more") + +notes_df <- my_data_filtered |> + dplyr::filter(!is.na(Note) & Note != "" & Intervention != "Suffer severe mental illness") |> + dplyr::mutate( + Note_Wrapped = stringr::str_wrap(Note, width = 30), + x_note_pos = dplyr::case_when( + Intervention == "Suffer severe mental illness" ~ -14, + Intervention %in% force_left_list ~ -5.5, + Intervention %in% right_exceptions ~ 10, + TRUE ~ 15 + ), + text_hjust = dplyr::if_else(x_note_pos < 0, 1, 0), + x_line_start = dplyr::case_when( + Intervention == "Be optimistic" ~ 2.7, + Intervention == "Get health checks " ~ 3.5, + Intervention == "Exercise more" ~ 2.9, + Intervention == "Hang out with women - a lot!" ~ -1.0, + Intervention == "Be polygamous, maybe" ~ -1.0, + sign(x_note_pos) == sign(Years_Capped) ~ Years_Capped, + TRUE ~ 0 + ), + y_pos = bar_offset, + note_vjust = dplyr::if_else( + Intervention == "Hang out with women - a lot!", + 0.3, + 0.8 + ) + ) + +mental_note_df <- my_data_filtered |> + dplyr::filter(Intervention == "Suffer severe mental illness") |> + dplyr::mutate( + y_start = bar_offset, + y_end = bar_offset + 1.2, + x_pos = -5.5, + x_midpoint = -9, + Note_Wrapped = "25 years shorter\nlife expectancy" + ) + +longevity_dt <- longevity_dt + + geom_segment( + data = notes_df, + aes(x = x_line_start, xend = x_note_pos, y = y_pos, yend = y_pos), + linetype = "19", color = "black", linewidth = 0.1, inherit.aes = FALSE, lineend="round" + ) + + geom_text( + data = notes_df, + aes( + x = x_note_pos + dplyr::if_else(x_note_pos > 0, 0.2, -0.2), + y = y_pos, + label = Note_Wrapped, + hjust = text_hjust, + vjust = note_vjust + ), + size = 1.3, color = "#666666", family = "sans", lineheight = 0.8, inherit.aes = FALSE + ) + + geom_segment( + data = mental_note_df, + aes(x = x_midpoint, xend = x_midpoint, y = y_start, yend = y_end), + linetype = "19", color = "black", linewidth = 0.1, inherit.aes = FALSE, lineend="round" + ) + + geom_segment( + data = mental_note_df, + aes(x = x_midpoint, xend = -8.7, y = y_end, yend = y_end), + linetype = "19", color = "black", linewidth = 0.1, inherit.aes = FALSE, lineend="round" + ) + + geom_text( + data = mental_note_df, + aes(x = x_pos - 0.2, y = y_end, label = Note_Wrapped), + hjust = 1, vjust = 0.5, size = 1.3, color = "#666666", family = "sans", lineheight = 0.8, inherit.aes = FALSE + ) + +longevity_dt +``` + +### Final plot composition + +We use ggdraw from the cowplot package to combine the separate components. We treat the main plot and the legend as separate graphical objects, arranging them on a single canvas and adding the main title and subtitle text layers. + +```{r final, fig.width=7, fig.height=6.5, fig.showtext=TRUE, preview=TRUE} +final_plot <- ggdraw() + + draw_plot(longevity_dt, x = 0, y = 0, width = 1, height = 0.88) + + draw_plot(legend_plot, x = 0.58, y = 0.88, width = 0.38, height = 0.11) + + draw_label( + "Live Long", + x = 0.32, y = 0.96, + hjust = 0, vjust = 1, + fontfamily = "nunito_title", + size = 20, + color = "#333333" +) + + draw_label( + "What really extends lifespan?", + x = 0.32, y = 0.91, + hjust = 0, vjust = 1, + fontfamily = "nunito_subtitle", + size = 10, + color = "#333333" +) + +final_plot +``` + +We acknowledge that some details in our replica differ from the original graphic. First, regarding typography, we use the "Nunito" font family; since the original design uses a paid commercial font, we selected this as the closest open-source alternative. + +Furthermore, we notice that the footer text regarding the "Ultimate Recipe" is not fully legible in our final output. Although the structure is accurate, the positioning of certain text annotations and lines could be more precise compared to the original's manual layout. + +## Graph Improvement + +### Data Preparation + +In this first step, we prepare again the data for the improved visualization by filtering out the decorative elements and focusing on valid scientific strengths. We create a new factor variable, Strength_Label, to facilitate faceting, and we rescale the years for better visual impact. We also reorder the interventions based on the number of years gained or lost to ensure the bar chart is sorted logically. + +```{r data-preparation, fig.width=7.5, fig.height=6.5, fig.showtext=TRUE} +data_prep <- my_data |> + filter(Science_strength %in% c(1, 2, 3)) |> + mutate( + Intervention = case_when( + Intervention == "Quit" ~ "Quit smoking", + Intervention == "Have a long-lived maternal grandfather" ~ "Have a long-lived maternal grandad", + TRUE ~ Intervention + ), + Years = as.numeric(Years), + Strength_Label = factor(Science_strength, + levels = c(1, 2, 3), + labels = c("Weak scientific evidence", "Moderate scientific evidence", "Strong scientific evidence")) + ) |> + arrange(Science_strength, Years) |> + mutate( + Years_Capped = if_else(Intervention == "Suffer severe mental illness", -12, Years), + Years_Display = Years_Capped * 5, + Intervention = reorder(Intervention, -Years) + ) +``` + +### Plot Creation Function + +To resolve the ambiguity caused by the original irregular polygons, we switch to a standard column chart structure, which ensures the effective values are immediately readable. + +Simultaneously, we employ facet_wrap(~ Strength_Label) to segregate the interventions by evidence level; this approach rectifies the previous comparison difficulties, enabling a clear ranking of factors that share equivalent scientific backing. Regarding the color scheme, we implement a continuous gradient via scale_fill_gradientn. Unlike the confusing original palette, this transition from red to green explicitly highlights the contrast between life-shortening and life-extending habits. + +Additionally, we discard the non-essential gender icons to reduce visual clutter and refine the legend with descriptive text. To conclude the layout, we still generate a distinct "footer" plot for the "Ultimate Recipe" outlier, merging it with the main visualization using plot_grid. + +```{r improved-plot, fig.width=7.5, fig.height=6.5, fig.showtext=TRUE, preview=TRUE} +fill_scale <- scale_fill_gradientn( + colors = c("#EF9A9A", "#FFCC80", "#FFF59D", "#A5D6A7", "#66BB6A"), + limits = c(-75, 75), + values = scales::rescale(c(-75, -15, 0, 15, 75)), + name = "YEARS", + breaks = c(-75, 0, 75), + labels = c("LOST", "0", "GAINED"), + guide = guide_colorbar( + title.position = "top", + title.hjust = 0.5, + barwidth = unit(5, "cm"), + barheight = unit(0.3, "cm"), + frame.colour = NA, + ticks = FALSE + ) +) + +main_plot <- ggplot(data_prep, aes(y = Intervention, x = Years_Display)) + + geom_vline(xintercept = seq(-50, 100, by = 25), color = "orange", linewidth = 0.3, alpha = 0.8) + + geom_vline(xintercept = 0, color = "black", linewidth = 0.5) + + geom_col(aes(fill = Years_Display), width = 0.95, color = "white", linewidth = 0.5) + + geom_text( + aes( + x = if_else(Years_Display < 0, -2.5, 2.5), + label = Intervention, + hjust = if_else(Years_Display < 0, 1, 0) + ), + family = "nunito_bold", + fontface = "bold", + size = 2, + color = "black" + ) + + facet_wrap(~ Strength_Label, scales = "free_y", ncol = 3, strip.position = "top") + + fill_scale + + scale_x_continuous( + limits = c(-80, 110), + breaks = seq(-50, 100, by = 25), + labels = c("-10", "-5", "YEARS", "5", "10", "15", "20"), + sec.axis = dup_axis() + ) + + scale_y_discrete(expand = c(0, 0)) + + coord_cartesian(clip = "off") + + labs( + title = "Live Long", + subtitle = "What really extends lifespan?" + ) + + theme_void() + + theme( + text = element_text(family = "nunito_bold", face = "bold"), + legend.position = c(0.98, 1.2), + legend.direction = "horizontal", + legend.justification = "right", + legend.title = element_text(size = 8, family = "nunito_bold", color = "black"), + legend.text = element_text(size = 6, family = "nunito_bold", color = "black", margin = margin(t=2)), + plot.title = element_text(size = 20, family = "nunito_title", face = "bold", color = "#333333", hjust = 0, margin = margin(b=5, l=18)), + plot.subtitle = element_text(size = 11, family = "nunito_subtitle", face = "italic", color = "black", hjust = 0, margin = margin(b=25, l=18)), + plot.background = element_rect(fill = "white", color = NA), + panel.background = element_rect(fill = "white", color = NA), + panel.spacing = unit(0.2, "lines"), + strip.placement = "outside", + strip.text = element_text(size = 9, family = "nunito_bold", color = "#333333", margin = margin(b=5)), + axis.text.x = element_text(size = 4.5, face = "bold", color = "black", margin = margin(t = 2)), + axis.text.x.top = element_text(size = 4.5, face = "bold", color = "black", margin = margin(b = 2)), + plot.margin = margin(t = 10, r = 5, b = 5, l = 5) + ) + +footer <- ggplot() + + coord_cartesian(xlim = c(0, 1), ylim = c(0, 1)) + + geom_segment(aes(x = 0.05, xend = 0.95, y = 0.56, yend = 0.56), color = "#ebdab5", linewidth = 14, lineend = "round") + + geom_segment(aes(x = 0.055, xend = 0.95, y = 0.60, yend = 0.60), color = "#FFFDF2", linewidth = 14, lineend = "round") + + geom_text(aes(x = 0.5, y = 0.68, label = "THE ULTIMATE LONGEVITY PROFILE"), family = "nunito_bold", fontface = "bold", size = 3.5, color = "black", hjust = 0.5) + + geom_text(aes(x = 0.5, y = 0.52, label = "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"), family = "nunito_subtitle", fontface = "italic", size = 2.5, color = "black", hjust = 0.5) + + theme_void() + +final_combined <- plot_grid(main_plot, footer, ncol = 1, rel_heights = c(1, 0.15)) + +final_combined +``` diff --git a/_projects/2025/100572191/100572191.html b/_projects/2025/100572191/100572191.html new file mode 100644 index 00000000..4fdb20c1 --- /dev/null +++ b/_projects/2025/100572191/100572191.html @@ -0,0 +1,2244 @@ + + + + +
+ + + + + + + + + + + + + + + +This project analyzes factors that extend or shorten human lifespan, ranked by scientific evidence. The visualization ranks factors that extend or shorten human lifespan based on the strength of scientific evidence.
+This project provides an insightful look into the factors that extend or shorten human lifespan, ranked by the strength of scientific evidence. Recreated from an original Information is Beautiful graphic, the data synthesizes findings from academic studies (e.g., Khaw KT, 2008) and major reports (BBC, NYT) alongside landmark research like The Okinawa Program, which investigates the habits of the world’s longest-lived populations. By integrating clinical data with real-world longevity studies, the visualization offers a comparative view that separates well-supported health advice from less substantiated claims.
+
+
+One of the most notable strengths of the graph is its high aesthetic appeal, which immediately engages the viewer. It effectively communicates its objective, making an extremely interesting and complex topic—human longevity—accessible and intriguing to a broad audience. Overall, the visualization succeeds in sparking curiosity and encouraging readers to explore the factors that influence lifespan.
+While the graph is visually striking, it presents several limitations regarding data precision. The use of irregular, polygonal bars can be misleading, as it is not clear which part of the shape represents the effective value. Additionally, there is a discrepancy between the legend and the plot: the legend defines discrete color categories, yet the graph applies a continuous gradient, making exact values hard to interpret. Furthermore, while the factors are grouped by the strength of scientific evidence, they are not ordered by impact within those groups, which makes it difficult to compare them directly. Lastly, the icons used to distinguish between men and women are not immediately intuitive, potentially delaying the user’s understanding of the demographic breakdowns.
+We begin by setting up the R environment and loading the essential packages. We use “ggplot2” and “dplyr” for the core data manipulation and visualization tasks. To achieve the complex, non-standard layout of the original infographic, we rely on “cowplot” and “grid”, which allow us to manipulate graphic objects directly.
+Since the visualization requires external PNG images for gender icons, we include “magick” for image processing. Lastly, we import the “Nunito” font family using showtext to replicate the specific typography of the original design.
+knitr::opts_chunk$set(out.width="100%", fig.align="center", fig.showtext=TRUE)
+
+library(ggplot2)
+library(forcats)
+library(dplyr)
+library(showtext)
+library(cowplot)
+library(magick)
+library(grid)
+
+font_add_google("Nunito Sans", "nunito", regular.wt = 200)
+font_add_google("Nunito", "nunito_title", regular.wt = 500)
+font_add_google("Nunito", "nunito_subtitle", regular.wt = 200)
+showtext_auto()
+
+my_data <- read.csv("KIB_longevity data.csv")
+We clean the dataset and prepare specific variables required for the custom geometry. First, we ensure the Years column is numeric and append a specific row for the “Ultimate Recipe,” a humorous outlier that requires manual insertion. We also override the Science_strength values for specific interventions; this is a crucial step to ensure they map correctly to our custom color palette later, as the raw data does not perfectly align with the visual groups we want to create.
+To control the exact vertical ordering of the plot, we define levels_vec, a vector containing the interventions in the desired top-to-bottom order. We then calculate bar_offset and id_adj. These variables are mathematically derived to manage the vertical spacing between bars, allowing us to introduce gaps (e.g., separating “Keep smoking” from the rest) and shift specific bars like the “Ultimate Recipe” to avoid overlap.
+my_data_filtered <- my_data |>
+ mutate(Years = as.numeric(Years)) |>
+ add_row(
+ Intervention = "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat",
+ Years = 23,
+ Science_strength = 4
+ )
+
+my_data_filtered <- my_data_filtered |>
+ mutate(
+ Science_strength = case_when(
+ Intervention == "Be polygamous, maybe" ~ 1.2,
+ Intervention == "Go to church regularly" ~ 1.4,
+ Intervention == "Sit down" ~ 1.6,
+ Intervention == "More Pets" ~ 1.8,
+ Intervention == "Eat red meat" ~ 1.9,
+ Intervention == "Be rich" ~ 2.25,
+ Intervention == "Be a woman" ~ 2.4,
+ Intervention == "Suffer severe mental illness" ~ 2.5,
+ Intervention == "Become obese" ~ 2.6,
+ Intervention == "Keep smoking" ~ 2.7,
+ Intervention == "Quit" ~ 2.7,
+ TRUE ~ as.numeric(Science_strength)
+ )
+ )
+
+levels_vec <- c(
+ "Sleep too much", "Be optimistic", "Get promoted", "Live in a city", "Live in the country",
+ "Eat less food", "Have a long-lived maternal grandfather", "Hang out with women - a lot!",
+ "Be conscientious ", "Have more orgasms", "With close friends", "Be polygamous, maybe",
+ "Go to church regularly", "Sit down", "More Pets", "Eat red meat", "Avoid cancer",
+ "Avoid heart disease", "Be alcoholic", "Get health checks ", "Get married!", "Be rich",
+ "Be a woman", "Suffer severe mental illness", "Become obese", "Keep smoking", "Quit",
+ "Eat healthy", "Live healthily", "Have a long-lived sibling", "Exercise more",
+ "Live at high altitude",
+ "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"
+)
+
+my_data_filtered <- my_data_filtered |>
+ mutate(
+ Intervention = factor(Intervention, levels = rev(levels_vec)),
+ id = as.integer(Intervention),
+ Years_Capped = if_else(Intervention == "Suffer severe mental illness", -12, Years),
+ bar_offset = if_else(
+ Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat",
+ id - 0.8,
+ id + 0.2
+ )
+ )
+
+id_quit <- my_data_filtered$id[my_data_filtered$Intervention == "Keep smoking"]
+
+my_data_filtered <- my_data_filtered |>
+ mutate(
+ id_adj = case_when(
+ Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat" ~ id - 1.5,
+ id >= id_quit ~ id - 1,
+ TRUE ~ id
+ ),
+ bar_offset = id_adj
+ )
+This is the most technically complex section where we manually construct the polygon shapes instead of using standard bars. We use rowwise() to calculate coordinates for every single intervention. The logic defines horiz (the rectangular part of the bar) and diag_end (the angled tip), distinguishing between positive and negative years.
+For specific entries like “Have a long-lived maternal grandfather,” we implement a loop that generates multiple small polygons with decreasing alpha values. This creates a custom “fading” visual effect that standard ggplot functions cannot produce. Finally, we initialize the ggplot object, adding geom_polygon for the bars and geom_text for the labels, ensuring the “Ultimate Recipe” gets unique styling.
+poly_df <- my_data_filtered |>
+ rowwise() |>
+ mutate(
+ horiz = if_else(Years_Capped > 0, pmax(0, Years_Capped - 0.80), Years_Capped + 0.80),
+ diag_end = Years_Capped,
+ top = bar_offset + 0.45,
+ bottom = bar_offset - 0.45,
+
+ base_fill = if_else(
+ Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat",
+ "#6b1786",
+ scales::col_numeric(
+ palette = c("#E5BB39", "#ea9038", "#8ECB9A"),
+ domain = range(c(1, 3))
+ )(Science_strength)
+ ),
+
+ poly = list({
+ if (Intervention %in% c("Have a long-lived maternal grandfather", "Have a long-lived sibling")) {
+ n_fade <- 90
+ split_ratio <- 0.35
+
+ x_split_top <- horiz * split_ratio
+ x_split_bot <- diag_end * split_ratio
+
+ solid_part <- data.frame(
+ x = c(0, x_split_top, x_split_bot, 0),
+ y = c(top, top, bottom, bottom),
+ poly_id = paste0(id_adj, "_solid"),
+ fill_val = base_fill,
+ alpha_val = 1
+ )
+
+ seq_steps <- seq(split_ratio, 1, length.out = n_fade + 1)
+ x_top_edge <- seq_steps * horiz
+ x_bot_edge <- seq_steps * diag_end
+ alphas <- seq(1, 0.05, length.out = n_fade)
+
+ xs <- c()
+ ys <- c()
+ alpha_vec <- c()
+ ids <- c()
+
+ for (i in 1:n_fade) {
+ xs <- c(xs, x_top_edge[i], x_top_edge[i+1], x_bot_edge[i+1], x_bot_edge[i])
+ ys <- c(ys, top, top, bottom, bottom)
+ alpha_vec <- c(alpha_vec, rep(alphas[i], 4))
+ ids <- c(ids, rep(paste0(id_adj, "_fade_", i), 4))
+ }
+
+ fade_part <- data.frame(
+ x = xs, y = ys, poly_id = ids, fill_val = base_fill, alpha_val = alpha_vec
+ )
+
+ bind_rows(solid_part, fade_part)
+
+ } else {
+ data.frame(
+ x = c(0, horiz, diag_end, 0),
+ y = c(top, top, bottom, bottom),
+ poly_id = as.character(id_adj),
+ fill_val = base_fill,
+ alpha_val = 1
+ )
+ }
+ })
+ ) |>
+ pull(poly) |>
+ bind_rows()
+
+
+longevity_dt <- ggplot() +
+ geom_segment(
+ data = data.frame(x_val = seq(-10, 20, by = 5)),
+ aes(
+ x = x_val, xend = x_val,
+ y = max(poly_df$y) + 1,
+ yend = min(poly_df$y) - 1
+ ),
+ color = "#FFB777",
+ linewidth = 0.2,
+ alpha = 0.8
+ ) +
+ geom_polygon(
+ data = poly_df,
+ aes(x = x, y = y, group = poly_id, fill = fill_val, alpha = alpha_val),
+ color = NA
+ ) +
+ scale_alpha_identity() +
+ geom_segment(
+ data = data.frame(x_val = 0),
+ aes(
+ x = x_val, xend = x_val,
+ y = max(poly_df$y) + 1,
+ yend = min(poly_df$y) - 1
+ ),
+ color = "gray6",
+ linewidth = 0.2
+ ) +
+ geom_text(
+ data = my_data_filtered |>
+ filter(Intervention != "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"),
+ aes(
+ x = if_else(Years_Capped < 0, -0.2, 0.2),
+ y = bar_offset,
+ label = Intervention,
+ hjust = if_else(Years_Capped < 0, 1, 0)
+ ),
+ family = "nunito",
+ size = 2.1,
+ color = "black"
+ ) +
+ geom_text(
+ data = my_data_filtered |>
+ filter(Intervention == "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"),
+ aes(
+ x = 0.2,
+ y = bar_offset,
+ label = Intervention,
+ hjust = 0
+ ),
+ family = "nunito_bold",
+ size = 2.1,
+ color = "white",
+ fontface = "plain"
+ ) +
+ scale_color_manual(values = c("TRUE" = "white", "FALSE" = "black"), guide = "none") +
+ annotate(
+ "text",
+ x = -0.5,
+ y = my_data_filtered$bar_offset[
+ my_data_filtered$Intervention ==
+ "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"
+ ],
+ label = "ULTIMATE RECIPE",
+ color = "#6b1786",
+ family = "nunito",
+ fontface = "bold",
+ hjust = 1,
+ size = 2.4
+ ) +
+ scale_fill_identity() +
+ scale_y_continuous(NULL, breaks = NULL, labels = NULL) +
+ theme(
+ text = element_text(family = "nunito"),
+ legend.position = "none"
+ )
+
+longevity_dt
+
We customize the X-axis to replicate the ruler-like aesthetic of the original graphic. We use scale_x_continuous with dup_axis() to display the years on both the top and bottom scales. To add precise tick marks that match the design, we overlay geom_point and geom_segment elements manually rather than relying on default ggplot ticks.
+Crucially, we set coord_cartesian(clip = “off”), which allows text labels and annotations to extend beyond the plotting area boundaries without being cut off.
+longevity_dt <- longevity_dt +
+ scale_x_continuous(
+ limits = c(-25, 23),
+ breaks = seq(-10, 20, by = 5),
+ minor_breaks = seq(-12, 21, by = 1),
+ labels = function(x) ifelse(x == 0, expression(bold("YEARS")), as.character(x)),
+ sec.axis = dup_axis()
+ ) +
+ geom_point(
+ data = data.frame(x_val = seq(-10, 20, by = 1)) |>
+ dplyr::filter(x_val %% 5 != 0),
+ aes(x = x_val, y = max(poly_df$y) + 1.6),
+ shape = 16,
+ size = 0.1,
+ color = "black",
+ inherit.aes = FALSE
+ ) +
+ coord_cartesian(clip = "off")
+
+tick_data <- data.frame(x_val = seq(-10, 20, by = 5))
+longevity_dt <- longevity_dt +
+ geom_segment(
+ data = tick_data,
+ aes(x = x_val, xend = x_val,
+ y = max(poly_df$y) +1.45,
+ yend = max(poly_df$y) + 1.75),
+ color = "black",
+ linewidth = 0.1,
+ inherit.aes = FALSE
+ )
+
+longevity_dt
+
We apply a minimalist theme to strictly control the visual output. We explicitly set the panel and plot backgrounds to white using element_rect. We remove all standard background grids, borders, and default axis titles using element_blank() to leave only the necessary data ink.
+Furthermore, we fine-tune the plot.margin and reduce the size of the axis text to ensure the layout remains compact and legible.
+longevity_dt <- longevity_dt +
+ theme(
+ panel.background = element_rect(fill = "#FFFFFF", color = NA),
+ plot.background = element_rect(fill = "#FFFFFF", color = NA),
+ panel.grid.major = element_blank(),
+ panel.grid.minor = element_blank(),
+ axis.title.x.top = element_blank(),
+ axis.title.x.bottom = element_blank(),
+ axis.title.y = element_blank(),
+ plot.margin = unit(c(0.2, 0.5, 0.1, 0.5), "cm"),
+ axis.text.y = element_blank(),
+ axis.ticks.x.top = element_blank(),
+ axis.ticks.x.bottom = element_blank(),
+ legend.position = "none",
+ axis.text.x = element_text(size = 5, margin = margin(t = -8)),
+ axis.text.x.top = element_text(size = 5, margin = margin(b = -8))
+ )
+
+longevity_dt
+
We process the external PNG images for the gender icons here. Using magick, we read the files and scale the female icon to exactly match the dimensions of the male icon. Moreover, we use rasterGrob to convert these images into graphical objects compatible with the grid system.
+Finally, we filter the dataset to identify exactly which interventions require specific gender icons and calculate their coordinates to prepare them for placement.
+male_icon <- image_read("man.png")
+female_icon <- image_read("women.png")
+
+female_icon <- image_scale(female_icon, paste0(image_info(male_icon)$width, "x", image_info(male_icon)$height, "!"))
+
+male_grob <- rasterGrob(male_icon, interpolate = TRUE)
+female_grob <- rasterGrob(female_icon, interpolate = TRUE)
+
+gender_icons <- my_data_filtered |>
+ filter(Intervention %in% c(
+ "Be optimistic", "Get promoted", "Have a long-lived maternal grandfather",
+ "Hang out with women - a lot!", "Have more orgasms",
+ "Be polygamous, maybe", "Be a woman"
+ )) |>
+ mutate(
+ icon_type = case_when(
+ Intervention %in% c("Get promoted", "Have a long-lived maternal grandfather",
+ "Hang out with women - a lot!", "Have more orgasms", "Be polygamous, maybe") ~ "male",
+ Intervention %in% c("Be optimistic", "Be a woman") ~ "female",
+ TRUE ~ "male"
+ ),
+ x_pos = -0.5,
+ y_pos = bar_offset
+ )
+Because the standard ggplot legend cannot accommodate the specific layout of colored blocks and embedded images we need, we construct a custom legend from scratch using ggplot. We manually draw rectangles (annotate(“rect”)) for the “Strength of Science” categories to match the fill colors used in the main plot.
+We place the gender icon grobs directly into this legend object using annotation_custom to ensure the legend is fully self-contained.
+legend_plot <- ggplot() +
+ annotate("rect", xmin = 11, xmax = 13.5, ymin = 39.8, ymax = 40.6, fill = "#E5BB39", color = NA) +
+ annotate("rect", xmin = 13.5, xmax = 16, ymin = 39.8, ymax = 40.6, fill = "#EA9038", color = NA) +
+ annotate("polygon", x = c(16, 18.2, 18.5, 16), y = c(40.6, 40.6, 39.8, 39.8), fill = "#8ECB9A", color = NA) +
+ annotate("text", x = 12.25, y = 40.2, label = "Suggestive", family = "nunito", size = 1.8, color = "#333333") +
+ annotate("text", x = 14.75, y = 40.2, label = "Good", family = "nunito", size = 1.8, color = "#333333") +
+ annotate("text", x = 17.2, y = 40.2, label = "Strong", family = "nunito", size = 1.8, color = "#333333") +
+ annotate("text", x = 18.5, y = 40.9, label = "STRENGTH OF SCIENCE", family = "nunito_bold", fontface = "bold", size = 2.5, color = "#333333", hjust = 1) +
+ annotate("text", x = 9.7, y = 40.2, label = "male / female specific", family = "nunito", size = 1.8, color = "#666666", hjust = 1) +
+ coord_cartesian(xlim = c(5, 20), ylim = c(39, 42)) +
+ theme_void()
+
+legend_plot <- legend_plot +
+ annotation_custom(
+ grob = female_grob,
+ xmin = 9.90, xmax = 10.55,
+ ymin = 39.55, ymax = 40.8
+ ) +
+ annotation_custom(
+ grob = male_grob,
+ xmin = 10.4, xmax = 11.0,
+ ymin = 39.6, ymax = 40.8
+ )
+We finalize the main plot by looping through the gender_icons dataframe and placing the grobs at the calculated coordinates. We then calculate dynamic positions for the explanatory text notes (notes_df); we use conditional logic to decide whether a note should be forced to the left or right to avoid overlapping with the bars.
+Additionally, we construct a specific, multi-segment annotation for “Mental Illness” to handle its unique positioning.
+icon_size <- 0.7
+
+male_positions <- gender_icons |> filter(icon_type == "male")
+female_positions <- gender_icons |> filter(icon_type == "female")
+both_positions <- gender_icons |> filter(icon_type == "both")
+
+longevity_dt <- longevity_dt +
+ {if(nrow(male_positions) > 0) {
+ lapply(1:nrow(male_positions), function(i) {
+ annotation_custom(
+ grob = male_grob,
+ xmin = male_positions$x_pos[i] - icon_size/2,
+ xmax = male_positions$x_pos[i] + icon_size/2,
+ ymin = male_positions$y_pos[i] - icon_size/2,
+ ymax = male_positions$y_pos[i] + icon_size/2
+ )
+ })
+ }} +
+ {if(nrow(female_positions) > 0) {
+ lapply(1:nrow(female_positions), function(i) {
+ annotation_custom(
+ grob = female_grob,
+ xmin = female_positions$x_pos[i] - icon_size/2,
+ xmax = female_positions$x_pos[i] + icon_size/2,
+ ymin = female_positions$y_pos[i] - icon_size/2,
+ ymax = female_positions$y_pos[i] + icon_size/2
+ )
+ })
+ }}
+
+force_left_list <- c(
+ "Hang out with women - a lot!", "Be polygamous, maybe", "Sit down", "Eat healthy",
+ "Have a long-lived sibling", "Keep smoking",
+ "Live at a high altitude", "Be conscientious "
+)
+
+right_exceptions <- c("Get promoted", "Have more orgasms", "Get health checks ", "Exercise more")
+
+notes_df <- my_data_filtered |>
+ dplyr::filter(!is.na(Note) & Note != "" & Intervention != "Suffer severe mental illness") |>
+ dplyr::mutate(
+ Note_Wrapped = stringr::str_wrap(Note, width = 30),
+ x_note_pos = dplyr::case_when(
+ Intervention == "Suffer severe mental illness" ~ -14,
+ Intervention %in% force_left_list ~ -5.5,
+ Intervention %in% right_exceptions ~ 10,
+ TRUE ~ 15
+ ),
+ text_hjust = dplyr::if_else(x_note_pos < 0, 1, 0),
+ x_line_start = dplyr::case_when(
+ Intervention == "Be optimistic" ~ 2.7,
+ Intervention == "Get health checks " ~ 3.5,
+ Intervention == "Exercise more" ~ 2.9,
+ Intervention == "Hang out with women - a lot!" ~ -1.0,
+ Intervention == "Be polygamous, maybe" ~ -1.0,
+ sign(x_note_pos) == sign(Years_Capped) ~ Years_Capped,
+ TRUE ~ 0
+ ),
+ y_pos = bar_offset,
+ note_vjust = dplyr::if_else(
+ Intervention == "Hang out with women - a lot!",
+ 0.3,
+ 0.8
+ )
+ )
+
+mental_note_df <- my_data_filtered |>
+ dplyr::filter(Intervention == "Suffer severe mental illness") |>
+ dplyr::mutate(
+ y_start = bar_offset,
+ y_end = bar_offset + 1.2,
+ x_pos = -5.5,
+ x_midpoint = -9,
+ Note_Wrapped = "25 years shorter\nlife expectancy"
+ )
+
+longevity_dt <- longevity_dt +
+ geom_segment(
+ data = notes_df,
+ aes(x = x_line_start, xend = x_note_pos, y = y_pos, yend = y_pos),
+ linetype = "19", color = "black", linewidth = 0.1, inherit.aes = FALSE, lineend="round"
+ ) +
+ geom_text(
+ data = notes_df,
+ aes(
+ x = x_note_pos + dplyr::if_else(x_note_pos > 0, 0.2, -0.2),
+ y = y_pos,
+ label = Note_Wrapped,
+ hjust = text_hjust,
+ vjust = note_vjust
+ ),
+ size = 1.3, color = "#666666", family = "sans", lineheight = 0.8, inherit.aes = FALSE
+ ) +
+ geom_segment(
+ data = mental_note_df,
+ aes(x = x_midpoint, xend = x_midpoint, y = y_start, yend = y_end),
+ linetype = "19", color = "black", linewidth = 0.1, inherit.aes = FALSE, lineend="round"
+ ) +
+ geom_segment(
+ data = mental_note_df,
+ aes(x = x_midpoint, xend = -8.7, y = y_end, yend = y_end),
+ linetype = "19", color = "black", linewidth = 0.1, inherit.aes = FALSE, lineend="round"
+ ) +
+ geom_text(
+ data = mental_note_df,
+ aes(x = x_pos - 0.2, y = y_end, label = Note_Wrapped),
+ hjust = 1, vjust = 0.5, size = 1.3, color = "#666666", family = "sans", lineheight = 0.8, inherit.aes = FALSE
+ )
+
+longevity_dt
+
We use ggdraw from the cowplot package to combine the separate components. We treat the main plot and the legend as separate graphical objects, arranging them on a single canvas and adding the main title and subtitle text layers.
+final_plot <- ggdraw() +
+ draw_plot(longevity_dt, x = 0, y = 0, width = 1, height = 0.88) +
+ draw_plot(legend_plot, x = 0.58, y = 0.88, width = 0.38, height = 0.11) +
+ draw_label(
+ "Live Long",
+ x = 0.32, y = 0.96,
+ hjust = 0, vjust = 1,
+ fontfamily = "nunito_title",
+ size = 20,
+ color = "#333333"
+) +
+ draw_label(
+ "What really extends lifespan?",
+ x = 0.32, y = 0.91,
+ hjust = 0, vjust = 1,
+ fontfamily = "nunito_subtitle",
+ size = 10,
+ color = "#333333"
+)
+
+final_plot
+
We acknowledge that some details in our replica differ from the original graphic. First, regarding typography, we use the “Nunito” font family; since the original design uses a paid commercial font, we selected this as the closest open-source alternative.
+Furthermore, we notice that the footer text regarding the “Ultimate Recipe” is not fully legible in our final output. Although the structure is accurate, the positioning of certain text annotations and lines could be more precise compared to the original’s manual layout.
+In this first step, we prepare again the data for the improved visualization by filtering out the decorative elements and focusing on valid scientific strengths. We create a new factor variable, Strength_Label, to facilitate faceting, and we rescale the years for better visual impact. We also reorder the interventions based on the number of years gained or lost to ensure the bar chart is sorted logically.
+data_prep <- my_data |>
+ filter(Science_strength %in% c(1, 2, 3)) |>
+ mutate(
+ Intervention = case_when(
+ Intervention == "Quit" ~ "Quit smoking",
+ Intervention == "Have a long-lived maternal grandfather" ~ "Have a long-lived maternal grandad",
+ TRUE ~ Intervention
+ ),
+ Years = as.numeric(Years),
+ Strength_Label = factor(Science_strength,
+ levels = c(1, 2, 3),
+ labels = c("Weak scientific evidence", "Moderate scientific evidence", "Strong scientific evidence"))
+ ) |>
+ arrange(Science_strength, Years) |>
+ mutate(
+ Years_Capped = if_else(Intervention == "Suffer severe mental illness", -12, Years),
+ Years_Display = Years_Capped * 5,
+ Intervention = reorder(Intervention, -Years)
+ )
+To resolve the ambiguity caused by the original irregular polygons, we switch to a standard column chart structure, which ensures the effective values are immediately readable.
+Simultaneously, we employ facet_wrap(~ Strength_Label) to segregate the interventions by evidence level; this approach rectifies the previous comparison difficulties, enabling a clear ranking of factors that share equivalent scientific backing. Regarding the color scheme, we implement a continuous gradient via scale_fill_gradientn. Unlike the confusing original palette, this transition from red to green explicitly highlights the contrast between life-shortening and life-extending habits.
+Additionally, we discard the non-essential gender icons to reduce visual clutter and refine the legend with descriptive text. To conclude the layout, we still generate a distinct “footer” plot for the “Ultimate Recipe” outlier, merging it with the main visualization using plot_grid.
+fill_scale <- scale_fill_gradientn(
+ colors = c("#EF9A9A", "#FFCC80", "#FFF59D", "#A5D6A7", "#66BB6A"),
+ limits = c(-75, 75),
+ values = scales::rescale(c(-75, -15, 0, 15, 75)),
+ name = "YEARS",
+ breaks = c(-75, 0, 75),
+ labels = c("LOST", "0", "GAINED"),
+ guide = guide_colorbar(
+ title.position = "top",
+ title.hjust = 0.5,
+ barwidth = unit(5, "cm"),
+ barheight = unit(0.3, "cm"),
+ frame.colour = NA,
+ ticks = FALSE
+ )
+)
+
+main_plot <- ggplot(data_prep, aes(y = Intervention, x = Years_Display)) +
+ geom_vline(xintercept = seq(-50, 100, by = 25), color = "orange", linewidth = 0.3, alpha = 0.8) +
+ geom_vline(xintercept = 0, color = "black", linewidth = 0.5) +
+ geom_col(aes(fill = Years_Display), width = 0.95, color = "white", linewidth = 0.5) +
+ geom_text(
+ aes(
+ x = if_else(Years_Display < 0, -2.5, 2.5),
+ label = Intervention,
+ hjust = if_else(Years_Display < 0, 1, 0)
+ ),
+ family = "nunito_bold",
+ fontface = "bold",
+ size = 2,
+ color = "black"
+ ) +
+ facet_wrap(~ Strength_Label, scales = "free_y", ncol = 3, strip.position = "top") +
+ fill_scale +
+ scale_x_continuous(
+ limits = c(-80, 110),
+ breaks = seq(-50, 100, by = 25),
+ labels = c("-10", "-5", "YEARS", "5", "10", "15", "20"),
+ sec.axis = dup_axis()
+ ) +
+ scale_y_discrete(expand = c(0, 0)) +
+ coord_cartesian(clip = "off") +
+ labs(
+ title = "Live Long",
+ subtitle = "What really extends lifespan?"
+ ) +
+ theme_void() +
+ theme(
+ text = element_text(family = "nunito_bold", face = "bold"),
+ legend.position = c(0.98, 1.2),
+ legend.direction = "horizontal",
+ legend.justification = "right",
+ legend.title = element_text(size = 8, family = "nunito_bold", color = "black"),
+ legend.text = element_text(size = 6, family = "nunito_bold", color = "black", margin = margin(t=2)),
+ plot.title = element_text(size = 20, family = "nunito_title", face = "bold", color = "#333333", hjust = 0, margin = margin(b=5, l=18)),
+ plot.subtitle = element_text(size = 11, family = "nunito_subtitle", face = "italic", color = "black", hjust = 0, margin = margin(b=25, l=18)),
+ plot.background = element_rect(fill = "white", color = NA),
+ panel.background = element_rect(fill = "white", color = NA),
+ panel.spacing = unit(0.2, "lines"),
+ strip.placement = "outside",
+ strip.text = element_text(size = 9, family = "nunito_bold", color = "#333333", margin = margin(b=5)),
+ axis.text.x = element_text(size = 4.5, face = "bold", color = "black", margin = margin(t = 2)),
+ axis.text.x.top = element_text(size = 4.5, face = "bold", color = "black", margin = margin(b = 2)),
+ plot.margin = margin(t = 10, r = 5, b = 5, l = 5)
+ )
+
+footer <- ggplot() +
+ coord_cartesian(xlim = c(0, 1), ylim = c(0, 1)) +
+ geom_segment(aes(x = 0.05, xend = 0.95, y = 0.56, yend = 0.56), color = "#ebdab5", linewidth = 14, lineend = "round") +
+ geom_segment(aes(x = 0.055, xend = 0.95, y = 0.60, yend = 0.60), color = "#FFFDF2", linewidth = 14, lineend = "round") +
+ geom_text(aes(x = 0.5, y = 0.68, label = "THE ULTIMATE LONGEVITY PROFILE"), family = "nunito_bold", fontface = "bold", size = 3.5, color = "black", hjust = 0.5) +
+ geom_text(aes(x = 0.5, y = 0.52, label = "Married happy-go-lucky outdoors-loving sex-mad hippy party-girl in senior management with a cat"), family = "nunito_subtitle", fontface = "italic", size = 2.5, color = "black", hjust = 0.5) +
+ theme_void()
+
+final_combined <- plot_grid(main_plot, footer, ncol = 1, rel_heights = c(1, 0.15))
+
+final_combined
+
`,e.githubCompareUpdatesUrl&&(t+=`View all changes to this article since it was first published.`),t+=` + If you see mistakes or want to suggest changes, please create an issue on GitHub.
+ `);const n=e.journal;return'undefined'!=typeof n&&'Distill'===n.title&&(t+=` +Diagrams and text are licensed under Creative Commons Attribution CC-BY 4.0 with the source available on GitHub, unless noted otherwise. The figures that have been reused from other sources don’t fall under this license and can be recognized by a note in their caption: “Figure from …”.
+ `),'undefined'!=typeof e.publishedDate&&(t+=` +For attribution in academic contexts, please cite this work as
+${e.concatenatedAuthors}, "${e.title}", Distill, ${e.publishedYear}.
+ BibTeX citation
+${m(e)}
+ `),t}var An=Math.sqrt,En=Math.atan2,Dn=Math.sin,Mn=Math.cos,On=Math.PI,Un=Math.abs,In=Math.pow,Nn=Math.LN10,jn=Math.log,Rn=Math.max,qn=Math.ceil,Fn=Math.floor,Pn=Math.round,Hn=Math.min;const zn=['Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'],Bn=['Jan.','Feb.','March','April','May','June','July','Aug.','Sept.','Oct.','Nov.','Dec.'],Wn=(e)=>10>e?'0'+e:e,Vn=function(e){const t=zn[e.getDay()].substring(0,3),n=Wn(e.getDate()),i=Bn[e.getMonth()].substring(0,3),a=e.getFullYear().toString(),d=e.getUTCHours().toString(),r=e.getUTCMinutes().toString(),o=e.getUTCSeconds().toString();return`${t}, ${n} ${i} ${a} ${d}:${r}:${o} Z`},$n=function(e){const t=Array.from(e).reduce((e,[t,n])=>Object.assign(e,{[t]:n}),{});return t},Jn=function(e){const t=new Map;for(var n in e)e.hasOwnProperty(n)&&t.set(n,e[n]);return t};class Qn{constructor(e){this.name=e.author,this.personalURL=e.authorURL,this.affiliation=e.affiliation,this.affiliationURL=e.affiliationURL,this.affiliations=e.affiliations||[]}get firstName(){const e=this.name.split(' ');return e.slice(0,e.length-1).join(' ')}get lastName(){const e=this.name.split(' ');return e[e.length-1]}}class Gn{constructor(){this.title='unnamed article',this.description='',this.authors=[],this.bibliography=new Map,this.bibliographyParsed=!1,this.citations=[],this.citationsCollected=!1,this.journal={},this.katex={},this.publishedDate=void 0}set url(e){this._url=e}get url(){if(this._url)return this._url;return this.distillPath&&this.journal.url?this.journal.url+'/'+this.distillPath:this.journal.url?this.journal.url:void 0}get githubUrl(){return this.githubPath?'https://github.com/'+this.githubPath:void 0}set previewURL(e){this._previewURL=e}get previewURL(){return this._previewURL?this._previewURL:this.url+'/thumbnail.jpg'}get publishedDateRFC(){return Vn(this.publishedDate)}get updatedDateRFC(){return Vn(this.updatedDate)}get publishedYear(){return this.publishedDate.getFullYear()}get publishedMonth(){return Bn[this.publishedDate.getMonth()]}get publishedDay(){return this.publishedDate.getDate()}get publishedMonthPadded(){return Wn(this.publishedDate.getMonth()+1)}get publishedDayPadded(){return Wn(this.publishedDate.getDate())}get publishedISODateOnly(){return this.publishedDate.toISOString().split('T')[0]}get volume(){const e=this.publishedYear-2015;if(1>e)throw new Error('Invalid publish date detected during computing volume');return e}get issue(){return this.publishedDate.getMonth()+1}get concatenatedAuthors(){if(2 tag. We found the following text: '+t);const n=document.createElement('span');n.innerHTML=e.nodeValue,e.parentNode.insertBefore(n,e),e.parentNode.removeChild(e)}}}}).observe(this,{childList:!0})}}var Ti='undefined'==typeof window?'undefined'==typeof global?'undefined'==typeof self?{}:self:global:window,_i=f(function(e,t){(function(e){function t(){this.months=['jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'],this.notKey=[',','{','}',' ','='],this.pos=0,this.input='',this.entries=[],this.currentEntry='',this.setInput=function(e){this.input=e},this.getEntries=function(){return this.entries},this.isWhitespace=function(e){return' '==e||'\r'==e||'\t'==e||'\n'==e},this.match=function(e,t){if((void 0==t||null==t)&&(t=!0),this.skipWhitespace(t),this.input.substring(this.pos,this.pos+e.length)==e)this.pos+=e.length;else throw'Token mismatch, expected '+e+', found '+this.input.substring(this.pos);this.skipWhitespace(t)},this.tryMatch=function(e,t){return(void 0==t||null==t)&&(t=!0),this.skipWhitespace(t),this.input.substring(this.pos,this.pos+e.length)==e},this.matchAt=function(){for(;this.input.length>this.pos&&'@'!=this.input[this.pos];)this.pos++;return!('@'!=this.input[this.pos])},this.skipWhitespace=function(e){for(;this.isWhitespace(this.input[this.pos]);)this.pos++;if('%'==this.input[this.pos]&&!0==e){for(;'\n'!=this.input[this.pos];)this.pos++;this.skipWhitespace(e)}},this.value_braces=function(){var e=0;this.match('{',!1);for(var t=this.pos,n=!1;;){if(!n)if('}'==this.input[this.pos]){if(0 =k&&(++x,i=k);if(d[x]instanceof n||d[T-1].greedy)continue;w=T-x,y=e.slice(i,k),v.index-=i}if(v){g&&(h=v[1].length);var S=v.index+h,v=v[0].slice(h),C=S+v.length,_=y.slice(0,S),L=y.slice(C),A=[x,w];_&&A.push(_);var E=new n(o,u?a.tokenize(v,u):v,b,v,f);A.push(E),L&&A.push(L),Array.prototype.splice.apply(d,A)}}}}}return d},hooks:{all:{},add:function(e,t){var n=a.hooks.all;n[e]=n[e]||[],n[e].push(t)},run:function(e,t){var n=a.hooks.all[e];if(n&&n.length)for(var d,r=0;d=n[r++];)d(t)}}},i=a.Token=function(e,t,n,i,a){this.type=e,this.content=t,this.alias=n,this.length=0|(i||'').length,this.greedy=!!a};if(i.stringify=function(e,t,n){if('string'==typeof e)return e;if('Array'===a.util.type(e))return e.map(function(n){return i.stringify(n,t,e)}).join('');var d={type:e.type,content:i.stringify(e.content,t,n),tag:'span',classes:['token',e.type],attributes:{},language:t,parent:n};if('comment'==d.type&&(d.attributes.spellcheck='true'),e.alias){var r='Array'===a.util.type(e.alias)?e.alias:[e.alias];Array.prototype.push.apply(d.classes,r)}a.hooks.run('wrap',d);var l=Object.keys(d.attributes).map(function(e){return e+'="'+(d.attributes[e]||'').replace(/"/g,'"')+'"'}).join(' ');return'<'+d.tag+' class="'+d.classes.join(' ')+'"'+(l?' '+l:'')+'>'+d.content+''+d.tag+'>'},!t.document)return t.addEventListener?(t.addEventListener('message',function(e){var n=JSON.parse(e.data),i=n.language,d=n.code,r=n.immediateClose;t.postMessage(a.highlight(d,a.languages[i],i)),r&&t.close()},!1),t.Prism):t.Prism;var d=document.currentScript||[].slice.call(document.getElementsByTagName('script')).pop();return d&&(a.filename=d.src,document.addEventListener&&!d.hasAttribute('data-manual')&&('loading'===document.readyState?document.addEventListener('DOMContentLoaded',a.highlightAll):window.requestAnimationFrame?window.requestAnimationFrame(a.highlightAll):window.setTimeout(a.highlightAll,16))),t.Prism}();e.exports&&(e.exports=n),'undefined'!=typeof Ti&&(Ti.Prism=n),n.languages.markup={comment://,prolog:/<\?[\w\W]+?\?>/,doctype://i,cdata://i,tag:{pattern:/<\/?(?!\d)[^\s>\/=$<]+(?:\s+[^\s>\/=]+(?:=(?:("|')(?:\\\1|\\?(?!\1)[\w\W])*\1|[^\s'">=]+))?)*\s*\/?>/i,inside:{tag:{pattern:/^<\/?[^\s>\/]+/i,inside:{punctuation:/^<\/?/,namespace:/^[^\s>\/:]+:/}},"attr-value":{pattern:/=(?:('|")[\w\W]*?(\1)|[^\s>]+)/i,inside:{punctuation:/[=>"']/}},punctuation:/\/?>/,"attr-name":{pattern:/[^\s>\/]+/,inside:{namespace:/^[^\s>\/:]+:/}}}},entity:/?[\da-z]{1,8};/i},n.hooks.add('wrap',function(e){'entity'===e.type&&(e.attributes.title=e.content.replace(/&/,'&'))}),n.languages.xml=n.languages.markup,n.languages.html=n.languages.markup,n.languages.mathml=n.languages.markup,n.languages.svg=n.languages.markup,n.languages.css={comment:/\/\*[\w\W]*?\*\//,atrule:{pattern:/@[\w-]+?.*?(;|(?=\s*\{))/i,inside:{rule:/@[\w-]+/}},url:/url\((?:(["'])(\\(?:\r\n|[\w\W])|(?!\1)[^\\\r\n])*\1|.*?)\)/i,selector:/[^\{\}\s][^\{\};]*?(?=\s*\{)/,string:{pattern:/("|')(\\(?:\r\n|[\w\W])|(?!\1)[^\\\r\n])*\1/,greedy:!0},property:/(\b|\B)[\w-]+(?=\s*:)/i,important:/\B!important\b/i,function:/[-a-z0-9]+(?=\()/i,punctuation:/[(){};:]/},n.languages.css.atrule.inside.rest=n.util.clone(n.languages.css),n.languages.markup&&(n.languages.insertBefore('markup','tag',{style:{pattern:/(
+
+
+ ${e.map(l).map((e)=>`
`)}}const Mi=`
+d-citation-list {
+ contain: layout style;
+}
+
+d-citation-list .references {
+ grid-column: text;
+}
+
+d-citation-list .references .title {
+ font-weight: 500;
+}
+`;class Oi extends HTMLElement{static get is(){return'd-citation-list'}connectedCallback(){this.hasAttribute('distill-prerendered')||(this.style.display='none')}set citations(e){x(this,e)}}var Ui=f(function(e){var t='undefined'==typeof window?'undefined'!=typeof WorkerGlobalScope&&self instanceof WorkerGlobalScope?self:{}:window,n=function(){var e=/\blang(?:uage)?-(\w+)\b/i,n=0,a=t.Prism={util:{encode:function(e){return e instanceof i?new i(e.type,a.util.encode(e.content),e.alias):'Array'===a.util.type(e)?e.map(a.util.encode):e.replace(/&/g,'&').replace(/e.length)break tokenloop;if(!(y instanceof n)){c.lastIndex=0;var v=c.exec(y),w=1;if(!v&&f&&x!=d.length-1){if(c.lastIndex=i,v=c.exec(e),!v)break;for(var S=v.index+(g?v[1].length:0),C=v.index+v[0].length,T=x,k=i,p=d.length;T
+
+`);class Ni extends ei(Ii(HTMLElement)){renderContent(){if(this.languageName=this.getAttribute('language'),!this.languageName)return void console.warn('You need to provide a language attribute to your Footnotes
+
+`,!1);class Fi extends qi(HTMLElement){connectedCallback(){super.connectedCallback(),this.list=this.root.querySelector('ol'),this.root.style.display='none'}set footnotes(e){if(this.list.innerHTML='',e.length){this.root.style.display='';for(const t of e){const e=document.createElement('li');e.id=t.id+'-listing',e.innerHTML=t.innerHTML;const n=document.createElement('a');n.setAttribute('class','footnote-backlink'),n.textContent='[\u21A9]',n.href='#'+t.id,e.appendChild(n),this.list.appendChild(e)}}else this.root.style.display='none'}}const Pi=ti('d-hover-box',`
+
+
+