1 Purpose and scope

This report documents the reproducible FY 2025-26 analysis of the Parent and Child Together (PACT) Parenting Ladder and Program Improvement surveys. It covers survey participation, parenting outcomes, family activities, participant characteristics, and program experience. No focus-group component was conducted this year.

The primary Parenting Ladder analysis uses distinct survey episodes. Rows that repeat the same participant, survey date, and response pattern because of multiple service records are collapsed. Genuinely different survey episodes are retained. A sensitivity analysis also limits the data to the most recent episode for each participant.

2 Data import and validation

pre_raw <- read_excel(pre_file, sheet = "Pre + Demographics - Rows") |>
  clean_names()

post_raw <- read_excel(post_file, sheet = "Post + Demographics - Rows") |>
  clean_names()

pi_raw <- read_excel(pi_file, sheet = "PACT Program Improvement Survey") |>
  clean_names()

expected_pl_rows <- 344L
expected_pl_items <- 16L
expected_pi_items <- 16L

stopifnot(
  nrow(pre_raw) == nrow(post_raw),
  ncol(pre_raw) >= 44,
  ncol(post_raw) >= 46,
  ncol(pi_raw) >= 22
)

if (!identical(as.character(pre_raw[[1]]), as.character(post_raw[[1]]))) {
  stop(
    "The pre and post files are not aligned row-for-row by Participant ID. ",
    "Review the source export before continuing.",
    call. = FALSE
  )
}

if (
  sum(str_detect(names(pre_raw)[26:41], "^x?\\d+_")) != expected_pl_items ||
  sum(str_detect(names(post_raw)[26:41], "^x?\\d+_")) != expected_pl_items ||
  sum(str_detect(names(pi_raw)[4:19], "^x?\\d+_")) != expected_pi_items
) {
  stop(
    "The expected 16-item survey blocks were not found in their prior locations. ",
    "Review the workbook structure before continuing.",
    call. = FALSE
  )
}

2.1 Item definitions

pl_dictionary <- tibble(
  item_number = 1:16,
  item_label = c(
    "Knowledge of how my child is growing and developing",
    "Knowledge of what behavior is typical at this age",
    "Confidence in myself as a parent",
    "Confidence I can help my child learn",
    "Confidence in setting limits for my child",
    "Ability to keep my child safe and healthy",
    "Ability to recognize when my child is upset",
    "Find positive ways to guide and discipline my child",
    "Listen to my child to understand their feelings",
    "Know fun activities to help my child learn",
    "Play with my child frequently",
    "Number of other families I can depend on for support",
    "Strength of my connections to other families",
    "Ability to get services that I need for my child",
    "Ability to get services that I need for myself",
    "Ability to manage the day-to-day stress of being a parent"
  ),
  factor = c(
    rep("Parental Knowledge, Confidence, and Abilities", 11),
    rep("Social Support", 2),
    rep("Ability to Get Services", 2),
    "Additional Parenting Stress Item"
  )
)

activity_dictionary <- tibble(
  activity = c("Read or look at picture books", "Talk or share stories", "Sing"),
  activity_order = 1:3
)

pi_dictionary <- tibble(
  item_number = 1:16,
  item_label = c(
    "Services and activities are offered at a convenient time and location",
    "Staff are welcoming and respectful",
    "Staff ask about my family's concerns",
    "Staff follow up about my family's concerns",
    "Staff respect my culture and traditions",
    "Staff communicate with me in my home language",
    "Staff respect my identity",
    "The program offers opportunities to learn about diversity, equity, and inclusion",
    "Staff value my feedback and ideas",
    "I spend more time playing and interacting with my child",
    "I have opportunities to build strong relationships with other families",
    "I have other families I can depend on for support",
    "I am able to get the services my family needs",
    "We have more consistent routines at home",
    "I am better able to understand and respond to my child's cues",
    "I am better able to understand and support my child's behavior"
  ),
  domain = c(rep("Services and Staff", 9), rep("Parent and Family Outcomes", 7))
)

2.2 Construct the paired Parenting Ladder file

The source exports contain one row per associated service. Consequently, the same survey can appear on multiple rows. The code below builds a paired record, then collapses rows only when the participant ID, survey-entry date, and all outcome responses are identical.

to_numeric <- function(x) suppressWarnings(as.numeric(as.character(x)))

parse_survey_date <- function(x) {
  if (inherits(x, "Date")) return(x)
  if (inherits(x, c("POSIXct", "POSIXt"))) return(as.Date(x))
  parsed <- suppressWarnings(lubridate::parse_date_time(
    as.character(x),
    orders = c("mdy", "ymd", "mdy HMS", "ymd HMS")
  ))
  as.Date(parsed)
}

pre_items <- pre_raw[, 26:41] |>
  mutate(across(everything(), to_numeric))
names(pre_items) <- sprintf("pl_%02d_pre", 1:16)

post_items <- post_raw[, 26:41] |>
  mutate(across(everything(), to_numeric))
names(post_items) <- sprintf("pl_%02d_post", 1:16)

pre_activities <- pre_raw[, 42:44] |>
  mutate(across(everything(), to_numeric))
names(pre_activities) <- c("read_pre", "talk_pre", "sing_pre")

