# RESPONDENTS’ PREFERRED SURVEY TOPICS: MEASUREMENT AND PREVALENCE

### Replication Files: Study 1

#### Tobias Gummer, Saskia Bartholomäus, and Bernd Weiss

#### 19.01.2026

# Introduction

Gummer, Tobias, Bartholomäus, Saskia, and Weiss, Bernd (2026): “Respondents’ Preferred Survey Topics: Measurement and Prevalence.” Survey Research Methods.

Respondents’ interest in a survey’s topic is used frequently by survey researchers to explain and predict survey errors. Whether respondents are interested in a survey’s content relates to their participation and cognitive answering processes, which consequently impacts nonresponse and measurement errors. Since the content of a survey is under the control of the researchers who design and conduct it, the content could be varied to improve participation and answering behavior. Unfortunately, research is lacking as to (i) how to measure these preferences, (ii) whether groups of respondents differ in their topic preferences, and (iii) the topic preferences in the social science survey samples. We have addressed this research gap by presenting the findings of three experimental studies that we conducted. In our study, we validated a measurement instrument to assess respondents’ topic interests. Moreover, we found that topic preferences varied between samples and respondent subgroups. However, across samples we consistently found that respondents were more interested in answering questions on personal rather than political topics. Based on our empirical findings, we provide practical recommendations for survey research and outline future research opportunities.

The ReplicationFileStudy1.html contains all analyses of study 1 reported in the cited article. The published R.Rmd files allow users to replicate the results. The data required for the replication code can be granted for scientific purposes upon request. To reproduce the analyses, please follow these steps:

1. Place all R.Rmd files in a subfolder named scripts and the data set in a subfolder named data.
2. Required R packages are listed and loaded in 01am_pre.Rmd. Please review this file to ensure that all necessary packages are installed before proceeding. Note that running 01am_pre.Rmd will automatically create all required subfolders for the workflow.
3. For the file 02dp_pre.Rmd, include the path to required data set in the first code chunk.
4. After making any necessary adjustments, you only need to run 05re_pre.Rmd. This file will source all other scripts and reproduce the analyses and results as described in the project.

Bartholomäus, S., and Gummer, T. (2025). PrADePS Pretest (SDN-10.7802-2635; Version 1.0.0) [Data set]. https://doi.org/10.7802/2635

    # Random Number Generation
    set.seed(42)

# Data Preparation

The data required for the replication code can be granted for scientific purposes upon request.

