Overview

Between-subjects online experiment: Prolific, US adults, N = 3,750 recruited (750 per arm); N ~ 3,560 analytic after exclusions. Participants imagine a catered event and choose between a Tofu Bánh Mì and a Chicken Bánh Mì under one of five randomly assigned conditions:

Arm Description
Control Neither option pre-selected
T1 Tofu Bánh Mì pre-selected
T2 Single checkbox for Tofu Bánh Mì pre-checked; uncheck to receive Chicken
T3 Tofu Bánh Mì pre-selected + inclusivity framing
T4 Tofu Bánh Mì pre-selected + environmental framing

Hypotheses:

Alpha = 0.01 throughout. Exclusions applied before any analysis.

For unaddressed issues we defer to Lin, Green & Coppock (2016) SOPs (v1.05) as best we can.

Reading the export: raw tag -> meaningful name

The Qualtrics export names each column by its export tag. The map below renames those into the analysis variables documented in the codebook. Update the right-hand keys to match the actual export header (e.g. if the T4 choice or attention check exports with a suffix because of a duplicate/blank tag).

# raw Qualtrics export tag  ->  meaningful name
rename_map <- c(
  ResponseId = "response_id",
  QID2       = "consent",        # consent item (currently a blank tag -> exports as QID2)
  Q11        = "attn_response",  # attention check (currently blank tag -> may export as QID11)
  Q6         = "age",
  Q7         = "gender",
  Q8         = "education_code",
  Q1         = "state",
  Q10        = "diet_text",
  # per-arm behavioral choice items (coalesced below into meal_chosen / chose_veg)
  Q13        = "choice_control",
  Q15        = "choice_t1",
  Q17        = "choice_t2",      # single opt-out checkbox
  Q19        = "choice_t3",
  Q27        = "choice_t4",      # confirm actual tag; collides with Q21 unless renamed in QSF
  Q21        = "sat_chosen",     # PRIMARY reactance
  Q26        = "sat_choices",
  Q24        = "sat_presentation",
  Q20        = "manip_code",     # 1 = Chicken, 2 = Tofu
  Q22        = "norms_estimate",
  Q25        = "free_text"
)
# Applied to a real export with:
#   df_raw <- readr::read_csv("export.csv") |> dplyr::rename(any_of(setNames(names(rename_map), rename_map)))
# `condition` comes from the randomizer's embedded-data field, added separately.

Packages and Helper Functions

pkgs <- c("broom", "estimatr", "dplyr", "knitr", "pwr")
invisible(lapply(pkgs, function(p) {
  if (!requireNamespace(p, quietly = TRUE))
    install.packages(p, repos = "https://cloud.r-project.org")
  library(p, character.only = TRUE, warn.conflicts = FALSE)
}))

tidy_lm <- function(m, digits = 4) {
  tidy(m) |>
    select(term, estimate, std.error, p.value) |>
    mutate(across(c(estimate, std.error), \(x) round(x, digits)),
           p.value = formatC(p.value, format = "g", digits = 3))
}

wilson_ci <- function(x, n, conf = 0.95) {
  z  <- qnorm(1 - (1 - conf) / 2)
  p  <- x / n; d <- 1 + z^2 / n
  ct <- (p + z^2 / (2 * n)) / d
  mg <- z * sqrt(p * (1 - p) / n + z^2 / (4 * n^2)) / d
  c(est = p, lo = ct - mg, hi = ct + mg)
}

hte_pvals <- function(m, label) {
  tidy(m) |>
    filter(grepl(":", term)) |>
    select(term, p.value) |>
    mutate(p.value = round(p.value, 3), moderator = label)
}

Power Analysis

N ~ 712 per arm (3,560 analytic after ~5% attention-check exclusions), alpha = 0.01.

H1: Plant-Based Uptake

N_per_arm <- 712L
alpha     <- 0.01

cat("Sensitivity across treatment thresholds (baseline = 20%):\n")
## Sensitivity across treatment thresholds (baseline = 20%):
for (mde in c(0.10, 0.20, 0.30)) {
  r <- power.prop.test(p1 = 0.20, p2 = 0.20 + mde, n = N_per_arm,
                       sig.level = alpha, alternative = "two.sided")
  cat(sprintf("  MDE = %d pp.: %.1f%% power\n", round(mde * 100), r$power * 100))
}
##   MDE = 10 pp.: 96.4% power
##   MDE = 20 pp.: 100.0% power
##   MDE = 30 pp.: 100.0% power