# The post export contains embedded Before PACT copies for Read and Talk.
# Columns 43, 45, and 46 contain the intended NOW values.
post_activities <- post_raw[, c(43, 45, 46)] |>
  mutate(across(everything(), to_numeric))
names(post_activities) <- c("read_post", "talk_post", "sing_post")

pl_paired_rows <- bind_cols(
  pre_raw |>
    transmute(
      participant_id = as.character(participant_id),
      survey_date = parse_survey_date(date_pl_survey_entered),
      service_date = parse_survey_date(date_of_service),
      enrollment = as.character(enrollment_associated_with_pl_survey),
      gender = as.character(gender_genero),
      ethnicity = as.character(ethnicity_cual_es_su_etnicidad),
      primary_language = as.character(primary_language_cual_es_el_primer_idioma),
      client_type = as.character(client_type),
      employment = as.character(what_is_your_current_employment_status_cual_es_su_situacion_laboral),
      income = as.character(what_was_your_family_income_in_the_last_12_months),
      education = as.character(what_is_your_highest_level_of_education),
      survey_language = as.character(language_of_survey)
    ),
  pre_items,
  post_items,
  pre_activities,
  post_activities
)

response_columns <- c(
  names(pre_items), names(post_items),
  names(pre_activities), names(post_activities)
)

pl_episodes <- pl_paired_rows |>
  arrange(participant_id, survey_date, service_date) |>
  distinct(
    participant_id,
    survey_date,
    across(all_of(response_columns)),
    .keep_all = TRUE
  ) |>
  group_by(participant_id) |>
  mutate(episode_number = row_number()) |>
  ungroup() |>
  mutate(episode_id = paste(participant_id, episode_number, sep = "_"))

pl_latest_participant <- pl_episodes |>
  arrange(participant_id, desc(survey_date), desc(service_date)) |>
  distinct(participant_id, .keep_all = TRUE)

stopifnot(
  all(map_lgl(pl_episodes[response_columns], ~ all(is.na(.x) | .x %in% 0:7))),
  n_distinct(pl_episodes$participant_id) == n_distinct(pre_raw$participant_id)
)

2.3 Construct the Program Improvement file

pi_items <- pi_raw[, 4:19]
names(pi_items) <- sprintf("pi_%02d", 1:16)

pi_activities <- pi_raw[, 20:22] |>
  mutate(across(everything(), to_numeric))
names(pi_activities) <- c("read", "talk", "sing")

pi <- bind_cols(
  pi_raw |>
    transmute(
      participant_id = as.character(participant_record_id),
      survey_date = parse_survey_date(date_survey_completed),
      survey_language = as.character(language_of_survey)
    ),
  pi_items,
  pi_activities
) |>
  distinct()

likert_levels <- c("Strongly Disagree", "Disagree", "Agree", "Strongly Agree")

pi <- pi |>
  mutate(
    across(starts_with("pi_"), ~ factor(.x, levels = likert_levels)),
    across(c(read, talk, sing), to_numeric)
  )

stopifnot(
  length(grep("^pi_\\d{2}$", names(pi))) == expected_pi_items,
  all(map_lgl(pi[c("read", "talk", "sing")], ~ all(is.na(.x) | .x %in% 0:7)))
)

2.4 Data-quality summary

qa_summary <- tibble(
  measure = c(
    "Parenting Ladder pre source rows",
    "Parenting Ladder post source rows",
    "Distinct Parenting Ladder participants",
    "Distinct Parenting Ladder survey episodes",
    "Participants with more than one distinct episode",
    "Program Improvement source rows",
    "Distinct Program Improvement submissions after exact deduplication",
    "Distinct Program Improvement participants",
    "Program Improvement participants with multiple submissions"
  ),
  value = c(
    nrow(pre_raw),
    nrow(post_raw),
    n_distinct(pl_episodes$participant_id),
    nrow(pl_episodes),
    pl_episodes |> count(participant_id) |> filter(n > 1) |> nrow(),
    nrow(pi_raw),
    nrow(pi),
    n_distinct(pi$participant_id),
    pi |> count(participant_id) |> filter(n > 1) |> nrow()
  )
)

kable(qa_summary, col.names = c("Data-quality measure", "Count"))

Data-quality measure	Count
Parenting Ladder pre source rows	344
Parenting Ladder post source rows	344
Distinct Parenting Ladder participants	225
Distinct Parenting Ladder survey episodes	241
Participants with more than one distinct episode	16
Program Improvement source rows	140
Distinct Program Improvement submissions after exact deduplication	140
Distinct Program Improvement participants	132
Program Improvement participants with multiple submissions	8

3 Parenting Ladder findings

3.1 Item-level change

paired_item_result <- function(data, item_number) {
  pre_name <- sprintf("pl_%02d_pre", item_number)
  post_name <- sprintf("pl_%02d_post", item_number)
  pairs <- data |>
    transmute(pre = .data[[pre_name]], post = .data[[post_name]]) |>
    drop_na()

  test <- t.test(pairs$post, pairs$pre, paired = TRUE)
  difference <- pairs$post - pairs$pre

  tibble(
    item_number = item_number,
    matched_n = nrow(pairs),
    mean_pre = mean(pairs$pre),
    mean_post = mean(pairs$post),
    mean_change = mean(difference),
    pct_6_7_pre = mean(pairs$pre %in% 6:7) * 100,
    pct_6_7_post = mean(pairs$post %in% 6:7) * 100,
    t_statistic = unname(test$statistic),
    df = unname(test$parameter),
    p_value = test$p.value,
    cohen_dz = mean(difference) / sd(difference)
  )
}