Bartholomäus, S., and Gummer, T. (2025). PrADePS Pretest (SDN-10.7802-2635; Version 1.0.0) [Data set]. https://doi.org/10.7802/2635

    # Loading Dataset
    cat("pretest_csv <- read.csv(file = '[INCLUDE PATH TO THE PRETEST DATA SET HERE]/20251007_PrADePSPretestData.csv', sep = ';')")

    ## pretest_csv <- read.csv(file = '[INCLUDE PATH TO THE PRETEST DATA SET HERE]/20251007_PrADePSPretestData.csv', sep = ';')

    # Renaming Variables
    pretest_csv <- dplyr::rename(
      pretest_csv,                    #dataset
      i_gender      = v_2683,         #newname = oldname
      i_birthyear   = rtr3p1_y,
      i_education   = v_2686,
      i_state       = v_2687,
      i_polinterest = jazc030a,
      s_interesting = jazq001a,

      m_migration   = v_2925,
      m_pol         = v_2927,
      m_crisis      = v_2932,
      m_nature      = v_2881,
      m_economy     = v_2882,
      m_work        = v_2886,
      m_media       = v_2890,
      m_well        = v_2891,
      m_values      = v_2895,
      i_comp        = v_2803)

    # Variable Labels
    labels <- list(
      i_gender         = "Gender",
      i_birthyear      = "Year of Birth",
      i_age            = "Age in Years",
      i_education      = "Educaional Level",
      i_state          = "Federal State",
      i_east           = "Eastern Germany",
      i_polinterest    = "Political Interest",
      st_polinterest   = "Political Interest",
      s_interesting    = "Survey is Interesting",

      tp_pol           = "Topic Interest Politics",
      tp_well          = "Topic Interest Well-Being",
      tp_nature        = "Topic Interest Nature",
      tp_values        = "Topic Interest Values",
      tp_media         = "Topic Interest Media",
      tp_work          = "Topic Interest Work",
      tp_migration     = "Topic Interest Migration",
      tp_economy       = "Topic Interest Economy",
      tp_crisis        = "Topic Interest Crisis",

      vb_quest         = "Questionnaire",
      vb_explain       = "Explanaition",
      vb_comp          = "Matrix")

    # Creating Subsets
    subset <- select(pretest_csv, lfdn, duration, i_gender : i_polinterest, s_interesting, v_2786 : v_2802, rnd_pg_7235041 : rnd_pg_7236459,
      m_migration, m_values, m_pol, m_crisis, m_nature, m_economy, m_work, m_media, m_well, i_comp)
    # subset for balance tests
    balance <- select(pretest_csv, i_gender : i_state)

    # Defining Missing Values
    pretest_csv[pretest_csv == -111 | pretest_csv == -77] <- NA

    subset[subset == -111 | subset == -77 | subset == 97 | subset == 98 | subset == 99] <- NA
    subset$lfdn <- pretest_csv$lfdn
    subset$duration <- pretest_csv$duration
    subset$duration[subset$duration == -111] <- NA

    # Defining Experimental Groups
    subset <- mutate(subset, vb_quest = ifelse(rnd_pg_7235041 == 7234835, 1, 0))
    balance$vb_quest <- subset$vb_quest

    subset <- mutate(subset, vb_explain = ifelse(rnd_pg_7235688 == 7235696, 1, 0))
    balance$vb_explain <- subset$vb_explain

    subset <- mutate(subset, vb_comp = case_match(rnd_pg_7236459, 7236339 ~ 1, 7236470 ~ 2, 7236473 ~ 3))
    balance$vb_comp <- subset$vb_comp

    subset <- set_labels(subset, vb_quest, labels = c("Politics" = 0, "Well-Being" = 1))
    subset <- set_labels(subset, vb_explain, labels = c("without Example" = 0, "with Example" = 1))
    subset <- set_labels(subset, vb_comp, labels = c("Economy, Work, Nature" = 1, "Media, Well-Being, Values" = 2, "Migration, Politics, Crisis" = 3))

    # Merging Variables of Groups
    subset <- mutate(subset, tp_pol = ifelse(!is.na(subset$v_2785), v_2785, v_2795))
    subset <- mutate(subset, tp_well = ifelse(!is.na(subset$v_2786), v_2786, v_2794))
    subset <- mutate(subset, tp_nature = ifelse(!is.na(subset$v_2787), v_2787, v_2796))
    subset <- mutate(subset, tp_values = ifelse(!is.na(subset$v_2788), v_2788, v_2797))
    subset <- mutate(subset, tp_media = ifelse(!is.na(subset$v_2789), v_2789, v_2798))
    subset <- mutate(subset, tp_work = ifelse(!is.na(subset$v_2790), v_2790, v_2799))
    subset <- mutate(subset, tp_migration = ifelse(!is.na(subset$v_2791), v_2791, v_2800))
    subset <- mutate(subset, tp_economy = ifelse(!is.na(subset$v_2792), v_2792, v_2801))
    subset <- mutate(subset, tp_crisis = ifelse(!is.na(subset$v_2793), v_2793, v_2802))

    subset <- set_labels(subset, tp_pol, tp_well, tp_nature, tp_values, tp_crisis, tp_media, tp_work, tp_migration, tp_economy,
      labels = c("not interested at all" = 1, "very interested" = 7))

    # share of correct assessments
    subset$m1 <- rowMeans(subset(pretest_csv, select = c(m_migration, m_pol, m_crisis)), na.rm = FALSE)
    subset$m2 <- rowMeans(subset(pretest_csv, select = c(m_nature, m_economy, m_work)), na.rm = FALSE)
    subset$m3 <- rowMeans(subset(pretest_csv, select = c(m_media, m_well, m_values)), na.rm = FALSE)

    subset$matrix_mean <- subset$m1
    subset <- mutate(subset, matrix_mean = ifelse(!is.na(subset$matrix_mean), matrix_mean, m2))
    subset <- mutate(subset, matrix_mean = ifelse(!is.na(subset$matrix_mean), matrix_mean, m3))

    # Defining Data Quality Indicators
    topic <- select(subset, tp_pol : tp_crisis)

    # extreme responding
    as.data.frame(extreme <- 1 * (topic == 1 | topic == 7))
      subset$extreme <- (rowSums(extreme, na.rm = FALSE))/9

    # midpoint responding
    as.data.frame(midpoint <- 1 * (topic == 4))
      subset$midpoint <- (rowSums(midpoint, na.rm = FALSE))/9

    # item nonresponse
    as.data.frame(na <- 1 * (is.na(topic)))
      subset$na <- (rowSums(na, na.rm = FALSE))/9

    # acquiescence
    as.data.frame(acquiescence <- 1 * (topic == 7 | topic == 6 | topic == 5))
      subset$acquiescence <- (rowSums(acquiescence, na.rm = FALSE))/9

    # comprehensability
    subset$i_comp <- (subset$i_comp - 1) / 6

    # Recoding Gender: randomly replace diverse values
    diverse <- subset$i_gender == 3
    subset$i_gender <- replace(subset$i_gender, diverse, sample(1:2, sum(diverse), TRUE, prob = c(0.5, 0.5)))
    rm(diverse)

    # Categorizing Education
    subset <- mutate(subset, i_education = case_match(i_education,
      1 ~ 2, 2 ~ 1, 3 ~ 1, 4 ~ 1, 5 ~ 2, 6 ~ 1, 7 ~ 2, 8 ~ 3, 9 ~ 3))
    balance$i_education <- subset$i_education

    subset <- set_labels(subset, i_education, labels = c("low" = 1, "medium" = 2, "high" = 3))

    # Recoding Political Interest
    subset <- mutate(subset, i_polinterest = case_match(i_polinterest, 1 ~ 5, 2 ~ 4, 3 ~ 3, 4 ~ 2, 5 ~ 1))

    subset <- set_labels(subset, i_polinterest, labels = c("not at all" = 1, "very strong" = 5))

    # Recoding Age in Years
    subset <- mutate(subset, i_age = 2022-i_birthyear)
    balance$i_age <- subset$i_age

    subset <- mutate(subset, age_group = case_when(i_age <= 30 ~ 1, i_age > 30 & i_age <= 48 ~ 2, i_age > 48 & i_age <= 63 ~ 3, i_age > 63 ~ 4))
    subset <- set_labels(subset, age_group, labels = c("<= 30" = 1, "> 30 & <= 49" = 2, "> 49 & <= 63" = 3, "> 63" = 4))

    # Recoding Residence in Germany
    subset <- mutate(subset, i_east = ifelse(              #gen var east
     i_state == 3 | i_state == 4 | i_state == 8 |          #2 if i_state = x
     i_state == 13 | i_state == 14 |i_state == 16, 2, 1))  #else 1

    subset <- set_labels(subset, i_east, labels = c("West Germany" = 1, "East Germany" = 2))

    balance <-  mutate(balance, i_east = ifelse(i_state == 3 | i_state == 4 | i_state == 8 | i_state == 13 | i_state == 14 |i_state == 16, 2, 1))
    balance <- mutate(balance, i_east = ifelse(i_state == 99, 0, i_east))

    # Defining Factor Variables
    subset$vb_quest <- as_factor(subset$vb_quest)
    subset$vb_explain <- as_factor(subset$vb_explain)
    subset$i_gender <- as_factor(subset$i_gender)
    subset$i_education <- as_factor(subset$i_education)
    subset$i_east <- as_factor(subset$i_east)
    subset$age_group <- as_factor(subset$age_group)
    #response$device_type <- as_factor(response$device_type)

    # Structure Dataset: long format
    long <- gather(subset, variable, matrix, m_migration:m_well)
      matrix1_long <- filter(long, vb_comp == 1, variable == "m_economy" | variable == "m_work" | variable == "m_nature")
      matrix2_long <- filter(long, vb_comp == 2, variable == "m_media" | variable == "m_well" | variable == "m_values")
      matrix3_long <- filter(long, vb_comp == 3, variable == "m_migration" | variable == "m_pol" | variable == "m_crisis")
    long <- smartbind(matrix1_long, matrix2_long, matrix3_long)
    rm(matrix1_long, matrix2_long, matrix3_long)

    long$tp_interest <- 0
    long <- mutate(long, tp_interest = ifelse(variable == "m_migration", tp_migration, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_crisis", tp_crisis, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_economy", tp_economy, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_media", tp_media, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_nature", tp_nature, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_pol", tp_pol, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_values", tp_values, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_well", tp_well, tp_interest))
    long <- mutate(long, tp_interest = ifelse(variable == "m_work", tp_work, tp_interest))

    # Save Datasets
    save(subset, labels, file = "data/subset.RData")
    save(balance, labels, file = "data/balance.RData")
    save(long, labels, file = "data/long.RData")

    # Clearing Memory
    rm(list = setdiff(ls(), c("custom_theme")))

## Balance Test

    # Loading Datasets
    load("data/balance.RData")

Age in Years

    bartlett.test(i_age ~ vb_explain, data = balance)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  i_age by vb_explain
    ## Bartlett's K-squared = 0.057939, df = 1, p-value = 0.8098

    tab <- map_df(list(t.test(balance$i_age ~ balance$vb_quest, var.equal = TRUE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3, caption = "Balance Test: Age in Years") %>%
      kable_styling()

Balance Test: Age in Years
Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
0.354 | 0.376 | 0.707 | -1.496 | 2.204 | Two Sample t-test

    rm(tab)

Gender (w/o diverse persons)

    balance$i_gender[balance$i_gender == 3] <- NA
    balance$i_gender <- as_factor(balance$i_gender)
    balance$vb_explain <- as_factor(balance$vb_explain)

    tab <- map_df(list(chisq.test(balance$i_gender, balance$vb_explain)), tidy)

    tab[c("statistic", "p.value", "parameter", "method")] %>%
      kbl(align = "llll", col.names = c("Chisq", "p.value", "df", "Method"), digits = 3, caption = "Balance Test: Gender (excluding diverse persons)") %>%
      kable_styling()

Balance Test: Gender (excluding diverse persons)
Chisq | p.value | df | Method
--- | --- | --- | ---
0.168 | 0.682 | 1 | Pearson’s Chi-squared test with Yates’ continuity correction

    rm(tab)

Education (by category)

    balance$i_education <- as_factor(balance$i_education)

    tab <- map_df(list(chisq.test(balance$i_education, balance$vb_explain)), tidy)

    tab[c("statistic", "p.value", "parameter", "method")] %>%
      kbl(align = "llll", col.names = c("Chisq", "p.value", "df", "Method"), digits = 3, caption = "Balance Test: Education (by category)") %>%
      kable_styling()

Balance Test: Education (by category)
Chisq | p.value | df | Method
--- | --- | --- | ---
10.026 | 0.007 | 2 | Pearson’s Chi-squared test

    tab <- table(balance$i_education, balance$vb_quest)
    tab_df <- as.data.frame.matrix(tab)
    rownames(tab_df) <- c("Low", "Intermediate", "High")

    kable(tab_df, align = "llll", col.names = c("without Example", "with Example"), row.names = TRUE, caption = "Number of Respondents by Education and Treatment") %>%
      kable_styling()

Number of Respondents by Education and Treatment
| without Example | with Example
--- | --- | ---
Low | 181 | 183
Intermediate | 183 | 187
High | 189 | 178

    rm(tab)

Residence in Germany

    balance$i_east <- as_factor(balance$i_east)

    tab <- map_df(list(chisq.test(balance$i_east, balance$vb_explain)), tidy)

    tab[c("statistic", "p.value", "parameter", "method")] %>%
      kbl(align = "llll", col.names = c("Chisq", "p.value", "df", "Method"), digits = 3, caption = "Balance Test: Residence in Germany (by state)") %>%
      kable_styling()

Balance Test: Residence in Germany (by state)
Chisq | p.value | df | Method
--- | --- | --- | ---
0.701 | 0.704 | 2 | Pearson’s Chi-squared test

    rm(tab, balance)

## Descriptive Results

    # Loading Datasets
    load("data/subset.RData")

Experimental Group

    sumtable(subset, vars = "vb_explain", label = "Questionnaire", out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Percent
--- | --- | ---
Questionnaire | 1101 |
… 0 | 518 | 47%
… 1 | 583 | 53%

Age in Years

    sumtable(subset, vars = "i_age", label = "Age in Years", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Age in Years | 1101 | 45.2 | 15.6 | 18 | 32 | 45 | 57 | 87

    sumtable(subset, vars = "age_group", label = "Age Group", out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Percent
--- | --- | ---
Age Group | 1101 |
… 1 | 243 | 22%
… 2 | 397 | 36%
… 3 | 304 | 28%
… 4 | 157 | 14%

Gender

    sumtable(subset, vars = "i_gender", label = "Gender", out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Percent
--- | --- | ---
Gender | 1101 |
… 1 | 549 | 50%
… 2 | 552 | 50%

Education

    sumtable(subset, vars = "i_education", label = "Education", out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Percent
--- | --- | ---
Education | 1101 |
… 1 | 364 | 33%
… 2 | 370 | 34%
… 3 | 367 | 33%

Eastern Germany

    sumtable(subset, vars = "i_east", label = "Residence in Germany", out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Percent
--- | --- | ---
Residence in Germany | 1024 |
… 1 | 792 | 77%
… 2 | 232 | 23%

Interest in Survey

    sumtable(subset, vars = "s_interesting", label = "Interestingness of the Survey", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Interestingness of the Survey | 1099 | 3.76 | 0.978 | 1 | 3 | 4 | 5 | 5

Acquiescence

    sumtable(subset, vars = "acquiescence", label = "Acquiescence", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Acquiescence | 1060 | 0.582 | 0.327 | 0 | 0.333 | 0.667 | 0.889 | 1

Extreme

    sumtable(subset, vars = "extreme", label = "Extreme Responding", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Extreme Responding | 1060 | 0.254 | 0.309 | 0 | 0 | 0.111 | 0.444 | 1

Midpoint

    sumtable(subset, vars = "midpoint", label = "Midpoint Responding", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Midpoint Responding | 1060 | 0.239 | 0.256 | 0 | 0 | 0.222 | 0.333 | 1

Item Nonresponse

    sumtable(subset, vars = "na", label = "Item Nonresponse", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Item Nonresponse | 1101 | 0.00626 | 0.0448 | 0 | 0 | 0 | 0 | 0.778

Comprehension

    sumtable(subset, vars = "i_comp", label = "Comprehension", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Comprehension | 1097 | 0.827 | 0.219 | 0 | 0.667 | 1 | 1 | 1

Correct Assessment

    sumtable(subset, vars = "matrix_mean", label = "Correct Assessment", add.median = TRUE, digits = 3, out = "kable") %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Correct Assessment | 1101 | 0.733 | 0.337 | 0 | 0.333 | 1 | 1 | 1

# Measurement Properties

Topic Popularity

    subset_tp <- select(subset, tp_nature, tp_crisis, tp_values, tp_economy, tp_well, tp_migration, tp_work, tp_pol, tp_media )
    subset_tp <- subset_tp[complete.cases(subset_tp), ]

    sumtable(subset_tp, vars=c("tp_well", "tp_values", "tp_nature", "tp_crisis",
      "tp_work", "tp_economy", "tp_pol", "tp_media", "tp_migration"),
      labels = c("Well-Being", "Values", "Nature", "Crisis", "Work", "Economy",
      "Politics", "Media", "Migration"), out = "kable", add.median = TRUE, digits = 3) %>%
      kableExtra::kable_styling(bootstrap_options = "basic")

Summary Statistics
Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max
--- | --- | --- | --- | --- | --- | --- | --- | ---
Well-Being | 1060 | 5.3 | 1.41 | 1 | 4 | 5 | 7 | 7
Values | 1060 | 5.23 | 1.49 | 1 | 4 | 5 | 7 | 7
Nature | 1060 | 5.05 | 1.61 | 1 | 4 | 5 | 7 | 7
Crisis | 1060 | 4.96 | 1.66 | 1 | 4 | 5 | 6 | 7
Work | 1060 | 4.88 | 1.54 | 1 | 4 | 5 | 6 | 7
Economy | 1060 | 4.71 | 1.57 | 1 | 4 | 5 | 6 | 7
Politics | 1060 | 4.44 | 1.81 | 1 | 3 | 4 | 6 | 7
Media | 1060 | 4.44 | 1.69 | 1 | 4 | 4 | 6 | 7
Migration | 1060 | 4.3 | 1.82 | 1 | 3 | 4 | 6 | 7

Test of Comparisons

    topics <- c("tp_nature", "tp_crisis", "tp_values", "tp_economy", "tp_well", "tp_migration", "tp_work", "tp_pol", "tp_media")
    tt_results <- list()

    for (i in 1:(length(topics) - 1)) {
        for (j in (i + 1):length(topics)) {
          var1 <- topics[i]
          var2 <- topics[j]

         tab <- map_df(list(t.test(subset_tp[[var1]], subset_tp[[var2]], paired = TRUE, alternative = "two.sided")), tidy)
         tt_results[[paste(var1, "_vs_", var2, sep = "")]] <- tab
        }
    }

    ttresults_df <- do.call(rbind, tt_results)
      ttresults_df$Comparison <- gsub("_vs_", " vs. ", rownames(ttresults_df))
      ttresults_df <- ttresults_df[c("Comparison", "estimate", "statistic", "p.value", "conf.low", "conf.high", "method")]

    ttresults_df[c("Comparison", "estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Comparison", "Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"),
          digits = 3, caption = "Difference of Topic Popularity") %>%
      kable_styling() %>%
      kableExtra::scroll_box(width = "100%", height = "300px")

Difference of Topic Popularity
Comparison | Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | --- | ---
tp_nature vs. tp_crisis | 0.093 | 1.719 | 0.086 | -0.013 | 0.200 | Paired t-test
tp_nature vs. tp_values | -0.180 | -3.931 | 0.000 | -0.270 | -0.090 | Paired t-test
tp_nature vs. tp_economy | 0.340 | 6.603 | 0.000 | 0.239 | 0.441 | Paired t-test
tp_nature vs. tp_well | -0.247 | -5.517 | 0.000 | -0.335 | -0.159 | Paired t-test
tp_nature vs. tp_migration | 0.746 | 12.313 | 0.000 | 0.627 | 0.865 | Paired t-test
tp_nature vs. tp_work | 0.170 | 3.230 | 0.001 | 0.067 | 0.273 | Paired t-test
tp_nature vs. tp_pol | 0.611 | 10.433 | 0.000 | 0.496 | 0.726 | Paired t-test
tp_nature vs. tp_media | 0.613 | 10.399 | 0.000 | 0.497 | 0.729 | Paired t-test
tp_crisis vs. tp_values | -0.274 | -5.364 | 0.000 | -0.374 | -0.173 | Paired t-test
tp_crisis vs. tp_economy | 0.246 | 5.536 | 0.000 | 0.159 | 0.334 | Paired t-test
tp_crisis vs. tp_well | -0.341 | -6.886 | 0.000 | -0.438 | -0.244 | Paired t-test
tp_crisis vs. tp_migration | 0.653 | 13.410 | 0.000 | 0.557 | 0.748 | Paired t-test
tp_crisis vs. tp_work | 0.076 | 1.493 | 0.136 | -0.024 | 0.177 | Paired t-test
tp_crisis vs. tp_pol | 0.518 | 10.513 | 0.000 | 0.421 | 0.615 | Paired t-test
tp_crisis vs. tp_media | 0.520 | 9.098 | 0.000 | 0.408 | 0.632 | Paired t-test
tp_values vs. tp_economy | 0.520 | 10.344 | 0.000 | 0.421 | 0.618 | Paired t-test
tp_values vs. tp_well | -0.067 | -2.018 | 0.044 | -0.132 | -0.002 | Paired t-test
tp_values vs. tp_migration | 0.926 | 15.637 | 0.000 | 0.810 | 1.043 | Paired t-test
tp_values vs. tp_work | 0.350 | 7.374 | 0.000 | 0.257 | 0.443 | Paired t-test
tp_values vs. tp_pol | 0.792 | 14.288 | 0.000 | 0.683 | 0.900 | Paired t-test
tp_values vs. tp_media | 0.793 | 14.337 | 0.000 | 0.685 | 0.902 | Paired t-test
tp_economy vs. tp_well | -0.587 | -12.039 | 0.000 | -0.682 | -0.491 | Paired t-test
tp_economy vs. tp_migration | 0.407 | 8.070 | 0.000 | 0.308 | 0.505 | Paired t-test
tp_economy vs. tp_work | -0.170 | -3.518 | 0.000 | -0.265 | -0.075 | Paired t-test
tp_economy vs. tp_pol | 0.272 | 5.874 | 0.000 | 0.181 | 0.362 | Paired t-test
tp_economy vs. tp_media | 0.274 | 4.848 | 0.000 | 0.163 | 0.384 | Paired t-test
tp_well vs. tp_migration | 0.993 | 17.167 | 0.000 | 0.880 | 1.107 | Paired t-test
tp_well vs. tp_work | 0.417 | 9.302 | 0.000 | 0.329 | 0.505 | Paired t-test
tp_well vs. tp_pol | 0.858 | 15.290 | 0.000 | 0.748 | 0.969 | Paired t-test
tp_well vs. tp_media | 0.860 | 16.192 | 0.000 | 0.756 | 0.965 | Paired t-test
tp_migration vs. tp_work | -0.576 | -10.351 | 0.000 | -0.686 | -0.467 | Paired t-test
tp_migration vs. tp_pol | -0.135 | -2.429 | 0.015 | -0.244 | -0.026 | Paired t-test
tp_migration vs. tp_media | -0.133 | -2.176 | 0.030 | -0.253 | -0.013 | Paired t-test
tp_work vs. tp_pol | 0.442 | 7.648 | 0.000 | 0.328 | 0.555 | Paired t-test
tp_work vs. tp_media | 0.443 | 8.566 | 0.000 | 0.342 | 0.545 | Paired t-test
tp_pol vs. tp_media | 0.002 | 0.029 | 0.977 | -0.127 | 0.130 | Paired t-test

    chi_results <- list()
    sim_results <- list()

    for (i in 1:(length(topics) - 1)) {
        for (j in (i + 1):length(topics)) {
          var1 <- topics[i]
          var2 <- topics[j]

         tab <- map_df(list(chisq.test(subset_tp[[var1]], subset_tp[[var2]])), tidy)

         tab2 <- map_df(list(chisq.test(subset_tp[[var1]], subset_tp[[var2]], simulate.p.value = TRUE)), tidy)

         chi_results[[paste(var1, "_vs_", var2, sep = "")]] <- tab
         sim_results[[paste(var1, "_vs_", var2, sep = "")]] <- tab2
        }
    }

    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein
    ## Warning in chisq.test(subset_tp[[var1]], subset_tp[[var2]]): Chi-Quadrat-Approximation kann inkorrekt sein

    chiresults_df <- do.call(rbind, chi_results)
      chiresults_df$Comparison <- gsub("_vs_", " vs. ", rownames(chiresults_df))
      chiresults_df <- chiresults_df[c("statistic", "p.value", "parameter", "method")]

    chiresults_df[c("statistic", "p.value", "parameter", "method")] %>%
      kbl(align = "llllll", col.names = c("Chisq", "p.value", "df", "Method"), digits = 3, caption = "Difference of Topic Popularity") %>%
      kable_styling()  %>%
      kableExtra::scroll_box(width = "100%", height = "300px")

Difference of Topic Popularity
Chisq | p.value | df | Method
--- | --- | --- | ---
517.252 | 0 | 36 | Pearson’s Chi-squared test
878.983 | 0 | 36 | Pearson’s Chi-squared test
542.759 | 0 | 36 | Pearson’s Chi-squared test
842.261 | 0 | 36 | Pearson’s Chi-squared test
417.751 | 0 | 36 | Pearson’s Chi-squared test
505.308 | 0 | 36 | Pearson’s Chi-squared test
441.558 | 0 | 36 | Pearson’s Chi-squared test
332.322 | 0 | 36 | Pearson’s Chi-squared test
610.117 | 0 | 36 | Pearson’s Chi-squared test
962.310 | 0 | 36 | Pearson’s Chi-squared test
614.954 | 0 | 36 | Pearson’s Chi-squared test
933.662 | 0 | 36 | Pearson’s Chi-squared test
678.072 | 0 | 36 | Pearson’s Chi-squared test
680.329 | 0 | 36 | Pearson’s Chi-squared test
486.981 | 0 | 36 | Pearson’s Chi-squared test
619.657 | 0 | 36 | Pearson’s Chi-squared test
1673.654 | 0 | 36 | Pearson’s Chi-squared test
402.592 | 0 | 36 | Pearson’s Chi-squared test
766.153 | 0 | 36 | Pearson’s Chi-squared test
541.688 | 0 | 36 | Pearson’s Chi-squared test
441.200 | 0 | 36 | Pearson’s Chi-squared test
623.551 | 0 | 36 | Pearson’s Chi-squared test
825.070 | 0 | 36 | Pearson’s Chi-squared test
775.513 | 0 | 36 | Pearson’s Chi-squared test
813.696 | 0 | 36 | Pearson’s Chi-squared test
542.665 | 0 | 36 | Pearson’s Chi-squared test
435.932 | 0 | 36 | Pearson’s Chi-squared test
824.499 | 0 | 36 | Pearson’s Chi-squared test
489.486 | 0 | 36 | Pearson’s Chi-squared test
476.613 | 0 | 36 | Pearson’s Chi-squared test
560.412 | 0 | 36 | Pearson’s Chi-squared test
553.667 | 0 | 36 | Pearson’s Chi-squared test
453.160 | 0 | 36 | Pearson’s Chi-squared test
397.669 | 0 | 36 | Pearson’s Chi-squared test
749.695 | 0 | 36 | Pearson’s Chi-squared test
247.401 | 0 | 36 | Pearson’s Chi-squared test

    simresults_df <- do.call(rbind, sim_results)
      simresults_df$Comparison <- gsub("_vs_", " vs. ", rownames(simresults_df))
      simresults_df <- simresults_df[c("statistic", "p.value", "parameter", "method")]

    simresults_df[c("statistic", "p.value", "parameter", "method")] %>%
      kbl(align = "llllll", col.names = c("Chisq", "p.value", "df", "Method"), digits = 3, caption = "Difference of Topic Popularity") %>%
      kable_styling()  %>%
      kableExtra::scroll_box(width = "100%", height = "300px")

Difference of Topic Popularity
Chisq | p.value | df | Method
--- | --- | --- | ---
517.252 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
878.983 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
542.759 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
842.261 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
417.751 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
505.308 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
441.558 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
332.322 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
610.117 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
962.310 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
614.954 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
933.662 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
678.072 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
680.329 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
486.981 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
619.657 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
1673.654 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
402.592 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
766.153 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
541.688 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
441.200 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
623.551 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
825.070 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
775.513 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
813.696 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
542.665 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
435.932 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
824.499 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
489.486 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
476.613 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
560.412 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
553.667 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
453.160 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
397.669 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
749.695 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)
247.401 | 0 | NA | Pearson’s Chi-squared test with simulated p-value (based on 2000 replicates)

By Political Interest

    m1 <- mean(subset$tp_pol[subset$i_polinterest == 1], na.rm = T)
    m2 <- mean(subset$tp_pol[subset$i_polinterest == 5], na.rm = T)
    tab <- rbind(m1, m2)
    tab <- data.frame(`Topic Interest in Politics` = round(c(m1, m2), 2))
    rownames(tab) <- c("low political interest", "high political interest")

    tab %>%  kbl(align = "llllll", col.names = c("Topic Interest in Politics")) %>%
      kable_styling()

| Topic Interest in Politics
--- | ---
low political interest | 2.11
high political interest | 6.21

# Principal Component Analysis

Identifying Number of Components

    i_topic <- select(subset, tp_nature, tp_crisis, tp_values, tp_economy, tp_well, tp_migration, tp_work, tp_pol, tp_media)
    i_topic <- i_topic[complete.cases(i_topic), ]

    scree_plot(i_topic, method="pc")

Table Principal Component Analysis

    fit_topic <- principal(i_topic, nfactors = 2, rotate = "varimax")
    results_pca <- as.data.frame.matrix(fit_topic[["loadings"]])
    results_pca <- cbind(results_pca, as.data.frame(fit_topic[["uniquenesses"]]))
    results_pca <- cbind(results_pca, as.data.frame(fit_topic[["complexity"]]))
    results_pca <- cbind(rownames(results_pca), data.frame(results_pca, row.names=NULL))
    colnames(results_pca)<- c("Topic Interest", "Factor Loadings 1", "Factor Loadings 2", "Uniqueness", "Complexity")
    results_pca[, 2:5] <- round(results_pca[, 2:5], 2)

    n_row <- data.frame("Topic Interest" = "N",
      "Factor Loadings 1" = fit_topic$n.obs, "Factor Loadings 2" = NA,
      "Uniqueness" = NA, "Complexity" = NA)
    eigenvalues <- fit_topic$values[1:2]
    eigenvalues_row <- data.frame("Topic Interest" = "Eigenvalues",
      "Factor Loadings 1" = round(eigenvalues[1], 2),
      "Factor Loadings 2" = round(eigenvalues[2], 2),
      "Uniqueness" = NA, "Complexity" = NA)

    colnames(eigenvalues_row) <- colnames(results_pca)
    colnames(n_row) <- colnames(results_pca)
    table_pca <- rbind(results_pca, eigenvalues_row, n_row)
    table_pca[table_pca[["Topic Interest"]] == "N", "Factor Loadings 1"] <- as.character(as.integer(table_pca[table_pca[["Topic Interest"]] == "N", "Factor Loadings 1"]))
    table_pca[is.na(table_pca)] <- ""

    vars <- c("tp_well", "tp_values", "tp_nature", "tp_crisis", "tp_work", "tp_economy", "tp_pol", "tp_media", "tp_migration")
    labels <- c("Well-Being", "Values", "Nature", "Crisis", "Work", "Economy", "Politics", "Media", "Migration")

    var_labels <- setNames(labels, vars)
    table_pca <- table_pca %>%
      mutate(`Topic Interest` = ifelse(`Topic Interest` %in% names(var_labels),
      var_labels[`Topic Interest`], `Topic Interest`))

Table Principal Component Analysis

    knitr::kable(table_pca)

Topic Interest | Factor Loadings 1 | Factor Loadings 2 | Uniqueness | Complexity
--- | --- | --- | --- | ---
Nature | 0.7 | 0.26 | 0.44 | 1.28
Crisis | 0.33 | 0.76 | 0.31 | 1.37
Values | 0.84 | 0.21 | 0.25 | 1.12
Economy | 0.33 | 0.76 | 0.31 | 1.37
Well-Being | 0.86 | 0.2 | 0.23 | 1.11
Migration | 0.18 | 0.8 | 0.33 | 1.1
Work | 0.6 | 0.41 | 0.47 | 1.78
Politics | 0.23 | 0.77 | 0.35 | 1.17
Media | 0.51 | 0.32 | 0.64 | 1.69
Eigenvalues | 4.6 | 1.07 |  |
N | 1060 |  |  |

Plot Principal Component Analysis

    g_pca <- ggplot(results_pca, aes(x = `Factor Loadings 2`, y = `Factor Loadings 1`)) +
      labs(x = "Factor Loadings 1", y = "Factor Loadings 2") +
      geom_point(aes(colour = `Factor Loadings 2` < 0.5 & `Factor Loadings 1` > 0.5), show.legend = FALSE) +
      geom_text(aes(label = c("nature and environment", "current crisis", "personality and values", "economy and society", "satisfaction and well-being", "flight and migration", "work and leisure", "political attiudes and behavior", "media and social networks")),
           hjust = 0, nudge_x = 0.02, size = 3, family = "Times New Roman", colour = "black") +
      theme_light() + custom_theme + scale_color_grey() +
      scale_y_continuous(limits = c(0, 1.)) +
      scale_x_continuous(limits = c(0, 1.)) +
      geom_hline(yintercept = 0.5) +
      geom_vline(xintercept = 0.5)

    g_pca

# Reasearch Question 1. Analyses

    crosstab <- CrossTable(subset$matrix_mean, prop.r = TRUE, prop.c = FALSE, prop.t = FALSE, prop.chisq = FALSE)

    t <- as.data.frame(crosstab[["t"]])
    t <- t %>% mutate(across(everything(), ~ as.character(.x)))
    prop <- as.data.frame(crosstab[["prop.row"]])
    prop <- prop %>% mutate(across(everything(), ~ .x * 100)) # <-- Multiply by 100
    prop <- prop %>% mutate(across(everything(), ~ formatC(.x, format = "f", digits = 2)))
    tab <- rbind(t, prop)
    rownames(tab) <- c("N", "prop.row")

    tab %>% kbl(align = "llllll", col.names = c("0", "0.333", "0.667", "1"), caption = "Share of Correct Assessments") %>%
      kable_styling()

Share of Correct Assessments
| 0 | 0.333 | 0.667 | 1
--- | --- | --- | --- | ---
N | 78 | 240 | 169 | 614
prop.row | 7.08 | 21.80 | 15.35 | 55.77

# Reasearch Question 2. Analyses

Regression Diagnostics

    # main model for regression diagnostics
    rmatrix <- glmer(matrix ~ vb_explain + tp_interest + s_interesting + i_education + age_group + i_gender + i_east + (1 | lfdn),
      data = long, family = "binomial", nAGQ=0)

    subset_long <- select(long, matrix, vb_explain, tp_interest, s_interesting, i_education, i_gender, age_group, i_east, lfdn)
    subset_long <- subset_long[complete.cases(subset_long), ]

Regression Model

    r_main <- glmer(matrix ~ vb_explain + (1 | lfdn),
      data = subset_long, family = "binomial", nAGQ=0)

    r_edu <- glmer(matrix ~ vb_explain + i_education +(1 | lfdn),
      data = subset_long, family = "binomial", nAGQ=0)

    r_socio <- glmer(matrix ~ vb_explain + i_education + age_group + i_gender + i_east +  (1 | lfdn),
      data = subset_long, family = "binomial", nAGQ=0)

    r_comp <- glmer(matrix ~ vb_explain + i_education + age_group + i_gender + i_east + tp_interest + s_interesting +  (1 | lfdn),
      data = subset_long, family = "binomial", nAGQ=0)

Comparisons Test

    c <- avg_comparisons(r_edu, variables = list(vb_explain = c(0, 1)), comparison = "difference")

    c1 <- avg_comparisons(r_comp, variables = list(s_interesting = c(1, 5)), comparison = "difference")
    c2 <- avg_comparisons(r_comp, variables = list(tp_interest = c(1, 7)), comparison = "difference")
    c3 <- avg_comparisons(r_comp, variables = list(i_education = c(1, 3)), comparison = "difference")

    c_matrix <- rbind(c, c1, c2, c3)
    c_matrix[c("term", "contrast", "estimate", "std.error", "statistic", "p.value")] %>%
        kbl(align = "llll", digits = 3) %>%
        kable_styling()

term | contrast | estimate | std.error | statistic | p.value
--- | --- | --- | --- | --- | ---
vb_explain | mean(1) - mean(0) | -0.030 | 0.022 | -1.380 | 0.168
s_interesting | mean(5) - mean(1) | 0.109 | 0.049 | 2.239 | 0.025
tp_interest | mean(7) - mean(1) | 0.051 | 0.033 | 1.564 | 0.118
i_education | mean(3) - mean(1) | 0.156 | 0.027 | 5.720 | 0.000

## Regression Tables

    tab_model(r_main, r_edu, r_socio, r_comp,
      show.est = TRUE, show.se = TRUE, show.ci = FALSE, show.aic = TRUE, collapse.se = TRUE, linebreak = TRUE,  p.style = "numeric", show.reflvl = TRUE,
      pred.labels = c("Intercept", "Topic Explanation", "Education: Intermediate", "Education: High", "31-48", "49-63", "63+", "Gender: Female", "Germany: East", "Topic Interest", "Survey Interest" ),
      dv.labels = c("Main Effect", "Controlled Effect I", "Controlled Effect II", "Competence Effect"),
      title = "Mixed Effects Logistic Regression Model: Correct Assessment of a Survey Questions' Topic",
      CSS = list(css.thead = 'border-top: 1px solid;', css.summary= 'border-bottom: 1px solid;', css.table = 'width: 100%;'))

Mixed Effects Logistic Regression Model: Correct Assessment of a Survey Questions’ Topic
| Main Effect | Controlled Effect I | Controlled Effect II | Competence Effect
--- | --- | --- | --- | ---
Predictors | Odds Ratios | p | Odds Ratios | p | Odds Ratios | p | Odds Ratios | p
Intercept | 4.49 (0.51) | <0.001 | 2.78 (0.43) | <0.001 | 1.50 (0.36) | 0.095 | 0.59 (0.23) | 0.173
Topic Explanation | 0.75 (0.12) | 0.066 | 0.81 (0.12) | 0.169 | 0.81 (0.12) | 0.153 | 0.81 (0.12) | 0.163
Education: Intermediate |  |  | 1.43 (0.26) | 0.049 | 1.63 (0.30) | 0.008 | 1.61 (0.30) | 0.009
Education: High |  |  | 2.68 (0.50) | <0.001 | 3.09 (0.59) | <0.001 | 2.97 (0.57) | <0.001
31-48 |  |  |  |  | 1.23 (0.25) | 0.302 | 1.20 (0.24) | 0.362
49-63 |  |  |  |  | 2.01 (0.45) | 0.002 | 1.86 (0.41) | 0.005
63+ |  |  |  |  | 1.92 (0.50) | 0.012 | 1.78 (0.46) | 0.025
Gender: Female |  |  |  |  | 1.43 (0.21) | 0.018 | 1.47 (0.22) | 0.010
Germany: East |  |  |  |  | 0.95 (0.17) | 0.765 | 0.95 (0.17) | 0.768
Topic Interest |  |  |  |  |  |  | 1.06 (0.04) | 0.112
Survey Interest |  |  |  |  |  |  | 1.20 (0.09) | 0.020
Random Effects
σ2 | 3.29 | 3.29 | 3.29 | 3.29
τ00 | 3.33 lfdn | 3.16 lfdn | 2.97 lfdn | 2.85 lfdn
ICC | 0.50 | 0.49 | 0.47 | 0.46
N | 1023 lfdn | 1023 lfdn | 1023 lfdn | 1023 lfdn
Observations | 3051 | 3051 | 3051 | 3051
Marginal R2 / Conditional R2 | 0.003 / 0.504 | 0.028 / 0.504 | 0.044 / 0.498 | 0.051 / 0.492
AIC | 3201.038 | 3163.606 | 3147.365 | 3137.330

## Regression Graphs

    graph_matrix = ggarrange( g_edu, g_tp, g_s, ncol = 1, nrow = 3)

    graph_matrix = annotate_figure(graph_matrix,
      top = text_grob("Predicted Values\nCorrect Assessment of a Survey Questions' Topic\nwith 95% Confidence Intervals", size = 10, family = "Times New Roman", face = "plain"))

    graph_matrix

# Reasearch Question 3. Analyses

## Correct Assessment

t-test for Difference in Means

    bartlett.test(matrix_mean ~ vb_explain, data = subset)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  matrix_mean by vb_explain
    ## Bartlett's K-squared = 2.1801, df = 1, p-value = 0.1398

    tab <- map_df(list(t.test(subset$matrix_mean ~ subset$vb_explain, var.equal = TRUE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3) %>%
      kable_styling()

Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
0.055 | 2.723 | 0.007 | 0.015 | 0.095 | Two Sample t-test

    t.test.cluster(long$matrix, cluster = long$lfdn, group = long$vb_explain)

    ##                                     0            1
    ## N                                   1554         1749
    ## Clusters                            518          583
    ## Mean                                0.7619048    0.7066895
    ## SS among clusters within groups     163.2381     208.5317
    ## SS within clusters within groups    118.6667     154.0000
    ## MS among clusters within groups     0.3382801
    ## d.f.                                1099
    ## MS within clusters within groups    0.1238268
    ## d.f.                                2202
    ## Na                                  2.997273
    ## Intracluster correlation            0.3662137
    ## Variance Correction Factor          1.732427     1.732427
    ## Variance of effect                  0.0002606979
    ## Variance without cluster adjustment 0.0001504813
    ## Design Effect                       1.732427
    ## Effect (Difference in Means)        -0.05521523
    ## S.E. of Effect                      0.01614614
    ## 0.95 Confidence limits              -0.08686108  -0.02356937
    ## Z Statistic                         -3.419716
    ## 2-sided P Value                     0.0006268645

## Topic Preferences

t-test for Difference in Means

    vb_results <- list()

    for (i in topics) {

        bartlett_result <- bartlett.test(subset[[i]] ~ subset$vb_explain)
        p_value_bartlett <- bartlett_result$p.value
        var_equal <- ifelse(p_value_bartlett > 0.05, TRUE, FALSE)

        t_test_result <- t.test(subset[[i]] ~ subset$vb_explain, alternative = "two.sided", var.equal = var_equal)

        t_test_tab <- broom::tidy(t_test_result)
        t_test_tab$Comparison <- paste(i, "_by_", "vb_explain", sep = "")
        vb_results[[paste(i, "_by_", "vb_explain", sep = "")]] <- rbind(t_test_tab)
    }

    vbresults_df <- do.call(rbind, vb_results)
    vbresults_df$Comparison <- gsub("_by_", " by ", rownames(vbresults_df))
    vbresults_df <- vbresults_df[c("Comparison", "estimate", "statistic", "p.value", "conf.low", "conf.high", "method")]

    vbresults_df[c("Comparison", "estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Comparison", "Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3,
      caption = "Topic Popularity by Experimental Group") %>%
      kable_styling() %>%
      kableExtra::scroll_box(width = "100%", height = "300px")

Topic Popularity by Experimental Group
Comparison | Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | --- | ---
tp_nature by vb_explain | -0.008 | -0.083 | 0.934 | -0.200 | 0.184 | Two Sample t-test
tp_crisis by vb_explain | 0.016 | 0.159 | 0.873 | -0.181 | 0.213 | Two Sample t-test
tp_values by vb_explain | 0.048 | 0.535 | 0.593 | -0.129 | 0.226 | Two Sample t-test
tp_economy by vb_explain | 0.016 | 0.172 | 0.863 | -0.170 | 0.203 | Two Sample t-test
tp_well by vb_explain | 0.081 | 0.944 | 0.345 | -0.087 | 0.249 | Welch Two Sample t-test
tp_migration by vb_explain | 0.120 | 1.087 | 0.277 | -0.097 | 0.337 | Two Sample t-test
tp_work by vb_explain | -0.006 | -0.063 | 0.950 | -0.189 | 0.177 | Two Sample t-test
tp_pol by vb_explain | 0.309 | 2.810 | 0.005 | 0.093 | 0.524 | Two Sample t-test
tp_media by vb_explain | -0.023 | -0.220 | 0.826 | -0.224 | 0.179 | Two Sample t-test

## Acquiescence

t-test for Difference in Means

    bartlett.test(acquiescence ~ vb_explain, data = subset)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  acquiescence by vb_explain
    ## Bartlett's K-squared = 0.056007, df = 1, p-value = 0.8129

    tab <- map_df(list(t.test(subset$acquiescence ~ subset$vb_explain, var.equal = TRUE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3) %>%
        kable_styling()

Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
0.014 | 0.707 | 0.48 | -0.025 | 0.054 | Two Sample t-test

    rm(tab)

Proportion Test

    prop_test_data <- subset %>%
      group_by(vb_explain) %>%
      dplyr::summarise( mean_acquiescence = mean(acquiescence, na.rm = TRUE), n = n()) %>%
      ungroup()

    prop_test_data <- prop_test_data %>%  mutate(count = mean_acquiescence * n)
    prop_test <- prop.test(prop_test_data$count, prop_test_data$n)
    tab <- tidy(prop_test)

    tab %>%  select(estimate1, estimate2, statistic, p.value, conf.low, conf.high, method) %>%
      kbl(align = "llllll", digits = 3) %>%
      kable_styling()

estimate1 | estimate2 | statistic | p.value | conf.low | conf.high | method
--- | --- | --- | --- | --- | --- | ---
0.589 | 0.575 | 0.173 | 0.677 | -0.046 | 0.074 | 2-sample test for equality of proportions with continuity correction

    rm(tab)

Regression Diagnostics

    # main model for regression diagnostics
    racqu <- lm(acquiescence ~ vb_explain + i_education, data= subset)

    # Breusch-Pagan test
    lmtest::bptest(racqu)

    ##
    ##  studentized Breusch-Pagan test
    ##
    ## data:  racqu
    ## BP = 13.682, df = 3, p-value = 0.003372

    # identifying influential cases
    cooksd <- cooks.distance(racqu)
    influential_acqu <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
    subset_acq <- subset[-c(influential_acqu), ]
    subset_acq <- select(subset_acq, acquiescence, vb_explain, i_education)
    subset_acq <- subset_acq[complete.cases(subset_acq), ]

Regression Model

    racqu <- lm_robust(acquiescence ~ vb_explain + i_education, data= subset)

Comparisons Test

    c <- avg_comparisons(racqu, variables = list(vb_explain = c(0, 1)), comparison = "difference")

    c[c("term", "contrast", "estimate", "std.error", "statistic", "p.value")] %>%
        kbl(align = "llll", digits = 3) %>%
        kable_styling()

term | contrast | estimate | std.error | statistic | p.value
--- | --- | --- | --- | --- | ---
vb_explain | mean(1) - mean(0) | -0.004 | 0.02 | -0.188 | 0.851

## Extreme Responding

t-test for Difference in Means

    bartlett.test(extreme ~ vb_explain, data = subset)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  extreme by vb_explain
    ## Bartlett's K-squared = 0.18482, df = 1, p-value = 0.6673

    tab <- map_df(list(t.test(subset$extreme ~ subset$vb_explain, var.equal = TRUE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3) %>%
        kable_styling()

Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
-0.025 | -1.322 | 0.187 | -0.062 | 0.012 | Two Sample t-test

    rm(tab)

Proportion Test

    prop_test_data <- subset %>%
      group_by(vb_explain) %>%
      dplyr::summarise(mean_extreme = mean(extreme, na.rm = TRUE), n = n()) %>%
      ungroup()

    prop_test_data <- prop_test_data %>% mutate(count = mean_extreme * n)
    prop_test <- prop.test(prop_test_data$count, prop_test_data$n)
    tab <- tidy(prop_test)

    tab %>% select(estimate1, estimate2, statistic, p.value, conf.low, conf.high, method) %>%
      kbl(align = "llllll", digits = 3) %>%
      kable_styling()

estimate1 | estimate2 | statistic | p.value | conf.low | conf.high | method
--- | --- | --- | --- | --- | --- | ---
0.241 | 0.266 | 0.786 | 0.375 | -0.078 | 0.028 | 2-sample test for equality of proportions with continuity correction

    rm(tab)

Regression Diagnostics

    # main model for regression diagnostics
    rext <- lm(extreme ~ vb_explain + i_education, data= subset)

    # Breusch-Pagan test
    lmtest::bptest(rext)

    ##
    ##  studentized Breusch-Pagan test
    ##
    ## data:  rext
    ## BP = 5.7053, df = 3, p-value = 0.1269

    # identifying influential cases
    cooksd <- cooks.distance(rext)
    influential_ext <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
    subset_ext <- subset[-c(influential_ext), ]
    subset_ext <- select(subset_ext, extreme, vb_explain, i_education)
    subset_ext <- subset_ext[complete.cases(subset_ext), ]

Regression Models

    rext <- lm(extreme ~ vb_explain + i_education, data= subset)

Comparisons Test

    c <- avg_comparisons(rext, variables = list(vb_explain = c(0, 1)), comparison = "difference")

    c[c("term", "contrast", "estimate", "std.error", "statistic", "p.value")] %>%
        kbl(align = "llll", digits = 3) %>%
        kable_styling()

term | contrast | estimate | std.error | statistic | p.value
--- | --- | --- | --- | --- | ---
vb_explain | mean(1) - mean(0) | 0.02 | 0.019 | 1.057 | 0.29

## Midpoint Responding

t-test for Difference in Means

    bartlett.test(midpoint ~ vb_explain, data = subset)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  midpoint by vb_explain
    ## Bartlett's K-squared = 0.0030992, df = 1, p-value = 0.9556

    tab <- map_df(list(t.test(subset$midpoint ~ subset$vb_explain, var.equal = TRUE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3) %>%
      kable_styling()

Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
0 | -0.001 | 0.999 | -0.031 | 0.031 | Two Sample t-test

    rm(tab)

Proportion Test

    prop_test_data <- subset %>%
      group_by(vb_explain) %>%
      dplyr::summarise(mean_midpoint = mean(midpoint, na.rm = TRUE), n = n()) %>%
      ungroup()

    prop_test_data <- prop_test_data %>% mutate(count = mean_midpoint * n)
    prop_test <- prop.test(prop_test_data$count, prop_test_data$n)
    tab <- tidy(prop_test)

    tab %>% select(estimate1, estimate2, statistic, p.value, conf.low, conf.high, method) %>%
      kbl(align = "llllll", digits = 3) %>%
      kable_styling()

estimate1 | estimate2 | statistic | p.value | conf.low | conf.high | method
--- | --- | --- | --- | --- | --- | ---
0.239 | 0.239 | 0 | 1 | -0.05 | 0.05 | 2-sample test for equality of proportions with continuity correction

    rm(tab)

Regression Diagnostics

    # main model for regression diagnostics
    rmid <- lm(midpoint  ~ vb_explain + i_education, data= subset)

    # Breusch-Pagan test
    lmtest::bptest(rmid)

    ##
    ##  studentized Breusch-Pagan test
    ##
    ## data:  rmid
    ## BP = 6.0382, df = 3, p-value = 0.1098

    # identifying influential cases
    cooksd <- cooks.distance(rmid)
    influential_mid <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
    subset_mid <- subset[-c(influential_mid), ]
    subset_mid <- select(subset_mid, midpoint, vb_explain, i_education)
    subset_mid <- subset_mid[complete.cases(subset_mid), ]

Regression Models

    rmid <- lm(midpoint ~ vb_explain + i_education, data= subset)

Comparisons Test

    c <- avg_comparisons(rmid, variables = list(vb_explain = c(0, 1)), comparison = "difference")

    c[c("term", "contrast", "estimate", "std.error", "statistic", "p.value")] %>%
        kbl(align = "llll", digits = 3) %>%
        kable_styling()

term | contrast | estimate | std.error | statistic | p.value
--- | --- | --- | --- | --- | ---
vb_explain | mean(1) - mean(0) | -0.004 | 0.016 | -0.252 | 0.801

## Item Nonresponse

t-test for Difference in Means

    bartlett.test(na ~ vb_explain, data = subset)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  na by vb_explain
    ## Bartlett's K-squared = 206.25, df = 1, p-value < 2.2e-16

    tab <- map_df(list(t.test(subset$na ~ subset$vb_explain, var.equal = FALSE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3) %>%
      kable_styling()

Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
-0.004 | -1.422 | 0.155 | -0.009 | 0.001 | Welch Two Sample t-test

    rm(tab)

Proportion Test

    prop_test_data <- subset %>%
      group_by(vb_explain) %>%
      dplyr::summarise(mean_na = mean(na, na.rm = TRUE), n = n()) %>%
      ungroup()

    prop_test_data <- prop_test_data %>% mutate(count = mean_na * n)
    prop_test <- prop.test(prop_test_data$count, prop_test_data$n)
    tab <- tidy(prop_test)

    tab %>% select(estimate1, estimate2, statistic, p.value, conf.low, conf.high, method) %>%
      kbl(align = "llllll", digits = 3) %>%
      kable_styling()

estimate1 | estimate2 | statistic | p.value | conf.low | conf.high | method
--- | --- | --- | --- | --- | --- | ---
0.004 | 0.008 | 0.158 | 0.691 | -0.015 | 0.007 | 2-sample test for equality of proportions with continuity correction

    rm(tab)

Regression Diagnostics

    # main model for regression diagnostics
    rna <- lm(na  ~ vb_explain + i_education, data= subset)

    # Breusch-Pagan test
    lmtest::bptest(rna)

    ##
    ##  studentized Breusch-Pagan test
    ##
    ## data:  rna
    ## BP = 5.7109, df = 3, p-value = 0.1266

    # identifying influential cases
    cooksd <- cooks.distance(rna)
    influential_na <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
    subset_na <- subset[-c(influential_na), ]
    subset_na <- select(subset_na, na, vb_explain, i_education)
    subset_na <- subset_na[complete.cases(subset_na), ]

Regression Models

    rna <- lm(na ~ vb_explain + i_education, data= subset)

Comparisons Test

    c <- avg_comparisons(rna, variables = list(vb_explain = c(0, 1)), comparison = "difference")

    c[c("term", "contrast", "estimate", "std.error", "statistic", "p.value")] %>%
        kbl(align = "llll", digits = 3) %>%
        kable_styling()

term | contrast | estimate | std.error | statistic | p.value
--- | --- | --- | --- | --- | ---
vb_explain | mean(1) - mean(0) | 0.003 | 0.003 | 1.189 | 0.235

## Comprehensibility

t-test for Difference in Means

    bartlett.test(i_comp ~ vb_explain, data = subset)

    ##
    ##  Bartlett test of homogeneity of variances
    ##
    ## data:  i_comp by vb_explain
    ## Bartlett's K-squared = 0.71633, df = 1, p-value = 0.3974

    tab <- map_df(list(t.test(subset$i_comp ~ subset$vb_explain, var.equal = TRUE, alternative = "two.sided")), tidy)

    tab[c("estimate", "statistic", "p.value", "conf.low", "conf.high", "method")] %>%
      kbl(align = "llllll", col.names = c("Difference in Means", "t", "p.value", "conf.low", "conf.high", "Method"), digits = 3) %>%
      kable_styling()

Difference in Means | t | p.value | conf.low | conf.high | Method
--- | --- | --- | --- | --- | ---
0.002 | 0.172 | 0.863 | -0.024 | 0.028 | Two Sample t-test

    rm(tab)

Regression Diagnostics

    # main model for regression diagnostics
    rcomp <- lm(i_comp  ~ vb_explain + i_education, data= subset)

    # Breusch-Pagan test
    lmtest::bptest(rcomp)

    ##
    ##  studentized Breusch-Pagan test
    ##
    ## data:  rcomp
    ## BP = 13.532, df = 3, p-value = 0.003617

    # identifying influential cases
    cooksd <- cooks.distance(rcomp)
    influential_comp <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
    subset_comp <- subset[-c(influential_comp), ]
    subset_comp <- select(subset_comp, i_comp, vb_explain, i_education)
    subset_comp <- subset_comp[complete.cases(subset_comp), ]

Regression Models

    rcomp <- lm(i_comp ~ vb_explain + i_education, data= subset)

Comparisons Test

    c <- avg_comparisons(rcomp, variables = list(vb_explain = c(0, 1)), comparison = "difference")

    c[c("term", "contrast", "estimate", "std.error", "statistic", "p.value")] %>%
        kbl(align = "llll", digits = 3) %>%
        kable_styling()

term | contrast | estimate | std.error | statistic | p.value
--- | --- | --- | --- | --- | ---
vb_explain | mean(1) - mean(0) | 0.002 | 0.013 | 0.146 | 0.884

## Regression Tables

    tab_model(racqu, rext, rmid, rna, rcomp,
      show.est = TRUE, show.se = TRUE, show.ci = FALSE, show.aic = TRUE, collapse.se = TRUE, linebreak = TRUE,  p.style = "numeric", show.reflvl = TRUE,
      pred.labels = c("Intercept", "Topic Explanation", "Education: Intermediate", "Education: High"),
      dv.labels = c("Acquiescence", "Extreme Responding", "Midpoint Responding", "Item Nonresponse", "Comprehension"),
      title = "OLS Regression Model: Data Quality by Experimental Group",
      CSS = list(css.thead = 'border-top: 1px solid;', css.summary= 'border-bottom: 1px solid;', css.table = 'width: 100%;'))

OLS Regression Model: Data Quality by Experimental Group
| Acquiescence | Extreme Responding | Midpoint Responding | Item Nonresponse | Comprehension
--- | --- | --- | --- | --- | ---
Predictors | Estimates | p | Estimates | p | Estimates | p | Estimates | p | Estimates | p
Intercept | 0.52 (0.02) | <0.001 | 0.28 (0.02) | <0.001 | 0.26 (0.02) | <0.001 | 0.01 (0.00) | 0.005 | 0.81 (0.01) | <0.001
Topic Explanation | -0.00 (0.02) | 0.851 | 0.02 (0.02) | 0.291 | -0.00 (0.02) | 0.801 | 0.00 (0.00) | 0.235 | 0.00 (0.01) | 0.884
Education: Intermediate | 0.05 (0.03) | 0.032 | -0.03 (0.02) | 0.138 | -0.00 (0.02) | 0.998 | -0.00 (0.00) | 0.276 | -0.00 (0.02) | 0.969
Education: High | 0.12 (0.02) | <0.001 | -0.06 (0.02) | 0.011 | -0.05 (0.02) | 0.016 | -0.01 (0.00) | 0.056 | 0.05 (0.02) | 0.002
Observations | 1060 | 1060 | 1060 | 1101 | 1097
R2 / R2 adjusted | 0.025 / 0.022 | 0.008 / 0.005 | 0.007 / 0.005 | 0.005 / 0.002 | 0.012 / 0.009
AIC | 620.771 | 520.895 | 118.649 | -3712.467 | -218.254

# Documentation

    out <- out <- capture.output(sessioninfo::session_info())
    out <- out[!grepl("^\\s*\\[\\d+\\]", out)]
    out <- out[!grepl("^\\s*quarto\\s+ERROR:", out)]
    cat(out, sep = "\n")

    ## ─ Session info ───────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
    ##  setting  value
    ##  version  R version 4.4.0 (2024-04-24 ucrt)
    ##  os       Windows 11 x64 (build 26100)
    ##  system   x86_64, mingw32
    ##  ui       RStudio
    ##  language (EN)
    ##  collate  German_Germany.utf8
    ##  ctype    German_Germany.utf8
    ##  tz       Europe/Berlin
    ##  date     2026-01-23
    ##  rstudio  2025.09.2+418 Cucumberleaf Sunflower (desktop)
    ##  pandoc   3.6.3 @ C:/Program Files/RStudio/resources/app/bin/quarto/bin/tools/ (via rmarkdown)
    ##
    ## ─ Packages ───────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
    ##  package         * version  date (UTC) lib source
    ##  abind             1.4-8    2024-09-12 [1] CRAN (R 4.4.1)
    ##  backports         1.5.0    2024-05-23 [1] CRAN (R 4.4.0)
    ##  base64enc         0.1-3    2015-07-28 [1] CRAN (R 4.4.0)
    ##  bayestestR        0.16.1   2025-07-01 [1] CRAN (R 4.4.3)
    ##  boot              1.3-31   2024-08-28 [1] CRAN (R 4.4.3)
    ##  broom           * 1.0.8    2025-03-28 [1] CRAN (R 4.4.3)
    ##  bslib             0.9.0    2025-01-30 [1] CRAN (R 4.4.3)
    ##  cachem            1.1.0    2024-05-16 [1] CRAN (R 4.4.0)
    ##  car               3.1-3    2024-09-27 [1] CRAN (R 4.4.3)
    ##  carData           3.0-5    2022-01-06 [1] CRAN (R 4.4.0)
    ##  checkmate         2.3.1    2023-12-04 [1] CRAN (R 4.4.0)
    ##  cli               3.6.5    2025-04-23 [1] CRAN (R 4.4.3)
    ##  cluster           2.1.6    2023-12-01 [1] CRAN (R 4.4.0)
    ##  coda              0.19-4.1 2024-01-31 [1] CRAN (R 4.4.1)
    ##  codetools         0.2-20   2024-03-31 [1] CRAN (R 4.4.0)
    ##  colorspace        2.1-0    2023-01-23 [1] CRAN (R 4.4.0)
    ##  cowplot           1.2.0    2025-07-07 [1] CRAN (R 4.4.3)
    ##  data.table        1.15.4   2024-03-30 [1] CRAN (R 4.4.0)
    ##  datawizard        1.1.0    2025-05-09 [1] CRAN (R 4.4.3)
    ##  devtools        * 2.4.6    2025-10-03 [1] CRAN (R 4.4.3)
    ##  dichromat         2.0-0.1  2022-05-02 [1] CRAN (R 4.4.0)
    ##  digest            0.6.35   2024-03-11 [1] CRAN (R 4.4.0)
    ##  dplyr           * 1.1.4    2023-11-17 [1] CRAN (R 4.4.0)
    ##  effectsize        1.0.1    2025-05-27 [1] CRAN (R 4.4.3)
    ##  ellipsis          0.3.2    2021-04-29 [1] CRAN (R 4.4.0)
    ##  emmeans           1.11.1   2025-05-04 [1] CRAN (R 4.4.3)
    ##  estimability      1.5.1    2024-05-12 [1] CRAN (R 4.4.0)
    ##  estimatr        * 1.0.4    2024-03-31 [1] CRAN (R 4.4.0)
    ##  evaluate          1.0.4    2025-06-18 [1] CRAN (R 4.4.3)
    ##  factoextra        1.0.7    2020-04-01 [1] CRAN (R 4.4.3)
    ##  farver            2.1.2    2024-05-13 [1] CRAN (R 4.4.0)
    ##  fastmap           1.2.0    2024-05-15 [1] CRAN (R 4.4.0)
    ##  forcats           1.0.0    2023-01-29 [1] CRAN (R 4.4.0)
    ##  foreign           0.8-86   2023-11-28 [1] CRAN (R 4.4.0)
    ##  Formula           1.2-5    2023-02-24 [1] CRAN (R 4.4.0)
    ##  fs                1.6.6    2025-04-12 [1] CRAN (R 4.4.3)
    ##  gdata             3.0.1    2024-10-22 [1] CRAN (R 4.4.3)
    ##  generics          0.1.4    2025-05-09 [1] CRAN (R 4.4.3)
    ##  ggeffects       * 2.3.0    2025-06-13 [1] CRAN (R 4.4.3)
    ##  ggplot2         * 3.5.2    2025-04-09 [1] CRAN (R 4.4.3)
    ##  ggpubr          * 0.6.1    2025-06-27 [1] CRAN (R 4.4.3)
    ##  ggrepel           0.9.6    2024-09-07 [1] CRAN (R 4.4.3)
    ##  ggsignif          0.6.4    2022-10-13 [1] CRAN (R 4.4.0)
    ##  glue              1.7.0    2024-01-09 [1] CRAN (R 4.4.0)
    ##  gmodels         * 2.19.1   2024-03-06 [1] CRAN (R 4.4.1)
    ##  gridExtra         2.3      2017-09-09 [1] CRAN (R 4.4.0)
    ##  gtable            0.3.6    2024-10-25 [1] CRAN (R 4.4.3)
    ##  gtools          * 3.9.5    2023-11-20 [1] CRAN (R 4.4.0)
    ##  haven             2.5.4    2023-11-30 [1] CRAN (R 4.4.0)
    ##  Hmisc           * 5.1-3    2024-05-28 [1] CRAN (R 4.4.0)
    ##  hms               1.1.3    2023-03-21 [1] CRAN (R 4.4.0)
    ##  htmlTable         2.4.3    2024-07-21 [1] CRAN (R 4.4.3)
    ##  htmltools         0.5.8.1  2024-04-04 [1] CRAN (R 4.4.0)
    ##  htmlwidgets       1.6.4    2023-12-06 [1] CRAN (R 4.4.0)
    ##  httr              1.4.7    2023-08-15 [1] CRAN (R 4.4.0)
    ##  insight           1.3.1    2025-06-30 [1] CRAN (R 4.4.3)
    ##  jquerylib         0.1.4    2021-04-26 [1] CRAN (R 4.4.0)
    ##  jsonlite          2.0.0    2025-03-27 [1] CRAN (R 4.4.3)
    ##  kableExtra      * 1.4.0    2024-01-24 [1] CRAN (R 4.4.0)
    ##  knitr           * 1.50     2025-03-16 [1] CRAN (R 4.4.3)
    ##  labeling          0.4.3    2023-08-29 [1] CRAN (R 4.4.0)
    ##  lattice           0.22-6   2024-03-20 [1] CRAN (R 4.4.0)
    ##  lifecycle         1.0.4    2023-11-07 [1] CRAN (R 4.4.0)
    ##  lme4            * 1.1-35.3 2024-04-16 [1] CRAN (R 4.4.0)
    ##  lmtest          * 0.9-40   2022-03-21 [1] CRAN (R 4.4.0)
    ##  magrittr          2.0.3    2022-03-30 [1] CRAN (R 4.4.0)
    ##  marginaleffects * 0.20.1   2024-05-08 [1] CRAN (R 4.4.0)
    ##  MASS              7.3-60.2 2024-04-24 [1] local
    ##  Matrix          * 1.7-0    2024-03-22 [1] CRAN (R 4.4.0)
    ##  memoise           2.0.1    2021-11-26 [1] CRAN (R 4.4.0)
    ##  minqa             1.2.7    2024-05-20 [1] CRAN (R 4.4.0)
    ##  mnormt            2.1.1    2022-09-26 [1] CRAN (R 4.4.0)
    ##  multcomp          1.4-28   2025-01-29 [1] CRAN (R 4.4.3)
    ##  mvtnorm           1.2-5    2024-05-21 [1] CRAN (R 4.4.1)
    ##  nlme              3.1-164  2023-11-27 [1] CRAN (R 4.4.0)
    ##  nloptr            2.0.3    2022-05-26 [1] CRAN (R 4.4.0)
    ##  nnet              7.3-19   2023-05-03 [1] CRAN (R 4.4.0)
    ##  parameters        0.27.0   2025-07-09 [1] CRAN (R 4.4.0)
    ##  performance       0.14.0   2025-05-22 [1] CRAN (R 4.4.3)
    ##  pillar            1.11.0   2025-07-04 [1] CRAN (R 4.4.3)
    ##  pkgbuild          1.4.8    2025-05-26 [1] CRAN (R 4.4.3)
    ##  pkgconfig         2.0.3    2019-09-22 [1] CRAN (R 4.4.0)
    ##  pkgload           1.4.1    2025-09-23 [1] CRAN (R 4.4.3)
    ##  plyr            * 1.8.9    2023-10-02 [1] CRAN (R 4.4.0)
    ##  psych           * 2.5.6    2025-06-23 [1] CRAN (R 4.4.3)
    ##  purrr           * 1.0.2    2023-08-10 [1] CRAN (R 4.4.0)
    ##  qacDR           * 0.1.0    2025-03-26 [1] Github (rkabacoff/qacDR@fd1d6a0)
    ##  R6                2.6.1    2025-02-15 [1] CRAN (R 4.4.3)
    ##  rbibutils         2.3      2024-10-04 [1] CRAN (R 4.4.3)
    ##  RColorBrewer      1.1-3    2022-04-03 [1] CRAN (R 4.4.0)
    ##  Rcpp              1.0.12   2024-01-09 [1] CRAN (R 4.4.0)
    ##  Rdpack            2.6.4    2025-04-09 [1] CRAN (R 4.4.3)
    ##  reformulas        0.4.1    2025-04-30 [1] CRAN (R 4.4.3)
    ##  remotes           2.5.0    2024-03-17 [1] CRAN (R 4.4.0)
    ##  rlang             1.1.4    2024-06-04 [1] CRAN (R 4.4.0)
    ##  rmarkdown         2.29     2024-11-04 [1] CRAN (R 4.4.3)
    ##  rpart             4.1.23   2023-12-05 [1] CRAN (R 4.4.0)
    ##  rprojroot         2.1.1    2025-08-26 [1] CRAN (R 4.4.3)
    ##  rstatix           0.7.2    2023-02-01 [1] CRAN (R 4.4.0)
    ##  rstudioapi        0.17.1   2024-10-22 [1] CRAN (R 4.4.3)
    ##  sandwich        * 3.1-1    2024-09-15 [1] CRAN (R 4.4.3)
    ##  sass              0.4.10   2025-04-11 [1] CRAN (R 4.4.3)
    ##  scales            1.4.0    2025-04-24 [1] CRAN (R 4.4.3)
    ##  sessioninfo       1.2.3    2025-02-05 [1] CRAN (R 4.4.3)
    ##  sjlabelled      * 1.2.0    2022-04-10 [1] CRAN (R 4.4.0)
    ##  sjmisc            2.8.10   2024-05-13 [1] CRAN (R 4.4.0)
    ##  sjPlot          * 2.8.17   2024-11-29 [1] CRAN (R 4.4.3)
    ##  sjstats           0.19.1   2025-06-13 [1] CRAN (R 4.4.3)
    ##  snakecase         0.11.1   2023-08-27 [1] CRAN (R 4.4.1)
    ##  stringi           1.8.4    2024-05-06 [1] CRAN (R 4.4.0)
    ##  stringr           1.5.1    2023-11-14 [1] CRAN (R 4.4.0)
    ##  survival          3.5-8    2024-02-14 [1] CRAN (R 4.4.0)
    ##  svglite           2.1.3    2023-12-08 [1] CRAN (R 4.4.0)
    ##  systemfonts       1.1.0    2024-05-15 [1] CRAN (R 4.4.0)
    ##  texreg            1.39.4   2024-07-24 [1] CRAN (R 4.4.3)
    ##  TH.data           1.1-3    2025-01-17 [1] CRAN (R 4.4.3)
    ##  tibble            3.2.1    2023-03-20 [1] CRAN (R 4.4.0)
    ##  tidyr           * 1.3.1    2024-01-24 [1] CRAN (R 4.4.0)
    ##  tidyselect        1.2.1    2024-03-11 [1] CRAN (R 4.4.0)
    ##  usethis         * 3.2.1    2025-09-06 [1] CRAN (R 4.4.3)
    ##  vctrs             0.6.5    2023-12-01 [1] CRAN (R 4.4.0)
    ##  viridisLite       0.4.2    2023-05-02 [1] CRAN (R 4.4.1)
    ##  vtable          * 1.4.8    2024-12-21 [1] CRAN (R 4.4.3)
    ##  withr             3.0.2    2024-10-28 [1] CRAN (R 4.4.3)
    ##  xfun              0.52     2025-04-02 [1] CRAN (R 4.4.3)
    ##  xml2              1.3.6    2023-12-04 [1] CRAN (R 4.4.0)
    ##  xtable            1.8-4    2019-04-21 [1] CRAN (R 4.4.0)
    ##  yaml              2.3.8    2023-12-11 [1] CRAN (R 4.4.0)
    ##  zoo             * 1.8-12   2023-04-13 [1] CRAN (R 4.4.0)
    ##
    ##  * ── Packages attached to the search path.
    ##
    ## ──────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────