H2: Dissatisfaction Ceilings

P(Wilson CI upper bound < ceiling) under assumed true rates, by simulation (B = 10,000). Control shown for reference only; it is not a registered H2 arm.

B <- 10000L
h2_params <- data.frame(
  condition = c("Control", "T1", "T2", "T3", "T4"),
  p_true    = c(0.08, 0.15, 0.22, 0.15, 0.15),
  ceiling   = c(0.10, 0.20, 0.30, 0.20, 0.20)
)
h2_params$power <- sapply(seq_len(nrow(h2_params)), function(i) {
  draws     <- rbinom(B, N_per_arm, h2_params$p_true[i])
  ci_uppers <- sapply(draws, function(x) wilson_ci(x, N_per_arm)[["hi"]])
  round(mean(ci_uppers < h2_params$ceiling[i]), 3)
})
kable(h2_params, col.names = c("Condition", "Assumed true rate", "Ceiling", "Power"),
      caption = "H2 power under assumed true rates")
H2 power under assumed true rates
Condition Assumed true rate Ceiling Power
Control 0.08 0.1 0.425
T1 0.15 0.2 0.939
T2 0.22 0.3 0.999
T3 0.15 0.2 0.936
T4 0.15 0.2 0.934

Simulated Data

We simulate the data as the Qualtrics export will arrive (raw tag names, one populated choice column per arm, T2 opt-outs blank, education level 7 = “Prefer not to say”), then rename and derive exactly as we will for the real data. To run on real data, replace the Simulate chunk with read_csv() + the rename_map above.

set.seed(42)
N_raw <- 3750L
arms  <- c("Control", "T1", "T2", "T3", "T4")

# condition := randomizer assignment (a separate embedded-data field in the real export)
condition <- factor(sample(rep(arms, each = N_raw / 5)), levels = arms)

ResponseId <- sprintf("R_%08d", seq_len(N_raw))
QID2 <- 1L                                                       # consenters (non-consenters screened out)
Q11  <- ifelse(rbinom(N_raw, 1, 0.95) == 1L, 5L, sample(1:4, N_raw, TRUE))  # attn (5 = pass)
Q6   <- pmax(18L, pmin(80L, round(rnorm(N_raw, 38, 12))))        # age
Q7   <- sample(c("Male", "Female", "Non-binary", "Prefer Not to Say", "Prefer to self-identify"),
               N_raw, TRUE, prob = c(0.47, 0.47, 0.02, 0.02, 0.02))         # gender
Q8   <- sample(1:7, N_raw, TRUE, prob = c(0.03,0.18,0.22,0.10,0.27,0.18,0.02)) # education (7=PNTS)
Q1   <- sample(state.name, N_raw, TRUE)                          # state
diet_pool <- c("", "none", "no", "n/a", "no restrictions", "none that i know of",
               "vegetarian", "I am vegetarian", "veggie", "vegan", "I'm vegan",
               "plant-based / vegan", "pescatarian", "pescetarian - i eat fish",
               "flexitarian", "mostly plant based, flexitarian", "omnivore",
               "i eat everything", "no i eat meat", "lactose intolerant", "dairy allergy",
               "gluten free / celiac", "nut allergy", "allergic to peanuts",
               "halal", "kosher", "shellfish allergy")
Q10  <- sample(diet_pool, N_raw, TRUE)                           # dietary free text

# True uptake by arm (all above H1 thresholds)
p_veg      <- c(Control = 0.20, T1 = 0.35, T2 = 0.45, T3 = 0.55, T4 = 0.50)
veg_latent <- rbinom(N_raw, 1, p_veg[as.character(condition)])

# Per-arm choice columns AS EXPORTED: radio arms 1=Tofu,2=Chicken; T2 1=Tofu, BLANK=Chicken
Q13 <- ifelse(condition == "Control", 2L - veg_latent, NA_integer_)
Q15 <- ifelse(condition == "T1",      2L - veg_latent, NA_integer_)
Q17 <- ifelse(condition == "T2" & veg_latent == 1L, 1L, NA_integer_)
Q19 <- ifelse(condition == "T3",      2L - veg_latent, NA_integer_)
Q27 <- ifelse(condition == "T4",      2L - veg_latent, NA_integer_)