pl_item_results <- map_dfr(1:16, ~ paired_item_result(pl_episodes, .x)) |>
  left_join(pl_dictionary, by = "item_number") |>
  mutate(
    p_adjusted_bh = p.adjust(p_value, method = "BH"),
    significant = p_adjusted_bh < .05
  )

kable(
  pl_item_results |>
    transmute(
      Item = item_label,
      N = matched_n,
      Before = round(mean_pre, 1),
      After = round(mean_post, 1),
      Change = round(mean_change, 1),
      `Before 6 or 7` = scales::percent(pct_6_7_pre / 100, accuracy = 1),
      `After 6 or 7` = scales::percent(pct_6_7_post / 100, accuracy = 1),
      `Adjusted p` = format.pval(p_adjusted_bh, digits = 3, eps = .001),
      `Effect size` = round(cohen_dz, 2)
    ),
  align = c("l", rep("r", 8))
)

Item	N	Before	After	Change	Before 6 or 7	After 6 or 7	Adjusted p	Effect size
Knowledge of how my child is growing and developing	237	4.7	6.4	1.7	25%	91%	<0.001	1.54
Knowledge of what behavior is typical at this age	236	4.7	6.4	1.8	25%	91%	<0.001	1.43
Confidence in myself as a parent	236	4.9	6.4	1.5	36%	90%	<0.001	1.23
Confidence I can help my child learn	235	5.1	6.7	1.5	42%	95%	<0.001	1.22
Confidence in setting limits for my child	236	4.8	6.2	1.4	32%	80%	<0.001	1.11
Ability to keep my child safe and healthy	236	6.2	6.8	0.6	78%	97%	<0.001	0.60
Ability to recognize when my child is upset	235	5.9	6.7	0.9	66%	97%	<0.001	0.71
Find positive ways to guide and discipline my child	233	5.0	6.3	1.4	33%	85%	<0.001	1.12
Listen to my child to understand their feelings	237	5.2	6.5	1.3	46%	91%	<0.001	1.01
Know fun activities to help my child learn	236	4.5	6.6	2.1	21%	94%	<0.001	1.45
Play with my child frequently	236	5.4	6.7	1.3	52%	94%	<0.001	0.96
Number of other families I can depend on for support	228	4.1	5.5	1.4	21%	63%	<0.001	1.07
Strength of my connections to other families	233	4.1	5.7	1.6	20%	64%	<0.001	1.15
Ability to get services that I need for my child	235	4.8	6.4	1.6	35%	87%	<0.001	1.05
Ability to get services that I need for myself	233	4.8	6.2	1.3	35%	76%	<0.001	0.95
Ability to manage the day-to-day stress of being a parent	235	4.5	6.1	1.6	27%	78%	<0.001	1.21

pl_item_plot <- pl_item_results |>
  mutate(item_label = fct_reorder(item_label, mean_change)) |>
  ggplot(aes(y = item_label)) +
  geom_segment(
    aes(x = mean_pre, xend = mean_post, yend = item_label),
    colour = "#B8B8B8", linewidth = 1
  ) +
  geom_point(aes(x = mean_pre, colour = "Before PACT"), size = 3) +
  geom_point(aes(x = mean_post, colour = "After PACT"), size = 3) +
  scale_colour_manual(
    values = c("Before PACT" = colors$before, "After PACT" = colors$after),
    breaks = c("Before PACT", "After PACT")
  ) +
  scale_x_continuous(limits = c(1, 7), breaks = 1:7) +
  labs(
    title = "Parenting Ladder ratings increased after PACT",
    subtitle = "Mean ratings among distinct matched survey episodes",
    x = "Average rating (1 to 7)", y = NULL, colour = NULL
  )

pl_item_plot

3.2 Parenting Ladder factors and reliability

The three established factors use items 1–11, 12–13, and 14–15. Item 16 is reported separately and is not included in a factor score.

factor_map <- list(
  "Parental Knowledge, Confidence, and Abilities" = 1:11,
  "Social Support" = 12:13,
  "Ability to Get Services" = 14:15
)

score_factor <- function(data, indices, wave) {
  selected <- sprintf("pl_%02d_%s", indices, wave)
  values <- as.data.frame(data[selected])
  score <- rowMeans(values, na.rm = TRUE)
  score[rowSums(!is.na(values)) == 0] <- NA_real_
  score
}

pl_factor_scores <- pl_episodes |>
  select(episode_id, participant_id) 

for (factor_name in names(factor_map)) {
  safe_name <- factor_name |> janitor::make_clean_names()
  pl_factor_scores[[paste0(safe_name, "_pre")]] <-
    score_factor(pl_episodes, factor_map[[factor_name]], "pre")
  pl_factor_scores[[paste0(safe_name, "_post")]] <-
    score_factor(pl_episodes, factor_map[[factor_name]], "post")
}

