# Advanced Data Operations

    library(clinpubr)
    library(dplyr)
    library(survival)

## Introduction

Clinical research often requires complex data manipulation: multi-source integration, fuzzy matching, temporal alignment, and format conversion. This vignette covers the advanced tools in `clinpubr` for these tasks:

1. Cohort Screening — CONSORT-style exclusion tracking
2. Data Merging — Substring and time-range matching
3. Data Transformation — Long/wide format, multi-choice data
4. Utility Functions — String manipulation, list operations
5. Multi-Table Screening — `screen_data_list()` for complex cohort workflows

## Cohort Screening with Exclusion Tracking

`exclusion_count()` creates a CONSORT-style flow diagram, tracking how many patients are excluded at each stage:

    set.seed(123)

    patients <- data.frame(
      patient_id = 1:100,
      age = round(rnorm(100, 60, 15)),
      gender = sample(c("M", "F"), 100, replace = TRUE),
      has_baseline_data = sample(c(TRUE, FALSE), 100, prob = c(0.9, 0.1), replace = TRUE),
      meets_inclusion = sample(c(TRUE, FALSE), 100, prob = c(0.8, 0.2), replace = TRUE),
      complete_followup = sample(c(TRUE, FALSE), 100, prob = c(0.85, 0.15), replace = TRUE)
    )

    exclusion_summary <- exclusion_count(
      patients,
      age < 50,
      gender != "M",
      !has_baseline_data,
      !meets_inclusion,
      !complete_followup
    )

    knitr::kable(exclusion_summary, caption = "CONSORT-Style Cohort Flow")

CONSORT-Style Cohort Flow
Criteria | N
--- | ---
Initial N | 100
age < 50 | 16
gender != “M” | 44
!has_baseline_data | 7
!meets_inclusion | 6
!complete_followup | 7
Final N | 20

    cat("Retention rate:", round(100 * exclusion_summary$N[nrow(exclusion_summary)] / exclusion_summary$N[1], 1), "%\n")
    #> Retention rate: 20 %

Customize exclusion criteria names:

    exclusion_flow <- exclusion_count(
      patients,
      age < 18 | age > 80,
      !has_baseline_data,
      !meets_inclusion,
      .criteria_names = c(
        "Age outside 18-80 range",
        "Missing baseline data",
        "Does not meet inclusion criteria"
      )
    )

    knitr::kable(exclusion_flow, caption = "Custom Exclusion Flow")

Custom Exclusion Flow
Criteria | N
--- | ---
Initial N | 100
Age outside 18-80 range | 9
Missing baseline data | 10
Does not meet inclusion criteria | 14
Final N | 67

## Data Merging Strategies

### Merge by Substring Matching

`merge_by_substring()` matches records when exact identifiers don’t align (e.g., mapping free-text diagnoses to ICD codes):

    medical_terms <- data.frame(
      match_term = c(
        "Type 2 Diabetes", "Hypertension", "Coronary Artery Disease",
        "Coronary Disease", "Chronic Kidney Disease", "Heart Failure", "Atrial Fibrillation"
      ),
      standard_term = c(
        "Type 2 Diabetes Mellitus", "Hypertension", "Coronary Artery Disease",
        "Coronary Artery Disease", "Chronic Kidney Disease", "Heart Failure", "Atrial Fibrillation"
      ),
      icd_code = c("E11", "I10", "I25", "I25", "N18", "I50", "I48"),
      category = c(
        "Endocrine", "Cardiovascular", "Cardiovascular", "Cardiovascular",
        "Renal", "Cardiovascular", "Cardiovascular"
      )
    )

    patient_diagnoses <- data.frame(
      patient_id = 1:10,
      diagnosis_text = c(
        "Severe Type 2 Diabetes", "Type 2 Diabetes Mellitus",
        "Type 2 Diabetes with Complications", "Essential Hypertension",
        "Hypertensive disease", "CAD - Coronary Artery Disease",
        "Coronary disease", "CKD Stage 3",
        "Congestive Heart Failure", "Heart failure chronic"
      )
    )

    merged_substring <- merge_by_substring(
      data = patient_diagnoses,
      key_df = medical_terms,
      search_col = "diagnosis_text",
      key_col = "match_term",
      value_cols = c("standard_term", "icd_code", "category")
    )

    knitr::kable(medical_terms, caption = "Medical Terms Table")