# Satisfaction (1-5); means chosen to hit target dissatisfaction (<=2) ~8/15/22/15/15%
q21_mu <- c(Control = 3.9, T1 = 3.6, T2 = 3.3, T3 = 3.6, T4 = 3.6)
clamp15 <- function(mu) pmax(1L, pmin(5L, round(rnorm(N_raw, mu, 1))))
Q21 <- clamp15(q21_mu[as.character(condition)])                  # chosen meal (PRIMARY)
Q26 <- clamp15((q21_mu + 0.15)[as.character(condition)])         # available choices
Q24 <- clamp15(q21_mu[as.character(condition)])                  # presentation
Q22 <- pmax(0L, pmin(100L, round(rnorm(N_raw, 50, 20))))         # norms 0-100

# Manipulation check Q20: 1=Chicken, 2=Tofu; ~95% consistent with the recorded choice
Q20 <- ifelse(rbinom(N_raw, 1, 0.95) == 1L,
              ifelse(veg_latent == 1L, 2L, 1L),
              ifelse(veg_latent == 1L, 1L, 2L))

export_raw <- data.frame(ResponseId, QID2, Q11, Q6, Q7, Q8, Q1, Q10,
                         Q13, Q15, Q17, Q19, Q27, Q21, Q26, Q24, Q20, Q22,
                         condition, stringsAsFactors = FALSE)

Rename + derive analysis variables

df_raw <- export_raw |>
  rename(
    response_id      = ResponseId,
    consent          = QID2,
    attn_response    = Q11,
    age              = Q6,
    gender           = Q7,
    education_code   = Q8,
    state            = Q1,
    diet_text        = Q10,
    choice_control   = Q13,
    choice_t1        = Q15,
    choice_t2        = Q17,
    choice_t3        = Q19,
    choice_t4        = Q27,
    sat_chosen       = Q21,
    sat_choices      = Q26,
    sat_presentation = Q24,
    manip_code       = Q20,
    norms_estimate   = Q22
  )

ed_labels <- c("Less than high school", "High school diploma or GED", "Some college",
               "2 year degree", "4 year degree", "Graduate degree", "Prefer not to say")

df_raw <- df_raw |>
  mutate(
    attn_pass     = as.integer(attn_response == 5L),
    education     = factor(ed_labels[education_code], levels = ed_labels),
    education_num = ifelse(education_code == 7L, NA_integer_, education_code),
    # Behavioral: coalesce per-arm choices. Tofu=1, Chicken=0.
    # T2: box checked (==1) = Tofu; BLANK = opted out to Chicken = 0 (NOT missing).
    chose_veg = case_when(
      condition == "Control" ~ as.integer(choice_control == 1L),
      condition == "T1"      ~ as.integer(choice_t1 == 1L),
      condition == "T2"      ~ as.integer(!is.na(choice_t2) & choice_t2 == 1L),
      condition == "T3"      ~ as.integer(choice_t3 == 1L),
      condition == "T4"      ~ as.integer(choice_t4 == 1L)
    ),
    meal_chosen = factor(ifelse(chose_veg == 1L, "Tofu", "Chicken"),
                         levels = c("Chicken", "Tofu")),
    manip_meal  = factor(ifelse(manip_code == 2L, "Tofu", "Chicken"),
                         levels = c("Chicken", "Tofu")),
    manip_ok    = as.integer((manip_code == 2L & chose_veg == 1L) |
                             (manip_code == 1L & chose_veg == 0L)),
    dissat_chosen       = as.integer(sat_chosen       <= 2L),
    dissat_choices      = as.integer(sat_choices      <= 2L),
    dissat_presentation = as.integer(sat_presentation <= 2L)
  )

# Exclusion: failed attention check (applied before any analysis)
df <- filter(df_raw, attn_pass == 1L)

cat(sprintf("Raw N: %d  |  Excluded: %d  |  Analytic N: %d\n",
            nrow(df_raw), nrow(df_raw) - nrow(df), nrow(df)))
## Raw N: 3750  |  Excluded: 180  |  Analytic N: 3570
df |>
  group_by(condition) |>
  summarise(n = n(), pct_veg = round(mean(chose_veg) * 100, 1), .groups = "drop") |>
  kable(caption = "Plant-based uptake by condition (simulated analytic sample)")