factor_result <- function(factor_name) {
  safe_name <- janitor::make_clean_names(factor_name)
  pairs <- pl_factor_scores |>
    transmute(
      pre = .data[[paste0(safe_name, "_pre")]],
      post = .data[[paste0(safe_name, "_post")]]
    ) |>
    drop_na()
  test <- t.test(pairs$post, pairs$pre, paired = TRUE)
  difference <- pairs$post - pairs$pre
  tibble(
    factor = factor_name,
    matched_n = nrow(pairs),
    mean_pre = mean(pairs$pre),
    mean_post = mean(pairs$post),
    mean_change = mean(difference),
    p_value = test$p.value,
    cohen_dz = mean(difference) / sd(difference)
  )
}

pl_factor_results <- map_dfr(names(factor_map), factor_result)

reliability_results <- map_dfr(names(factor_map), function(factor_name) {
  indices <- factor_map[[factor_name]]
  pre_alpha <- psych::alpha(
    pl_episodes[sprintf("pl_%02d_pre", indices)],
    warnings = FALSE, check.keys = FALSE
  )$total$raw_alpha
  post_alpha <- psych::alpha(
    pl_episodes[sprintf("pl_%02d_post", indices)],
    warnings = FALSE, check.keys = FALSE
  )$total$raw_alpha
  tibble(factor = factor_name, alpha_pre = pre_alpha, alpha_post = post_alpha)
})

kable(
  pl_factor_results |>
    left_join(reliability_results, by = "factor") |>
    transmute(
      Factor = factor,
      N = matched_n,
      Before = round(mean_pre, 1),
      After = round(mean_post, 1),
      Change = round(mean_change, 1),
      `p value` = format.pval(p_value, digits = 3, eps = .001),
      `Effect size` = round(cohen_dz, 2),
      `Alpha before` = round(alpha_pre, 2),
      `Alpha after` = round(alpha_post, 2)
    )
)

Factor	N	Before	After	Change	p value	Effect size	Alpha before	Alpha after
Parental Knowledge, Confidence, and Abilities	237	5.1	6.5	1.4	<0.001	1.45	0.93	0.87
Social Support	236	4.1	5.6	1.5	<0.001	1.19	0.88	0.87
Ability to Get Services	236	4.8	6.3	1.5	<0.001	1.06	0.90	0.78

pl_factor_plot_data <- pl_factor_results |>
  select(factor, mean_pre, mean_post) |>
  pivot_longer(c(mean_pre, mean_post), names_to = "wave", values_to = "mean") |>
  mutate(
    wave = recode(wave, mean_pre = "Before PACT", mean_post = "After PACT"),
    # Reverse the dodge grouping so Before appears above After in the
    # horizontal chart; the legend order remains Before then After below.
    wave = factor(wave, levels = c("After PACT", "Before PACT")),
    factor = forcats::fct_rev(base::factor(factor, levels = names(factor_map)))
  )

pl_factor_plot <- ggplot(pl_factor_plot_data, aes(x = mean, y = factor, fill = wave)) +
  geom_col(position = position_dodge(width = .75), width = .68) +
  geom_text(
    aes(label = number(mean, accuracy = .1)),
    position = position_dodge(width = .75), hjust = -.2, size = 3.6
  ) +
  scale_fill_manual(
    values = c("Before PACT" = colors$before, "After PACT" = colors$after),
    breaks = c("Before PACT", "After PACT")
  ) +
  scale_x_continuous(limits = c(0, 7.4), breaks = 0:7) +
  labs(
    title = "Average ratings on the Parenting Ladder factors",
    x = "Average rating (1 to 7)", y = NULL, fill = NULL
  )

pl_factor_plot

3.2.1 Parents selecting the top two ratings

This companion view shows the average percentage of parents selecting 6 or 7 across the items within each Parenting Ladder factor. Percentages are based on the matched responses available for each item.

significance_stars <- function(p) {
  case_when(
    p < .001 ~ "***",
    p < .01 ~ "**",
    p < .05 ~ "*",
    TRUE ~ ""
  )
}

pl_factor_top_two <- imap_dfr(factor_map, function(indices, factor_name) {
  item_results <- pl_item_results |>
    filter(item_number %in% indices)

  tibble(
    factor = factor_name,
    item_count = nrow(item_results),
    pct_6_7_pre = mean(item_results$pct_6_7_pre, na.rm = TRUE),
    pct_6_7_post = mean(item_results$pct_6_7_post, na.rm = TRUE)
  )
}) |>
  left_join(
    pl_factor_results |> select(factor, matched_n, p_value),
    by = "factor"
  ) |>
  mutate(significance = significance_stars(p_value))

kable(
  pl_factor_top_two |>
    transmute(
      Factor = factor,
      `Items in factor` = item_count,
      `Matched N` = matched_n,
      `Before 6 or 7` = percent(pct_6_7_pre / 100, accuracy = 1),
      `After 6 or 7` = percent(pct_6_7_post / 100, accuracy = 1),
      `p value` = format.pval(p_value, digits = 3, eps = .001)
    )
)

Factor	Items in factor	Matched N	Before 6 or 7	After 6 or 7	p value
Parental Knowledge, Confidence, and Abilities	11	237	41%	91%	<0.001
Social Support	2	236	21%	63%	<0.001
Ability to Get Services	2	236	35%	82%	<0.001

factor_label_levels <- pl_factor_top_two |>
  transmute(factor_label = paste0(factor, significance)) |>
  pull(factor_label)

