# Load packages
library(tidyverse)
library(here)
library(patchwork)
library(jsonlite)
library(gt)
library(gtsummary)
# Set paths
path_processed <- here("04_Data", "02_Processed")
path_figures <- here("06_Results", "02_Figures")
# Create figure directory if it doesn't exist
if (!dir.exists(path_figures)) dir.create(path_figures, recursive = TRUE)
# Color palette
col_blue <- "#4E79A7"
col_red <- "#E15759"
col_green <- "#59A14F"
col_orange <- "#F28E2B"
col_purple <- "#B07AA1"# Load final cleaned dataset
df <- read_rds(file.path(path_processed, "all_apps_wide_final.rds"))
n_total <- nrow(df)
n_vars <- ncol(df)Datensatz: 133 Teilnehmer × 112 Variablen
Das Modell von Wagner & Akbari (2023) basiert auf vier individuellen Parametern:
| Parameter | Symbol | Messung (Experiment-Teil) |
|---|---|---|
| Consumption Utility | \(r\) | Teil 1: BDM-Mechanismus |
| Generosity | \(\lambda\) | Teil 3: Zweistufige Fairness-Bewertung |
| Advantageous Inequity Aversion | \(\gamma\) | Teil 5: Modifiziertes Diktator-Spiel |
| Disadvantageous Inequity Aversion | \(\beta\) | Teil 4: Modifiziertes Ultimatum-Spiel |
Dieses Skript schätzt alle vier Parameter und validiert die Schätzungen.
# Prepare data: replace Inf with NA
df_desc_apa <- df |>
mutate(lowerbeta = if_else(is.infinite(lowerbeta), NA_real_, lowerbeta))
# Calculate PWYW non-purchase rate for note
n_no_purchase_apa <- sum(df$pwyw_no_purchase == TRUE, na.rm = TRUE)
pct_no_purchase_apa <- round(100 * n_no_purchase_apa / nrow(df), 1)
# Using apa_desc() pipeline function with Median
df_desc_apa |>
apa_desc(
willingness_to_pay, production_costs, generosity, lowerbeta,
pay_what_you_want, fair_price, p_threshold,
recalled_mug_price, estimated_shop_price, estimated_production_cost,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(
willingness_to_pay = "Zahlungsbereitschaft (WTP, €)",
production_costs = "Herstellungskosten (c, €)",
generosity = "Generosity (λ)",
lowerbeta = "Disadv. Inequity Aversion (β)",
pay_what_you_want = "PWYW-Preis (€)",
fair_price = "Fairer Preis (€)",
p_threshold = "BDM-Schwellenpreis (€)",
recalled_mug_price = "Erinnerter Shop-Preis (€)",
estimated_shop_price = "Geschätzter Ladenpreis (€)",
estimated_production_cost = "Geschätzte Herstellungskosten (€)"
),
note = paste0(
"PWYW = Pay What You Want. Mdn = Median. ",
"PWYW-Nicht-Käufer: *n* = ", n_no_purchase_apa, " (", pct_no_purchase_apa, "%)."
)
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| Zahlungsbereitschaft (WTP, €) | 133 | 5.16 | 3.48 | 4.50 | 0.40 | 15.00 |
| Herstellungskosten (c, €) | 133 | 2.58 | 1.74 | 2.25 | 0.20 | 7.50 |
| Generosity (λ) | 133 | 0.45 | 0.28 | 0.44 | 0.00 | 1.00 |
| Disadv. Inequity Aversion (β) | 118 | 1.65 | 3.93 | 0.33 | 0.00 | 19.00 |
| PWYW-Preis (€) | 103 | 3.04 | 2.41 | 2.50 | 0.00 | 11.00 |
| Fairer Preis (€) | 133 | 3.71 | 2.53 | 3.25 | 0.20 | 11.51 |
| BDM-Schwellenpreis (€) | 133 | 5.02 | 0.42 | 5.00 | 4.50 | 5.50 |
| Erinnerter Shop-Preis (€) | 133 | 9.06 | 0.23 | 9.00 | 9.00 | 10.00 |
| Geschätzter Ladenpreis (€) | 133 | 9.26 | 4.18 | 9.00 | 1.50 | 20.00 |
| Geschätzte Herstellungskosten (€) | 133 | 2.43 | 1.82 | 2.00 | 0.20 | 10.00 |
| Note. PWYW = Pay What You Want. Mdn = Median. PWYW-Nicht-Käufer: n = 30 (22.6%). | ||||||
Diese Tabelle zeigt deskriptive Statistiken für alle zentralen Variablen, die zur Schätzung der vier Modellparameter verwendet werden:
Der Parameter \(\gamma\) (Advantageous Inequity Aversion) wird im Verlauf der Analyse aus den Entscheidungen im modifizierten Diktator-Spiel geschätzt.
\(r_i\) beschreibt den individuellen Konsumnutzen — den Nutzen, den ein Käufer aus dem Konsum des Gutes zieht. Die Messung erfolgt über die Zahlungsbereitschaft (WTP) mittels BDM-Mechanismus (Becker, DeGroot & Marschak, 1964).
Modellannahme: \(r\) ist gleichverteilt: \(\phi(r) = 1\) im Intervall \([0, 1]\).
Im Experiment: \(\tilde{r}_i\) = willingness_to_pay (in €), Schwellenpreis p_threshold ∈ {4.50, 5.00, 5.50}.
# Histogram with density curve on left
p_hist <- ggplot(df, aes(x = willingness_to_pay)) +
geom_histogram(aes(y = after_stat(density)), binwidth = 1,
fill = col_blue, color = "white", alpha = 0.6) +
geom_density(fill = col_blue, alpha = 0.3, linewidth = 0.8) +
geom_vline(aes(xintercept = mean(willingness_to_pay, na.rm = TRUE)),
linetype = "dashed", color = col_red, linewidth = 0.8) +
geom_rug(alpha = 0.3) +
annotate("text",
x = mean(df$willingness_to_pay, na.rm = TRUE) + 0.5,
y = Inf, vjust = 2, hjust = 0,
label = paste0("M = ", round(mean(df$willingness_to_pay, na.rm = TRUE), 2), " €"),
color = col_red, size = 4) +
labs(x = "Zahlungsbereitschaft (€)", y = "Dichte",
title = "Verteilung der WTP (BDM-Mechanismus)") +
scale_x_continuous(breaks = seq(0, 25, 2)) +
theme_minimal()
# Boxplot on right
p_box <- ggplot(df, aes(y = willingness_to_pay)) +
geom_boxplot(fill = col_blue, alpha = 0.4, width = 0.3) +
labs(y = "WTP (€)") +
theme_minimal() +
theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
# Combine plots
p_hist + p_box + plot_layout(widths = c(4, 1))
# Standardize WTP to [0, 1]
r_max <- max(df$willingness_to_pay, na.rm = TRUE)
if (!"r_std" %in% names(df)) {
df <- df |>
mutate(r_std = willingness_to_pay / r_max)
}
calc_binwidth <- 1 / r_max
# KS-Test: standardized WTP vs. Uniform(0, 1)
ks_result <- ks.test(df$r_std, "punif", 0, 1)
tibble(
Test = "Kolmogorov-Smirnov",
`H₀` = "WTP ist gleichverteilt auf [0, 1]",
D = round(ks_result$statistic, 4),
`p-Wert` = format.pval(ks_result$p.value, digits = 3),
Ergebnis = ifelse(ks_result$p.value < 0.05,
"H₀ verworfen — nicht gleichverteilt",
"H₀ nicht verworfen — Gleichverteilung plausibel")
) |>
knitr::kable(caption = "KS-Test: WTP-Standardisiert vs. Gleichverteilung U(0,1)")| Test | H₀ | D | p-Wert | Ergebnis |
|---|---|---|---|---|
| Kolmogorov-Smirnov | WTP ist gleichverteilt auf [0, 1] | 0.3378 | 1.3e-13 | H₀ verworfen — nicht gleichverteilt |
ggplot(df, aes(x = r_std)) +
geom_histogram(aes(y = after_stat(density)),
binwidth = calc_binwidth, boundary = 0,
fill = col_blue, color = "white", alpha = 0.7) +
geom_hline(yintercept = 1, linetype = "dashed", color = col_red, linewidth = 0.8) +
annotate("text", x = 0.9, y = 1.1, label = "Gleichverteilung (Theorie)",
color = col_red, hjust = 1, size = 4) +
labs(x = expression(r[i]^{std} == tilde(r)[i] / r[max]),
y = "Dichte",
title = "Standardisierte WTP vs. theoretische Gleichverteilung",
subtitle = paste0("KS-Test: D = ", round(ks_result$statistic, 3),
", p = ", format.pval(ks_result$p.value, digits = 3))) +
scale_x_continuous(breaks = seq(0, 1, 0.1)) +
theme_minimal()
ggplot(df, aes(sample = r_std)) +
stat_qq(distribution = qunif, color = col_blue, alpha = 0.6) +
stat_qq_line(distribution = qunif, color = col_red, linewidth = 0.8) +
labs(x = "Theoretische Quantile (Gleichverteilung)",
y = "Empirische Quantile (standardisierte WTP)",
title = "Q-Q-Plot: WTP vs. U(0,1)") +
coord_equal() +
theme_minimal()
Die Ergebnisse (KS-Test, Histogramm, Q-Q-Plot) zeigen deutlich, dass die Gleichverteilungsannahme (\(r \sim U[0,1]\)) für die empirischen Daten nicht gegeben ist. Die Verteilung der Zahlungsbereitschaft weicht signifikant von der theoretisch angenommenen Uniformverteilung ab.
df |>
apa_desc(
willingness_to_pay, pay_what_you_want, first_not_buy_price,
recalled_mug_price, estimated_shop_price, estimated_production_cost,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(
willingness_to_pay = "WTP (BDM)",
pay_what_you_want = "PWYW Preis (Teil 2)",
first_not_buy_price = "Beta-Schwellenpreis (Teil 4)",
recalled_mug_price = "Erinnerter Shop-Preis",
estimated_shop_price = "Geschätzter Ladenpreis",
estimated_production_cost = "Geschätzte Herstellungskosten"
),
note = "Alle Werte in Euro (€). Mdn = Median."
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| WTP (BDM) | 133 | 5.16 | 3.48 | 4.50 | 0.40 | 15.00 |
| PWYW Preis (Teil 2) | 103 | 3.04 | 2.41 | 2.50 | 0.00 | 11.00 |
| Beta-Schwellenpreis (Teil 4) | 96 | 4.01 | 2.87 | 3.26 | 0.30 | 14.25 |
| Erinnerter Shop-Preis | 133 | 9.06 | 0.23 | 9.00 | 9.00 | 10.00 |
| Geschätzter Ladenpreis | 133 | 9.26 | 4.18 | 9.00 | 1.50 | 20.00 |
| Geschätzte Herstellungskosten | 133 | 2.43 | 1.82 | 2.00 | 0.20 | 10.00 |
| Note. Alle Werte in Euro (€). Mdn = Median. | ||||||
df |>
apa_cor(
willingness_to_pay, pay_what_you_want, first_not_buy_price,
recalled_mug_price, estimated_shop_price, estimated_production_cost,
labels = c(
willingness_to_pay = "WTP (BDM)",
pay_what_you_want = "PWYW Preis",
first_not_buy_price = "Beta-Schwelle",
recalled_mug_price = "Erinnerter Preis",
estimated_shop_price = "Geschätzter Laden",
estimated_production_cost = "Geschätzte Kosten"
)
)| Variable | n | M | SD | 1 | 2 | 3 | 4 | 5 | 6 |
|---|---|---|---|---|---|---|---|---|---|
| 1. WTP (BDM) | 133 | 5.16 | 3.48 | — | |||||
| 2. PWYW Preis | 103 | 3.04 | 2.41 | 0.80*** | — | ||||
| 3. Beta-Schwelle | 96 | 4.01 | 2.87 | 0.93*** | 0.82*** | — | |||
| 4. Erinnerter Preis | 133 | 9.06 | 0.23 | 0.00 | 0.07 | 0.07 | — | ||
| 5. Geschätzter Laden | 133 | 9.26 | 4.18 | 0.37*** | 0.24* | 0.46*** | 0.00 | — | |
| 6. Geschätzte Kosten | 133 | 2.43 | 1.82 | 0.60*** | 0.57*** | 0.59*** | -0.12 | 0.42*** | — |
| *p < .05. **p < .01. ***p < .001. | |||||||||
# Define reference variables and labels for scatter plots
scatter_vars <- c("pay_what_you_want", "first_not_buy_price", "recalled_mug_price",
"estimated_shop_price", "estimated_production_cost")
scatter_labels <- c("PWYW Preis (€)", "Beta-Schwellenpreis (€)", "Erinnerter Shop-Preis (€)",
"Geschätzter Ladenpreis (€)", "Geschätzte Herstellungskosten (€)")
# Create scatter plots with correlation info
scatter_plots <- map2(scatter_vars, scatter_labels, function(var, label) {
d <- df |> filter(!is.na(willingness_to_pay), !is.na(.data[[var]]))
ct <- cor.test(d$willingness_to_pay, d[[var]], method = "pearson")
sub_label <- sprintf("r = %.2f, p = %s, n = %d",
ct$estimate, format.pval(ct$p.value, digits = 3, eps = 0.001), nrow(d))
ggplot(d, aes(x = .data[[var]], y = willingness_to_pay)) +
geom_point(alpha = 0.5, color = col_blue) +
geom_smooth(method = "lm", formula = y ~ x, se = TRUE, color = col_red, linewidth = 0.8) +
geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "grey50") +
labs(x = label, y = "WTP (€)", subtitle = sub_label) +
theme_minimal()
})
# Combine with patchwork: 2 columns, 3 rows
wrap_plots(scatter_plots, ncol = 2) +
plot_annotation(title = "WTP vs. Referenzpreise")
source(here::here("05_Analysis", "R", "apa_tables.R"))
composite_labels <- c(
willingness_to_pay = "WTP (€)",
altruism_composite = "Altruismus",
price_consciousness = "Preisbewusstsein",
experiment_experience = "Experiment-Erfahrung",
product_reaction = "Produktreaktion",
fairness_self = "Preisfairness"
)
df |>
apa_cor(willingness_to_pay, altruism_composite, price_consciousness,
experiment_experience, product_reaction, fairness_self,
labels = composite_labels)| Variable | n | M | SD | 1 | 2 | 3 | 4 | 5 | 6 |
|---|---|---|---|---|---|---|---|---|---|
| 1. WTP (€) | 133 | 5.16 | 3.48 | — | |||||
| 2. Altruismus | 133 | 4.70 | 0.91 | 0.14 | — | ||||
| 3. Preisbewusstsein | 133 | 4.71 | 1.00 | -0.18* | 0.04 | — | |||
| 4. Experiment-Erfahrung | 133 | 5.98 | 1.00 | 0.20* | 0.11 | -0.17 | — | ||
| 5. Produktreaktion | 133 | 4.03 | 1.60 | 0.07 | 0.13 | 0.11 | 0.26** | — | |
| 6. Preisfairness | 133 | 5.37 | 1.65 | 0.17 | 0.11 | 0.15 | 0.13 | 0.23** | — |
| *p < .05. **p < .01. ***p < .001. | |||||||||
Für die weitere Modellanalyse wird \(r\) auf \([0, 1]\) standardisiert:
\[r_i^{std} = \frac{\tilde{r}_i}{r_{max}}\]
df |>
apa_desc(
r_std,
stats = c("n", "M", "SD", "Min", "Max"),
labels = c(r_std = paste0("r_std (r_max = ", r_max, "€)"))
)| Variable | n | M | SD | Min | Max |
|---|---|---|---|---|---|
| r_std (r_max = 15€) | 133 | 0.34 | 0.23 | 0.03 | 1.00 |
Dieser Abschnitt analysiert das beobachtete PWYW-Verhalten entlang zweier Outcomes:
pwyw_no_purchase (1 = nicht gekauft, 0 = gekauft)pay_what_you_want (in €)Fokus: Verteilungen, Vergleich mit WTP und fairem Preis, Verhältniskennzahlen sowie Einfluss weiterer Variablen.
df_pwyw <- df |>
mutate(
pwyw_no_purchase = as.integer(pwyw_no_purchase),
purchased = case_when(
pwyw_no_purchase == 0 ~ TRUE,
pwyw_no_purchase == 1 ~ FALSE,
TRUE ~ NA
),
pwyw_ratio_wtp = if_else(willingness_to_pay > 0,
pay_what_you_want / willingness_to_pay,
NA_real_),
pwyw_ratio_fair = if_else(fair_price > 0,
pay_what_you_want / fair_price,
NA_real_),
pwyw_gap_wtp = pay_what_you_want - willingness_to_pay,
pwyw_gap_fair = pay_what_you_want - fair_price
)pwyw_freq <- df_pwyw |>
filter(!is.na(pwyw_no_purchase)) |>
mutate(
Entscheidung = if_else(pwyw_no_purchase == 1,
"Nicht gekauft",
"Gekauft")
) |>
count(Entscheidung, name = "n") |>
mutate(Prozent = round(100 * n / sum(n), 1))pwyw_freq |>
ggplot(aes(x = Entscheidung, y = n, fill = Entscheidung)) +
geom_col(alpha = 0.8, width = 0.6) +
geom_text(aes(label = paste0(n, " (", Prozent, "%)")), vjust = -0.3) +
scale_fill_manual(values = c("Gekauft" = col_blue, "Nicht gekauft" = col_red), guide = "none") +
labs(x = NULL, y = "Anzahl Teilnehmer") +
theme_minimal()
# Filter to buyers only (non-buyers have no PWYW price)
df_buyers <- df_pwyw |>
filter(pwyw_no_purchase == 0, !is.na(pay_what_you_want))
# Histogram with density curve on left (matching 05.02 style)
p_hist <- ggplot(df_buyers, aes(x = pay_what_you_want)) +
geom_histogram(aes(y = after_stat(density)), binwidth = 0.5,
fill = col_blue, color = "white", alpha = 0.6) +
geom_density(fill = col_blue, alpha = 0.3, linewidth = 0.8) +
geom_vline(aes(xintercept = mean(pay_what_you_want, na.rm = TRUE)),
linetype = "dashed", color = col_red, linewidth = 0.8) +
geom_rug(alpha = 0.3) +
annotate("text",
x = mean(df_buyers$pay_what_you_want, na.rm = TRUE) + 0.3,
y = Inf, vjust = 2, hjust = 0,
label = paste0("M = ", round(mean(df_buyers$pay_what_you_want, na.rm = TRUE), 2), " €"),
color = col_red, size = 4) +
labs(x = "PWYW-Preis (€)", y = "Dichte",
title = "Verteilung des PWYW-Preises (nur Käufer)") +
scale_x_continuous(breaks = seq(0, 15, 1)) +
theme_minimal()
# Boxplot on right
p_box <- ggplot(df_buyers, aes(y = pay_what_you_want)) +
geom_boxplot(fill = col_blue, alpha = 0.4, width = 0.3) +
labs(y = "PWYW-Preis (€)") +
theme_minimal() +
theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
# Combine plots
p_hist + p_box + plot_layout(widths = c(4, 1))
# Use apa_desc_by for group comparison with t-test
df_purchase <- df_pwyw |>
filter(!is.na(pwyw_no_purchase)) |>
mutate(Entscheidung = factor(
if_else(pwyw_no_purchase == 1, "Nicht gekauft", "Gekauft"),
levels = c("Gekauft", "Nicht gekauft")
))
df_purchase |>
apa_desc_by(
willingness_to_pay, fair_price, gamma_estimate,
by = Entscheidung,
labels = c(
willingness_to_pay = "WTP (€)",
fair_price = "Fairer Preis (€)",
gamma_estimate = "γ (Inequity Aversion)"
)
)| Variable |
Gekauft
|
Nicht gekauft
|
t | df | p | d | ||
|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | |||||
| WTP (€) | 4.95 | 3.44 | 5.87 | 3.60 | −1.24 | 45.52 | .220 | 0.26 |
| Fairer Preis (€) | 3.55 | 2.48 | 4.23 | 2.68 | −1.24 | 44.41 | .220 | 0.27 |
| γ (Inequity Aversion) | 1.35 | 0.49 | 1.36 | 0.53 | −0.10 | 34.61 | .918 | 0.02 |
| Note. Effect size is Cohen’s d. | ||||||||
# Descriptive statistics for buyers only
df_buyers <- df_pwyw |>
filter(pwyw_no_purchase == 0, !is.na(pay_what_you_want))
df_buyers |>
apa_desc(
pay_what_you_want, pwyw_ratio_wtp, pwyw_ratio_fair,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(
pay_what_you_want = "PWYW-Preis (€)",
pwyw_ratio_wtp = "PWYW / WTP",
pwyw_ratio_fair = "PWYW / Fairer Preis"
)
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| PWYW-Preis (€) | 103 | 3.04 | 2.41 | 2.50 | 0.00 | 11.00 |
| PWYW / WTP | 103 | 0.65 | 0.26 | 0.67 | 0.00 | 1.00 |
| PWYW / Fairer Preis | 103 | 0.91 | 0.39 | 0.95 | 0.00 | 2.00 |
scatter_df <- df_pwyw |>
filter(pwyw_no_purchase == 0,
is.finite(pay_what_you_want),
is.finite(willingness_to_pay),
is.finite(fair_price))
cor_wtp <- cor(scatter_df$pay_what_you_want, scatter_df$willingness_to_pay, use = "complete.obs")
cor_fair <- cor(scatter_df$pay_what_you_want, scatter_df$fair_price, use = "complete.obs")
p_wtp <- ggplot(scatter_df, aes(x = willingness_to_pay, y = pay_what_you_want)) +
geom_point(color = col_blue, alpha = 0.7, size = 2) +
geom_smooth(method = "lm", formula = y ~ x, se = FALSE, color = col_red, linewidth = 0.8) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey40") +
labs(
title = "PWYW vs. WTP",
subtitle = paste0("r = ", round(cor_wtp, 3)),
x = "WTP (€)",
y = "PWYW-Preis (€)"
) +
theme_minimal()
p_fair <- ggplot(scatter_df, aes(x = fair_price, y = pay_what_you_want)) +
geom_point(color = col_green, alpha = 0.7, size = 2) +
geom_smooth(method = "lm", formula = y ~ x, se = FALSE, color = col_red, linewidth = 0.8) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey40") +
labs(
title = "PWYW vs. fairer Preis",
subtitle = paste0("r = ", round(cor_fair, 3)),
x = "Fairer Preis (€)",
y = "PWYW-Preis (€)"
) +
theme_minimal()
p_wtp + p_fair
# Define buyer segments based on payment amount
df_buyer_segments <- df_pwyw |>
filter(pwyw_no_purchase == 0, !is.na(pay_what_you_want)) |>
mutate(
buyer_segment = case_when(
pay_what_you_want == 0 ~ "Freeloaders (0 €)",
abs(pay_what_you_want - production_costs) < 0.01 ~ "Zahlung = Kosten",
abs(pay_what_you_want - fair_price) < 0.01 ~ "Zahlung = fairer Preis",
TRUE ~ "Andere Zahlung"
),
buyer_segment = factor(buyer_segment,
levels = c("Freeloaders (0 €)", "Zahlung = Kosten",
"Zahlung = fairer Preis", "Andere Zahlung")),
# Sub-segment for "Andere Zahlung"
andere_sub = case_when(
buyer_segment != "Andere Zahlung" ~ NA_character_,
pay_what_you_want > fair_price ~ "mehr als fair",
pay_what_you_want < fair_price ~ "weniger als fair",
TRUE ~ NA_character_
)
)# Using apa_desc_segments() for hierarchical segment table
df_buyer_segments |>
apa_desc_segments(
pay_what_you_want, willingness_to_pay, fair_price, gamma_estimate,
by = buyer_segment,
sub_by = andere_sub,
parent_segment = "Andere Zahlung",
stats = c("n", "pct", "M", "SD"),
ratio_vars = list(
"PWYW/WTP" = c("pay_what_you_want", "willingness_to_pay"),
"PWYW/Fair" = c("pay_what_you_want", "fair_price")
),
labels = c(
pay_what_you_want = "PWYW",
willingness_to_pay = "WTP",
fair_price = "Fair",
gamma_estimate = "γ"
),
note = "*Note.* PWYW/WTP, PWYW/Fair: Arithmetic mean of individual ratios."
)| Segment | n | Prozent | PWYW (M) | PWYW (SD) | WTP (M) | WTP (SD) | Fair (M) | Fair (SD) | γ (M) | γ (SD) | PWYW/WTP | PWYW/Fair |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Andere Zahlung | 78.00 | 75.70 | 3.11 | 2.31 | 4.83 | 3.38 | 3.52 | 2.46 | 1.32 | 0.44 | 0.69 | 0.97 |
| → weniger als fair | 42.00 | 40.80 | 3.14 | 2.35 | 5.76 | 3.58 | 4.40 | 2.55 | 1.34 | 0.44 | 0.56 | 0.72 |
| → mehr als fair | 36.00 | 35.00 | 3.07 | 2.30 | 3.74 | 2.81 | 2.50 | 1.92 | 1.30 | 0.45 | 0.85 | 1.27 |
| Zahlung = fairer Preis | 10.00 | 9.70 | 4.70 | 2.95 | 6.45 | 4.31 | 4.70 | 2.96 | 1.32 | 0.56 | 0.77 | 1.00 |
| Freeloaders (0 €) | 5.00 | 4.90 | 0.00 | 0.00 | 4.20 | 2.89 | 2.50 | 1.73 | 1.40 | 0.55 | 0.00 | 0.00 |
| Zahlung = Kosten | 10.00 | 9.70 | 2.38 | 1.63 | 4.75 | 3.26 | 3.14 | 2.31 | 1.58 | 0.70 | 0.50 | 0.78 |
| Note. Note. PWYW/WTP, PWYW/Fair: Arithmetic mean of individual ratios. | ||||||||||||
segment_colors <- c(
"Freeloaders (0 €)" = col_red,
"Zahlung = Kosten" = col_orange,
"Zahlung = fairer Preis" = col_green,
"Andere Zahlung" = col_blue
)
df_buyer_segments |>
count(buyer_segment) |>
mutate(pct = round(100 * n / sum(n), 1)) |>
ggplot(aes(x = buyer_segment, y = n, fill = buyer_segment)) +
geom_col(alpha = 0.8, width = 0.7) +
geom_text(aes(label = paste0(n, " (", pct, "%)")), vjust = -0.3) +
scale_fill_manual(values = segment_colors, guide = "none") +
labs(x = NULL, y = "Anzahl Käufer",
title = "Käufersegmente nach Zahlungshöhe") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 15, hjust = 1))
# Prepare long format for faceted boxplots
df_segments_long <- df_buyer_segments |>
select(buyer_segment, pay_what_you_want, fair_price, gamma_estimate) |>
pivot_longer(cols = c(pay_what_you_want, fair_price, gamma_estimate),
names_to = "variable", values_to = "value") |>
mutate(
variable = factor(variable,
levels = c("pay_what_you_want", "fair_price", "gamma_estimate"),
labels = c("PWYW-Preis (€)", "Fairer Preis (€)", "γ (Inequity Aversion)"))
)
ggplot(df_segments_long, aes(x = buyer_segment, y = value, fill = buyer_segment)) +
geom_boxplot(alpha = 0.7, outlier.alpha = 0.5) +
facet_wrap(~ variable, scales = "free_y", ncol = 3) +
scale_fill_manual(values = segment_colors, guide = "none") +
labs(x = NULL, y = NULL) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 25, hjust = 1, size = 9))
# Define variables for correlation matrix
main_vars <- c("pay_what_you_want", "willingness_to_pay", "fair_price", "gamma_estimate")
# Composite variables (check if they exist in the data)
composite_candidates <- c("altruism_composite", "price_consciousness",
"experiment_experience", "product_reaction", "fairness_self")
composite_vars <- intersect(composite_candidates, names(df_buyers))
all_vars <- c(main_vars, composite_vars)
# APA correlation table
df_buyers |>
select(all_of(all_vars)) |>
drop_na() |>
apa_cor(
pay_what_you_want, willingness_to_pay, fair_price, gamma_estimate,
altruism_composite, price_consciousness, experiment_experience,
product_reaction, fairness_self,
labels = c(
pay_what_you_want = "PWYW-Preis",
willingness_to_pay = "WTP",
fair_price = "Fairer Preis",
gamma_estimate = "γ (IA)",
altruism_composite = "Altruismus",
price_consciousness = "Preisbewusstsein",
experiment_experience = "Exp.-Erfahrung",
product_reaction = "Produktreaktion",
fairness_self = "Preisfairness"
)
)| Variable | n | M | SD | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 1. PWYW-Preis | 101 | 3.05 | 2.43 | — | ||||||||
| 2. WTP | 101 | 4.96 | 3.47 | 0.80*** | — | |||||||
| 3. Fairer Preis | 101 | 3.54 | 2.50 | 0.83*** | 0.95*** | — | ||||||
| 4. γ (IA) | 101 | 1.35 | 0.49 | -0.09 | -0.07 | -0.06 | — | |||||
| 5. Altruismus | 101 | 4.70 | 0.97 | 0.23* | 0.18 | 0.17 | 0.17 | — | ||||
| 6. Preisbewusstsein | 101 | 4.76 | 0.97 | -0.18 | -0.18 | -0.16 | -0.09 | -0.01 | — | |||
| 7. Exp.-Erfahrung | 101 | 5.96 | 1.01 | 0.29** | 0.36*** | 0.34*** | -0.10 | 0.17 | -0.18 | — | ||
| 8. Produktreaktion | 101 | 4.39 | 1.48 | 0.24* | 0.18 | 0.16 | -0.33*** | 0.18 | -0.00 | 0.31** | — | |
| 9. Preisfairness | 101 | 5.55 | 1.58 | 0.33*** | 0.23* | 0.23* | -0.09 | 0.02 | 0.11 | 0.18 | 0.18 | — |
| *p < .05. **p < .01. ***p < .001. | ||||||||||||
df_buyers |>
apa_desc(
pay_what_you_want, willingness_to_pay, fair_price, gamma_estimate,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(
pay_what_you_want = "PWYW-Preis (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fairer Preis (€)",
gamma_estimate = "γ (Inequity Aversion)"
)
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| PWYW-Preis (€) | 103 | 3.04 | 2.41 | 2.50 | 0.00 | 11.00 |
| WTP (€) | 103 | 4.95 | 3.44 | 4.00 | 0.40 | 15.00 |
| Fairer Preis (€) | 103 | 3.55 | 2.48 | 3.00 | 0.20 | 11.25 |
| γ (Inequity Aversion) | 101 | 1.35 | 0.49 | 1.00 | 1.00 | 2.90 |
fp_data <- df |>
filter(!is.na(fair_price), !is.na(willingness_to_pay), !is.na(production_costs)) |>
mutate(
ratio_fair_wtp = if_else(willingness_to_pay > 0, fair_price / willingness_to_pay, NA_real_),
ratio_fair_cost = if_else(production_costs > 0, fair_price / production_costs, NA_real_),
ratio_pwyw_fair = if_else(fair_price > 0, pay_what_you_want / fair_price, NA_real_)
)
# Count: Fair = Kosten (exakt)
n_fair_equals_cost <- sum(abs(fp_data$fair_price - fp_data$production_costs) < 0.01, na.rm = TRUE)
pct_fair_equals_cost <- round(100 * n_fair_equals_cost / nrow(fp_data), 1)
fp_data |>
apa_desc(
fair_price, willingness_to_pay, production_costs,
ratio_fair_wtp, ratio_fair_cost, ratio_pwyw_fair,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(
fair_price = "Fairer Preis (p_f)",
willingness_to_pay = "WTP (r)",
production_costs = "Herstellungskosten (c)",
ratio_fair_wtp = "Ratio p_f / WTP",
ratio_fair_cost = "Ratio p_f / Kosten",
ratio_pwyw_fair = "Ratio PWYW / p_f"
),
note = paste0("Fair = Kosten (exakt): *n* = ", n_fair_equals_cost,
" (", pct_fair_equals_cost, "%).")
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| Fairer Preis (p_f) | 133 | 3.71 | 2.53 | 3.25 | 0.20 | 11.51 |
| WTP (r) | 133 | 5.16 | 3.48 | 4.50 | 0.40 | 15.00 |
| Herstellungskosten (c) | 133 | 2.58 | 1.74 | 2.25 | 0.20 | 7.50 |
| Ratio p_f / WTP | 133 | 0.73 | 0.14 | 0.72 | 0.40 | 1.00 |
| Ratio p_f / Kosten | 133 | 1.45 | 0.28 | 1.44 | 0.80 | 2.00 |
| Ratio PWYW / p_f | 103 | 0.91 | 0.39 | 0.95 | 0.00 | 2.00 |
| Note. Fair = Kosten (exakt): n = 7 (5.3%). | ||||||
df_fp_wtp <- df |>
filter(!is.na(fair_price), !is.na(willingness_to_pay), !is.na(generosity))
# Left panel: Fair Price vs WTP
p1 <- df_fp_wtp |>
ggplot(aes(x = willingness_to_pay, y = fair_price)) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey50", alpha = 0.5) +
geom_abline(slope = 0.5, intercept = 0, linetype = "dotted", color = col_green, alpha = 0.7) +
geom_smooth(method = "lm", formula = y ~ x, se = FALSE, color = "black", linewidth = 0.7, alpha = 0.7) +
geom_point(aes(color = generosity), size = 3, alpha = 0.7) +
scale_color_gradient2(low = col_red, mid = col_orange, high = col_green,
midpoint = 0.5, name = expression(lambda)) +
labs(x = "WTP (r) in €", y = "Fairer Preis (p_f) in €",
title = "Fairer Preis vs. WTP",
subtitle = paste0(
"Pearson r = ",
round(cor(df_fp_wtp$fair_price, df_fp_wtp$willingness_to_pay, use = "complete.obs"), 2),
", N = ", nrow(df_fp_wtp)
)) +
coord_fixed(xlim = c(0, 15), ylim = c(0, 15)) +
scale_x_continuous(breaks = seq(0, 15, 5)) +
scale_y_continuous(breaks = seq(0, 15, 5)) +
theme_minimal()
# Middle panel: PWYW Price vs Fair Price
df_fp_pw_all <- df |>
filter(!is.na(fair_price), !is.na(generosity), !is.na(pwyw_no_purchase))
df_fp_pw <- df_fp_pw_all |>
filter(!is.na(pay_what_you_want), pwyw_no_purchase != 1)
df_fp_pw_no_purchase <- df_fp_pw_all |>
filter(pwyw_no_purchase == 1) |>
mutate(no_purchase_y = -0.9)
n_no_purchase_plot <- nrow(df_fp_pw_no_purchase)
pct_no_purchase_plot <- round(100 * n_no_purchase_plot / nrow(df_fp_pw_all), 1)
p2 <- df_fp_pw |>
ggplot(aes(x = fair_price, y = pay_what_you_want)) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey50", alpha = 0.5) +
geom_abline(slope = 0.5, intercept = 0, linetype = "dotted", color = col_green, alpha = 0.7) +
geom_smooth(method = "lm", formula = y ~ x, se = FALSE, color = "black", linewidth = 0.7, alpha = 0.7) +
geom_point(aes(color = generosity), size = 3, alpha = 0.7) +
annotate("rect", xmin = 0, xmax = 15, ymin = -1.6, ymax = -0.2,
fill = "grey97", color = "grey80", linewidth = 0.3) +
geom_point(
data = df_fp_pw_no_purchase,
aes(x = fair_price, y = no_purchase_y, color = generosity),
shape = 17, size = 3.2, alpha = 0.9, inherit.aes = FALSE
) +
annotate(
"text", x = 0.2, y = -0.3, hjust = 0, vjust = 1,
label = paste0("PWYW: Kein Kauf (n = ", n_no_purchase_plot, ", ", pct_no_purchase_plot, "%)"),
size = 3.2, color = "grey30"
) +
scale_color_gradient2(low = col_red, mid = col_orange, high = col_green,
midpoint = 0.5, name = expression(lambda)) +
labs(x = "Fairer Preis (p_f) in €", y = "PWYW-Preis in €",
title = "PWYW-Preis vs. Fairer Preis",
subtitle = paste0(
"Pearson r = ",
round(cor(df_fp_pw$pay_what_you_want, df_fp_pw$fair_price, use = "complete.obs"), 2),
", N (Kauf) = ", nrow(df_fp_pw)
)) +
coord_fixed(xlim = c(0, 15), ylim = c(-1.8, 15)) +
scale_x_continuous(breaks = seq(0, 15, 5)) +
scale_y_continuous(breaks = seq(0, 15, 5), expand = expansion(mult = c(0, 0.02))) +
theme_minimal()
# Right panel: PAAP Threshold Price vs Fair Price
df_fp_paap <- df |>
filter(!is.na(threshold_price), !is.na(fair_price), !is.na(generosity))
p3 <- df_fp_paap |>
ggplot(aes(x = fair_price, y = threshold_price)) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey50", alpha = 0.5) +
geom_abline(slope = 0.5, intercept = 0, linetype = "dotted", color = col_green, alpha = 0.7) +
geom_smooth(method = "lm", formula = y ~ x, se = FALSE, color = "black", linewidth = 0.7, alpha = 0.7) +
geom_point(aes(color = generosity), size = 3, alpha = 0.7) +
scale_color_gradient2(low = col_red, mid = col_orange, high = col_green,
midpoint = 0.5, name = expression(lambda)) +
labs(x = "Fairer Preis (p_f) in €", y = "PAAP-Schwellenpreis in €",
title = "PAAP-Schwellenpreis vs. Fairer Preis",
subtitle = paste0(
"Pearson r = ",
round(cor(df_fp_paap$threshold_price, df_fp_paap$fair_price, use = "complete.obs"), 2),
", N = ", nrow(df_fp_paap)
)) +
coord_fixed(xlim = c(0, 15), ylim = c(0, 15)) +
scale_x_continuous(breaks = seq(0, 15, 5)) +
scale_y_continuous(breaks = seq(0, 15, 5)) +
theme_minimal()
p1 + p2 + p3 + plot_layout(guides = "collect", ncol = 3)
\(\lambda_i\) beschreibt die Generosität — den Anteil des Gesamtsurplus \((r_i - c)\), den der Konsument dem Verkäufer als fairen Preis zugesteht.
\[p_{f_i} = \lambda_i \cdot r_i + (1 - \lambda_i) \cdot c, \quad \text{wenn } r_i > c\]
Die Messung erfolgt gemäß Online Resource F.2 über eine zweistufige Fairness-Bewertung (Guttman-Skala). Daraus wird \(\lambda\) berechnet:
\[\lambda_i = \frac{p_{f_i} - c}{r_i - c}\]
Wertebereiche:
Als grobe Orientierung aus der Literatur gilt: \(0.2 \leq \lambda \leq 0.7\) (Jang & Chu, 2012).
lambda_mean <- mean(df$generosity, na.rm = TRUE)
lambda_sd <- sd(df$generosity, na.rm = TRUE)
# Histogram + density + rug (left panel)
p_hist <- df |>
filter(!is.na(generosity)) |>
ggplot(aes(x = generosity)) +
geom_histogram(aes(y = after_stat(density)), binwidth = 0.05, boundary = 0,
fill = col_blue, color = "white", alpha = 0.6) +
geom_density(fill = col_blue, alpha = 0.3, linewidth = 0.8) +
geom_vline(xintercept = lambda_mean, linetype = "dashed",
color = col_red, linewidth = 0.8) +
geom_rug(alpha = 0.3) +
annotate("text", x = lambda_mean + 0.05, y = Inf, vjust = 1.5, hjust = 0,
label = paste0("M = ", round(lambda_mean, 2), "\nSD = ", round(lambda_sd, 2)),
color = col_red, size = 3.5) +
labs(x = expression(lambda), y = "Dichte") +
scale_x_continuous(breaks = seq(0, 1, 0.1), limits = c(0, 1)) +
theme_minimal()
# Boxplot (right panel, vertical)
p_box <- df |>
filter(!is.na(generosity)) |>
ggplot(aes(y = generosity)) +
geom_boxplot(fill = col_blue, alpha = 0.4, width = 0.3) +
scale_y_continuous(breaks = seq(0, 1, 0.1), limits = c(0, 1)) +
labs(y = expression(lambda)) +
theme_minimal() +
theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
p_hist + p_box + plot_layout(widths = c(4, 1))
df |>
filter(!is.na(generosity)) |>
ggplot(aes(x = generosity)) +
stat_ecdf(color = col_blue, linewidth = 0.8) +
labs(x = expression(lambda), y = "Kumulative Häufigkeit (ECDF)") +
scale_x_continuous(breaks = seq(0, 1, 0.1), limits = c(0, 1)) +
theme_minimal()
lambda_vals_norm <- df$generosity[!is.na(df$generosity)]
# Shapiro-Wilk (nur bei n ≤ 50, sonst nur KS)
if (length(lambda_vals_norm) <= 50) {
shapiro_result <- shapiro.test(lambda_vals_norm)
shapiro_text <- paste0("W = ", round(shapiro_result$statistic, 4),
", p = ", round(shapiro_result$p.value, 3))
} else {
shapiro_text <- paste0("N = ", length(lambda_vals_norm), " > 50 (nur KS-Test anwendbar)")
}
# KS-Test gegen Normalverteilung
ks_norm <- ks.test(lambda_vals_norm, "pnorm",
mean = mean(lambda_vals_norm), sd = sd(lambda_vals_norm))
tibble(
Test = c("Shapiro-Wilk", "KS-Test (vs. Normal)"),
Ergebnis = c(shapiro_text,
paste0("D = ", round(ks_norm$statistic, 4),
", p = ", round(ks_norm$p.value, 3)))
) |>
knitr::kable(caption = "Normalverteilungstests für λ")| Test | Ergebnis |
|---|---|
| Shapiro-Wilk | N = 133 > 50 (nur KS-Test anwendbar) |
| KS-Test (vs. Normal) | D = 0.0979, p = 0.156 |
fp_data |>
apa_cor(
generosity, fair_price, willingness_to_pay, production_costs,
ratio_pwyw_fair,
labels = c(
generosity = "λ (Generosity)",
fair_price = "Fairer Preis (p_f)",
willingness_to_pay = "WTP (r)",
production_costs = "Herstellungskosten (c)",
ratio_pwyw_fair = "Ratio PWYW / p_f"
)
)| Variable | n | M | SD | 1 | 2 | 3 | 4 | 5 |
|---|---|---|---|---|---|---|---|---|
| 1. λ (Generosity) | 133 | 0.45 | 0.28 | — | ||||
| 2. Fairer Preis (p_f) | 133 | 3.71 | 2.53 | 0.17 | — | |||
| 3. WTP (r) | 133 | 5.16 | 3.48 | -0.08 | 0.96*** | — | ||
| 4. Herstellungskosten (c) | 133 | 2.58 | 1.74 | -0.08 | 0.96*** | 1.00*** | — | |
| 5. Ratio PWYW / p_f | 103 | 0.91 | 0.39 | -0.23* | -0.20* | -0.17 | -0.17 | — |
| *p < .05. **p < .01. ***p < .001. | ||||||||
if ("altruism_composite" %in% names(df)) {
# Manual cor.test() for reliability
alt_test <- cor.test(
df$generosity[!is.na(df$generosity) & !is.na(df$altruism_composite)],
df$altruism_composite[!is.na(df$generosity) & !is.na(df$altruism_composite)],
method = "pearson"
)
lambda_altruism_label <- paste0(
"r = ", round(alt_test$estimate, 2),
", p = ", format.pval(alt_test$p.value, digits = 3, eps = 0.001)
)
df |>
filter(!is.na(generosity), !is.na(altruism_composite)) |>
ggplot(aes(x = altruism_composite, y = generosity)) +
geom_point(alpha = 0.5, size = 2, color = col_blue) +
geom_smooth(method = "lm", formula = y ~ x, se = TRUE, color = col_red, alpha = 0.2) +
scale_y_continuous(limits = c(0, 1)) +
labs(x = "Altruismus-Composite (Survey 1)", y = "Generosity (λ)",
title = "Zusammenhang: λ und Altruismus",
subtitle = lambda_altruism_label) +
theme_minimal()
} else {
cat("Variable altruism_composite nicht vorhanden.")
}
df |>
apa_desc(
generosity,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(generosity = "λ (Generosity)")
) | Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| λ (Generosity) | 133 | 0.45 | 0.28 | 0.44 | 0.00 | 1.00 |
Nach Wagner & Akbari (2023) ist \(\lambda\) zentral für die Wahl der optimalen Preispolitik:
Hohe Generosität (\(\lambda > 0.5\)) spricht für PAYW-Varianten, niedrige (\(\lambda < 0.3\)) eher für PAAP.
Die obige Verteilung zeigt, dass \(\lambda\) stark zwischen den Teilnehmern variiert — von sehr niedrigen Werten (kaum Bereitschaft, über die Kosten hinaus zu zahlen) bis hin zu hohen Werten (fast die gesamte WTP als fairer Preis). Es wäre daher nicht sinnvoll, \(\lambda\) als fixen Parameter für die gesamte Population anzunehmen, wie es im theoretischen Modell (Wagner & Akbari, 2023) aus Vereinfachungsgründen geschieht (\(\lambda_i = \lambda\)).
Ein naheliegender Kandidat für einen „normalen” Marktpreis wäre \(E[p_f]\), der erwartete faire Preis. Ein solches Aggregat-Schätzmaß für \(\lambda\) liegt zwar vor, die individuelle Heterogenität ist aber erheblich. Für die Profitabilitätsanalyse und die Wahl der optimalen Preispolitik muss daher die gesamte Verteilung von \(\lambda\) berücksichtigt werden — nicht nur ein Mittelwert.
\(\gamma_i\) beschreibt die Advantageous Inequity Aversion — wie stark ein Konsument darunter leidet, gegenüber dem Verkäufer überprivilegiert zu sein (\(p < p_f\)). Die Messung erfolgt über ein modifiziertes Diktator-Spiel (Teil 5: TaxDecision).
Messmethode (Online Resource F.4): Der Konsumnutzen wird durch Lizenzgebühr (\(\delta < 0\)) oder Gutschein (\(\delta > 0\)) variiert: \(r_\gamma = r \cdot (1 + \delta)\). Der Switching-Point von „nicht kaufen” zu „ohne zu bezahlen” oder „fair bezahlen” bestimmt \(\gamma\):
\[\gamma_i < \frac{\tilde{r}_\gamma}{c}\]
Segmentierung:
# Delta values for the 20 scenarios (index 1-20)
delta_values <- c(-0.50, -0.45, -0.40, -0.35, -0.30, -0.25, -0.20, -0.15, -0.10, -0.05,
0.00, 0.05, 0.10, 0.15, 0.20, 0.30, 0.40, 0.50, 0.75, 1.00)
# Extract tax decisions into long format
tax_vars <- paste0("tax_decision_", 1:20)
tax_long <- df |>
select(participant_code, willingness_to_pay, production_costs, generosity,
fair_mindedness, all_of(tax_vars)) |>
pivot_longer(
cols = all_of(tax_vars),
names_to = "scenario",
values_to = "decision"
) |>
mutate(
scenario_idx = as.integer(str_extract(scenario, "\\d+$")),
delta = delta_values[scenario_idx],
r_gamma = willingness_to_pay * (1 + delta),
# Fair price in scenario (Eq. from experiment)
fair_price_scenario = pmax(
generosity * r_gamma + (1 - generosity) * production_costs,
production_costs
)
)# Overall decision distribution by scenario
tax_summary <- tax_long |>
group_by(scenario_idx, delta) |>
summarise(
n_fair = sum(decision == "mit_fair"),
n_free = sum(decision == "ohne_bez"),
n_nobuy = sum(decision == "nicht"),
pct_fair = round(n_fair / n() * 100, 1),
pct_free = round(n_free / n() * 100, 1),
pct_nobuy = round(n_nobuy / n() * 100, 1),
.groups = "drop"
)
tax_summary |>
select(scenario_idx, delta, pct_fair, pct_free, pct_nobuy) |>
knitr::kable(caption = "Entscheidungen nach Szenario (% der Teilnehmer)",
col.names = c("Szenario", "δ", "% Fair", "% Freeride", "% Nicht kaufen"))| Szenario | δ | % Fair | % Freeride | % Nicht kaufen |
|---|---|---|---|---|
| 1 | -0.50 | 27.1 | 21.8 | 51.1 |
| 2 | -0.45 | 30.1 | 22.6 | 47.4 |
| 3 | -0.40 | 33.8 | 21.8 | 44.4 |
| 4 | -0.35 | 36.1 | 22.6 | 41.4 |
| 5 | -0.30 | 39.8 | 21.8 | 38.3 |
| 6 | -0.25 | 44.4 | 18.8 | 36.8 |
| 7 | -0.20 | 50.4 | 16.5 | 33.1 |
| 8 | -0.15 | 54.9 | 14.3 | 30.8 |
| 9 | -0.10 | 58.6 | 15.8 | 25.6 |
| 10 | -0.05 | 60.9 | 14.3 | 24.8 |
| 11 | 0.00 | 66.9 | 15.0 | 18.0 |
| 12 | 0.05 | 66.9 | 15.8 | 17.3 |
| 13 | 0.10 | 67.7 | 15.8 | 16.5 |
| 14 | 0.15 | 67.7 | 14.3 | 18.0 |
| 15 | 0.20 | 69.2 | 15.0 | 15.8 |
| 16 | 0.30 | 69.2 | 14.3 | 16.5 |
| 17 | 0.40 | 72.2 | 12.8 | 15.0 |
| 18 | 0.50 | 72.2 | 12.8 | 15.0 |
| 19 | 0.75 | 70.7 | 14.3 | 15.0 |
| 20 | 1.00 | 71.4 | 15.0 | 13.5 |
plot_df <- tax_summary |>
pivot_longer(
cols = c(pct_fair, pct_free, pct_nobuy),
names_to = "decision_type",
values_to = "pct"
) |>
mutate(
decision_type = recode(
decision_type,
pct_fair = "Fair bezahlen",
pct_free = "Ohne zu bezahlen",
pct_nobuy = "Nicht kaufen"
),
# Force stack order for geom_area: levels are drawn top -> bottom.
# We want: bottom = "Ohne zu bezahlen", middle = "Nicht kaufen", top = "Fair bezahlen".
# This guarantees: top("Ohne zu bezahlen") == bottom("Nicht kaufen").
decision_type = factor(
decision_type,
levels = c("Fair bezahlen", "Nicht kaufen", "Ohne zu bezahlen")
)
)
# Data-driven brace bounds (no hard-coded y placement)
edge_left <- tax_summary |>
slice_min(delta, with_ties = FALSE)
edge_right <- tax_summary |>
slice_max(delta, with_ties = FALSE)
delta_min <- edge_left$delta
delta_max <- edge_right$delta
x_range <- delta_max - delta_min
# Upper bound of "Ohne zu bezahlen" (and thus lower bound of "Nicht kaufen")
y_free_left <- edge_left$pct_free
y_free_right <- edge_right$pct_free
# Curly brace as a path with x-amplitude scaled to the x-range.
# This avoids visual distortion from the large y-range (0..100) vs small x-range (-0.5..1).
brace_path <- function(x_outer, x_inner, y0, y1, n = 250) {
t <- seq(0, 1, length.out = n)
w <- abs(x_outer - x_inner)
tibble::tibble(
x = if (x_outer > x_inner) x_outer - w * (sin(2 * pi * t) ^ 2) else x_outer + w * (sin(2 * pi * t) ^ 2),
y = y0 + t * (y1 - y0)
)
}
x_pad <- x_range * 0.025
brace_w <- x_range * 0.015
x_outer_r <- delta_max + x_pad
x_inner_r <- x_outer_r - brace_w
x_outer_l <- delta_min - x_pad
x_inner_l <- x_outer_l + brace_w
brace_right <- brace_path(x_outer_r, x_inner_r, y_free_right, 100)
brace_left <- brace_path(x_outer_l, x_inner_l, 0, y_free_left)
plot_df |>
ggplot(aes(x = delta, y = pct, fill = decision_type)) +
geom_area(alpha = 0.7, position = "stack") +
scale_fill_manual(
values = c(
"Fair bezahlen" = col_green,
"Ohne zu bezahlen" = col_orange,
"Nicht kaufen" = col_blue
),
# Legend order (top -> bottom) to match the stacked areas visually
breaks = c("Fair bezahlen", "Nicht kaufen", "Ohne zu bezahlen")
) +
geom_vline(xintercept = 0, linetype = "dashed", color = "grey30") +
annotate("text", x = -0.25, y = 95, label = "← Lizenzgebühr", color = "grey40", size = 3) +
annotate("text", x = 0.5, y = 95, label = "Gutschein →", color = "grey40", size = 3) +
geom_path(
data = brace_right,
aes(x = x, y = y),
inherit.aes = FALSE,
linewidth = 0.5,
color = "grey60",
lineend = "round"
) +
geom_text(
data = tibble::tibble(
x = x_outer_r + x_range * 0.02,
y = y_free_right + (100 - y_free_right) * 0.55,
label = "gamma>1"
),
aes(x = x, y = y, label = label),
inherit.aes = FALSE,
parse = TRUE,
hjust = 0,
size = 3.6,
color = "grey30",
family = "sans"
) +
geom_text(
data = tibble::tibble(
x = x_outer_r + x_range * 0.02,
y = y_free_right + (100 - y_free_right) * 0.40,
label = "more fair minded"
),
aes(x = x, y = y, label = label),
inherit.aes = FALSE,
hjust = 0,
size = 3.1,
color = "grey35",
family = "sans"
) +
geom_path(
data = brace_left,
aes(x = x, y = y),
inherit.aes = FALSE,
linewidth = 0.5,
color = "grey60",
lineend = "round"
) +
geom_text(
data = tibble::tibble(
x = x_outer_l - x_range * 0.02,
y = y_free_left * 0.70,
label = "gamma<1"
),
aes(x = x, y = y, label = label),
inherit.aes = FALSE,
parse = TRUE,
hjust = 1,
size = 3.4,
color = "grey30",
family = "sans"
) +
geom_text(
data = tibble::tibble(
x = x_outer_l - x_range * 0.02,
y = y_free_left * 0.40,
label = "less fair minded"
),
aes(x = x, y = y, label = label),
inherit.aes = FALSE,
hjust = 1,
size = 3.0,
color = "grey35",
family = "sans"
) +
coord_cartesian(ylim = c(0, 100), clip = "off") +
labs(x = "Delta (δ)", y = "Anteil (%)", fill = "Entscheidung",
title = "Entscheidungsmuster über Szenarien (TaxDecision, Teil 5)",
subtitle = "Negative δ = Lizenzgebühr, Positive δ = Gutschein") +
theme_minimal() +
theme(
legend.position = "top",
plot.margin = margin(t = 8, r = 95, b = 10, l = 95)
)
# For each participant: identify switching behavior
# Classification strategy: Use delta = -0.50 (scenario 1) as baseline.
# At delta = -0.50: gamma = 2*(1+(-0.50)) = 1.0 (exact theoretical threshold).
# If participant freeloads at this point -> less fair-minded (gamma <= 1)
# If participant abstains or pays fair -> more fair-minded (gamma > 1)
gamma_required_vars <- c(
"participant_code", "willingness_to_pay", "production_costs", "generosity",
"fair_mindedness", "pwyw_price", "pwyw_no_purchase",
"n_fair_total", "n_free_total", "n_nobuy_total",
"decision_at_baseline", "freeloads_at_baseline",
"first_active_idx_calc", "first_active_decision_calc",
"r_gamma_at_switch", "gamma_estimate", "gamma_type"
)
missing_gamma_vars <- setdiff(gamma_required_vars, names(df))
if (length(missing_gamma_vars) > 0) {
stop("Missing precomputed gamma variables in final dataset: ",
paste(missing_gamma_vars, collapse = ", "))
}
gamma_individual <- df |>
select(all_of(gamma_required_vars))
# Filter valid gamma estimates
gamma_valid <- gamma_individual |> filter(!is.na(gamma_estimate))gamma_valid |>
apa_desc(
gamma_estimate,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(gamma_estimate = "γ (Advantageous IA)")
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| γ (Advantageous IA) | 126 | 1.35 | 0.49 | 1.00 | 0.98 | 2.90 |
Die Gamma-Schätzung basiert auf der Formel (Online Resource F, Eq. F.3):
\[\hat{\gamma}_i = \frac{r_\gamma}{c} = \frac{\text{WTP} \times (1 + \delta)}{\text{WTP} / 2} = 2 \times (1 + \delta)\]
Das Szenario mit \(\delta = -0.50\) ergibt exakt den theoretischen Schwellenwert \(\hat{\gamma} = 2 \times (1 + (-0.50)) = 1.0\). Damit ist dieses Szenario der natürliche Klassifikationspunkt:
ohne_bez) gewählt haben — sie freeloaden selbst dann, wenn \(r_\gamma = c\) und somit kein Surplus vorhanden ist.mit_fair) oder „nicht kaufen” (nicht) gewählt haben — und in mindestens einem anderen Szenario aktiv den fairen Preis gezahlt haben.Der numerische \(\hat{\gamma}\)-Wert (basierend auf dem Switching-Point) ist für Teilnehmer mit \(\gamma > 1\) als Maß dafür interpretierbar, wie stark ihre Fairness-Orientierung ausgeprägt ist. Für Less Fair-Minded-Teilnehmer ist der \(\hat{\gamma}\)-Wert ≥ 1.0 per Design und daher nicht direkt als Niveau der Inequity Aversion interpretierbar.
# Left panel: Histogram + Density + Rug
p_gamma_hist <- gamma_valid |>
ggplot(aes(x = gamma_estimate)) +
geom_histogram(aes(y = after_stat(density)), binwidth = 0.2, boundary = 0,
fill = col_purple, color = "white", alpha = 0.8) +
geom_density(fill = col_purple, alpha = 0.3) +
geom_vline(xintercept = 1, linetype = "dashed", color = col_red, linewidth = 0.8) +
annotate("text", x = 1.05, y = Inf, vjust = 2, hjust = 0,
label = "γ = 1\n(Schwelle fair-minded)", color = col_red, size = 3.5) +
geom_rug(alpha = 0.3) +
annotate("text", x = Inf, y = Inf, hjust = 1.1, vjust = 1.5,
label = paste0("M = ", round(mean(gamma_valid$gamma_estimate), 2),
"\nSD = ", round(sd(gamma_valid$gamma_estimate), 2)),
size = 3.5, color = "grey30") +
labs(x = expression(hat(gamma)), y = "Dichte",
subtitle = "γ > 1: fair-minded, γ ≤ 1: less fair-minded") +
theme_minimal()
# Right panel: Boxplot with γ = 1 threshold
p_gamma_box <- gamma_valid |>
ggplot(aes(y = gamma_estimate)) +
geom_boxplot(fill = col_blue, alpha = 0.4, width = 0.3, outlier.shape = 16) +
geom_hline(yintercept = 1, linetype = "dashed", color = col_red, linewidth = 0.6) +
labs(y = expression(hat(gamma))) +
theme_minimal() +
theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
# Combined patchwork
p_gamma_hist + p_gamma_box + plot_layout(widths = c(4, 1))
gamma_valid |>
ggplot(aes(x = gamma_estimate)) +
stat_ecdf(color = col_purple, linewidth = 0.8) +
geom_vline(xintercept = 1, linetype = "dashed", color = col_red, linewidth = 0.6) +
annotate("text", x = 1.05, y = 0.5, label = "γ = 1\n(fair-minded Schwelle)",
color = col_red, size = 3.5, hjust = 0) +
labs(x = expression(hat(gamma)), y = "Kumulative Wahrscheinlichkeit") +
theme_minimal()
# omega: share of less fair-minded consumers (based on baseline decision at delta = -0.50)
# A consumer is "less fair-minded" (γ ≤ 1) if they freeloaded at delta = -0.50
omega <- mean(gamma_individual$freeloads_at_baseline, na.rm = TRUE)
# gamma_bar: mean gamma for less fair-minded consumers
# NOTE: gamma_estimate ≥ 1.0 for ALL participants due to design (delta_min = -0.50).
# gamma_bar_01 is computed for baseline-identified less fair-minded consumers.
less_fair <- gamma_individual |>
filter(!is.na(gamma_estimate), freeloads_at_baseline == TRUE)
more_fair <- gamma_individual |>
filter(!is.na(gamma_estimate), freeloads_at_baseline == FALSE)
gamma_bar_01 <- if (nrow(less_fair) > 0) mean(less_fair$gamma_estimate) else NA_real_
gamma_bar_more <- if (nrow(more_fair) > 0) mean(more_fair$gamma_estimate) else NA_real_
n_always_abstain <- sum(gamma_individual$gamma_type == "Always Abstain", na.rm = TRUE)
tibble(
Parameter = c("ω (Anteil less fair-minded)",
"1 - ω (Anteil more fair-minded)",
"M γ (more fair-minded)",
"N less fair-minded",
"N more fair-minded",
"N immer Abstinenz"),
Wert = c(
sprintf("%.2f", omega),
sprintf("%.2f", 1 - omega),
sprintf("%.2f", gamma_bar_more),
as.character(nrow(less_fair)),
as.character(nrow(more_fair)),
as.character(n_always_abstain)
)
) |>
gt() |>
gt_apa_style()| Parameter | Wert |
|---|---|
| ω (Anteil less fair-minded) | 0.22 |
| 1 - ω (Anteil more fair-minded) | 0.78 |
| M γ (more fair-minded) | 1.46 |
| N less fair-minded | 29 |
| N more fair-minded | 97 |
| N immer Abstinenz | 7 |
Referenzwerte (Wagner & Akbari, 2023):
Für Konsumenten mit \(\gamma \leq 1\) ist die Nutzenfunktion unter PAYW (Eq. 1c):
\[u^* = r - \gamma p_f, \quad p^* = 0\]
Da der Koeffizient \((1 - \gamma) \geq 0\) ist das Optimum immer \(p = 0\) (Freeloading). Teilnehmer, die bei \(\delta = -0.50\) freeloaden und damit als \(\gamma \leq 1\) klassifiziert werden, sollten daher in allen Szenarien mit positivem Nutzen freeloaden — unabhängig von der Höhe des Konsumnutzens. Ein Wechsel zu „fair bezahlen” in höheren Szenarien wäre theoretisch inkonsistent.
# Filter less fair-minded participants (freeload at baseline delta = -0.50)
lfm_ids <- gamma_individual |>
filter(freeloads_at_baseline == TRUE) |>
pull(participant_code)
# Their decisions across all 20 scenarios
lfm_long <- tax_long |>
filter(participant_code %in% lfm_ids) |>
mutate(
decision_label = recode(decision,
"ohne_bez" = "Ohne zu bezahlen",
"mit_fair" = "Fair bezahlen",
"nicht" = "Nicht kaufen")
)
# Summary: consistency check
lfm_consistency <- gamma_individual |>
filter(freeloads_at_baseline == TRUE) |>
mutate(
# Proportion of freeloading among all active decisions (excluding "nicht")
n_active = n_free_total + n_fair_total,
freeride_rate = if_else(n_active > 0, n_free_total / n_active, NA_real_),
# Perfectly consistent: freeloads in ALL active scenarios
perfectly_consistent = (n_fair_total == 0),
# Ever pays fair despite gamma <= 1
ever_pays_fair = n_fair_total > 0
)lfm_consistency |>
summarise(
`N Less Fair-Minded` = n(),
`Immer Freeride (konsistent)` = sum(perfectly_consistent),
`Auch mal Fair bezahlt (inkonsistent)` = sum(ever_pays_fair),
`% konsistent` = round(mean(perfectly_consistent) * 100, 1),
`Mittlere Freeride-Rate` = round(mean(freeride_rate, na.rm = TRUE), 2),
`Min Freeride-Rate` = round(min(freeride_rate, na.rm = TRUE), 2),
`N mit Abstinenz (nicht kaufen)` = sum(n_nobuy_total > 0)
) |>
pivot_longer(everything(), names_to = "Kennzahl", values_to = "Wert") |>
gt() |>
gt_apa_style()| Kennzahl | Wert |
|---|---|
| N Less Fair-Minded | 29.00 |
| Immer Freeride (konsistent) | 7.00 |
| Auch mal Fair bezahlt (inkonsistent) | 22.00 |
| % konsistent | 24.10 |
| Mittlere Freeride-Rate | 0.60 |
| Min Freeride-Rate | 0.05 |
| N mit Abstinenz (nicht kaufen) | 8.00 |
Verhaltenskonsistenz: Less Fair-Minded (γ ≤ 1) sollten theoretisch in allen aktiven Szenarien freeloaden.
decision_colors <- c(
"Ohne zu bezahlen" = col_orange,
"Fair bezahlen" = col_green,
"Nicht kaufen" = col_blue
)
# Prepare data for heatmap - convert participant_code to character for proper reordering
lfm_plot_data <- lfm_long |>
mutate(
participant_code_chr = as.character(participant_code),
id_label = paste0("ID ", participant_code_chr),
delta_label = paste0("δ=", sprintf("%+.2f", delta))
)
lfm_plot_data |>
ggplot(aes(x = factor(scenario_idx), y = fct_reorder(id_label, as.numeric(factor(participant_code_chr))), fill = decision_label)) +
geom_tile(color = "white", linewidth = 0.3) +
scale_fill_manual(values = decision_colors) +
geom_vline(xintercept = 10.5, linetype = "dashed", color = "grey30", linewidth = 0.5) +
annotate("text", x = 5.5, y = Inf, label = "Lizenzgebühr (δ < 0)",
vjust = -0.5, color = "grey40", size = 3) +
annotate("text", x = 15.5, y = Inf, label = "Gutschein (δ > 0)",
vjust = -0.5, color = "grey40", size = 3) +
scale_x_discrete(labels = paste0(sprintf("%+.2f", delta_values))) +
labs(x = "Szenario (δ-Wert)", y = NULL, fill = "Entscheidung",
title = "Entscheidungsmuster der Less Fair-Minded (γ ≤ 1)",
subtitle = "Theoretische Vorhersage: durchgehend Freeloading bei allen aktiven Szenarien") +
theme_minimal() +
theme(
axis.text.x = element_text(angle = 45, hjust = 1, size = 7),
axis.text.y = element_text(size = 7),
plot.margin = margin(t = 15, r = 5, b = 5, l = 5)
)
# Aggregate: decision distribution per scenario for LFM only
lfm_agg <- lfm_long |>
group_by(scenario_idx, delta, decision_label) |>
summarise(n = n(), .groups = "drop") |>
group_by(scenario_idx, delta) |>
mutate(pct = n / sum(n) * 100)
lfm_agg |>
ggplot(aes(x = delta, y = pct, fill = decision_label)) +
geom_area(alpha = 0.7, position = "stack") +
scale_fill_manual(values = decision_colors) +
geom_vline(xintercept = 0, linetype = "dashed", color = "grey30") +
geom_vline(xintercept = -0.50, linetype = "dotted", color = col_red, linewidth = 0.6) +
annotate("text", x = -0.48, y = 5, label = "Baseline\n(δ = −0.50)",
color = col_red, size = 3, hjust = 0) +
labs(x = "Delta (δ)", y = "Anteil (%)", fill = "Entscheidung",
title = "Entscheidungsverteilung der Less Fair-Minded (γ ≤ 1)",
subtitle = "Bei konsistentem γ ≤ 1: Freeloading sollte in allen aktiven Szenarien dominieren") +
theme_minimal()
Die aggregierte Verteilung zeigt, dass Less Fair-Minded Teilnehmer nicht konsistent freeloaden. Obwohl alle bei δ = −0.50 (Baseline) ohne Bezahlung gewählt haben, zahlen viele in anderen Szenarien den fairen Preis. Dieses inkonsistente Verhalten entspricht nicht der theoretischen Vorhersage und deutet auf kontextabhängige Entscheidungen hin.
gamma_individual |>
filter(freeloads_at_baseline == TRUE) |>
mutate(
n_active = n_free_total + n_fair_total,
freeride_rate = if_else(n_active > 0,
round(n_free_total / n_active * 100, 0), NA_real_)
) |>
select(participant_code, n_free_total, n_fair_total, n_nobuy_total, freeride_rate, gamma_estimate) |>
arrange(desc(n_fair_total)) |>
knitr::kable(
col.names = c("ID", "N Freeride", "N Fair", "N Nicht kaufen",
"Freeride-Rate (%)", "γ̂"),
caption = "Less Fair-Minded: Individuelle Entscheidungsprofile"
)| ID | N Freeride | N Fair | N Nicht kaufen | Freeride-Rate (%) | γ̂ |
|---|---|---|---|---|---|
| 804pb2zy | 1 | 19 | 0 | 5 | 1.0000000 |
| 8y11bhfv | 2 | 18 | 0 | 10 | 1.0000000 |
| y4shc77m | 2 | 18 | 0 | 10 | 1.0000000 |
| jvrsiitv | 2 | 18 | 0 | 10 | 1.0000000 |
| s8iq5n4u | 6 | 14 | 0 | 30 | 1.0000000 |
| u8f6bqc0 | 4 | 14 | 2 | 22 | 1.0000000 |
| 8edftuti | 6 | 14 | 0 | 30 | 1.0000000 |
| rkk2gkz8 | 6 | 12 | 2 | 33 | 1.0000000 |
| uz0f59tm | 2 | 11 | 7 | 15 | 1.0000000 |
| dg2hsuvy | 10 | 10 | 0 | 50 | 0.9807692 |
| ob8r0ss9 | 10 | 10 | 0 | 50 | 1.0000000 |
| gzdrgzs2 | 10 | 10 | 0 | 50 | 1.0000000 |
| swmpw4sf | 11 | 9 | 0 | 55 | 1.0000000 |
| rw9v2ryl | 11 | 9 | 0 | 55 | 1.0000000 |
| cotg8tvc | 11 | 9 | 0 | 55 | 1.0000000 |
| 18v49g92 | 6 | 9 | 5 | 40 | 1.0000000 |
| il64sert | 14 | 6 | 0 | 70 | 1.0000000 |
| kranea3p | 16 | 4 | 0 | 80 | 1.0000000 |
| tdzks2xj | 19 | 1 | 0 | 95 | 1.0000000 |
| 2msf0dr1 | 19 | 1 | 0 | 95 | 1.0000000 |
| 10mi76np | 13 | 1 | 6 | 93 | 1.0000000 |
| lcerg8jw | 9 | 1 | 10 | 90 | 1.0000000 |
| 6vbu295d | 20 | 0 | 0 | 100 | 1.0000000 |
| 0ipyr6pc | 19 | 0 | 1 | 100 | 1.0000000 |
| r780qdj9 | 1 | 0 | 19 | 100 | 1.0000000 |
| e6f1doh4 | 20 | 0 | 0 | 100 | 1.0000000 |
| dvmf11v4 | 20 | 0 | 0 | 100 | 1.0000000 |
| k9ebhn3l | 20 | 0 | 0 | 100 | 1.0000000 |
| tnzoxkbi | 20 | 0 | 0 | 100 | 1.0000000 |
# Map to theoretical segments from Wagner & Akbari (2023), Table 1
gamma_individual <- gamma_individual |>
mutate(
# Theoretical segment classification (baseline: delta = -0.50)
segment = case_when(
# γ ≤ 1 cases (freeloads at baseline δ = -0.50)
gamma_type == "Less Fair-Minded (γ ≤ 1)" &
(pwyw_price == 0 | pwyw_no_purchase == 0) ~ "I: Freeloaders",
gamma_type == "Less Fair-Minded (γ ≤ 1)" &
pwyw_no_purchase == 1 ~ "II: Non-Buyers (CKZ-neu)",
# γ > 1 cases (does not freeride at baseline δ = -0.50)
gamma_type == "More Fair-Minded (γ > 1)" &
pwyw_price > 0 ~ "III: Fair Payers",
gamma_type == "More Fair-Minded (γ > 1)" &
(pwyw_price == 0 | pwyw_no_purchase == 1) ~ "IV: Fair Non-Buyers",
gamma_type == "Always Abstain" ~ "Always Abstain (kein Segment)",
TRUE ~ "Nicht zuordbar"
)
)
# Segment sizes
gamma_individual |>
count(segment, name = "n") |>
mutate(pct = round(n / sum(n) * 100, 1)) |>
arrange(segment) |>
knitr::kable(caption = "Vier-Segment-Klassifikation (Wagner & Akbari, 2023)")| segment | n | pct |
|---|---|---|
| Always Abstain (kein Segment) | 7 | 5.3 |
| I: Freeloaders | 24 | 18.0 |
| II: Non-Buyers (CKZ-neu) | 5 | 3.8 |
| III: Fair Payers | 71 | 53.4 |
| IV: Fair Non-Buyers | 21 | 15.8 |
| Nicht zuordbar | 5 | 3.8 |
segment_colors <- c(
"I: Freeloaders" = col_orange,
"II: Non-Buyers (CKZ-neu)" = col_red,
"III: Fair Payers" = col_green,
"IV: Fair Non-Buyers" = col_blue,
"Always Abstain (kein Segment)" = "grey70",
"Nicht zuordbar" = "grey90"
)
gamma_individual |>
count(segment) |>
ggplot(aes(x = reorder(segment, -n), y = n, fill = segment)) +
geom_col(alpha = 0.8) +
geom_text(aes(label = n), vjust = -0.3) +
scale_fill_manual(values = segment_colors, guide = "none") +
labs(x = NULL, y = "Anzahl Teilnehmer") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 20, hjust = 1))
Die aktuelle Zuordnung zu Segment III (Fair Payers) basiert auf der Bedingung pwyw_price > 0. Das ist problematisch: Ein Preis von z.B. €0,01 wäre zwar > 0, aber keineswegs fair.
Für eine valide Klassifikation sollte stattdessen geprüft werden, wie viel vom fairen Preis tatsächlich gezahlt wurde — z.B. über das Verhältnis pwyw_price / fair_price. Nur Teilnehmer, die einen substanziellen Anteil des fairen Preises gezahlt haben (z.B. ≥ 80%), sollten als „Fair Payers” klassifiziert werden. Diese Überarbeitung ist für die nächste Analysephase vorgesehen.
# Column order: I, II, III, IV, then special categories
segment_order <- c("I: Freeloaders", "II: Non-Buyers (CKZ-neu)",
"III: Fair Payers", "IV: Fair Non-Buyers",
"Nicht zuordbar", "Always Abstain (kein Segment)")
# Row order with grouping: γ ≤ 1 first, then γ > 1, then Always Abstain
gamma_order <- c("Less Fair-Minded", "Always Freeride",
"More Fair-Minded", "Always Fair",
"Always Abstain")
# Cross-tabulation with proper ordering
cross_tbl <- gamma_individual |>
mutate(
fair_mindedness = factor(fair_mindedness, levels = gamma_order),
# Create grouping variable for row groups
gamma_group = case_when(
fair_mindedness %in% c("Less Fair-Minded", "Always Freeride") ~ "γ ≤ 1 (Freeloading-Tendenz)",
fair_mindedness %in% c("More Fair-Minded", "Always Fair") ~ "γ > 1 (Fair-Mindedness)",
fair_mindedness == "Always Abstain" ~ "Sonstige",
TRUE ~ NA_character_
),
gamma_group = factor(gamma_group, levels = c("γ ≤ 1 (Freeloading-Tendenz)",
"γ > 1 (Fair-Mindedness)",
"Sonstige"))
) |>
count(gamma_group, fair_mindedness, segment) |>
pivot_wider(names_from = segment, values_from = n, values_fill = 0) |>
select(gamma_group, fair_mindedness, any_of(segment_order)) |>
filter(!is.na(fair_mindedness)) |>
arrange(gamma_group, fair_mindedness)
cross_tbl |>
gt(groupname_col = "gamma_group") |>
cols_label(fair_mindedness = "γ-Typ (Part 5)") |>
tab_spanner(label = "PWYW-Segment (Part 2)", columns = -fair_mindedness) |>
tab_style(
style = cell_text(indent = px(15)),
locations = cells_body(columns = fair_mindedness)
) |>
tab_source_note(md("*Note.* Zeilen = Klassifikation basierend auf Part 5 (Szenario-Entscheidungen). Spalten = Klassifikation basierend auf Part 2 (tatsächliches PWYW-Verhalten)."))| γ-Typ (Part 5) |
PWYW-Segment (Part 2)
|
|||||
|---|---|---|---|---|---|---|
| I: Freeloaders | II: Non-Buyers (CKZ-neu) | III: Fair Payers | IV: Fair Non-Buyers | Nicht zuordbar | Always Abstain (kein Segment) | |
| γ ≤ 1 (Freeloading-Tendenz) | ||||||
| Less Fair-Minded | 20 | 4 | 10 | 3 | 5 | 0 |
| Always Freeride | 4 | 1 | 0 | 0 | 0 | 0 |
| γ > 1 (Fair-Mindedness) | ||||||
| More Fair-Minded | 0 | 0 | 6 | 5 | 0 | 0 |
| Always Fair | 0 | 0 | 55 | 13 | 0 | 0 |
| Sonstige | ||||||
| Always Abstain | 0 | 0 | 0 | 0 | 0 | 7 |
| Note. Zeilen = Klassifikation basierend auf Part 5 (Szenario-Entscheidungen). Spalten = Klassifikation basierend auf Part 2 (tatsächliches PWYW-Verhalten). | ||||||
source(here::here("05_Analysis", "R", "apa_tables.R"))
# Prepare data with additional categorical variables
# Filter to only Less Fair-Minded vs. More Fair-Minded (exclude "Other")
gamma_pwyw_data <- gamma_individual |>
filter(!is.na(gamma_type),
gamma_type != "Always Abstain",
gamma_type %in% c("Less Fair-Minded (γ ≤ 1)", "More Fair-Minded (γ > 1)")) |>
left_join(df |> select(participant_code, fair_price), by = "participant_code") |>
mutate(
pct_zero = as.numeric(pwyw_price == 0) * 100,
pct_paid_c = as.numeric(abs(pwyw_price - production_costs) < 0.01) * 100,
pct_no_purchase = as.numeric(pwyw_no_purchase == 1) * 100,
ratio_pwyw_fair = if_else(fair_price > 0, pwyw_price / fair_price, NA_real_),
ratio_pwyw_wtp = if_else(willingness_to_pay > 0, pwyw_price / willingness_to_pay, NA_real_)
)
# APA-formatierte Tabelle für Kernvariablen mit t-Test
gamma_pwyw_data |>
apa_desc_by(
pwyw_price, willingness_to_pay, fair_price, generosity,
pct_zero, pct_paid_c, pct_no_purchase, ratio_pwyw_fair, ratio_pwyw_wtp,
by = gamma_type,
labels = c(
pwyw_price = "PWYW (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fair Price (€)",
generosity = "λ",
pct_zero = "p = 0 (%)",
pct_paid_c = "p = c (%)",
pct_no_purchase = "Nicht-Kauf (%)",
ratio_pwyw_fair = "PWYW/p_f",
ratio_pwyw_wtp = "PWYW/WTP"
),
note = "'Other' Kategorie (n = 5) wurde ausgeschlossen. Nur Less Fair-Minded vs. More Fair-Minded verglichen."
)| Variable |
Less Fair-Minded (γ ≤ 1)
|
More Fair-Minded (γ > 1)
|
t | df | p | d | ||
|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | |||||
| PWYW (€) | 2.52 | 2.11 | 3.24 | 2.54 | −1.38 | 46.27 | .174 | 0.29 |
| WTP (€) | 4.55 | 3.73 | 5.27 | 3.52 | −0.91 | 44.87 | .366 | 0.20 |
| Fair Price (€) | 3.18 | 2.52 | 3.81 | 2.60 | −1.16 | 48.17 | .252 | 0.24 |
| λ | 0.42 | 0.24 | 0.46 | 0.29 | −0.65 | 54.87 | .518 | 0.13 |
| p = 0 (%) | 4.17 | 20.41 | 5.33 | 22.62 | −0.24 | 42.59 | .814 | 0.05 |
| p = c (%) | 16.67 | 38.07 | 6.67 | 25.11 | 1.21 | 29.67 | .237 | 0.35 |
| Nicht-Kauf (%) | 17.24 | 38.44 | 18.48 | 39.02 | −0.15 | 47.60 | .881 | 0.03 |
| PWYW/p_f | 0.87 | 0.39 | 0.93 | 0.39 | −0.65 | 38.57 | .520 | 0.15 |
| PWYW/WTP | 0.60 | 0.29 | 0.67 | 0.26 | −1.10 | 35.42 | .279 | 0.27 |
| Note. ‘Other’ Kategorie (n = 5) wurde ausgeschlossen. Nur Less Fair-Minded vs. More Fair-Minded verglichen. | ||||||||
Der Anteil der Freerider (\(p = 0\)) ist in beiden γ-Typen sehr niedrig (~5%) — selbst die weniger Fair-Minded freeloaden selten tatsächlich. Bemerkenswerterweise gibt es auch bei den More Fair-Minded Personen, die \(p = 0\) zahlen.
Konsistent mit der Theorie ist jedoch, dass der Anteil derjenigen, die exakt die Produktionskosten zahlen (\(p = c\)), bei den Less Fair-Minded deutlich höher ist (16.7% vs. 6.7%). Dies deutet darauf hin, dass Less Fair-Minded zwar selten auf \(p = 0\) gehen, aber häufiger den minimalen „fairen” Beitrag wählen.
gamma_individual |>
filter(!is.na(gamma_type), gamma_type != "Always Abstain") |>
ggplot(aes(x = gamma_type, y = pwyw_price, fill = gamma_type)) +
geom_boxplot(alpha = 0.4, width = 0.3, outlier.shape = NA) +
geom_jitter(width = 0.2, alpha = 0.4, size = 1.5) +
scale_fill_manual(values = c(
"Less Fair-Minded (γ ≤ 1)" = col_orange,
"More Fair-Minded (γ > 1)" = col_blue), guide = "none") +
labs(x = NULL, y = "PWYW-Preis (€)") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 15, hjust = 1))
source(here::here("05_Analysis", "R", "apa_tables.R"))
gamma_with_survey <- gamma_individual |>
left_join(df |> select(participant_code, altruism_composite, fairness_self), by = "participant_code")
gamma_with_survey |>
filter(!is.na(gamma_type), gamma_type != "Always Abstain") |>
apa_desc_by(altruism_composite, fairness_self, by = gamma_type,
labels = c(altruism_composite = "Altruismus", fairness_self = "Fairness (Selbst)"))| Variable |
Less Fair-Minded (γ ≤ 1)
|
More Fair-Minded (γ > 1)
|
Other
|
F | df | p | η² | |||
|---|---|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | M | SD | |||||
| Altruismus | 4.31 | 0.77 | 4.86 | 0.94 | 4.17 | 0.86 | 4.96 | 2, 123 | .008 | 0.07 |
| Fairness (Selbst) | 4.59 | 1.66 | 5.77 | 1.45 | 4.60 | 1.95 | 7.52 | 2, 123 | < .001 | 0.11 |
| Note. Effect size is η² (eta-squared). | ||||||||||
# For each participant, predict the PWYW price based on the model
validation_df <- gamma_individual |>
mutate(
# Predicted PWYW price based on model
predicted_pwyw = case_when(
# γ > 1: should pay p_f = λ*r + (1-λ)*c
gamma_type == "More Fair-Minded (γ > 1)" ~
generosity * willingness_to_pay + (1 - generosity) * production_costs,
# γ ≤ 1: should pay 0
gamma_type == "Less Fair-Minded (γ ≤ 1)" ~ 0,
TRUE ~ NA_real_
),
# Prediction error
prediction_error = pwyw_price - predicted_pwyw,
# Correct prediction (within tolerance)
correct_prediction = case_when(
is.na(predicted_pwyw) ~ NA,
gamma_type == "Less Fair-Minded (γ ≤ 1)" ~ pwyw_price == 0,
TRUE ~ abs(prediction_error) < 1 # within 1€
)
)# Summary by gamma type (APA table)
validation_summary <- validation_df |>
filter(!is.na(predicted_pwyw), !is.na(gamma_type), gamma_type != "Always Abstain") |>
group_by(gamma_type) |>
summarise(
n = n(),
mean_predicted = mean(predicted_pwyw, na.rm = TRUE),
mean_actual = mean(pwyw_price, na.rm = TRUE),
mean_error = mean(prediction_error, na.rm = TRUE),
pct_correct = mean(correct_prediction, na.rm = TRUE) * 100,
.groups = "drop"
)
validation_summary |>
gt() |>
cols_label(
gamma_type = "γ-Typ",
n = "n",
mean_predicted = "Vorhergesagt (M)",
mean_actual = "Beobachtet (M)",
mean_error = "Fehler (M)",
pct_correct = "% Korrekt"
) |>
fmt_number(columns = c(mean_predicted, mean_actual, mean_error), decimals = 2) |>
fmt_number(columns = pct_correct, decimals = 1) |>
tab_source_note(md("*Note.* Korrekt = beobachteter Preis innerhalb ±1€ der Vorhersage (γ > 1) bzw. = 0 (γ ≤ 1)."))| γ-Typ | n | Vorhergesagt (M) | Beobachtet (M) | Fehler (M) | % Korrekt |
|---|---|---|---|---|---|
| Less Fair-Minded (γ ≤ 1) | 29 | 0.00 | 2.52 | 2.52 | 4.2 |
| More Fair-Minded (γ > 1) | 92 | 3.82 | 3.24 | −0.44 | 69.3 |
| Note. Korrekt = beobachteter Preis innerhalb ±1€ der Vorhersage (γ > 1) bzw. = 0 (γ ≤ 1). | |||||
validation_df |>
filter(!is.na(predicted_pwyw), !is.na(gamma_type), gamma_type != "Always Abstain") |>
ggplot(aes(x = predicted_pwyw, y = pwyw_price, color = gamma_type)) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey50") +
geom_point(alpha = 0.5, size = 2) +
scale_color_manual(values = c(
"Less Fair-Minded (γ ≤ 1)" = col_orange,
"More Fair-Minded (γ > 1)" = col_blue)) +
labs(x = "Vorhergesagter PWYW-Preis (€)", y = "Beobachteter PWYW-Preis (€)",
color = "γ-Typ") +
theme_minimal()
\(\beta_i\) beschreibt die Disadvantageous Inequity Aversion — die Abneigung gegen eine Situation, in der der Verkäufer überprivilegiert ist (\(p > p_f\)). Die Messung erfolgt über ein modifiziertes Ultimatum-Spiel (Teil 4: BetaSequence).
Messung (Online Resource F.3): Eine strukturierte Preisliste von \(p_f\) bis \(r\) wird vorgelegt. Der Switching-Point von „Kaufen” zu „Nicht kaufen” bestimmt \(\beta\):
\[\beta_i > \frac{r_i - p_{\beta_i}}{p_{\beta_i} - p_{f_i}}\]
21 Preise: \(\text{price}_i = c + \frac{i}{20} \cdot (r - c)\), wobei \(c = r/2\).
Referenzbereich (Eckel & Gintis, 2010): \(0.31 \leq \beta \leq 1.89\), generell \(\beta > \gamma\).
lowerbeta# Basic descriptive statistics for lowerbeta
beta_vals <- df$lowerbeta[!is.na(df$lowerbeta)]
# Separate finite and infinite values
n_inf <- sum(is.infinite(df$lowerbeta))
n_zero <- sum(df$lowerbeta == 0, na.rm = TRUE)
beta_finite <- beta_vals[is.finite(beta_vals)]tibble(
Kategorie = c("N gesamt", "N finite β", "β = ∞ (nie kaufen)", "β = 0 (immer kaufen)"),
n = c(length(beta_vals), length(beta_finite), n_inf, n_zero)
) |>
gt() |>
gt_apa_style()| Kategorie | n |
|---|---|
| N gesamt | 133 |
| N finite β | 118 |
| β = ∞ (nie kaufen) | 15 |
| β = 0 (immer kaufen) | 37 |
df |>
filter(is.finite(lowerbeta)) |>
apa_desc(
lowerbeta,
stats = c("n", "M", "SD", "Mdn", "Min", "Max"),
labels = c(lowerbeta = "β (Disadvantageous IA)")
)| Variable | n | M | SD | Mdn | Min | Max |
|---|---|---|---|---|---|---|
| β (Disadvantageous IA) | 118 | 1.65 | 3.93 | 0.33 | 0.00 | 19.00 |
beta_mean <- mean(beta_finite)
beta_sd <- sd(beta_finite)
# Left panel: Histogram + Density + Rug
p_beta_hist <- df |>
filter(is.finite(lowerbeta)) |>
ggplot(aes(x = lowerbeta)) +
geom_histogram(aes(y = after_stat(density)), binwidth = 0.5, boundary = 0,
fill = col_blue, color = "white", alpha = 0.8) +
geom_density(color = col_blue, fill = col_blue, alpha = 0.2, linewidth = 0.9) +
geom_vline(xintercept = beta_mean, linetype = "dashed",
color = col_red, linewidth = 0.8) +
annotate("text", x = beta_mean + 0.3, y = Inf, vjust = 2, hjust = 0,
label = paste0("M = ", round(beta_mean, 2), "\nSD = ", round(beta_sd, 2)),
color = col_red, size = 3.7) +
geom_rug(alpha = 0.3) +
labs(x = expression(hat(beta)), y = "Dichte",
subtitle = paste0("N finite = ", length(beta_finite),
", β = ∞: ", n_inf, ", β = 0: ", n_zero)) +
theme_minimal()
# Right panel: Boxplot
p_beta_box <- df |>
filter(is.finite(lowerbeta)) |>
ggplot(aes(y = lowerbeta)) +
geom_boxplot(fill = col_blue, alpha = 0.4, width = 0.3, outlier.shape = 16) +
labs(y = expression(hat(beta))) +
theme_minimal() +
theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
# Combined patchwork
p_beta_hist + p_beta_box + plot_layout(widths = c(4, 1))
df |>
filter(is.finite(lowerbeta)) |>
ggplot(aes(x = lowerbeta)) +
stat_ecdf(color = col_blue, linewidth = 0.8) +
labs(x = expression(hat(beta)), y = "Kumulative Häufigkeit (ECDF)") +
theme_minimal()
# Parse beta_final_decisions JSON and check monotonicity
beta_monotonicity <- df |>
select(participant_code, beta_final_decisions) |>
rowwise() |>
mutate(
# Parse JSON decisions
decisions_parsed = list({
tryCatch({
decs <- fromJSON(beta_final_decisions)
# Sort by price (numeric keys)
prices <- as.numeric(names(decs))
values <- unname(unlist(decs))
tibble(price = prices, decision = values) |> arrange(price)
}, error = function(e) tibble(price = numeric(), decision = character()))
}),
# Check monotonicity: should be "buy" at low prices, "not_buy" at high prices
is_monotone = {
decs <- decisions_parsed
if (nrow(decs) == 0) NA
else {
binary <- ifelse(decs$decision == "buy", 1, 0)
# Monotone = once you switch to not_buy, you never go back to buy
all(diff(binary) <= 0)
}
}
) |>
ungroup()
n_monotone <- sum(beta_monotonicity$is_monotone, na.rm = TRUE)
n_not_monotone <- sum(!beta_monotonicity$is_monotone, na.rm = TRUE)
n_na_mono <- sum(is.na(beta_monotonicity$is_monotone))
tibble(
Kriterium = c("Monotone Sequenz (konsistent)", "Nicht-monotone Sequenz",
"Nicht auswertbar", "Anteil monoton"),
n = c(n_monotone, n_not_monotone, n_na_mono,
paste0(round(n_monotone / (n_monotone + n_not_monotone) * 100, 1), "%"))
) |>
knitr::kable(caption = "Monotonie der BetaSequence-Entscheidungen (finale Version)")| Kriterium | n |
|---|---|
| Monotone Sequenz (konsistent) | 128 |
| Nicht-monotone Sequenz | 5 |
| Nicht auswertbar | 0 |
| Anteil monoton | 96.2% |
# Merge beta and gamma estimates
beta_gamma <- gamma_individual |>
left_join(df |> select(participant_code, lowerbeta), by = "participant_code") |>
filter(!is.na(gamma_estimate), is.finite(lowerbeta))
n_beta_gt_gamma <- sum(beta_gamma$lowerbeta > beta_gamma$gamma_estimate, na.rm = TRUE)
n_comparable <- nrow(beta_gamma)
tibble(
Vergleich = c("N (beide Parameter vorhanden & finite)",
"β > γ (theoretische Erwartung)",
"β ≤ γ",
"Anteil β > γ"),
Wert = c(n_comparable, n_beta_gt_gamma,
n_comparable - n_beta_gt_gamma,
paste0(round(n_beta_gt_gamma / n_comparable * 100, 1), "%"))
) |>
knitr::kable(caption = "Prüfung: β > γ (Eckel & Gintis, 2010)")| Vergleich | Wert |
|---|---|
| N (beide Parameter vorhanden & finite) | 114 |
| β > γ (theoretische Erwartung) | 25 |
| β ≤ γ | 89 |
| Anteil β > γ | 21.9% |
Die Parameter \(\beta\) und \(\gamma\) wurden mit unterschiedlichen Methoden erhoben und sind daher nur eingeschränkt vergleichbar:
lowerbeta ist eine untere Grenze — der tatsächliche \(\beta\)-Wert kann höher liegen.gamma_estimate basiert auf dem Switching-Point-Verfahren und ist ebenfalls eine Schätzung.Die theoretische Erwartung \(\beta > \gamma\) (Eckel & Gintis, 2010; Fehr & Schmidt, 1999) bezieht sich auf die wahren Parameter, nicht auf die hier erhobenen Schätzungen. Die Ergebnisse sind daher als Tendenz zu interpretieren, nicht als exakter Test.
beta_gamma |>
ggplot(aes(x = gamma_estimate, y = lowerbeta)) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "grey50") +
geom_point(alpha = 0.5, color = col_purple, size = 2) +
annotate("text", x = max(beta_gamma$gamma_estimate) * 0.7,
y = max(beta_gamma$lowerbeta) * 0.9,
label = "β > γ\n(erwarteter Bereich)", color = "grey50", size = 3.5) +
labs(x = expression(hat(gamma) ~ "(Advantageous IA)"),
y = expression(hat(beta) ~ "(Disadvantageous IA)")) +
theme_minimal()
# Classify beta into groups: beta = 0 as separate, then tertiles of remaining finite values
beta_nonzero <- beta_finite[beta_finite > 0]
beta_tertiles <- quantile(beta_nonzero, probs = c(1/3, 2/3))
source(here::here("05_Analysis", "R", "apa_tables.R"))
# Berechne Gruppengrößen
n_beta_0 <- sum(df$lowerbeta == 0 & is.finite(df$lowerbeta), na.rm = TRUE)
n_beta_low <- sum(df$lowerbeta > 0 & df$lowerbeta <= beta_tertiles[1] & is.finite(df$lowerbeta), na.rm = TRUE)
n_beta_mid <- sum(df$lowerbeta > beta_tertiles[1] & df$lowerbeta <= beta_tertiles[2] & is.finite(df$lowerbeta), na.rm = TRUE)
n_beta_high <- sum(df$lowerbeta > beta_tertiles[2] & is.finite(df$lowerbeta), na.rm = TRUE)
# Vereinfachte β-Klassifikation für APA-Tabelle mit Gruppengrößen und Grenzen
df_beta_simple <- df |>
filter(is.finite(lowerbeta)) |>
mutate(
beta_group = case_when(
lowerbeta == 0 ~ paste0("β = 0 (n=", n_beta_0, ")"),
lowerbeta <= beta_tertiles[1] ~ paste0("Niedrig (n=", n_beta_low, ", β ≤ ", round(beta_tertiles[1], 2), ")"),
lowerbeta <= beta_tertiles[2] ~ paste0("Mittel (n=", n_beta_mid, ", β ≤ ", round(beta_tertiles[2], 2), ")"),
TRUE ~ paste0("Hoch (n=", n_beta_high, ", β > ", round(beta_tertiles[2], 2), ")")
),
beta_group = factor(beta_group, levels = c(
paste0("β = 0 (n=", n_beta_0, ")"),
paste0("Niedrig (n=", n_beta_low, ", β ≤ ", round(beta_tertiles[1], 2), ")"),
paste0("Mittel (n=", n_beta_mid, ", β ≤ ", round(beta_tertiles[2], 2), ")"),
paste0("Hoch (n=", n_beta_high, ", β > ", round(beta_tertiles[2], 2), ")")
)),
# Create additional variables for comparison
pct_zero = as.numeric(pwyw_price == 0) * 100,
pct_paid_c = as.numeric(abs(pwyw_price - production_costs) < 0.01) * 100,
pct_no_purchase = as.numeric(pwyw_no_purchase == 1) * 100,
ratio_pwyw_fair = if_else(fair_price > 0, pwyw_price / fair_price, NA_real_),
ratio_pwyw_wtp = if_else(willingness_to_pay > 0, pwyw_price / willingness_to_pay, NA_real_)
)# Fixed price behavior: threshold_price = highest price at which participant buys
# first_not_buy_price = first price at which participant refuses to buy
# Finite beta groups with additional variables
df_beta_fixprice <- df_beta_simple |>
mutate(
ratio_threshold_wtp = if_else(willingness_to_pay > 0, threshold_price / willingness_to_pay, NA_real_),
ratio_threshold_pf = if_else(fair_price > 0, threshold_price / fair_price, NA_real_),
pct_buy_at_pf = as.numeric(threshold_price >= fair_price) * 100
)
df_beta_fixprice |>
apa_desc_by(
threshold_price, first_not_buy_price, willingness_to_pay, fair_price,
ratio_threshold_wtp, ratio_threshold_pf, pct_buy_at_pf,
by = beta_group,
labels = c(
threshold_price = "Schwelle (€)",
first_not_buy_price = "1. Ablehnung (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fair Price (€)",
ratio_threshold_wtp = "Schwelle/WTP",
ratio_threshold_pf = "Schwelle/p_f",
pct_buy_at_pf = "Kauf bei p_f (%)"
),
note = "β = ∞ Teilnehmer (n = 15) nicht in dieser Tabelle enthalten (nie gekauft)."
)| Variable |
β = 0 (n=37)
|
Niedrig (n=28, β ≤ 0.43)
|
Mittel (n=29, β ≤ 1.5)
|
Hoch (n=24, β > 1.5)
|
F | df | p | η² | ||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | M | SD | M | SD | |||||
| Schwelle (€) | 4.31 | 3.36 | 5.15 | 3.44 | 3.96 | 2.75 | 2.94 | 2.05 | 2.38 | 3, 114 | .073 | 0.06 |
| 1. Ablehnung (€) | NA | NA | 5.29 | 3.54 | 4.09 | 2.84 | 3.07 | 2.14 | 3.76 | 2, 78 | .028 | 0.09 |
| WTP (€) | 4.31 | 3.36 | 5.81 | 3.89 | 5.24 | 3.50 | 5.15 | 3.48 | 1.00 | 3, 114 | .395 | 0.03 |
| Fair Price (€) | 3.32 | 2.55 | 4.29 | 2.87 | 3.67 | 2.47 | 3.19 | 2.14 | 1.06 | 3, 114 | .370 | 0.03 |
| Schwelle/WTP | 1.00 | 0.00 | 0.89 | 0.05 | 0.75 | 0.05 | 0.57 | 0.05 | 676.86 | 3, 114 | < .001 | 0.95 |
| Schwelle/p_f | 1.33 | 0.30 | 1.24 | 0.20 | 1.10 | 0.16 | 0.93 | 0.16 | 17.49 | 3, 114 | < .001 | 0.32 |
| Kauf bei p_f (%) | 100.00 | 0.00 | 89.29 | 31.50 | 79.31 | 41.23 | 25.00 | 44.23 | 28.28 | 3, 114 | < .001 | 0.43 |
| Note. β = ∞ Teilnehmer (n = 15) nicht in dieser Tabelle enthalten (nie gekauft). | ||||||||||||
Fixpreis-Variablen:
df_beta_simple |>
apa_desc_by(
pwyw_price, willingness_to_pay, fair_price, generosity,
pct_zero, pct_paid_c, pct_no_purchase, ratio_pwyw_fair, ratio_pwyw_wtp,
by = beta_group,
labels = c(
pwyw_price = "PWYW (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fair Price (€)",
generosity = "λ",
pct_zero = "p = 0 (%)",
pct_paid_c = "p = c (%)",
pct_no_purchase = "Nicht-Kauf (%)",
ratio_pwyw_fair = "PWYW/p_f",
ratio_pwyw_wtp = "PWYW/WTP"
),
note = paste0("Tertil-Grenzen: ", round(beta_tertiles[1], 2), " und ", round(beta_tertiles[2], 2),
". Finite β-Werte: n = ", sum(is.finite(df$lowerbeta)), ".")
)| Variable |
β = 0 (n=37)
|
Niedrig (n=28, β ≤ 0.43)
|
Mittel (n=29, β ≤ 1.5)
|
Hoch (n=24, β > 1.5)
|
F | df | p | η² | ||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | M | SD | M | SD | |||||
| PWYW (€) | 2.63 | 2.09 | 4.05 | 3.02 | 2.88 | 1.88 | 2.51 | 1.91 | 2.28 | 3, 90 | .085 | 0.07 |
| WTP (€) | 4.31 | 3.36 | 5.81 | 3.89 | 5.24 | 3.50 | 5.15 | 3.48 | 1.00 | 3, 114 | .395 | 0.03 |
| Fair Price (€) | 3.32 | 2.55 | 4.29 | 2.87 | 3.67 | 2.47 | 3.19 | 2.14 | 1.06 | 3, 114 | .370 | 0.03 |
| λ | 0.57 | 0.32 | 0.47 | 0.24 | 0.40 | 0.24 | 0.27 | 0.21 | 7.07 | 3, 114 | < .001 | 0.16 |
| p = 0 (%) | 3.85 | 19.61 | 3.85 | 19.61 | 0.00 | 0.00 | 11.11 | 32.34 | 1.05 | 3, 90 | .377 | 0.03 |
| p = c (%) | 3.85 | 19.61 | 3.85 | 19.61 | 20.83 | 41.49 | 11.11 | 32.34 | 1.88 | 3, 90 | .139 | 0.06 |
| Nicht-Kauf (%) | 29.73 | 46.34 | 7.14 | 26.23 | 17.24 | 38.44 | 25.00 | 44.23 | 1.86 | 3, 114 | .140 | 0.05 |
| PWYW/p_f | 1.02 | 0.44 | 0.91 | 0.28 | 0.95 | 0.29 | 0.87 | 0.48 | 0.61 | 3, 90 | .611 | 0.02 |
| PWYW/WTP | 0.76 | 0.26 | 0.68 | 0.20 | 0.65 | 0.20 | 0.54 | 0.32 | 2.71 | 3, 90 | .050 | 0.08 |
| Note. Tertil-Grenzen: 0.43 und 1.5. Finite β-Werte: n = 118. | ||||||||||||
β-Typ-Klassifikation:
Die Tertil-Grenzen werden auf Basis der β > 0 Werte berechnet.
Teilnehmer mit hohem β (starke Disadvantageous Inequity Aversion) zeigen:
Diese Teilnehmer sind besonders sensibel gegenüber Situationen, in denen der Verkäufer überprivilegiert ist. Möglicherweise übertragen sie diese Aversion auch auf das PWYW-Setting, obwohl dort keine externe Preissetzung stattfindet.
df |>
filter(is.finite(lowerbeta)) |>
apa_cor(
lowerbeta, pwyw_price, willingness_to_pay, fair_price,
generosity, gamma_estimate, altruism_composite,
labels = c(
lowerbeta = "β (Disadv. IA)",
pwyw_price = "PWYW-Preis",
willingness_to_pay = "WTP",
fair_price = "Fairer Preis",
generosity = "λ (Generosity)",
gamma_estimate = "γ (Adv. IA)",
altruism_composite = "Altruismus"
)
)| Variable | n | M | SD | 1 | 2 | 3 | 4 | 5 | 6 | 7 |
|---|---|---|---|---|---|---|---|---|---|---|
| 1. β (Disadv. IA) | 118 | 1.65 | 3.93 | — | ||||||
| 2. PWYW-Preis | 94 | 3.06 | 2.35 | -0.07 | — | |||||
| 3. WTP | 118 | 5.06 | 3.55 | 0.04 | 0.80*** | — | ||||
| 4. Fairer Preis | 118 | 3.61 | 2.54 | -0.05 | 0.82*** | 0.96*** | — | |||
| 5. λ (Generosity) | 118 | 0.44 | 0.28 | -0.33*** | 0.08 | -0.08 | 0.16 | — | ||
| 6. γ (Adv. IA) | 114 | 1.33 | 0.46 | 0.28** | -0.08 | -0.07 | -0.07 | -0.08 | — | |
| 7. Altruismus | 118 | 4.74 | 0.89 | 0.06 | 0.31** | 0.19* | 0.19* | -0.06 | 0.05 | — |
| *p < .05. **p < .01. ***p < .001. | ||||||||||
# Merge all parameter estimates
param_df <- gamma_individual |>
select(participant_code, gamma_estimate) |>
left_join(df |> select(participant_code, willingness_to_pay, generosity, lowerbeta), by = "participant_code") |>
filter(is.finite(lowerbeta))param_df |>
transmute(
r = willingness_to_pay,
lambda = generosity,
gamma = gamma_estimate,
beta = lowerbeta
) |>
tidyr::drop_na() |>
apa_cor(
r, lambda, gamma, beta,
labels = c(
r = "r (WTP)",
lambda = "λ (Generosity)",
gamma = "γ (Adv. IA)",
beta = "β (Disadv. IA)"
)
)| Variable | n | M | SD | 1 | 2 | 3 | 4 |
|---|---|---|---|---|---|---|---|
| 1. r (WTP) | 114 | 5.04 | 3.57 | — | |||
| 2. λ (Generosity) | 114 | 0.43 | 0.27 | -0.07 | — | ||
| 3. γ (Adv. IA) | 114 | 1.33 | 0.46 | -0.07 | -0.08 | — | |
| 4. β (Disadv. IA) | 114 | 1.53 | 3.64 | -0.00 | -0.34*** | 0.28** | — |
| *p < .05. **p < .01. ***p < .001. | |||||||
param_plot_df <- param_df |>
select(r = willingness_to_pay, lambda = generosity,
gamma = gamma_estimate, beta = lowerbeta) |>
tidyr::drop_na()
if (nrow(param_plot_df) > 5) {
pairs(param_plot_df,
col = adjustcolor(col_blue, alpha.f = 0.4),
pch = 16,
main = "Paarweise Beziehungen der Modellparameter")
}
Das Wiener Deewan ist ein bekanntes PWYW-Restaurant in Wien. Im Fragebogen wurden drei Variablen erhoben:
knows_wiener_deewan: Kenntnis des Restaurants (ja/nein)wiener_deewan_never_visited: Noch nie besucht (ja/nein, nur wenn bekannt)wiener_deewan_price: Gezahlter Preis beim letzten Besuch (€)# Stichprobengrößen
n_total <- nrow(df)
n_knows <- sum(df$knows_wiener_deewan, na.rm = TRUE)
n_never_visited <- sum(df$wiener_deewan_never_visited, na.rm = TRUE)
n_has_price <- sum(!is.na(df$wiener_deewan_price))
tibble(
Gruppe = c("Gesamt", "Kennt Deewan", "Nie besucht (von Kennern)", "Hat Preis angegeben"),
n = c(n_total, n_knows, n_never_visited, n_has_price),
`%` = round(c(100, n_knows/n_total*100, n_never_visited/n_knows*100, n_has_price/n_knows*100), 1)
) |>
gt() |>
gt_apa_style() |>
tab_footnote("Die Prozentangaben in Zeile 3 und 4 beziehen sich auf die Deewan-Kenner.")| Gruppe | n | % |
|---|---|---|
| Gesamt | 133 | 100.0 |
| Kennt Deewan | 65 | 48.9 |
| Nie besucht (von Kennern) | 12 | 18.5 |
| Hat Preis angegeben | 54 | 83.1 |
| Die Prozentangaben in Zeile 3 und 4 beziehen sich auf die Deewan-Kenner. | ||
df_deewan <- df |>
filter(!is.na(wiener_deewan_price))
df_deewan |>
apa_desc(wiener_deewan_price, labels = c(wiener_deewan_price = "Deewan-Preis (€)"))| Variable | n | M | SD | Min | Max |
|---|---|---|---|---|---|
| Deewan-Preis (€) | 54 | 7.50 | 2.79 | 0.00 | 15.00 |
ggplot(df_deewan, aes(x = wiener_deewan_price)) +
geom_histogram(binwidth = 1, fill = "steelblue", color = "white", alpha = 0.8) +
geom_vline(xintercept = mean(df_deewan$wiener_deewan_price),
linetype = "dashed", color = "red", linewidth = 1) +
labs(
x = "Gezahlter Preis (€)",
y = "Häufigkeit",
subtitle = paste0("M = ", round(mean(df_deewan$wiener_deewan_price), 2),
", SD = ", round(sd(df_deewan$wiener_deewan_price), 2),
", n = ", nrow(df_deewan))
) +
theme_minimal()
Eine zentrale Frage ist, ob Teilnehmer, die bereits PWYW-Erfahrung haben (Deewan-Besucher), sich im Experiment anders verhalten.
df_deewan |>
apa_desc(
wiener_deewan_price, pwyw_price, willingness_to_pay, fair_price,
labels = c(
wiener_deewan_price = "Deewan-Preis (€)",
pwyw_price = "PWYW-Experiment (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fair Price (€)"
)
)| Variable | n | M | SD | Min | Max |
|---|---|---|---|---|---|
| Deewan-Preis (€) | 54 | 7.50 | 2.79 | 0.00 | 15.00 |
| PWYW-Experiment (€) | 45 | 2.83 | 2.42 | 0.00 | 11.00 |
| WTP (€) | 54 | 4.73 | 3.34 | 0.50 | 15.00 |
| Fair Price (€) | 54 | 3.52 | 2.38 | 0.28 | 11.25 |
# Korrelationstest
cor_test <- cor.test(df_deewan$wiener_deewan_price, df_deewan$pwyw_price,
use = "pairwise.complete.obs")
ggplot(df_deewan, aes(x = wiener_deewan_price, y = pwyw_price)) +
geom_jitter(alpha = 0.6, size = 3, width = 0.3, height = 0.3) +
geom_smooth(method = "lm", se = TRUE, color = "steelblue") +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "gray50") +
labs(
x = "Deewan-Preis (€)",
y = "PWYW-Preis Experiment (€)",
subtitle = paste0("r = ", round(cor_test$estimate, 3),
", p = ", format.pval(cor_test$p.value, digits = 3),
", n = ", nrow(df_deewan))
) +
theme_minimal() +
coord_fixed(xlim = c(0, 16), ylim = c(0, 16))
Die gestrichelte Linie zeigt die Identitätslinie (Deewan = Experiment). Punkte oberhalb bedeuten höhere Zahlungen im Experiment.
Für Teilnehmer mit Deewan-Erfahrung: Korreliert ihr gezahlter Preis mit den geschätzten Parametern?
# Nur Teilnehmer mit Deewan-Preis und finiten Beta-Werten
df_cor <- df_deewan |>
filter(is.finite(lowerbeta)) |>
mutate(
ratio_pwyw_wtp = if_else(willingness_to_pay > 0, pwyw_price / willingness_to_pay, NA_real_),
ratio_pwyw_pf = if_else(fair_price > 0, pwyw_price / fair_price, NA_real_)
)
df_cor |>
apa_cor(
wiener_deewan_price, pwyw_price, willingness_to_pay, fair_price,
ratio_pwyw_wtp, ratio_pwyw_pf,
generosity, gamma_estimate, lowerbeta,
labels = c(
wiener_deewan_price = "Deewan",
pwyw_price = "PWYW",
willingness_to_pay = "WTP",
fair_price = "p_f",
ratio_pwyw_wtp = "PWYW/WTP",
ratio_pwyw_pf = "PWYW/p_f",
generosity = "λ",
gamma_estimate = "γ",
lowerbeta = "β"
)
)| Variable | n | M | SD | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 1. Deewan | 47 | 7.64 | 2.89 | — | ||||||||
| 2. PWYW | 40 | 2.95 | 2.54 | 0.21 | — | |||||||
| 3. WTP | 47 | 4.64 | 3.49 | 0.12 | 0.78*** | — | ||||||
| 4. p_f | 47 | 3.42 | 2.48 | 0.10 | 0.85*** | 0.96*** | — | |||||
| 5. PWYW/WTP | 40 | 0.71 | 0.25 | 0.25 | 0.21 | -0.28 | -0.17 | — | ||||
| 6. PWYW/p_f | 40 | 0.97 | 0.35 | 0.25 | 0.15 | -0.26 | -0.25 | 0.85*** | — | |||
| 7. λ | 47 | 0.50 | 0.27 | -0.03 | 0.08 | -0.11 | 0.12 | 0.34* | -0.18 | — | ||
| 8. γ | 45 | 1.34 | 0.50 | -0.01 | -0.07 | -0.13 | -0.13 | 0.10 | 0.14 | -0.06 | — | |
| 9. β | 47 | 1.33 | 3.09 | 0.27 | -0.02 | 0.08 | -0.03 | -0.20 | 0.00 | -0.38** | 0.39** | — |
| *p < .05. **p < .01. ***p < .001. | ||||||||||||
Die Korrelation zwischen Deewan-Preis und PWYW im Experiment (r ≈ 0.21) ist zwar nicht signifikant, zeigt aber einen positiven Zusammenhang. Die Ratio-Variablen (PWYW/WTP, PWYW/p_f) zeigen, wie viel Prozent der WTP bzw. des fairen Preises tatsächlich gezahlt wird.
df_comparison <- df |>
filter(!is.na(knows_wiener_deewan)) |>
mutate(
knows_deewan = as.logical(knows_wiener_deewan),
deewan_group = if_else(knows_deewan,
paste0("Kennt Deewan (n=", sum(knows_deewan), ")"),
paste0("Kennt nicht (n=", sum(!knows_deewan), ")")),
deewan_group = factor(deewan_group)
)
df_comparison |>
apa_desc_by(
pwyw_price, willingness_to_pay, fair_price, generosity,
by = deewan_group,
labels = c(
pwyw_price = "PWYW (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fair Price (€)",
generosity = "λ"
)
)| Variable |
Kennt Deewan (n=65)
|
Kennt nicht (n=68)
|
t | df | p | d | ||
|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | |||||
| PWYW (€) | 2.90 | 2.41 | 3.17 | 2.42 | −0.58 | 100.70 | .561 | 0.12 |
| WTP (€) | 4.83 | 3.32 | 5.47 | 3.63 | −1.07 | 130.75 | .289 | 0.18 |
| Fair Price (€) | 3.57 | 2.35 | 3.84 | 2.70 | −0.61 | 129.85 | .545 | 0.11 |
| λ | 0.51 | 0.27 | 0.40 | 0.28 | 2.21 | 130.99 | .029 | 0.38 |
| Note. Effect size is Cohen’s d. | ||||||||
Teilnehmer haben auch angegeben, wie oft sie PWYW nutzen (pwyw_usage_frequency). Unterscheiden sich Viel-Nutzer von Wenig-Nutzern?
df |>
count(pwyw_usage_frequency, name = "n") |>
mutate(pct = round(n / sum(n) * 100, 1)) |>
arrange(desc(n)) |>
gt() |>
gt_apa_style() |>
cols_label(
pwyw_usage_frequency = "Nutzungshäufigkeit",
n = "n",
pct = "%"
)| Nutzungshäufigkeit | n | % |
|---|---|---|
| never | 30 | 22.6 |
| very_rarely | 26 | 19.5 |
| rarely | 22 | 16.5 |
| frequently | 20 | 15.0 |
| occasionally | 19 | 14.3 |
| dont_know_concept | 11 | 8.3 |
| NA | 5 | 3.8 |
df_freq_base <- df |>
filter(!is.na(pwyw_usage_frequency))
# Berechne Gruppengrößen vorab
n_regular <- sum(df_freq_base$pwyw_usage_frequency %in% c("regularly", "occasionally"))
n_rarely <- sum(df_freq_base$pwyw_usage_frequency == "rarely")
n_never <- sum(df_freq_base$pwyw_usage_frequency == "never")
df_freq <- df_freq_base |>
mutate(
freq_group = case_when(
pwyw_usage_frequency %in% c("regularly", "occasionally") ~ paste0("Regelmäßig (n=", n_regular, ")"),
pwyw_usage_frequency == "rarely" ~ paste0("Selten (n=", n_rarely, ")"),
TRUE ~ paste0("Nie (n=", n_never, ")")
),
freq_group = factor(freq_group, levels = c(
paste0("Regelmäßig (n=", n_regular, ")"),
paste0("Selten (n=", n_rarely, ")"),
paste0("Nie (n=", n_never, ")")
))
)
# Add additional variables for comparison
df_freq <- df_freq |>
mutate(
pct_zero = as.numeric(pwyw_price == 0) * 100,
pct_no_purchase = as.numeric(pwyw_no_purchase == 1) * 100,
ratio_pwyw_fair = if_else(fair_price > 0, pwyw_price / fair_price, NA_real_)
)
df_freq |>
apa_desc_by(
pwyw_price, willingness_to_pay, fair_price, generosity, gamma_estimate,
pct_zero, pct_no_purchase, ratio_pwyw_fair,
by = freq_group,
labels = c(
pwyw_price = "PWYW (€)",
willingness_to_pay = "WTP (€)",
fair_price = "Fair Price (€)",
generosity = "λ",
gamma_estimate = "γ",
pct_zero = "p = 0 (%)",
pct_no_purchase = "Nicht-Kauf (%)",
ratio_pwyw_fair = "PWYW/p_f"
)
)| Variable |
Regelmäßig (n=19)
|
Selten (n=22)
|
Nie (n=30)
|
F | df | p | η² | |||
|---|---|---|---|---|---|---|---|---|---|---|
| M | SD | M | SD | M | SD | |||||
| PWYW (€) | 3.24 | 2.71 | 3.06 | 2.63 | 3.08 | 2.32 | 0.03 | 2, 95 | .970 | 0.00 |
| WTP (€) | 4.73 | 3.72 | 5.07 | 4.05 | 5.29 | 3.36 | 0.21 | 2, 125 | .814 | 0.00 |
| Fair Price (€) | 3.45 | 2.83 | 3.73 | 3.00 | 3.75 | 2.38 | 0.11 | 2, 125 | .896 | 0.00 |
| λ | 0.43 | 0.31 | 0.51 | 0.25 | 0.44 | 0.28 | 0.67 | 2, 125 | .514 | 0.01 |
| γ | 1.39 | 0.48 | 1.40 | 0.54 | 1.35 | 0.49 | 0.14 | 2, 118 | .870 | 0.00 |
| p = 0 (%) | 0.00 | 0.00 | 9.52 | 30.08 | 3.23 | 17.81 | 1.16 | 2, 95 | .317 | 0.02 |
| Nicht-Kauf (%) | 21.05 | 41.89 | 4.55 | 21.32 | 28.74 | 45.52 | 2.96 | 2, 125 | .055 | 0.05 |
| PWYW/p_f | 1.02 | 0.35 | 0.88 | 0.36 | 0.92 | 0.39 | 0.57 | 2, 95 | .566 | 0.01 |
| Note. Effect size is η² (eta-squared). | ||||||||||
# Key findings
r_deewan_pwyw <- cor(df_deewan$wiener_deewan_price, df_deewan$pwyw_price, use = "complete.obs")sessionInfo()R version 4.5.2 (2025-10-31 ucrt)
Platform: x86_64-w64-mingw32/x64
Running under: Windows 11 x64 (build 26200)
Matrix products: default
LAPACK version 3.12.1
locale:
[1] LC_COLLATE=German_Germany.utf8 LC_CTYPE=German_Germany.utf8
[3] LC_MONETARY=German_Germany.utf8 LC_NUMERIC=C
[5] LC_TIME=German_Germany.utf8
time zone: Europe/Berlin
tzcode source: internal
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] corrr_0.4.5 effectsize_1.0.1 broom_1.0.12 gtsummary_2.5.0
[5] gt_1.3.0 jsonlite_2.0.0 patchwork_1.3.2 here_1.0.2
[9] lubridate_1.9.5 forcats_1.0.1 stringr_1.6.0 dplyr_1.2.0
[13] purrr_1.2.1 readr_2.1.6 tidyr_1.3.2 tibble_3.3.1
[17] ggplot2_4.0.2 tidyverse_2.0.0
loaded via a namespace (and not attached):
[1] sass_0.4.10 generics_0.1.4 xml2_1.5.2 lattice_0.22-7
[5] stringi_1.8.7 hms_1.1.4 digest_0.6.39 magrittr_2.0.4
[9] evaluate_1.0.5 grid_4.5.2 timechange_0.4.0 RColorBrewer_1.1-3
[13] fastmap_1.2.0 Matrix_1.7-4 rprojroot_2.1.1 backports_1.5.0
[17] mgcv_1.9-3 scales_1.4.0 cli_3.6.5 rlang_1.1.7
[21] litedown_0.9 splines_4.5.2 commonmark_2.0.0 base64enc_0.1-6
[25] withr_3.0.2 yaml_2.3.12 datawizard_1.3.0 tools_4.5.2
[29] tzdb_0.5.0 bayestestR_0.17.0 vctrs_0.7.1 R6_2.6.1
[33] lifecycle_1.0.5 fs_1.6.6 htmlwidgets_1.6.4 insight_1.4.6
[37] pkgconfig_2.0.3 pillar_1.11.1 gtable_0.3.6 glue_1.8.0
[41] xfun_0.56 tidyselect_1.2.1 parameters_0.28.3 knitr_1.51
[45] farver_2.1.2 nlme_3.1-168 htmltools_0.5.9 labeling_0.4.3
[49] rmarkdown_2.30 compiler_4.5.2 S7_0.2.1 markdown_2.0