Plant-based uptake by condition (simulated analytic sample)
condition n pct_veg
Control 715 19.6
T1 717 34.7
T2 715 46.0
T3 711 53.0
T4 712 51.8

Balance Check

df |>
  group_by(condition) |>
  summarise(age = round(mean(age), 2),
            education = round(mean(education_num, na.rm = TRUE), 2),
            .groups = "drop") |>
  kable(caption = "Covariate means by condition")
Covariate means by condition
condition age education
Control 37.63 3.96
T1 38.63 3.95
T2 37.29 3.92
T3 38.59 3.91
T4 37.84 3.88

H1: Plant-Based Uptake (Primary)

LPM, HC2 robust SEs, Control reference. Criterion: p < 0.01 AND estimate >= threshold (T1: 10 pp; T2: 20 pp; T3/T4: 30 pp). Unadjusted is primary; adjusted is a robustness check.

m1     <- lm_robust(chose_veg ~ condition, data = df, se_type = "HC2")
m1_adj <- lm_robust(chose_veg ~ condition + age + gender + education_num,
                    data = df, se_type = "HC2")

tidy_lm(m1)     |> kable(caption = "H1 unadjusted")
H1 unadjusted
term estimate std.error p.value
(Intercept) 0.1958 0.0149 8.54e-39
conditionT1 0.1515 0.0232 7.22e-11
conditionT2 0.2643 0.0238 4.16e-28
conditionT3 0.3344 0.0239 2.42e-43
conditionT4 0.3225 0.0239 1.82e-40 
tidy_lm(m1_adj) |> kable(caption = "H1 covariate-adjusted (robustness check)")
H1 covariate-adjusted (robustness check)
term estimate std.error p.value
(Intercept) 0.1628 0.0391 3.28e-05
conditionT1 0.1523 0.0234 8.41e-11
conditionT2 0.2655 0.0241 7.83e-28
conditionT3 0.3390 0.0241 9.61e-44
conditionT4 0.3302 0.0242 2.15e-41
age 0.0006 0.0007 0.406
genderMale 0.0377 0.0166 0.0233
genderNon-binary 0.0918 0.0576 0.111
genderPrefer Not to Say -0.0204 0.0600 0.734
genderPrefer to self-identify -0.0539 0.0548 0.326
education_num -0.0030 0.0053 0.575 
res    <- tidy(m1) |> filter(grepl("^condition", term))
thresh <- c(conditionT1 = 0.10, conditionT2 = 0.20,
            conditionT3 = 0.30, conditionT4 = 0.30)
res |>
  mutate(threshold = thresh[term],
         h1_pass = (p.value < 0.01) & (estimate >= threshold)) |>
  select(term, estimate, p.value, threshold, h1_pass) |>
  mutate(across(where(is.numeric), \(x) round(x, 4))) |>
  kable(caption = "H1 pass/fail by arm")
H1 pass/fail by arm
term estimate p.value threshold h1_pass
conditionT1 0.1515 0 0.1 TRUE
conditionT2 0.2643 0 0.2 TRUE
conditionT3 0.3344 0 0.3 TRUE
conditionT4 0.3225 0 0.3 TRUE

H2: Dissatisfaction Ceilings (Primary)

Outcome dissat_chosen (= 1 if sat_chosen <= 2). Criterion: point estimate AND upper Wilson CI bound both below the pre-registered ceiling.

ceilings <- c(Control = 0.10, T1 = 0.20, T2 = 0.30, T3 = 0.20, T4 = 0.20)
df |>
  group_by(condition) |>
  summarise(n = n(), n_dis = sum(dissat_chosen), .groups = "drop") |>
  mutate(ceiling = ceilings[as.character(condition)],
         w     = Map(wilson_ci, n_dis, n),
         est   = round(sapply(w, `[[`, "est"), 3),
         ci_lo = round(sapply(w, `[[`, "lo"),  3),
         ci_hi = round(sapply(w, `[[`, "hi"),  3),
         h2_pass = ci_hi < ceiling) |>
  select(condition, n, n_dis, est, ci_lo, ci_hi, ceiling, h2_pass) |>
  kable(caption = "H2: dissatisfaction (sat_chosen) vs. ceilings")