pl_factor_top_two_plot_data <- pl_factor_top_two |>
  select(factor, significance, pct_6_7_pre, pct_6_7_post) |>
  pivot_longer(
    c(pct_6_7_pre, pct_6_7_post),
    names_to = "wave",
    values_to = "percent_top_two"
  ) |>
  mutate(
    wave = recode(
      wave,
      pct_6_7_pre = "Before PACT",
      pct_6_7_post = "After PACT"
    ),
    # Reverse dodge grouping so Before appears above After while retaining
    # Before-then-After legend order.
    wave = factor(wave, levels = c("After PACT", "Before PACT")),
    factor_label = paste0(factor, significance),
    factor_label = forcats::fct_rev(
      base::factor(
        factor_label,
        levels = factor_label_levels
      )
    )
  )

pl_factor_top_two_plot <- ggplot(
  pl_factor_top_two_plot_data,
  aes(x = percent_top_two, y = factor_label, fill = wave)
) +
  geom_col(position = position_dodge(width = .75), width = .68) +
  geom_text(
    aes(label = percent(percent_top_two / 100, accuracy = 1)),
    position = position_dodge(width = .75), hjust = -.15, size = 3.6
  ) +
  scale_fill_manual(
    values = c("Before PACT" = colors$before, "After PACT" = colors$after),
    breaks = c("Before PACT", "After PACT")
  ) +
  scale_x_continuous(
    limits = c(0, 105), breaks = seq(0, 100, 20),
    labels = ~ percent(.x / 100, accuracy = 1)
  ) +
  labs(
    title = "Parents selecting the top two Parenting Ladder ratings",
    subtitle = "Average percent selecting 6 or 7 across items in each factor",
    x = "Percent selecting 6 or 7", y = NULL, fill = NULL,
    caption = "* p < .05; ** p < .01; *** p < .001 for paired factor-score comparisons."
  )

pl_factor_top_two_plot

3.3 Read, Talk, and Sing activities

activity_result <- function(data, activity) {
  pre_name <- paste0(tolower(activity), "_pre")
  post_name <- paste0(tolower(activity), "_post")
  pairs <- data |>
    transmute(pre = .data[[pre_name]], post = .data[[post_name]]) |>
    drop_na()
  test <- t.test(pairs$post, pairs$pre, paired = TRUE)
  difference <- pairs$post - pairs$pre
  tibble(
    activity = str_to_title(activity),
    matched_n = nrow(pairs),
    mean_pre = mean(pairs$pre),
    mean_post = mean(pairs$post),
    mean_change = mean(difference),
    pct_6_7_pre = mean(pairs$pre %in% 6:7) * 100,
    pct_6_7_post = mean(pairs$post %in% 6:7) * 100,
    p_value = test$p.value,
    cohen_dz = mean(difference) / sd(difference)
  )
}

activity_results <- map_dfr(c("read", "talk", "sing"), ~ activity_result(pl_episodes, .x))

kable(
  activity_results |>
    transmute(
      Activity = activity,
      N = matched_n,
      Before = round(mean_pre, 1),
      After = round(mean_post, 1),
      Change = round(mean_change, 1),
      `Before 6 or 7` = scales::percent(pct_6_7_pre / 100, accuracy = 1),
      `After 6 or 7` = scales::percent(pct_6_7_post / 100, accuracy = 1),
      `p value` = format.pval(p_value, digits = 3, eps = .001),
      `Effect size` = round(cohen_dz, 2)
    )
)

Activity	N	Before	After	Change	Before 6 or 7	After 6 or 7	p value	Effect size
Read	233	4.6	6.1	1.5	33%	71%	<0.001	0.96
Talk	233	5.4	6.5	1.1	54%	84%	<0.001	0.80
Sing	232	5.3	6.6	1.3	51%	91%	<0.001	0.87

activity_plot_data <- activity_results |>
  select(activity, mean_pre, mean_post) |>
  pivot_longer(c(mean_pre, mean_post), names_to = "wave", values_to = "mean") |>
  mutate(
    wave = recode(wave, mean_pre = "Before PACT", mean_post = "After PACT"),
    wave = factor(wave, levels = c("Before PACT", "After PACT"))
  )

activity_plot <- ggplot(activity_plot_data, aes(x = activity, y = mean, fill = wave)) +
  geom_col(position = position_dodge(width = .75), width = .68) +
  geom_text(
    aes(label = number(mean, accuracy = .1)),
    position = position_dodge(width = .75), vjust = -.4
  ) +
  scale_fill_manual(
    values = c("Before PACT" = colors$before, "After PACT" = colors$after),
    breaks = c("Before PACT", "After PACT")
  ) +
  scale_y_continuous(limits = c(0, 7.5), breaks = 0:7) +
  labs(
    title = "Frequency of weekly activities with children",
    subtitle = "Average number of days per week",
    x = NULL, y = "Average days per week", fill = NULL
  )

activity_plot

3.4 Sensitivity analysis

The following comparison checks whether retaining multiple distinct episodes for a small number of participants materially changes the findings.

episode_sensitivity <- map_dfr(1:16, ~ paired_item_result(pl_episodes, .x)) |>
  select(item_number, episode_change = mean_change)

participant_sensitivity <- map_dfr(1:16, ~ paired_item_result(pl_latest_participant, .x)) |>
  select(item_number, participant_change = mean_change)

