Show R code
source("R/fast-tech-shared.R")
figure_caption <- function(title, reading_key) {
paste0(
title,
"<br><span class='figure-key'><strong>How to read:</strong> ",
reading_key,
"</span>"
)
}Behavioural insight
WEEE Forum Fast-Tech Consumer Study
Behavioural analyses of fast tech purchasing, ownership and end-of-life decisions.
Executive summary
This report examines the factors associated with fast tech purchasing, willingness, future intentions and end-of-life methods.
- Attitude, age and perceived approval stand out. People with a favourable view of fast tech are more likely to have bought it. The same is true for younger people and those who feel their relatives approve.
- Durability perceptions matter. Expected and comparative lifespan are the leading factors associated with willingness to pay more and replacement choices.
- A shorter perceived lifespan points towards reduction. It corresponds to lower future purchasing intentions, alongside stronger support for buying fewer items.
- Several disposal methods coexist. Recycling is often linked with habit and environmental concern. Keeping devices or putting them in unsuitable bins is more often linked with convenience or not knowing what else to do.
- Buyer profiles are clear. Buyers tend to be younger, live in larger households and have a more favourable view of fast tech than non-buyers.
Research questions
Factors influencing buying
Are buying attitudes, perceived social approval, dynamic norms, durability perceptions and socio-demographic characteristics associated with having bought fast tech?Durability and future choices
Which behavioural factors distinguish willingness to pay for longer-lasting alternatives, replacement choices and intentions to increase, reduce or stop future fast-tech purchases?Exposure and market context
How do exposure to fast tech, ownership and recent purchasing relate to one another?End-of-life pathways
How closely does disposal follow purchasing volume, and which attitudes, norms, lifespan perceptions and declared motivations distinguish keeping, recycling and inappropriate waste disposal?Communication and policy levers
Which intersections and respondent profiles offer the clearest opportunities for durability information, purchase-friction messages, take-back communication, collection design and regulatory action?
1 Sample subdivisions
Show R code
model_country_levels <- sort(
unique(as.character(df$Country))
)
sociodemo_cross_data <- df |>
transmute(
respondent_id = row_number(),
analysis_weight,
country = factor(
Country,
levels = model_country_levels
),
Age_group = as.character(Age_recoded_1),
Gender_group = recode(
as.character(Gender),
"98" = "No answer"
),
Employment_group = as.character(Employment),
Household_size = as.numeric(Nb_household),
recent_purchase_any_non_vape = if_any(
all_of(recent_purchase_cols),
~ as.character(.x) != "0"
)
)
summarise_binary_outcome_by_group <- function(data, outcome) {
outcome <- enquo(outcome)
summarise_dimension <- function(
variable,
dimension,
levels
) {
data |>
transmute(
Group = as.character(.data[[variable]]),
outcome = as.integer(!!outcome),
analysis_weight
) |>
filter(
!is.na(outcome),
Group %in% levels
) |>
group_by(Group) |>
summarise(
n = n(),
pct = weighted_mean_safe(outcome, analysis_weight),
.groups = "drop"
) |>
mutate(
Dimension = dimension,
Group = factor(
Group,
levels = levels
)
)
}
overall <- data |>
summarise(
pct = weighted_mean_safe(
as.integer(!!outcome),
analysis_weight
)
) |>
pull(pct)
desired_rows <- c(
paste(
"Age",
sociodemographic_age_levels,
sep = "___"
),
paste(
"Gender",
sociodemographic_gender_levels,
sep = "___"
),
paste(
"Employment",
sociodemographic_employment_levels,
sep = "___"
)
)
bind_rows(
summarise_dimension(
"Age_group",
"Age",
sociodemographic_age_levels
),
summarise_dimension(
"Gender_group",
"Gender",
sociodemographic_gender_levels
),
summarise_dimension(
"Employment_group",
"Employment",
sociodemographic_employment_levels
)
) |>
mutate(
Dimension = factor(
Dimension,
levels = c(
"Age",
"Gender",
"Employment"
)
),
Group_plot = paste(
Dimension,
as.character(Group),
sep = "___"
),
Group_plot = factor(
Group_plot,
levels = rev(desired_rows)
),
overall = overall,
comparison = if_else(
pct >= overall,
"At or above overall",
"Below overall"
)
)
}
estimate_household_size_curve <- function(data, outcome) {
outcome <- enquo(outcome)
model_data <- data |>
transmute(
Household_size,
country,
outcome = as.integer(!!outcome),
analysis_weight
) |>
drop_na() |>
droplevels()
model <- survey::svyglm(
outcome ~ Household_size + country,
design = make_analysis_design(model_data),
family = quasibinomial()
)
household_values <- seq(
min(model_data$Household_size),
max(model_data$Household_size),
length.out = 100
)
country_weights <- model_data |>
group_by(country) |>
summarise(country_n = sum(analysis_weight), .groups = "drop") |>
mutate(weight = country_n / sum(country_n))
prediction_data <- tidyr::crossing(
Household_size = household_values,
country = levels(model_data$country)
) |>
mutate(
country = factor(
country,
levels = levels(model_data$country)
)
) |>
left_join(
country_weights,
by = "country"
)
design_matrix <- model.matrix(
delete.response(terms(model)),
data = prediction_data
)
prediction_data$predicted <- plogis(
drop(design_matrix %*% coef(model))
)
map_dfr(
household_values,
function(household_size) {
rows <- which(
prediction_data$Household_size ==
household_size
)
probabilities <- prediction_data$predicted[rows]
weights <- prediction_data$weight[rows]
weighted_derivative <- weights *
probabilities *
(1 - probabilities)
gradient <- colSums(
design_matrix[rows, , drop = FALSE] *
weighted_derivative
)
standard_error <- sqrt(
drop(
t(gradient) %*%
vcov(model) %*%
gradient
)
)
estimate <- sum(weights * probabilities)
tibble(
Household_size = household_size,
pct = estimate,
lower = pmax(
0,
estimate - 1.96 * standard_error
),
upper = pmin(
1,
estimate + 1.96 * standard_error
)
)
}
)
}
summarise_household_size_observed <- function(data, outcome) {
outcome <- enquo(outcome)
data |>
transmute(
Household_size,
outcome = as.integer(!!outcome),
analysis_weight
) |>
drop_na() |>
group_by(Household_size) |>
summarise(
n = n(),
pct = weighted_mean_safe(outcome, analysis_weight),
.groups = "drop"
)
}
buying_sociodemo_summary <- summarise_binary_outcome_by_group(
sociodemo_cross_data,
recent_purchase_any_non_vape
)
buying_household_curve <- estimate_household_size_curve(
sociodemo_cross_data,
recent_purchase_any_non_vape
)
buying_household_observed <- summarise_household_size_observed(
sociodemo_cross_data,
recent_purchase_any_non_vape
)
buying_age_young <- buying_sociodemo_summary |>
filter(
Dimension == "Age",
Group == "18-29"
) |>
pull(pct)
buying_age_old <- buying_sociodemo_summary |>
filter(
Dimension == "Age",
Group == "65-99"
) |>
pull(pct)
buying_employment_high <- buying_sociodemo_summary |>
filter(Dimension == "Employment") |>
slice_max(
pct,
n = 1,
with_ties = FALSE
)
buying_employment_low <- buying_sociodemo_summary |>
filter(Dimension == "Employment") |>
slice_min(
pct,
n = 1,
with_ties = FALSE
)
household_volume_cols <- c(
"Household_Charging & lighting devices",
"Household_High-tech",
"Household_Gadgets & lifestyle items"
)
purchase_band_midpoint <- c(
"0" = 0,
"1" = 1,
"2 to 5" = 3.5,
"6 to 9" = 7.5,
"10 to 19" = 14.5,
"20+" = 20
)
disposal_band_midpoint <- c(
"1" = 0,
"2" = 1,
"3" = 3.5,
"4" = 7.5,
"5" = 14.5,
"6" = 20
)
purchase_disposal_data <- df |>
transmute(
analysis_weight,
purchased_count = rowSums(
across(
all_of(recent_purchase_cols),
~ unname(
purchase_band_midpoint[as.character(.x)]
)
)
),
disposed_count = rowSums(
across(
all_of(disposed_non_vape_cols),
~ unname(
disposal_band_midpoint[as.character(.x)]
)
)
)
) |>
drop_na()
purchase_disposal_rho <- weighted_correlation_safe(
rank(purchase_disposal_data$purchased_count),
rank(purchase_disposal_data$disposed_count),
purchase_disposal_data$analysis_weight
)
purchase_disposal_plot_limits <- c(
purchased = unname(quantile(
purchase_disposal_data$purchased_count,
0.98
)),
disposed = unname(quantile(
purchase_disposal_data$disposed_count,
0.98
))
)
purchase_disposal_plot_eligible <- purchase_disposal_data |>
filter(
purchased_count <= purchase_disposal_plot_limits[["purchased"]],
disposed_count <= purchase_disposal_plot_limits[["disposed"]]
)
set.seed(20260805)
purchase_disposal_plot_data <- purchase_disposal_plot_eligible |>
slice_sample(
n = min(
2500,
nrow(purchase_disposal_plot_eligible)
)
)
purchase_disposal_loess <- loess(
disposed_count ~ purchased_count,
data = purchase_disposal_plot_eligible,
weights = analysis_weight,
span = 0.8,
control = loess.control(surface = "direct")
)
purchase_disposal_gap_data <- tibble(
purchased_count = seq(
0,
min(purchase_disposal_plot_limits),
length.out = 200
)
) |>
mutate(
observed = pmax(
0,
predict(
purchase_disposal_loess,
newdata = pick(purchased_count)
)
),
benchmark = purchased_count,
lower = pmin(observed, benchmark),
upper = pmax(observed, benchmark)
) |>
drop_na()
country_purchase_summary <- df |>
group_by(Country) |>
summarise(
n = n(),
pct_recent_buyer = weighted_mean_safe(
Buy_12months == "Buyer",
analysis_weight
),
.groups = "drop"
) |>
arrange(desc(pct_recent_buyer))
country_ever_bought_summary <- df |>
group_by(Country) |>
summarise(
n = n(),
pct_ever_bought = weighted_mean_safe(
Buyer == "Buyer",
analysis_weight
),
.groups = "drop"
) |>
arrange(desc(pct_ever_bought))
country_ever_bought_high <- country_ever_bought_summary |>
slice_max(
pct_ever_bought,
n = 1,
with_ties = FALSE
)
country_ever_bought_low <- country_ever_bought_summary |>
slice_min(
pct_ever_bought,
n = 1,
with_ties = FALSE
)
country_recent_purchase_high <- country_purchase_summary |>
slice_max(
pct_recent_buyer,
n = 1,
with_ties = FALSE
)
country_recent_purchase_low <- country_purchase_summary |>
slice_min(
pct_recent_buyer,
n = 1,
with_ties = FALSE
)
country_buying_stage_summary <- country_ever_bought_summary |>
select(
Country,
`Ever bought` = pct_ever_bought
) |>
left_join(
country_purchase_summary |>
select(
Country,
`Purchased during the last 12 months` =
pct_recent_buyer
),
by = "Country"
) |>
pivot_longer(
-Country,
names_to = "Measure",
values_to = "pct"
) |>
mutate(
Measure = factor(
Measure,
levels = c(
"Purchased during the last 12 months",
"Ever bought"
)
)
)
country_category_owned_summary <- df |>
select(
Country,
analysis_weight,
all_of(household_volume_cols)
) |>
pivot_longer(
all_of(household_volume_cols),
names_to = "Category",
values_to = "Band"
) |>
filter(!is.na(Band)) |>
mutate(
Category = str_remove(
Category,
"^Household_"
),
owned = as.character(Band) != "0"
) |>
group_by(
Country,
Category
) |>
summarise(
n = n(),
pct = weighted_mean_safe(
owned,
analysis_weight
),
.groups = "drop"
) |>
group_by(Country) |>
mutate(
country_mean = mean(pct)
) |>
ungroup()
country_category_owned_extremes <-
country_category_owned_summary |>
group_by(Category) |>
summarise(
highest_country = Country[which.max(pct)],
highest_pct = max(pct),
lowest_country = Country[which.min(pct)],
lowest_pct = min(pct),
.groups = "drop"
)
extract_country_owned_extreme <- function(
category,
field
) {
country_category_owned_extremes |>
filter(Category == category) |>
pull(all_of(field))
}
country_category_disposed_summary <- df |>
select(
Country,
analysis_weight,
all_of(disposed_non_vape_cols)
) |>
pivot_longer(
all_of(disposed_non_vape_cols),
names_to = "Category",
values_to = "Code"
) |>
filter(!is.na(Code)) |>
mutate(
Category = str_remove(
Category,
"^12months_disposed_"
),
Category = recode(
Category,
"Gadget and lifestyle items" =
"Gadgets & lifestyle items"
),
disposed = as.character(Code) != "1"
) |>
group_by(
Country,
Category
) |>
summarise(
n = n(),
pct = weighted_mean_safe(
disposed,
analysis_weight
),
.groups = "drop"
) |>
group_by(Country) |>
mutate(
country_mean = mean(pct)
) |>
ungroup()
country_category_disposed_extremes <-
country_category_disposed_summary |>
group_by(Category) |>
summarise(
highest_country = Country[which.max(pct)],
highest_pct = max(pct),
lowest_country = Country[which.min(pct)],
lowest_pct = min(pct),
.groups = "drop"
)
extract_country_disposed_extreme <- function(
category,
field
) {
country_category_disposed_extremes |>
filter(Category == category) |>
pull(all_of(field))
}
country_category_purchase_summary <- df |>
select(
Country,
analysis_weight,
all_of(recent_purchase_cols)
) |>
pivot_longer(
all_of(recent_purchase_cols),
names_to = "Category",
values_to = "Band"
) |>
mutate(
Category = str_remove(
Category,
"^Buy_12months_"
),
bought = as.character(Band) != "0"
) |>
group_by(
Country,
Category
) |>
summarise(
n = sum(!is.na(bought)),
pct = weighted_mean_safe(bought, analysis_weight),
.groups = "drop"
) |>
group_by(Country) |>
mutate(
country_mean = mean(pct)
) |>
ungroup()
country_category_purchase_extremes <-
country_category_purchase_summary |>
group_by(Category) |>
summarise(
highest_country = Country[which.max(pct)],
highest_pct = max(pct),
lowest_country = Country[which.min(pct)],
lowest_pct = min(pct),
.groups = "drop"
)
extract_country_purchase_extreme <- function(category, field) {
country_category_purchase_extremes |>
filter(Category == category) |>
pull(all_of(field))
}
country_category_ownership_purchase_summary <- bind_rows(
country_category_owned_summary |>
transmute(
Country,
Category,
Measure = "Owned at home",
pct
),
country_category_purchase_summary |>
transmute(
Country,
Category,
Measure = "Purchased during the last 12 months",
pct
)
) |>
left_join(
country_category_owned_summary |>
distinct(
Country,
country_mean
),
by = "Country"
) |>
mutate(
Measure = factor(
Measure,
levels = c(
"Purchased during the last 12 months",
"Owned at home"
)
)
)
country_disposal_method_summary <- df |>
select(
Country,
analysis_weight,
all_of(disposal_method_cols)
) |>
pivot_longer(
all_of(disposal_method_cols),
names_to = "Method",
values_to = "Value"
) |>
filter(!is.na(Value)) |>
mutate(
Method = recode(
Method,
"Other...124" = "Other",
"I don’t remember...125" =
"I don’t remember"
),
selected = is_selected(Value),
method_type = case_when(
Method %in% c(
"I brought them to a recycling centre / municipal waste facility",
"I brought them to a recycling point in a store",
"I gave them away or donated",
"I sold them"
) ~ "Recycling or reuse",
Method %in% c(
"I threw them in general household waste",
"I threw them in the plastic waste bin",
"I threw them in a street bin"
) ~ "Waste disposal",
TRUE ~ "Kept, other or unknown"
)
) |>
group_by(
Country,
Method,
method_type
) |>
summarise(
n = sum(selected),
denominator = n(),
pct = weighted_mean_safe(selected, analysis_weight),
.groups = "drop"
)
country_disposal_method_levels <- c(
"I brought them to a recycling centre / municipal waste facility",
"I brought them to a recycling point in a store",
"I gave them away or donated",
"I sold them",
"I kept them",
"I threw them in general household waste",
"I threw them in the plastic waste bin",
"I threw them in a street bin",
"I don’t remember",
"Other"
)
recycling_centre_method <-
"I brought them to a recycling centre / municipal waste facility"
household_waste_method <-
"I threw them in general household waste"
country_disposal_method_extremes <-
country_disposal_method_summary |>
group_by(Method) |>
summarise(
highest_country = Country[which.max(pct)],
highest_pct = max(pct),
lowest_country = Country[which.min(pct)],
lowest_pct = min(pct),
.groups = "drop"
)
extract_country_disposal_extreme <- function(method, field) {
country_disposal_method_extremes |>
filter(Method == method) |>
pull(all_of(field))
}
test_country_disposal_difference <- function(method, label) {
test_data <- df |>
transmute(
Country = factor(Country),
analysis_weight,
response = .data[[method]]
) |>
filter(!is.na(response)) |>
mutate(
selected = factor(
is_selected(response),
levels = c(FALSE, TRUE)
)
)
design <- survey::svydesign(
ids = ~1,
weights = ~analysis_weight,
data = test_data
)
test <- survey::svychisq(
~selected + Country,
design = design,
statistic = "F"
)
tibble(
Method = label,
F = unname(test$statistic),
df_num = unname(test$parameter[[1]]),
df_den = unname(test$parameter[[2]]),
p_value = test$p.value
)
}
country_disposal_tests <- bind_rows(
test_country_disposal_difference(
recycling_centre_method,
"Recycling centre"
),
test_country_disposal_difference(
household_waste_method,
"Household waste"
)
)
recycling_country_test <- country_disposal_tests |>
filter(Method == "Recycling centre")
household_waste_country_test <- country_disposal_tests |>
filter(Method == "Household waste")1.1 Exposure, ownership and recent purchasing
Show R code
exposure_score_levels <- c(
"Less or never" = 1,
"Few times a year" = 2,
"At least once a month" = 3,
"At least once a week" = 4,
"Everyday" = 5
)
exposure_volume_data <- df |>
transmute(
analysis_weight,
exposure_score = unname(
exposure_score_levels[as.character(`SeeFast-tech`)]
),
items_at_home = rowSums(
across(
all_of(household_volume_cols),
~ unname(purchase_band_midpoint[as.character(.x)])
)
),
items_purchased = rowSums(
across(
all_of(recent_purchase_cols),
~ unname(purchase_band_midpoint[as.character(.x)])
)
)
) |>
drop_na()
exposure_home_r <- weighted_correlation_safe(
exposure_volume_data$exposure_score,
exposure_volume_data$items_at_home,
exposure_volume_data$analysis_weight
)
exposure_purchase_r <- weighted_correlation_safe(
exposure_volume_data$exposure_score,
exposure_volume_data$items_purchased,
exposure_volume_data$analysis_weight
)
exposure_volume_plot_data <- exposure_volume_data |>
transmute(
analysis_weight,
Exposure = exposure_score,
`Items at home` = items_at_home,
`Items purchased during the last 12 months` = items_purchased
) |>
pivot_longer(
c(`Items at home`, `Items purchased during the last 12 months`),
names_to = "Measure",
values_to = "Estimated_items"
)
exposure_volume_summary <- unique(
exposure_volume_plot_data$Measure
) |>
map_dfr(function(measure) {
measure_data <- exposure_volume_plot_data |>
filter(Measure == measure)
survey::svyby(
~Estimated_items,
~Exposure,
make_analysis_design(measure_data),
survey::svymean,
vartype = "ci",
keep.names = FALSE
) |>
as_tibble() |>
transmute(
Measure = measure,
Exposure,
mean_items = Estimated_items,
conf_low = pmax(0, ci_l),
conf_high = ci_u
)
})Quite logically, the more respondents report to be exposed to fast tech, the more devices they have at home and the more they’ve bought during the last 12 months. We cannot know the direction of the relationship, though. Do they buy more because they are more frequently exposed? Do they remember or notice more being exposed because they buy or own more? Do we notice fast tech more if we own more of them?
Show R code
exposure_volume_summary |>
ggplot(aes(
x = Exposure,
y = mean_items,
colour = Measure,
group = Measure
)) +
geom_errorbar(
aes(
ymin = conf_low,
ymax = conf_high
),
width = 0.08,
linewidth = bg_lw_hairline,
position = position_dodge(width = 0.16)
) +
geom_line(
linewidth = bg_lw_line,
position = position_dodge(width = 0.16)
) +
geom_point(
size = bg_point_size,
position = position_dodge(width = 0.16)
) +
scale_colour_manual(
values = c(
"Items at home" = bg_accent,
"Items purchased during the last 12 months" = bg_pink
),
name = NULL
) +
scale_x_continuous(
breaks = 1:5,
labels = c(
"Less or\nnever",
"A few times\na year",
"Monthly",
"Weekly",
"Every day"
)
) +
labs(
x = "Reported exposure frequency",
y = "Estimated number of items"
) +
theme(
legend.position = "top"
)
How to read: Higher exposure frequency accompanies both greater ownership and more purchases, without establishing which comes first.
1.2 Ever having bought fast tech & recent purchasing, by country
The share of respondents who have ever bought fast tech ranges from France (82.6%) to Greece (95.6%). Recent purchasing ranges from Netherlands (70.1%) to Greece (88.8%).
Show R code
country_buying_stage_summary |>
left_join(
country_ever_bought_summary |>
select(
Country,
country_order = pct_ever_bought
),
by = "Country"
) |>
mutate(
Country = fct_reorder(
Country,
country_order
)
) |>
ggplot(aes(
x = pct,
y = Country,
fill = Measure
)) +
geom_col(
position = position_dodge(
width = 0.76
),
width = 0.66
) +
geom_text(
aes(label = percent(
pct,
accuracy = 0.1
)),
position = position_dodge(
width = 0.76
),
hjust = -0.15,
size = bg_size_label / .pt
) +
scale_fill_manual(
name = NULL,
breaks = c(
"Ever bought",
"Purchased during the last 12 months"
),
values = c(
"Ever bought" = bg_accent,
"Purchased during the last 12 months" =
bg_accent_50
)
) +
scale_x_continuous(
labels = percent_format(),
limits = c(0, 1),
expand = expansion(
mult = c(0, 0.06)
)
) +
labs(
x = "% of respondents",
y = NULL
) +
theme(
legend.position = "top"
)
How to read: In Greece, 95.6% have bought fast tech at least once, while 88.8% purchased it during the previous 12 months.
1.3 Recent purchasing by socio-demographic characteristics
Recent purchasing changes with age. It decreases from 93.1% among younger respondents (18–29) to 61.3% among those aged 65–99. By employment status, it is highest among student (94.4%) and lowest among retired (62.1%).
Show R code
buying_sociodemo_summary |>
ggplot(aes(
x = pct,
y = Group_plot,
colour = comparison
)) +
geom_vline(
xintercept = buying_sociodemo_summary$overall[[1]],
colour = bg_ink_32,
linewidth = bg_lw_hairline,
linetype = "dashed"
) +
geom_segment(
aes(
x = overall,
xend = pct,
yend = Group_plot
),
colour = bg_ink_32,
linewidth = bg_lw_line
) +
geom_point(size = 3) +
geom_text(
aes(label = percent(pct, accuracy = 0.1)),
hjust = -0.35,
colour = bg_ink,
size = bg_size_label / .pt
) +
scale_colour_manual(
values = c(
"At or above overall" = bg_accent,
"Below overall" = bg_blue
),
guide = "none"
) +
scale_x_continuous(
labels = percent_format(),
limits = c(0, 1),
expand = expansion(mult = c(0, 0.06))
) +
scale_y_discrete(
labels = \(x) str_remove(x, "^.*___")
) +
facet_grid(
rows = vars(Dimension),
scales = "free_y",
space = "free_y"
) +
labs(
x = "% purchasing at least one item",
y = NULL
) +
theme(
strip.text.y = element_text(angle = 0)
)
How to read: 93.1% of respondents aged 18–29 purchased at least one item, compared with 61.3% of those aged 65–99.
1.4 Recent purchasing by household size
The curve shows the estimated probability of purchasing, with observed rates as points.
Show R code
ggplot(
buying_household_curve,
aes(x = Household_size, y = pct)
) +
geom_ribbon(
aes(ymin = lower, ymax = upper),
fill = bg_accent_20,
alpha = bg_alpha_mute
) +
geom_line(
colour = bg_accent,
linewidth = bg_lw_line
) +
geom_point(
data = buying_household_observed,
aes(size = n),
colour = bg_ink
) +
scale_size_continuous(
name = "N",
range = c(2, 5)
) +
scale_x_continuous(
breaks = 1:10
) +
scale_y_continuous(
labels = percent_format(),
limits = c(0, 1),
expand = expansion(mult = c(0, 0.04))
) +
labs(
x = "Household size",
y = "Estimated probability of recent purchase"
)
How to read: 71.7% of respondents in two-person households purchased at least one item.
1.5 Ownership and recent purchasing by category and country
Ownership and recent purchasing follow similar country patterns, but ownership is consistently more frequent because it includes devices acquired before the last 12 months. For charging and lighting devices, ownership ranges from France (73.8%) to Ireland (90.9%), while recent purchasing ranges from France (59.5%) to Greece (80.3%).
Show R code
country_category_ownership_purchase_summary |>
mutate(
Country = fct_reorder(
Country,
country_mean
),
Category = factor(
Category,
levels = c(
"Charging & lighting devices",
"High-tech",
"Gadgets & lifestyle items"
)
)
) |>
ggplot(aes(
x = pct,
y = Country,
fill = Measure
)) +
geom_col(
position = position_dodge(
width = 0.76
),
width = 0.66
) +
geom_text(
aes(label = percent(
pct,
accuracy = 0.1
)),
position = position_dodge(
width = 0.76
),
hjust = -0.15,
size = bg_size_label / .pt
) +
scale_fill_manual(
name = NULL,
breaks = c(
"Owned at home",
"Purchased during the last 12 months"
),
values = c(
"Owned at home" = bg_accent,
"Purchased during the last 12 months" =
bg_accent_50
)
) +
scale_x_continuous(
labels = percent_format(),
limits = c(0, 1),
expand = expansion(
mult = c(0, 0.07)
)
) +
facet_wrap(
~Category,
ncol = 1
) +
labs(
x = "% of respondents",
y = NULL
) +
theme(
legend.position = "top",
panel.spacing.y = grid::unit(
1.2,
"lines"
)
)
How to read: In Ireland, 90.9% report owning a charging or lighting device at home.
Note: Percentages use the global analysis weight and are calculated separately within each country and category. Ownership refers to devices present in the household and may include devices used by other household members.
1.6 Buying reasons and willingness to pay more
Show R code
buying_reason_cols <- c(
"They are more affordable",
"They are the only available option",
"They are easily available or showcased",
"I read positive reviews about them",
"Promotions or special deals",
"People I trust recommend them",
"I see them in ads or on social media",
"Curiosity, for fun, or trying something new"
)
buying_reason_pay_more_summary <- df |>
select(
analysis_weight,
`Pay more`,
all_of(buying_reason_cols)
) |>
filter(!is.na(`Pay more`)) |>
pivot_longer(
all_of(buying_reason_cols),
names_to = "Reason",
values_to = "Value"
) |>
filter(!is.na(Value)) |>
mutate(
selected = is_selected(Value),
Willingness = factor(
`Pay more`,
levels = willingness_to_pay_levels
)
) |>
group_by(Willingness, Reason) |>
summarise(
n = sum(selected),
denominator = n(),
pct = weighted_mean_safe(
selected,
analysis_weight
),
.groups = "drop"
) |>
mutate(
Reason_plot = str_wrap(Reason, width = 34)
)
buying_reason_pay_more_extreme <-
buying_reason_pay_more_summary |>
slice_max(pct, n = 1, with_ties = FALSE)
if (!requireNamespace("nnet", quietly = TRUE)) {
stop("Install the 'nnet' package before rendering this section.")
}
buying_reason_wtp_model_data <- df |>
transmute(
willingness = factor(
as.character(`Pay more`),
levels = willingness_to_pay_levels,
ordered = FALSE
),
affordability = as.integer(
is_selected(`They are more affordable`)
),
promotions = as.integer(
is_selected(`Promotions or special deals`)
),
analysis_weight
) |>
drop_na()
buying_reason_wtp_fit_object <- fit_survey_multinomial(
willingness ~ affordability + promotions,
data = buying_reason_wtp_model_data
)
buying_reason_wtp_model <- buying_reason_wtp_fit_object$model
buying_reason_wtp_vcov <- buying_reason_wtp_fit_object$vcov
buying_reason_wtp_fit <- survey_multinomial_joint_test(
buying_reason_wtp_model,
buying_reason_wtp_vcov
) |>
mutate(
N = nrow(buying_reason_wtp_model_data),
.before = 1
)
buying_reason_wtp_predictor_tests <-
survey_multinomial_term_tests(
buying_reason_wtp_model,
buying_reason_wtp_vcov,
c("affordability", "promotions")
) |>
mutate(
Predictor = recode(
term,
affordability = "Affordability",
promotions = "Promotions or special deals"
)
) |>
select(Predictor, Wald, df, p_value)
average_buying_reason_wtp_probabilities <- function(
variable,
value
) {
new_data <- buying_reason_wtp_model_data
new_data[[variable]] <- value
predictions <- predict(
buying_reason_wtp_model,
newdata = new_data,
type = "probs"
)
colSums(
predictions *
buying_reason_wtp_model_data$analysis_weight
) / sum(buying_reason_wtp_model_data$analysis_weight)
}
buying_reason_wtp_effects <- imap_dfr(
c(
affordability = "Affordability",
promotions = "Promotions or special deals"
),
function(label, variable) {
difference <-
average_buying_reason_wtp_probabilities(variable, 1) -
average_buying_reason_wtp_probabilities(variable, 0)
tibble(
Predictor = label,
Willingness = names(difference),
probability_difference = as.numeric(difference)
)
}
)
affordability_some_effect <- buying_reason_wtp_effects |>
filter(
Predictor == "Affordability",
Willingness == "Yes, for some of them"
) |>
pull(probability_difference)
affordability_all_effect <- buying_reason_wtp_effects |>
filter(
Predictor == "Affordability",
Willingness == "Yes, for all of them"
) |>
pull(probability_difference)Is there a link between the reasons respondents have to buy fast tech and their willingness to pay more for a more durable device?
Affordability is the clearest factor. People who mention low prices as a reason for buying fast tech are 6.8% more likely to say they would pay more for only some longer-lasting devices, and 3.8% less likely to say they would pay more for all of them. Promotions do not show a clear link once affordability is taken into account.
Show R code
buying_reason_pay_more_summary |>
ggplot(aes(
x = Willingness,
y = fct_rev(factor(
Reason_plot,
levels = unique(str_wrap(
buying_reason_cols,
width = 34
))
)),
fill = pct
)) +
geom_tile(
colour = bg_surface,
linewidth = bg_lw_hairline
) +
geom_text(
aes(label = percent(pct, accuracy = 0.1)),
size = (bg_size_label - 1) / .pt,
colour = bg_ink
) +
scale_fill_gradient(
low = bg_accent_20,
high = bg_accent,
guide = "none"
) +
labs(x = NULL, y = NULL) +
theme(
axis.text.x = element_text(angle = 25, hjust = 1),
panel.grid = element_blank(),
legend.position = "none"
)
How to read: 58.2% of respondents answering ‘Yes, for some of them’ selected ‘They are more affordable’.
NoteShow tables and assumptions
The model distinguishes the four willingness responses. The bars show how each buying reason is linked with each response. These links do not prove that one causes the other.
Show R code
buying_reason_wtp_fit |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_integer(columns = c(N, df)) |>
fmt_number(
columns = Wald,
decimals = 3
) |>
cols_label(
Wald = "Overall test",
p_value = "p-value"
) |>
gt_bellegarde()| N | Overall test | df | p-value |
|---|---|---|---|
| 9,154 | 46.058 | 6 | <0.001 |
Show R code
buying_reason_wtp_predictor_tests |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_number(columns = Wald, decimals = 2) |>
cols_label(
Wald = "Overall test",
p_value = "p-value"
) |>
gt_bellegarde()| Predictor | Overall test | df | p-value |
|---|---|---|---|
| Affordability | 38.67 | 3 | <0.001 |
| Promotions or special deals | 6.09 | 3 | 0.11 |
Show R code
buying_reason_wtp_effects |>
gt(groupname_col = "Predictor") |>
fmt_percent(
columns = probability_difference,
decimals = 1
) |>
cols_label(
probability_difference = "Probability difference"
) |>
gt_bellegarde()| Willingness | Probability difference |
|---|---|
| Affordability | |
| No | 0.2% |
| Yes, for some of them | 6.8% |
| Yes, for most of them | −3.2% |
| Yes, for all of them | −3.8% |
| Promotions or special deals | |
| No | −1.7% |
| Yes, for some of them | 2.8% |
| Yes, for most of them | 0.4% |
| Yes, for all of them | −1.4% |
Note: Q10 allowed multiple responses, percentages within a column therefore do not sum to 100%.
1.7 Purchase channel and reasons for buying
Show R code
channel_reason_categories <- c(
"Charging & lighting devices",
"High-tech",
"Gadgets & lifestyle items"
)
channel_reason_labels <- c(
"For work, study or everyday use",
"As a temporary replacement",
"I wanted a newer version",
"As a spare device",
"I bought it even though I didn't really need it",
"It was a gift for someone else",
"There was no other product / no other choice"
)
channel_reason_reason_plot_labels <- c(
"For work, study or everyday use" = "Everyday use",
"As a temporary replacement" = "Temporary replacement",
"I wanted a newer version" = "Newer version",
"As a spare device" = "Spare device",
"I bought it even though I didn't really need it" =
"Bought without need",
"It was a gift for someone else" = "Gift for someone else",
"There was no other product / no other choice" =
"No other choice"
)
channel_reason_columns <- unlist(
lapply(
channel_reason_categories,
\(category) paste0(
category,
"_",
channel_reason_labels
)
),
use.names = FALSE
)
channel_reason_channel_labels <- c(
"On the brand’s website",
"Online stores, marketplaces, social media",
"Tobacconist, convenience store",
"Physical stores, outdoor stall, market store",
"At the airport or a train station",
"As gifts, professional giveaways or merch",
"Second hand platform"
)
channel_reason_channel_plot_labels <- c(
"On the brand’s website" = "Brand website",
"Online stores, marketplaces, social media" =
"Online / marketplaces / social media",
"Tobacconist, convenience store" =
"Tobacconist / convenience store",
"Physical stores, outdoor stall, market store" =
"Physical stores / stalls / markets",
"At the airport or a train station" =
"Airport / train station",
"As gifts, professional giveaways or merch" =
"Gifts / giveaways / merch",
"Second hand platform" = "Second-hand platform"
)
channel_reason_responses <- df |>
mutate(respondent_id = row_number()) |>
select(
respondent_id,
analysis_weight,
all_of(channel_reason_columns)
) |>
pivot_longer(
cols = all_of(channel_reason_columns),
names_to = "Variable",
values_to = "Value"
) |>
mutate(
Reason = str_remove(Variable, "^[^_]+_"),
reason_presented = !is.na(Value),
reason_selected = is_selected(Value)
) |>
group_by(
respondent_id,
Reason
) |>
summarise(
analysis_weight = first(analysis_weight),
reason_presented = any(reason_presented),
reason_selected = any(reason_selected),
.groups = "drop"
) |>
filter(
reason_presented,
Reason %in% channel_reason_labels
)
channel_reason_channel_responses <- df |>
mutate(respondent_id = row_number()) |>
select(
respondent_id,
all_of(channel_reason_channel_labels)
) |>
pivot_longer(
cols = all_of(channel_reason_channel_labels),
names_to = "Channel",
values_to = "Value"
) |>
filter(!is.na(Value)) |>
transmute(
respondent_id,
Channel,
channel_selected = is_selected(Value)
)
channel_reason_analysis_data <- channel_reason_responses |>
inner_join(
channel_reason_channel_responses,
by = "respondent_id"
)
channel_reason_overall <- channel_reason_analysis_data |>
distinct(
respondent_id,
Reason,
.keep_all = TRUE
) |>
group_by(Reason) |>
summarise(
overall_pct = weighted_mean_safe(
reason_selected,
analysis_weight
),
.groups = "drop"
)
channel_reason_summary <- channel_reason_analysis_data |>
filter(channel_selected) |>
group_by(
Channel,
Reason
) |>
summarise(
n = n(),
pct = weighted_mean_safe(
reason_selected,
analysis_weight
),
.groups = "drop"
) |>
left_join(
channel_reason_overall,
by = "Reason"
) |>
mutate(
difference = pct - overall_pct,
Channel_plot = str_wrap(
unname(channel_reason_channel_plot_labels[Channel]),
width = 18
),
Reason_plot = str_wrap(
unname(channel_reason_reason_plot_labels[Reason]),
width = 18
)
)
channel_reason_difference_limit <- max(
abs(channel_reason_summary$difference)
)
channel_reason_key <- channel_reason_summary |>
slice_max(
abs(difference),
n = 1,
with_ties = FALSE
)
channel_reason_n <- channel_reason_analysis_data |>
distinct(respondent_id) |>
nrow()This comparison combines Q8b/Q9b across the three non-vape fast tech categories. A reason is counted once per respondent, even if it was selected for more than one category. The clearest difference is among respondents who selected “As gifts, professional giveaways or merch” as a usual channel: 44.7% also selected “I bought it even though I didn’t really need it” for at least one category, 22.0 percentage points above the overall share.
Show R code
channel_reason_summary |>
mutate(
Channel_plot = factor(
Channel_plot,
levels = str_wrap(
unname(channel_reason_channel_plot_labels),
width = 18
)
),
Reason_plot = factor(
Reason_plot,
levels = str_wrap(
unname(channel_reason_reason_plot_labels),
width = 18
)
)
) |>
ggplot(aes(
x = Reason_plot,
y = fct_rev(Channel_plot),
fill = difference
)) +
geom_tile(
colour = bg_surface,
linewidth = bg_lw_hairline
) +
geom_text(
aes(label = percent(pct, accuracy = 1)),
size = (bg_size_label - 1) / .pt,
colour = bg_ink
) +
scale_fill_gradient2(
low = bg_pink,
mid = bg_surface,
high = bg_accent,
midpoint = 0,
limits = c(
-channel_reason_difference_limit,
channel_reason_difference_limit
),
breaks = c(-0.2, 0, 0.2),
labels = label_percent(accuracy = 1),
name = "Difference\nfrom overall"
) +
labs(
x = NULL,
y = NULL
) +
theme(
axis.text.x = element_text(
angle = 25,
hjust = 1,
lineheight = 0.9
),
panel.grid = element_blank(),
legend.position = "top"
)
How to read: 44.7% of respondents selecting ‘As gifts, professional giveaways or merch’ also selected ‘I bought it even though I didn’t really need it’ for at least one category.
The percentages show the share of respondents using each channel who selected each reason for at least one category. The colour compares that percentage with the overall share for the same reason. Both questions allowed multiple responses, so the cells show co-occurrence rather than exclusive pathways. The analysis includes 8,205 respondents with both sets of answers.
1.8 Shortest duration details
Show R code
shortest_duration_levels <- c(
"I got rid of it without ever using it",
"Single-use",
"Less than a week",
"Less than a month",
"1 to 6 months",
"6 to 12 months",
"12 months or more"
)
shortest_duration_age_data <- df |>
transmute(
Age_group = factor(
as.character(Age_recoded_1),
levels = sociodemographic_age_levels
),
Duration = factor(
as.character(Shortest_used),
levels = shortest_duration_levels,
ordered = TRUE
),
analysis_weight
) |>
drop_na()
shortest_duration_age_summary <-
shortest_duration_age_data |>
group_by(
Age_group,
Duration,
.drop = FALSE
) |>
summarise(
n = n(),
weighted_n = sum(analysis_weight),
.groups = "drop_last"
) |>
mutate(
pct = weighted_n / sum(weighted_n)
) |>
ungroup()
shortest_duration_under_six_by_age <-
shortest_duration_age_data |>
mutate(
no_more_than_six_months =
as.integer(Duration) <= 5
) |>
group_by(Age_group) |>
summarise(
n = n(),
pct = weighted_mean_safe(
no_more_than_six_months,
analysis_weight
),
.groups = "drop"
)
shortest_duration_young_pct <-
shortest_duration_under_six_by_age |>
filter(Age_group == "18-29") |>
pull(pct)
shortest_duration_old_pct <-
shortest_duration_under_six_by_age |>
filter(Age_group == "65-99") |>
pull(pct)
shortest_duration_age_test <- survey::svychisq(
~Age_group + Duration,
design = make_analysis_design(
shortest_duration_age_data
),
statistic = "F"
)Short recalled durations are more frequent among younger respondents. 80.1% of those aged 18–29 report that their shortest-lived device was used for no more than six months, compared with 55.7% of those aged 65–99. The full distribution differs by age group (p < .001).
Show R code
shortest_duration_age_summary |>
ggplot(aes(
x = Duration,
y = fct_rev(Age_group),
fill = pct
)) +
geom_tile(
colour = bg_surface,
linewidth = 1
) +
geom_text(
aes(label = percent(pct, accuracy = 0.1)),
colour = bg_ink,
size = (bg_size_label - 1) / .pt
) +
scale_fill_bg_c(
palette = "seq",
labels = percent_format(),
name = "% within age group"
) +
scale_x_discrete(
labels = \(x) str_wrap(x, width = 17)
) +
labs(
x = "Shortest recalled duration of use",
y = "Age group"
) +
theme(
axis.text.x = element_text(
angle = 30,
hjust = 1
),
panel.grid = element_blank(),
legend.position = "top"
)
How to read: 80.1% of respondents aged 18–29 recalled using their shortest-lived device for no more than six months, compared with 55.7% of those aged 65–99.
This result describes each respondent’s shortest recalled experience, not the average lifespan of all their devices. Differences between age groups can also reflect different purchasing histories and recall, so they should not be interpreted as an effect of age alone.
1.9 End-of-life disposal and purchasing volume
Quite logically, end-of-life disposal follows purchasing volume. Respondents reporting more purchases also tend to report more disposal (correlation = 0.57).
Show R code
purchase_disposal_plot_data |>
ggplot(aes(
x = purchased_count,
y = disposed_count
)) +
geom_ribbon(
data = purchase_disposal_gap_data,
aes(
x = purchased_count,
ymin = lower,
ymax = upper
),
inherit.aes = FALSE,
fill = bg_accent_20,
alpha = 0.55
) +
geom_abline(
intercept = 0,
slope = 1,
colour = bg_pink,
linetype = "dashed",
linewidth = bg_lw_line
) +
geom_jitter(
width = 0.55,
height = 0.55,
alpha = 0.16,
size = 1.2,
colour = bg_accent
) +
geom_smooth(
data = purchase_disposal_plot_eligible,
method = "loess",
formula = y ~ x,
span = 0.8,
se = FALSE,
colour = bg_accent,
linewidth = bg_lw_line
) +
scale_x_continuous(
breaks = pretty_breaks(n = 6),
expand = expansion(mult = c(0, 0.01))
) +
scale_y_continuous(
breaks = pretty_breaks(n = 6),
expand = expansion(mult = c(0, 0.01))
) +
coord_cartesian(
xlim = c(
0,
purchase_disposal_plot_limits[["purchased"]]
),
ylim = c(
0,
purchase_disposal_plot_limits[["disposed"]]
)
) +
labs(
x = "Estimated number purchased",
y = "Estimated number disposed of"
) +
theme(
legend.position = "none"
)
How to read: Respondents reporting about 15 items recently bought reported a little less than 10 devices disposed of during the past 12 months
1.10 Disposal habits by country
End-of-life methods differ clearly between countries. Taking devices to a recycling centre ranges from Greece (16.8%) to Norway (47.6%).
Disposal in general household waste ranges from Poland (14.3%) to UK (35.5%).
NoteShow country-difference tests
The tests compare how often each method is selected in the 12 countries. They do not show which pairs of countries differ.
Show R code
country_disposal_tests |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_number(
columns = c(F, df_num, df_den),
decimals = 1
) |>
cols_label(
F = "Overall test",
df_num = "df₁",
df_den = "df₂",
p_value = "p-value"
) |>
gt_bellegarde()| Method | Overall test | df₁ | df₂ | p-value |
|---|---|---|---|---|
| Recycling centre | 18.5 | 5.6 | 51,499.4 | <0.001 |
| Household waste | 24.5 | 5.6 | 51,438.8 | <0.001 |
Show R code
country_disposal_method_summary |>
mutate(
Country = factor(
Country,
levels = sort(unique(Country))
),
Method = factor(
Method,
levels = rev(country_disposal_method_levels)
),
Method_plot = factor(
str_wrap(
as.character(Method),
width = 42
),
levels = str_wrap(
rev(country_disposal_method_levels),
width = 42
)
)
) |>
ggplot(aes(
x = Country,
y = Method_plot,
fill = method_type,
alpha = pct
)) +
geom_tile(
colour = bg_surface,
linewidth = bg_lw_hairline
) +
geom_text(
aes(label = percent(pct, accuracy = 0.1)),
colour = bg_ink,
alpha = 1,
size = (bg_size_label - 1) / .pt,
show.legend = FALSE
) +
scale_fill_manual(
name = NULL,
values = c(
"Recycling or reuse" = bg_accent,
"Waste disposal" = bg_pink,
"Kept, other or unknown" = bg_ink_32
),
guide = "none"
) +
scale_alpha_continuous(
range = c(0.2, 1),
labels = percent_format(),
name = "% selecting"
) +
guides(
alpha = guide_legend(
order = 1,
nrow = 1
)
) +
labs(
x = NULL,
y = NULL
) +
theme(
axis.text.x = element_text(
angle = 45,
hjust = 1
),
panel.grid = element_blank(),
legend.position = "top",
legend.box = "vertical"
)
How to read: 47.6% of eligible respondents in Norway reported taking devices to a recycling centre.
2 Behavioural models
Show R code
model_country_levels <- sort(
unique(df$Country[!is.na(df$Country)])
)
figure_caption <- function(title, reading_key) {
paste0(
title,
"<br><span class='figure-key'><strong>How to read:</strong> ",
reading_key,
"</span>"
)
}
coefficient_term_label <- function(term) {
case_when(
term == "attitude_z" ~ "Attitude towards buying (1 SD)",
term == "injunctive_z" ~ "Injunctive norm (1 SD)",
term == "dynamic_z" ~ "Dynamic norm (1 SD)",
term == "buy_fewer_z" ~ "Support for buying fewer (1 SD)",
term == "regulation_z" ~ "Support for regulation (1 SD)",
term == "satisfaction_z" ~ "Device satisfaction (1 SD)",
term == "age_z" ~ "Age (1 SD)",
str_starts(term, "expected_lifespan") ~ paste0(
"Expected lifespan: ",
str_remove(term, "^expected_lifespan")
),
str_starts(term, "comparison_lifespan") ~ paste0(
"Lifespan compared with alternatives: ",
str_remove(term, "^comparison_lifespan")
),
str_starts(term, "gender") ~ paste0(
"Gender: ",
str_remove(term, "^gender")
),
TRUE ~ str_replace_all(term, "_", " ") |>
str_to_sentence()
)
}
model_coefficient_data <- function(
model,
robust_vcov = NULL,
pathway = NULL
) {
estimates <- coef(model)
if (is.matrix(estimates)) {
survey_estimates <- attr(
robust_vcov,
"survey_coef"
)
if (!is.null(survey_estimates)) {
estimates <- matrix(
survey_estimates,
nrow = nrow(estimates),
ncol = ncol(estimates),
byrow = TRUE,
dimnames = dimnames(estimates)
)
}
if (is.null(robust_vcov)) {
standard_errors <- summary(model)$standard.errors
} else {
standard_errors <- matrix(
sqrt(diag(robust_vcov)),
nrow = nrow(estimates),
ncol = ncol(estimates),
byrow = TRUE,
dimnames = dimnames(estimates)
)
}
result <- as.data.frame(as.table(estimates)) |>
as_tibble() |>
rename(
Outcome = Var1,
term = Var2,
beta = Freq
) |>
mutate(
standard_error = as.vector(standard_errors)
)
} else {
covariance <- robust_vcov %||% vcov(model)
result <- tibble(
term = names(estimates),
beta = as.numeric(estimates),
standard_error = sqrt(diag(covariance))
)
}
result |>
filter(
term != "(Intercept)",
!str_starts(term, "country")
) |>
mutate(
Predictor = map_chr(term, coefficient_term_label),
z = beta / standard_error,
p_value = 2 * pnorm(abs(z), lower.tail = FALSE),
conf_low = beta - qnorm(0.975) * standard_error,
conf_high = beta + qnorm(0.975) * standard_error,
Pathway = pathway,
.before = 1
) |>
select(
any_of(c("Pathway", "Outcome")),
Predictor,
beta,
standard_error,
conf_low,
conf_high,
p_value
)
}
coefficient_gt <- function(data) {
data <- data |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
)
)
group_column <- intersect(
c("Pathway", "Outcome"),
names(data)
) |>
first(default = NA_character_)
table <- if (is.na(group_column)) {
gt(data)
} else {
gt(data, groupname_col = group_column)
}
table |>
fmt_number(
columns = c(beta, standard_error, conf_low, conf_high),
decimals = 3
) |>
cols_label(
beta = "β",
standard_error = "SE",
conf_low = "95% CI low",
conf_high = "95% CI high",
p_value = "p-value"
) |>
cols_width(
Predictor ~ pct(42),
everything() ~ px(92)
) |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Predictor)
) |>
gt_bellegarde()
}
survey_binary_model_fit <- function(
model,
model_name,
model_terms
) {
test <- survey::regTermTest(
model,
reformulate(model_terms),
method = "Wald"
)
tibble(
Model = model_name,
N = nrow(model$survey.design$variables),
Wald = survey_test_statistic(test),
df = as.numeric(test$df),
p_value = as.numeric(test$p),
Pseudo_R2 = survey::psrsq(
model,
method = "Nagelkerke"
)
)
}
survey_multinomial_model_fit <- function(
model,
design_vcov,
model_name,
model_terms
) {
survey_multinomial_joint_test(
model,
design_vcov,
model_terms
) |>
mutate(
Model = model_name,
N = nrow(fitted(model)),
.before = 1
)
}
model_fit_gt <- function(data) {
table <- data |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_integer(columns = N) |>
fmt_number(
columns = any_of(c("Wald", "Pseudo_R2")),
decimals = 3
) |>
fmt_integer(columns = df) |>
cols_label(
Wald = "Overall test",
df = "df",
p_value = "p-value"
)
if ("Pseudo_R2" %in% names(data)) {
table <- table |>
cols_label(Pseudo_R2 = "Model fit")
}
table |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Model)
) |>
gt_bellegarde()
}Note: The following models take country, age and gender into account. They show links between answers, not causes.
2.1 Ever having bought fast tech
Show R code
ever_bought_base <- df |>
transmute(
analysis_weight,
ever_bought = factor(
if_else(
Buyer == "Buyer",
"Buyer",
"Non-buyer"
),
levels = c(
"Non-buyer",
"Buyer"
)
),
attitude = Attitude_buying_recoded,
injunctive = .data[["Injunctive norm_recoded"]],
dynamic = .data[["Dynamic norm_recoded"]],
buy_fewer = .data[["Consumers should buy fewer_recoded"]],
regulation = .data[[
"Governments should more strictly regulate_recoded"
]],
comparison_lifespan = factor(
Comparison_Lifespan,
levels = c(
"Similar lifespan",
"Shorter lifespan",
"Greater lifespan"
)
),
gender = factor(
if_else(
Gender %in% sociodemographic_gender_levels,
Gender,
NA_character_
),
levels = sociodemographic_gender_levels
),
country = factor(
Country,
levels = model_country_levels
),
age = Age
)
ever_model_data <- ever_bought_base |>
select(
ever_bought,
analysis_weight,
attitude,
injunctive,
dynamic,
buy_fewer,
regulation,
comparison_lifespan,
gender,
country,
age
) |>
drop_na() |>
mutate(
attitude_z = weighted_standardize(
attitude,
analysis_weight
),
injunctive_z = weighted_standardize(
injunctive,
analysis_weight
),
dynamic_z = weighted_standardize(
dynamic,
analysis_weight
),
buy_fewer_z = weighted_standardize(
buy_fewer,
analysis_weight
),
regulation_z = weighted_standardize(
regulation,
analysis_weight
),
age_z = weighted_standardize(
age,
analysis_weight
)
)
ever_model <- survey::svyglm(
ever_bought ~
attitude_z +
injunctive_z +
dynamic_z +
buy_fewer_z +
regulation_z +
comparison_lifespan +
gender +
country +
age_z,
design = make_analysis_design(ever_model_data),
family = quasibinomial()
)
survey_wald_term_tests <- function(
model,
terms
) {
map_dfr(
terms,
function(term) {
test <- survey::regTermTest(
model,
reformulate(term),
method = "Wald"
)
tibble(
term,
Wald = survey_test_statistic(test),
df = as.numeric(test$df),
p_value = as.numeric(test$p)
)
}
) |>
mutate(
q_value = p.adjust(
p_value,
method = "BH"
)
)
}
planned_lifespan_contrasts <- function(
model,
model_data,
type = c("response", "probs"),
vcov = NULL
) {
type <- match.arg(type)
lifespan_levels <- c(
"Similar lifespan",
"Shorter lifespan",
"Greater lifespan"
)
lifespan_counts <- tapply(
model_data$analysis_weight,
factor(
model_data$comparison_lifespan,
levels = lifespan_levels
),
sum
)
prediction_grid <- map_dfr(
lifespan_levels,
function(lifespan_level) {
model_data |>
mutate(
comparison_lifespan = factor(
lifespan_level,
levels = lifespan_levels
)
)
}
)
by_variables <- if (type == "probs") {
c("comparison_lifespan", "group")
} else {
"comparison_lifespan"
}
prediction_arguments <- list(
model = model,
newdata = prediction_grid,
by = by_variables,
type = type,
wts = "analysis_weight"
)
if (!is.null(vcov)) {
prediction_arguments$vcov <- vcov
}
predictions <- do.call(
marginaleffects::avg_predictions,
prediction_arguments
)
prediction_data <- predictions |>
as.data.frame() |>
as_tibble() |>
mutate(
prediction_row = row_number()
)
prediction_data$Outcome <- if (
"group" %in% names(prediction_data)
) {
as.character(prediction_data$group)
} else {
"Buyer"
}
prediction_vcov <- stats::vcov(predictions)
outcome_values <- unique(prediction_data$Outcome)
contrast_definitions <- list(
"Shorter vs non-shorter" = c(
"Similar lifespan" =
-lifespan_counts[["Similar lifespan"]] /
sum(lifespan_counts[c(
"Similar lifespan",
"Greater lifespan"
)]),
"Shorter lifespan" = 1,
"Greater lifespan" =
-lifespan_counts[["Greater lifespan"]] /
sum(lifespan_counts[c(
"Similar lifespan",
"Greater lifespan"
)])
),
"Greater vs non-greater" = c(
"Similar lifespan" =
-lifespan_counts[["Similar lifespan"]] /
sum(lifespan_counts[c(
"Similar lifespan",
"Shorter lifespan"
)]),
"Shorter lifespan" =
-lifespan_counts[["Shorter lifespan"]] /
sum(lifespan_counts[c(
"Similar lifespan",
"Shorter lifespan"
)]),
"Greater lifespan" = 1
)
)
contrast_rows <- crossing(
Outcome = outcome_values,
Contrast = names(contrast_definitions)
)
contrast_matrix <- matrix(
0,
nrow = nrow(contrast_rows),
ncol = nrow(prediction_data)
)
for (row_index in seq_len(nrow(contrast_rows))) {
outcome_value <- contrast_rows$Outcome[[row_index]]
contrast_name <- contrast_rows$Contrast[[row_index]]
weights <- contrast_definitions[[contrast_name]]
relevant_rows <- prediction_data |>
filter(Outcome == outcome_value)
contrast_matrix[
row_index,
relevant_rows$prediction_row
] <- weights[
as.character(relevant_rows$comparison_lifespan)
]
}
estimates <- as.numeric(
contrast_matrix %*% prediction_data$estimate
)
standard_errors <- sqrt(diag(
contrast_matrix %*%
prediction_vcov %*%
t(contrast_matrix)
))
contrast_rows |>
mutate(
term = "comparison_lifespan",
estimate = estimates,
std_error = standard_errors,
conf_low = estimate - qnorm(0.975) * std_error,
conf_high = estimate + qnorm(0.975) * std_error,
p_value = 2 * pnorm(
-abs(estimate / std_error)
)
)
}
ever_model_terms <- c(
"attitude_z",
"injunctive_z",
"dynamic_z",
"buy_fewer_z",
"regulation_z",
"comparison_lifespan",
"gender",
"country",
"age_z"
)
ever_term_tests <- survey_wald_term_tests(
ever_model,
ever_model_terms
)
ever_term_labels <- c(
attitude_z = "Attitude towards buying",
injunctive_z = "Injunctive norm",
dynamic_z = "Dynamic norm",
buy_fewer_z = "Support for buying fewer items",
regulation_z = "Support for stricter regulation",
comparison_lifespan = "Lifespan compared with alternatives",
gender = "Gender",
country = "Country",
age_z = "Age"
)
prepare_binary_marginal_effects <- function(
model,
term_tests,
model_data
) {
variables <- term_tests |>
filter(
q_value < 0.05,
!term %in% c(
"gender",
"country",
"age_z"
)
) |>
pull(term)
if (length(variables) == 0) {
return(tibble())
}
marginaleffects::avg_slopes(
model,
variables = variables,
type = "response",
wts = model_data$analysis_weight,
vcov = vcov(model)
) |>
as.data.frame() |>
as_tibble() |>
transmute(
term,
Predictor = if_else(
contrast == "dY/dX",
unname(ever_term_labels[term]),
paste0(
unname(ever_term_labels[term]),
": ",
str_replace(
contrast,
" - ",
" vs "
)
)
),
estimate,
conf_low = conf.low,
conf_high = conf.high
)
}
ever_marginal_effects <- prepare_binary_marginal_effects(
ever_model,
ever_term_tests,
ever_model_data
)
ever_lifespan_contrasts <- planned_lifespan_contrasts(
ever_model,
ever_model_data,
type = "response",
vcov = vcov(ever_model)
) |>
transmute(
term,
Predictor = paste0(
"Lifespan compared with alternatives: ",
Contrast
),
estimate,
conf_low,
conf_high
)
if (ever_term_tests$q_value[
ever_term_tests$term == "comparison_lifespan"
] < 0.05) {
ever_marginal_effects <- bind_rows(
ever_marginal_effects |>
filter(term != "comparison_lifespan"),
ever_lifespan_contrasts
)
} else {
ever_marginal_effects <- ever_marginal_effects |>
filter(term != "comparison_lifespan")
}
ever_attitude_effect <- ever_marginal_effects |>
filter(Predictor == "Attitude towards buying") |>
pull(estimate)
ever_model_overview <- ever_term_tests |>
mutate(
Predictor = unname(
ever_term_labels[term]
)
) |>
select(
Predictor,
Wald,
df,
p_value,
q_value
)
ever_global_fit <- survey_binary_model_fit(
ever_model,
"Ever having bought fast tech",
ever_model_terms
)
maximum_coefficient_vif <- function(model) {
matrix <- model.matrix(model)[
,
-1,
drop = FALSE
]
max(
map_dbl(
seq_len(ncol(matrix)),
function(index) {
focal <- matrix[, index]
others <- matrix[
,
-index,
drop = FALSE
]
auxiliary <- lm.fit(
cbind(intercept = 1, others),
focal
)
r_squared <- 1 -
sum(auxiliary$residuals^2) /
sum((focal - mean(focal))^2)
1 / (1 - r_squared)
}
)
)
}
ever_diagnostics <- tibble(
Check = c(
"Complete-case sample",
"Convergence",
"Maximum coefficient-level VIF",
"Smallest response group",
"Finite estimates"
),
Result = c(
format_count(nrow(ever_model_data)),
if_else(ever_model$converged, "Passed", "Failed"),
number(
maximum_coefficient_vif(ever_model),
accuracy = 0.01
),
format_count(
min(table(ever_model_data$ever_bought))
),
if_else(
all(
is.finite(coef(ever_model)),
is.finite(vcov(ever_model))
),
"Passed",
"Failed"
)
)
)This model estimates how attitudes, norms, lifespan perceptions and socio-demographic characteristics distinguish buyers from non-buyers. The chart expresses the results as changes in probability, so a value of +5% means an average increase of five percentage points in the probability of having bought fast tech.
NoteShow tables and assumptions
Show R code
ever_global_fit |>
model_fit_gt()| Model | N | Overall test | df | p-value | Model fit |
|---|---|---|---|---|---|
| Ever having bought fast tech | 10,182 | 26.245 | 21 | <0.001 | 0.238 |
Show R code
ever_model_overview |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
),
q_value = format.pval(
q_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_number(
columns = Wald,
decimals = 1
) |>
cols_label(
Wald = "Overall test",
df = "df",
p_value = "p-value",
q_value = "Corrected p"
) |>
cols_width(
Predictor ~ pct(48),
Wald ~ px(105)
) |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Predictor)
) |>
gt_bellegarde()| Predictor | Overall test | df | p-value | Corrected p |
|---|---|---|---|---|
| Attitude towards buying | 70.5 | 1 | <0.001 | <0.001 |
| Injunctive norm | 18.1 | 1 | <0.001 | <0.001 |
| Dynamic norm | 3.4 | 1 | 0.067 | 0.086 |
| Support for buying fewer items | 0.3 | 1 | 0.609 | 0.686 |
| Support for stricter regulation | 0.1 | 1 | 0.768 | 0.768 |
| Lifespan compared with alternatives | 2.8 | 2 | 0.060 | 0.086 |
| Gender | 7.5 | 2 | <0.001 | 0.001 |
| Country | 6.9 | 11 | <0.001 | <0.001 |
| Age | 171.5 | 1 | <0.001 | <0.001 |
Coefficients are on the logistic scale. Country coefficients are included in the model but omitted from the table to keep the substantive predictors readable.
Show R code
model_coefficient_data(ever_model) |>
coefficient_gt()| Predictor | β | SE | 95% CI low | 95% CI high | p-value |
|---|---|---|---|---|---|
| Attitude towards buying (1 SD) | 0.590 | 0.070 | 0.453 | 0.728 | <0.001 |
| Injunctive norm (1 SD) | 0.256 | 0.060 | 0.138 | 0.374 | <0.001 |
| Dynamic norm (1 SD) | 0.090 | 0.049 | −0.006 | 0.187 | 0.067 |
| Support for buying fewer (1 SD) | −0.031 | 0.061 | −0.151 | 0.088 | 0.609 |
| Support for regulation (1 SD) | −0.017 | 0.059 | −0.133 | 0.098 | 0.768 |
| Lifespan compared with alternatives: Shorter lifespan | −0.051 | 0.112 | −0.271 | 0.168 | 0.645 |
| Lifespan compared with alternatives: Greater lifespan | −0.498 | 0.211 | −0.912 | −0.084 | 0.019 |
| Gender: Male | 0.335 | 0.101 | 0.137 | 0.532 | <0.001 |
| Gender: Non-binary | 1.631 | 0.736 | 0.189 | 3.073 | 0.027 |
| Age (1 SD) | −0.705 | 0.054 | −0.810 | −0.599 | <0.001 |
The model uses one record per respondent. For scored questions, it follows the overall rise or fall in answers.
Show R code
ever_diagnostics |>
gt() |>
gt_bellegarde()| Check | Result |
|---|---|
| Complete-case sample | 10,182 |
| Convergence | Passed |
| Maximum coefficient-level VIF | 1.71 |
| Smallest response group | 1,084 |
| Finite estimates | Passed |
Show R code
ever_marginal_effects |>
mutate(
Predictor = fct_reorder(
str_wrap(Predictor, 38),
estimate
)
) |>
ggplot(aes(
x = estimate,
y = Predictor
)) +
geom_vline(
xintercept = 0,
colour = bg_ink_32,
linewidth = bg_lw_hairline,
linetype = "dashed"
) +
geom_errorbar(
aes(
xmin = conf_low,
xmax = conf_high
),
orientation = "y",
width = 0,
linewidth = bg_lw_line,
colour = bg_pink
) +
geom_point(
size = bg_size_label / .pt,
colour = bg_pink
) +
scale_x_continuous(
labels = label_percent(
accuracy = 0.1,
style_positive = "plus"
)
) +
labs(
x = "Average change in probability of being a buyer",
y = NULL
)
How to read: A more favourable buying attitude is linked with a +5.4% difference in the probability of having bought fast tech.
Note: Product satisfaction and expected lifespan are not included, since they were asked only of previous buyers. For scored questions, each bar shows a typical increase. Only the clearest factors are shown. The model does not establish cause and effect.
Top 3 factors
- Attitude towards buying. The more favourable respondents’ attitudes towards buying fast tech devices, the more likely they are to have bought them.
- Age. Younger people are more likely to have bought fast tech.
- Perceived approval. People who feel that those close to them approve of fast tech are more likely to have bought it.
2.1.1 Behavioural path model
Show R code
if (!requireNamespace("lavaan", quietly = TRUE)) {
stop("Install the 'lavaan' package before rendering this section.")
}
behavioural_path_base <- ever_model_data |>
mutate(
ever_bought = ordered(
ever_bought,
levels = c("Non-buyer", "Buyer")
),
shorter_lifespan = as.numeric(
comparison_lifespan == "Shorter lifespan"
),
greater_lifespan = as.numeric(
comparison_lifespan == "Greater lifespan"
)
)
behavioural_path_controls <- model.matrix(
~ gender + country,
data = behavioural_path_base
)[, -1, drop = FALSE]
colnames(behavioural_path_controls) <- make.names(
colnames(behavioural_path_controls),
unique = TRUE
)
behavioural_path_data <- bind_cols(
behavioural_path_base,
as_tibble(behavioural_path_controls)
)
behavioural_path_control_terms <- colnames(
behavioural_path_controls
)
behavioural_path_model_syntax <- paste0(
"attitude_z ~ injunctive_z + dynamic_z + buy_fewer_z + ",
"regulation_z + shorter_lifespan + greater_lifespan + age_z + ",
paste(behavioural_path_control_terms, collapse = " + "),
"\n",
"ever_bought ~ attitude_z + injunctive_z + greater_lifespan + age_z + ",
paste(behavioural_path_control_terms, collapse = " + ")
)
behavioural_path_model <- lavaan::sem(
model = behavioural_path_model_syntax,
data = behavioural_path_data,
ordered = "ever_bought",
estimator = "WLSMV",
sampling.weights = "analysis_weight",
std.lv = TRUE
)
behavioural_path_fit <- lavaan::fitMeasures(
behavioural_path_model,
c("cfi", "tli", "rmsea", "srmr")
)
behavioural_path_labels <- c(
injunctive_z = "Perceived approval",
dynamic_z = "Dynamic norm",
buy_fewer_z = "Support for buying fewer",
regulation_z = "Support for regulation",
shorter_lifespan = "Shorter lifespan",
greater_lifespan = "Greater lifespan",
age_z = "Age (+1 SD)",
attitude_z = "Buying attitude",
ever_bought = "Ever bought fast tech"
)
behavioural_path_estimates <-
lavaan::standardizedSolution(behavioural_path_model) |>
as_tibble() |>
filter(
op == "~",
lhs %in% c("attitude_z", "ever_bought"),
rhs %in% names(behavioural_path_labels)
) |>
transmute(
Outcome = unname(behavioural_path_labels[lhs]),
Predictor = unname(behavioural_path_labels[rhs]),
from = rhs,
to = lhs,
beta = est.std,
standard_error = se,
p_value = pvalue,
Direction = if_else(beta >= 0, "Positive", "Negative")
)
behavioural_path_age_effect <- marginaleffects::avg_slopes(
ever_model,
variables = "age_z",
type = "response",
wts = ever_model_data$analysis_weight,
vcov = vcov(ever_model)
) |>
as.data.frame() |>
as_tibble() |>
transmute(
from = "age_z",
probability_difference = estimate,
conf_low = conf.low,
conf_high = conf.high
)
behavioural_path_purchase_effects <- bind_rows(
ever_marginal_effects |>
filter(Predictor == "Attitude towards buying") |>
transmute(
from = "attitude_z",
probability_difference = estimate,
conf_low,
conf_high
),
ever_marginal_effects |>
filter(Predictor == "Injunctive norm") |>
transmute(
from = "injunctive_z",
probability_difference = estimate,
conf_low,
conf_high
),
ever_marginal_effects |>
filter(str_detect(Predictor, "Greater vs")) |>
transmute(
from = "greater_lifespan",
probability_difference = estimate,
conf_low,
conf_high
),
behavioural_path_age_effect
)
behavioural_path_plot_data <- bind_rows(
behavioural_path_estimates |>
filter(to == "attitude_z") |>
transmute(
Stage = "Buying attitude\nEffect in standard deviations",
Predictor,
effect = beta,
conf_low = beta - 1.96 * standard_error,
conf_high = beta + 1.96 * standard_error,
Direction = if_else(effect >= 0, "Positive", "Negative"),
display_label = paste0(
number(
effect,
accuracy = 0.01,
style_positive = "plus"
),
" SD"
)
),
behavioural_path_purchase_effects |>
transmute(
Stage = "Ever bought fast tech\nEffect in percentage points",
Predictor = unname(behavioural_path_labels[from]),
effect = probability_difference * 100,
conf_low = conf_low * 100,
conf_high = conf_high * 100,
Direction = if_else(effect >= 0, "Positive", "Negative"),
display_label = paste0(
number(
effect,
accuracy = 0.1,
style_positive = "plus"
),
" pp"
)
)
)
path_attitude_purchase_effect <-
behavioural_path_purchase_effects |>
filter(from == "attitude_z") |>
pull(probability_difference)Perceived approval has the strongest link with buying attitude. People who feel stronger approval also tend to view fast tech more favourably. A typical increase in buying attitude is linked with a +5.4% difference in the probability of having bought fast tech.
Show R code
behavioural_path_plot_data |>
mutate(
Predictor = fct_reorder(
str_wrap(Predictor, 28),
effect
)
) |>
ggplot(aes(
x = effect,
y = Predictor,
colour = Direction
)) +
geom_vline(
xintercept = 0,
colour = bg_ink_32,
linewidth = bg_lw_hairline,
linetype = "dashed"
) +
geom_errorbarh(
aes(xmin = conf_low, xmax = conf_high),
height = 0,
linewidth = bg_lw_line
) +
geom_point(size = bg_point_size) +
geom_text(
aes(
label = display_label,
hjust = if_else(effect >= 0, -0.18, 1.18)
),
colour = bg_ink,
size = bg_size_label / .pt,
show.legend = FALSE
) +
scale_colour_manual(
values = c(
Positive = bg_accent,
Negative = bg_pink
),
guide = "none"
) +
facet_wrap(
~Stage,
ncol = 1,
scales = "free"
) +
scale_x_continuous(
labels = label_number(
accuracy = 0.1,
style_positive = "plus"
),
expand = expansion(mult = c(0.18, 0.22))
) +
labs(
x = "Strength of link",
y = NULL
) +
theme(
panel.spacing.y = grid::unit(bg_margin_pt, "pt"),
strip.text = element_text(face = "bold")
)
How to read: A typical increase in buying attitude corresponds to a +5.4% difference in the probability of having bought fast tech.
NoteShow tables and assumptions
Arrows ending at buying attitude show the relative strength of each link. Arrows ending at purchase show average differences in probability.
Show R code
behavioural_path_estimates |>
select(
Outcome,
Predictor,
beta,
standard_error,
p_value
) |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
)
) |>
gt(groupname_col = "Outcome") |>
fmt_number(
columns = c(beta, standard_error),
decimals = 3
) |>
cols_label(
beta = "Standardised β",
standard_error = "SE",
p_value = "p-value"
) |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Predictor)
) |>
gt_bellegarde()| Predictor | Standardised β | SE | p-value |
|---|---|---|---|
| Buying attitude | |||
| Perceived approval | 0.500 | 0.007 | <0.001 |
| Dynamic norm | 0.113 | 0.009 | <0.001 |
| Support for buying fewer | −0.106 | 0.011 | <0.001 |
| Support for regulation | −0.088 | 0.011 | <0.001 |
| Shorter lifespan | −0.138 | 0.012 | <0.001 |
| Greater lifespan | 0.046 | 0.009 | <0.001 |
| Age (+1 SD) | −0.030 | 0.011 | 0.0066 |
| Ever bought fast tech | |||
| Buying attitude | 0.266 | 0.025 | <0.001 |
| Perceived approval | 0.118 | 0.028 | <0.001 |
| Greater lifespan | −0.066 | 0.025 | 0.0077 |
| Age (+1 SD) | −0.320 | 0.023 | <0.001 |
The path model uses the same complete records as the buying model. Country and gender are included but omitted from the diagram. This is an exploratory view: the data cannot show which factor causes another.
2.2 Perception & willingness
2.2.1 Willingness to pay more for longer-lasting alternatives
Show R code
required_packages <- c(
"nnet",
"marginaleffects"
)
missing_packages <- required_packages[
!vapply(
required_packages,
requireNamespace,
logical(1),
quietly = TRUE
)
]
if (length(missing_packages) > 0) {
stop(
"Install before rendering: ",
paste(missing_packages, collapse = ", ")
)
}
behavioural_predictor_data <- df |>
transmute(
respondent_id = row_number(),
analysis_weight,
satisfaction = Satisfaction_recoded,
expected_lifespan = factor(
Global_Lifespan,
levels = c(
"Expected lifespan",
"Shorter lifespan",
"Longer lifespan"
)
),
comparison_lifespan = factor(
Comparison_Lifespan,
levels = c(
"Similar lifespan",
"Shorter lifespan",
"Greater lifespan"
)
),
attitude = Attitude_buying_recoded,
injunctive = .data[["Injunctive norm_recoded"]],
dynamic = .data[["Dynamic norm_recoded"]],
buy_fewer = .data[["Consumers should buy fewer_recoded"]],
regulation = .data[[
"Governments should more strictly regulate_recoded"
]],
gender = factor(
if_else(
Gender %in% sociodemographic_gender_levels,
Gender,
NA_character_
),
levels = sociodemographic_gender_levels
),
country = factor(
Country,
levels = model_country_levels
),
age = Age
)
continuous_behavioural_predictors <- c(
"satisfaction",
"attitude",
"injunctive",
"dynamic",
"buy_fewer",
"regulation"
)
behavioural_predictor_names <- c(
"satisfaction",
"expected_lifespan",
"comparison_lifespan",
"attitude",
"injunctive",
"dynamic",
"buy_fewer",
"regulation"
)
behavioural_predictor_labels <- c(
satisfaction_z = "Device satisfaction",
expected_lifespan = "Expected lifespan",
expected_lifespan_longer =
"Expected lifespan",
comparison_lifespan =
"Lifespan compared with alternatives",
attitude_z = "Attitude towards buying",
injunctive_z = "Injunctive norm",
dynamic_z = "Dynamic norm",
buy_fewer_z = "Support for buying fewer items",
regulation_z = "Support for stricter regulation",
gender = "Gender",
country = "Country",
age_z = "Age"
)
build_behavioural_model_terms <- function(variables) {
c(
if_else(
variables %in% continuous_behavioural_predictors,
paste0(variables, "_z"),
variables
),
"gender",
"country",
"age_z"
)
}
prepare_behavioural_model_data <- function(
outcome_data,
outcome_name,
variables = behavioural_predictor_names
) {
outcome_data |>
left_join(
behavioural_predictor_data,
by = "respondent_id"
) |>
select(
all_of(outcome_name),
all_of(variables),
gender,
country,
age,
analysis_weight
) |>
drop_na() |>
mutate(
across(
all_of(intersect(
variables,
continuous_behavioural_predictors
)),
~ weighted_standardize(
.x,
analysis_weight
),
.names = "{.col}_z"
),
age_z = weighted_standardize(
age,
analysis_weight
)
)
}
pay_more_outcome_data <- df |>
transmute(
respondent_id = row_number(),
pay_more = factor(
as.character(.data[["Pay more"]]),
levels = willingness_to_pay_levels,
ordered = FALSE
)
)
pay_more_model_data <- prepare_behavioural_model_data(
pay_more_outcome_data,
"pay_more"
)
pay_more_terms <- build_behavioural_model_terms(
behavioural_predictor_names
)
pay_more_formula <- reformulate(
pay_more_terms,
response = "pay_more"
)
pay_more_fit <- fit_survey_multinomial(
pay_more_formula,
data = pay_more_model_data
)
pay_more_model <- pay_more_fit$model
pay_more_vcov <- pay_more_fit$vcov
pay_more_term_tests <- survey_multinomial_term_tests(
pay_more_model,
pay_more_vcov,
pay_more_terms
)
prepare_multinomial_marginal_effects <- function(
model,
term_tests,
model_data,
design_vcov
) {
variables <- term_tests |>
filter(
q_value < 0.05,
!term %in% c(
"gender",
"country",
"age_z"
)
) |>
pull(term)
marginaleffects::avg_slopes(
model,
variables = variables,
type = "probs",
wts = model_data$analysis_weight,
vcov = design_vcov
) |>
as.data.frame() |>
as_tibble() |>
transmute(
term,
Outcome = factor(
group,
levels = willingness_to_pay_levels,
labels = c(
"No",
"Yes: some",
"Yes: most",
"Yes: all"
)
),
Predictor = if_else(
contrast == "dY/dX",
unname(behavioural_predictor_labels[term]),
paste0(
unname(behavioural_predictor_labels[term]),
": ",
str_replace(
contrast,
" - ",
" vs "
)
)
),
estimate,
conf_low = conf.low,
conf_high = conf.high
)
}
pay_more_marginal_effects <- prepare_multinomial_marginal_effects(
pay_more_model,
pay_more_term_tests,
pay_more_model_data,
pay_more_vcov
)
pay_more_lifespan_contrasts <- planned_lifespan_contrasts(
pay_more_model,
pay_more_model_data,
type = "probs",
vcov = pay_more_vcov
) |>
transmute(
term,
Outcome = factor(
Outcome,
levels = willingness_to_pay_levels,
labels = c(
"No",
"Yes: some",
"Yes: most",
"Yes: all"
)
),
Predictor = paste0(
"Lifespan compared with alternatives: ",
Contrast
),
estimate,
conf_low,
conf_high
)
if (pay_more_term_tests$q_value[
pay_more_term_tests$term == "comparison_lifespan"
] < 0.05) {
pay_more_marginal_effects <- bind_rows(
pay_more_marginal_effects |>
filter(term != "comparison_lifespan"),
pay_more_lifespan_contrasts
)
} else {
pay_more_marginal_effects <- pay_more_marginal_effects |>
filter(term != "comparison_lifespan")
}
diagnostics_for_model <- function(
model,
data,
design_vcov,
outcome,
inference_converged
) {
tibble(
Check = c(
"Convergence",
"Predictor overlap",
"Smallest response group",
"Stable estimates",
"Uncertainty"
),
Result = c(
if_else(
model$convergence == 0 && inference_converged,
"Yes",
"No"
),
paste0(
"Low (",
scales::number(
maximum_coefficient_vif(model),
accuracy = 0.01
),
")"
),
paste0(
format_count(min(table(data[[outcome]]))),
" people"
),
if_else(
all(
is.finite(coef(model)),
is.finite(design_vcov)
),
"Yes",
"No"
),
"Included"
),
Interpretation = c(
"Optimisation completed normally",
"The factors remain distinct",
"Every answer has enough people",
"No numerical warning",
"Ranges show uncertainty around each result"
)
)
}
pay_more_diagnostics <- diagnostics_for_model(
pay_more_model,
pay_more_model_data,
pay_more_vcov,
"pay_more",
pay_more_fit$inference_converged
)
pay_more_model_overview <- pay_more_term_tests |>
mutate(
Predictor = unname(behavioural_predictor_labels[term])
) |>
select(
Predictor,
Wald,
df,
p_value,
q_value
)
pay_more_global_fit <- survey_multinomial_model_fit(
pay_more_model,
pay_more_vcov,
"Willingness to pay more",
pay_more_terms
)This model shows which factors shift respondents between the four willingness-to-pay responses. The chart reports changes in probability for each answer, making the direction and size of those shifts directly readable.
NoteShow tables and assumptions
Show R code
pay_more_global_fit |>
model_fit_gt()| Model | N | Overall test | df | p-value |
|---|---|---|---|---|
| Willingness to pay more | 9,098 | 675.259 | 72 | <0.001 |
Show R code
pay_more_model_overview |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
),
q_value = format.pval(
q_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_number(
columns = Wald,
decimals = 1
) |>
cols_label(
Wald = "Overall test",
df = "df",
p_value = "p-value",
q_value = "Corrected p"
) |>
cols_width(
Predictor ~ pct(48),
Wald ~ px(105)
) |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Predictor)
) |>
gt_bellegarde()| Predictor | Overall test | df | p-value | Corrected p |
|---|---|---|---|---|
| Device satisfaction | 24.9 | 3 | <0.001 | <0.001 |
| Expected lifespan | 40.2 | 6 | <0.001 | <0.001 |
| Lifespan compared with alternatives | 45.0 | 6 | <0.001 | <0.001 |
| Attitude towards buying | 3.9 | 3 | 0.2779 | 0.2779 |
| Injunctive norm | 13.6 | 3 | 0.0035 | 0.0048 |
| Dynamic norm | 12.5 | 3 | 0.0058 | 0.0071 |
| Support for buying fewer items | 25.1 | 3 | <0.001 | <0.001 |
| Support for stricter regulation | 56.1 | 3 | <0.001 | <0.001 |
| Gender | 17.8 | 6 | 0.0069 | 0.0075 |
| Country | 185.7 | 33 | <0.001 | <0.001 |
| Age | 87.2 | 3 | <0.001 | <0.001 |
Each outcome is compared with the model’s reference response. Country coefficients are omitted from display but remain in the model.
Show R code
model_coefficient_data(
pay_more_model,
robust_vcov = pay_more_vcov
) |>
coefficient_gt()| Predictor | β | SE | 95% CI low | 95% CI high | p-value |
|---|---|---|---|---|---|
| Yes, for some of them | |||||
| Device satisfaction (1 SD) | −0.024 | 0.049 | −0.119 | 0.071 | 0.6231 |
| Expected lifespan: Shorter lifespan | 0.023 | 0.113 | −0.198 | 0.243 | 0.8404 |
| Expected lifespan: Longer lifespan | −0.349 | 0.130 | −0.603 | −0.095 | 0.0071 |
| Lifespan compared with alternatives: Shorter lifespan | 0.460 | 0.095 | 0.274 | 0.646 | <0.001 |
| Lifespan compared with alternatives: Greater lifespan | 0.292 | 0.175 | −0.051 | 0.636 | 0.0952 |
| Attitude towards buying (1 SD) | −0.026 | 0.057 | −0.138 | 0.086 | 0.6502 |
| Injunctive norm (1 SD) | 0.028 | 0.053 | −0.076 | 0.131 | 0.6013 |
| Dynamic norm (1 SD) | 0.105 | 0.048 | 0.011 | 0.200 | 0.0283 |
| Support for buying fewer (1 SD) | 0.107 | 0.052 | 0.005 | 0.209 | 0.0389 |
| Support for regulation (1 SD) | 0.171 | 0.049 | 0.075 | 0.266 | <0.001 |
| Gender: Male | −0.014 | 0.083 | −0.177 | 0.149 | 0.8665 |
| Gender: Non-binary | 0.922 | 0.443 | 0.054 | 1.789 | 0.0374 |
| Age (1 SD) | −0.296 | 0.045 | −0.383 | −0.208 | <0.001 |
| Yes, for most of them | |||||
| Device satisfaction (1 SD) | 0.146 | 0.062 | 0.025 | 0.266 | 0.0183 |
| Expected lifespan: Shorter lifespan | 0.276 | 0.136 | 0.009 | 0.544 | 0.0426 |
| Expected lifespan: Longer lifespan | −0.029 | 0.174 | −0.370 | 0.313 | 0.8699 |
| Lifespan compared with alternatives: Shorter lifespan | 0.495 | 0.121 | 0.258 | 0.732 | <0.001 |
| Lifespan compared with alternatives: Greater lifespan | 0.831 | 0.202 | 0.435 | 1.227 | <0.001 |
| Attitude towards buying (1 SD) | −0.120 | 0.070 | −0.257 | 0.017 | 0.0852 |
| Injunctive norm (1 SD) | 0.151 | 0.067 | 0.019 | 0.283 | 0.0246 |
| Dynamic norm (1 SD) | 0.099 | 0.057 | −0.013 | 0.211 | 0.0820 |
| Support for buying fewer (1 SD) | 0.272 | 0.065 | 0.145 | 0.399 | <0.001 |
| Support for regulation (1 SD) | 0.334 | 0.061 | 0.214 | 0.454 | <0.001 |
| Gender: Male | 0.276 | 0.106 | 0.069 | 0.483 | 0.0089 |
| Gender: Non-binary | 0.748 | 0.499 | −0.229 | 1.725 | 0.1335 |
| Age (1 SD) | −0.496 | 0.054 | −0.602 | −0.389 | <0.001 |
| Yes, for all of them | |||||
| Device satisfaction (1 SD) | 0.396 | 0.111 | 0.179 | 0.613 | <0.001 |
| Expected lifespan: Shorter lifespan | 0.800 | 0.198 | 0.412 | 1.189 | <0.001 |
| Expected lifespan: Longer lifespan | 0.731 | 0.240 | 0.260 | 1.202 | 0.0023 |
| Lifespan compared with alternatives: Shorter lifespan | 0.456 | 0.195 | 0.074 | 0.839 | 0.0195 |
| Lifespan compared with alternatives: Greater lifespan | 0.913 | 0.269 | 0.385 | 1.440 | <0.001 |
| Attitude towards buying (1 SD) | −0.051 | 0.113 | −0.272 | 0.171 | 0.6549 |
| Injunctive norm (1 SD) | 0.305 | 0.102 | 0.105 | 0.504 | 0.0027 |
| Dynamic norm (1 SD) | 0.334 | 0.098 | 0.143 | 0.525 | <0.001 |
| Support for buying fewer (1 SD) | 0.402 | 0.110 | 0.187 | 0.617 | <0.001 |
| Support for regulation (1 SD) | 0.697 | 0.108 | 0.486 | 0.908 | <0.001 |
| Gender: Male | 0.232 | 0.166 | −0.092 | 0.557 | 0.1607 |
| Gender: Non-binary | 0.308 | 0.740 | −1.143 | 1.759 | 0.6773 |
| Age (1 SD) | −0.431 | 0.087 | −0.602 | −0.259 | <0.001 |
The model treats the four answers separately. The checks show whether the calculation was stable and whether every answer has enough people.
Show R code
pay_more_diagnostics |>
gt() |>
cols_width(
Check ~ pct(25),
Result ~ pct(22),
Interpretation ~ pct(53)
) |>
gt_bellegarde()| Check | Result | Interpretation |
|---|---|---|
| Convergence | Yes | Optimisation completed normally |
| Predictor overlap | Low (1.70) | The factors remain distinct |
| Smallest response group | 492 people | Every answer has enough people |
| Stable estimates | Yes | No numerical warning |
| Uncertainty | Included | Ranges show uncertainty around each result |
Show R code
pay_more_marginal_effects |>
mutate(
Predictor = fct_reorder(
str_wrap(Predictor, 42),
estimate
)
) |>
ggplot(aes(
x = estimate,
y = Predictor,
colour = Outcome
)) +
geom_vline(
xintercept = 0,
colour = bg_ink_32,
linewidth = bg_lw_hairline,
linetype = "dashed"
) +
geom_errorbar(
aes(
xmin = conf_low,
xmax = conf_high
),
orientation = "y",
position = position_dodge(width = 0.65),
width = 0,
linewidth = bg_lw_line
) +
geom_point(
position = position_dodge(width = 0.65),
size = bg_size_label / .pt
) +
scale_x_continuous(
labels = label_percent(accuracy = 0.1)
) +
scale_colour_manual(
values = c(
"No" = bg_ink_54,
"Yes: some" = bg_accent_20,
"Yes: most" = bg_accent_50,
"Yes: all" = bg_accent
),
name = NULL
) +
labs(
x = "Change in probability",
y = NULL
) +
theme(
legend.position = "top"
)
How to read: Respondents reporting a longer-than-expected lifespan are less likely to say they would pay more for only some devices.
Note: For scored questions, each bar shows a typical increase. The lifespan bars compare shorter with other answers, and greater with other answers. Positive and negative values show how probability moves between the four choices. The model does not establish causality.
Top 3 factors
- Expected lifespan. Respondents expecting a longer lifespan are less likely to say they would pay more for only some devices.
- Lifespan compared with alternatives. Perceiving a greater lifespan is associated with greater willingness to pay more for most devices than not perceiving that advantage.
- Support for stricter regulation. The stronger the support for regulation, the less likely respondents are to reject paying more.
2.3 Willingness to replace a broken fast tech device
Show R code
fit_multinomial_specification <- function(
outcome_data,
outcome_name,
outcome_levels
) {
variables <- behavioural_predictor_names
model_data <- prepare_behavioural_model_data(
outcome_data,
outcome_name,
variables
)
terms <- build_behavioural_model_terms(variables) |>
setdiff("gender")
formula <- reformulate(
terms,
response = outcome_name
)
survey_fit <- fit_survey_multinomial(
formula,
data = model_data
)
model <- survey_fit$model
design_vcov <- survey_fit$vcov
model_tests <- survey_multinomial_term_tests(
model,
design_vcov,
terms
)
marginal_effect_variables <- model_tests |>
filter(
q_value < 0.05,
!term %in% c(
"gender",
"country",
"age_z"
)
) |>
pull(term)
marginal_effects <- marginaleffects::avg_slopes(
model,
variables = marginal_effect_variables,
type = "probs",
wts = model_data$analysis_weight,
vcov = design_vcov
) |>
as.data.frame() |>
as_tibble() |>
transmute(
term,
Outcome = factor(
group,
levels = outcome_levels
),
Predictor = if_else(
contrast == "dY/dX",
unname(
behavioural_predictor_labels[term]
),
paste0(
unname(
behavioural_predictor_labels[term]
),
": ",
str_replace(
contrast,
" - ",
" vs "
)
)
),
estimate,
conf_low = conf.low,
conf_high = conf.high
)
lifespan_contrasts <- planned_lifespan_contrasts(
model,
model_data,
type = "probs",
vcov = design_vcov
) |>
transmute(
term,
Outcome = factor(
Outcome,
levels = outcome_levels
),
Predictor = paste0(
"Lifespan compared with alternatives: ",
Contrast
),
estimate,
conf_low,
conf_high
)
if (model_tests$q_value[
model_tests$term == "comparison_lifespan"
] < 0.05) {
marginal_effects <- bind_rows(
marginal_effects |>
filter(term != "comparison_lifespan"),
lifespan_contrasts
)
} else {
marginal_effects <- marginal_effects |>
filter(term != "comparison_lifespan")
}
diagnostics <- tibble(
Check = c(
"Convergence",
"Predictor overlap",
"Smallest response group",
"Stable estimates",
"Uncertainty"
),
Result = c(
if_else(
model$convergence == 0 &&
survey_fit$inference_converged,
"Yes",
"No"
),
paste0(
"Low (",
scales::number(
maximum_coefficient_vif(model),
accuracy = 0.01
),
")"
),
paste0(
format_count(
min(table(model_data[[outcome_name]]))
),
" people"
),
if_else(
all(
is.finite(coef(model)),
is.finite(design_vcov)
),
"Yes",
"No"
),
"Included"
),
Interpretation = c(
"Optimisation completed normally",
"The factors remain distinct",
"Every answer has enough people",
"No numerical warning",
"Ranges show uncertainty around each result"
)
)
list(
data = model_data,
model = model,
vcov = design_vcov,
tests = model_tests,
marginal_effects = marginal_effects,
diagnostics = diagnostics
)
}
fit_outcome_model <- function(
outcome_data,
outcome_name,
outcome_levels
) {
results <- fit_multinomial_specification(
outcome_data,
outcome_name,
outcome_levels
)
overview <- results$tests |>
mutate(
Predictor = unname(
behavioural_predictor_labels[term]
)
) |>
select(
Predictor,
Wald,
df,
p_value,
q_value
)
list(
data = results$data,
model = results$model,
vcov = results$vcov,
tests = results$tests,
overview = overview,
marginal_effects = results$marginal_effects,
diagnostics = results$diagnostics
)
}
outcome_model_overview_table <- function(results) {
results$overview |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
),
q_value = format.pval(
q_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_number(
columns = Wald,
decimals = 1
) |>
cols_label(
Wald = "Overall test",
df = "df",
p_value = "p-value",
q_value = "Corrected p"
) |>
cols_width(
Predictor ~ pct(48),
Wald ~ px(105)
) |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Predictor)
) |>
gt_bellegarde()
}
outcome_model_diagnostics_table <- function(results) {
results$diagnostics |>
gt() |>
cols_width(
Check ~ pct(25),
Result ~ pct(22),
Interpretation ~ pct(53)
) |>
gt_bellegarde()
}Show R code
replacement_outcome_data <- df |>
transmute(
respondent_id = row_number(),
replacement = factor(
Replace,
levels = replacement_choice_levels
)
) |>
filter(!is.na(replacement))
replacement_results <- fit_outcome_model(
replacement_outcome_data,
"replacement",
replacement_choice_levels
)
replacement_global_fit <- survey_multinomial_model_fit(
replacement_results$model,
replacement_results$vcov,
"Replacement choice",
replacement_results$tests$term
)This model shows which factors shift respondents between the five possible replacement choices. The chart expresses these results as probability differences for each choice.
NoteShow tables and assumptions
Show R code
replacement_global_fit |>
model_fit_gt()| Model | N | Overall test | df | p-value |
|---|---|---|---|---|
| Replacement choice | 9,098 | 831.829 | 88 | <0.001 |
Show R code
outcome_model_overview_table(
replacement_results
)| Predictor | Overall test | df | p-value | Corrected p |
|---|---|---|---|---|
| Device satisfaction | 18.6 | 4 | <0.001 | 0.0016 |
| Expected lifespan | 44.9 | 8 | <0.001 | <0.001 |
| Lifespan compared with alternatives | 137.5 | 8 | <0.001 | <0.001 |
| Attitude towards buying | 40.6 | 4 | <0.001 | <0.001 |
| Injunctive norm | 16.4 | 4 | 0.0026 | 0.0032 |
| Dynamic norm | 6.8 | 4 | 0.1490 | 0.1656 |
| Support for buying fewer items | 39.6 | 4 | <0.001 | <0.001 |
| Support for stricter regulation | 4.8 | 4 | 0.3095 | 0.3095 |
| Country | 205.7 | 44 | <0.001 | <0.001 |
| Age | 16.8 | 4 | 0.0021 | 0.0030 |
Each replacement response is compared with the reference choice. Country coefficients are omitted from display but remain in the model.
Show R code
model_coefficient_data(
replacement_results$model,
robust_vcov = replacement_results$vcov
) |>
coefficient_gt()| Predictor | β | SE | 95% CI low | 95% CI high | p-value |
|---|---|---|---|---|---|
| Buy another small and inexpensive device | |||||
| Device satisfaction (1 SD) | −0.137 | 0.057 | −0.249 | −0.024 | 0.0174 |
| Expected lifespan: Shorter lifespan | −0.304 | 0.116 | −0.532 | −0.076 | 0.0090 |
| Expected lifespan: Longer lifespan | −0.382 | 0.145 | −0.665 | −0.098 | 0.0084 |
| Lifespan compared with alternatives: Shorter lifespan | 0.079 | 0.102 | −0.122 | 0.280 | 0.4398 |
| Lifespan compared with alternatives: Greater lifespan | −0.256 | 0.166 | −0.581 | 0.070 | 0.1237 |
| Attitude towards buying (1 SD) | −0.153 | 0.058 | −0.266 | −0.040 | 0.0079 |
| Injunctive norm (1 SD) | −0.152 | 0.053 | −0.256 | −0.048 | 0.0041 |
| Dynamic norm (1 SD) | 0.014 | 0.049 | −0.082 | 0.110 | 0.7808 |
| Support for buying fewer (1 SD) | 0.055 | 0.054 | −0.052 | 0.162 | 0.3129 |
| Support for regulation (1 SD) | −0.031 | 0.050 | −0.129 | 0.067 | 0.5389 |
| Age (1 SD) | −0.031 | 0.046 | −0.121 | 0.060 | 0.5069 |
| Buy a more expensive one | |||||
| Device satisfaction (1 SD) | −0.132 | 0.059 | −0.248 | −0.015 | 0.0264 |
| Expected lifespan: Shorter lifespan | 0.151 | 0.115 | −0.074 | 0.376 | 0.1882 |
| Expected lifespan: Longer lifespan | −0.042 | 0.160 | −0.356 | 0.273 | 0.7949 |
| Lifespan compared with alternatives: Shorter lifespan | 0.965 | 0.107 | 0.756 | 1.174 | <0.001 |
| Lifespan compared with alternatives: Greater lifespan | 0.501 | 0.172 | 0.165 | 0.838 | 0.0035 |
| Attitude towards buying (1 SD) | −0.329 | 0.060 | −0.446 | −0.212 | <0.001 |
| Injunctive norm (1 SD) | −0.217 | 0.058 | −0.330 | −0.103 | <0.001 |
| Dynamic norm (1 SD) | 0.016 | 0.051 | −0.085 | 0.116 | 0.7569 |
| Support for buying fewer (1 SD) | 0.310 | 0.060 | 0.192 | 0.427 | <0.001 |
| Support for regulation (1 SD) | 0.056 | 0.056 | −0.053 | 0.165 | 0.3145 |
| Age (1 SD) | −0.082 | 0.048 | −0.176 | 0.013 | 0.0905 |
| Choose not to replace it | |||||
| Device satisfaction (1 SD) | −0.337 | 0.079 | −0.492 | −0.183 | <0.001 |
| Expected lifespan: Shorter lifespan | −0.032 | 0.169 | −0.363 | 0.300 | 0.8523 |
| Expected lifespan: Longer lifespan | 0.244 | 0.216 | −0.179 | 0.668 | 0.2575 |
| Lifespan compared with alternatives: Shorter lifespan | 0.270 | 0.155 | −0.035 | 0.574 | 0.0830 |
| Lifespan compared with alternatives: Greater lifespan | 0.350 | 0.254 | −0.149 | 0.849 | 0.1690 |
| Attitude towards buying (1 SD) | −0.441 | 0.088 | −0.614 | −0.269 | <0.001 |
| Injunctive norm (1 SD) | −0.201 | 0.090 | −0.378 | −0.023 | 0.0265 |
| Dynamic norm (1 SD) | −0.014 | 0.076 | −0.164 | 0.135 | 0.8534 |
| Support for buying fewer (1 SD) | 0.239 | 0.088 | 0.066 | 0.412 | 0.0067 |
| Support for regulation (1 SD) | −0.003 | 0.080 | −0.159 | 0.153 | 0.9685 |
| Age (1 SD) | 0.188 | 0.078 | 0.036 | 0.340 | 0.0155 |
| Other | |||||
| Device satisfaction (1 SD) | −0.101 | 0.179 | −0.451 | 0.250 | 0.5735 |
| Expected lifespan: Shorter lifespan | −0.854 | 0.389 | −1.617 | −0.091 | 0.0282 |
| Expected lifespan: Longer lifespan | 0.832 | 0.414 | 0.021 | 1.644 | 0.0444 |
| Lifespan compared with alternatives: Shorter lifespan | 0.390 | 0.357 | −0.310 | 1.090 | 0.2747 |
| Lifespan compared with alternatives: Greater lifespan | −1.300 | 0.802 | −2.872 | 0.271 | 0.1049 |
| Attitude towards buying (1 SD) | −0.318 | 0.176 | −0.663 | 0.026 | 0.0703 |
| Injunctive norm (1 SD) | −0.319 | 0.152 | −0.617 | −0.021 | 0.0357 |
| Dynamic norm (1 SD) | 0.364 | 0.144 | 0.081 | 0.646 | 0.0116 |
| Support for buying fewer (1 SD) | 0.020 | 0.166 | −0.306 | 0.345 | 0.9060 |
| Support for regulation (1 SD) | −0.205 | 0.188 | −0.574 | 0.164 | 0.2769 |
| Age (1 SD) | 0.237 | 0.164 | −0.085 | 0.558 | 0.1487 |
The model treats the five replacement choices separately. The checks show whether the calculation was stable and whether every answer has enough people.
Show R code
outcome_model_diagnostics_table(
replacement_results
)| Check | Result | Interpretation |
|---|---|---|
| Convergence | Yes | Optimisation completed normally |
| Predictor overlap | Low (1.70) | The factors remain distinct |
| Smallest response group | 123 people | Every answer has enough people |
| Stable estimates | Yes | No numerical warning |
| Uncertainty | Included | Ranges show uncertainty around each result |
Show R code
replacement_results$marginal_effects |>
mutate(
Predictor = fct_reorder(
str_wrap(Predictor, 42),
estimate
)
) |>
ggplot(aes(
x = estimate,
y = Predictor,
colour = Outcome
)) +
geom_vline(
xintercept = 0,
colour = bg_ink_32,
linewidth = bg_lw_hairline,
linetype = "dashed"
) +
geom_errorbar(
aes(
xmin = conf_low,
xmax = conf_high
),
orientation = "y",
position = position_dodge(width = 0.65),
width = 0,
linewidth = bg_lw_line
) +
geom_point(
position = position_dodge(width = 0.65),
size = bg_size_label / .pt
) +
scale_x_continuous(
labels = label_percent(
accuracy = 0.1,
style_positive = "plus"
)
) +
scale_colour_manual(
values = c(
"Buy the exact same small and inexpensive model" =
bg_accent_20,
"Buy another small and inexpensive device" =
bg_accent_50,
"Buy a more expensive one" = bg_accent,
"Choose not to replace it" = bg_pink,
"Other" = bg_ink_32
),
labels = function(x) {
str_wrap(x, width = 24)
},
name = NULL
) +
guides(
colour = guide_legend(
nrow = 3,
byrow = TRUE
)
) +
labs(
x = "Change in probability",
y = NULL
) +
theme(
legend.position = "bottom"
)
How to read: People who see fast tech as short-lived are more likely to choose a more expensive replacement.
Note: For scored questions, each bar shows a typical increase. The lifespan bars compare shorter with other answers, and greater with other answers. Positive and negative values show how probability moves between the replacement choices. The model does not establish causality.
Top 3 factors
- Lifespan compared with alternatives. Perceiving fast tech as shorter-lived is associated with a greater probability of choosing a more expensive replacement than reporting no durability deficit.
- Expected lifespan. A shorter-than-expected lifespan makes choosing another inexpensive device less likely.
- Support for buying fewer items. Stronger support for buying fewer devices makes choosing a more expensive replacement more likely.
2.4 Future buying intention
Show R code
future_intention_outcome_data <- df |>
transmute(
respondent_id = row_number(),
previous_buyer = Buyer == "Buyer",
future_intention = ordered(
.data[["12months_Intentionbuy"]],
levels = future_purchase_intention_levels
)
) |>
filter(
previous_buyer,
!is.na(future_intention)
) |>
mutate(
future_intention_score =
as.numeric(future_intention) - 1,
reduce_or_stop = as.integer(
future_intention_score <= 2
),
increase_purchases = as.integer(
future_intention_score >= 4
)
)
future_intention_score_data <-
prepare_behavioural_model_data(
future_intention_outcome_data |>
select(
respondent_id,
future_intention_score
),
"future_intention_score",
behavioural_predictor_names
)
future_intention_terms <- build_behavioural_model_terms(
behavioural_predictor_names
)
future_intention_score_formula <- reformulate(
future_intention_terms,
response = "future_intention_score"
)
future_intention_score_model <- survey::svyglm(
future_intention_score_formula,
design = make_analysis_design(
future_intention_score_data
),
family = gaussian()
)
future_intention_score_vcov <- vcov(
future_intention_score_model
)
future_intention_term_tests <-
survey_wald_term_tests(
future_intention_score_model,
future_intention_terms
)
future_intention_overview <-
future_intention_term_tests |>
mutate(
Predictor = unname(
behavioural_predictor_labels[term]
)
) |>
select(
Predictor,
Wald,
df,
p_value,
q_value
)
future_intention_significant_terms <-
future_intention_term_tests |>
filter(
q_value < 0.05,
!term %in% c(
"gender",
"country",
"age_z"
)
) |>
pull(term)
future_intention_score_effects <-
marginaleffects::avg_slopes(
future_intention_score_model,
variables = future_intention_significant_terms,
vcov = future_intention_score_vcov,
wts = future_intention_score_data$analysis_weight
) |>
as.data.frame() |>
as_tibble() |>
transmute(
term,
Predictor = if_else(
contrast == "dY/dX",
unname(behavioural_predictor_labels[term]),
paste0(
unname(behavioural_predictor_labels[term]),
": ",
str_replace(
contrast,
" - ",
" vs "
)
)
),
estimate,
conf_low = conf.low,
conf_high = conf.high
)
future_intention_lifespan_score_contrasts <-
planned_lifespan_contrasts(
future_intention_score_model,
future_intention_score_data,
type = "response",
vcov = future_intention_score_vcov
) |>
transmute(
term,
Predictor = paste0(
"Lifespan compared with alternatives: ",
Contrast
),
estimate,
conf_low,
conf_high
)
if (future_intention_term_tests$q_value[
future_intention_term_tests$term ==
"comparison_lifespan"
] < 0.05) {
future_intention_score_effects <- bind_rows(
future_intention_score_effects |>
filter(term != "comparison_lifespan"),
future_intention_lifespan_score_contrasts
)
} else {
future_intention_score_effects <-
future_intention_score_effects |>
filter(term != "comparison_lifespan")
}
fit_future_threshold_model <- function(outcome_name) {
model_data <- prepare_behavioural_model_data(
future_intention_outcome_data |>
select(
respondent_id,
all_of(outcome_name)
),
outcome_name,
behavioural_predictor_names
)
model_formula <- reformulate(
future_intention_terms,
response = outcome_name
)
model <- survey::svyglm(
model_formula,
design = make_analysis_design(model_data),
family = quasibinomial()
)
robust_vcov <- vcov(model)
contrasts <- planned_lifespan_contrasts(
model,
model_data,
type = "response",
vcov = robust_vcov
)
list(
data = model_data,
model = model,
vcov = robust_vcov,
contrasts = contrasts
)
}
future_reduce_model <- fit_future_threshold_model(
"reduce_or_stop"
)
future_increase_model <- fit_future_threshold_model(
"increase_purchases"
)
future_shorter_score <-
future_intention_lifespan_score_contrasts |>
filter(str_detect(
Predictor,
fixed("Shorter vs non-shorter")
))
future_greater_score <-
future_intention_lifespan_score_contrasts |>
filter(str_detect(
Predictor,
fixed("Greater vs non-greater")
))
future_shorter_reduce <-
future_reduce_model$contrasts |>
filter(Contrast == "Shorter vs non-shorter")
future_greater_reduce <-
future_reduce_model$contrasts |>
filter(Contrast == "Greater vs non-greater")
future_greater_increase <-
future_increase_model$contrasts |>
filter(Contrast == "Greater vs non-greater")
future_intention_diagnostics <- tibble(
Check = c(
"Complete responses",
"Answer scale",
"Uncertainty",
"Predictor overlap",
"Cross-check"
),
Result = c(
format_count(nrow(
future_intention_score_data
)),
"Six levels coded 0–5",
"Included",
paste0(
"Low (",
number(
maximum_coefficient_vif(
future_intention_score_model
),
accuracy = 0.01
),
")"
),
"Less, much less or stop"
),
Interpretation = c(
"Previous buyers with all required answers",
"Higher scores mean intending to buy more",
"Ranges show uncertainty around each result",
"The factors remain distinct",
"A separate yes/no model confirms the main result"
)
)
future_intention_global_test <- survey::regTermTest(
future_intention_score_model,
reformulate(future_intention_terms),
method = "Wald"
)
future_intention_global_fit <- tibble(
Model = "Future buying intention",
N = nrow(future_intention_score_data),
Wald = as.numeric(
survey_test_statistic(future_intention_global_test)
),
df = as.numeric(future_intention_global_test$df),
p_value = as.numeric(future_intention_global_test$p)
)The six answers are treated as an ordered continuum from 0 (I intend to stop) to 5 (Much more). A lower score therefore represents an intention to purchase less in the future.
Perceiving a shorter lifespan corresponds to a 0.21 points lower than for respondents not reporting a shorter lifespan. It is also associated with an increase of 12.1 percentage points in the probability of intending to buy less or stop.
The following visualisation shows factors driving intention. For scored questions such as attitudes and satisfaction, each bar shows a typical increase. The lifespan contrasts compare shorter with all non-shorter responses and greater with all non-greater responses. Negative values indicate lower future purchasing intentions; positive values indicate higher intentions.
NoteShow tables and assumptions
Show R code
future_intention_global_fit |>
model_fit_gt()| Model | N | Overall test | df | p-value |
|---|---|---|---|---|
| Future buying intention | 9,098 | 37.077 | 24 | <0.001 |
Show R code
future_intention_overview |>
mutate(
p_value = format.pval(
p_value,
digits = 2,
eps = 0.001
),
q_value = format.pval(
q_value,
digits = 2,
eps = 0.001
)
) |>
gt() |>
fmt_number(
columns = Wald,
decimals = 1
) |>
cols_label(
Wald = "Overall test",
df = "df",
p_value = "p-value",
q_value = "Corrected p"
) |>
cols_width(
Predictor ~ pct(46),
Wald ~ px(145)
) |>
tab_style(
style = cell_text(weight = "600"),
locations = cells_body(columns = Predictor)
) |>
gt_bellegarde()| Predictor | Overall test | df | p-value | Corrected p |
|---|---|---|---|---|
| Device satisfaction | 21.9 | 1 | <0.001 | <0.001 |
| Expected lifespan | 4.5 | 2 | 0.012 | 0.014 |
| Lifespan compared with alternatives | 27.3 | 2 | <0.001 | <0.001 |
| Attitude towards buying | 54.6 | 1 | <0.001 | <0.001 |
| Injunctive norm | 18.5 | 1 | <0.001 | <0.001 |
| Dynamic norm | 0.0 | 1 | 0.997 | 0.997 |
| Support for buying fewer items | 70.6 | 1 | <0.001 | <0.001 |
| Support for stricter regulation | 0.3 | 1 | 0.595 | 0.655 |
| Gender | 18.3 | 2 | <0.001 | <0.001 |
| Country | 4.2 | 11 | <0.001 | <0.001 |
| Age | 66.0 | 1 | <0.001 | <0.001 |
Positive coefficients indicate a higher intended purchasing score. Country results are included in the model but not shown in the table.
Show R code
model_coefficient_data(
future_intention_score_model,
robust_vcov = future_intention_score_vcov
) |>
coefficient_gt()| Predictor | β | SE | 95% CI low | 95% CI high | p-value |
|---|---|---|---|---|---|
| Device satisfaction (1 SD) | 0.084 | 0.018 | 0.049 | 0.119 | <0.001 |
| Expected lifespan: Shorter lifespan | −0.037 | 0.035 | −0.106 | 0.031 | 0.284 |
| Expected lifespan: Longer lifespan | −0.134 | 0.047 | −0.226 | −0.043 | 0.004 |
| Lifespan compared with alternatives: Shorter lifespan | −0.196 | 0.029 | −0.252 | −0.139 | <0.001 |
| Lifespan compared with alternatives: Greater lifespan | 0.101 | 0.064 | −0.024 | 0.226 | 0.114 |
| Attitude towards buying (1 SD) | 0.150 | 0.020 | 0.110 | 0.189 | <0.001 |
| Injunctive norm (1 SD) | 0.077 | 0.018 | 0.042 | 0.112 | <0.001 |
| Dynamic norm (1 SD) | 0.000 | 0.016 | −0.032 | 0.032 | 0.997 |
| Support for buying fewer (1 SD) | −0.163 | 0.019 | −0.201 | −0.125 | <0.001 |
| Support for regulation (1 SD) | −0.009 | 0.016 | −0.041 | 0.023 | 0.595 |
| Gender: Male | 0.160 | 0.027 | 0.108 | 0.212 | <0.001 |
| Gender: Non-binary | 0.071 | 0.154 | −0.230 | 0.373 | 0.643 |
| Age (1 SD) | −0.115 | 0.014 | −0.143 | −0.087 | <0.001 |
The answers run from stopping purchases to buying much more. The score model gives a clear overall direction, while a separate yes/no check confirms the main result for people who plan to buy less or stop.
Show R code
future_intention_diagnostics |>
gt() |>
cols_width(
Check ~ pct(25),
Result ~ pct(25),
Interpretation ~ pct(50)
) |>
gt_bellegarde()| Check | Result | Interpretation |
|---|---|---|
| Complete responses | 9,098 | Previous buyers with all required answers |
| Answer scale | Six levels coded 0–5 | Higher scores mean intending to buy more |
| Uncertainty | Included | Ranges show uncertainty around each result |
| Predictor overlap | Low (1.70) | The factors remain distinct |
| Cross-check | Less, much less or stop | A separate yes/no model confirms the main result |
Show R code
future_intention_score_effects |>
mutate(
Predictor = fct_reorder(
str_wrap(Predictor, 42),
estimate
)
) |>
ggplot(aes(
x = estimate,
y = Predictor
)) +
geom_vline(
xintercept = 0,
colour = bg_ink_32,
linewidth = bg_lw_hairline,
linetype = "dashed"
) +
geom_errorbar(
aes(
xmin = conf_low,
xmax = conf_high
),
orientation = "y",
width = 0,
linewidth = bg_lw_line,
colour = bg_accent
) +
geom_point(
size = bg_size_label / .pt,
colour = bg_accent
) +
scale_x_continuous(
labels = label_number(
accuracy = 0.05,
style_positive = "plus"
)
) +
labs(
x = paste0(
"Change in intention score ",
"(0 = stop; 5 = much more)"
),
y = NULL
)
How to read: Seeing fast tech as short-lived is linked with a 0.21-point lower score on the 0–5 scale.
Top 3 factors
- Lifespan compared with alternatives. Respondents perceiving fast tech as having a shorter lifespan intend more to purchase less or stop.
- Support for buying fewer items. Stronger support for buying fewer devices corresponds to lower future purchasing intentions.
- Attitude towards buying. More favourable attitudes towards fast tech buying go with higher future purchasing intentions.
3 Comparative profiles
A comparative profile tests which observed characteristics distinguish one group of respondents over one outcome. It uses a deliberately small set of characteristics to produce easy-to-grasp audience groups associated with a defined behaviour. This approach doesn’t establishe causality.
Show R code
profile_required_packages <- c(
"car",
"marginaleffects",
"rpart"
)
profile_missing_packages <- profile_required_packages[
!map_lgl(
profile_required_packages,
requireNamespace,
quietly = TRUE
)
]
if (length(profile_missing_packages) > 0) {
stop(
"Install the following packages before rendering: ",
paste(profile_missing_packages, collapse = ", ")
)
}
profile_age_levels <- c(
"18–29",
"30–39",
"40–54",
"55–64",
"65+"
)
profile_household_levels <- c(
"1",
"2",
"3",
"4",
"5+"
)
profile_education_levels <- c(
"No formal education / Primary school",
"Secondary school / High school",
"College / Undergraduate",
"Bachelor or equivalent",
"Master or equivalent / Doctorate, Ph.D. or equivalent"
)
comparative_profile_data <- df |>
mutate(
respondent_id = row_number()
) |>
transmute(
respondent_id,
analysis_weight,
buyer_status = factor(
if_else(Buyer == "Buyer", "Buyer", "Non-buyer"),
levels = c("Non-buyer", "Buyer")
),
age = Age,
age_group = cut(
Age,
breaks = c(-Inf, 29, 39, 54, 64, Inf),
labels = profile_age_levels
),
age_category = as.numeric(cut(
Age,
breaks = c(-Inf, 29, 39, 54, 64, Inf),
labels = FALSE
)),
household_size = as.numeric(Nb_household),
household_group = cut(
as.numeric(Nb_household),
breaks = c(-Inf, 1, 2, 3, 4, Inf),
labels = profile_household_levels
),
household_category = as.numeric(cut(
as.numeric(Nb_household),
breaks = c(-Inf, 1, 2, 3, 4, Inf),
labels = FALSE
)),
gender = factor(
if_else(
Gender %in% sociodemographic_gender_levels,
Gender,
NA_character_
),
levels = sociodemographic_gender_levels
),
education = factor(
if_else(
Education == "Prefer not to say",
NA_character_,
Education
),
levels = profile_education_levels
),
employment = factor(
if_else(
Employment == "Prefer not to say",
NA_character_,
Employment
),
levels = sociodemographic_employment_levels
),
satisfaction_score = as.numeric(
Satisfaction_recoded
),
expected_lifespan = factor(
Global_Lifespan,
levels = c(
"Expected lifespan",
"Shorter lifespan",
"Longer lifespan"
)
),
comparison_lifespan = factor(
Comparison_Lifespan,
levels = c(
"Similar lifespan",
"Shorter lifespan",
"Greater lifespan"
)
),
attitude_score = as.numeric(
Attitude_buying_recoded
),
injunctive_score = as.numeric(
.data[["Injunctive norm_recoded"]]
),
dynamic_score = as.numeric(
.data[["Dynamic norm_recoded"]]
),
buy_fewer_score = as.numeric(
.data[["Consumers should buy fewer_recoded"]]
),
regulation_score = as.numeric(
.data[["Governments should more strictly regulate_recoded"]]
),
country = factor(
Country,
levels = model_country_levels
)
)
profile_term_labels <- c(
age = "Age",
age_group = "Age group",
age_category = "Age category",
household_group = "Household size",
household_category = "Household-size category",
gender = "Gender",
education = "Education",
employment = "Employment status",
satisfaction_score = "Device satisfaction",
expected_lifespan = "Expected lifespan",
comparison_lifespan = "Lifespan versus alternatives",
attitude_score = "Attitude towards buying fast tech",
injunctive_score = "Perceived injunctive norm",
dynamic_score = "Perceived dynamic norm",
buy_fewer_score = "Consumers should buy fewer items",
regulation_score = "Support for stricter regulation",
country = "Country"
)
maximum_predictor_overlap <- function(model) {
vif_result <- suppressWarnings(car::vif(model))
if (is.matrix(vif_result)) {
if ("GVIF^(1/(2*Df))" %in% colnames(vif_result)) {
return(max(
vif_result[, "GVIF^(1/(2*Df))"],
na.rm = TRUE
))
}
return(max(
vif_result[, "GVIF"] ^
(1 / (2 * vif_result[, "Df"])),
na.rm = TRUE
))
}
max(sqrt(vif_result), na.rm = TRUE)
}
fit_comparative_profile <- function(
data,
outcome,
terms,
contrast_specifications,
linearity_variables = character()
) {
model_data <- data |>
select(all_of(c(outcome, terms)), analysis_weight) |>
drop_na()
model_formula <- reformulate(
terms,
response = outcome
)
model <- survey::svyglm(
model_formula,
design = make_analysis_design(model_data),
family = quasibinomial()
)
global_tests <- survey_wald_term_tests(
model,
terms
) |>
mutate(
Predictor = unname(profile_term_labels[term]),
significant = q_value < 0.05
)
probability_contrasts <- pmap_dfr(
contrast_specifications,
function(
variable,
low,
high,
Predictor,
Domain,
contrast_type
) {
if (contrast_type == "continuous") {
continuous_contrast <- if (variable == "age") {
marginaleffects::avg_comparisons(
model,
variables = setNames(list(10), variable),
type = "response",
wts = model_data$analysis_weight,
vcov = vcov(model)
)
} else {
marginaleffects::avg_slopes(
model,
variables = variable,
type = "response",
wts = model_data$analysis_weight,
vcov = vcov(model)
)
}
return(
continuous_contrast |>
as.data.frame() |>
as_tibble() |>
transmute(
variable,
Predictor,
Domain,
contrast = if_else(
variable == "age",
"Ten-year increase",
if_else(
variable == "household_category",
"One-category increase",
"One-point increase"
)
),
estimate,
conf_low = conf.low,
conf_high = conf.high,
p_value = p.value
)
)
}
marginaleffects::avg_comparisons(
model,
variables = setNames(
list(c(low, high)),
variable
),
type = "response",
wts = model_data$analysis_weight,
vcov = vcov(model)
) |>
as.data.frame() |>
as_tibble() |>
transmute(
variable,
Predictor,
Domain,
contrast = paste0(high, " vs ", low),
estimate,
conf_low = conf.low,
conf_high = conf.high,
p_value = p.value
)
}
) |>
mutate(
q_value = p.adjust(p_value, method = "BH")
)
outcome_counts <- table(model_data[[outcome]])
predictor_cells <- map_int(
terms,
function(term) {
cells <- table(
model_data[[outcome]],
model_data[[term]]
)
min(cells[cells > 0])
}
)
fitted_probabilities <- fitted(model)
observed_binary <- as.numeric(model_data[[outcome]]) - 1
tjur_r2 <-
weighted.mean(
fitted_probabilities[observed_binary == 1],
model_data$analysis_weight[observed_binary == 1]
) -
weighted.mean(
fitted_probabilities[observed_binary == 0],
model_data$analysis_weight[observed_binary == 0]
)
influential_threshold <- 4 / nrow(model_data)
influential_n <- sum(
cooks.distance(model) > influential_threshold,
na.rm = TRUE
)
linearity_checks <- if (
length(linearity_variables) == 0
) {
tibble(
term = character(),
Predictor = character(),
Wald = numeric(),
df = numeric(),
p_value = numeric(),
q_value = numeric(),
Result = character()
)
} else {
map_dfr(
linearity_variables,
function(variable) {
flexible_formula <- update(
model_formula,
as.formula(
paste0(
". ~ . - ",
variable,
" + factor(",
variable,
")"
)
)
)
flexible_model <- survey::svyglm(
flexible_formula,
design = make_analysis_design(model_data),
family = quasibinomial()
)
comparison <- stats::anova(
model,
flexible_model,
method = "Wald",
test = "F",
force = TRUE
)
tibble(
term = variable,
Wald = as.numeric(comparison$Ftest),
df = as.numeric(comparison$df),
p_value = as.numeric(comparison$p)
)
}
) |>
mutate(
q_value = p.adjust(
p_value,
method = "BH"
),
Predictor = unname(
profile_term_labels[term]
),
Result = if_else(
q_value < 0.05,
"Evidence of non-linearity",
"No evidence of non-linearity"
)
) |>
select(
term,
Predictor,
Wald,
df,
p_value,
q_value,
Result
)
}
diagnostics <- tibble(
Check = c(
"Complete-case sample",
"Outcome counts",
"Convergence",
"Finite coefficients",
"Predictor overlap",
"Smallest non-empty outcome × predictor cell",
"Predictor specification",
"Continuous-scale linearity check",
"Observations with Cook's distance > 4/N",
"Tjur's coefficient of discrimination"
),
Result = c(
format_count(nrow(model_data)),
paste(
names(outcome_counts),
format_count(as.numeric(outcome_counts)),
collapse = "; "
),
if_else(model$converged, "Passed", "Failed"),
if_else(
all(is.finite(coef(model))),
"Passed",
"Failed"
),
number(maximum_predictor_overlap(model), accuracy = 0.01),
format_count(min(predictor_cells)),
paste0(
"Age entered in years; household size entered as an ",
"ordered category score; lifespan and other ",
"socio-demographic variables categorical; rating ",
"scales continuous"
),
paste0(
sum(linearity_checks$q_value < 0.05),
" of ",
nrow(linearity_checks),
" scales show evidence of non-linearity"
),
paste0(
format_count(influential_n),
" (",
format_percent(influential_n / nrow(model_data)),
")"
),
number(tjur_r2, accuracy = 0.001)
)
)
list(
data = model_data,
model = model,
global_tests = global_tests,
probability_contrasts = probability_contrasts,
diagnostics = diagnostics,
linearity_checks = linearity_checks
)
}
profile_linearity_table <- function(results) {
results$linearity_checks |>
select(
Predictor,
Wald,
df,
q_value,
Result
) |>
gt() |>
cols_label(
Predictor = "Continuous scale",
Wald = "Overall test",
df = "df",
q_value = "Corrected p",
Result = "Assessment"
) |>
fmt_number(columns = Wald, decimals = 1) |>
fmt_number(columns = q_value, decimals = 3) |>
tab_style(
style = cell_text(weight = "bold"),
locations = cells_body(
rows = q_value < 0.05
)
) |>
gt_bellegarde()
}
profile_global_test_table <- function(results) {
results$global_tests |>
arrange(desc(significant), q_value) |>
select(Predictor, Wald, df, q_value) |>
gt() |>
cols_label(
Predictor = "Predictor",
Wald = "Overall test",
df = "df",
q_value = "Corrected p"
) |>
fmt_number(columns = Wald, decimals = 1) |>
fmt_number(columns = q_value, decimals = 3) |>
sub_missing(columns = q_value, missing_text = "—") |>
tab_style(
style = cell_text(weight = "bold"),
locations = cells_body(
rows = q_value < 0.05
)
) |>
gt_bellegarde()
}
plot_profile_contrasts <- function(results, positive_label) {
results$probability_contrasts |>
mutate(
Predictor_plot = paste0(Predictor, "\n", contrast),
Domain = factor(
Domain,
levels = c(
"Socio-demographic characteristics",
"Perceptions and behavioural factors"
)
)
) |>
ggplot(aes(
x = estimate,
y = fct_reorder(Predictor_plot, estimate)
)) +
geom_vline(
xintercept = 0,
colour = bg_ink_32,
linewidth = bg_lw_hairline
) +
geom_errorbarh(
aes(xmin = conf_low, xmax = conf_high),
height = 0,
colour = bg_pink,
linewidth = bg_lw_line
) +
geom_point(
colour = bg_pink,
size = bg_point_size
) +
scale_x_continuous(
labels = percent_format(accuracy = 1),
expand = expansion(mult = c(0.08, 0.08))
) +
facet_grid(
Domain ~ .,
scales = "free_y",
space = "free_y"
) +
labs(
x = paste0(
"Difference in probability of being a ",
positive_label
),
y = NULL
) +
theme(
panel.spacing.y = grid::unit(bg_margin_pt, "pt")
)
}3.1 Buyers and non-buyers
3.1.1 Comparative profile
The following model estimates the probability of having ever bought fast tech and compares buyers with non-buyers on socio-demographic characteristics, lifespan perceptions, buying attitude and perceived norms.
Show R code
buyer_profile_terms <- c(
"age",
"household_category",
"gender",
"education",
"employment",
"comparison_lifespan",
"attitude_score",
"injunctive_score",
"dynamic_score",
"buy_fewer_score",
"regulation_score",
"country"
)
buyer_profile_contrasts <- tribble(
~variable, ~low, ~high, ~Predictor, ~Domain, ~contrast_type,
"age", NA_character_, NA_character_, "Age", "Socio-demographic characteristics", "continuous",
"household_category", NA_character_, NA_character_, "Household-size category", "Socio-demographic characteristics", "continuous",
"comparison_lifespan", "Shorter lifespan", "Greater lifespan", "Lifespan versus alternatives", "Perceptions and behavioural factors", "categorical",
"attitude_score", NA_character_, NA_character_, "Attitude towards buying fast tech", "Perceptions and behavioural factors", "continuous",
"injunctive_score", NA_character_, NA_character_, "Perceived injunctive norm", "Perceptions and behavioural factors", "continuous",
"dynamic_score", NA_character_, NA_character_, "Perceived dynamic norm", "Perceptions and behavioural factors", "continuous",
"buy_fewer_score", NA_character_, NA_character_, "Consumers should buy fewer items", "Perceptions and behavioural factors", "continuous",
"regulation_score", NA_character_, NA_character_, "Support for stricter regulation", "Perceptions and behavioural factors", "continuous"
)
buyer_profile_results <- fit_comparative_profile(
comparative_profile_data,
outcome = "buyer_status",
terms = buyer_profile_terms,
contrast_specifications = buyer_profile_contrasts,
linearity_variables = c(
"age",
"household_category",
"attitude_score",
"injunctive_score",
"dynamic_score",
"buy_fewer_score",
"regulation_score"
)
)
buyer_profile_significant <- buyer_profile_results$global_tests |>
filter(
significant,
term != "country"
) |>
pull(Predictor)
buyer_profile_significant_text <- paste(
buyer_profile_significant,
collapse = ", "
)
buyer_profile_key_effect <- buyer_profile_results$probability_contrasts |>
slice_max(
abs(estimate),
n = 1,
with_ties = FALSE
)
buyer_profile_age_effect <- buyer_profile_results$probability_contrasts |>
filter(variable == "age") |>
slice_head(n = 1)The analysis includes 10,030 respondents. It shows links, not causes. Over ten years of age, the probability of having bought fast tech is 3.3% lower (likely range: 2.3% to 4.3% lower).
Show R code
plot_profile_contrasts(
buyer_profile_results,
positive_label = "buyer"
)
How to read: Over ten years of age, the probability of having bought fast tech is 3.3% lower.
NoteShow tables and assumptions
Show R code
profile_global_test_table(buyer_profile_results)| Predictor | Overall test | df | Corrected p |
|---|---|---|---|
| Attitude towards buying fast tech | 63.0 | 1 | 0.000 |
| Age | 48.8 | 1 | 0.000 |
| Household-size category | 37.5 | 1 | 0.000 |
| Country | 5.6 | 11 | 0.000 |
| Education | 6.9 | 4 | 0.000 |
| Perceived injunctive norm | 18.6 | 1 | 0.000 |
| Employment status | 2.9 | 6 | 0.013 |
| Gender | 4.7 | 2 | 0.013 |
| Lifespan versus alternatives | 4.4 | 2 | 0.016 |
| Perceived dynamic norm | 2.6 | 1 | 0.129 |
| Consumers should buy fewer items | 0.6 | 1 | 0.469 |
| Support for stricter regulation | 0.5 | 1 | 0.494 |
The model uses one record per person. Age, household size and the five rating scales are treated as gradual measures. Lifespan perception and the other personal characteristics are treated as categories. The results show links, not causes.
Show R code
buyer_profile_results$diagnostics |>
gt() |>
gt_bellegarde()| Check | Result |
|---|---|
| Complete-case sample | 10,030 |
| Outcome counts | Non-buyer 1,066; Buyer 8,964 |
| Convergence | Passed |
| Finite coefficients | Passed |
| Predictor overlap | 1.54 |
| Smallest non-empty outcome × predictor cell | 1 |
| Predictor specification | Age entered in years; household size entered as an ordered category score; lifespan and other socio-demographic variables categorical; rating scales continuous |
| Continuous-scale linearity check | 6 of 7 scales show evidence of non-linearity |
| Observations with Cook's distance > 4/N | 683 (6.8%) |
| Tjur's coefficient of discrimination | 0.183 |
The following tests compare each one-slope specification with a model giving every response level its own coefficient. A significant result indicates that the continuous scale remains usable as a metric score, but that a single straight-line effect may be an oversimplification.
Show R code
profile_linearity_table(
buyer_profile_results
)| Continuous scale | Overall test | df | Corrected p | Assessment |
|---|---|---|---|---|
| Age | 8.1 | 69 | 0.000 | Evidence of non-linearity |
| Household-size category | 0.5 | 3 | 0.690 | No evidence of non-linearity |
| Attitude towards buying fast tech | 12.8 | 3 | 0.000 | Evidence of non-linearity |
| Perceived injunctive norm | 10.0 | 3 | 0.000 | Evidence of non-linearity |
| Perceived dynamic norm | 18.2 | 3 | 0.000 | Evidence of non-linearity |
| Consumers should buy fewer items | 7.1 | 3 | 0.000 | Evidence of non-linearity |
| Support for stricter regulation | 10.0 | 3 | 0.000 | Evidence of non-linearity |
The smallest cell is driven by rare response combinations, especially the non-binary gender category. Its coefficient should therefore be interpreted cautiously. Observations exceeding the Cook’s-distance screening threshold are retained: this threshold flags cases for sensitivity review and is not an automatic exclusion rule.
3.1.2 Typical observed profiles
Show R code
weighted_mode_with_share <- function(x, weights) {
valid <- !is.na(x) & !is.na(weights) & weights > 0
if (!any(valid)) {
return(NA_character_)
}
distribution <- tibble(
value = as.character(x[valid]),
weight = weights[valid]
) |>
group_by(value) |>
summarise(weight = sum(weight), .groups = "drop")
modal_response <- distribution |>
slice_max(weight, n = 1, with_ties = FALSE)
paste0(
modal_response$value,
" (",
percent(
modal_response$weight / sum(distribution$weight),
accuracy = 0.1
),
")"
)
}
buyer_profile_metric_spec <- tribble(
~term, ~variable, ~Characteristic, ~metric, ~suffix,
"age", "age", "Mean age", "mean", " years",
"household_category", "household_size", "Mean household size", "mean", " people",
"education", "education", "Most common education level", "mode", "",
"employment", "employment", "Most common employment status", "mode", "",
"comparison_lifespan", "comparison_lifespan", "Most common comparative-lifespan response", "mode", "",
"attitude_score", "attitude_score", "Mean buying-attitude score", "mean", "/5",
"injunctive_score", "injunctive_score", "Mean perceived-approval score", "mean", "/5",
"buy_fewer_score", "buy_fewer_score", "Mean ‘buy fewer’ score", "mean", "/5",
"regulation_score", "regulation_score", "Mean regulation-support score", "mean", "/5"
)
buyer_profile_significant_terms <-
buyer_profile_results$global_tests |>
filter(significant, term != "country") |>
pull(term)
buyer_typical_profiles <- buyer_profile_metric_spec |>
filter(term %in% buyer_profile_significant_terms) |>
pmap_dfr(function(
term,
variable,
Characteristic,
metric,
suffix
) {
comparative_profile_data |>
group_by(buyer_status) |>
summarise(
Value = if (metric == "mean") {
paste0(
number(
weighted_mean_safe(
.data[[variable]],
analysis_weight
),
accuracy = 0.1
),
suffix
)
} else {
weighted_mode_with_share(
.data[[variable]],
analysis_weight
)
},
.groups = "drop"
) |>
mutate(
term = term,
Characteristic = Characteristic
)
}) |>
left_join(
buyer_profile_metric_spec |>
mutate(metric_order = row_number()) |>
select(term, metric_order),
by = "term"
) |>
arrange(metric_order) |>
select(Characteristic, buyer_status, Value) |>
pivot_wider(
names_from = buyer_status,
values_from = Value
)
buyer_profile_mean_age <- comparative_profile_data |>
group_by(buyer_status) |>
summarise(
mean_age = weighted_mean_safe(
age,
analysis_weight
),
.groups = "drop"
) |>
pivot_wider(
names_from = buyer_status,
values_from = mean_age
)This profile shows the average or most common answer in each group. Non-buyers are older on average (59.5 years) than buyers (47.7 years). This age difference remains clear when the other characteristics are considered.
Show R code
buyer_typical_profiles |>
gt() |>
gt_bellegarde()| Characteristic | Non-buyer | Buyer |
|---|---|---|
| Mean age | 59.5 years | 47.7 years |
| Mean household size | 2.0 people | 2.7 people |
| Most common education level | Secondary school / High school (47.5%) | Secondary school / High school (33.9%) |
| Most common employment status | Retired (45.8%) | Employed (55.7%) |
| Most common comparative-lifespan response | Shorter lifespan (58.8%) | Similar lifespan (48.6%) |
| Mean buying-attitude score | 2.6/5 | 3.3/5 |
| Mean perceived-approval score | 2.8/5 | 3.3/5 |
3.1.3 Behavioural profiles by buying status
The figure below isolates the main characteristic in the buying profile: attitude towards buying fast tech. It shows the probability of belonging to the buyer group at each of the five response levels. This is an observed gradient, not a causal effect of changing attitude.
Show R code
format_action_tree_path <- function(path) {
conditions <- path |>
tail(-1)
if (length(conditions) == 0) {
return("All eligible respondents")
}
parsed_conditions <- str_remove_all(
conditions,
"\\s+"
) |>
str_match(
"^(age|attitude_score|injunctive_score)(>=|<)([0-9.]+)$"
) |>
as_tibble(
.name_repair = ~ c(
"condition",
"variable",
"operator",
"threshold"
)
) |>
mutate(
condition_order = row_number(),
threshold = as.numeric(threshold)
) |>
filter(!is.na(variable))
variable_labels <- c(
age = "Age",
attitude_score = "Buying attitude",
injunctive_score = "Perceived approval"
)
parsed_conditions |>
group_by(variable) |>
summarise(
condition_order = min(condition_order),
lower = if (any(operator == ">=")) {
max(threshold[operator == ">="])
} else {
-Inf
},
upper = if (any(operator == "<")) {
min(threshold[operator == "<"])
} else {
Inf
},
.groups = "drop"
) |>
arrange(condition_order) |>
mutate(
lower_display = ceiling(lower),
upper_display = floor(upper - 1e-8),
label = case_when(
is.finite(lower) & is.finite(upper) ~ paste0(
variable_labels[variable],
" ",
lower_display,
"–",
upper_display
),
is.finite(lower) ~ paste0(
variable_labels[variable],
" ≥ ",
lower_display
),
is.finite(upper) ~ paste0(
variable_labels[variable],
" ≤ ",
upper_display
)
)
) |>
pull(label) |>
paste(collapse = " and ")
}
fit_action_tree <- function(
data,
outcome,
seed = 20260805
) {
model_data <- data |>
select(
all_of(outcome),
age,
attitude_score,
injunctive_score,
analysis_weight
) |>
drop_na() |>
mutate(
outcome_numeric = as.integer(
.data[[outcome]] == "Yes"
)
)
set.seed(seed)
tree <- rpart::rpart(
outcome_numeric ~
age +
attitude_score +
injunctive_score,
data = model_data,
weights = analysis_weight,
method = "anova",
control = rpart::rpart.control(
maxdepth = 2,
minbucket = max(
100,
floor(0.05 * nrow(model_data))
),
cp = 0.001,
xval = 10
)
)
cp_table <- tree$cptable
best_row <- which.min(cp_table[, "xerror"])
selected_cp <- cp_table[best_row, "CP"]
tree <- rpart::prune(
tree,
cp = selected_cp
)
leaf_nodes <- as.integer(
row.names(tree$frame)[
tree$frame$var == "<leaf>"
]
)
tree_paths <- rpart::path.rpart(
tree,
nodes = leaf_nodes,
print.it = FALSE
)
profile_labels <- map_chr(
tree_paths,
format_action_tree_path
)
names(profile_labels) <- as.character(leaf_nodes)
profiles <- model_data |>
mutate(
leaf_node = row.names(tree$frame)[tree$where],
Profile = profile_labels[leaf_node]
) |>
group_by(Profile) |>
summarise(
N = n(),
weighted_N = sum(analysis_weight),
outcome_rate = weighted_mean_safe(
outcome_numeric,
analysis_weight
),
.groups = "drop"
) |>
arrange(outcome_rate) |>
mutate(
Profile = factor(Profile, levels = Profile)
)
node_numbers <- as.integer(row.names(tree$frame))
tree_depth <- max(
floor(log(node_numbers, base = 2))
)
list(
data = model_data,
tree = tree,
profiles = profiles,
diagnostics = tibble(
Check = c(
"Complete cases",
"Terminal profiles",
"Maximum tree depth",
"Smallest profile",
"Cross-validation"
),
Result = c(
format_count(nrow(model_data)),
nrow(profiles),
tree_depth,
format_count(min(profiles$N)),
"Used to choose tree size"
)
)
)
}
plot_action_tree_profiles <- function(
tree_results,
x_label
) {
tree_results$profiles |>
ggplot(aes(
x = outcome_rate,
y = Profile,
fill = outcome_rate
)) +
geom_col(width = bg_bar_width) +
geom_text(
aes(label = percent(
outcome_rate,
accuracy = 0.1
)),
hjust = -0.12,
size = bg_size_label / .pt
) +
scale_fill_bg_c(
palette = "seq",
guide = "none"
) +
scale_x_continuous(
labels = percent_format(),
breaks = c(0, 0.25, 0.50, 0.75, 1),
expand = expansion(mult = c(0, 0.02))
) +
scale_y_discrete(
labels = \(x) str_wrap(x, width = 38)
) +
coord_cartesian(
xlim = c(0, 1.12),
clip = "off"
) +
labs(
x = x_label,
y = NULL
)
}
buyer_action_profile_data <- comparative_profile_data |>
transmute(
buyer = factor(
if_else(
buyer_status == "Buyer",
"Yes",
"No"
),
levels = c("No", "Yes")
),
age,
attitude_score,
injunctive_score,
analysis_weight
)
buyer_attitude_design <- survey::svydesign(
ids = ~1,
weights = ~analysis_weight,
data = buyer_action_profile_data |>
mutate(buyer_numeric = as.numeric(buyer == "Yes"))
)
buyer_attitude_probability <- survey::svyby(
~buyer_numeric,
~attitude_score,
design = buyer_attitude_design,
FUN = survey::svymean,
vartype = "ci",
na.rm = TRUE
) |>
as.data.frame() |>
as_tibble() |>
transmute(
Attitude = factor(
attitude_score,
levels = 1:5,
labels = c(
"Completely unfavourable",
"Rather unfavourable",
"Neither favourable nor unfavourable",
"Rather favourable",
"Completely favourable"
)
),
probability = buyer_numeric,
conf_low = ci_l,
conf_high = ci_u
)The probability of being a previous buyer rises from 49.5% among respondents completely unfavourable towards buying to 94.0% among those completely favourable.
Show R code
buyer_attitude_probability |>
ggplot(aes(x = Attitude, y = probability, group = 1)) +
geom_errorbar(
aes(ymin = conf_low, ymax = conf_high),
width = 0.12,
colour = bg_accent_50,
linewidth = bg_lw_line
) +
geom_line(
colour = bg_accent,
linewidth = bg_lw_line
) +
geom_point(
colour = bg_accent,
fill = bg_surface,
shape = 21,
stroke = bg_lw_line,
size = 3.2
) +
geom_text(
aes(label = percent(probability, accuracy = 0.1)),
vjust = -0.9,
size = bg_size_label / .pt
) +
scale_y_continuous(
labels = percent_format(),
limits = c(0, 1),
expand = expansion(mult = c(0, 0.06))
) +
scale_x_discrete(labels = \(x) str_wrap(x, width = 18)) +
labs(
x = "Attitude towards buying fast tech",
y = "Probability of belonging to the buyer group"
)
How to read: The buyer share rises from 49.5% among completely unfavourable respondents to 94.0% among completely favourable respondents.
3.2 Behavioural profiles by disposal method
Here’s a split by age to identify profiles associated with each concrete disposal method.
Show R code
disposal_action_profile_data <-
disposal_pathway_outcome_data |>
left_join(
comparative_profile_data |>
select(
respondent_id,
age,
attitude_score,
injunctive_score,
analysis_weight
),
by = "respondent_id"
)
disposal_action_trees <- imap(
disposal_pathway_labels,
~ fit_action_tree(
disposal_action_profile_data,
outcome = .y,
seed = 20260810 + match(
.y,
names(disposal_pathway_labels)
)
)
)
disposal_action_tree_profiles <- imap_dfr(
disposal_action_trees,
~ .x$profiles |>
mutate(
Pathway = unname(disposal_pathway_labels[.y]),
Profile_text = as.character(Profile)
)
) |>
arrange(Pathway, outcome_rate) |>
mutate(
Profile_plot = paste(
Pathway,
Profile_text,
sep = "___"
),
Profile_plot = factor(
Profile_plot,
levels = unique(Profile_plot)
),
Pathway = factor(
Pathway,
levels = c(
"Recycling centre",
"In-store recycling",
"Household waste",
"Plastic-waste bin",
"Keeping devices"
)
)
)
disposal_action_tree_extremes <-
disposal_action_tree_profiles |>
group_by(Pathway) |>
summarise(
lowest_rate = min(outcome_rate),
highest_rate = max(outcome_rate),
.groups = "drop"
)
disposal_recycling_centre_tree_extreme <-
disposal_action_tree_extremes |>
filter(Pathway == "Recycling centre")
disposal_recycling_centre_tree_low_profile <-
disposal_action_tree_profiles |>
filter(Pathway == "Recycling centre") |>
slice_min(outcome_rate, n = 1, with_ties = FALSE)
disposal_recycling_centre_tree_high_profile <-
disposal_action_tree_profiles |>
filter(Pathway == "Recycling centre") |>
slice_max(outcome_rate, n = 1, with_ties = FALSE)
disposal_kept_tree_high_profile <-
disposal_action_tree_profiles |>
filter(Pathway == "Keeping devices") |>
slice_max(outcome_rate, n = 1, with_ties = FALSE)Note: These profiles are exploratory and should be tested before use.
Show R code
disposal_action_tree_profiles |>
ggplot(aes(
x = outcome_rate,
y = Profile_plot,
fill = Pathway
)) +
geom_col(
width = bg_bar_width,
show.legend = FALSE
) +
geom_text(
aes(label = percent(
outcome_rate,
accuracy = 0.1
)),
hjust = -0.12,
size = bg_size_label / .pt
) +
scale_fill_manual(
values = c(
"Recycling centre" = bg_accent,
"In-store recycling" = bg_accent_50,
"Household waste" = bg_pink,
"Plastic-waste bin" = bg_pink_50,
"Keeping devices" = bg_ink_54
)
) +
scale_x_continuous(
labels = percent_format(),
limits = c(0, 1),
expand = expansion(mult = c(0, 0.12))
) +
scale_y_discrete(
labels = \(x) x |>
str_remove("^[^_]+___") |>
str_wrap(width = 38)
) +
facet_wrap(
~Pathway,
ncol = 1,
scales = "free_y"
) +
labs(
x = "Observed share selecting the method",
y = NULL
)
How to read: The bars compare groups defined by age
NoteShow assumption checks
Every tree is restricted to two levels and requires each terminal profile to contain at least 5% of its complete-case sample. This favours readable and adequately sized profiles. Split points remain sample-dependent, and the five trees should be validated on new data before being used for targeting.
Show R code
imap_dfr(
disposal_action_trees,
~ .x$diagnostics |>
mutate(
Pathway = unname(
disposal_pathway_labels[.y]
)
)
) |>
select(Pathway, Check, Result) |>
gt(groupname_col = "Pathway") |>
gt_bellegarde()| Check | Result |
|---|---|
| Keeping devices | |
| Complete cases | 9,154 |
| Terminal profiles | 2 |
| Maximum tree depth | 1 |
| Smallest profile | 2,227 |
| Cross-validation | Used to choose tree size |
| Household waste | |
| Complete cases | 9,154 |
| Terminal profiles | 4 |
| Maximum tree depth | 2 |
| Smallest profile | 1,561 |
| Cross-validation | Used to choose tree size |
| Plastic-waste bin | |
| Complete cases | 8,266 |
| Terminal profiles | 2 |
| Maximum tree depth | 1 |
| Smallest profile | 1,097 |
| Cross-validation | Used to choose tree size |
| Recycling centre | |
| Complete cases | 9,154 |
| Terminal profiles | 3 |
| Maximum tree depth | 2 |
| Smallest profile | 1,083 |
| Cross-validation | Used to choose tree size |
| In-store recycling | |
| Complete cases | 9,154 |
| Terminal profiles | 1 |
| Maximum tree depth | 0 |
| Smallest profile | 9,154 |
| Cross-validation | Used to choose tree size |
3.3 Associations between methods and motivations
Show R code
charger_disposal_analysis_data <- df |>
mutate(
respondent_id = row_number(),
charger_disposed = as.character(
.data[[
"12months_disposed_Charging & lighting devices"
]]
) %in% c("2", "3", "4", "5", "6")
) |>
inner_join(
disposal_response_data |>
select(respondent_id),
by = "respondent_id"
) |>
filter(charger_disposed)
method_cols_for_matrix <- disposal_method_cols[
!disposal_method_cols %in% c(
"Other...124",
"I don’t remember...125"
)
]
motivation_cols_for_matrix <- disposal_motivation_cols[
disposal_motivation_cols != "Other...132"
]
method_labels <- c(
"I kept them" = "Kept",
"I threw them in general household waste" =
"Household waste",
"I threw them in the plastic waste bin" =
"Plastic-waste bin",
"I threw them in a street bin" = "Street bin",
"I brought them to a recycling centre / municipal waste facility" =
"Recycling centre",
"I brought them to a recycling point in a store" =
"In-store recycling",
"I gave them away or donated" = "Donated",
"I sold them" = "Sold"
)
motivation_labels <- c(
"It’s the easiest solution" = "Easiest solution",
"It’s closest to home" = "Closest to home",
"It’s what I usually do with this kind of waste" =
"Usual practice",
"I did it to protect the environment" =
"Environmental protection",
"It’s what my family and friends do with that kind of waste" =
"Family and friends",
"I didn’t really think about it" = "Did not think",
"didn’t know where else to put it" =
"Did not know where else"
)
method_motivation_matrix <- map_dfr(
method_cols_for_matrix,
function(method) {
map_dfr(
motivation_cols_for_matrix,
function(motivation) {
pair <- charger_disposal_analysis_data |>
filter(
!is.na(.data[[method]]),
!is.na(.data[[motivation]])
) |>
transmute(
analysis_weight,
country = factor(
Country,
levels = model_country_levels
),
method_selected = is_selected(
.data[[method]]
),
motivation_selected = is_selected(
.data[[motivation]]
)
)
a <- weighted_sum_safe(
pair$method_selected & pair$motivation_selected,
pair$analysis_weight
)
b <- weighted_sum_safe(
pair$method_selected & !pair$motivation_selected,
pair$analysis_weight
)
pair_design <- make_analysis_design(pair)
association_model <- survey::svyglm(
motivation_selected ~ method_selected + country,
design = pair_design,
family = quasibinomial()
)
association_test <- survey::regTermTest(
association_model,
~method_selected,
method = "Wald"
)
method_coefficient <- coef(
association_model
)[["method_selectedTRUE"]]
tibble(
Method = method,
Motivation = motivation,
denominator = nrow(pair),
conditional_pct = a / (a + b),
odds_ratio = exp(method_coefficient),
p_value = as.numeric(association_test$p)
)
}
)
}
) |>
mutate(
q_value = p.adjust(
p_value,
method = "BH"
),
Method = factor(
unname(method_labels[Method]),
levels = rev(unname(method_labels))
),
Motivation = factor(
unname(motivation_labels[Motivation]),
levels = unname(motivation_labels)
),
log2_or = log2(odds_ratio),
label = percent(
conditional_pct,
accuracy = 1
)
)
method_motivation_key <- method_motivation_matrix |>
filter(q_value < 0.05) |>
slice_max(
abs(log2_or),
n = 1,
with_ties = FALSE
)Each cell shows the share of people who gave the reason after choosing the method on that row. Green means the reason is more common for that method, pink means it is less common, and white means little difference. Bold percentages mark links that are unlikely to be due to chance. The comparison also allows for differences between countries.
Show R code
method_motivation_matrix |>
ggplot(aes(
x = Motivation,
y = Method,
fill = log2_or
)) +
geom_tile(
colour = bg_surface,
linewidth = 1
) +
geom_text(
aes(
label = label,
fontface = if_else(
q_value < 0.05,
"bold",
"plain"
)
),
colour = bg_ink,
size = (bg_size_label - 1) / .pt
) +
scale_fill_gradient2(
low = bg_pink,
mid = bg_surface,
high = bg_accent,
midpoint = 0,
limits = log2(c(0.25, 4)),
oob = scales::squish,
breaks = log2(c(0.25, 1, 4)),
labels = c(
"Less",
"Similar",
"More"
),
name = "Link"
) +
labs(
x = "Reason for choosing the solution",
y = NULL
) +
theme(
axis.text.x = element_text(
angle = 35,
hjust = 1
),
panel.grid = element_blank(),
legend.position = "top"
)
How to read: 1% of respondents selecting ‘Recycling centre’ also selected ‘Did not think’.
Official recycling channels are mainly associated with established habits and environmental protection, whereas inappropriate disposal methods or keeping devices are more commonly associated with convenience, proximity or a lack of forethought.
3.4 Buying attitude and perceived approval
Show R code
attitude_response_levels <- c(
"Completely unfavourable",
"Rather unfavourable",
"Neither favourable nor unfavourable",
"Rather favourable",
"Completely favourable"
)
injunctive_response_levels <- c(
"Completely disapprove",
"Rather disapprove",
"Neither approve nor disapprove",
"Rather approve",
"Completely approve"
)
attitude_flow_labels <- c(
"Completely\nunfavourable",
"Rather\nunfavourable",
"Neither favourable\nnor unfavourable",
"Rather\nfavourable",
"Completely\nfavourable"
)
injunctive_flow_labels <- c(
"Completely\ndisapprove",
"Rather\ndisapprove",
"Neither approve\nnor disapprove",
"Rather\napprove",
"Completely\napprove"
)
attitude_injunctive_data <- df |>
transmute(
attitude_score = as.numeric(Attitude_buying_recoded),
injunctive_score = as.numeric(
.data[["Injunctive norm_recoded"]]
),
analysis_weight
) |>
drop_na() |>
mutate(
Attitude = factor(
attitude_score,
levels = 1:5,
labels = attitude_flow_labels
),
`Perceived approval` = factor(
injunctive_score,
levels = 1:5,
labels = injunctive_flow_labels
)
)
attitude_injunctive_rho <- weighted_correlation_safe(
rank(attitude_injunctive_data$attitude_score),
rank(attitude_injunctive_data$injunctive_score),
attitude_injunctive_data$analysis_weight
)
attitude_injunctive_direction <- if_else(
attitude_injunctive_rho >= 0,
"positive",
"negative"
)
attitude_injunctive_strength <- case_when(
abs(attitude_injunctive_rho) < 0.10 ~ "very weak",
abs(attitude_injunctive_rho) < 0.30 ~ "weak",
abs(attitude_injunctive_rho) < 0.50 ~ "moderate",
abs(attitude_injunctive_rho) < 0.70 ~ "strong",
TRUE ~ "very strong"
)
attitude_injunctive_flow <- attitude_injunctive_data |>
group_by(Attitude, `Perceived approval`) |>
summarise(
n = n(),
weighted_n = sum(analysis_weight),
.groups = "drop"
) |>
mutate(pct = weighted_n / sum(weighted_n))Buying attitude and perceived approval show a strong positive association (correlation = 0.58). Respondents who are more favourable towards buying fast tech therefore also tend to perceive greater approval from people important to them.
Show R code
attitude_injunctive_flow |>
ggplot(aes(
axis1 = Attitude,
axis2 = `Perceived approval`,
y = weighted_n
)) +
ggalluvial::geom_alluvium(
aes(fill = Attitude),
width = 0.24,
alpha = 0.55,
knot.pos = 0.45
) +
ggalluvial::geom_stratum(
width = 0.24,
fill = bg_surface,
colour = bg_ink_32,
linewidth = bg_lw_hairline
) +
ggalluvial::stat_stratum(
geom = "text",
aes(label = after_stat(stratum)),
size = (bg_size_label - 2) / .pt,
lineheight = 0.9
) +
scale_fill_manual(
values = setNames(
bg_ramp("seq", 5),
attitude_flow_labels
),
guide = "none"
) +
scale_x_discrete(
limits = c(
"Buying attitude",
"Perceived approval"
),
expand = expansion(mult = c(0.22, 0.22))
) +
scale_y_continuous(
breaks = NULL,
labels = NULL
) +
labs(
x = NULL,
y = NULL
) +
theme(
panel.grid = element_blank()
)
How to read: A majority of respondents who are completely favourable mainly think that people important to them completely approve of buying fast tech devices
Note: Wider flows mean that the response is more common.
Citation
BibTeX citation:
@report{naczaj2026,
author = {Naczaj, Dimitri and Bonetto, Éric},
publisher = {Bellegarde Scientific Consulting for the WEEE Forum},
title = {Fast-Tech {Consumer} {Study}},
date = {2026},
langid = {en-GB}
}
For attribution, please cite this work as:
Naczaj, D., & Bonetto, É. (2026). Fast-Tech Consumer Study.
Bellegarde Scientific Consulting for the WEEE Forum.