H2: dissatisfaction (sat_chosen) vs. ceilings
condition n n_dis est ci_lo ci_hi ceiling h2_pass
Control 715 65 0.091 0.072 0.114 0.1 FALSE
T1 717 94 0.131 0.108 0.158 0.2 TRUE
T2 715 142 0.199 0.171 0.229 0.3 TRUE
T3 711 87 0.122 0.100 0.149 0.2 TRUE
T4 712 100 0.140 0.117 0.168 0.2 TRUE

Secondary Analyses

Manipulation check

df |>
  group_by(condition) |>
  summarise(pct_correct = round(mean(manip_ok) * 100, 1), .groups = "drop") |>
  kable(caption = "% whose reported meal matches their recorded choice")
% whose reported meal matches their recorded choice
condition pct_correct
Control 94.8
T1 95.4
T2 94.3
T3 94.9
T4 94.8

Secondary reactance: available choices and presentation

Same dissatisfied-<=2 coding as the primary, descriptive by condition (no registered ceiling).

sec_dissat <- function(var, label) {
  df |>
    group_by(condition) |>
    summarise(n = n(), n_dis = sum(.data[[var]]), .groups = "drop") |>
    mutate(w = Map(wilson_ci, n_dis, n),
           est = round(sapply(w, `[[`, "est"), 3),
           ci_lo = round(sapply(w, `[[`, "lo"), 3),
           ci_hi = round(sapply(w, `[[`, "hi"), 3),
           item = label) |>
    select(item, condition, n, n_dis, est, ci_lo, ci_hi)
}
bind_rows(
  sec_dissat("dissat_choices", "Available choices"),
  sec_dissat("dissat_presentation", "Presentation")
) |>
  kable(caption = "Secondary reactance: dissatisfaction with 95% Wilson CIs")
Secondary reactance: dissatisfaction with 95% Wilson CIs
item condition n n_dis est ci_lo ci_hi
Available choices Control 715 38 0.053 0.039 0.072
Available choices T1 717 70 0.098 0.078 0.122
Available choices T2 715 130 0.182 0.155 0.212
Available choices T3 711 58 0.082 0.064 0.104
Available choices T4 712 92 0.129 0.107 0.156
Presentation Control 715 52 0.073 0.056 0.094
Presentation T1 717 109 0.152 0.128 0.180
Presentation T2 715 135 0.189 0.162 0.219
Presentation T3 711 92 0.129 0.107 0.156
Presentation T4 712 94 0.132 0.109 0.159

Descriptive norms

lm_robust(norms_estimate ~ condition, data = df, se_type = "HC2") |>
  tidy_lm() |>
  kable(caption = "Descriptive norms (OLS, Control reference)")
Descriptive norms (OLS, Control reference)
term estimate std.error p.value
(Intercept) 49.0434 0.7145 0
conditionT1 2.7056 1.0305 0.00869
conditionT2 0.7469 1.0278 0.467
conditionT3 1.6838 1.0154 0.0973
conditionT4 -0.3987 1.0410 0.702

Cross-condition comparisons (exploratory)

lapply(c("T1", "T2", "T3", "T4"), function(ref) {
  lm_robust(chose_veg ~ condition,
            data = mutate(df, condition = relevel(condition, ref = ref)),
            se_type = "HC2") |>
    tidy_lm() |> mutate(reference = ref)
}) |>
  bind_rows() |>
  filter(grepl("^condition", term)) |>
  kable(caption = "Cross-condition comparisons (exploratory)")
Cross-condition comparisons (exploratory)
term estimate std.error p.value reference
conditionControl -0.1515 0.0232 7.22e-11 T1
conditionT2 0.1129 0.0258 1.23e-05 T1
conditionT3 0.1830 0.0258 1.7e-12 T1
conditionT4 0.1710 0.0258 4.22e-11 T1
conditionControl -0.2643 0.0238 4.16e-28 T2
conditionT1 -0.1129 0.0258 1.23e-05 T2
conditionT3 0.0701 0.0264 0.00804 T2
conditionT4 0.0581 0.0264 0.028 T2
conditionControl -0.3344 0.0239 2.42e-43 T3
conditionT1 -0.1830 0.0258 1.7e-12 T3
conditionT2 -0.0701 0.0264 0.00804 T3
conditionT4 -0.0120 0.0265 0.651 T3
conditionControl -0.3225 0.0239 1.82e-40 T4
conditionT1 -0.1710 0.0258 4.22e-11 T4
conditionT2 -0.0581 0.0264 0.028 T4
conditionT3 0.0120 0.0265 0.651 T4