sensitivity_results <- episode_sensitivity |>
  left_join(participant_sensitivity, by = "item_number") |>
  left_join(pl_dictionary, by = "item_number") |>
  mutate(absolute_difference = abs(episode_change - participant_change))

kable(
  sensitivity_results |>
    transmute(
      Item = item_label,
      `Episode-level change` = round(episode_change, 2),
      `One-participant change` = round(participant_change, 2),
      `Absolute difference` = round(absolute_difference, 2)
    )
)

Item	Episode-level change	One-participant change	Absolute difference
Knowledge of how my child is growing and developing	1.69	1.71	0.02
Knowledge of what behavior is typical at this age	1.78	1.79	0.01
Confidence in myself as a parent	1.52	1.52	0.00
Confidence I can help my child learn	1.51	1.52	0.00
Confidence in setting limits for my child	1.39	1.40	0.01
Ability to keep my child safe and healthy	0.60	0.61	0.01
Ability to recognize when my child is upset	0.85	0.87	0.02
Find positive ways to guide and discipline my child	1.35	1.38	0.03
Listen to my child to understand their feelings	1.27	1.31	0.03
Know fun activities to help my child learn	2.10	2.14	0.04
Play with my child frequently	1.31	1.33	0.02
Number of other families I can depend on for support	1.37	1.34	0.03
Strength of my connections to other families	1.56	1.53	0.03
Ability to get services that I need for my child	1.62	1.58	0.04
Ability to get services that I need for myself	1.34	1.32	0.03
Ability to manage the day-to-day stress of being a parent	1.58	1.57	0.01

4 Participant profile and subgroup results

Demographic summaries use one record per participant to avoid counting participants with multiple survey episodes more than once.

collapse_income <- function(x) {
  x <- str_squish(as.character(x))
  case_when(
    is.na(x) | x == "" ~ NA_character_,
    str_detect(x, regex("prefer|no answer|decline", ignore_case = TRUE)) ~ NA_character_,
    str_detect(x, regex("more than.*100,?000|^\\$?(50|75),?000", ignore_case = TRUE)) ~ "$50,000 or more",
    str_detect(x, regex("less than.*10,?000|^\\$?(10|20|30|40),?000", ignore_case = TRUE)) ~ "Under $50,000",
    TRUE ~ NA_character_
  )
}

collapse_education <- function(x) {
  x <- str_squish(as.character(x))
  case_when(
    is.na(x) | x == "" ~ NA_character_,
    str_detect(x, regex("prefer|no answer|decline", ignore_case = TRUE)) ~ NA_character_,
    str_detect(x, regex("less.*high school", ignore_case = TRUE)) ~ "Less than high school",
    str_detect(x, regex("high school|GED", ignore_case = TRUE)) ~ "High school diploma or GED",
    str_detect(x, regex("some college|associate", ignore_case = TRUE)) ~ "Some college or associate degree",
    str_detect(x, regex("bachelor|graduate|professional|master|doctor|PhD", ignore_case = TRUE)) ~ "Bachelor's degree or higher",
    TRUE ~ "Other"
  )
}

participant_profile <- pl_latest_participant |>
  mutate(
    income_group = collapse_income(income),
    education_group = collapse_education(education),
    education_binary = case_when(
      education_group %in% c("Less than high school", "High school diploma or GED") ~ "High school or less",
      education_group %in% c("Some college or associate degree", "Bachelor's degree or higher") ~ "Some college or higher",
      TRUE ~ NA_character_
    )
  )

summarize_categorical <- function(data, variable, characteristic) {
  data |>
    filter(!is.na(.data[[variable]]), str_squish(.data[[variable]]) != "") |>
    count(category = .data[[variable]], name = "n") |>
    mutate(
      characteristic = characteristic,
      denominator = sum(n),
      percent = n / denominator * 100
    ) |>
    select(characteristic, category, n, denominator, percent)
}

demographic_results <- bind_rows(
  summarize_categorical(participant_profile, "gender", "Gender"),
  summarize_categorical(participant_profile, "income_group", "Household income"),
  summarize_categorical(participant_profile, "education_group", "Education"),
  summarize_categorical(participant_profile, "primary_language", "Primary language"),
  summarize_categorical(participant_profile, "ethnicity", "Race and ethnicity"),
  summarize_categorical(participant_profile, "employment", "Employment status")
)

kable(
  demographic_results |>
    mutate(percent = scales::percent(percent / 100, accuracy = 1)) |>
    rename(
      Characteristic = characteristic,
      Category = category,
      N = n,
      Denominator = denominator,
      Percent = percent
    )
)