Medical Terms Table
match_term | standard_term | icd_code | category
--- | --- | --- | ---
Type 2 Diabetes | Type 2 Diabetes Mellitus | E11 | Endocrine
Hypertension | Hypertension | I10 | Cardiovascular
Coronary Artery Disease | Coronary Artery Disease | I25 | Cardiovascular
Coronary Disease | Coronary Artery Disease | I25 | Cardiovascular
Chronic Kidney Disease | Chronic Kidney Disease | N18 | Renal
Heart Failure | Heart Failure | I50 | Cardiovascular
Atrial Fibrillation | Atrial Fibrillation | I48 | Cardiovascular

    knitr::kable(merged_substring, caption = "Diagnoses with Mapped ICD Codes")

Diagnoses with Mapped ICD Codes
diagnosis_text | patient_id | standard_term | icd_code | category
--- | --- | --- | --- | ---
CAD - Coronary Artery Disease | 6 | Coronary Artery Disease | I25 | Cardiovascular
CKD Stage 3 | 8 | NA | NA | NA
Congestive Heart Failure | 9 | Heart Failure | I50 | Cardiovascular
Coronary disease | 7 | Coronary Artery Disease | I25 | Cardiovascular
Essential Hypertension | 4 | Hypertension | I10 | Cardiovascular
Heart failure chronic | 10 | Heart Failure | I50 | Cardiovascular
Hypertensive disease | 5 | NA | NA | NA
Severe Type 2 Diabetes | 1 | Type 2 Diabetes Mellitus | E11 | Endocrine
Type 2 Diabetes Mellitus | 2 | Type 2 Diabetes Mellitus | E11 | Endocrine
Type 2 Diabetes with Complications | 3 | Type 2 Diabetes Mellitus | E11 | Endocrine

### Merge by Range (Time-Based Matching)

`merge_by_range()` matches events within specific time windows (e.g., lab results during hospitalization):

    patient_visits <- data.frame(
      patient_id = rep(1:3, each = 2),
      visit_id = 1:6,
      visit_start = as.Date(c(
        "2023-01-01", "2023-06-01", "2023-02-01",
        "2023-07-01", "2023-03-01", "2023-08-01"
      )),
      visit_end = as.Date(c(
        "2023-01-10", "2023-06-10", "2023-02-10",
        "2023-07-10", "2023-03-10", "2023-08-10"
      ))
    )

    lab_results <- data.frame(
      lab_id = 1:6,
      patient_id = c(1, 1, 2, 2, 3, 3),
      test_date = as.Date(c(
        "2023-01-05", "2023-06-05", "2023-02-03",
        "2023-07-08", "2023-03-15", "2023-08-05"
      )),
      test_name = c("Glucose", "HbA1c", "Glucose", "Creatinine", "Glucose", "Lipid panel"),
      result = round(rnorm(6, 100, 15), 1)
    )

    merged_range <- merge_by_range(
      x = patient_visits, y = lab_results,
      by = "patient_id",
      x_start = "visit_start", x_end = "visit_end",
      y_val = "test_date"
    )

    knitr::kable(merged_range, caption = "Labs Matched to Visit Windows")