Exploratory: Dietary Identity from Open Text

No inferential claims. Case-insensitive regex coding of diet_text; finalized after inspecting real responses.

classify_diet <- function(x) {
  x <- tolower(trimws(x))
  case_when(
    grepl("vegan", x)                            ~ "Vegan",
    grepl("vegetar|veggie", x)                   ~ "Vegetarian",
    grepl("pesc", x)                             ~ "Pescatarian",
    grepl("flexi", x)                            ~ "Flexitarian",
    grepl("omnivore|eat everything|eat meat", x) ~ "Omnivore (stated)",
    x %in% c("", "none", "no", "n/a", "no restrictions", "none that i know of")
                                                 ~ "None stated",
    grepl("allerg|intoleran|celiac|gluten|nut|dairy|shellfish|lactose", x)
                                                 ~ "Allergy/intolerance only",
    grepl("halal", x)                            ~ "Halal",
    grepl("kosher", x)                           ~ "Kosher",
    TRUE                                         ~ "Other/uncoded"
  )
}
df <- df |> mutate(diet_cat = classify_diet(diet_text))
df |>
  count(diet_cat, sort = TRUE) |>
  mutate(pct = round(n / sum(n) * 100, 1)) |>
  kable(caption = "Dietary identity (regex-coded, exploratory)")
Dietary identity (regex-coded, exploratory)
diet_cat n pct
Allergy/intolerance only 840 23.5
None stated 831 23.3
Omnivore (stated) 390 10.9
Vegan 371 10.4
Vegetarian 353 9.9
Flexitarian 267 7.5
Pescatarian 260 7.3
Halal 132 3.7
Kosher 126 3.5

Exploratory: Heterogeneous Treatment Effects

No inferential claims. Interaction p-values only.

bind_rows(
  hte_pvals(lm_robust(chose_veg ~ condition * gender, data = df, se_type = "HC2"), "gender"),
  hte_pvals(lm_robust(chose_veg ~ condition * education_num, data = df, se_type = "HC2"), "education"),
  hte_pvals(lm_robust(chose_veg ~ condition * I(age >= median(age)),
                      data = df, se_type = "HC2"), "age (above vs. below median)")
) |>
  select(moderator, term, p.value) |>
  kable(caption = "HTE interaction p-values (exploratory)")
HTE interaction p-values (exploratory)
moderator term p.value
gender conditionT1:genderMale 0.570
gender conditionT2:genderMale 0.567
gender conditionT3:genderMale 0.434
gender conditionT4:genderMale 0.828
gender conditionT1:genderNon-binary 0.384
gender conditionT2:genderNon-binary 0.826
gender conditionT3:genderNon-binary 0.815
gender conditionT4:genderNon-binary 0.490
gender conditionT1:genderPrefer Not to Say 0.971
gender conditionT2:genderPrefer Not to Say 0.775
gender conditionT3:genderPrefer Not to Say 0.675
gender conditionT4:genderPrefer Not to Say 0.792
gender conditionT1:genderPrefer to self-identify 0.118
gender conditionT2:genderPrefer to self-identify 0.009
gender conditionT3:genderPrefer to self-identify 0.785
gender conditionT4:genderPrefer to self-identify 0.356
education conditionT1:education_num 0.018
education conditionT2:education_num 0.777
education conditionT3:education_num 0.271
education conditionT4:education_num 0.265
age (above vs. below median) conditionT1:I(age >= median(age))TRUE 0.252
age (above vs. below median) conditionT2:I(age >= median(age))TRUE 0.355
age (above vs. below median) conditionT3:I(age >= median(age))TRUE 0.041
age (above vs. below median) conditionT4:I(age >= median(age))TRUE 0.176

Notes

H1 and H2 will be analyzed precisely as specified; any change will be noted in the text. Exploratory analyses (cross-condition comparisons, dietary identity, HTE) may be modified, and additional exploratory tests may be added. Variable names follow the accompanying codebook; the shared dataset will use those names so it is legible without the survey.