Characteristic	Category	N	Denominator	Percent
Gender	F	212	225	94%
Gender	M	11	225	5%
Gender	Other/Otro	2	225	1%
Household income	$50,000 or more	76	119	64%
Household income	Under $50,000	43	119	36%
Education	Bachelor’s degree or higher	89	197	45%
Education	High school diploma or GED	29	197	15%
Education	Less than high school	10	197	5%
Education	Other	1	197	1%
Education	Some college or associate degree	68	197	35%
Primary language	Arabic/Arábico	1	224	0%
Primary language	English/Inglés	170	224	76%
Primary language	Korean/Koreano	1	224	0%
Primary language	Mandarin Chinese/Mandarin Chino (Putonghua)	1	224	0%
Primary language	Other (Specify)/Otro (especifique):	8	224	4%
Primary language	Spanish/Español	43	224	19%
Race and ethnicity	Asian/Asiático	7	225	3%
Race and ethnicity	Black/African American/Negro/Afroamericano	3	225	1%
Race and ethnicity	Decline to answer/Prefiero no responder	4	225	2%
Race and ethnicity	Hispanic/Hispano/Latino	155	225	69%
Race and ethnicity	Multiracial/Razas múltiples	5	225	2%
Race and ethnicity	Native Hawaiian or Other Pacific Islander/Nativo de Hawai o otro Isleños del Pacífico	1	225	0%
Race and ethnicity	Other/Otro	6	225	3%
Race and ethnicity	White/Blanco	44	225	20%
Employment status	Employed full-time	49	203	24%
Employment status	Employed part-time	28	203	14%
Employment status	No answer/prefer not to say	3	203	1%
Employment status	Seasonal worker	1	203	0%
Employment status	Stay at home parent	86	203	42%
Employment status	Temporary Employment	1	203	0%
Employment status	Unemployed	35	203	17%

4.1 Outcomes by income and education

Subgroup estimates are displayed only when each comparison group has at least 10 usable survey records.

pl_analysis_with_groups <- pl_episodes |>
  mutate(
    income_group = collapse_income(income),
    education_group = collapse_education(education),
    education_binary = case_when(
      education_group %in% c("Less than high school", "High school diploma or GED") ~ "High school or less",
      education_group %in% c("Some college or associate degree", "Bachelor's degree or higher") ~ "Some college or higher",
      TRUE ~ NA_character_
    )
  )

subgroup_activity_summary <- function(data, group_variable, group_label) {
  data |>
    select(all_of(group_variable), ends_with("_pre"), ends_with("_post")) |>
    rename(group = all_of(group_variable)) |>
    filter(!is.na(group)) |>
    pivot_longer(
      cols = matches("^(read|talk|sing)_(pre|post)$"),
      names_to = c("activity", "wave"),
      names_pattern = "(read|talk|sing)_(pre|post)",
      values_to = "value"
    ) |>
    group_by(group, activity, wave) |>
    summarize(n = sum(!is.na(value)), mean = mean(value, na.rm = TRUE), .groups = "drop") |>
    group_by(group, activity) |>
    filter(min(n) >= params$minimum_subgroup_n) |>
    ungroup() |>
    mutate(group_variable = group_label)
}

subgroup_activity_results <- bind_rows(
  subgroup_activity_summary(pl_analysis_with_groups, "income_group", "Household income"),
  subgroup_activity_summary(pl_analysis_with_groups, "education_binary", "Education")
) |>
  mutate(wave = factor(wave, levels = c("pre", "post")))

if (nrow(subgroup_activity_results) > 0) {
  ggplot(
    subgroup_activity_results,
    aes(x = wave, y = mean, group = group, colour = group)
  ) +
    geom_line(linewidth = 1) +
    geom_point(size = 3) +
    geom_text(aes(label = number(mean, accuracy = .1)), vjust = -1, show.legend = FALSE) +
    facet_grid(group_variable ~ activity, scales = "free_x") +
    scale_x_discrete(labels = c(pre = "Before", post = "After")) +
    scale_y_continuous(limits = c(0, 7.5), breaks = 0:7) +
    labs(
      title = "Weekly family activities by participant background",
      x = NULL, y = "Average days per week", colour = NULL
    )
} else {
  cat("Current subgroup sizes do not meet the minimum reporting threshold.")
}

5 Program Improvement Survey findings

5.1 Services, staff, and family outcomes

pi_long <- pi |>
  select(participant_id, survey_date, matches("^pi_\\d{2}$")) |>
  pivot_longer(
    matches("^pi_\\d{2}$"),
    names_to = "item_code",
    values_to = "response"
  ) |>
  mutate(item_number = as.integer(str_extract(item_code, "\\d+"))) |>
  left_join(pi_dictionary, by = "item_number")

pi_results <- pi_long |>
  filter(!is.na(response)) |>
  count(domain, item_number, item_label, response, name = "n") |>
  group_by(domain, item_number, item_label) |>
  mutate(denominator = sum(n), percent = n / denominator * 100) |>
  ungroup()

pi_top_box <- pi_results |>
  group_by(domain, item_number, item_label, denominator) |>
  summarize(
    agree_or_strongly_agree = sum(percent[response %in% c("Agree", "Strongly Agree")]),
    strongly_agree = sum(percent[response == "Strongly Agree"]),
    .groups = "drop"
  )

kable(
  pi_top_box |>
    transmute(
      Domain = domain,
      Item = item_label,
      N = denominator,
      `Agree or strongly agree` = scales::percent(agree_or_strongly_agree / 100, accuracy = 1),
      `Strongly agree` = scales::percent(strongly_agree / 100, accuracy = 1)
    )
)