Labs Matched to Visit Windows
patient_id | visit_id | visit_start | visit_end | lab_id | test_date | test_name | result | since_start
--- | --- | --- | --- | --- | --- | --- | --- | ---
1 | 1 | 2023-01-01 | 2023-01-10 | 1 | 2023-01-05 | Glucose | 89.3 | 4
1 | 2 | 2023-06-01 | 2023-06-10 | 2 | 2023-06-05 | HbA1c | 88.7 | 4
2 | 3 | 2023-02-01 | 2023-02-10 | 3 | 2023-02-03 | Glucose | 85.9 | 2
2 | 4 | 2023-07-01 | 2023-07-10 | 4 | 2023-07-08 | Creatinine | 84.2 | 7
3 | 6 | 2023-08-01 | 2023-08-10 | 6 | 2023-08-05 | Lipid panel | 105.0 | 4
NA | NA | NA | NA | 5 | 2023-03-15 | Glucose | 93.4 | NA

## Data Transformation

### Long to Wide Format

`to_wide()` converts long-format data (one row per measurement) to wide format (one row per patient) to facilitate analysis:

    long_labs <- data.frame(
      patient_id = rep(1:5, each = 3),
      visit = rep(c(1, 2), times = c(8, 7)),
      test = rep(c("glucose", "creatinine", "cholesterol"), 5),
      value = round(rnorm(15, 100, 20), 1)
    )

    wide_labs <- to_wide(
      df = long_labs,
      keys = c("patient_id", "visit"),
      item_col = "test",
      value_col = "value"
    )

    knitr::kable(head(long_labs), caption = "Laboratory Data - Long Format")

Laboratory Data - Long Format
patient_id | visit | test | value
--- | --- | --- | ---
1 | 1 | glucose | 59.7
1 | 1 | creatinine | 104.2
1 | 1 | cholesterol | 124.7
2 | 1 | glucose | 140.8
2 | 1 | creatinine | 126.0
2 | 1 | cholesterol | 115.1

    knitr::kable(head(wide_labs), caption = "Laboratory Data - Wide Format")

Laboratory Data - Wide Format
patient_id | visit | cholesterol | creatinine | glucose
--- | --- | --- | --- | ---
1 | 1 | 124.7 | 104.2 | 59.7
2 | 1 | 115.1 | 126.0 | 140.8
3 | 1 | NA | 88.0 | 65.5
3 | 2 | 93.0 | NA | NA
4 | 2 | 74.8 | 97.9 | 114.1
5 | 2 | 104.7 | 118.2 | 133.7

### Multi-Choice Data

`split_multichoice()` splits comma-separated multi-choice columns into binary indicators; `combine_multichoice()` recombines them:

    set.seed(456)
    survey_data <- data.frame(
      id = 1:20,
      symptoms = sapply(1:20, function(x) {
        paste(sample(
          c("fever", "cough", "headache", "fatigue"),
          sample(1:4, 1)
        ), collapse = ",")
      }),
      comorbidities = sapply(1:20, function(x) {
        paste(sample(
          c("diabetes", "hypertension"),
          sample(1:2, 1)
        ), collapse = ",")
      })
    )

    symptoms_split <- split_multichoice(
      survey_data,
      quest_cols = c("symptoms", "comorbidities"),
      split = ",",
      remove_space = FALSE
    )

    knitr::kable(head(survey_data), caption = "Multi-Choice Data")

Multi-Choice Data
id | symptoms | comorbidities
--- | --- | ---
1 | fever | diabetes
2 | cough,fever,fatigue | diabetes,hypertension
3 | fever,cough,fatigue | hypertension
4 | fever,headache | diabetes
5 | headache,fatigue | hypertension,diabetes
6 | fatigue,cough,headache | diabetes

    knitr::kable(head(symptoms_split), caption = "Split Multi-Choice Data")

