################################################################################ # Figures and figure source-data for the Nature Climate Change Analysis on # measurement documentation in natural-hazards adaptation research. # # INPUT (two CSVs in the working directory): # released_dataset_paper_level.csv study-level metadata + fields to code # released_dataset_theory_application_level.csv theory-application level (study x theory) # # To reproduce: complete the empty assessment fields in both files using the # published coding scheme (survey_instrument_level, theory_constructs_measured, # psychometric_quality, qualitative_validation, measurement_replicable), derive # measurement_documentation_level from the decision table in the scheme, then # run this script. Outputs are written to ./ncc_figures at 180 mm width. # # Requires R (>= 4.3) with ggplot2, dplyr, tidyr, stringr, forcats, scales, # patchwork and tibble; circlize and png are needed for Figure 1. ################################################################################ suppressPackageStartupMessages({ library(ggplot2); library(dplyr); library(tidyr); library(stringr) library(forcats); library(scales); library(patchwork); library(tibble) }) PAPER_PATH <- "released_dataset_paper_level.csv" # study-level metadata + fields to code LONG_PATH <- "released_dataset_theory_application_level.csv" # theory-application level (study x theory) # Figures are exported at 180 mm (Nature Climate Change double-column width). # Panels authored larger are scaled down to column width at typesetting. NCC_W180 <- 7.09 OUT <- "ncc_figures" dir.create(OUT, showWarnings = FALSE, recursive = TRUE) save_fig <- function(p, name, w, h) { ggsave(file.path(OUT, name), p, width = w, height = h, dpi = 300, bg = "white") message(" saved: ", name) } # ══════════════════════════════════════════════════════════════════════════════ # PALETTES # ══════════════════════════════════════════════════════════════════════════════ # Colour-blind-safe theory palette (CARTO "Safe" / Paul Tol-derived; separable # under deuteranopia, protanopia and tritanopia). Applied globally. PAL_THEORY <- c( PMT="#332288", PADM="#CC6677", TPB="#117733", Psychometric="#AA4499", CT="#DDCC77", RISP="#44AA99", EPPM="#882255", HBM="#88CCEE", EUT="#999933", SCT="#6699CC") CORE10 <- names(PAL_THEORY) PAL_INST <- c("1_Minimal"="#CCDDEE","2_Moderate"="#88BBDD","3_Detailed"="#3388AA","4_Complete"="#004466") PAL_PSYCH <- c("Not_Reported"="#BBBBBB","Poor"="#D55E00","Fair"="#E69F00","Good"="#56B4E9","Excellent"="#0072B2") # 4-level collapsed palette (Not_Reported + Poor = Inadequate) — used in Fig 5b & ED Fig 2 PAL_PSYCH_COL <- c("Inadequate"="#D55E00","Fair"="#E69F00","Good"="#56B4E9","Excellent"="#0072B2") PAL_REP <- c("No"="#D55E00","Partial"="#E69F00","Yes"="#0072B2") PAL_MDL <- c("Minimally Documented"="#D55E00","Partially Documented"="#E69F00","Well-Documented"="#0072B2") PAL_MULTI <- c("Single theory"="#9ECAE1","Multi-theory"="#CB181D") PAL_PIPE <- c("#DAE8F5","#B8D4EA","#7FB5D6","#4A92BF","#2B6F9E","#194F72") PAL_MEASURED <- c("Measured"="#2166AC","Not measured"="#F0F0F0") theme_ncc <- function(base = 9) { theme_minimal(base_size = base, base_family = "sans") %+replace% theme( plot.title = element_blank(), plot.subtitle = element_text(size = base - 0.5, color = "grey30", hjust = 0, margin = margin(b = 4)), axis.title = element_text(size = base - 0.5, color = "grey20"), axis.text = element_text(size = base - 1, color = "grey20"), axis.line = element_line(color = "grey40", linewidth = 0.3), axis.ticks = element_line(color = "grey40", linewidth = 0.3), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), legend.title = element_text(size = base - 1), legend.text = element_text(size = base - 1.5), legend.key.size = unit(0.3, "cm"), strip.text = element_text(size = base, face = "bold", hjust = 0), plot.margin = margin(4, 6, 4, 4), plot.background = element_rect(fill = "white", color = NA), panel.background = element_rect(fill = "white", color = NA)) } wilson_ci <- function(k, n) { if (n == 0) return(list(p = NA, lo = NA, hi = NA)) z <- qnorm(0.975); p <- k/n; d <- 1 + z^2/n c_ <- (p + z^2/(2*n))/d; h <- (z*sqrt(p*(1-p)/n + z^2/(4*n^2)))/d list(p = p, lo = max(0, c_ - h), hi = min(1, c_ + h)) } add_ci <- function(df, k_col, n_col) { cis <- mapply(wilson_ci, df[[k_col]], df[[n_col]], SIMPLIFY = FALSE) df$p <- sapply(cis, `[[`, "p") df$ci_lo <- sapply(cis, `[[`, "lo") df$ci_hi <- sapply(cis, `[[`, "hi") df } # Hazard recode. Operates on the harmonised label set (hazard_harmonised in the # v5 files). The residual "Other" bucket should now be empty: every label maps # to a named category, so anything landing in "Other" signals a new label that # needs a decision rather than a spelling variant. recode_hazard <- function(x) case_when( x %in% c("Flood","Coastal Flood","Flash Flood", "Glacial Lake Outburst Flood") ~ "Flood", x == "Earthquake" ~ "Earthquake", x == "Wildfire" ~ "Wildfire", x == "Hurricane" ~ "Hurricane", x == "Tropical Cyclone" ~ "Trop. Cyclone", x == "Tsunami" ~ "Tsunami", x == "Heatwave" ~ "Heatwave", x == "Drought" ~ "Drought", x == "Tornado" ~ "Tornado", x == "Landslide" ~ "Landslide", x == "Volcanic Hazard" ~ "Volcanic", x == "Cold Spell" ~ "Cold spell", x == "General Hazard" ~ "General Hazard", x %in% c("Storm","Hailstorm","Heavy Rainfall") ~ "Storm / Heavy rain", x %in% c("Sea Level Rise","Erosion") ~ "Coastal change", x %in% c("Geological Hazard","Mountain Hazard") ~ "Other geophysical", x %in% c("Climate Change","Climate change impacts", "Extreme weather events","Water Scarcity", "Biodiversity Loss") ~ "Climate change (general)", # Hazards outside the natural-hazard scheme that the corpus retains. Three of # the four COVID-19 studies and both fire studies are compound-event or # multi-hazard designs in which a natural hazard is also studied; keeping them # in a named category rather than folding them into "Other" makes the scope # decision visible to a reader. x %in% c("COVID-19","Air Pollution","Fire","Cyberdisaster") ~ "Other hazards", TRUE ~ "Other") read_clean <- function(path) { raw <- readLines(path, warn = FALSE) raw[1] <- sub("^\xEF\xBB\xBF", "", raw[1]) raw[1] <- sub("^\uFEFF", "", raw[1]) sep <- if (str_count(raw[1], "\t") > str_count(raw[1], ",")) "\t" else "," read.csv(textConnection(raw), stringsAsFactors = FALSE, quote = "\"", sep = sep, encoding = "UTF-8") } paper <- read_clean(PAPER_PATH) long <- read_clean(LONG_PATH) # Use the harmonised hazard labels when present, so every downstream hazard # count comes from one cleaned column. Falls back to hazard_corrected. use_harmonised <- function(df) { if ("hazard_harmonised" %in% names(df)) df$hazard_corrected <- ifelse(is.na(df$hazard_harmonised), df$hazard_corrected, df$hazard_harmonised) df } paper <- use_harmonised(paper) long <- use_harmonised(long) # Every harmonised label should map to a named category; "Other" now means an # unrecognised label has entered the data. unmapped <- unique(unlist(strsplit(as.character(paper$hazard_corrected), ";"))) unmapped <- trimws(unmapped[!is.na(unmapped) & trimws(unmapped) != ""]) unmapped <- unique(unmapped[recode_hazard(unmapped) == "Other"]) if (length(unmapped) > 0) warning("Unmapped hazard label(s): ", paste(unmapped, collapse = ", "), " - add to recode_hazard() before rendering.") if ("toolbox_potential" %in% names(paper)) paper$measurement_documentation_level <- dplyr::recode(paper$toolbox_potential, "High"="Well-Documented","Medium"="Partially Documented", "Low"="Minimally Documented", .default=NA_character_) if ("toolbox_potential" %in% names(long)) long$measurement_documentation_level <- dplyr::recode(long$toolbox_potential, "High"="Well-Documented","Medium"="Partially Documented", "Low"="Minimally Documented", .default=NA_character_) safe_logical <- function(x) { if (is.logical(x)) return(x) r <- suppressWarnings(as.logical(x)) if (all(is.na(r)) && !all(is.na(x))) r <- tolower(trimws(as.character(x))) == "true" r } paper$multi_theory <- safe_logical(paper$multi_theory) long$is_core <- safe_logical(long$is_core) # Derive collapsed psychometric column for both data frames. # Not_Reported + Poor -> "Inadequate"; Fair / Good / Excellent unchanged. # This matches the 4-level scheme used in the reliability analysis. collapse_psy_fn <- function(x) dplyr::case_when( x %in% c("Not_Reported", "Poor") ~ "Inadequate", x %in% c("Fair", "Good", "Excellent") ~ x, TRUE ~ NA_character_) paper <- paper %>% mutate(psychometric_quality_collapsed = collapse_psy_fn(psychometric_quality)) long <- long %>% mutate(psychometric_quality_collapsed = collapse_psy_fn(psychometric_quality)) # --- data integrity checks ------------------------------------------------- # (1) is_core is NA for a few rows; filter(is_core) drops them silently, so # they appear in neither the core bars nor the "Others" bar of Fig 1a. n_na_core <- sum(is.na(long$is_core)) if (n_na_core > 0) warning("is_core is NA for ", n_na_core, " rows (file_id ", paste(long$file_id[is.na(long$is_core)], collapse = ", "), "); these are excluded from BOTH the core and the Others bars.") # (2) distinct(file_id, theory_abbrev) keeps only the FIRST row per pair. Where # a paper has several coded rows for one theory with different construct # descriptions, the others are discarded rather than combined. dup_ft <- long %>% filter(is_core %in% TRUE) %>% count(file_id, theory_abbrev) %>% filter(n > 1) if (nrow(dup_ft) > 0) warning(nrow(dup_ft), " (file_id, theory) pairs have multiple coded rows ", "(file_id ", paste(unique(dup_ft$file_id), collapse = ", "), "); only the first construct description is used.") core <- long %>% filter(is_core) %>% distinct(file_id, theory_abbrev, .keep_all = TRUE) theory_n <- core %>% count(theory_abbrev, name = "n_papers") %>% arrange(desc(n_papers)) # ── Construct definitions ─────────────────────────────────────────────────── ################################################################################ # CONSTRUCT DEFINITIONS (regex) # # Patterns redesigned in v3 based on full inventory of coder language across all # 223 papers. Per user decisions (May 2026): # Q1: PADM "Threat appraisal" folded into Risk perception (not Threat assessment) # Q2: "protective action perception" added to Protective action # Q3: TPB elicitation beliefs added (salient advantages/disadvantages/referents) # Q4(a): Aggregate terms aggressively mapped (risk appraisal -> Risk perception, # coping appraisal -> Protective action / Self-efficacy) # Q5: Coder annotation rows ("not present", "ill defined", "not mapped") are # filtered out before regex matching (see is_coder_note() below) # # PMT also retains aggregate handling per methodological_report.docx: # "threat appraisal"/"risk appraisal" -> Perceived severity (primary representant) # "coping appraisal" -> Self-efficacy (avoid triple-count with response efficacy) ################################################################################ source_constructs <- list( PMT = list(pattern="Protection Motivation", core=c("Perceived severity","Perceived vulnerability","Self-efficacy","Response efficacy", "Response cost","Protection motivation","Fear / Worry"), items=c( "Perceived severity"="\\bseverity\\b|perceived severity|perceived consequence|perceived damage|severity of (threat|storm|hurricane|landslide)|perceived (future\\s+)?damage|perceived risk proximity|threat appraisal|risk appraisal|risk threat|threat assessment", "Perceived vulnerability"="vulnerability|susceptibility|perceived probability|perceived likelihood|perceived (future\\s+)?probability|\\bexposure\\b|perceived exposure", "Self-efficacy"="self.efficacy|self efficacy|coping appraisal|coping/adaptation appraisal|perceived preparedness|preparedness belief", "Response efficacy"="response efficacy|response-efficacy|perceived effectiveness|efficacy of measure|efficacy of (adaptation|protective|mitigation)", "Response cost"="response cost|response-cost|response costs|perceived cost|perceived costs|perceived barrier|\\beffort\\b|feasib", "Protection motivation"="protection motivation|protective intention|protective behavio|behavioral intention|behavioural intention|\\bintention\\b|adaptive behavio|adaption behaviour|protective action|protective response|protective measure|preventive response|\\badoption\\b|behavioral response|intended response|safety plan", "Fear / Worry"="\\bfear\\b|\\bworry\\b|\\bworries\\b|anxiety|\\bdread\\b|fear arousal|negative emotion|negative affect|positive affective", "Prior experience"="prior experience|past experience|flood experience|past behavior|past behaviour|personal experience|previous.{0,20}(experience|flood|hazard)", "Maladaptive coping"="fatalism|denial|wishful thinking|maladaptive|avoidance|non-protective|wishful|non protective")), PADM = list(pattern="Protective Action Decision", core=c("Risk perception","Protective action","Information seeking","Situational facilitators", "Hazard knowledge","Stakeholder perception"), items=c( "Risk perception"="risk perception|perceived risk|perceived flood|perceived exposure|perceived likelihood|perceived consequence|perceived damage|perceived vulnerability|perceived severity|perceived disruption|perceived storm|perceived hurricane|threat appraisal|risk appraisal|threat assessment|threat perception|affective risk|cognitive risk|risk to self|risk to others", "Protective action"="protective action|protective response|protective behavio|protective measure|protection motivation|evacuat|preparedness|\\badoption\\b|\\badopt\\b|mitigation|adaptive behavio|adaption behaviour|taking protective|preventive response|behavioral response|behavior response|intended response|intention to|safety plan|earthquake adjustment", "Information seeking"="information seek|seeking information|information source|information channel|information processing|hazard information|risk information|warning source|warning message|received.*warning|\\bwarning\\b|message credibility|\\bmessage\\b|environmental cue|social cue|decision cue|official cue|physical cue|\\bcues\\b|sense of being informed|perceived information credibility", "Situational facilitators"="situational facilitator|situational variable|situational factor|situational context|adaptive capacity|resource requirement|resource-related|household context|physical context|\\bimpediment\\b|evacuation impediment|\\bbarrier\\b|shelter", "Hazard knowledge"="hazard knowledge|hazard awareness|\\bknowledge\\b|\\bawareness\\b|\\bunderstanding\\b|subjective knowledge|knowledge efficacy|knowledge perception|location perception", "Stakeholder perception"="stakeholder perception|stakeholder|\\btrust\\b|responsibility|self.responsibility|individual responsibility|government responsibility|institutional context|trust in (federal|community|government|local)|social support|community connectedness|community homophily", "Prior experience"="prior experience|past experience|evacuation experience|past preparedness|flood experience|personal experience|previous.{0,20}(experience|flood|evacu|hurricane|hazard)", "Threat assessment"="threat assessment|threat appraisal|perceived efficacy|coping appraisal")), TPB = list(pattern="Planned Behav", core=c("Attitude","Subjective norm","Perceived behavioral control","Intention"), items=c( "Attitude"="\\battitude|attitude.{0,30}behavio|salient advantage|salient disadvantage|behavioral belief|behavioural belief|anticipated affect", "Subjective norm"="subjective norm|social norm|prescriptive norm|salient referent|normative belief|risk avoidance norm|perceived social norm|moral norm", "Perceived behavioral control"="perceived behavioral control|perceived behavioural control|behavioral control|behaviour.?al control|perceived control|\\bPBC\\b|salient circumstance|salient barrier|control belief", "Intention"="\\bintention\\b|behavioral intention|behavioural intention|intentions to|intention to|strength of intention|Public Readiness|\\bPRI\\b|adoption intention|preparedness intention|evacuation intention", "Risk perception"="risk perception|perceived risk|perceived severity|perceived vulnerability|perceived susceptibility|perceived risk proximity", "Self-efficacy"="self-efficacy|self efficacy", "Descriptive norm"="descriptive norm", "Moral norm"="moral norm")), Psychometric = list(pattern="Psychometric", core=c("Dread","Unknown risk","Controllability"), items=c( "Dread"="\\bdread\\b|dread risk|fear", "Unknown risk"="\\bunknown\\b|unfamili|newness|immediacy", "Controllability"="controllab|\\bcontrol\\b", "Knowledge"="\\bknowledge\\b|familiarity", "Catastrophic potential"="catastroph|widespread|catastrophism|generations|financial loss", "Worry"="\\bworry\\b|worries", "Voluntariness"="voluntar")), CT = list(pattern="Cultural Theory", core=c("Egalitarianism","Individualism","Fatalism","Hierarchy"), items=c("Egalitarianism"="egalitarian|communitarian|communitarianism|worldview", "Individualism"="individualis|worldview", "Fatalism"="fatalis|worldview","Hierarchy"="hierarch|grid|worldview")), RISP = list(pattern="Risk Information Seeking", core=c("Affective response","Information need","Information seeking","Systematic processing","Relevant channel beliefs"), items=c("Affective response"="affect|emotion|fear|positive affect|feared emotion|worry", "Information need"="information need|information sufficiency|information insufficiency", "Information seeking"="information seek|active.*seek|passive.*seek|seeking information", "Systematic processing"="systematic processing|processing", "Relevant channel beliefs"="channel|trust|source|message credibility", "Risk perception"="risk perception|risk belief|perceived hazard")), EPPM = list(pattern="Extended Parallel", core=c("Perceived susceptibility","Perceived severity","Self-efficacy","Response efficacy", "Fear","Danger control","Fear control"), items=c("Perceived susceptibility"="susceptibility|likelihood|vulnerability", "Perceived severity"="severity", "Self-efficacy"="self-efficacy|self efficacy", "Response efficacy"="response efficacy", "Fear"="fear|worry|dread|affective response|negative personal experience", "Danger control"="danger control", "Fear control"="fear control|maladaptive response")), HBM = list(pattern="Health Belief", core=c("Perceived susceptibility","Perceived severity","Perceived benefits","Perceived barriers","Cues to action"), items=c("Perceived susceptibility"="susceptibility|vulnerability|likelihood", "Perceived severity"="severity|seriousness", "Perceived benefits"="benefit","Perceived barriers"="barrier", "Cues to action"="cues to action|cue", "Self-efficacy"="self-efficacy|self efficacy")), EUT = list(pattern="Expected Utility|\\bEUT\\b", core=c("Subjective probability","Expected loss/utility"), items=c("Subjective probability"="probability|subjective probability|likelihood|probability misperception", "Expected loss/utility"="utility|expected loss|expected damage|subjective utility|time preferences", "Risk aversion"="risk avers|risk attitude", "Wealth / income"="wealth|income|budget")), SCT = list(pattern="Social Cognitive", core=c("Self-efficacy","Outcome expectations","Observational learning","Collective efficacy"), items=c("Self-efficacy"="self-efficacy|self efficacy|behavioral capability|confidence in capacity", "Outcome expectations"="outcome expectat|response efficacy|DRR behaviors|behavioral intention", "Observational learning"="observational|social learning|vicarious", "Collective efficacy"="collective efficacy", "Risk appraisal"="risk appraisal|risk perception|coping appraisal")) ) # Filter helper: identify coder-annotation rows (not actual construct lists) # Excluded BEFORE regex matching to prevent inflated "zero-match" counts is_coder_note <- function(text) { if (is.na(text)) return(TRUE) s <- tolower(trimws(as.character(text))) note_phrases <- c("not present", "not mapped", "ill defined", "ill-defined", "no clear description", "no clear constructs", "not formalised", "not formalized") any(sapply(note_phrases, function(p) grepl(p, s, fixed = TRUE))) || nchar(s) < 10 } detect_constructs <- function() { rows <- list() for (th in names(source_constructs)) { info <- source_constructs[[th]] # Harmonised to the long per-theory source (same unit as the UpSet # figures): one row per (paper, theory), so denominators and rates # match Fig 4 / ED Fig 7 rather than the consolidated paper-level blob. paps <- long[long$theory_abbrev == th & !is.na(long$theory_constructs_measured), ] paps <- paps[!duplicated(paps$file_id), ] # Drop coder annotation rows paps <- paps[!sapply(paps$theory_constructs_measured, is_coder_note), ] n_total <- nrow(paps); if (n_total < 3) next for (con in names(info$items)) { n_hit <- sum(grepl(paste0("(?i)", info$items[[con]]), paps$theory_constructs_measured, perl = TRUE)) ci <- wilson_ci(n_hit, n_total) rows[[length(rows)+1]] <- data.frame( theory = th, construct = con, n_hit = n_hit, n_total = n_total, p = ci$p, ci_lo = ci$lo, ci_hi = ci$hi, is_core = con %in% info$core, stringsAsFactors = FALSE) } } bind_rows(rows) } cdf <- detect_constructs() # Apply 5% threshold globally for Fig 3 + ED Fig 4 cdf_filtered <- cdf %>% filter(p >= 0.05) dropped_constructs <- cdf %>% filter(p < 0.05) if (nrow(dropped_constructs) > 0) { cat("\n--- Constructs dropped (<5% of papers) ---\n") print(dropped_constructs %>% select(theory, construct, n_hit, n_total, p)) cat("\n") } cat("Ready:", nrow(paper), "papers,", nrow(cdf), "construct rows (", nrow(cdf_filtered), "after >=5% filter)\n") ################################################################################ # MAIN TEXT FIG 1 — Theory landscape ################################################################################ # CAPTION # Figure 1 | The theory landscape of disaster risk research. # (a) Frequency of the ten core theoretical frameworks across N = 222 studies, # with the 47 non-core frameworks collapsed into a single "Others" category. # Bars show the number of studies applying each framework. Bars are NOT # mutually exclusive: a study applying two frameworks enters both bars, so the # bars sum to more than 223 and the percentages to more than 100%. each bar is split by # shade into single-theory (darker) and multi-theory (lighter) studies, and # labels give the count and percentage of the corpus. (b) Co-occurrence of the # core frameworks: chord diagram in which ribbon width is proportional to the # number of papers jointly applying each pair of frameworks (rendered with # circlize and saved separately as Fig1b_cooccurrence_chord.png; see note). # The temporal share of frameworks and the Shannon diversity of framework use # over time are provided in the Extended Data (ED Fig. 2 / ED Fig. 3). ################################################################################ message("NCC Fig 1 (theory landscape) ...") # --- Panel A data: core theories + collapsed "Others", split single/multi ----- # Counting unit: distinct (file_id, theory_abbrev), consistent with Fig 2/3/4/6. # Single vs multi comes from the paper-level multi_theory flag (joined by # file_id), so a paper using >1 theory is "Multi-theory" in every bar it enters. mt_flag <- paper %>% distinct(file_id, multi_theory) core_ab <- core %>% distinct(file_id, theory_abbrev) %>% left_join(mt_flag, by = "file_id") %>% mutate(theory_group = theory_abbrev) others_ab <- long %>% filter(!is_core) %>% distinct(file_id, theory_abbrev) %>% # the 49 non-core frameworks distinct(file_id) %>% # collapse to one row per paper left_join(mt_flag, by = "file_id") %>% mutate(theory_group = "Others") fig1a_long <- bind_rows( core_ab %>% select(file_id, theory_group, multi_theory), others_ab %>% select(file_id, theory_group, multi_theory)) %>% mutate(type = if_else(multi_theory, "Multi-theory", "Single theory")) grp_tot <- fig1a_long %>% count(theory_group, name = "n_papers") %>% mutate(total = nrow(paper), pct = n_papers / total * 100, label = paste0(n_papers, " (", round(pct), "%)")) seg_df <- fig1a_long %>% count(theory_group, type, name = "n") %>% left_join(grp_tot %>% select(theory_group, n_papers), by = "theory_group") # Order by total (desc on the axis), with "Others" pinned to the bottom row. lev <- grp_tot %>% filter(theory_group != "Others") %>% arrange(n_papers) %>% pull(theory_group) lev <- c("Others", lev) seg_df$theory_group <- factor(seg_df$theory_group, levels = lev) grp_tot$theory_group <- factor(grp_tot$theory_group, levels = lev) seg_df$type <- factor(seg_df$type, levels = c("Single theory", "Multi-theory")) # Recolour: two shades of ONE hue (replaces the rejected per-theory rainbow) and # simultaneously encodes single- vs multi-theory studies (folds in old panel c). PAL_A_SHADE <- c("Single theory" = "#2166AC", "Multi-theory" = "#9ECAE1") # Total labels: INSIDE the bar for the two dominant frameworks (PMT, PADM) to # cut white space; just OUTSIDE the bar end for the shorter frameworks. X_CAP <- 90 lab_in <- grp_tot %>% filter(theory_group %in% c("PMT", "PADM")) lab_out <- grp_tot %>% filter(!theory_group %in% c("PMT", "PADM")) p1a <- ggplot(seg_df, aes(x = n, y = theory_group, fill = type)) + geom_col(width = 0.72, color = "white", linewidth = 0.2, position = position_stack(reverse = TRUE)) + # Single (dark) at left geom_text(data = lab_in, aes(x = n_papers, y = theory_group, label = label), inherit.aes = FALSE, hjust = 1.08, size = 4.2, fontface = "bold", color = "grey15") + # inside, on light segment geom_text(data = lab_out, aes(x = n_papers, y = theory_group, label = label), inherit.aes = FALSE, hjust = -0.12, size = 4.2, fontface = "bold", color = "grey15") + scale_fill_manual(values = PAL_A_SHADE, name = NULL) + scale_x_continuous(limits = c(0, X_CAP), breaks = seq(0, X_CAP, 30), expand = expansion(mult = c(0, 0.02))) + labs(x = paste0("Studies (N = ", nrow(paper), ")"), y = NULL, subtitle = "a Theory frequency") + theme_ncc(base = 12) + # larger labels throughout theme(plot.subtitle = element_text(size = 15, face = "bold", color = "grey15"), axis.text.y = element_text(size = 12), axis.text.x = element_text(size = 10.5), axis.title.x = element_text(size = 11.5), legend.position = c(0.98, 0.04), # bottom-right of panel a legend.justification = c(1, 0), legend.background = element_rect(fill = alpha("white", 0.85), color = NA), legend.text = element_text(size = 11), legend.key.size = unit(0.42, "cm")) # Panel c is folded into panel a. Panel b (the chord) is rendered first as a # standalone PNG (circlize draws with base graphics), then read back and # composed with panel a into a single two-panel Figure 1 below. # --- Panel B: theory co-occurrence chord diagram ----------------------------- # Ribbon width = number of papers jointly applying a pair of core frameworks. # Rendered with circlize (base graphics) and saved separately, because a base- # graphics chord cannot be composed into the patchwork layout with panel a. # Guarded by requireNamespace() so the script still runs if circlize is absent. cooc <- core %>% distinct(file_id, theory_abbrev) %>% filter(theory_abbrev %in% CORE10) %>% group_by(file_id) %>% filter(n() >= 2) %>% summarise(pairs = list(t(combn(sort(theory_abbrev), 2))), .groups = "drop") if (nrow(cooc) > 0 && requireNamespace("circlize", quietly = TRUE)) { edges <- as.data.frame(do.call(rbind, cooc$pairs), stringsAsFactors = FALSE) %>% setNames(c("from", "to")) %>% count(from, to, name = "value") png(file.path(OUT, "Fig1b_cooccurrence_chord.png"), width = 6.5, height = 6.5, units = "in", res = 300, bg = "white") circlize::circos.clear() # Expand the canvas so the enlarged, rotated sector names have room and are not # clipped at the PNG edge (long labels like "Psychometric"/"PADM" overflowed). circlize::circos.par(canvas.xlim = c(-1.55, 1.55), canvas.ylim = c(-1.55, 1.55), start.degree = 90) circlize::chordDiagram(edges, grid.col = PAL_THEORY[CORE10], annotationTrack = "grid", preAllocateTracks = list(track.height = 0.12)) # Draw sector (theory) names in a custom outer track so their size is # controllable; the default "name" track ignores cex. Larger, rotated labels # placed just outside the ring (ylim[1]). circlize::circos.trackPlotRegion( track.index = 1, bg.border = NA, panel.fun = function(x, y) { circlize::circos.text( circlize::CELL_META$xcenter, circlize::CELL_META$ylim[1], circlize::CELL_META$sector.index, facing = "clockwise", niceFacing = TRUE, adj = c(0, 0.5), cex = 1.2) }) circlize::circos.clear(); dev.off() message(" saved: Fig1b_cooccurrence_chord.png") } else { message(" [Fig 1b] circlize not installed - chord diagram skipped. ", "Install with install.packages('circlize') to render Panel B.") } # --- Compose Figure 1 as a single two-panel figure (a: bars, b: chord) ------- # The chord PNG is read back as a raster grob so both panels sit in one file, # as required for a single display item. Requires the 'png' package. chord_path <- file.path(OUT, "Fig1b_cooccurrence_chord.png") if (file.exists(chord_path) && requireNamespace("png", quietly = TRUE)) { chord_img <- png::readPNG(chord_path) p1b <- ggplot() + annotation_custom(grid::rasterGrob(chord_img, interpolate = TRUE)) + labs(subtitle = "b Theory co-occurrence") + theme_void(base_size = 10) + theme(plot.subtitle = element_text(size = 15, face = "bold", color = "grey15"), plot.margin = margin(2, 2, 2, 2)) ncc_fig1 <- p1a + p1b + plot_layout(widths = c(1.15, 1)) save_fig(ncc_fig1, "Fig1_theory_landscape.png", 12.5, 6.0) } else { message(" [Fig 1] 'png' package or chord PNG unavailable - saving panel a alone.") save_fig(p1a, "Fig1_theory_landscape.png", 8.5, 6.0) } # --- Extended Data (moved out of main Fig 1) --------------------------------- # ED Fig 1b: temporal share of frameworks (formerly main Fig 1 panel b). Moved # here because it shows no meaningful temporal pattern for the main figure. year_theory <- core %>% filter(year >= 2010, year <= 2024) %>% count(year, theory_abbrev, name = "n") %>% complete(year, theory_abbrev = CORE10, fill = list(n = 0)) %>% group_by(year) %>% mutate(pct = n / sum(n)) %>% ungroup() %>% mutate(theory_abbrev = factor(theory_abbrev, levels = rev(CORE10))) year_totals <- core %>% filter(year >= 2010, year <= 2024) %>% distinct(file_id, year) %>% count(year) max_t <- max(year_totals$n); sf <- 1 / max_t ed_fig1b <- ggplot() + geom_col(data = year_theory, aes(x = year, y = pct, fill = theory_abbrev), width = 0.8, color = "white", linewidth = 0.12) + geom_line(data = year_totals, aes(x = year, y = n * sf), color = "grey25", linewidth = 0.7) + geom_point(data = year_totals, aes(x = year, y = n * sf), color = "grey25", size = 1.3) + scale_fill_manual(values = PAL_THEORY, name = NULL, guide = guide_legend(reverse = TRUE, ncol = 2)) + scale_x_continuous(breaks = seq(2010, 2024, 2)) + scale_y_continuous(labels = percent_format(1), expand = expansion(mult = c(0, 0.05)), sec.axis = sec_axis(~ . / sf, name = "Total papers", breaks = seq(0, max_t, 5))) + labs(x = NULL, y = "Share", subtitle = "Framework share over time") + theme_ncc(base = 10) + theme(axis.text.x = element_text(angle = 45, hjust = 1, size = 8), legend.position = c(0.02, 0.98), legend.justification = c(0, 1), legend.background = element_rect(fill = alpha("white", 0.85), color = NA), legend.key.size = unit(0.28, "cm"), legend.text = element_text(size = 7.5), plot.subtitle = element_text(size = 12, face = "bold"), axis.title.y.right = element_text(size = 8.5, color = "grey40"), axis.text.y.right = element_text(size = 7.5, color = "grey40")) save_fig(ed_fig1b, "ED_Fig2_theory_share_over_time_180mm.png", NCC_W180, 4.2) # ED Fig 1c: framework diversification over time, expressed as the effective # number of theories exp(H) (Hill number of order 1) per publication period. # Period-level aggregation avoids the small-sample bias of annual Shannon # estimates (early years contribute < 10 applications each), and exp(H) reads # directly as "the field behaves as if N frameworks were in active use". eff_n <- function(x) { pr <- x / sum(x); exp(-sum(pr * log(pr))) } div_df <- bind_rows( long %>% mutate(set = "All frameworks (59)"), long %>% filter(is_core) %>% mutate(set = "Core theories (10)")) %>% filter(!is.na(year)) %>% mutate(period = cut(year, breaks = c(-Inf, 2016, 2020, Inf), labels = c("≤2016", "2017–2020", "2021–2025"))) %>% count(set, period, theory_full, name = "n") %>% group_by(set, period) %>% summarise(effN = eff_n(n), napps = sum(n), .groups = "drop") ed_fig1c <- ggplot(div_df, aes(x = period, y = effN, group = set, color = set)) + geom_line(linewidth = 0.8) + geom_point(size = 2.4) + geom_text(aes(label = sprintf("%.1f", effN)), vjust = -1.1, size = 3, show.legend = FALSE) + scale_color_manual(values = c("All frameworks (59)" = "#2166AC", "Core theories (10)" = "#B2182B"), name = NULL) + scale_y_continuous(limits = c(0, 16), expand = expansion(mult = c(0, 0.05))) + labs(x = NULL, y = "Effective number of theories, exp(H)", subtitle = "Framework diversity by publication period") + theme_ncc(base = 11) + theme(plot.subtitle = element_text(size = 12.5, face = "bold"), legend.position = "bottom") save_fig(ed_fig1c, "ED_Fig3_theory_diversity_180mm.png", NCC_W180, 4.3) ################################################################################ # MAIN TEXT FIG 2 — Theory-hazard heatmap ################################################################################ # CAPTION # Figure 2 | Distribution of theory applications across natural hazards. # (a) All studies (N = 222). Each cell shows the number of studies applying a # given theory to a given hazard; em dashes indicate zero studies. (b) Subset # of papers classified as Well-Documented under our rule-based MDL criteria, # using identical theory and hazard ordering. Cell colour intensity scales # with absolute count. ################################################################################ message("NCC Fig 2 ...") MAJOR_HAZARDS <- c("Flood","Earthquake","Wildfire","Hurricane", "Trop. Cyclone","Tsunami","Heatwave","Drought") # v5: theory assignment now uses the core (is_core) long table — distinct # (file_id, theory_abbrev) — so Fig 2 is consistent with Fig 1/3/4/6 rather than # re-deriving theories from the raw_theories blob. Hazard is still counted by # token membership across a paper's (possibly multi-hazard) hazard_corrected # string. Input is a vector of file_ids defining the subset. build_heatmap_data <- function(file_ids) { sub <- core %>% filter(file_id %in% file_ids, theory_abbrev %in% names(source_constructs)) rows <- list() for (i in seq_len(nrow(sub))) { r <- sub[i, ] if (is.na(r$hazard_corrected)) next th_s <- r$theory_abbrev for (hz in trimws(unlist(strsplit(as.character(r$hazard_corrected), ";")))) { hz_s <- recode_hazard(hz) if (hz_s %in% MAJOR_HAZARDS) rows[[length(rows)+1]] <- data.frame( theory = th_s, hazard = hz_s, stringsAsFactors = FALSE) } } if (length(rows) == 0) return(tibble(theory = character(), hazard = character(), n = integer())) bind_rows(rows) %>% count(theory, hazard) } hm_all <- build_heatmap_data(paper$file_id) th_order <- hm_all %>% group_by(theory) %>% summarise(total = sum(n)) %>% arrange(total) %>% pull(theory) # Order hazard columns by the number of STUDIES (not theory applications), so # the column order matches the hazard counts quoted in the Results. Ordering by # applications put wildfire ahead of earthquake, contradicting the text. hz_study_n <- paper %>% filter(!is.na(hazard_corrected)) %>% transmute(file_id, hz = strsplit(as.character(hazard_corrected), ";")) %>% tidyr::unnest(hz) %>% mutate(hz = recode_hazard(trimws(hz))) %>% filter(hz %in% MAJOR_HAZARDS) %>% distinct(file_id, hz) %>% count(hz, name = "n_studies") hz_order <- hz_study_n %>% arrange(desc(n_studies)) %>% pull(hz) hm_all <- hm_all %>% complete(theory = th_order, hazard = hz_order, fill = list(n = 0)) %>% mutate(theory = factor(theory, levels = th_order), hazard = factor(hazard, levels = hz_order)) n_max <- max(hm_all$n) # [FIX, not part of the cosmetic revision] well_ids / hm_well are used by Fig 2b # below but were never defined in v13, so the script halted at Fig 2. Restored to # the obviously intended value: the Well-Documented subset (matches panel-b label). well_ids <- paper %>% filter(measurement_documentation_level == "Well-Documented") %>% pull(file_id) hm_well <- build_heatmap_data(well_ids) %>% complete(theory = th_order, hazard = hz_order, fill = list(n = 0)) %>% mutate(theory = factor(theory, levels = th_order), hazard = factor(hazard, levels = hz_order)) # show_y_labels: FALSE drops the theory row labels (PMT, PADM, ...) since # panel b shares identical row order with panel a — printing them twice was # redundant (mb's comment). y_title: axis title text, shown only where # show_y_labels = TRUE (i.e. once, on panel a). make_heatmap <- function(data, n_max_val, sub_label, show_y_labels = TRUE, y_title = NULL) { ggplot(data, aes(x = hazard, y = theory, fill = n)) + geom_tile(color = "white", linewidth = 0.5) + geom_text(data = data %>% filter(n > 0), aes(label = n, color = ifelse(n > n_max_val * 0.4, "white", "grey20")), size = 3.9, fontface = "bold") + geom_text(data = data %>% filter(n == 0), aes(label = "\u2014"), color = "#C0A0A0", size = 3.9) + scale_color_identity() + scale_fill_gradientn( colors = c("#F5EDED", "#CCDDEE", "#6699CC", "#336699", "#002244"), values = rescale(c(0, 1, 5, 15, max(n_max_val, 1))), limits = c(0, n_max_val), name = "n") + labs(x = "Hazard", y = y_title, subtitle = sub_label) + theme_ncc() + theme(axis.text.x = element_text(angle = 35, hjust = 1, size = 10), axis.title.x = element_text(size = 10, face = "bold"), axis.text.y = if (show_y_labels) element_text(size = 10) else element_blank(), axis.ticks.y = if (show_y_labels) element_line(color = "grey40", linewidth = 0.3) else element_blank(), axis.title.y = if (show_y_labels) element_text(size = 10, face = "bold") else element_blank(), axis.line = element_blank(), plot.subtitle = element_text(size = 10.5, face = "bold")) } p2a <- make_heatmap( hm_all, n_max, "a All studies", y_title = "Theory" ) p2b <- make_heatmap( hm_well, n_max, paste0("b Well-documented (n = ", length(well_ids), ")"), show_y_labels = FALSE ) + theme(legend.position = "none") # One shared legend, collected and placed to the right of the whole figure # (was sitting between panels a and b); panel b's row labels + y-axis title # dropped (identical order to panel a); x-axis title "Hazard" on both panels. ncc_fig2 <- (p2a | p2b) + plot_layout(guides = "collect") & theme(legend.position = "right") save_fig(ncc_fig2, "Fig2_theory_hazard_180mm.png", NCC_W180, 3.9) ################################################################################ # MAIN TEXT FIG 3 — Construct operationalization (10-panel) [<5% filtered] ################################################################################ # CAPTION # Figure 3 | Operationalisation of theoretical constructs across the literature. # For each of the ten core theories, points show the proportion of papers # applying that theory which measured each canonical construct; horizontal # bars indicate Wilson 95% confidence intervals. Filled circles denote core # constructs (defined in foundational theoretical literature); open diamonds # denote extended constructs. Numbers next to each point indicate raw count # of papers measuring the construct. Constructs measured in fewer than 5% # of papers applying the theory are omitted. Theory abbreviations: PMT, # Protection Motivation Theory; PADM, Protective Action Decision Model; TPB, # Theory of Planned Behaviour; Psychometric, Psychometric Paradigm; CT, # Cultural Theory of Risk; RISP, Risk Information Seeking and Processing model; # EPPM, Extended Parallel Process Model; HBM, Health Belief Model; EUT, # Expected Utility Theory; SCT, Social Cognitive Theory. ################################################################################ message("NCC Fig 3 (10-panel, >=5%) ...") make_panel_10 <- function(th) { d <- cdf_filtered %>% filter(theory == th) if (nrow(d) == 0) return(ggplot() + theme_void() + labs(subtitle = paste0(th, " (no constructs >=5%)"))) n_tot <- d$n_total[1]; th_col <- PAL_THEORY[th] d_ext <- d %>% filter(!is_core) %>% arrange(p) d_core <- d %>% filter(is_core) %>% arrange(p) d <- bind_rows(d_ext, d_core) d$construct <- factor(d$construct, levels = d$construct) ggplot(d, aes(x = p, y = construct)) + geom_segment(aes(x = 0, xend = p, yend = construct), color = "grey85", linewidth = 0.4) + geom_errorbarh(aes(xmin = ci_lo, xmax = ci_hi), # Wilson 95% CI (visible) height = 0.30, linewidth = 0.5, color = th_col, alpha = 0.9) + geom_point(data = d %>% filter(is_core), shape = 16, size = 2.5, color = th_col, alpha = 0.85) + geom_point(data = d %>% filter(!is_core), shape = 5, size = 2.5, color = th_col, stroke = 0.8, alpha = 0.75) + geom_text(aes(x = ci_hi, label = n_hit), hjust = -0.5, size = 1.8, color = "grey30") + labs(subtitle = paste0(th, " (n = ", n_tot, ")"), x = NULL, y = NULL) + scale_x_continuous(limits = c(-0.03, 1.18), breaks = c(0, .25, .5, .75, 1), labels = percent_format(1), expand = c(0, 0)) + theme_ncc(base = 6.5) + theme(plot.subtitle = element_text(size = 7, face = "bold", color = "black"), axis.text.y = element_text(size = 5.5, color = "black"), axis.text.x = element_text(size = 5), plot.margin = margin(1, 4, 1, 1)) } panels_10 <- setNames(lapply(names(source_constructs), make_panel_10), names(source_constructs)) ncc_fig3_10 <- wrap_plots( panels_10[c("PMT","PADM","TPB","Psychometric","CT","RISP","EPPM","HBM","EUT","SCT")], ncol = 2) + plot_annotation( caption = paste0("Filled circle (\u25CF) = core construct. ", "Hollow diamond (\u25C7) = extended construct. ", "Error bars: Wilson 95% CI. ", "Constructs measured by <5% of papers omitted.\n", "PMT, Protection Motivation Theory; PADM, Protective Action Decision Model; ", "TPB, Theory of Planned Behaviour; Psychometric, Psychometric Paradigm; ", "CT, Cultural Theory of Risk; RISP, Risk Information Seeking and Processing model; ", "EPPM, Extended Parallel Process Model; HBM, Health Belief Model; ", "EUT, Expected Utility Theory; SCT, Social Cognitive Theory."), theme = theme(plot.caption = element_text(size = 7, color = "grey40", hjust = 0, lineheight = 1.15), plot.margin = margin(6, 6, 6, 6))) ncc_fig3_10 <- ncc_fig3_10 + plot_annotation( caption = paste(strwrap(paste0( "Filled circle = core construct. Hollow diamond = extended construct. ", "Error bars: Wilson 95% CI. Constructs measured by <5% of studies omitted. ", "PMT, Protection Motivation Theory; PADM, Protective Action Decision Model; ", "TPB, Theory of Planned Behaviour; Psychometric, Psychometric Paradigm; ", "CT, Cultural Theory of Risk; RISP, Risk Information Seeking and Processing ", "model; EPPM, Extended Parallel Process Model; HBM, Health Belief Model; ", "EUT, Expected Utility Theory; SCT, Social Cognitive Theory."), width = 120), collapse = "\n"), theme = theme(plot.caption = element_text(size = 7, color = "grey40", hjust = 0, lineheight = 1.15))) save_fig(ncc_fig3_10, "Fig3_constructs_10panel.png", 8.27, 11.69) ################################################################################ # MAIN TEXT FIG 3 — 6-panel version ################################################################################ # CAPTION (Fig 3 shorter) # Figure 3 | Construct operationalisation for the six theories discussed in # the Results. NOTE: this is NOT the six most-applied theories - Cultural # Theory (n = 9) is more frequently applied than EPPM (n = 7). The selection is # by what the Results discuss, and the caption must say so. # As Figure 3 (10-panel) but limited to: Protection Motivation Theory (PMT), Protective Action Decision # Model (PADM), Theory of Planned Behaviour (TPB), Extended Parallel Process # Model (EPPM), the Psychometric Paradigm, and the Risk Information Seeking and # Processing model (RISP). # Constructs measured by fewer than 5% of papers applying each theory are # omitted. Filled circles = core constructs; open diamonds = extended # constructs. Error bars: Wilson 95% CI. ################################################################################ message("NCC Fig 3 (6-panel, >=5%) ...") make_panel_6 <- function(th) { d <- cdf_filtered %>% filter(theory == th) if (nrow(d) == 0) return(ggplot() + theme_void() + labs(subtitle = paste0(th, " (no constructs >=5%)"))) n_tot <- d$n_total[1]; th_col <- PAL_THEORY[th] d_ext <- d %>% filter(!is_core) %>% arrange(p) d_core <- d %>% filter(is_core) %>% arrange(p) d <- bind_rows(d_ext, d_core) d$construct <- factor(d$construct, levels=d$construct) ggplot(d, aes(x=p, y=construct)) + geom_segment(aes(x=0, xend=p, yend=construct), color="grey85", linewidth=0.4) + geom_errorbarh(aes(xmin=ci_lo, xmax=ci_hi), height=0.32, linewidth=0.6, # Wilson 95% CI (visible) color=th_col, alpha=0.9) + geom_point(data=d %>% filter(is_core), shape=16, size=3, color=th_col, alpha=0.85) + geom_point(data=d %>% filter(!is_core), shape=5, size=3, color=th_col, stroke=0.8, alpha=0.75) + geom_text(aes(x=ci_hi, label=n_hit), hjust=-0.5, size=3.2, color="grey30") + labs(subtitle=paste0(th, " (n = ", n_tot, ")"), x=NULL, y=NULL) + scale_x_continuous(limits=c(-0.03,1.22), breaks=c(0,.25,.5,.75,1), labels=percent_format(1), expand=c(0,0)) + theme_ncc(base = 9.5) + theme(plot.subtitle = element_text(size = 11, face = "bold", color = "black"), axis.text.y = element_text(size = 9.5, color = "black"), axis.text.x = element_text(size = 9), plot.margin = margin(2, 6, 2, 2)) } panels_6 <- setNames(lapply(names(source_constructs), make_panel_6), names(source_constructs)) MAIN_THEORIES <- c("PMT","PADM","TPB","EPPM","Psychometric","RISP") # Caption built and wrapped BEFORE it reaches plot_annotation: the unwrapped # string ran off the right edge of the exported PNG in v8. cap6 <- paste0( "Filled circle = core construct. Hollow diamond = extended construct. ", "Error bars: Wilson 95% CI. Constructs measured by <5% of studies omitted. ", "PMT, Protection Motivation Theory; PADM, Protective Action Decision Model; ", "TPB, Theory of Planned Behaviour; EPPM, Extended Parallel Process Model; ", "Psychometric, Psychometric Paradigm; RISP, Risk Information Seeking and ", "Processing model.") cap6 <- paste(strwrap(cap6, width = 110), collapse = "\n") ncc_fig3 <- wrap_plots(panels_6[MAIN_THEORIES], ncol = 2) + plot_annotation( caption = cap6, theme = theme(plot.caption = element_text(size = 8.5, color = "grey40", hjust = 0, lineheight = 1.15), plot.margin = margin(6, 6, 6, 6))) save_fig(ncc_fig3, "Fig3_constructs_shorter_180mm.png", NCC_W180, 7.7) ################################################################################ # Generic UpSet builder (used by Fig 4 main + ED Fig 7a/b/c) # Sorted by combination frequency (n) descending ################################################################################ build_upset_data <- function(theory_abbrev_target, cons_patterns) { sub <- long %>% filter(theory_abbrev == theory_abbrev_target, !is.na(theory_constructs_measured)) %>% distinct(file_id, .keep_all = TRUE) # v3: filter coder annotation rows before construct matching sub <- sub[!sapply(sub$theory_constructs_measured, is_coder_note), ] for (con in names(cons_patterns)) { sub[[con]] <- grepl(paste0("(?i)", cons_patterns[[con]]), sub$theory_constructs_measured, perl = TRUE) } sub } make_upset_figure <- function(data_in, cons_patterns, theory_color = "#2166AC", complete_color = "#B2182B", panel_widths = c(2.0, 3.0), side_label_size = 2.5, name_size = 8.5) { N_TOTAL <- nrow(data_in) if (N_TOTAL == 0) return(list(plot = ggplot() + theme_void(), n = 0)) # --------------------------------------------------------------------------- # Combination frequencies # --------------------------------------------------------------------------- combo_counts <- data_in %>% group_by(across(all_of(names(cons_patterns)))) %>% summarise(n = n(), .groups = "drop") %>% mutate(n_cons = rowSums(across(all_of(names(cons_patterns))))) %>% arrange(desc(n), desc(n_cons)) %>% mutate(combo_id = row_number()) # --------------------------------------------------------------------------- # Overall construct coverage # --------------------------------------------------------------------------- cons_rates <- sapply(names(cons_patterns), function(c) mean(data_in[[c]])) cons_sorted <- names(sort(cons_rates, decreasing = TRUE)) # --------------------------------------------------------------------------- # Matrix data # --------------------------------------------------------------------------- mat_df <- combo_counts %>% select(combo_id, n_cons, all_of(names(cons_patterns))) %>% pivot_longer(cols = all_of(names(cons_patterns)), names_to = "construct", values_to = "measured") %>% mutate(construct = factor(construct, levels = rev(cons_sorted))) # --------------------------------------------------------------------------- # Highlight the fully complete combination # --------------------------------------------------------------------------- n_all <- length(cons_patterns) combo_counts$fill <- ifelse( combo_counts$n_cons == 0, "#BBBBBB", ifelse(combo_counts$n_cons == n_all, complete_color, theory_color) ) # --------------------------------------------------------------------------- # Connecting lines in the matrix # --------------------------------------------------------------------------- line_df <- mat_df %>% filter(measured) %>% group_by(combo_id, n_cons) %>% summarise(y_min = min(as.integer(construct)), y_max = max(as.integer(construct)), n_meas = n(), .groups = "drop") %>% filter(n_meas >= 2) %>% mutate(fill = ifelse(n_cons == 0, "#BBBBBB", theory_color)) mat_df <- mat_df %>% left_join(combo_counts %>% select(combo_id, fill), by = "combo_id") X_LIMITS <- c(0.5, nrow(combo_counts) + 0.5) Y_EXPAND <- 0.04 combo_counts$label_colour <- ifelse(combo_counts$n >= 2, "#0d2640", "#555555") combo_counts$label_face <- ifelse(combo_counts$n >= 2, "bold", "plain") # ========================================================================== # TOP: combination-frequency bars # ========================================================================== p_top <- ggplot(combo_counts, aes(x = combo_id, y = n, fill = I(fill))) + geom_col(width = 0.68, colour = "white", linewidth = 0.25) + geom_text(aes(label = n, colour = I(label_colour), fontface = I(label_face)), vjust = -0.35, size = 2.8) + # 3.15->2.8: keep labels from touching in dense combo runs after the right column narrows scale_x_continuous( limits = X_LIMITS, expand = expansion(mult = c(0, 0.008)) ) + # Only modest headroom is needed for the count labels. scale_y_continuous( limits = c(0, max(combo_counts$n) * 1.20), breaks = pretty(c(0, max(combo_counts$n)), 5), expand = expansion(mult = c(0.02, 0)) # small lower pad so the "0" baseline label isn't clipped ) + coord_cartesian(clip = "off") + labs( x = NULL, y = "Studies sharing\nthis combination", subtitle = str_wrap( paste0( sum(combo_counts$n_cons == length(cons_patterns)), " of ", nrow(combo_counts), " combinations is complete (red); ", sum(combo_counts$n == 1), " are used by a single study" ), 40 # tighter wrap so the subtitle line fits the top cell ) ) + theme_ncc(base = 10) + theme( axis.text.x = element_blank(), axis.ticks.x = element_blank(), axis.line.x = element_blank(), # Keep enough left room for the rotated two-line title. axis.title.y = element_text( size = 10.2, colour = "grey25", margin = margin(r = 3) ), axis.text.y = element_text(size = 9.2, colour = "grey25"), panel.grid.major.y = element_line( colour = "#F2F2F2", linewidth = 0.3 ), plot.subtitle = element_text( size = 8.8, colour = "grey25", lineheight = 1.05 ), # 20 pt is enough for the rotated y-axis title while reducing the # previously excessive left-side white space. plot.margin = margin(3, 14, 2, 20) # right 2->14: subtitle was clipping ) # ========================================================================== # LEFT: construct coverage bars # ========================================================================== cov_df <- tibble( construct = factor(cons_sorted, levels = rev(cons_sorted)), rate = cons_rates[cons_sorted], n = round(rate * N_TOTAL) ) cov_df$label_face <- ifelse(cov_df$rate >= 0.5, "bold", "plain") p_side <- ggplot(cov_df, aes(x = rate, y = construct)) + # Subtle reference lines clarify the 50% and 100% positions. geom_vline( xintercept = c(0.5, 1), colour = "#E8E8E8", linewidth = 0.35, linetype = "dashed" ) + geom_col(width = 0.34, fill = "#C8D4E3") + geom_text( aes( label = sprintf("%.0f%% (%d/%d)", rate * 100, n, N_TOTAL), x = rate + 0.035, fontface = I(label_face) ), hjust = 0, size = side_label_size, colour = "#1a3a5c" ) + # The old limit was 0-2.35 although rates are 0-1. This was the main # source of the large empty area and the visually compressed 0/50/100% axis. # 1.35 leaves enough room for the right-hand count labels. scale_x_continuous( limits = c(0, 1.9), # 1.35->1.9: room for a full "100% (10/10)" label beside a full bar breaks = c(0, 0.5, 1), labels = c("0", "50%", "100%"), expand = c(0, 0) ) + scale_y_discrete(expand = expansion(add = c(Y_EXPAND, Y_EXPAND))) + labs(x = "Share of studies", y = NULL) + coord_cartesian(clip = "off") + theme_ncc(base = 10) + theme( axis.text.y = element_text(size = name_size, colour = "#111111"), axis.text.x = element_text( size = 8.2, colour = "grey35", margin = margin(t = 2) ), axis.title.x = element_text( size = 8.4, colour = "grey30", margin = margin(t = 4) ), axis.ticks.y = element_blank(), axis.line.y = element_blank(), axis.ticks.x = element_line(colour = "grey50", linewidth = 0.3), axis.line.x = element_blank(), # no long trailing line to x=1.9 under the labels panel.grid = element_blank(), plot.margin = margin(2, 3, 3, 2) ) # ========================================================================== # BOTTOM RIGHT: UpSet matrix # ========================================================================== p_mat <- ggplot() + geom_hline( yintercept = seq_len(length(cons_sorted)), colour = "#F0F0F0", linewidth = 0.35 ) + geom_segment( data = line_df, aes(x = combo_id, xend = combo_id, y = y_min, yend = y_max, colour = I(fill)), linewidth = 0.5 ) + geom_point( data = mat_df %>% filter(!measured), aes(x = combo_id, y = as.integer(construct)), shape = 21, size = 1.25, colour = "#B8B8B8", fill = "white", stroke = 0.5 ) + geom_point( data = mat_df %>% filter(measured), aes(x = combo_id, y = as.integer(construct), colour = I(fill)), size = 1.75 ) + scale_x_continuous( limits = X_LIMITS, expand = expansion(mult = c(0, 0.006)) ) + scale_y_continuous( limits = c( 1 - Y_EXPAND - 0.15, length(cons_sorted) + Y_EXPAND + 0.15 ), expand = c(0, 0) ) + coord_cartesian(clip = "off") + labs(x = NULL, y = NULL) + theme_ncc(base = 10) + theme( axis.text = element_blank(), axis.ticks = element_blank(), axis.line = element_blank(), panel.grid = element_blank(), plot.margin = margin(2, 2, 3, 2) ) # ========================================================================== # COMBINED LAYOUT # ========================================================================== # Genuine two-column design: the widths vector now really controls the # left:right split. The matrix receives slightly more width than before. layout_fig <- c( area(t = 1, b = 3, l = 1, r = 1), area(t = 1, b = 3, l = 2, r = 2), area(t = 4, b = 7, l = 1, r = 1), area(t = 4, b = 7, l = 2, r = 2) ) p_empty <- ggplot() + theme_void() list( plot = p_empty + p_top + p_side + p_mat + plot_layout( design = layout_fig, widths = panel_widths # left:right split; PMT overrides to give the wide matrix more room ), n = N_TOTAL ) } ################################################################################ # EXTENDED DATA FIG 9a — UpSet (PMT), all hazard contexts ################################################################################ # CAPTION # Extended Data Figure 9a | Fragmented operationalisation of Protection Motivation Theory # across all hazard contexts (n = 85 studies). Every column is a unique # combination of PMT constructs measured across studies; the top bar shows how # many studies share that combination (sorted most-to-least frequent), and the # dot matrix below indicates which canonical PMT constructs are measured # (filled circle) or omitted (open circle). Vertical lines connect constructs # measured together. The side bar (left) shows the overall proportion of # studies measuring each construct, ordered by frequency. ################################################################################ message("ED Fig 9a (UpSet PMT, all hazard contexts) ...") pmt_cons_patterns <- c( "Perceived severity" = "\\bseverity\\b|perceived severity|perceived consequence|perceived damage|severity of (threat|storm|hurricane|landslide)|perceived (future\\s+)?damage|perceived risk proximity|threat appraisal|risk appraisal|risk threat|threat assessment", "Perceived vulnerability" = "vulnerability|susceptibility|perceived probability|perceived likelihood|perceived (future\\s+)?probability|\\bexposure\\b|perceived exposure", "Self-efficacy" = "self.efficacy|self efficacy|coping appraisal|coping/adaptation appraisal|perceived preparedness|preparedness belief", "Response efficacy" = "response efficacy|response-efficacy|perceived effectiveness|efficacy of measure|efficacy of (adaptation|protective|mitigation)", "Response cost" = "response cost|response-cost|response costs|perceived cost|perceived costs|perceived barrier|\\beffort\\b|feasib", "Fear / Worry" = "\\bfear\\b|\\bworry\\b|\\bworries\\b|anxiety|\\bdread\\b|fear arousal|negative emotion|negative affect|positive affective", "Protection motivation" = "protection motivation|protective intention|protective behavio|behavioral intention|behavioural intention|\\bintention\\b|adaptive behavio|adaption behaviour|protective action|protective response|protective measure|preventive response|\\badoption\\b|behavioral response|intended response|safety plan" ) # PMT across all hazard contexts (n = 85) pmt_all <- build_upset_data("PMT", pmt_cons_patterns) upset_pmt_all <- make_upset_figure(pmt_all, pmt_cons_patterns, theory_color = PAL_THEORY["PMT"], panel_widths = c(1.45, 3.75)) # 28% left: widest matrix (34 cols) # The PMT UpSet is now Extended Data Fig. 9a. It is dense at print size and its # content compresses to two numbers already given in the Results, so the main # text slot is used for the reuse map and typology instead (new Fig. 4). ed_fig9a <- upset_pmt_all$plot save_fig(ed_fig9a, "ED_Fig9a_fragmentation_PMT_180mm.png", NCC_W180, 4.0) # 5.4 -> 4.0: landscape, removes the vacant space between construct rows cat("PMT UpSet all-hazard (ED Fig 9a): n =", upset_pmt_all$n, "\n") ################################################################################ # EXTENDED DATA FIG 7a/b/c — UpSet for PADM, TPB, Psychometric Paradigm ################################################################################ # CAPTION (ED Fig 7) # Extended Data Figure 9 | Fragmented operationalisation of PADM, TPB, and # the Psychometric Paradigm. As Figure 4, but for the three next-most-applied # theoretical frameworks (regardless of hazard). Each panel shows construct # combinations sorted by frequency (top bar) and a corresponding dot matrix. # Side bars show the overall measurement rate per construct within papers # applying the theory. (a) PADM; (b) TPB; (c) Psychometric Paradigm. ################################################################################ message("ED Fig 7 (UpSet PADM, TPB, Psychometric) ...") padm_cons_patterns <- c( "Risk perception" = "risk perception|perceived risk|perceived flood|perceived exposure|perceived likelihood|perceived consequence|perceived damage|perceived vulnerability|perceived severity|perceived disruption|perceived storm|perceived hurricane|threat appraisal|risk appraisal|threat assessment|threat perception|affective risk|cognitive risk|risk to self|risk to others", "Protective action" = "protective action|protective response|protective behavio|protective measure|protection motivation|evacuat|preparedness|\\badoption\\b|\\badopt\\b|mitigation|adaptive behavio|adaption behaviour|taking protective|preventive response|behavioral response|behavior response|intended response|intention to|safety plan|earthquake adjustment", "Information seeking" = "information seek|seeking information|information source|information channel|information processing|hazard information|risk information|warning source|warning message|received.*warning|\\bwarning\\b|message credibility|\\bmessage\\b|environmental cue|social cue|decision cue|official cue|physical cue|\\bcues\\b|sense of being informed|perceived information credibility", "Situational facilitators" = "situational facilitator|situational variable|situational factor|situational context|adaptive capacity|resource requirement|resource-related|household context|physical context|\\bimpediment\\b|evacuation impediment|\\bbarrier\\b|shelter", "Hazard knowledge" = "hazard knowledge|hazard awareness|\\bknowledge\\b|\\bawareness\\b|\\bunderstanding\\b|subjective knowledge|knowledge efficacy|knowledge perception|location perception", "Stakeholder perception" = "stakeholder perception|stakeholder|\\btrust\\b|responsibility|self.responsibility|individual responsibility|government responsibility|institutional context|trust in (federal|community|government|local)|social support|community connectedness|community homophily" ) tpb_cons_patterns <- c( "Attitude" = "\\battitude|attitude.{0,30}behavio|salient advantage|salient disadvantage|behavioral belief|behavioural belief|anticipated affect", "Subjective norm" = "subjective norm|social norm|prescriptive norm|salient referent|normative belief|risk avoidance norm|perceived social norm|moral norm", "Perceived behavioral control" = "perceived behavioral control|perceived behavioural control|behavioral control|behaviour.?al control|perceived control|\\bPBC\\b|salient circumstance|salient barrier|control belief", "Intention" = "\\bintention\\b|behavioral intention|behavioural intention|intentions to|intention to|strength of intention|Public Readiness|\\bPRI\\b|adoption intention|preparedness intention|evacuation intention", "Risk perception" = "risk perception|perceived risk|perceived severity|perceived vulnerability|perceived susceptibility|perceived risk proximity" ) psych_cons_patterns <- c( "Dread" = "\\bdread\\b|dread risk|fear", "Unknown risk" = "\\bunknown\\b|unfamili|newness|immediacy", "Controllability" = "controllab|\\bcontrol\\b", "Knowledge" = "\\bknowledge\\b|familiarity", "Catastrophic pot." = "catastroph|widespread|catastrophism|generations|financial loss" ) padm_all <- build_upset_data("PADM", padm_cons_patterns) tpb_all <- build_upset_data("TPB", tpb_cons_patterns) psych_all <- build_upset_data("Psychometric", psych_cons_patterns) upset_padm <- make_upset_figure(padm_all, padm_cons_patterns, theory_color = PAL_THEORY["PADM"], panel_widths = c(1.55, 3.55)) # 30% left upset_tpb <- make_upset_figure(tpb_all, tpb_cons_patterns, theory_color = PAL_THEORY["TPB"], # green (now CB-safe via global palette) complete_color = "#4477AA", # blue: separable from green for red-green CB readers panel_widths = c(1.85, 3.25)) # 36% left ("Perceived behavioral control" is the longest name) upset_psych <- make_upset_figure(psych_all, psych_cons_patterns, theory_color = PAL_THEORY["Psychometric"], panel_widths = c(1.75, 3.35)) # 34% left ("100% (10/10)" is the widest label) save_fig(upset_padm$plot, "ED_Fig9b_fragmentation_PADM_180mm.png", NCC_W180, 3.8) # 5.1 -> 3.8 save_fig(upset_tpb$plot, "ED_Fig9c_fragmentation_TPB_180mm.png", NCC_W180, 4.0) # 5.1 -> 4.0 save_fig(upset_psych$plot, "ED_Fig9d_fragmentation_Psychometric_180mm.png", NCC_W180, 4.0) # 5.1 -> 4.0 cat("PADM UpSet: n =", upset_padm$n, "\n") cat("TPB UpSet: n =", upset_tpb$n, "\n") cat("Psych UpSet: n =", upset_psych$n, "\n") # ============================================================================= # REVISED BLOCKS ONLY. Paste each block over the corresponding block in # ncc_submission_figures_FINAL_v13.R. Nothing else in the script changes. # # What was wrong # Fig 4a the count and the construct name were drawn as two separate labels # at fixed offsets, so on short names they collided and on dark tiles # the grey name disappeared. Two names also wrapped to three lines and # overflowed the tile. # Fig 4b text size was absolute while cell width shrinks at 180 mm, so the # strings ran across cell boundaries. # ED 10 the PADM segments are 4% and 4%, so their in-bar labels overlapped. # ============================================================================= # ============================================================================= # BLOCK 1 of 3 # Replace everything from the line # ---- (a) reuse map --- # down to (but NOT including) # ---- (b) typology --- # ============================================================================= # ---- (a) reuse map --------------------------------------------------------- # Well-documented applications only, using the theory-specific documentation # level (consistent with Fig. 6). Construct detection reuses exactly the same # per-theory unit and patterns as detect_constructs(), so the cells here are a # subset of the counts behind Fig. 3. wd_ids <- core %>% filter(measurement_documentation_level == "Well-Documented") %>% pull(file_id) # Two canonical names wrap to three lines and overflow the tile. Shortened for # display only; the underlying construct is unchanged. SHORT_NAME <- c("Perceived behavioral control" = "Perceived control", "Relevant channel beliefs" = "Channel beliefs") reuse_rows <- list() for (th in names(source_constructs)) { info <- source_constructs[[th]] paps <- long[long$theory_abbrev == th & !is.na(long$theory_constructs_measured), ] paps <- paps[!duplicated(paps$file_id), ] paps <- paps[!sapply(paps$theory_constructs_measured, is_coder_note), ] paps_wd <- paps[paps$file_id %in% wd_ids, ] for (con in info$core) { n_wd <- if (nrow(paps_wd)) { sum(grepl(paste0("(?i)", info$items[[con]]), paps_wd$theory_constructs_measured, perl = TRUE)) } else 0L reuse_rows[[length(reuse_rows) + 1]] <- data.frame( theory = th, construct = con, n_wd = n_wd, stringsAsFactors = FALSE) } } reuse <- bind_rows(reuse_rows) # Constructs are theory-specific, so each theory occupies its own row of cells, # indexed by position rather than by a shared construct axis. reuse <- reuse %>% group_by(theory) %>% mutate(slot = row_number()) %>% ungroup() %>% mutate( disp = ifelse(construct %in% names(SHORT_NAME), SHORT_NAME[construct], construct), lab_n = ifelse(n_wd == 0, "\u2014", as.character(n_wd)), # One label per cell, count on the first line and name below it, so the two # can never collide: ggplot lays the lines out itself. label = paste0(lab_n, "\n", str_wrap(disp, 13)), # Contrast is decided once for the whole label, so the name is never grey # text on a dark tile. txt_col = ifelse(n_wd >= 12, "white", "grey15")) th_ord <- core %>% count(theory_abbrev, name = "n") %>% arrange(n) %>% pull(theory_abbrev) reuse$theory <- factor(reuse$theory, levels = th_ord[th_ord %in% reuse$theory]) n_cells <- nrow(reuse); n_zero <- sum(reuse$n_wd == 0); n_thin <- sum(reuse$n_wd <= 1) cat("Fig 4a: ", n_cells, " theory x core-construct cells; ", n_zero, " with no well-documented instrument (", round(100 * n_zero / n_cells), "%); ", n_thin, " with at most one (", round(100 * n_thin / n_cells), "%)\n", sep = "") p4a <- ggplot(reuse, aes(x = slot, y = theory)) + geom_tile(aes(fill = ifelse(n_wd == 0, NA_real_, n_wd)), color = "white", linewidth = 0.7, height = 0.97) + geom_text(aes(label = label, color = txt_col), size = 2.5, lineheight = 0.92, fontface = "plain") + scale_color_identity() + scale_fill_gradientn(colors = c("#EAF2F8", "#A8C9E2", "#5A93C4", "#1F5C8B"), na.value = "#EFECEC", name = "Well-documented\ninstruments", limits = c(0, max(reuse$n_wd)), breaks = c(0, 5, 10, 15, 20)) + scale_x_continuous(breaks = NULL, expand = expansion(mult = 0.005)) + scale_y_discrete(expand = expansion(add = 0.55)) + labs(x = NULL, y = NULL, subtitle = "a Construct-level reuse map") + theme_ncc() + theme(axis.line = element_blank(), axis.ticks = element_blank(), axis.text.y = element_text(size = 9, face = "bold"), panel.grid = element_blank(), legend.key.height = unit(0.55, "cm"), legend.key.width = unit(0.30, "cm"), legend.title = element_text(size = 8), legend.text = element_text(size = 7.5), plot.subtitle = element_text(size = 12, face = "bold")) # ============================================================================= # BLOCK 2 of 3 # Replace everything from the line # ---- (b) typology --- # down to and including the two save_fig() calls and the write.csv() for Fig 4. # ============================================================================= # ---- (b) typology ---------------------------------------------------------- # Text is wrapped by str_wrap at draw time rather than with hard line breaks, # so the same block re-wraps correctly when the figure is exported at 180 mm. WRAP_B <- 22 typo <- data.frame( row = 1:3, what = c("Theory is selected", "Constructs are selected", "Reporting is aggregated"), driver = c("Two frameworks absorb most applications; the rest are applied too rarely for comparison", "Constructs that cost more survey items are dropped first; those with clear intervention levers are kept", "Appraisal bundles are reported in place of the sub-constructs they contain"), remedy = c("Scale development for widely applied theory-hazard pairings with no documented instrument", "Shared item templates for the neglected constructs: response cost, institutional trust, maladaptive coping", "Reporting standard requiring constructs measured, and constructs omitted, to be named"), stringsAsFactors = FALSE) typo_long <- typo %>% pivot_longer(c(what, driver, remedy), names_to = "col", values_to = "txt") %>% mutate(col = factor(col, levels = c("what", "driver", "remedy"), labels = c("What is selected", "Why", "Remedy")), row = factor(row, levels = 3:1), txt = ifelse(col == "What is selected", txt, str_wrap(txt, WRAP_B)), face = ifelse(col == "What is selected", "bold", "plain")) p4b <- ggplot(typo_long, aes(x = col, y = row)) + geom_tile(fill = "#F5F8FB", color = "white", linewidth = 1.6) + geom_text(aes(label = txt, fontface = face), size = 2.8, lineheight = 1.0, color = "grey15") + scale_x_discrete(position = "top", expand = expansion(mult = 0.004)) + scale_y_discrete(expand = expansion(add = 0.5)) + labs(x = NULL, y = NULL, subtitle = "b Typology of selective operationalisation") + theme_ncc() + theme(axis.line = element_blank(), axis.ticks = element_blank(), axis.text.y = element_blank(), axis.text.x = element_text(size = 9.5, face = "bold", hjust = 0.5), panel.grid = element_blank(), plot.subtitle = element_text(size = 12, face = "bold"), plot.margin = margin(4, 8, 2, 2)) ncc_fig4 <- p4a / p4b + plot_layout(heights = c(1.6, 1)) # more height to panel a so cells read taller save_fig(ncc_fig4, "Fig4_reuse_map_typology_180mm.png", NCC_W180, 7.6) write.csv(reuse %>% select(theory, construct, n_wd), file.path(OUT, "Fig4a_reuse_map_values.csv"), row.names = FALSE) ################################################################################ # MAIN TEXT FIG 5 — Documentation pipeline (panel a) + lollipops (b/c/d) ################################################################################ # CAPTION # Figure 5 | The measurement documentation deficit. # (a) Documentation pipeline showing the proportion of studies (N = 222) # passing each criterion required for Well-Documented status under the # rule-based MDL decision rule. Bars are stacked: dark blue = papers passing # all preceding criteria and the current criterion; light grey = papers # excluded at this stage. (b) Distribution of psychometric quality, (c) # replicability, and (d) qualitative validation approach across all papers. # Lollipops show proportion (with Wilson 95% CI) and absolute count. ################################################################################ message("NCC Fig 5 (documentation pipeline + lollipops) ...") pipeline <- paper %>% filter(!is.na(measurement_documentation_level)) %>% mutate( pass_inst_mod = survey_instrument_level %in% c("2_Moderate","3_Detailed","4_Complete"), pass_inst_hi = survey_instrument_level %in% c("3_Detailed","4_Complete"), pass_psych = psychometric_quality_collapsed %in% c("Fair","Good","Excellent"), pass_repl = measurement_replicable == "Yes" ) N_total <- nrow(pipeline) # The v8 funnel ended with two identical bars: the cumulative "Replicable = # Yes" stage and "Well-Documented" are the same 66 studies by construction, so # the final bar read as a rendering error. The two are merged into one stage # and the identity is verified rather than drawn twice. stopifnot( sum(pipeline$pass_inst_hi & pipeline$pass_psych & pipeline$pass_repl, na.rm = TRUE) == sum(pipeline$measurement_documentation_level == "Well-Documented", na.rm = TRUE)) stage_lv <- c("All studies", "Instrument >= 2_Moderate", "Instrument >= 3_Detailed", "+ Psychometric >= Fair", "+ Replicable = Yes\n(= Well-Documented)") funnel_df <- tibble( stage = factor(stage_lv, levels = stage_lv), n_pass = c( N_total, sum(pipeline$pass_inst_mod, na.rm = TRUE), sum(pipeline$pass_inst_hi, na.rm = TRUE), sum(pipeline$pass_inst_hi & pipeline$pass_psych, na.rm = TRUE), sum(pipeline$pass_inst_hi & pipeline$pass_psych & pipeline$pass_repl, na.rm = TRUE) ) ) %>% mutate(n_fail = N_total - n_pass) funnel_long <- funnel_df %>% pivot_longer(cols = c(n_pass, n_fail), names_to = "status", values_to = "n") %>% mutate(status = factor(ifelse(status == "n_pass", "Passes criterion", "Excluded at this stage"), levels = c("Excluded at this stage", "Passes criterion")), pct = n / N_total * 100) p5a <- ggplot(funnel_long, aes(x = pct, y = stage, fill = status)) + geom_col(width = 0.72, color = "white", linewidth = 0.4) + geom_text(data = funnel_long %>% filter(status == "Passes criterion"), aes(label = paste0(n, " (", round(pct), "%)")), position = position_stack(vjust = 0.5), color = "white", size = 3.4, fontface = "bold") + scale_y_discrete(limits = rev(levels(funnel_long$stage)), labels = function(x) str_wrap(x, 20)) + # Legend labels shortened: at 180 mm the long labels were clipped by the # panel edge. Extra right expansion keeps the 100% tick from being cut. scale_fill_manual(values = c("Excluded at this stage" = "#E8E8E8", "Passes criterion" = "#2B6F9E"), labels = c("Excluded", "Passes"), name = NULL) + scale_x_continuous(labels = label_percent(scale = 1), expand = expansion(mult = c(0, 0.06))) + labs(x = "Proportion of studies", y = NULL, subtitle = "a Documentation pipeline") + theme_ncc() + theme(plot.subtitle = element_text(size = 12.5, face = "bold"), axis.text.y = element_text(size = 10, lineheight = 0.85), legend.position = "bottom", legend.justification = "left", legend.margin = margin(0, 0, 0, 0), legend.box.margin = margin(-6, 0, 0, 0), legend.key.size = unit(0.28, "cm"), legend.text = element_text(size = 8.5)) make_comp <- function(data, var, pal, lv, lbs, sub) { d <- data %>% filter(!is.na(.data[[var]]), .data[[var]] != "") %>% mutate(cat = factor(.data[[var]], levels = lv)) %>% count(cat, .drop = FALSE, name = "n") %>% mutate(total = sum(n)) %>% add_ci("n", "total") %>% mutate(cat = factor(cat, levels = rev(lv))) ggplot(d, aes(x = p, y = cat)) + geom_segment(aes(x = 0, xend = p, yend = cat), color = "grey80", linewidth = 0.35) + # Wilson 95% CI. v8 drew these as a thick translucent bar, which rendered # as a grey blob that readers mistook for a second data mark. Thin line # with end caps instead. # CI drawn darker and slightly heavier, and the point made smaller, so the # interval is still legible when the figure is scaled to 180 mm. geom_errorbarh(aes(xmin = ci_lo, xmax = ci_hi), height = 0.26, linewidth = 0.75, color = "grey25") + geom_point(aes(fill = cat), shape = 21, size = 1.8, color = "white", stroke = 0.5) + geom_text(aes(x = ci_hi, label = paste0(n, " (", round(p*100), "%)")), hjust = -0.08, size = 3.6, color = "grey20") + scale_fill_manual(values = pal, na.value = "grey80", guide = "none") + scale_x_continuous(labels = percent_format(1), expand = expansion(mult = c(0, 0.45)), limits = c(0, 1)) + scale_y_discrete(labels = function(x) str_wrap(rev(lbs)[match(x, rev(lv))], width = 16)) + labs(x = NULL, y = NULL, subtitle = sub) + theme_ncc() + theme(axis.text.y = element_text(size = 10.5, lineheight = 0.85), plot.subtitle = element_text(size = 12.5, face = "bold"), plot.margin = margin(2, 4, 2, 2)) } p5b <- make_comp(paper, "psychometric_quality_collapsed", PAL_PSYCH_COL, c("Inadequate","Fair","Good","Excellent"), c("Inadequate\n(Not reported/Poor)","Fair","Good","Excellent"), "b Psychometric quality") p5c <- make_comp(paper, "measurement_replicable", PAL_REP, c("No","Partial","Yes"), c("No","Partial","Yes"), "c Replicability") val_pal <- c("Not_Reported"="#BBBBBB","Pilot_Feedback"="#E69F00", "Expert_Review"="#56B4E9","Mixed_Approach"="#009E73", "Full_Qualitative"="#0072B2") p5d <- make_comp(paper, "qualitative_validation", val_pal, c("Not_Reported","Pilot_Feedback","Expert_Review", "Mixed_Approach","Full_Qualitative"), c("Not reported","Pilot feedback","Expert review", "Mixed approach","Full qualitative"), "d Validation approach") ncc_fig5 <- (p5a | (p5b / p5c / p5d)) + plot_layout(widths = c(1, 1)) save_fig(ncc_fig5, "Fig5_documentation_180mm.png", NCC_W180, 6.6) ################################################################################ # MAIN TEXT FIG 6 — Popularity-quality paradox ################################################################################ # CAPTION # Figure 6 | Popularity-quality paradox across theories. # (a) Distribution of measurement documentation levels for the ten core # theories, ordered by the proportion of Well-Documented papers (highest at # top). Diamonds with horizontal bars show the point estimate and Wilson # 95% CI for the proportion Well-Documented. Sample sizes (n) shown at # right. (b) Heatmap showing the proportion of papers in each theory meeting # each of four documentation criteria: detailed instrument (level >= 3), # good/excellent psychometric reporting, full replicability, and overall # Well-Documented MDL. Theories are ordered by mean proportion across # criteria (lowest at bottom). ################################################################################ message("NCC Fig 6 ...") # Figure 6 uses the THEORY-SPECIFIC coding held in the long file, not the # study-level values joined from the consolidated file. A study that documents # PMT thoroughly and PADM poorly is therefore counted once at each standard. # The study-level version is retained below as a robustness comparison; the two # give the same ordering of theories. core_q <- core %>% select(file_id, theory_abbrev, survey_instrument_level, psychometric_quality, measurement_replicable, measurement_documentation_level) %>% mutate(psychometric_quality_collapsed = ifelse( psychometric_quality %in% c("Not_Reported", "Poor"), "Inadequate", psychometric_quality)) # Robustness: the same rates computed from the study-level values. core_q_paperlevel <- core %>% select(file_id, theory_abbrev) %>% left_join(paper %>% select(file_id, survey_instrument_level, psychometric_quality, psychometric_quality_collapsed, measurement_replicable, measurement_documentation_level), by = "file_id") rob <- bind_rows( core_q %>% group_by(theory_abbrev) %>% summarise(source = "theory-specific", well_doc = round(100 * mean(measurement_documentation_level == "Well-Documented", na.rm = TRUE))), core_q_paperlevel %>% group_by(theory_abbrev) %>% summarise(source = "study-level", well_doc = round(100 * mean(measurement_documentation_level == "Well-Documented", na.rm = TRUE)))) write.csv( rob, file.path(OUT, "Fig6_robustness_theory_vs_study_level.csv"), row.names = FALSE ) make_qp <- function(df, var, pal, lv, lbs, pos, sub) { st <- df %>% filter(!is.na(.data[[var]]), .data[[var]] != "") %>% mutate(cat = factor(.data[[var]], levels = lv)) %>% count(theory_abbrev, cat, .drop = FALSE) %>% group_by(theory_abbrev) %>% mutate(total = sum(n), pct = n / total) %>% ungroup() ci_d <- st %>% group_by(theory_abbrev) %>% summarise(n_pos = sum(n[cat %in% pos]), n_tot = first(total), .groups = "drop") %>% add_ci("n_pos", "n_tot") %>% rename(pos_p = p, pos_lo = ci_lo, pos_hi = ci_hi) # BUG FIX (v8): the caption promised "highest at top" but ggplot places the # FIRST factor level at the BOTTOM of a discrete y axis, so arrange(desc()) # put the best-documented theory at the bottom. Ascending order here puts it # at the top, matching both the caption and panel b. ord <- ci_d %>% arrange(pos_p) %>% pull(theory_abbrev) st$theory_abbrev <- factor(st$theory_abbrev, levels = ord) ci_d$theory_abbrev <- factor(ci_d$theory_abbrev, levels = ord) nl <- st %>% distinct(theory_abbrev, total) %>% mutate(label = paste0("n=", total)) ggplot(st, aes(x = pct, y = theory_abbrev, fill = cat)) + geom_col(width = 0.45, color = "white", linewidth = 0.15) + geom_errorbarh(data = ci_d, aes(y = theory_abbrev, xmin = pos_lo, xmax = pos_hi), inherit.aes = FALSE, height = 0.18, linewidth = 0.45, color = "grey15") + geom_point(data = ci_d, aes(x = pos_p, y = theory_abbrev), inherit.aes = FALSE, shape = 23, size = 1.8, fill = "white", color = "grey15", stroke = 0.6) + geom_text(data = nl, aes(x = 1.01, y = theory_abbrev, label = label), inherit.aes = FALSE, hjust = 0, size = 3, color = "grey35") + scale_fill_manual(values = pal, labels = lbs, name = NULL, drop = FALSE) + scale_x_continuous(labels = percent_format(1), expand = expansion(mult = c(0, 0.18)), breaks = c(0, .25, .5, .75, 1)) + labs(x = "Proportion", y = NULL, subtitle = sub) + theme_ncc() + theme(axis.text.y = element_text(size = 10.5), legend.position = "bottom", legend.key.size = unit(0.26, "cm"), legend.text = element_text(size = 8.5), legend.margin = margin(0, 0, 0, 0), legend.box.margin = margin(t = -2), plot.subtitle = element_text(size = 12, face = "bold"), plot.margin = margin(2, 10, 2, 2)) } p6a <- make_qp(core_q, "measurement_documentation_level", PAL_MDL, c("Minimally Documented","Partially Documented","Well-Documented"), c("Minimally","Partially","Well-Documented"), "Well-Documented", "a Documentation level") # Three-line wraps: at 180 mm the two-line labels ran into each other. m_names <- c("Detailed\ninstru-\nment","Good\npsycho-\nmetrics","Repli-\ncable","Well-\nDocu-\nmented") qm_rows <- list() for (th in CORE10) { sub_df <- core_q[core_q$theory_abbrev == th, ] n <- nrow(sub_df); if (n < 3) next vals <- c(sum(sub_df$survey_instrument_level %in% c("3_Detailed","4_Complete"), na.rm = TRUE), sum(sub_df$psychometric_quality_collapsed %in% c("Good","Excellent"), na.rm = TRUE), sum(sub_df$measurement_replicable == "Yes", na.rm = TRUE), sum(sub_df$measurement_documentation_level == "Well-Documented", na.rm = TRUE)) for (j in 1:4) { ci <- wilson_ci(vals[j], n) qm_rows[[length(qm_rows)+1]] <- data.frame( theory = th, metric = m_names[j], n = n, p = ci$p, ci_lo = ci$lo, ci_hi = ci$hi, stringsAsFactors = FALSE) } } qm <- bind_rows(qm_rows) # Sample sizes on the axis: several theories rest on 5-11 studies, and a bare # "100%" cell invites over-reading without the denominator in view. qm <- qm %>% mutate(theory_lab = paste0(theory, " (n=", n, ")")) lab_order <- qm %>% group_by(theory_lab) %>% summarise(mp = mean(p)) %>% arrange(mp) %>% pull(theory_lab) qm$theory <- factor(qm$theory_lab, levels = lab_order) qm$metric <- factor(qm$metric, levels = m_names) qm$text_col <- ifelse(qm$p > 0.45, "white", "grey20") p6b <- ggplot(qm, aes(x = metric, y = theory, fill = p)) + geom_tile(color = "white", linewidth = 0.5) + geom_text(aes(label = paste0(round(p*100), "%"), color = text_col), size = 3.4, fontface = "bold") + scale_color_identity() + scale_fill_gradientn(colors = c("#F5F5F5","#CCDDEE","#6699CC","#336699","#002244"), values = rescale(c(0, 0.15, 0.3, 0.5, 1)), limits = c(0, 1), labels = percent, breaks = c(0, 0.5, 1), name = "% meeting criterion", guide = guide_colourbar( title.position = "top", title.hjust = 0, barwidth = unit(3.2, "cm"), barheight = unit(0.32, "cm"))) + labs(x = NULL, y = NULL, subtitle = "b Quality by criterion") + theme_ncc() + theme(axis.text.x = element_text(size = 7.5, lineheight = 0.78), axis.text.y = element_text(size = 10), axis.line = element_blank(), legend.position = "bottom", # matches p6a so guides="collect" merges at bottom plot.subtitle = element_text(size = 12.5, face = "bold")) # NOTE: guides="collect" interacted badly with per-panel legend.position here # (overlapping panels/labels in testing), so panel a and panel b keep their own # independent bottom legends instead of a merged one. This also avoids the `&` # operator, which can fail with "Can't find method for generic `&(e1, e2)`" if # another loaded package (e.g. raster/terra/sp) registers an S4 `&` method that # shadows patchwork's S3 `&.gg`. ncc_fig6 <- (p6a | p6b) + plot_layout(widths = c(1.12, 1)) save_fig(ncc_fig6, "Fig6_quality_paradox_180mm.png", NCC_W180, 5.6) ################################################################################ # EXTENDED DATA FIGURES ################################################################################ message("Extended Data figures ...") # ── ED Fig 1: Study selection (PRISMA 2020) ────────────────────────────────── # CAPTION # Extended Data Figure 1 | Study selection (PRISMA 2020 flow diagram). # Flow of records from Web of Science identification, through machine-learning- # assisted and manual screening, full-text (PDF) retrieval, and eligibility # assessment (automated theory detection followed by manual validation), to the # studies included in the review. Counts reconcile exactly at every stage. ################################################################################ # Main-flow boxes (left column) and exclusion boxes (right column). Coordinates # on an arbitrary 0-10 grid; drawn as a standard top-down PRISMA 2020 template. main_box <- tibble::tribble( ~id, ~xc, ~yc, ~hh, ~label, "M1", 3.4, 9.0, 0.55, "Records identified from\nWeb of Science (n = 3,410)", "M2", 3.4, 7.4, 0.45, "Records screened\n(n = 3,344)", "M3", 3.4, 5.9, 0.45, "Reports sought for retrieval\n(n = 1,214)", "M4", 3.4, 4.4, 0.45, "Reports assessed for eligibility\n(n = 1,103)", "M5", 3.4, 2.6, 0.45, "Studies included in review\n(n = 223)") excl_box <- tibble::tribble( ~id, ~xc, ~yc, ~hh, ~label, "E1", 8.0, 9.0, 0.55, "Records removed before screening:\nnon-article types (n = 66)", "E2", 8.0, 7.4, 0.55, "Records excluded by ML-assisted\nand manual screening (n = 2,130)", "E3", 8.0, 5.9, 0.55, "Reports not retrieved:\nPDF unavailable (n = 111)", "E4", 8.0, 4.4, 0.95, "Reports excluded (n = 880):\nno theory detected (n = 559);\nfailed manual validation (n = 116);\nno confirmed guiding theory (n = 205)") MAIN_HW <- 1.95; EXCL_HW <- 1.95 main_box <- main_box %>% mutate(xmin = xc - MAIN_HW, xmax = xc + MAIN_HW, ymin = yc - hh, ymax = yc + hh) excl_box <- excl_box %>% mutate(xmin = xc - EXCL_HW, xmax = xc + EXCL_HW, ymin = yc - hh, ymax = yc + hh) # Vertical flow arrows (bottom of upper main box -> top of lower main box). v_arr <- tibble::tibble( x = 3.4, xend = 3.4, y = head(main_box$ymin, -1), yend = tail(main_box$ymax, -1)) # Horizontal exclusion arrows (right edge of main box -> left edge of excl box). h_arr <- tibble::tibble( x = main_box$xmax[1:4], xend = excl_box$xmin, y = main_box$yc[1:4], yend = excl_box$yc) # PRISMA stage labels (rotated, far left). stage_lab <- tibble::tibble( x = 0.15, y = c(9.0, 6.15, 2.6), label = c("Identification", "Screening", "Included")) arrow_style <- arrow(length = unit(0.18, "cm"), type = "closed") ed_fig1 <- ggplot() + geom_segment(data = v_arr, aes(x = x, xend = xend, y = y, yend = yend), arrow = arrow_style, linewidth = 0.5, color = "grey30", lineend = "round") + geom_segment(data = h_arr, aes(x = x, xend = xend, y = y, yend = yend), arrow = arrow_style, linewidth = 0.5, color = "grey30", lineend = "round") + geom_rect(data = main_box, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = "#DAE8F5", color = "#2B6F9E", linewidth = 0.5) + geom_rect(data = excl_box, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = "#F2F2F2", color = "grey55", linewidth = 0.5) + geom_text(data = main_box, aes(x = xc, y = yc, label = label), size = 3.4, color = "grey10", lineheight = 0.95) + geom_text(data = excl_box, aes(x = xc, y = yc, label = label), size = 3.2, color = "grey25", lineheight = 0.95) + geom_text(data = stage_lab, aes(x = x, y = y, label = label), angle = 90, fontface = "bold", size = 3.7, color = "grey40") + coord_cartesian(xlim = c(0, 10), ylim = c(1.9, 9.8), clip = "off") + theme_void() + theme(plot.margin = margin(8, 8, 8, 8)) save_fig(ed_fig1, "ED_Fig1_screening_180mm.png", NCC_W180, 5.6) # ── ED Fig 2: Composition lollipops ────────────────────────────────────────── # CAPTION # Extended Data Figure 4 | Composition of the corpus across six descriptive # dimensions. (a) Survey instrument level, (b) measurement documentation level, # (c) theory combination type, (d) psychometric quality, (e) measurement # replicability, (f) qualitative validation approach. Lollipops show # proportion (with Wilson 95% CI) and counts. ################################################################################ p_inst <- make_comp(paper, "survey_instrument_level", PAL_INST, c("1_Minimal","2_Moderate","3_Detailed","4_Complete"), c("Minimal","Moderate","Detailed","Complete"), "a Instrument detail") p_mdl <- make_comp(paper, "measurement_documentation_level", PAL_MDL, c("Minimally Documented","Partially Documented","Well-Documented"), c("Minimally\nDocumented","Partially\nDocumented","Well-\nDocumented"), "b Measurement documentation") if ("combination_type" %in% names(paper)) { combo_pal <- c("Single theory"="#2171B5","Multiple core theories"="#CB181D", "Core + supplementary"="#E08214","Multiple non-core theories"="#BDBDBD") p_combo <- make_comp(paper, "combination_type", combo_pal, c("Single theory","Multiple core theories","Core + supplementary","Multiple non-core theories"), c("Single theory","Multiple core\ntheories","Core +\nsupplementary","Multiple\nnon-core theories"), "c Theory combinations") } else { p_combo <- ggplot() + theme_void() + labs(subtitle = "c Theory combinations (column unavailable)") } ed_fig2 <- (p_inst | p5b | p5c) / (p_mdl | p_combo | p5d) + plot_layout(axes = "collect") # 180 mm A4 version: 2 columns x 3 rows so each panel keeps enough width for its # wrapped y-axis labels and count text (3-across is too cramped at 180 mm). # Subtitle size is overridden per-panel with `+` (not `&`) before composing: # the `&` operator can fail with "Can't find method for generic `&(e1, e2)`" # if another loaded package (e.g. raster/terra/sp) registers an S4 `&` method # that shadows patchwork's S3 `&.gg`; `+.gg` is ggplot2's core operator and is # not affected. shrink_sub_180 <- function(p) p + theme(plot.subtitle = element_text(size = 11, face = "bold", hjust = 0)) ed_fig2_180 <- (shrink_sub_180(p_inst) | shrink_sub_180(p5b)) / (shrink_sub_180(p5c) | shrink_sub_180(p_mdl)) / (shrink_sub_180(p_combo) | shrink_sub_180(p5d)) + plot_layout(axes = "collect") save_fig(ed_fig2_180, "ED_Fig4_composition_180mm.png", NCC_W180, 8.6) # ── ED Fig 3: Hazard distribution ──────────────────────────────────────────── # CAPTION # Extended Data Figure 5 | Distribution of studies across natural hazards. # Bars show the number of papers studying each hazard, partitioned by # single-hazard vs multi-hazard studies. Multi-hazard papers contribute to # multiple bars. ################################################################################ hz_all <- list() for (i in seq_len(nrow(paper))) { r <- paper[i, ]; if (is.na(r$hazard_corrected)) next hrs <- trimws(unlist(strsplit(as.character(r$hazard_corrected), ";"))) im <- length(hrs) > 1 for (h in hrs) { hr <- recode_hazard(h) if (hr != "Other") hz_all[[length(hz_all)+1]] <- data.frame( hazard = hr, hazard_type = ifelse(im, "Multi-hazard", "Single-hazard"), stringsAsFactors = FALSE) } } hz_df <- bind_rows(hz_all) hz_ord <- hz_df %>% count(hazard) %>% arrange(n) %>% pull(hazard) hz_df$hazard <- factor(hz_df$hazard, levels = hz_ord) hz_df$hazard_type <- factor(hz_df$hazard_type, levels = c("Multi-hazard","Single-hazard")) ed_fig3 <- ggplot(hz_df, aes(x = hazard, fill = hazard_type)) + geom_bar(width = 0.6, color = "white", linewidth = 0.2) + stat_count(geom = "text", aes(label = after_stat(count)), hjust = -0.2, size = 2.7, color = "grey30") + scale_fill_manual(values = c("Multi-hazard"="#C7A4D5","Single-hazard"="#7B5B9E"), name = NULL) + scale_y_continuous(expand = expansion(mult = c(0, 0.15))) + coord_flip() + labs(x = NULL, y = "Studies") + theme_ncc() + theme(axis.text.y = element_text(size = 8.5), axis.text.x = element_text(size = 8), legend.position = "bottom", legend.key.size = unit(0.28, "cm"), legend.text = element_text(size = 8), plot.margin = margin(2, 4, 2, 2)) save_fig(ed_fig3, "ED_Fig5_hazard_distribution_180mm.png", NCC_W180, 4.7) # ── ED Fig 4: Construct panels (core only) ─────────────────────────────────── # CAPTION # Extended Data Figure 6 | Construct operationalisation for the four theories # NOT shown in Figure 3 (Fig 3 covers PMT, PADM, TPB, EPPM, Psychometric, RISP). # As Figure 3 but restricted to the core (foundational) constructs of # Cultural Theory, HBM, EUT and SCT. Constructs measured by <5% of papers omitted. ################################################################################ make_panel_core <- function(th) { d <- cdf_filtered %>% filter(theory == th, is_core) %>% mutate(construct = fct_reorder(construct, p)) if (nrow(d) == 0) return(ggplot() + theme_void() + labs(subtitle = paste0(th, " (no core >=5%)"))) n_tot <- d$n_total[1]; th_col <- PAL_THEORY[th] ggplot(d, aes(x = p, y = construct)) + geom_segment(aes(x = 0, xend = p, yend = construct), color = "grey88", linewidth = 0.4) + geom_linerange(aes(xmin = ci_lo, xmax = ci_hi), linewidth = 1.2, color = th_col, alpha = 0.3) + geom_point(shape = 16, size = 2.5, color = th_col, alpha = 0.85) + geom_text(aes(x = ci_hi, label = n_hit), hjust = -0.5, size = 2.4, color = "grey30") + labs(subtitle = paste0(th, " (n = ", n_tot, ")"), x = NULL, y = NULL) + scale_x_continuous(limits = c(-0.03, 1.18), breaks = c(0, .25, .5, .75, 1), labels = percent_format(1), expand = c(0, 0)) + theme_ncc(base = 8.5) + theme(plot.subtitle = element_text(size = 9.5, face = "bold"), axis.text.y = element_text(size = 9), axis.text.x = element_text(size = 8.5), plot.margin = margin(1, 4, 1, 1)) } pv_core <- setNames(lapply(names(source_constructs), make_panel_core), names(source_constructs)) # comment 12: restrict to the four theories not already in Fig 3 ed_fig4 <- wrap_plots(pv_core[c("CT","HBM","EUT","SCT")], ncol = 2) save_fig(ed_fig4, "ED_Fig6_constructs_core_only_180mm.png", NCC_W180, 4.9) # ── [ED Fig 5 removed] PMT-flood paper-by-construct matrix dropped per # author decision (did not add value); subsequent ED figures renumbered. # ── ED Fig 5: Hazard × year tile plot ──────────────────────────────────────── # CAPTION # Extended Data Figure 7 | Hazard-by-year distribution of studies. # Each cell shows the number of papers studying a given hazard in a given # publication year. Hazards are ordered by total count (most-studied at top). # Cell colour scales with count. ################################################################################ hz_rows <- list() for (i in seq_len(nrow(paper))) { r <- paper[i, ]; if (is.na(r$hazard_corrected)) next for (h in trimws(unlist(strsplit(as.character(r$hazard_corrected), ";")))) if (h != "") hz_rows[[length(hz_rows)+1]] <- data.frame( year = r$year, hazard = recode_hazard(h), stringsAsFactors = FALSE) } hz_yr <- bind_rows(hz_rows) %>% filter(hazard != "Other", year >= 2009) %>% count(hazard, year) hz_o <- hz_yr %>% group_by(hazard) %>% summarise(t = sum(n)) %>% arrange(t) %>% pull(hazard) hz_yr$hazard <- factor(hz_yr$hazard, levels = hz_o) ed_fig5 <- ggplot(hz_yr, aes(x = year, y = hazard, fill = n)) + geom_tile(color = "white", linewidth = 0.4) + geom_text(aes(label = ifelse(n > 0, n, "")), size = 3.2, color = "grey20") + # comment 15: larger cell labels scale_fill_gradientn(colors = c("#F5F5F5","#CCDDEE","#6699CC","#336699"), name = "n") + scale_x_continuous(breaks = seq(2010, 2024, 2)) + labs(x = NULL, y = NULL) + theme_ncc(base = 11) + # comment 15: larger base font theme(axis.line = element_blank(), axis.text = element_text(size = 10), legend.text = element_text(size = 9), legend.title = element_text(size = 10)) save_fig(ed_fig5, "ED_Fig7_hazard_year_180mm.png", NCC_W180, 4.3) # ── ED Fig 6: Cross-theory construct dumbbell ──────────────────────────────── # CAPTION # Extended Data Figure 8 | Cross-theory variation in shared construct # measurement. Constructs measured under more than one theoretical framework # are mapped to standardised labels. Each row shows a construct, with coloured # points indicating the measurement rate within each theory that uses it. # Grey horizontal bars span the range of rates; Δ values indicate the # percentage-point spread between the lowest and highest rate. Rows are # ordered by spread (smallest at top, largest at bottom). ################################################################################ std_con <- function(c) case_when( c %in% c("Fear / Worry","Fear","Worry","Dread","Affective response") ~ "Fear / Affect", c %in% c("Perceived vulnerability","Perceived susceptibility") ~ "Perceived vulnerability", c %in% c("Risk perception","Risk appraisal") ~ "Risk perception", c %in% c("Protection motivation","Intention","Protective action") ~ "Behavioral intention", c %in% c("Perceived barriers","Response cost") ~ "Perceived barriers/cost", TRUE ~ c) tile_agg <- cdf %>% mutate(construct_std = std_con(construct)) %>% group_by(theory, construct_std) %>% summarise(p = max(p), n_hit = sum(n_hit), n_total = first(n_total), .groups = "drop") shared <- tile_agg %>% group_by(construct_std) %>% filter(n() >= 2) %>% ungroup() cr <- shared %>% group_by(construct_std) %>% summarise(mean_p = mean(p), min_p = min(p), max_p = max(p), range_p = max(p) - min(p), .groups = "drop") %>% mutate(construct_std = fct_reorder(construct_std, range_p, .desc = FALSE)) ed_fig6 <- ggplot() + geom_segment(data = cr, aes(x = min_p, xend = max_p, y = construct_std, yend = construct_std), color = "grey80", linewidth = 2, alpha = 0.5) + geom_point(data = shared %>% mutate(construct_std = factor(construct_std, levels = levels(cr$construct_std))), aes(x = p, y = construct_std, fill = theory), shape = 21, size = 3, color = "white", stroke = 0.3, alpha = 0.9) + geom_text(data = cr, aes(x = max_p + 0.03, y = construct_std, label = paste0("\u0394", round(range_p*100), "pp")), size = 4.3, hjust = 0, color = "grey30") + scale_fill_manual(values = PAL_THEORY, name = "Theory") + scale_x_continuous(labels = percent_format(1), limits = c(0, 1.2), breaks = c(0, 0.25, 0.5, 0.75, 1)) + labs(x = "Measurement rate", y = NULL) + theme_ncc(base = 11) + theme(legend.position = "right", legend.key.size = unit(0.4, "cm"), legend.text = element_text(size = 11), legend.title = element_text(size = 12), axis.text.y = element_text(size = 13), axis.text.x = element_text(size = 12), axis.title.x = element_text(size = 13), plot.margin = margin(2, 4, 2, 2)) save_fig(ed_fig6, "ED_Fig8_crosstheory_dumbbell_180mm.png", NCC_W180, 4.9) # ── ED Fig 8: Aggregate vs disaggregated PMT/PADM operationalization ──────── # CAPTION # Extended Data Figure 10 | Aggregate vs disaggregated operationalisation # of PMT and PADM. Each bar shows the proportion of papers applying the # theory that operationalise constructs in (i) fully disaggregated form # (explicit specific subconstructs measured, e.g., perceived severity, # response efficacy, etc.); (ii) partial form (some specific subconstructs # plus an aggregate construct such as "threat appraisal" or "coping # appraisal"); or (iii) aggregate-only form (only the aggregate construct # measured, with no specific subconstruct items). Labels show n (%) for # segments >= 10%. ################################################################################ classify_op <- function(pat, sub_pats) { paps <- long %>% filter(grepl(pat, theory_full, ignore.case = TRUE), !is.na(theory_constructs_measured)) %>% distinct(file_id, .keep_all = TRUE) # Harmonised denominator: keep only papers with a codable construct # description (same filter as detect_constructs / the UpSet figures), # so ED Fig 8 n matches Fig 3/Fig 4 (PMT = 85, PADM = 57). paps <- paps[!sapply(paps$theory_constructs_measured, is_coder_note), ] paps$has_agg <- grepl("(?i)threat appraisal|coping appraisal|risk appraisal", paps$theory_constructs_measured, perl = TRUE) paps$n_spec <- rowSums(sapply(sub_pats, function(p) grepl(p, paps$theory_constructs_measured, ignore.case = TRUE, perl = TRUE))) paps %>% mutate(op_type = factor(case_when( has_agg & n_spec == 0 ~ "Aggregate only", has_agg & n_spec >= 1 ~ "Partial", TRUE ~ "Fully disaggregated"), levels = c("Fully disaggregated", "Partial", "Aggregate only"))) } pmt_p <- classify_op("Protection Motivation", c("severity|perceived consequence|perceived damage", "vulnerability|susceptibility|perceived probability|perceived likelihood", "self.?efficacy", "response efficacy", "response cost|perceived cost|perceived barrier|effort|feasib")) padm_p <- classify_op("Protective Action Decision", c("risk perception|perceived risk|perceived exposure|perceived likelihood", "protective action|preparedness|evacuation|adoption", "situational facilitat|adaptive capacity|household|resource|impediment|shelter", "information seek|information source|warning|channel|message", "prior experience|past experience|evacuation experience", "stakeholder|trust|government|responsibility")) op_c <- bind_rows( pmt_p %>% count(op_type) %>% mutate(theory_lab = paste0("PMT (n = ", nrow(pmt_p), ")")), padm_p %>% count(op_type) %>% mutate(theory_lab = paste0("PADM (n = ", nrow(padm_p), ")"))) %>% group_by(theory_lab) %>% mutate(pct = n / sum(n)) %>% ungroup() # ============================================================================= # BLOCK 3 of 3 # Extended Data Fig. 10 (object `ed_fig8` in the script). Replace from the line # op_c$txt_col <- ... # down to and including its save_fig() call. Everything above that line, which # builds pmt_p, padm_p and op_c, is unchanged. # # The stacked bar put two 4% segments side by side for PADM and their labels # collided. A dodged bar with the three categories on the y axis removes the # possibility: every label sits at the end of its own bar. # ============================================================================= dis_levels <- c("Fully disaggregated", "Partial", "Aggregate only") # `op_c` is the data frame already built earlier in this block (columns # theory_lab, op_type, n, pct). Nothing above this line changes. op_c <- op_c %>% mutate(op_type = factor(op_type, levels = rev(dis_levels))) PAL_OP <- c("Fully disaggregated" = "#1F6FB4", "Partial" = "#9EC9E6", "Aggregate only" = "#D1622B") ed_fig8 <- ggplot(op_c, aes(x = pct, y = op_type, fill = op_type)) + geom_col(width = 0.66) + geom_text(aes(label = paste0(n, " (", round(pct * 100), "%)")), hjust = -0.12, size = 3.1, colour = "grey15") + facet_wrap(~ theory_lab, ncol = 1, scales = "free_y") + scale_fill_manual(values = PAL_OP, guide = "none") + scale_x_continuous(labels = percent_format(1), limits = c(0, 1.18), breaks = c(0, .25, .5, .75, 1), expand = expansion(mult = c(0, 0))) + labs(x = "Proportion of studies applying the theory", y = NULL) + theme_ncc(base = 9) + theme(axis.text.y = element_text(size = 9.5), strip.text = element_text(size = 10, face = "bold", hjust = 0), panel.grid.major.y = element_blank(), panel.spacing = unit(0.7, "lines")) save_fig(ed_fig8, "ED_Fig10_disaggregation_180mm.png", NCC_W180, 4.0)