Domain	Item	N	Agree or strongly agree	Strongly agree
Parent and Family Outcomes	I spend more time playing and interacting with my child	140	100%	89%
Parent and Family Outcomes	I have opportunities to build strong relationships with other families	140	100%	71%
Parent and Family Outcomes	I have other families I can depend on for support	140	96%	54%
Parent and Family Outcomes	I am able to get the services my family needs	138	100%	71%
Parent and Family Outcomes	We have more consistent routines at home	140	100%	76%
Parent and Family Outcomes	I am better able to understand and respond to my child’s cues	140	100%	79%
Parent and Family Outcomes	I am better able to understand and support my child’s behavior	140	100%	84%
Services and Staff	Services and activities are offered at a convenient time and location	139	100%	78%
Services and Staff	Staff are welcoming and respectful	139	100%	94%
Services and Staff	Staff ask about my family’s concerns	138	100%	75%
Services and Staff	Staff follow up about my family’s concerns	140	100%	77%
Services and Staff	Staff respect my culture and traditions	140	100%	91%
Services and Staff	Staff communicate with me in my home language	140	100%	90%
Services and Staff	Staff respect my identity	139	100%	91%
Services and Staff	The program offers opportunities to learn about diversity, equity, and inclusion	139	99%	88%
Services and Staff	Staff value my feedback and ideas	138	100%	86%

plot_likert_domain <- function(domain_name) {
  plot_data <- pi_results |>
    filter(domain == domain_name) |>
    mutate(
      response = factor(response, levels = likert_levels),
      item_label = str_wrap(item_label, width = 46),
      item_label = fct_rev(factor(item_label, levels = unique(item_label)))
    )

  ggplot(plot_data, aes(x = percent, y = item_label, fill = response)) +
    geom_col(width = .72) +
    geom_text(
      aes(label = if_else(percent >= 4, scales::percent(percent / 100, accuracy = 1), "")),
      position = position_stack(vjust = .5), size = 3
    ) +
    scale_fill_manual(
      values = c(
        "Strongly Disagree" = "#78A641",
        "Disagree" = colors$blue,
        "Agree" = colors$after,
        "Strongly Agree" = "#50AFCB"
      ),
      drop = FALSE
    ) +
    guides(fill = guide_legend(reverse = TRUE)) +
    scale_x_continuous(labels = percent_format(scale = 1), expand = expansion(mult = c(0, .02))) +
    labs(title = domain_name, x = NULL, y = NULL, fill = NULL)
}

pi_services_plot <- plot_likert_domain("Services and Staff")
pi_services_plot

pi_outcomes_plot <- plot_likert_domain("Parent and Family Outcomes")
pi_outcomes_plot

5.2 First-time and returning-family activities

This comparison places the post-program activity ratings from the Parenting Ladder alongside the Program Improvement Survey ratings from returning families. It is a comparison of two groups, not a paired before-and-after test.

first_time_activities <- pl_episodes |>
  select(read = read_post, talk = talk_post, sing = sing_post) |>
  pivot_longer(everything(), names_to = "activity", values_to = "value") |>
  mutate(group = "Parenting Ladder post (first-time)")

returning_activities <- pi |>
  select(read, talk, sing) |>
  pivot_longer(everything(), names_to = "activity", values_to = "value") |>
  mutate(group = "Program Improvement (returning)")

first_returning_long <- bind_rows(first_time_activities, returning_activities)

first_returning_results <- first_returning_long |>
  group_by(activity, group) |>
  summarize(
    n = sum(!is.na(value)),
    mean = mean(value, na.rm = TRUE),
    pct_6_7 = mean(value %in% 6:7, na.rm = TRUE) * 100,
    .groups = "drop"
  )

first_returning_tests <- map_dfr(c("read", "talk", "sing"), function(this_activity) {
  first_values <- first_time_activities |> filter(activity == this_activity) |> pull(value) |> na.omit()
  returning_values <- returning_activities |> filter(activity == this_activity) |> pull(value) |> na.omit()
  test <- t.test(first_values, returning_values)
  tibble(
    activity = this_activity,
    p_value = test$p.value,
    mean_difference = mean(first_values) - mean(returning_values)
  )
})

kable(
  first_returning_results |>
    left_join(first_returning_tests, by = "activity") |>
    transmute(
      Activity = str_to_title(activity),
      Group = group,
      N = n,
      Mean = round(mean, 1),
      `Percent 6 or 7` = scales::percent(pct_6_7 / 100, accuracy = 1),
      `Group-comparison p` = format.pval(p_value, digits = 3, eps = .001)
    )
)

Activity	Group	N	Mean	Percent 6 or 7	Group-comparison p
Read	Parenting Ladder post (first-time)	235	6.1	69%	< 0.001
Read	Program Improvement (returning)	139	5.5	55%	< 0.001
Sing	Parenting Ladder post (first-time)	233	6.6	88%	0.00228
Sing	Program Improvement (returning)	139	6.3	76%	0.00228
Talk	Parenting Ladder post (first-time)	234	6.5	81%	0.00193
Talk	Program Improvement (returning)	139	6.1	67%	0.00193

6 Interpretation guidance

Parenting Ladder ratings use a 1-to-7 scale; Read, Talk, and Sing use days per week from 0 to 7.
Program Improvement items use a four-category agreement scale.
Percentages use the number of nonmissing responses to the specific item as the denominator.
Statistical significance does not by itself establish practical importance. Mean change, effect size, sample size, and program context should be considered together.
Item-level adjusted p-values use the Benjamini-Hochberg procedure to limit false discoveries across the 16 Parenting Ladder comparisons.
Subgroup results are descriptive and should not be interpreted causally.

7 Export analytical outputs

PACT Evaluation Analysis FY 2025-26

Parenting Ladder and Program Improvement Surveys

Applied Survey Research

September 09, 2026