Split Multi-Choice Data
id | symptoms_fever | symptoms_cough | symptoms_fatigue | symptoms_headache | comorbidities_diabetes | comorbidities_hypertension
--- | --- | --- | --- | --- | --- | ---
1 | TRUE | FALSE | FALSE | FALSE | TRUE | FALSE
2 | TRUE | TRUE | TRUE | FALSE | TRUE | TRUE
3 | TRUE | TRUE | TRUE | FALSE | FALSE | TRUE
4 | TRUE | FALSE | FALSE | TRUE | TRUE | FALSE
5 | FALSE | FALSE | TRUE | TRUE | TRUE | TRUE
6 | FALSE | TRUE | TRUE | TRUE | TRUE | FALSE

    combined <- combine_multichoice(
      symptoms_split,
      quest_cols = list(
        respiratory = c("symptoms_cough", "symptoms_fatigue"),
        systemic = c("symptoms_fever", "symptoms_headache")
      ),
      sep = ","
    )

    knitr::kable(head(combined), caption = "Combined Symptom Groups")

Combined Symptom Groups
id | comorbidities_diabetes | comorbidities_hypertension | respiratory | systemic
--- | --- | --- | --- | ---
1 | TRUE | FALSE |  | fever
2 | TRUE | TRUE | cough,fatigue | fever
3 | FALSE | TRUE | cough,fatigue | fever
4 | TRUE | FALSE |  | fever,headache
5 | TRUE | TRUE | fatigue | headache
6 | TRUE | FALSE | cough,fatigue | headache

## Utility Functions

### String Manipulation

`common_prefix()` extracts the common prefix from a character vector, could be used when processing hospital exports to identify files from the same patient or batch processing multi-site survey data by site prefix.

    file_names <- c("patient_001_lab.csv", "patient_001_visit.csv", "patient_001_demo.csv")
    common_prefix(file_names)
    #> [1] "patient_001_"

`str_match_replace()` replaces matched patterns in strings with specified replacements, could be used when standardizing lab test names across hospitals or unifying option labels across translated questionnaires.

    test_names <- c("Glucose_Fasting", "Glucose_Random", "Cholesterol_Total", "LDL_Calculated")
    standardized <- str_match_replace(
      x = test_names,
      to_match = c("Glucose", "Cholesterol", "LDL"),
      to_replace = c("GLU", "CHOL", "LDL_CHOL")
    )

    knitr::kable(data.frame(Original = test_names, Standardized = standardized),
      caption = "Test Name Standardization"
    )

Test Name Standardization
Original | Standardized
--- | ---
Glucose_Fasting | GLU_Fasting
Glucose_Random | GLU_Random
Cholesterol_Total | CHOL_Total
LDL_Calculated | LDL_CHOL_Calculated

### List and Data Frame Operations

`add_lists()` adds corresponding elements of two lists element-wise, could be used when aggregating disease incidence counts across time periods or summing response frequencies across survey sites.

    list1 <- list(diabetes = 10, hypertension = 20, asthma = 5)
    list2 <- list(diabetes = 15, hypertension = 25, asthma = 8)
    add_lists(list1, list2)
    #> $diabetes
    #> [1] 25
    #>
    #> $hypertension
    #> [1] 45
    #>
    #> $asthma
    #> [1] 13

`merge_ordered_vectors()` merges multiple ordered vectors preserving unique elements and original ordering, could be used when combining inclusion criteria lists from multi-site studies or merging question orders across questionnaire versions.

    sites <- list(
      c("Diabetes", "Hypertension", "Heart Failure", "CKD"),
      c("Hypertension", "COPD", "Diabetes", "Cancer"),
      c("CKD", "Diabetes", "Stroke", "Hypertension")
    )
    merge_ordered_vectors(sites)
    #> [1] "COPD"          "Diabetes"      "Stroke"        "Hypertension"
    #> [5] "Heart Failure" "Cancer"        "CKD"

