This document reproduces all analyses reported in the paper across three studies (N = 549 total). Data are hosted on OSF at https://osf.io/tv7xb/.
library(dplyr)
library(ggplot2)
library(patchwork)
library(emmeans)
library(psych)
# ── Response-scale maps ──────────────────────────────────────────────────────
agree_map <- c(
"Strognly disagree" = 1, # typo present in raw data
"Strongly disagree" = 1,
"Somewhat disagree" = 2,
"Neither agree nor disagree" = 3,
"Somewhat agree" = 4,
"Strongly agree" = 5
)
likely_map <- c(
"Extremely unlikely" = 1,
"Somewhat unlikely" = 2,
"Neither likely nor unlikely" = 3,
"Somewhat likely" = 4,
"Extremely likely" = 5
)
wtp_map <- c(
"Nothing more" = 0,
"$0.50 more" = 0.5,
"$1.00 more" = 1,
"$1.50 more" = 1.5,
"$2.00 more" = 2,
"$2.50 more" = 2.5,
"$3.00 more" = 3,
"$3.50 more" = 3.5,
"$4.00 more" = 4,
"$4.50 more" = 4.5,
"$5.00+ more" = 5
)
yes_no_map <- c(
"Definitely no" = 1,
"Probably no" = 2,
"Not sure" = 3,
"Probably yes" = 4,
"Definitely yes" = 5
)
# ── Utility: replace "-99" with NA ──────────────────────────────────────────
na_99 <- function(x) {
x <- as.character(x)
x[x == "-99"] <- NA
x
}
as_num_na99 <- function(x) as.numeric(na_99(x))
# ── Shared Likert histogram theme & plot function ────────────────────────────
theme_apa_hist <- function(base_size = 14) {
theme_classic(base_size = base_size) %+replace%
theme(
panel.grid = element_blank(),
axis.line = element_line(color = "black", linewidth = 0.8),
plot.title = element_text(hjust = 0.5, face = "plain",
size = base_size + 1,
margin = margin(b = 10)),
axis.title.y = element_text(angle = 90, margin = margin(r = 10)),
axis.title.x = element_text(margin = margin(t = 8)),
plot.margin = margin(6, 8, 6, 8)
)
}
likert_labels <- c(
"Strongly\ndisagree", "Somewhat\ndisagree",
"Neither agree\nnor disagree", "Somewhat\nagree", "Strongly\nagree"
)
plot_likert_hist <- function(df, var, title, show_x = FALSE) {
df2 <- df |>
transmute(x = .data[[var]]) |>
filter(!is.na(x), x >= 1, x <= 5)
n <- nrow(df2)
ggplot(df2, aes(x = x, y = after_stat(count) / n * 100)) +
geom_bar(width = 1, color = "black", fill = "grey75", linewidth = 0.5) +
scale_x_continuous(
breaks = 1:5,
labels = if (show_x) likert_labels else NULL,
expand = c(0, 0)
) +
scale_y_continuous(
limits = c(0, 60),
expand = expansion(mult = c(0, 0.05)),
labels = function(x) paste0(x, "%")
) +
labs(
title = title,
x = if (show_x) "Response" else NULL,
y = "Percentage"
) +
theme_apa_hist()
}
Goal: Test how often consumers infer that a GLP-1 “support” smoothie powder literally contains GLP-1 as an ingredient.
# ── Replace these URLs with your OSF download links ─────────────────────────
# Pattern: https://osf.io/FILEID/download
# S1 file is stored under https://osf.io/tv7xb/files/t7cyn — locate the
# individual file permalink on OSF and append /download.
# Example placeholder (update before publishing):
s1_url <- "https://osf.io/t7cyn/download"
dat1 <- read.csv(s1_url, comment.char = "#")
# Drop extra header rows and test responses
dat1 <- dat1[-c(1:10), ]
# Keep only participants who passed the attention check
dat1 <- subset(dat1, product.type == "Smoothie Supplement Powder")
x <- dat1$contains.glp1
blank <- is.na(x) | x == ""
has_glp1 <- grepl("\\bGLP-1\\b", x)
count_selected <- ifelse(blank, 0, lengths(strsplit(x, ",")))
N <- length(x)
tab1 <- data.frame(
Group = c(
"Selected GLP-1 as an ingredient",
"Selected GLP-1 as the *only* ingredient",
"Selected GLP-1 with other ingredients",
"Selected other ingredients but not GLP-1"
),
n = c(
sum(has_glp1),
sum(has_glp1 & count_selected == 1),
sum(has_glp1 & count_selected > 1),
sum(!has_glp1 & count_selected > 0)
)
)
tab1$`%` <- round(100 * tab1$n / N, 1)
knitr::kable(
tab1,
caption = "Table 1. Ingredient selections for the GLP-1 support product (Study 1, N = 117)."
)
| Group | n | % |
|---|---|---|
| Selected GLP-1 as an ingredient | 114 | 97.4 |
| Selected GLP-1 as the only ingredient | 73 | 62.4 |
| Selected GLP-1 with other ingredients | 41 | 35.0 |
| Selected other ingredients but not GLP-1 | 3 | 2.6 |
Because endorsement of GLP-1 as an ingredient was near ceiling (97.4% selected GLP-1), there was insufficient variability to support meaningful inferential tests. Results are limited to descriptive statistics.
Goal: Replicate the ingredient-inference effect using graded dose-response belief measures and three advertisement stimuli (N = 136).
s2_url <- "https://osf.io/m3xtc/download" # update with OSF permalink
dat2 <- read.csv(s2_url, comment.char = "#")
# Drop extra header rows; rows 52–53 are early participants who missed items
dat2 <- dat2[-c(1:11, 52:53), ]
dat2 <- subset(dat2, product.type == "Smoothie Supplement Powder")
# ── Recode core variables ────────────────────────────────────────────────────
dat2$effect.like.glp1 <- unname(agree_map[as.character(dat2$effect.like.glp1)])
dat2$similar.to.glp1 <- unname(agree_map[as.character(dat2$similar.to.glp1)])
dat2$works.like.glp1 <- unname(agree_map[as.character(dat2$works.like.glp1)])
# False-belief composite
dat2$glp1_belief_mean <- rowMeans(
dat2[, c("effect.like.glp1", "similar.to.glp1", "works.like.glp1")],
na.rm = TRUE
)
# Product evaluation composite
eval_items2 <- data.frame(
purchase1 = unname(likely_map[as.character(dat2$purchase1)]),
purchase2 = unname(agree_map[as.character(dat2$purchase2)]),
appealing = unname(agree_map[as.character(dat2$appealing)])
)
dat2$eval_mean <- rowMeans(eval_items2, na.rm = TRUE)
# WTP
dat2$wtp <- as.numeric(unname(wtp_map[as.character(dat2$wtp)]))
# Prescription-knowledge item
script_map <- c(
"Definitely no" = 1, "Probably no" = 2, "Not sure" = 3,
"Probably yes" = 4, "Definitely yes" = 5
)
dat2$script.required <- unname(script_map[as.character(dat2$script.required)])
# Demographics
dat2$age <- as.numeric(dat2$age)
dat2$bmi <- (as.numeric(dat2$weight) / (as.numeric(dat2$height_1)^2)) * 703
dat2$income <- as.numeric(factor(
na_99(dat2$income),
levels = c("$0 - $19,999","$20,000 - $39,999","$40,000 - $59,999",
"$60,000 - $89,999","$90,000 - $119,999",
"$120,000 - $149,999","$150,000+"),
ordered = TRUE
))
dat2$ses <- as.numeric(sub("^([0-9]+).*", "\\1", as.character(dat2$ses)))
dat2$gender_simple <- case_when(
dat2$gender %in% c("Female","Female,Non-binary / third gender") ~ "Female",
dat2$gender %in% c("Male","Male,Non-binary / third gender","Male,Transgender") ~ "Male",
TRUE ~ NA_character_
)
race2 <- dat2$race
race2[grepl(",", race2) | grepl("prefer not to say", race2, ignore.case = TRUE)] <-
"Other / Prefer not to say"
dat2$race_simple <- case_when(
race2 == "White or European American" ~ "White",
race2 == "Black or African American" ~ "Black",
race2 == "Asian" ~ "Asian",
is.na(race2) ~ NA_character_,
TRUE ~ "Other"
) |> factor(levels = c("White","Black","Asian","Other"))
taking2 <- unname(yes_no_map[as.character(dat2$taking.glp1)])
dat2$glp1_exposure <- case_when(
taking2 %in% c(4,5) ~ 1,
taking2 %in% c(1,2) ~ 0,
TRUE ~ NA_real_
)
dat2$condition <- as.factor(dat2$condition)
# False-belief items
cat("=== False-belief scale (3 items) ===\n")
## === False-belief scale (3 items) ===
psych::alpha(dat2[, c("effect.like.glp1","similar.to.glp1","works.like.glp1")])[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd
## 0.9425831 0.9427783 0.9187885 0.8459634 16.47589 0.00860451 3.676471 1.108843
## median_r
## 0.8320618
# Inter-item correlations
cat("\nInter-item correlations:\n")
##
## Inter-item correlations:
round(cor(dat2[, c("effect.like.glp1","similar.to.glp1","works.like.glp1")],
use = "pairwise.complete.obs"), 2)
## effect.like.glp1 similar.to.glp1 works.like.glp1
## effect.like.glp1 1.00 0.88 0.83
## similar.to.glp1 0.88 1.00 0.83
## works.like.glp1 0.83 0.83 1.00
# Product evaluation items
cat("\n=== Product evaluation scale (3 items) ===\n")
##
## === Product evaluation scale (3 items) ===
psych::alpha(eval_items2)
##
## Reliability analysis
## Call: psych::alpha(x = eval_items2)
##
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd median_r
## 0.97 0.97 0.95 0.91 29 0.005 2.4 1.4 0.91
##
## 95% confidence boundaries
## lower alpha upper
## Feldt 0.95 0.97 0.97
## Duhachek 0.96 0.97 0.98
##
## Reliability if an item is dropped:
## raw_alpha std.alpha G6(smc) average_r S/N alpha se var.r med.r
## purchase1 0.95 0.95 0.91 0.91 20 0.0084 NA 0.91
## purchase2 0.95 0.95 0.91 0.91 20 0.0086 NA 0.91
## appealing 0.95 0.95 0.91 0.91 20 0.0085 NA 0.91
##
## Item statistics
## n raw.r std.r r.cor r.drop mean sd
## purchase1 136 0.97 0.97 0.94 0.93 2.2 1.3
## purchase2 135 0.97 0.97 0.94 0.93 2.5 1.4
## appealing 136 0.97 0.97 0.94 0.93 2.6 1.5
##
## Non missing response frequency for each item
## 1 2 3 4 5 miss
## purchase1 0.43 0.19 0.16 0.17 0.05 0.00
## purchase2 0.38 0.13 0.16 0.25 0.08 0.01
## appealing 0.37 0.13 0.15 0.23 0.12 0.00
cat("\nInter-item correlations:\n")
##
## Inter-item correlations:
round(cor(eval_items2, use = "pairwise.complete.obs"), 2)
## purchase1 purchase2 appealing
## purchase1 1.00 0.91 0.91
## purchase2 0.91 1.00 0.91
## appealing 0.91 0.91 1.00
# Endorsement rates (somewhat/strongly agree)
agree_pct <- function(x) round(100 * mean(x >= 4, na.rm = TRUE), 1)
cat("Endorsement rates (somewhat/strongly agree):\n")
## Endorsement rates (somewhat/strongly agree):
cat(" Has GLP-1-like effects:", agree_pct(dat2$effect.like.glp1), "%\n")
## Has GLP-1-like effects: 73.3 %
cat(" Similar to GLP-1: ", agree_pct(dat2$similar.to.glp1), "%\n")
## Similar to GLP-1: 72.8 %
cat(" Works like GLP-1: ", agree_pct(dat2$works.like.glp1), "%\n")
## Works like GLP-1: 66.2 %
p1 <- plot_likert_hist(dat2, "effect.like.glp1", "Has GLP-1-like effects")
p2 <- plot_likert_hist(dat2, "similar.to.glp1", "Similar to GLP-1")
p3 <- plot_likert_hist(dat2, "works.like.glp1", "Works like GLP-1", show_x = TRUE)
p1 / p2 / p3
Figure 2. Distributions of endorsement that the product has GLP-1-like effects (Study 2).
# False-belief strength by condition
m_belief2 <- aov(glp1_belief_mean ~ condition, data = dat2)
cat("=== Beliefs by condition ===\n"); summary(m_belief2)
## === Beliefs by condition ===
## Df Sum Sq Mean Sq F value Pr(>F)
## condition 2 0.79 0.3961 0.319 0.728
## Residuals 133 165.19 1.2421
# Product evaluations by condition
m_prefer2 <- aov(eval_mean ~ condition, data = dat2)
cat("\n=== Evaluations by condition ===\n"); summary(m_prefer2)
##
## === Evaluations by condition ===
## Df Sum Sq Mean Sq F value Pr(>F)
## condition 2 3.07 1.536 0.838 0.435
## Residuals 133 243.64 1.832
# WTP by condition
m_wtp2 <- aov(wtp ~ condition, data = dat2)
cat("\n=== WTP by condition ===\n"); summary(m_wtp2)
##
## === WTP by condition ===
## Df Sum Sq Mean Sq F value Pr(>F)
## condition 2 1.55 0.7758 0.339 0.713
## Residuals 133 304.71 2.2910
m_demog2 <- lm(
glp1_belief_mean ~ age + bmi + income + ses +
gender_simple + race_simple + glp1_exposure + condition,
data = na.omit(dat2)
)
summary(m_demog2)
##
## Call:
## lm(formula = glp1_belief_mean ~ age + bmi + income + ses + gender_simple +
## race_simple + glp1_exposure + condition, data = na.omit(dat2))
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.9027 -0.3981 0.2019 0.7110 1.7580
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 4.6383503 0.5429266 8.543 5.37e-14 ***
## age -0.0074446 0.0077468 -0.961 0.3385
## bmi -0.0115383 0.0093403 -1.235 0.2192
## income -0.1119193 0.0788102 -1.420 0.1582
## ses 0.0009389 0.0752588 0.012 0.9901
## gender_simpleMale 0.1085691 0.2025112 0.536 0.5929
## race_simpleBlack 0.6161984 0.3613507 1.705 0.0908 .
## race_simpleAsian -0.0564808 0.3630282 -0.156 0.8766
## race_simpleOther 0.2649364 0.3477260 0.762 0.4476
## glp1_exposure -0.4556302 0.3825953 -1.191 0.2361
## conditionmock 0.1166240 0.2519814 0.463 0.6443
## conditionsmoothie_king -0.0833086 0.2596089 -0.321 0.7489
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.104 on 118 degrees of freedom
## Multiple R-squared: 0.1116, Adjusted R-squared: 0.02874
## F-statistic: 1.347 on 11 and 118 DF, p-value: 0.2075
confint(m_demog2)
## 2.5 % 97.5 %
## (Intercept) 3.56320782 5.713492703
## age -0.02278541 0.007896231
## bmi -0.03003464 0.006957949
## income -0.26798488 0.044146362
## ses -0.14809409 0.149971871
## gender_simpleMale -0.29245820 0.509596357
## race_simpleBlack -0.09937445 1.331771167
## race_simpleAsian -0.77537553 0.662413921
## race_simpleOther -0.42365573 0.953528453
## glp1_exposure -1.21327313 0.302012667
## conditionmock -0.38236779 0.615615833
## conditionsmoothie_king -0.59740502 0.430787758
car::vif(m_demog2)
## GVIF Df GVIF^(1/(2*Df))
## age 1.107349 1 1.052307
## bmi 1.170358 1 1.081831
## income 1.968538 1 1.403046
## ses 2.024423 1 1.422822
## gender_simple 1.089185 1 1.043640
## race_simple 1.289671 3 1.043309
## glp1_exposure 1.209048 1 1.099567
## condition 1.215559 2 1.050011
shapiro.test(residuals(m_demog2))
##
## Shapiro-Wilk normality test
##
## data: residuals(m_demog2)
## W = 0.9093, p-value = 2.487e-07
lmtest::bptest(m_demog2)
##
## studentized Breusch-Pagan test
##
## data: m_demog2
## BP = 8.4855, df = 11, p-value = 0.6693
plot(m_demog2)
A few assumptions were violated, so we’ll run a bootstrapped model.
boot_demog2 <- car::Boot(m_demog2, R = 5000)
summary(boot_demog2)
##
## Number of bootstrap replications R = 5000
## original bootBias bootSE bootMed
## (Intercept) 4.63835026 -0.02823450 0.5609807 4.6113401
## age -0.00744459 -0.00024621 0.0077345 -0.0075609
## bmi -0.01153835 0.00134917 0.0103436 -0.0109470
## income -0.11191926 0.00271298 0.0726120 -0.1086275
## ses 0.00093889 0.00107705 0.0789708 0.0007107
## gender_simpleMale 0.10856908 0.00732795 0.1975563 0.1149586
## race_simpleBlack 0.61619836 -0.03528417 0.3171964 0.5797187
## race_simpleAsian -0.05648080 -0.00109131 0.3851599 -0.0498997
## race_simpleOther 0.26493636 0.01182211 0.2957016 0.2857324
## glp1_exposure -0.45563023 -0.00485698 0.5409207 -0.4435853
## conditionmock 0.11662402 -0.01947263 0.2591642 0.0966352
## conditionsmoothie_king -0.08330863 -0.01349561 0.2683256 -0.0954696
confint(boot_demog2, type = "perc")
## Bootstrap percent confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) 3.46603898 5.69259793
## age -0.02275325 0.00692676
## bmi -0.02915258 0.01283392
## income -0.25604149 0.03206759
## ses -0.14625094 0.16689552
## gender_simpleMale -0.27863781 0.50517593
## race_simpleBlack -0.03979502 1.19164840
## race_simpleAsian -0.83515272 0.68425062
## race_simpleOther -0.32198836 0.83206148
## glp1_exposure -1.58866167 0.58971908
## conditionmock -0.41437002 0.60449513
## conditionsmoothie_king -0.61647319 0.43594577
confint(boot_demog2, type = "bca")
## Bootstrap bca confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) 3.52102364 5.735575124
## age -0.02285777 0.006869729
## bmi -0.02918823 0.012671502
## income -0.26614505 0.020484044
## ses -0.14380212 0.173278031
## gender_simpleMale -0.30240481 0.482143295
## race_simpleBlack 0.03803647 1.278561463
## race_simpleAsian -0.84957105 0.655904998
## race_simpleOther -0.47669996 0.745755151
## glp1_exposure -1.66459455 0.548068885
## conditionmock -0.37304847 0.643933760
## conditionsmoothie_king -0.59032161 0.461495555
# Table 3: product evaluations ~ beliefs + demographics
m_eval2 <- lm(
eval_mean ~ glp1_belief_mean + age + bmi + income + ses +
gender_simple + race_simple + glp1_exposure + condition,
data = na.omit(dat2)
)
summary(m_eval2)
##
## Call:
## lm(formula = eval_mean ~ glp1_belief_mean + age + bmi + income +
## ses + gender_simple + race_simple + glp1_exposure + condition,
## data = na.omit(dat2))
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.4713 -1.1241 -0.2465 1.0704 2.6774
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.696395 0.812138 0.857 0.39293
## glp1_belief_mean 0.350278 0.108240 3.236 0.00158 **
## age -0.012470 0.009144 -1.364 0.17529
## bmi 0.018045 0.011053 1.633 0.10525
## income -0.180416 0.093452 -1.931 0.05596 .
## ses 0.192388 0.088488 2.174 0.03171 *
## gender_simpleMale 0.099297 0.238399 0.417 0.67780
## race_simpleBlack 0.066263 0.430074 0.154 0.87782
## race_simpleAsian -0.469233 0.426887 -1.099 0.27394
## race_simpleOther -0.178539 0.409855 -0.436 0.66392
## glp1_exposure 0.416598 0.452545 0.921 0.35917
## conditionmock 0.363982 0.296545 1.227 0.22213
## conditionsmoothie_king 0.208182 0.305377 0.682 0.49676
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.298 on 117 degrees of freedom
## Multiple R-squared: 0.1858, Adjusted R-squared: 0.1023
## F-statistic: 2.225 on 12 and 117 DF, p-value: 0.01458
Checking a few things:
# 95% CIs
confint(m_eval2)
## 2.5 % 97.5 %
## (Intercept) -0.912001080 2.304790721
## glp1_belief_mean 0.135915337 0.564641579
## age -0.030579135 0.005639961
## bmi -0.003845068 0.039934469
## income -0.365493022 0.004661691
## ses 0.017141459 0.367634051
## gender_simpleMale -0.372840687 0.571434021
## race_simpleBlack -0.785475238 0.918002176
## race_simpleAsian -1.314660171 0.376193425
## race_simpleOther -0.990236217 0.633157458
## glp1_exposure -0.479643468 1.312839478
## conditionmock -0.223308870 0.951273364
## conditionsmoothie_king -0.396601704 0.812965891
# Multicollinearity
car::vif(m_eval2)
## GVIF Df GVIF^(1/(2*Df))
## glp1_belief_mean 1.125568 1 1.060928
## age 1.116015 1 1.056416
## bmi 1.185493 1 1.088804
## income 2.002182 1 1.414985
## ses 2.024426 1 1.422823
## gender_simple 1.091838 1 1.044911
## race_simple 1.327033 3 1.048287
## glp1_exposure 1.223580 1 1.106155
## condition 1.222854 2 1.051583
# Residual diagnostics
shapiro.test(residuals(m_eval2))
##
## Shapiro-Wilk normality test
##
## data: residuals(m_eval2)
## W = 0.95648, p-value = 0.0003692
lmtest::bptest(m_eval2)
##
## studentized Breusch-Pagan test
##
## data: m_eval2
## BP = 20.263, df = 12, p-value = 0.06227
# Bootstrap
set.seed(1234)
boot_eval2 <- car::Boot(m_eval2, R = 5000)
summary(boot_eval2)
##
## Number of bootstrap replications R = 5000
## original bootBias bootSE bootMed
## (Intercept) 0.696395 -6.1970e-02 0.7516637 0.629308
## glp1_belief_mean 0.350278 -7.0022e-03 0.0877912 0.344736
## age -0.012470 4.4983e-05 0.0088363 -0.012466
## bmi 0.018045 2.6269e-03 0.0128518 0.018942
## income -0.180416 -2.9488e-04 0.0987534 -0.179718
## ses 0.192388 3.9484e-03 0.1066177 0.193193
## gender_simpleMale 0.099297 -3.7357e-03 0.2374789 0.093009
## race_simpleBlack 0.066263 -2.0891e-02 0.4624677 0.050564
## race_simpleAsian -0.469233 1.1454e-02 0.4098306 -0.451160
## race_simpleOther -0.178539 9.1645e-03 0.4121240 -0.173006
## glp1_exposure 0.416598 -8.1431e-03 0.3484391 0.412727
## conditionmock 0.363982 7.7287e-03 0.3134988 0.374321
## conditionsmoothie_king 0.208182 -5.4176e-03 0.3170942 0.200123
confint(boot_eval2, type = "perc")
## Bootstrap percent confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -8.149724e-01 2.115551263
## glp1_belief_mean 1.690583e-01 0.514211479
## age -2.989289e-02 0.004487929
## bmi -5.785233e-05 0.052165884
## income -3.760666e-01 0.014592671
## ses -4.552821e-03 0.411778097
## gender_simpleMale -3.707156e-01 0.552169329
## race_simpleBlack -9.041250e-01 0.934884962
## race_simpleAsian -1.277119e+00 0.340795413
## race_simpleOther -9.672057e-01 0.652195664
## glp1_exposure -3.093265e-01 1.080943446
## conditionmock -2.434339e-01 0.972604387
## conditionsmoothie_king -4.229345e-01 0.827806741
confint(boot_eval2, type = "bca")
## Bootstrap bca confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -0.649947579 2.318041819
## glp1_belief_mean 0.179896632 0.523719472
## age -0.029895783 0.004478506
## bmi -0.003564956 0.046776643
## income -0.370939250 0.021530602
## ses -0.022578461 0.393493903
## gender_simpleMale -0.361192716 0.566403193
## race_simpleBlack -0.857513474 0.994181581
## race_simpleAsian -1.338550710 0.292452581
## race_simpleOther -1.001594207 0.617515498
## glp1_exposure -0.286692927 1.108338762
## conditionmock -0.263274874 0.951217466
## conditionsmoothie_king -0.413257667 0.837402059
# Table 4: WTP ~ beliefs + demographics
m_wtp2_full <- lm(
wtp ~ glp1_belief_mean + age + bmi + income + ses +
gender_simple + race_simple + glp1_exposure + condition,
data = na.omit(dat2)
)
summary(m_wtp2_full)
##
## Call:
## lm(formula = wtp ~ glp1_belief_mean + age + bmi + income + ses +
## gender_simple + race_simple + glp1_exposure + condition,
## data = na.omit(dat2))
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.6556 -0.9771 -0.3014 0.5439 3.8088
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -0.349901 0.887128 -0.394 0.69399
## glp1_belief_mean 0.376319 0.118234 3.183 0.00187 **
## age -0.018599 0.009989 -1.862 0.06510 .
## bmi 0.003449 0.012074 0.286 0.77567
## income -0.137938 0.102081 -1.351 0.17922
## ses 0.301368 0.096659 3.118 0.00229 **
## gender_simpleMale -0.304173 0.260412 -1.168 0.24516
## race_simpleBlack 0.004260 0.469786 0.009 0.99278
## race_simpleAsian -0.662900 0.466304 -1.422 0.15780
## race_simpleOther -0.281246 0.447700 -0.628 0.53110
## glp1_exposure 0.779581 0.494332 1.577 0.11749
## conditionmock 0.161679 0.323927 0.499 0.61863
## conditionsmoothie_king 0.080773 0.333575 0.242 0.80909
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.418 on 117 degrees of freedom
## Multiple R-squared: 0.2124, Adjusted R-squared: 0.1316
## F-statistic: 2.629 on 12 and 117 DF, p-value: 0.00382
Checking assumptions.
confint(m_wtp2_full)
## 2.5 % 97.5 %
## (Intercept) -2.10681188 1.407009814
## glp1_belief_mean 0.14216216 0.610475830
## age -0.03838108 0.001182394
## bmi -0.02046251 0.027359513
## income -0.34010471 0.064229088
## ses 0.10993945 0.492795583
## gender_simpleMale -0.81990655 0.211559937
## race_simpleBlack -0.92612593 0.934646002
## race_simpleAsian -1.58639102 0.260591446
## race_simpleOther -1.16789263 0.605400846
## glp1_exposure -0.19941691 1.758579080
## conditionmock -0.47984087 0.803199128
## conditionsmoothie_king -0.57985463 0.741401179
car::vif(m_wtp2_full)
## GVIF Df GVIF^(1/(2*Df))
## glp1_belief_mean 1.125568 1 1.060928
## age 1.116015 1 1.056416
## bmi 1.185493 1 1.088804
## income 2.002182 1 1.414985
## ses 2.024426 1 1.422823
## gender_simple 1.091838 1 1.044911
## race_simple 1.327033 3 1.048287
## glp1_exposure 1.223580 1 1.106155
## condition 1.222854 2 1.051583
shapiro.test(residuals(m_wtp2_full))
##
## Shapiro-Wilk normality test
##
## data: residuals(m_wtp2_full)
## W = 0.91544, p-value = 5.593e-07
lmtest::bptest(m_wtp2_full)
##
## studentized Breusch-Pagan test
##
## data: m_wtp2_full
## BP = 15.348, df = 12, p-value = 0.2229
set.seed(1234)
boot_wtp2 <- car::Boot(m_wtp2_full, R = 5000)
summary(boot_wtp2)
##
## Number of bootstrap replications R = 5000
## original bootBias bootSE bootMed
## (Intercept) -0.3499010 -0.0589125 0.784112 -0.4060850
## glp1_belief_mean 0.3763190 -0.0022821 0.090496 0.3738312
## age -0.0185993 -0.0011854 0.010583 -0.0199102
## bmi 0.0034485 0.0035343 0.013747 0.0047731
## income -0.1379378 -0.0048635 0.113565 -0.1415879
## ses 0.3013675 0.0065352 0.119010 0.3035359
## gender_simpleMale -0.3041733 -0.0097832 0.258120 -0.3148804
## race_simpleBlack 0.0042600 -0.0241183 0.582198 -0.0228569
## race_simpleAsian -0.6628998 0.0509519 0.469804 -0.6529772
## race_simpleOther -0.2812459 0.0016612 0.420418 -0.2988002
## glp1_exposure 0.7795811 0.0428563 0.566701 0.8146769
## conditionmock 0.1616791 0.0138320 0.344703 0.1764465
## conditionsmoothie_king 0.0807733 0.0156197 0.353035 0.1066027
confint(boot_wtp2, type = "perc")
## Bootstrap percent confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -1.94644972 1.13187929
## glp1_belief_mean 0.20017790 0.55498621
## age -0.03996596 0.00140216
## bmi -0.01465780 0.03979243
## income -0.36556861 0.08015362
## ses 0.08564410 0.55001544
## gender_simpleMale -0.82270963 0.19624986
## race_simpleBlack -1.13436380 1.13822647
## race_simpleAsian -1.43092774 0.43584024
## race_simpleOther -1.06920840 0.59669032
## glp1_exposure -0.30718891 1.95305531
## conditionmock -0.50570563 0.84839654
## conditionsmoothie_king -0.60451580 0.79028226
confint(boot_wtp2, type = "bca")
## Bootstrap bca confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -1.85555955 1.224311026
## glp1_belief_mean 0.21004298 0.560910204
## age -0.03794710 0.003197798
## bmi -0.01778104 0.033062006
## income -0.35129756 0.090953414
## ses 0.07436284 0.537650636
## gender_simpleMale -0.80906334 0.210239385
## race_simpleBlack -0.99643149 1.320978170
## race_simpleAsian -1.35122088 0.665417569
## race_simpleOther -1.00951325 0.683658232
## glp1_exposure -0.30875203 1.951998291
## conditionmock -0.53501922 0.820998829
## conditionsmoothie_king -0.68596362 0.725831914
cor.test(dat2$script.required, dat2$glp1_belief_mean)
##
## Pearson's product-moment correlation
##
## data: dat2$script.required and dat2$glp1_belief_mean
## t = -1.7237, df = 134, p-value = 0.08707
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## -0.30797884 0.02158659
## sample estimates:
## cor
## -0.1472815
Goal: Replicate Study 2 in a larger, higher-powered sample and add psychological and social-media predictors (N = 363).
s3_url <- "https://osf.io/ypztv/download" # update with OSF permalink
dat3 <- read.csv(s3_url, comment.char = "#")
dat3 <- dat3[-c(1:10), ]
dat3 <- subset(dat3, product.type == "Smoothie Supplement Powder")
# ── Core DVs ─────────────────────────────────────────────────────────────────
dat3$effect.like.glp1 <- unname(agree_map[na_99(dat3$effect.like.glp1)])
dat3$similar.to.glp1 <- unname(agree_map[na_99(dat3$similar.to.glp1)])
dat3$works.like.glp1 <- unname(agree_map[na_99(dat3$works.like.glp1)])
dat3$glp1_belief_mean <- rowMeans(
dat3[, c("effect.like.glp1","similar.to.glp1","works.like.glp1")],
na.rm = TRUE
)
dat3$purchase1_num <- unname(likely_map[na_99(dat3$purchase1)])
dat3$purchase2_num <- unname(agree_map[na_99(dat3$purchase2)])
dat3$appealing_num <- unname(agree_map[na_99(dat3$appealing)])
dat3$prefer <- rowMeans(
dat3[, c("purchase1_num","purchase2_num","appealing_num")],
na.rm = TRUE
)
dat3$wtp <- as.numeric(unname(wtp_map[na_99(dat3$wtp)]))
# Prescription-knowledge item
dat3$script.required <- unname(script_map[as.character(dat3$script.required)])
# ── Demographics ─────────────────────────────────────────────────────────────
dat3$age <- as_num_na99(dat3$age)
dat3$bmi <- (as_num_na99(dat3$weight) / (as_num_na99(dat3$height_1)^2)) * 703
dat3$ses <- as.numeric(sub("^([0-9]+).*", "\\1", na_99(dat3$ses)))
dat3$income <- factor(
na_99(dat3$income),
levels = c("$0 - $19,999","$20,000 - $39,999","$40,000 - $59,999",
"$60,000 - $89,999","$90,000 - $119,999",
"$120,000 - $149,999","$150,000+"),
ordered = TRUE
) |> as.numeric()
dat3$gender_simple <- case_when(
na_99(dat3$gender) %in% c("Female","Female,Non-binary / third gender") ~ "Female",
na_99(dat3$gender) %in% c("Male","Male,Non-binary / third gender","Male,Transgender") ~ "Male",
TRUE ~ NA_character_
) |> factor(levels = c("Female","Male"))
race3 <- na_99(dat3$race)
race3[grepl(",", race3) | grepl("prefer not to say", race3, ignore.case = TRUE)] <-
"Other / Prefer not to say"
dat3$race_simple <- case_when(
race3 == "White or European American" ~ "White",
race3 == "Black or African American" ~ "Black",
race3 == "Asian" ~ "Asian",
is.na(race3) ~ NA_character_,
TRUE ~ "Other"
) |> factor(levels = c("White","Black","Asian","Other"))
dat3$taking.glp1_num <- unname(yes_no_map[na_99(dat3$taking.glp1)])
dat3$glp1_exposure <- case_when(
dat3$taking.glp1_num %in% c(4,5) ~ 1,
dat3$taking.glp1_num %in% c(1,2) ~ 0,
TRUE ~ NA_real_
)
dat3$politics <- recode(
na_99(dat3$politics),
"Very liberal" = "1",
"Liberal" = "2",
"Somewhat liberal" = "3",
"Neither liberal nor conservative"= "4",
"Somewhat conservative" = "5",
"Conservative" = "6",
"Very conservative" = "7",
.default = NA_character_
) |> as.numeric()
dat3$FL_16_DO <- factor(na_99(dat3$FL_16_DO))
# ── Health anxiety (6 SHAI items, columns 40–45) ─────────────────────────────
health_anxt <- as.data.frame(dat3[, 40:45])
score_item_0to3 <- function(x, levels_key) {
x <- na_99(x)
as.numeric(factor(x, levels = levels_key, ordered = TRUE)) - 1
}
s1h <- score_item_0to3(health_anxt[[1]], c("Never","Occasionally","Much of the time","Most of the time"))
s2h <- score_item_0to3(health_anxt[[2]], c("Without a problem","Most of the time",
"I try to resist thoughts of illness but am often unable to do so",
"Thoughts of illness are so strong I no longer try to resist them"))
s3h <- score_item_0to3(health_anxt[[3]], c("Not at all","Sometimes","Often","Always"))
s4h <- score_item_0to3(health_anxt[[4]], c("Never","Sometimes","Often","Always"))
s5h <- score_item_0to3(health_anxt[[5]], c("Very low","Fairly low","Moderate","High"))
s6h <- score_item_0to3(health_anxt[[6]], c("Do not worry about my health",
"Have a normal attitude about my health",
"Worry too much about my health","Am a hypochondriac"))
dat3$ha_mean <- rowMeans(cbind(s1h, s2h, s3h, s4h, s5h, s6h), na.rm = TRUE)
# ── Weight loss concerns (5 items, columns 46–52) ────────────────────────────
dat3$afraid_3lbs <- recode(dat3[,46],
"Very unafraid" = 1, "Unafraid" = 2,
"Neither afraid nor unafraid" = 3, "Afraid" = 4, "Very afraid" = 5)
dat3$weight_importance <- as.numeric(factor(dat3[,47],
levels = c("Not important at all","Barely important","Somewhat important",
"Important","Very important")))
dat3[,48][dat3[,48] == "-99"] <- NA
dat3$ever_dieted <- as.numeric(factor(dat3[,48],
levels = c("Definitely not","Probably not","Might or might not",
"Probably yes","Definitely yes")))
dat3$need.lose.weight <- ifelse(dat3[,51] == "Yes", 1, 0)
dat3$scale_matters <- as.numeric(factor(dat3[,52],
levels = c("Strongly disagree","Somewhat disagree","Neither agree nor disagree",
"Somewhat agree","Strongly agree")))
dat3$wlc.average <- rowMeans(cbind(
dat3$afraid_3lbs, dat3$weight_importance, dat3$ever_dieted,
dat3$need.lose.weight, dat3$scale_matters), na.rm = TRUE)
# ── Body surveillance (7 items, columns 53–59) ───────────────────────────────
bs_items <- names(dat3)[53:59]
likert7_key <- c("Strongly disagree"=1,"Disagree"=2,"Somewhat disagree"=3,
"Neither agree nor disagree"=4,"Somewhat agree"=5,
"Agree"=6,"Strongly agree"=7)
for (v in bs_items) {
x <- na_99(dat3[[v]]); x[x == "Not Applicable"] <- NA
dat3[[v]] <- unname(likert7_key[x])
}
rev_bs <- intersect(c("bs1","bs2","bs3","bs6","bs7"), names(dat3))
dat3[rev_bs] <- lapply(dat3[rev_bs], function(x) ifelse(is.na(x), NA, 8 - x))
dat3$body_surv_mean <- rowMeans(dat3[, bs_items], na.rm = TRUE)
# ── Body appreciation (10 items, columns 60–69) ──────────────────────────────
ba_items <- names(dat3)[60:69]
ba_key <- c("Never"=1,"Seldom"=2,"Sometimes"=3,"Often"=4,"Always"=5)
for (v in ba_items) {
x <- na_99(dat3[[v]]); x[x == "Not Applicable"] <- NA
dat3[[v]] <- unname(ba_key[x])
}
dat3$body_appreciation_mean <- rowMeans(dat3[, ba_items], na.rm = TRUE)
# ── Eating disorder risk (7 yes/no items, columns 70–76) ─────────────────────
ed_items <- names(dat3)[70:76]
yn_key <- c("No"=0,"Yes"=1)
for (v in ed_items) {
x <- na_99(dat3[[v]]); x[x == "Prefer not to say"] <- NA
dat3[[v]] <- unname(yn_key[x])
}
dat3$ed_risk_total <- rowSums(dat3[, ed_items], na.rm = TRUE)
cat("=== False-belief scale ===\n")
## === False-belief scale ===
psych::alpha(dat3[, c("effect.like.glp1","similar.to.glp1","works.like.glp1")])[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd
## 0.9540386 0.9545878 0.938384 0.8751068 21.02053 0.004208446 3.617069 1.230947
## median_r
## 0.8806055
cat("\n=== Product evaluation scale ===\n")
##
## === Product evaluation scale ===
psych::alpha(dat3[, c("purchase1_num","purchase2_num","appealing_num")])[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd
## 0.9669932 0.9680632 0.9563041 0.909942 30.31186 0.003014521 2.356122 1.368216
## median_r
## 0.9028927
cat("\n=== Health anxiety (SHAI) ===\n")
##
## === Health anxiety (SHAI) ===
psych::alpha(cbind(s1h, s2h, s3h, s4h, s5h, s6h))[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean
## 0.8883078 0.8887597 0.8764536 0.5711083 7.989546 0.008653013 1.004736
## sd median_r
## 0.6093592 0.6029069
cat("\n=== Weight loss concerns ===\n")
##
## === Weight loss concerns ===
psych::alpha(cbind(dat3$afraid_3lbs, dat3$weight_importance,
dat3$ever_dieted, dat3$need.lose.weight,
dat3$scale_matters))[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd
## 0.7540622 0.7833726 0.7620642 0.4196992 3.616221 0.01878833 2.884718 0.7933238
## median_r
## 0.3934151
cat("\n=== Body surveillance ===\n")
##
## === Body surveillance ===
psych::alpha(dat3[, bs_items])[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd
## 0.8437645 0.842784 0.837652 0.433688 5.360677 0.01221992 4.079325 1.18841
## median_r
## 0.4128959
cat("\n=== Body appreciation ===\n")
##
## === Body appreciation ===
psych::alpha(dat3[, ba_items])[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean
## 0.9619208 0.9619966 0.9623365 0.7168219 25.31346 0.002852702 3.333065
## sd median_r
## 0.9373581 0.7279823
cat("\n=== Eating disorder risk ===\n")
##
## === Eating disorder risk ===
psych::alpha(dat3[, ed_items])[1]
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean sd
## 0.7669352 0.7399519 0.743659 0.2890112 2.845443 0.01600541 0.2642601 0.2705937
## median_r
## 0.2931444
cat("Endorsement rates (somewhat/strongly agree):\n")
## Endorsement rates (somewhat/strongly agree):
cat(" Has GLP-1-like effects:", agree_pct(dat3$effect.like.glp1), "%\n")
## Has GLP-1-like effects: 67 %
cat(" Similar to GLP-1: ", agree_pct(dat3$similar.to.glp1), "%\n")
## Similar to GLP-1: 68.9 %
cat(" Works like GLP-1: ", agree_pct(dat3$works.like.glp1), "%\n")
## Works like GLP-1: 60.1 %
p1 <- plot_likert_hist(dat3, "effect.like.glp1", "Has GLP-1-like effects")
p2 <- plot_likert_hist(dat3, "similar.to.glp1", "Similar to GLP-1")
p3 <- plot_likert_hist(dat3, "works.like.glp1", "Works like GLP-1", show_x = TRUE)
p1 / p2 / p3
Figure 3. Distributions of endorsement that the product has GLP-1-like effects (Study 3).
m_belief3 <- aov(glp1_belief_mean ~ FL_16_DO, data = dat3)
cat("=== Beliefs by condition ===\n"); summary(m_belief3)
## === Beliefs by condition ===
## Df Sum Sq Mean Sq F value Pr(>F)
## FL_16_DO 2 19.7 9.827 6.684 0.00141 **
## Residuals 370 544.0 1.470
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
cat("\nHolm-corrected pairwise contrasts:\n")
##
## Holm-corrected pairwise contrasts:
emmeans(m_belief3, pairwise ~ FL_16_DO, adjust = "holm")
## $emmeans
## FL_16_DO emmean SE df lower.CL upper.CL
## AmazonSmoothie 3.29 0.111 370 3.07 3.50
## Smoothie 3.73 0.106 370 3.52 3.94
## SmoothieKing 3.82 0.110 370 3.60 4.03
##
## Confidence level used: 0.95
##
## $contrasts
## contrast estimate SE df t.ratio p.value
## AmazonSmoothie - Smoothie -0.4453 0.153 370 -2.905 0.0078
## AmazonSmoothie - SmoothieKing -0.5312 0.156 370 -3.400 0.0022
## Smoothie - SmoothieKing -0.0859 0.152 370 -0.564 0.5731
##
## P value adjustment: holm method for 3 tests
m_prefer3 <- aov(prefer ~ FL_16_DO, data = dat3)
cat("\n=== Evaluations by condition ===\n"); summary(m_prefer3)
##
## === Evaluations by condition ===
## Df Sum Sq Mean Sq F value Pr(>F)
## FL_16_DO 2 9.2 4.618 2.486 0.0846 .
## Residuals 370 687.2 1.857
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
m_wtp3 <- aov(wtp ~ FL_16_DO, data = dat3)
cat("\n=== WTP by condition ===\n"); summary(m_wtp3)
##
## === WTP by condition ===
## Df Sum Sq Mean Sq F value Pr(>F)
## FL_16_DO 2 7.0 3.476 1.576 0.208
## Residuals 370 815.9 2.205
demog_vars3 <- c("bmi","income","ses","age","gender_simple","race_simple",
"glp1_exposure","FL_16_DO")
psych_vars3 <- c("ha_mean","wlc.average","body_surv_mean",
"body_appreciation_mean","ed_risk_total","politics")
fml <- function(dv, rhs) as.formula(paste(dv, "~", paste(rhs, collapse = " + ")))
make_df <- function(dv, rhs) {
dat3 |> select(all_of(c(dv, rhs))) |> filter(complete.cases(pick(everything())))
}
df1 <- make_df("glp1_belief_mean", c(demog_vars3, psych_vars3))
message("Table 5 N: ", nrow(df1))
m1_s3 <- lm(fml("glp1_belief_mean", c(demog_vars3, psych_vars3)), data = na.omit(df1))
summary(m1_s3)
##
## Call:
## lm(formula = fml("glp1_belief_mean", c(demog_vars3, psych_vars3)),
## data = na.omit(df1))
##
## Residuals:
## Min 1Q Median 3Q Max
## -3.1386 -0.6162 0.1807 0.8567 2.5177
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 2.341447 0.572346 4.091 5.35e-05 ***
## bmi 0.008107 0.006049 1.340 0.181066
## income -0.036951 0.045738 -0.808 0.419714
## ses -0.042250 0.049081 -0.861 0.389929
## age -0.002025 0.005202 -0.389 0.697363
## gender_simpleMale -0.193812 0.132526 -1.462 0.144527
## race_simpleBlack 0.327344 0.204751 1.599 0.110792
## race_simpleAsian 0.350127 0.270356 1.295 0.196164
## race_simpleOther 0.430129 0.240495 1.789 0.074567 .
## glp1_exposure -0.611901 0.180255 -3.395 0.000767 ***
## FL_16_DOSmoothie 0.431067 0.151529 2.845 0.004709 **
## FL_16_DOSmoothieKing 0.465667 0.153938 3.025 0.002672 **
## ha_mean -0.051689 0.122650 -0.421 0.673696
## wlc.average 0.092939 0.108461 0.857 0.392101
## body_surv_mean -0.035231 0.064102 -0.550 0.582938
## body_appreciation_mean 0.200286 0.082902 2.416 0.016211 *
## ed_risk_total 0.041609 0.045327 0.918 0.359279
## politics 0.123817 0.034594 3.579 0.000394 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.16 on 346 degrees of freedom
## Multiple R-squared: 0.1608, Adjusted R-squared: 0.1196
## F-statistic: 3.9 on 17 and 346 DF, p-value: 4.992e-07
Checking assumptions.
confint(m1_s3)
## 2.5 % 97.5 %
## (Intercept) 1.215732376 3.467161693
## bmi -0.003790837 0.020005022
## income -0.126909779 0.053008340
## ses -0.138784751 0.054284348
## age -0.012255284 0.008206276
## gender_simpleMale -0.454470581 0.066846145
## race_simpleBlack -0.075370197 0.730057566
## race_simpleAsian -0.181621682 0.881875949
## race_simpleOther -0.042886251 0.903144576
## glp1_exposure -0.966434461 -0.257367675
## FL_16_DOSmoothie 0.133032705 0.729102066
## FL_16_DOSmoothieKing 0.162894805 0.768438318
## ha_mean -0.292922839 0.189543844
## wlc.average -0.120386722 0.306263777
## body_surv_mean -0.161309392 0.090846899
## body_appreciation_mean 0.037232008 0.363340872
## ed_risk_total -0.047543116 0.130760420
## politics 0.055776535 0.191856682
car::vif(m1_s3)
## GVIF Df GVIF^(1/(2*Df))
## bmi 1.349926 1 1.161863
## income 1.832550 1 1.353717
## ses 1.908543 1 1.381500
## age 1.271698 1 1.127696
## gender_simple 1.156192 1 1.075264
## race_simple 1.298592 3 1.044509
## glp1_exposure 1.258718 1 1.121926
## FL_16_DO 1.072011 2 1.017536
## ha_mean 1.506400 1 1.227355
## wlc.average 1.997856 1 1.413455
## body_surv_mean 1.565953 1 1.251380
## body_appreciation_mean 1.649444 1 1.284307
## ed_risk_total 1.981998 1 1.407835
## politics 1.125713 1 1.060996
shapiro.test(residuals(m1_s3))
##
## Shapiro-Wilk normality test
##
## data: residuals(m1_s3)
## W = 0.96729, p-value = 2.77e-07
lmtest::bptest(m1_s3)
##
## studentized Breusch-Pagan test
##
## data: m1_s3
## BP = 30.698, df = 17, p-value = 0.02173
library(car)
set.seed(1234)
boot_s3_1 <- Boot(m1_s3, R = 5000)
summary(boot_s3_1)
##
## Number of bootstrap replications R = 5000
## original bootBias bootSE bootMed
## (Intercept) 2.3414470 1.9087e-02 0.5554221 2.3568516
## bmi 0.0081071 -3.0459e-04 0.0052868 0.0081260
## income -0.0369507 -3.5378e-03 0.0462214 -0.0410505
## ses -0.0422502 1.7144e-03 0.0470593 -0.0408618
## age -0.0020245 -8.4185e-05 0.0051718 -0.0021535
## gender_simpleMale -0.1938122 1.9528e-03 0.1300895 -0.1911969
## race_simpleBlack 0.3273437 3.2005e-03 0.2045490 0.3349418
## race_simpleAsian 0.3501271 -6.4137e-03 0.2137357 0.3455192
## race_simpleOther 0.4301292 -4.5726e-04 0.2176669 0.4312117
## glp1_exposure -0.6119011 -5.8033e-04 0.2091386 -0.6117558
## FL_16_DOSmoothie 0.4310674 4.0657e-03 0.1548422 0.4347974
## FL_16_DOSmoothieKing 0.4656666 -3.7934e-03 0.1543293 0.4622557
## ha_mean -0.0516895 -3.0357e-04 0.1238376 -0.0523086
## wlc.average 0.0929385 4.0176e-03 0.1071363 0.0960189
## body_surv_mean -0.0352312 -8.2454e-04 0.0633781 -0.0351894
## body_appreciation_mean 0.2002864 -2.8262e-03 0.0819833 0.1979080
## ed_risk_total 0.0416087 -1.2797e-03 0.0451820 0.0402266
## politics 0.1238166 3.9379e-04 0.0359006 0.1242323
confint(boot_s3_1, type = "perc")
## Bootstrap percent confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) 1.277714249 3.464066383
## bmi -0.003667529 0.017369775
## income -0.131134608 0.051074265
## ses -0.133869633 0.050342595
## age -0.012215463 0.008151803
## gender_simpleMale -0.446477710 0.057280957
## race_simpleBlack -0.082010688 0.718507720
## race_simpleAsian -0.091615437 0.752288030
## race_simpleOther 0.006920541 0.862456756
## glp1_exposure -1.024027883 -0.200119146
## FL_16_DOSmoothie 0.121455567 0.740423956
## FL_16_DOSmoothieKing 0.157577876 0.768986032
## ha_mean -0.294650836 0.189522197
## wlc.average -0.118632680 0.302091158
## body_surv_mean -0.160784779 0.089155340
## body_appreciation_mean 0.036001781 0.355036407
## ed_risk_total -0.048700953 0.129116090
## politics 0.052741959 0.195488536
confint(boot_s3_1, type = "bca")
## Bootstrap bca confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) 1.235920921 3.422673092
## bmi -0.003344135 0.017461871
## income -0.122306801 0.059598104
## ses -0.137912979 0.048249154
## age -0.011987910 0.008455824
## gender_simpleMale -0.449745002 0.052698223
## race_simpleBlack -0.111854706 0.694276340
## race_simpleAsian -0.091262404 0.752300872
## race_simpleOther -0.015485189 0.840235614
## glp1_exposure -1.025185135 -0.206283009
## FL_16_DOSmoothie 0.114612012 0.736131936
## FL_16_DOSmoothieKing 0.163985857 0.775657524
## ha_mean -0.290579654 0.192814617
## wlc.average -0.127543093 0.294800514
## body_surv_mean -0.160816747 0.089010060
## body_appreciation_mean 0.041683495 0.360059224
## ed_risk_total -0.045638512 0.132574553
## politics 0.051587609 0.193307971
# Table 6: product evaluations ~ beliefs + demographics + psych
df2 <- make_df("prefer", c("glp1_belief_mean", demog_vars3, psych_vars3))
message("Table 6 N: ", nrow(df2))
m2_s3 <- lm(fml("prefer", c("glp1_belief_mean", demog_vars3, psych_vars3)), data = na.omit(df2))
summary(m2_s3)
##
## Call:
## lm(formula = fml("prefer", c("glp1_belief_mean", demog_vars3,
## psych_vars3)), data = na.omit(df2))
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.4716 -0.8689 -0.1019 0.8756 3.8496
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.122817 0.601357 -1.867 0.06273 .
## glp1_belief_mean 0.295015 0.055167 5.348 1.62e-07 ***
## bmi 0.008547 0.006224 1.373 0.17055
## income -0.014465 0.046979 -0.308 0.75834
## ses -0.033474 0.050419 -0.664 0.50719
## age 0.004316 0.005339 0.808 0.41946
## gender_simpleMale -0.081471 0.136413 -0.597 0.55074
## race_simpleBlack 0.193602 0.210883 0.918 0.35923
## race_simpleAsian 0.096632 0.278102 0.347 0.72845
## race_simpleOther -0.594601 0.247925 -2.398 0.01700 *
## glp1_exposure 0.372204 0.188026 1.980 0.04855 *
## FL_16_DOSmoothie 0.278354 0.157302 1.770 0.07769 .
## FL_16_DOSmoothieKing 0.262888 0.160041 1.643 0.10137
## ha_mean -0.108318 0.125891 -0.860 0.39016
## wlc.average 0.201815 0.111417 1.811 0.07096 .
## body_surv_mean 0.192970 0.065808 2.932 0.00359 **
## body_appreciation_mean 0.078692 0.085785 0.917 0.35962
## ed_risk_total 0.145039 0.046570 3.114 0.00200 **
## politics 0.053479 0.036150 1.479 0.13996
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.19 on 345 degrees of freedom
## Multiple R-squared: 0.2848, Adjusted R-squared: 0.2475
## F-statistic: 7.634 on 18 and 345 DF, p-value: < 2.2e-16
Checking assumptions.
confint(m2_s3)
## 2.5 % 97.5 %
## (Intercept) -2.305604959 0.05997164
## glp1_belief_mean 0.186509502 0.40352125
## bmi -0.003694096 0.02078792
## income -0.106865523 0.07793600
## ses -0.132641417 0.06569330
## age -0.006185311 0.01481643
## gender_simpleMale -0.349777472 0.18683555
## race_simpleBlack -0.221176427 0.60838055
## race_simpleAsian -0.450356353 0.64362012
## race_simpleOther -1.082236448 -0.10696609
## glp1_exposure 0.002381719 0.74202593
## FL_16_DOSmoothie -0.031037689 0.58774576
## FL_16_DOSmoothieKing -0.051890986 0.57766611
## ha_mean -0.355929238 0.13929305
## wlc.average -0.017326459 0.42095591
## body_surv_mean 0.063535764 0.32240517
## body_appreciation_mean -0.090035853 0.24741973
## ed_risk_total 0.053441894 0.23663519
## politics -0.017623196 0.12458045
car::vif(m2_s3)
## GVIF Df GVIF^(1/(2*Df))
## glp1_belief_mean 1.191624 1 1.091615
## bmi 1.356934 1 1.164875
## income 1.836007 1 1.354993
## ses 1.912630 1 1.382979
## age 1.272254 1 1.127943
## gender_simple 1.163339 1 1.078582
## race_simple 1.321305 3 1.047532
## glp1_exposure 1.300640 1 1.140456
## FL_16_DO 1.107189 2 1.025783
## ha_mean 1.507173 1 1.227670
## wlc.average 2.002096 1 1.414954
## body_surv_mean 1.567320 1 1.251927
## body_appreciation_mean 1.677269 1 1.295094
## ed_risk_total 1.986825 1 1.409548
## politics 1.167392 1 1.080459
shapiro.test(residuals(m2_s3))
##
## Shapiro-Wilk normality test
##
## data: residuals(m2_s3)
## W = 0.98849, p-value = 0.005673
lmtest::bptest(m2_s3)
##
## studentized Breusch-Pagan test
##
## data: m2_s3
## BP = 29.594, df = 18, p-value = 0.04159
set.seed(1234)
boot_s3_2 <- Boot(m2_s3, R = 5000)
summary(boot_s3_2)
##
## Number of bootstrap replications R = 5000
## original bootBias bootSE bootMed
## (Intercept) -1.1228167 0.02949849 0.5337420 -1.0988217
## glp1_belief_mean 0.2950154 -0.00088268 0.0560592 0.2937773
## bmi 0.0085469 -0.00016617 0.0060098 0.0086390
## income -0.0144648 0.00145906 0.0467046 -0.0130813
## ses -0.0334741 -0.00186361 0.0505118 -0.0355645
## age 0.0043156 -0.00021107 0.0053913 0.0040947
## gender_simpleMale -0.0814710 -0.00475773 0.1339327 -0.0849026
## race_simpleBlack 0.1936021 0.00454537 0.2302846 0.2006062
## race_simpleAsian 0.0966319 -0.00645099 0.2210492 0.0960515
## race_simpleOther -0.5946013 -0.00062853 0.2224722 -0.5972623
## glp1_exposure 0.3722038 -0.00531372 0.1910209 0.3670449
## FL_16_DOSmoothie 0.2783540 -0.00150611 0.1540223 0.2763377
## FL_16_DOSmoothieKing 0.2628876 -0.00348735 0.1631608 0.2571540
## ha_mean -0.1083181 -0.00496490 0.1319570 -0.1140558
## wlc.average 0.2018147 0.00383735 0.1089588 0.2050548
## body_surv_mean 0.1929705 -0.00071920 0.0636390 0.1929013
## body_appreciation_mean 0.0786919 -0.00155961 0.0816717 0.0782644
## ed_risk_total 0.1450385 -0.00097307 0.0471958 0.1443207
## politics 0.0534786 -0.00039889 0.0365831 0.0526430
confint(boot_s3_2, type = "perc")
## Bootstrap percent confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -2.134975807 -0.02206071
## glp1_belief_mean 0.183243320 0.40282784
## bmi -0.004548670 0.01944154
## income -0.104400087 0.08010441
## ses -0.134741930 0.06442687
## age -0.006389876 0.01508765
## gender_simpleMale -0.358605631 0.17529380
## race_simpleBlack -0.258712858 0.65352946
## race_simpleAsian -0.351275883 0.51719937
## race_simpleOther -1.031150551 -0.15737241
## glp1_exposure -0.002947027 0.73953425
## FL_16_DOSmoothie -0.029167497 0.57642050
## FL_16_DOSmoothieKing -0.061860544 0.58338831
## ha_mean -0.366464018 0.14351954
## wlc.average -0.009311236 0.41203672
## body_surv_mean 0.067385147 0.31672977
## body_appreciation_mean -0.080603708 0.23836852
## ed_risk_total 0.050597960 0.23732211
## politics -0.017335475 0.12478054
confint(boot_s3_2, type = "bca")
## Bootstrap bca confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -2.157338148 -0.06504740
## glp1_belief_mean 0.184337418 0.40486338
## bmi -0.004963183 0.01915281
## income -0.108248196 0.07616848
## ses -0.131161899 0.06777187
## age -0.005747043 0.01579030
## gender_simpleMale -0.352234315 0.18311898
## race_simpleBlack -0.271808853 0.63660341
## race_simpleAsian -0.369385199 0.50247047
## race_simpleOther -1.018517075 -0.13842251
## glp1_exposure 0.018424080 0.75828779
## FL_16_DOSmoothie -0.028000314 0.57824863
## FL_16_DOSmoothieKing -0.050087823 0.59339974
## ha_mean -0.354155400 0.15281168
## wlc.average -0.021780011 0.40328125
## body_surv_mean 0.066886841 0.31635022
## body_appreciation_mean -0.079181086 0.24083083
## ed_risk_total 0.051226158 0.23804821
## politics -0.016218764 0.12704351
# Table 7: WTP ~ beliefs + demographics + psych
df3 <- make_df("wtp", c("glp1_belief_mean", demog_vars3, psych_vars3))
message("Table 7 N: ", nrow(df3))
m3_s3 <- lm(fml("wtp", c("glp1_belief_mean", demog_vars3, psych_vars3)), data = na.omit(df3))
summary(m3_s3)
##
## Call:
## lm(formula = fml("wtp", c("glp1_belief_mean", demog_vars3, psych_vars3)),
## data = na.omit(df3))
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.5565 -0.9540 -0.3298 0.6195 4.6715
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -2.065819 0.704677 -2.932 0.0036 **
## glp1_belief_mean 0.347959 0.064645 5.383 1.36e-07 ***
## bmi 0.008376 0.007293 1.148 0.2516
## income 0.016361 0.055050 0.297 0.7665
## ses 0.024145 0.059082 0.409 0.6830
## age 0.006419 0.006256 1.026 0.3056
## gender_simpleMale 0.063314 0.159851 0.396 0.6923
## race_simpleBlack 0.435027 0.247115 1.760 0.0792 .
## race_simpleAsian -0.252520 0.325883 -0.775 0.4389
## race_simpleOther -0.392473 0.290521 -1.351 0.1776
## glp1_exposure -0.012206 0.220331 -0.055 0.9559
## FL_16_DOSmoothie 0.254049 0.184328 1.378 0.1690
## FL_16_DOSmoothieKing 0.007347 0.187538 0.039 0.9688
## ha_mean -0.192958 0.147521 -1.308 0.1917
## wlc.average 0.111755 0.130559 0.856 0.3926
## body_surv_mean 0.092216 0.077114 1.196 0.2326
## body_appreciation_mean 0.066048 0.100524 0.657 0.5116
## ed_risk_total 0.133020 0.054571 2.438 0.0153 *
## politics -0.009400 0.042361 -0.222 0.8245
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.394 on 345 degrees of freedom
## Multiple R-squared: 0.1756, Adjusted R-squared: 0.1326
## F-statistic: 4.084 on 18 and 345 DF, p-value: 9.262e-08
Checking assumptions.
confint(m3_s3)
## 2.5 % 97.5 %
## (Intercept) -3.451823285 -0.67981539
## glp1_belief_mean 0.220810338 0.47510702
## bmi -0.005968557 0.02271973
## income -0.091915614 0.12463678
## ses -0.092060318 0.14035042
## age -0.005886408 0.01872365
## gender_simpleMale -0.251090741 0.37771812
## race_simpleBlack -0.051015108 0.92106860
## race_simpleAsian -0.893487066 0.38844623
## race_simpleOther -0.963888750 0.17894346
## glp1_exposure -0.445567102 0.42115587
## FL_16_DOSmoothie -0.108499661 0.61659738
## FL_16_DOSmoothieKing -0.361513762 0.37620796
## ha_mean -0.483111472 0.09719529
## wlc.average -0.145036684 0.36854727
## body_surv_mean -0.059456486 0.24388944
## body_appreciation_mean -0.131668676 0.26376538
## ed_risk_total 0.025685610 0.24035346
## politics -0.092717673 0.07391808
car::vif(m3_s3)
## GVIF Df GVIF^(1/(2*Df))
## glp1_belief_mean 1.191624 1 1.091615
## bmi 1.356934 1 1.164875
## income 1.836007 1 1.354993
## ses 1.912630 1 1.382979
## age 1.272254 1 1.127943
## gender_simple 1.163339 1 1.078582
## race_simple 1.321305 3 1.047532
## glp1_exposure 1.300640 1 1.140456
## FL_16_DO 1.107189 2 1.025783
## ha_mean 1.507173 1 1.227670
## wlc.average 2.002096 1 1.414954
## body_surv_mean 1.567320 1 1.251927
## body_appreciation_mean 1.677269 1 1.295094
## ed_risk_total 1.986825 1 1.409548
## politics 1.167392 1 1.080459
shapiro.test(residuals(m3_s3))
##
## Shapiro-Wilk normality test
##
## data: residuals(m3_s3)
## W = 0.92126, p-value = 6.807e-13
lmtest::bptest(m3_s3)
##
## studentized Breusch-Pagan test
##
## data: m3_s3
## BP = 48.459, df = 18, p-value = 0.0001286
set.seed(1234)
boot_s3_3 <- Boot(m3_s3, R = 5000)
summary(boot_s3_3)
##
## Number of bootstrap replications R = 5000
## original bootBias bootSE bootMed
## (Intercept) -2.0658193 3.6890e-02 0.6207945 -2.0259223
## glp1_belief_mean 0.3479587 -1.3037e-03 0.0622742 0.3454575
## bmi 0.0083756 -4.3321e-04 0.0076126 0.0084113
## income 0.0163606 1.0988e-03 0.0555717 0.0177127
## ses 0.0241451 -1.5994e-03 0.0644276 0.0206698
## age 0.0064186 2.3528e-04 0.0060499 0.0065653
## gender_simpleMale 0.0633137 -7.2849e-03 0.1561079 0.0589094
## race_simpleBlack 0.4350267 1.7450e-03 0.2890151 0.4362306
## race_simpleAsian -0.2525204 -3.7853e-03 0.2762982 -0.2599898
## race_simpleOther -0.3924726 4.7092e-03 0.2289134 -0.3842326
## glp1_exposure -0.0122056 -9.4734e-03 0.2131354 -0.0231576
## FL_16_DOSmoothie 0.2540489 -3.8826e-05 0.1870513 0.2560695
## FL_16_DOSmoothieKing 0.0073471 -4.8630e-03 0.1899400 0.0012546
## ha_mean -0.1929581 -9.3143e-03 0.1555681 -0.2001676
## wlc.average 0.1117553 2.5307e-03 0.1203372 0.1170755
## body_surv_mean 0.0922165 -3.1755e-04 0.0736596 0.0922186
## body_appreciation_mean 0.0660484 -5.0454e-03 0.1003918 0.0600859
## ed_risk_total 0.1330195 -1.2917e-05 0.0543125 0.1320444
## politics -0.0093998 -7.2537e-04 0.0436081 -0.0099015
confint(boot_s3_3, type = "perc")
## Bootstrap percent confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -3.219237586 -0.78621325
## glp1_belief_mean 0.225193500 0.47290787
## bmi -0.008426349 0.02162018
## income -0.090329963 0.12667490
## ses -0.103015400 0.15387423
## age -0.005144504 0.01854047
## gender_simpleMale -0.254096688 0.35381744
## race_simpleBlack -0.133129107 1.02648167
## race_simpleAsian -0.782726461 0.29854172
## race_simpleOther -0.839330509 0.06250978
## glp1_exposure -0.433845221 0.40365113
## FL_16_DOSmoothie -0.112767848 0.60915310
## FL_16_DOSmoothieKing -0.374087336 0.37743017
## ha_mean -0.503717062 0.09195760
## wlc.average -0.121335723 0.34923288
## body_surv_mean -0.054075022 0.23208255
## body_appreciation_mean -0.133635581 0.25825177
## ed_risk_total 0.026618984 0.24344926
## politics -0.096021596 0.07532542
confint(boot_s3_3, type = "bca")
## Bootstrap bca confidence intervals
##
## 2.5 % 97.5 %
## (Intercept) -3.305054937 -0.87232532
## glp1_belief_mean 0.230230294 0.47617865
## bmi -0.007641868 0.02220470
## income -0.094538477 0.12425110
## ses -0.095747706 0.16457325
## age -0.005432095 0.01827506
## gender_simpleMale -0.241940849 0.36560745
## race_simpleBlack -0.115109112 1.03602147
## race_simpleAsian -0.736946792 0.34348511
## race_simpleOther -0.847637509 0.05353829
## glp1_exposure -0.408121009 0.42856372
## FL_16_DOSmoothie -0.117120143 0.60523638
## FL_16_DOSmoothieKing -0.362749592 0.39077149
## ha_mean -0.485365446 0.11369918
## wlc.average -0.139305141 0.33242094
## body_surv_mean -0.056794718 0.23031622
## body_appreciation_mean -0.122270116 0.27215665
## ed_risk_total 0.028854011 0.24508320
## politics -0.094140778 0.07624156
cor.test(dat3$script.required, dat3$glp1_belief_mean)
##
## Pearson's product-moment correlation
##
## data: dat3$script.required and dat3$glp1_belief_mean
## t = -2.0668, df = 371, p-value = 0.03944
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## -0.206003181 -0.005206382
## sample estimates:
## cor
## -0.1066925
sessionInfo()
## R version 4.5.1 (2025-06-13)
## Platform: aarch64-apple-darwin20
## Running under: macOS Sequoia 15.7.4
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/4.5-arm64/Resources/lib/libRblas.0.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.5-arm64/Resources/lib/libRlapack.dylib; LAPACK version 3.12.1
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## time zone: America/Chicago
## tzcode source: internal
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] car_3.1-3 carData_3.0-5 psych_2.5.6 emmeans_1.11.2
## [5] patchwork_1.3.2 ggplot2_3.5.2 dplyr_1.1.4
##
## loaded via a namespace (and not attached):
## [1] sandwich_3.1-1 sass_0.4.10 generics_0.1.4 lattice_0.22-7
## [5] digest_0.6.37 magrittr_2.0.3 evaluate_1.0.4 grid_4.5.1
## [9] estimability_1.5.1 RColorBrewer_1.1-3 mvtnorm_1.3-3 fastmap_1.2.0
## [13] jsonlite_2.0.0 Matrix_1.7-3 Formula_1.2-5 survival_3.8-3
## [17] multcomp_1.4-28 scales_1.4.0 TH.data_1.1-4 codetools_0.2-20
## [21] jquerylib_0.1.4 abind_1.4-8 mnormt_2.1.1 cli_3.6.5
## [25] rlang_1.1.6 splines_4.5.1 withr_3.0.2 cachem_1.1.0
## [29] yaml_2.3.10 tools_4.5.1 parallel_4.5.1 coda_0.19-4.1
## [33] boot_1.3-31 vctrs_0.6.5 R6_2.6.1 zoo_1.8-14
## [37] lifecycle_1.0.4 MASS_7.3-65 pkgconfig_2.0.3 pillar_1.11.0
## [41] bslib_0.9.0 gtable_0.3.6 glue_1.8.0 lmtest_0.9-40
## [45] xfun_0.56 tibble_3.3.0 tidyselect_1.2.1 rstudioapi_0.17.1
## [49] knitr_1.50 farver_2.1.2 xtable_1.8-4 htmltools_0.5.8.1
## [53] nlme_3.1-168 rmarkdown_2.29 labeling_0.4.3 compiler_4.5.1