`replace_elements()` replaces specified elements in a vector with new values, could be used when correcting data entry errors in clinical data or harmonizing option codes across survey interviewers.

    sample_data <- data.frame(
      group = c("Cntrol", "Treetment", "Placebo", "Cntrol", "Treatment"),
      value = 1:5
    )
    recoded <- replace_elements(
      x = sample_data$group,
      from = c("Cntrol", "Treetment"),
      to = c("Control", "Treatment")
    )
    knitr::kable(data.frame(Original = sample_data$group, Recoded = recoded),
      caption = "Group Recoding"
    )

Group Recoding
Original | Recoded
--- | ---
Cntrol | Control
Treetment | Treatment
Placebo | Placebo
Cntrol | Control
Treatment | Treatment

`fill_with_last()` fills missing values with the last valid observation (LOCF), could be used when handling merged cells from Excel imports of EMR data or filling respondent demographics across repeated survey measures.

    time_series <- c(120, NA, NA, 125, NA, 130, NA, NA)
    knitr::kable(data.frame(Original = time_series, Filled = fill_with_last(time_series)),
      caption = "Last Observation Carried Forward"
    )

Last Observation Carried Forward
Original | Filled
--- | ---
120 | 120
NA | 120
NA | 120
125 | 125
NA | 125
130 | 130
NA | 130
NA | 130

## Multi-Table Cohort Screening

`screen_data_list()` filters and joins multiple tables based on clinical criteria, with full audit trails. This is essential for retrospective EHR studies.

### Scenario: Building a Diabetes Cohort

    # Patient demographics
    patient <- data.frame(
      pid = 1:50,
      age = sample(25:75, 50, replace = TRUE),
      gender = sample(c("M", "F"), 50, replace = TRUE)
    )

    # Admission records
    admission <- data.frame(
      pid = c(1, 1, 2, 2, 3, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12),
      vid = 101:115,
      admit_day = c(1, 30, 5, 45, 10, 60, 15, 20, 25, 35, 40, 50, 55, 65, 70)
    )

    # Diagnosis records
    diagnosis <- data.frame(
      pid = c(1, 1, 2, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12),
      vid = c(101, 102, 103, 104, 105, 107, 108, 109, 110, 111, 112, 113, 114, 115),
      dx_day = c(1, 30, 5, 45, 10, 15, 20, 25, 35, 40, 50, 55, 65, 70),
      icd = c("E11", "I10", "N18", "E11", "E11", "I25", "E11", "J18", "E11", "I10", "E11", "N18", "E11", "I50")
    )

    # Lab results
    lab <- data.frame(
      pid = c(1, 1, 2, 2, 3, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12),
      vid = c(101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115),
      lab_day = c(1, 30, 5, 45, 10, 60, 15, 20, 25, 35, 40, 50, 55, 65, 70),
      HbA1c = c(8.5, 7.2, 9.1, 7.8, 8.0, 6.9, 7.5, 8.2, 7.0, 9.5, 7.8, 8.1, 7.3, 8.8, 7.6)
    )

### Screen and Filter

Select patients with diabetes (ICD: E11), keeping records from first diabetes diagnosis onward:

    screened_data <- screen_data_list(
      data_list = list(
        patient = patient, admission = admission,
        diagnosis = diagnosis, lab = lab
      ),
      entry_expr = any(icd == "E11"),
      entry_level = "patient_id",
      anchor_expr = icd == "E11",
      anchor_level = "date",
      patient_id_map = "pid",
      visit_id_map = c(admission = "vid", diagnosis = "vid", lab = "vid"),
      date_map = c(admission = "admit_day", diagnosis = "dx_day", lab = "lab_day"),
      output = "list",
      return_audit = TRUE
    )

    knitr::kable(screened_data$audit$entry_scope, caption = "Entry Stage Audit")

Entry Stage Audit
step | table | before | after | removed
--- | --- | --- | --- | ---
entry_scope | patient | 50 | 7 | 43
entry_scope | admission | 15 | 10 | 5
entry_scope | diagnosis | 14 | 9 | 5
entry_scope | lab | 15 | 10 | 5

    knitr::kable(screened_data$audit$anchor_scope, caption = "Anchor Stage Audit")

Anchor Stage Audit
step | table | before | after | removed
--- | --- | --- | --- | ---
anchor_scope | patient | 7 | 7 | 0
anchor_scope | admission | 10 | 9 | 1
anchor_scope | diagnosis | 9 | 8 | 1
anchor_scope | lab | 10 | 9 | 1

### Review Filtered Data

    knitr::kable(head(screened_data$data$patient), caption = "Filtered Patients")

Filtered Patients
| pid | age | gender
--- | --- | --- | ---
1 | 1 | 51 | M
2 | 2 | 72 | M
3 | 3 | 38 | M
5 | 5 | 75 | F
7 | 7 | 59 | F
9 | 9 | 28 | M

    knitr::kable(screened_data$data$diagnosis, caption = "Filtered Diagnoses")

Filtered Diagnoses
| pid | vid | dx_day | icd
--- | --- | --- | --- | ---
1 | 1 | 101 | 1 | E11
2 | 1 | 102 | 30 | I10
4 | 2 | 104 | 45 | E11
5 | 3 | 105 | 10 | E11
7 | 5 | 108 | 20 | E11
9 | 7 | 110 | 35 | E11
11 | 9 | 112 | 50 | E11
13 | 11 | 114 | 65 | E11

    knitr::kable(screened_data$data$lab, caption = "Filtered Labs")

Filtered Labs
| pid | vid | lab_day | HbA1c
--- | --- | --- | --- | ---
1 | 1 | 101 | 1 | 8.5
2 | 1 | 102 | 30 | 7.2
4 | 2 | 104 | 45 | 7.8
5 | 3 | 105 | 10 | 8.0
6 | 3 | 106 | 60 | 6.9
8 | 5 | 108 | 20 | 8.2
10 | 7 | 110 | 35 | 9.5
12 | 9 | 112 | 50 | 8.1
14 | 11 | 114 | 65 | 8.8

### Joined Output

Alternatively, get a single joined data frame:

    joined_result <- screen_data_list(
      data_list = list(
        patient = patient, admission = admission,
        diagnosis = diagnosis, lab = lab
      ),
      entry_expr = any(icd == "E11"),
      entry_level = "patient_id",
      anchor_expr = any(icd == "E11"),
      anchor_level = "date",
      anchor_window = "from_first_anchor",
      patient_id_map = "pid",
      visit_id_map = c(admission = "vid", diagnosis = "vid", lab = "vid"),
      date_map = c(admission = "admit_day", diagnosis = "dx_day", lab = "lab_day"),
      output = "joined"
    )

    cat("Joined data:", nrow(joined_result), "rows,", ncol(joined_result), "columns\n")
    #> Joined data: 9 rows, 7 columns
    knitr::kable(head(joined_result), caption = "Joined Output")

Joined Output
patient_id | age | gender | visit_id | date | icd | HbA1c
--- | --- | --- | --- | --- | --- | ---
1 | 51 | M | 101 | 1 | E11 | 8.5
1 | 51 | M | 102 | 30 | I10 | 7.2
2 | 72 | M | 104 | 45 | E11 | 7.8
3 | 38 | M | 105 | 10 | E11 | 8.0
3 | 38 | M | 106 | 60 | NA | 6.9
5 | 75 | F | 108 | 20 | E11 | 8.2

## Summary

Function | Clinical Application
--- | ---
`exclusion_count()` | CONSORT-style cohort flow documentation
`screen_data_list()` | Multi-table cohort screening with audit trails
`merge_by_substring()` | Substring matching for diagnosis/procedure coding
`merge_by_range()` | Time-window matching for longitudinal data
`to_wide()` | Long-to-wide format conversion
`split_multichoice()` / `combine_multichoice()` | Survey and symptom data processing
Utility functions | String standardization, list operations, NA filling