Drag and Drop Lottery (Preference) Pilot Study (N=30)

Drag and Drop Preference Study (Lotteries)

1. Descriptive Statistics of Respondent Effort in the Task

1.1 Drag-and-drop count

• Definition: The number of drag-and-drop actions (recorded with the RankCount) - only counts when the a drag-and-drop action results in an order change

### plot ###

plot_quiz <- function(data, column, title, item_n) {
  n_obs <- nrow(data)  # Total number of rows
  mean_val <- mean(data[[column]], na.rm = TRUE)  # Calculate mean
  median_val <- median(data[[column]], na.rm = TRUE)  # Calculate median
  subtitle_text <- paste0("Item.N = ", item_n, "; Subj.N = ", n_obs,
                          ", Mean = ", round(mean_val, 2),
                          ", Median = ", round(median_val, 2))
  
  ggplot(data, aes(x = "", y = !!sym(column))) + 
    geom_violin(fill = "lightblue", alpha = 0.5) + 
    geom_boxplot(width = 0.1, color = "black", alpha = 0.8) + 
    geom_jitter(width = 0.1, size = 1.5, color = "black", alpha = 0.6)+ 
    theme_minimal() + 
    labs(
      title = title,
      subtitle = subtitle_text,
      x = "",
      y = "Drag count"
    ) + 
    theme(plot.title = element_text(hjust = 0.5, face="bold"), plot.subtitle = element_text(hjust = 0.5)) +
    scale_y_continuous(breaks = seq(0, 10, by = 1), limits = c(0, 10))
}

# Create plots for each quiz

Quiz_WarmUp <- plot_quiz(dat, "RankCount_WarmUp", "Warm Up", item_n = 5)
Quiz_Prob  <- plot_quiz(dat, "RankCount_Prob", "Probability", item_n = 6)
Quiz_Amt <- plot_quiz(dat, "RankCount_Amount", "Amount", item_n = 6)
Quiz_Pref1  <- plot_quiz(dat, "RankCount_Prefer1", "Preference (1st)", item_n = 6)
Quiz_Pref2  <- plot_quiz(dat, "RankCount_Prefer2", "Preference (2nd)", item_n = 6)

# Combine all plots into one graph
combined_plot <- (Quiz_WarmUp | Quiz_Prob | Quiz_Amt | Quiz_Pref1| Quiz_Pref2)
combined_plot

1.2 Correlation between initial and final rank

• RankProcess data format: {0, initial rank order}{timestamp, new rank order}, etc.
• low correlations between initial and final rank for all 6 items across quiz conditions.

# dat_A$RankProcess_A
# dat_A$TaskA_40 # while the final rank in the RankProcess variable is inaccurate for the reason mentioned above, the initial rank is. We will correct the issue pertaining to the final rank later in the notebook. 2024/11/26

process_task <- function(data, rank_column, task_label) {
  # Extract the initial order
  initial_order <- sub("^\\{([^}]*)\\}.*", "\\1", data[[rank_column]]) # captures the content within the first {} in the string; we will apply this to the RankProcess column; Using double bracket to capture a vector 

  initial_order <- gsub("0; ", "", initial_order) # remove the 0 timestamp
  initial_order_split <- strsplit(initial_order, ",") # separate the strings into list
  
  # Identify unique items
  unique_items <- unique(unlist(initial_order_split))
  
  # Create a data frame to store initial ranks
  initial_positions_df <- data.frame(matrix(ncol = length(unique_items), nrow = length(initial_order_split))) # nrow is the number of respondents 
  names(initial_positions_df) <- paste0("initial.items_", unique_items)
  
  # Fill initial ranks
  for (i in seq_along(initial_order_split)) {
    initial_order <- initial_order_split[[i]] # for each respondent, extract the string of initial order
    for (j in seq_along(initial_order)) {
      item <- initial_order[j]
      initial_positions_df[i, paste0("initial.items_", item)] <- j
    }
  }
  
  data <- cbind(data, initial_positions_df)
  assign(paste0("initial.dat_", task_label), data, envir = .GlobalEnv)
  
  cor_results <- data.frame(
    item = paste0("rank_", task_label, "_", unique_items),
    initial_item = paste0("initial.items_", unique_items),
    correlation = NA_real_,
    p_value = NA_real_
  )
  
  cor_results <- cor_results %>% # it is important to do this step by Task, because IDs are only unique and consistent within each quiz.
    rowwise() %>%
    mutate(
      correlation = cor.test(data[[item]], data[[initial_item]])$estimate,
      p_value = cor.test(data[[item]], data[[initial_item]])$p.value
    ) %>%
    mutate(sig = p_value < 0.05) 
  
  cor_results$task <- task_label
  cor_results
}


# List of datasets, rank columns, and task labels
tasks <- list(
  
  list(data = dat, rank_column = "RankProcess_Prob", task_label = "prob"),
  list(data = dat, rank_column = "RankProcess_Amount", task_label = "amount"),
  list(data = dat, rank_column = "RankProcess_Prefer1", task_label = "Pref1"),
  list(data = dat, rank_column = "RankProcess_Prefer2", task_label = "Pref2")
)


all_results <- bind_rows(lapply(tasks, function(t) {
  process_task(t$data, t$rank_column, t$task_label)
}))



summary_stats <- all_results %>%
  group_by(task) %>%
  summarise(
    Mean = round(mean(correlation, na.rm = TRUE), 2),
    Median = round(median(correlation, na.rm = TRUE), 2),
    N = n()
  )

# summary_stats

all_results$task <- as.factor(all_results$task)
all_results$task <- factor(all_results$task, levels = c("amount", "prob", "Pref1", "Pref2"))



combined_plot <- ggplot(all_results, aes(x = task, y = correlation)) + 
  geom_violin(fill = "lightblue", alpha = 0.5) + 
  geom_jitter(aes(color = sig), width = 0.1, size = 1.5, alpha = 0.6) + 
  scale_color_manual(
    values = c("TRUE" = "red", "FALSE" = "black"), 
    labels = c("ns.", "p<.05"), 
    name = "p value"
  ) + 
  theme_minimal() + 
  labs(
    title = " Correlations for Initial and Final Ranks Across Tasks",
        subtitle = paste(
      " Color Task: Mean =", summary_stats$Mean[1], ", Median =", summary_stats$Median[1], ", N =", summary_stats$N[1], "\n",
      " Prob Task: Mean =", summary_stats$Mean[2], ", Median =", summary_stats$Median[2], ", N =", summary_stats$N[2], "\n"
    ),
    x = "Task",
    y = "Correlation"
  ) +
  theme(
    plot.title = element_text(hjust = 0.5),
    plot.subtitle = element_text(hjust = 0.5)
  )

# Print the plot
print(combined_plot)

# if one variable has no sd, the result will be NA. E.g., if everyone rank the item in the same place.


# Examination
# initial_order <- sub("^\\{([^}]*)\\}.*", "\\1", dat_A[["RankProcess_A"]]) # captures the content within the first {} in the string; we will apply this to the RankProcess column
#   initial_order <- gsub("0; ", "", initial_order) # remove the 0 timestamp
#   initial_order_split <- strsplit(initial_order, ",")
# initial_order
# initial_order_split

1.3 Rank Quiz Page Duration (seconds)

# each extract a dataset for each task and then do the psych mean thing

summarize_task <- function(data, column_name, task_name) {
  data %>%
    summarise(
      Task = task_name,
      Mean_t = mean(.data[[column_name]], na.rm = TRUE),
      Median_t = median(.data[[column_name]], na.rm = TRUE),
      SD = sd(.data[[column_name]], na.rm = TRUE),
      Min = min(.data[[column_name]], na.rm = TRUE),
      Max = max(.data[[column_name]], na.rm = TRUE),
      N = sum(!is.na(.data[[column_name]]))
    )
}

# Apply the function to each dataset


summary_warmup <- summarize_task(dat, "t_warmup_Page.Submit", "WarmUp")
summary_prob <- summarize_task(dat, "t_rank_prob_Page.Submit", "Probability")
summary_amt <- summarize_task(dat, "t_rank_amt_Page.Submit", "Amount")
summary_pref1 <- summarize_task(dat, "t_rank_pref1_Page.Submit", "Preference 1ST")
summary_pref2 <- summarize_task(dat, "t_rank_pref2_Page.Submit", "Preference 2ND")
# summary_Binary <- summarize_task(dat, "t_Prob_Page.Submit", "Prob")



# Combine all summaries into one table
all_summaries <- bind_rows(summary_warmup,summary_prob, summary_amt, summary_pref1,summary_pref2 )


# t.test(dat$t_Prob_Page.Submit,dat$rank_color_t_Page.Submit)
all_summaries

Preliminaries

Jitter Randomization Check

• 1ST Preference Ranking Task

# --- True lottery values and jitter ranges ---
prob <- c(5, 9, 17, 29, 54, 94)
amount <- c(56.7, 31.5, 17.5, 9.7, 5.4, 2.9)

bounded_jitter <- list(
  prob = c(2, 2, 6, 6, 18, 5),
  amt  = c(15.95, 9.25, 4.75, 3.05, 1.25, 1.25)
)

# --- Mapping from Set1_L1–L6 to correct lottery ---
lottery_mapping <- tibble(
  input_lottery = 1:6,
  lottery = factor(7 - input_lottery)
)

# --- Reshape wide-format jitter data to long format ---
jitter_check <- bind_rows(lapply(1:6, function(i) {
  tibble(
    ResponseId = dat$ResponseId,
    input_lottery = i,
    prob = dat[[paste0("Set1_L", i, "_Prob")]],
    amount = dat[[paste0("Set1_L", i, "_Amt")]]
  )
})) %>%
  left_join(lottery_mapping, by = "input_lottery") %>%
  select(ResponseId, lottery, prob, amount) %>%
  filter(!is.na(prob))

# --- Jitter bounds and true values per lottery ---
jitter_bounds <- tibble(
  lottery = factor(1:6),
  prob_min = prob - bounded_jitter$prob,
  prob_max = prob + bounded_jitter$prob,
  amt_min  = amount - bounded_jitter$amt,
  amt_max  = amount + bounded_jitter$amt,
  true_prob = prob,
  true_amount = amount
)

# --- Plot: Probability ---
ggplot(jitter_check, aes(x = lottery, y = prob)) +
  geom_jitter(width = 0.1, alpha = 0.4, size = 1, color = "black") +
  geom_point(data = jitter_bounds, aes(y = true_prob), color = "red", size = 3) +
  geom_linerange(data = jitter_bounds, aes(ymin = prob_min, ymax = prob_max), color = "red", size = 0.8) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Probability of Win per Lottery",
    subtitle = "Black = actual shown values; Red line = intended jitter range",
    x = "Lottery ID", y = "Probability (%)"
  )

# --- Plot: Amount ---
ggplot(jitter_check, aes(x = lottery, y = amount)) +
  geom_jitter(width = 0.1, alpha = 0.4, size = 1, color = "black") +
  geom_point(data = jitter_bounds, aes(y = true_amount), color = "red", size = 3) +
  geom_linerange(data = jitter_bounds, aes(ymin = amt_min, ymax = amt_max), color = "red", size = 0.8) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Amount to Win per Lottery",
    subtitle = "Black = actual shown values; Red line = intended jitter range",
    x = "Lottery ID", y = "Amount ($)"
  )

# --- Flag violations ---
jitter_check_flagged <- jitter_check %>%
  left_join(jitter_bounds, by = "lottery") %>%
  mutate(
    prob_out_of_range = prob < prob_min | prob > prob_max,
    amount_out_of_range = amount < amt_min | amount > amt_max
  ) %>%
  select(
    ResponseId, lottery,
    prob, prob_min, prob_max, prob_out_of_range,
    amount, amt_min, amt_max, amount_out_of_range,
    true_prob, true_amount
  )

jitter_check_flagged%>%
  filter(prob_out_of_range=="TRUE"|amount_out_of_range=="TRUE")

# --- Compute EV and summary ---
jitter_check <- jitter_check %>%
  mutate(ev = (prob / 100) * amount)

ev_summary <- jitter_check %>%
  group_by(lottery) %>%
  summarise(ev_mean = mean(ev, na.rm = TRUE))

# --- Plot: Expected Value with reference line ---
ggplot(jitter_check, aes(x = lottery, y = ev)) +
  geom_jitter(width = 0.1, alpha = 0.4, size = 1, color = "black") +
  geom_point(data = ev_summary, aes(x = lottery, y = ev_mean), color = "red", size = 3) +
  geom_hline(yintercept = 2.835, linetype = "dashed", color = "blue", linewidth = 1) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Expected Value per Lottery",
    subtitle = "Black = individual EVs; Red = mean EV; Blue dashed = intended EV = 2.835",
    x = "Lottery ID", y = "Expected Value ($)"
  )

• 2ND Preference Ranking Task

# --- Step 0: True values ---

prob <- c(3, 6, 15, 31, 63, 84)
amount <- c(93.4, 47.7, 18.7, 9.1, 4.4, 3.4)

# BOUNDED jitter ranges used for each lottery (for visual comparison)
bounded_jitter <- list(
  prob = c(2, 1, 8, 8, 11, 10),
  amt  = c(22, 23.7, 5.3, 4.3, 0.4, 0.4)
)

# --- Step 1: Reverse mapping: Set1_L1 = lottery 6, ..., Set1_L6 = lottery 1 ---
lottery_mapping <- tibble(
  input_lottery = 1:6,
  lottery = factor(7 - input_lottery)  # Reverse order
)

# --- Step 2: Reshape wide-format data into long-format jitter_check ---
jitter_check <- bind_rows(lapply(1:6, function(i) {
  tibble(
    ResponseId = dat$ResponseId,
    input_lottery = i,
    prob = dat[[paste0("Set2_L", i, "_Prob")]],
    amount = dat[[paste0("Set2_L", i, "_Amt")]]
  )
})) %>%
  left_join(lottery_mapping, by = "input_lottery") %>%
  select(ResponseId, lottery, prob, amount) %>%
  filter(!is.na(prob))

# --- Step 3: Jitter bounds and true value per lottery ---
jitter_bounds <- tibble(
  lottery = factor(1:6),
  prob = c(3, 6, 15, 31, 63, 84),
  prob_min = prob - bounded_jitter$prob,
  prob_max = prob + bounded_jitter$prob,
  amount = c(93.4, 47.7, 18.7, 9.1, 4.4, 3.4),
  amt_min = amount - bounded_jitter$amt,
  amt_max = amount + bounded_jitter$amt
)

# -------------------------------
# Plot 1: Probability (dots + jitter range + true center)
# -------------------------------
ggplot(jitter_check, aes(x = lottery, y = prob)) +
  geom_jitter(width = 0.1, alpha = 0.4, size = 1, color = "black") +  # actual shown values
  geom_point(data = jitter_bounds, aes(y = prob), color = "red", size = 3) +  # true center
  geom_linerange(data = jitter_bounds, aes(ymin = prob_min, ymax = prob_max), color = "red", size = 0.8) +  # expected jitter range
  theme_minimal(base_size = 13) +
  labs(
    title = "Probability of Win per Lottery",
    subtitle = "Black = actual shown values;  Red line = intended jitter range",
    x = "Lottery ID", y = "Probability (%)"
  )

# -------------------------------
# Plot 2: Amount (dots + jitter range + true center)
# -------------------------------
ggplot(jitter_check, aes(x = lottery, y = amount)) +
  geom_jitter(width = 0.1, alpha = 0.4, size = 1, color = "black") +
  geom_point(data = jitter_bounds, aes(y = amount), color = "red", size = 3) +
  geom_linerange(data = jitter_bounds, aes(ymin = amt_min, ymax = amt_max), color = "red", size = 0.8) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Amount to Win per Lottery",
    subtitle = "Black = actual shown values; RRed line = intended jitter range",
    x = "Lottery ID", y = "Amount ($)"
  )

jitter_bounds_renamed <- jitter_bounds %>%
  rename(
    true_prob = prob,
    true_amount = amount
  )

jitter_check_flagged<-jitter_check %>%
  left_join(jitter_bounds_renamed, by = "lottery") %>%
  mutate(
    prob_out_of_range = prob < prob_min | prob > prob_max,
    amount_out_of_range = amount < amt_min | amount > amt_max
  ) %>%
  select(
    ResponseId, lottery,
    prob, prob_min, prob_max, prob_out_of_range,
    amount, amt_min, amt_max, amount_out_of_range,
    true_prob, true_amount
  )
jitter_check_flagged%>%
  filter(prob_out_of_range=="TRUE"|amount_out_of_range=="TRUE")

jitter_check <- jitter_check %>%
  mutate(ev = (prob / 100) * amount)
ev_summary <- jitter_check %>%
  group_by(lottery) %>%
  summarise(ev_mean = mean(ev, na.rm = TRUE))
ggplot(jitter_check, aes(x = lottery, y = ev)) +
  geom_jitter(width = 0.1, alpha = 0.4, size = 1, color = "black") +
  geom_point(data = ev_summary, aes(x = lottery, y = ev_mean), color = "red", size = 3) +
  geom_hline(yintercept = 2.835, linetype = "dashed", color = "blue", linewidth = 1) +
  theme_minimal(base_size = 13) +
  labs(
    title = "Expected Value per Lottery",
    subtitle = "Black = individual EVs; Red = mean EV; Blue dashed = intended EV = 2.835",
    x = "Lottery ID", y = "Expected Value ($)"
  )

Warm Up Task

• The majority of participants passed the warm-up test on their first attempt.
• Reminder: Each participant is given up to 3 attempts to pass.

ggplot(dat, aes(x = factor(WarmUpAttempt_N+1))) +
  geom_bar(fill = "steelblue", color = "black", alpha = 0.8) +
  scale_x_discrete(limits = as.character(1:4)) +
  labs(
    title = "Distribution of Warm-Up Attempts",
    x = "Number of Warm-Up Attempts",
    y = "Count"
  ) +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5),
    axis.text = element_text(size = 12),
    axis.title = element_text(size = 13)
  )

ATTN and Dosage Question

• ATTN: I work 28 hours a day (TRUE/FALSE/UNSURE)
• DOSE: After participants completed ranking by probability, amount, and how much they like each lottery, we asked them to identify the tasks
  • A common error was selecting “expected winning amount” instead of the correct “amount to win.”
    • Perhaps we need to revsise the comprehension check question.

correct_answer <- "1,2,3"

dat <- dat %>%
  mutate(dose.coded = ifelse(Dose == correct_answer, "Correct", "Incorrect"))
# Recode attn1 (9 is correct)
dat$attn1.coded <- ifelse(dat$attn1 == 9, "Correct", "Incorrect")

dat$dose.coded <- as.factor(dat$dose.coded)
dat$attn1.coded <- as.factor(dat$attn1.coded)

dat_long <- dat %>%
  pivot_longer(cols = c(dose.coded, attn1.coded), names_to = "Question", values_to = "Response")

ggplot(dat_long, aes(x = Response, fill = Question)) +
  geom_bar(position = "dodge") +  # Bar plot using counts
  geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.5, size = 5) +  # Add count labels
  facet_wrap(~Question, scales = "free_x") +  # Separate plots for dose.coded and attn1.coded
  labs(x = "Response", y = "Count", title = "Count of Correct & Incorrect Responses") +
  theme_bw() +
  ylim(0, 100)  # Set y-axis limit

dose.wrong.subj<-dat%>%filter(dose.coded=="Incorrect")%>%pull(ResponseId)

# Display the actual things people select

Incentive Comprehension

• After the recall question, participants were asked whether ranking the top-ranked or bottom-ranked lotteries was more important for their bonus—or if both were equally important. * 66.7% of the participants answered that both are equally important.

dat$incentive_ch [dat$incentive_ch== 1] = 'Top-ranked lotteries are more important'
dat$incentive_ch [dat$incentive_ch== 2] = 'Both are equally important.'
dat$incentive_ch [dat$incentive_ch == 3] = 'Lower-ranked lotteries are more important'

dat$incentive_ch <- factor(dat$incentive_ch, levels = names(sort(table(dat$incentive_ch), decreasing = TRUE)))

ggplot(dat%>%filter(!is.na(incentive_ch)), aes(x = incentive_ch)) +
  geom_bar() +  # Use counts instead of proportions
  geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.5, size = 5) +  # Add count labels
  labs(x = "Incentive Scheme Comprehension", y = "Count", title = "Incentive Scheme Comprehension") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none") + # Tilt x-axis labels
ylim(c(0,30))

Device Used During the Ranking Quiz

• Possible Answers:
  • Mouse (wired or wireless)
  • Trackpad (touchpad)
  • Touchscreen (finger or stylus)
  • Others

dat$device [dat$device== 1] = 'Mouse (Wired or Wireless)'
dat$device [dat$device== 2] = 'Trackpad (touchpad)'
dat$device [dat$device == 4] = 'Touchscreen (finger or stylus)'
dat$device [dat$device == 3] = 'Other'

dat$device <- factor(dat$device, levels = names(sort(table(dat$device), decreasing = TRUE)))

ggplot(dat%>%filter(!is.na(device)), aes(x = device)) +
  geom_bar() +  # Use counts instead of proportions
  geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.5, size = 5) +  # Add count labels
  labs(x = "Device Type", y = "Count", title = "Distribution of Ranking Approaches") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none") + # Tilt x-axis labels
ylim(c(0,30))

Technical Issue

• “Did you run into any technical issue during the survey?”
• 0 out of 30 said yes.

# table(dat$technical)
# dat$technical_open

Belief in Bonus

• After the second ranking by “how much you like each lottery” question, we asked participants Do you believe that you have the chance to win a bonus in the task you just completed?”
• 93.3% said YES.

# table(dat$bonus_belief)

dat$bonus_belief [dat$bonus_belief== 1] = 'Yes'
dat$bonus_belief [dat$bonus_belief== 2] = 'No'

dat$bonus_belief <- factor(dat$bonus_belief, levels = names(sort(table(dat$bonus_belief), decreasing = TRUE)))

ggplot(dat%>%filter(!is.na(bonus_belief)), aes(x = bonus_belief)) +
  geom_bar() +  # Use counts instead of proportions
  geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.5, size = 5) +  # Add count labels
  labs(x = "Belief in Getting Bonus", y = "Count", title = "Do you believe that you have the chance to win a bonus in the task you just completed?") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none") + # Tilt x-axis labels
ylim(c(0,30))

Guess Purpose

• In a few sentences, please explain what you think the purpose of this study is. If you are not sure, please give your best guess.
  • “To see how people play games…”
  • “to know how poeple take risk..”

# dat$purpose

Debrief Question

• We are currently testing this survey, and you are one of a small number of participants to complete it. Is there anything else about the survey that you would like us to know? For example, was there anything that confused you? Was there ever a time when you were not sure how to answer?
  • Participants did not seem to report any confusion

# dat$pilot_feedback

Accuracy in Ranking Task

Amount Task: 90% (26/29) Tau = 1
Probability Task: 93% (25/27) Tau = 1

• We removed 1 observation from the amount task and 3 observations from the probability task due to data recording errors. These appear to be duplicates. Xuwen and Arian should revisit this later to determine whether simply removing the duplicates is a sufficient fix.

# Results remain the same, p value becomes even more favrable.; I need to check if the remaining data contains any wrongly formatted drag_Process - two ;; Those could mess up the data.

### The following focuses on quizes A and B, the two quizes with focal items

RankProcess_Amount<-dat%>%
  select(ResponseId,RankProcess_Amount)%>%
  separate_rows(RankProcess_Amount, sep = "}") %>% #separate data into long format... 
  mutate(RankProcess_Amount = gsub("[{}]", "", RankProcess_Amount))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_Amount!="")%>% # an empty obs is generated for each subject, removed
  separate(RankProcess_Amount, into = c("timing", "order"), sep = ";")%>%
# RankProcess%>%
#   filter(is.na(order)) #none
  group_by(ResponseId)%>%
  mutate(step=row_number()-1)%>% # first row records the initial position of items.
  select(step,everything())%>%
  ungroup()

### Check order column format ###

#### RankProcess Check #####
RankProcess_Amount$order <- trimws(RankProcess_Amount$order)
is_valid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Amount$order)
bug_respondent_Amount <- RankProcess_Amount %>%
  filter(!is_valid) %>%
  pull(ResponseId)# exclude 0 respondent with incorrect format data.

# RankProcess_A%>%
#   filter(ResponseId=="R_61SsQv6Vz0cWHQt") # this respondent has a duplicated row; needs to be removed; we tentatively remove this respondent entirely. But perhaps we only need to remove the duplicate row?

RankProcess_Amount<-RankProcess_Amount%>%
  filter(!ResponseId %in% c(bug_respondent_Amount)) # remove data from respondents with NA item_moved columns entirely. - Other Data Recording Issue
#### RankProcess Check DONE #####

#### Done Addressing Incorrect Data Recording ####


RankProcess_all_Amount<-dat%>%
  select(ResponseId,RankProcess_all_Amount)%>%
  separate_rows(RankProcess_all_Amount, sep = "}") %>%
  mutate(RankProcess_all_Amount = gsub("[{}]", "", RankProcess_all_Amount))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_all_Amount!="")%>%
  separate(RankProcess_all_Amount, into = c("timing", "order_all"), sep = ";")


RankProcess_Amount<-RankProcess_Amount%>%
  left_join(RankProcess_all_Amount,by=c("ResponseId","timing"))%>%
  mutate(item_moved= sub(",.*", "", order_all))%>% # # Retain only the value before the first comma. This is because the we are asking JavaScript to capture the order at the moment of mousedown, with RankProcess_all, prior to Qualtrics fully integrating the order. Additionally, the moved item consistently appears first in the recorded sequence (tested with the "inspect" function), a feature we use to identify the item taken. This behavior should be periodically checked to confirm if Qualtrics updates any underlying processes. # 10/25/2024 Xuwen.
  ungroup()%>%
  mutate(item_moved=as.numeric(item_moved),
         item.f=as.factor(case_when(
    item_moved==49 ~ "Pr6_Amt1",
    item_moved==50 ~ "Pr5_Amt2",
    item_moved==64 ~ "Pr4_Amt3",
    item_moved==65 ~ "Pr3_Amt4",
    item_moved==67 ~ "Pr2_Amt5",
    item_moved==68 ~ "Pr1_Amt6" # 2024/11/26; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature
  )))



#### Address Incorrect Data Recording ####

na_subj_Amount<-RankProcess_Amount%>%
  filter(is.na(item_moved))%>%
  pull(ResponseId)  # some respondents have missing item moved - menaing that there are items in  rank process that cannot be matched from Rank process all. This only occurs in rare cases and remove data from these responents.
# one participant identified

#### RankProcess ALL Check  #####
RankProcess_Amount$order_all <- trimws(RankProcess_Amount$order_all)
Invalid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Amount$order_all)
bug_respondent_Amount <- RankProcess_Amount %>%
  filter(Invalid & timing!=0) %>%
  pull(ResponseId)
#### RankProcess ALL Check DONE #####

RankProcess_Amount<-RankProcess_Amount%>%
  filter(!ResponseId %in% c(na_subj_Amount,bug_respondent_Amount))

# RankProcess_A%>%
#   filter(is.na(item_moved)) # order_all variable was somehow not recorded in these rows. 

drag_and_drop_count_Amount<-RankProcess_Amount%>%
  filter(step!=0)%>% # step=0 shows initial rank. Remove this.
  group_by(ResponseId)%>%
  summarize(item_49_moved.N=sum(item_moved==49),
            item_50_moved.N=sum(item_moved==50),
            item_64_moved.N=sum(item_moved==64),
            item_65_moved.N=sum(item_moved==65),
            item_67_moved.N=sum(item_moved==67),
            item_68_moved.N=sum(item_moved==68))%>%
  ungroup() 


# length(unique(na_subj_Amount)) # 6
# length(unique(dat_Amount$ResponseId)) # 149
# length(unique(RankProcess_Amount$ResponseId)) # 149; 
# length(unique(drag_and_drop_count_Amount$ResponseId)) # 143;  and 7 instances, 6 with missing data
# RankProcess_Amount%>%
#   filter(is.na(item_moved)) #7
# RankProcess_Amount%>%
#   filter(step!=0) #622


# Results remain the same, p value becomes even more favrable.; I need to check if the remaining data contains any wrongly formatted drag_Process - two ;; Those could mess up the data.

### The following focuses on quizes A and B, the two quizes with focal items

RankProcess_Prob<-dat%>%
  select(ResponseId,RankProcess_Prob)%>%
  separate_rows(RankProcess_Prob, sep = "}") %>% #separate data into long format... 
  mutate(RankProcess_Prob = gsub("[{}]", "", RankProcess_Prob))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_Prob!="")%>% # an empty obs is generated for each subject, removed
  separate(RankProcess_Prob, into = c("timing", "order"), sep = ";")%>%
# RankProcess%>%
#   filter(is.na(order)) #none
  group_by(ResponseId)%>%
  mutate(step=row_number()-1)%>% # first row records the initial position of items.
  select(step,everything())%>%
  ungroup()

### Check order column format ###

#### RankProcess Check #####
RankProcess_Prob$order <- trimws(RankProcess_Prob$order)
is_valid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Prob$order)
bug_respondent_Prob <- RankProcess_Prob %>%
  filter(!is_valid) %>%
  pull(ResponseId)# exclude 0 respondent with incorrect format data.

# RankProcess_A%>%
#   filter(ResponseId=="R_61SsQv6Vz0cWHQt") # this respondent has a duplicated row; needs to be removed; we tentatively remove this respondent entirely. But perhaps we only need to remove the duplicate row?

RankProcess_Prob<-RankProcess_Prob%>%
  filter(!ResponseId %in% c(bug_respondent_Prob)) # remove data from respondents with NA item_moved columns entirely. - Other Data Recording Issue
#### RankProcess Check DONE #####

#### Done Addressing Incorrect Data Recording ####


RankProcess_all_Prob<-dat%>%
  select(ResponseId,RankProcess_all_Prob)%>%
  separate_rows(RankProcess_all_Prob, sep = "}") %>%
  mutate(RankProcess_all_Prob = gsub("[{}]", "", RankProcess_all_Prob))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_all_Prob!="")%>%
  separate(RankProcess_all_Prob, into = c("timing", "order_all"), sep = ";")


RankProcess_Prob<-RankProcess_Prob%>%
  left_join(RankProcess_all_Prob,by=c("ResponseId","timing"))%>%
  mutate(item_moved= sub(",.*", "", order_all))%>% # # Retain only the value before the first comma. This is because the we are asking JavaScript to capture the order at the moment of mousedown, with RankProcess_all, prior to Qualtrics fully integrating the order. Additionally, the moved item consistently appears first in the recorded sequence (tested with the "inspect" function), a feature we use to identify the item taken. This behavior should be periodically checked to confirm if Qualtrics updates any underlying processes. # 10/25/2024 Xuwen.
  ungroup()%>%
  mutate(item_moved=as.numeric(item_moved),
         item.f=as.factor(case_when(
    item_moved==49 ~ "Pr6_Amt1",
    item_moved==50 ~ "Pr5_Amt2",
    item_moved==64 ~ "Pr4_Amt3",
    item_moved==65 ~ "Pr3_Amt4",
    item_moved==67 ~ "Pr2_Amt5",
    item_moved==68 ~ "Pr1_Amt6"  # 2024/11/26; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature
  )))

#### Address Incorrect Data Recording ####

na_subj_Prob<-RankProcess_Prob%>%
  filter(is.na(item_moved))%>%
  pull(ResponseId)  # some respondents have missing item moved - menaing that there are items in  rank process that cannot be matched from Rank process all. This only occurs in rare cases and remove data from these responents.
# one participant identified

#### RankProcess ALL Check  #####
RankProcess_Prob$order_all <- trimws(RankProcess_Prob$order_all)
Invalid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Prob$order_all)
bug_respondent_Prob <- RankProcess_Prob %>%
  filter(Invalid & timing!=0) %>%
  pull(ResponseId)
#### RankProcess ALL Check DONE #####

RankProcess_Prob<-RankProcess_Prob%>%
  filter(!ResponseId %in% c(na_subj_Prob,bug_respondent_Prob))

# RankProcess_A%>%
#   filter(is.na(item_moved)) # order_all variable was somehow not recorded in these rows. 


drag_and_drop_count_Prob<-RankProcess_Prob%>%
  filter(step!=0)%>% # step=0 shows initial rank. Remove this.
  group_by(ResponseId)%>%
  summarize(item_49_moved.N=sum(item_moved==49),
            item_50_moved.N=sum(item_moved==50),
            item_64_moved.N=sum(item_moved==64),
            item_65_moved.N=sum(item_moved==65),
            item_67_moved.N=sum(item_moved==67),
            item_68_moved.N=sum(item_moved==68))%>%
  ungroup() 

# length(unique(na_subj_Prob)) # 6
# length(unique(dat_Prob$ResponseId)) # 149
# length(unique(RankProcess_Prob$ResponseId)) # 149; 
# length(unique(drag_and_drop_count_Prob$ResponseId)) # 143;  and 7 instances, 6 with missing data
# RankProcess_Prob%>%
#   filter(is.na(item_moved)) #7
# RankProcess_Prob%>%
#   filter(step!=0) #622


Summary_data_Prob<- expand_grid(
 ResponseId = unique(RankProcess_Prob$ResponseId),
 item.f = unique(RankProcess_Prob$item.f))
Summary_data_Prob<-Summary_data_Prob%>%
  mutate(rank.Amount=
           case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6),
         rank.prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1
         ))%>%
  left_join(dat%>%select(ResponseId,rank_prob_49:rank_prob_68),by="ResponseId")%>%
  mutate(Subj.rank=case_when(
    item.f=="Pr6_Amt1" ~ rank_prob_49,
    item.f=="Pr5_Amt2" ~ rank_prob_50,
    item.f== "Pr4_Amt3" ~ rank_prob_64,
    item.f== "Pr3_Amt4" ~ rank_prob_65,
    item.f == "Pr2_Amt5" ~ rank_prob_67,
    item.f == "Pr1_Amt6" ~ rank_prob_68))%>%
  select(-c(rank_prob_49:rank_prob_68))%>%
  group_by(ResponseId) %>%
  mutate(Tau =- cor(Subj.rank, rank.prob, method = "kendall")) %>%
  ungroup()

Summary_data_Amount<- expand_grid(
 ResponseId = unique(RankProcess_Amount$ResponseId),
 item.f = unique(RankProcess_Amount$item.f))

Summary_data_Amount<-Summary_data_Amount%>%
  mutate(rank.amount=
           case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6),
         rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1
         ))%>%
  left_join(dat%>%select(ResponseId,rank_amount_49:rank_amount_68),by="ResponseId")%>%
  mutate(Subj.rank=case_when(
    item.f=="Pr6_Amt1" ~ rank_amount_49,
    item.f=="Pr5_Amt2" ~ rank_amount_50,
    item.f== "Pr4_Amt3" ~ rank_amount_64,
    item.f== "Pr3_Amt4" ~ rank_amount_65,
    item.f == "Pr2_Amt5" ~ rank_amount_67,
    item.f == "Pr1_Amt6" ~ rank_amount_68))%>%
  select(-c(rank_amount_49:rank_amount_68))%>%
  group_by(ResponseId) %>%
  mutate(Tau = -cor(Subj.rank, rank.amount, method = "kendall")) %>%
  ungroup()


Summary_data <- data.frame(
  Tau = c(Summary_data_Prob$Tau, Summary_data_Amount$Tau),
  Group = rep(c("Prob", "Amount"), c(length(Summary_data_Prob$Tau), length(Summary_data_Amount$Tau))),
  ResponseId = c(Summary_data_Prob$ResponseId, Summary_data_Amount$ResponseId)  # Add ResponseId
) %>%
  filter(!duplicated(paste(ResponseId,Group)))

mean_values <- Summary_data %>%
  group_by(Group) %>%
  summarize(mean_Tau = mean(Tau, na.rm = TRUE))


ggplot(Summary_data, aes(x = Group, y = Tau, fill = Group)) +
  geom_violin(trim = FALSE, alpha = 0.5) +  # Violin plot with transparency
  geom_jitter(width = 0.1, alpha = 0.5, size = 1.5) +  # Add jitter points
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4, fill = "white") +  # Show mean as point
  geom_text(data = mean_values, aes(x = Group, y = mean_Tau, label = sprintf("%.2f", mean_Tau)), 
            hjust=2, fontface = "bold", size = 5, Amount = "black") +  # Add mean text labels
  scale_fill_manual(values = c("steelblue", "darkorange")) +  # Custom Amounts
  labs(
       x = "Condition",
       y = "Tau") +
  theme_minimal(base_size = 14) +
  theme(legend.position = "none",  # Remove redundant legend
        axis.title = element_text(face = "bold"),
        axis.text = element_text(face = "bold"))

Prob_reverse_subj<-Summary_data_Prob%>%
  filter(Tau<=0)%>%
  pull(ResponseId)
Amount_reverse_subj<-Summary_data_Amount%>%
  filter(Tau<=0)%>%
  pull(ResponseId)

Prob_NoneNeg_subj<-Summary_data_Prob%>%
  filter(Tau>=0)%>%
  pull(ResponseId)
Amount_NoneNeg_subj<-Summary_data_Amount%>%
  filter(Tau>=0)%>%
  pull(ResponseId)

Prob_correct_subj<-Summary_data_Prob%>%
  filter(Tau==1)%>%
  pull(ResponseId)
Amount_correct_subj<-Summary_data_Amount%>%
  filter(Tau==1)%>%
  pull(ResponseId)

# 26/29
# 22/29

# dose.wrong.subj # only one overlap with Prob reverse

# length(unique(Summary_data_Prob$ResponseId)) 27
# length(unique(Prob_reverse_subj))
# length(unique(Prob_correct_subj)) #25

# length(unique(Summary_data_Amount$ResponseId))# 29
# length(unique(Amount_reverse_subj))
# length(unique(Amount_correct_subj)) #26

# unique(Prob_incorrect_subj)

# Examine<-dat%>%
#   filter(ResponseId=="R_57czmZivmqFW7cd")
# Examine$RankProcess_Prob
# Examine$RankProcess_all_Prob

# tau <- Summary_data_Amount %>% filter(!duplicated(ResponseId)) %>% pull(Tau)
# t.test(tau)$conf.int
# mean(tau)

2. Prob/Amt: 3F Analysis (More Often, First, and Further)

• Note on rank coding: throughout the note book, 6 refers to the highest rank (at the top) and 1 refers to the lowest (at the bottom)

• I think data generally supports the rank sequentially model (3F hypothesis), with some participants appearing to exhibit the rank extreme pattern.

### Data Wrangling for Drag distance - in order to identify data recording where a bug had appeared to occur ###

Distance_Amount<-RankProcess_Amount %>%
  group_by(ResponseId)%>%
  mutate(
    # Split the string into parts based on commas
    parts = str_split(order, ",")
  ) %>%
  mutate(
    Rank1 = sapply(parts, function(x) x[1]),  # Extract before 1st comma
    Rank2 = sapply(parts, function(x) x[2]),  # Extract before 2nd comma
    Rank3 = sapply(parts, function(x) x[3]),  # Extract before 3rd comma
    Rank4 = sapply(parts, function(x) x[4]),  # Extract before 4th comma
    Rank5 = sapply(parts, function(x) x[5]),  # Extract before 5th comma
    Rank6 = sapply(parts, function(x) ifelse(length(x) > 5, x[6], NA))  # Extract after 5th comma
  ) %>%
  select(-parts)

items_Amount <- c("49", "50", "64", "65", "67", "68")
for (item in items_Amount) {
  Distance_Amount[[paste0("current_", item)]] <- NA_integer_
}


Distance_Amount <- Distance_Amount %>%
  rowwise() %>%
  mutate(
    across(
      starts_with("current_"),
      ~ {
        item_number <- str_remove(cur_column(), "current_")  # Extract the item number
        case_when(
          Rank1 == item_number ~ 1,
          Rank2 == item_number ~ 2,
          Rank3 == item_number ~ 3,
          Rank4 == item_number ~ 4,
          Rank5 == item_number ~ 5,
          Rank6 == item_number ~ 6,
          TRUE ~ 1 # Distance_A %>% mutate(NA_count = rowSums(is.na(select(., starts_with("current_"))))); this code somehow results in the first item always gets an NA, so manually fix this error
        )
      }
    )
  ) %>%
  ungroup()

### No rows should have any repeated 1 in the "current_" columns ###
# Distance_A %>%
#   rowwise() %>%
#   mutate(
#     more_than_one_1 = sum(select(., starts_with("current_")) == 1, na.rm = TRUE) > 1
#   ) %>%
#   ungroup()%>%
#   filter(more_than_one_1) # NONE; good.


for (item in items_Amount) {
  Distance_Amount[[paste0("last_", item)]] <- lag(Distance_Amount[[paste0("current_", item)]])
}


Distance_Amount<-Distance_Amount%>%
  group_by(ResponseId)%>%
  rowwise() %>%
  mutate(
    current_item_moved = get(paste0("current_", item_moved)),  # Get the rank of the moved item from current columns
    last_item_moved = get(paste0("last_", item_moved)),        # Get the rank of the moved item from last columns
    # Determine the movement direction; we should not see any "no_change"
    move_direction = case_when(
      is.na(last_item_moved) ~ "no_change",  
      current_item_moved < last_item_moved ~ "up",
      current_item_moved > last_item_moved ~ "down",
      TRUE ~ "no_change"
    )
  ) %>%
  ungroup()


Distance_Amount <- Distance_Amount %>%
  group_by(ResponseId)%>%
  filter(step!=0) # need to retain step 0 for steps that come before

bug_respondent_Amount<-Distance_Amount%>%
  filter(move_direction=="no_change")%>%pull(ResponseId) # 0 respondent

# table(Distance_Amount$move_direction) #73.3

### Data Wrangling for Drag distance - in order to identify data recording where a bug had appeared to occur ###

Distance_Prob<-RankProcess_Prob %>%
  group_by(ResponseId)%>%
  mutate(
    # Split the string into parts based on commas
    parts = str_split(order, ",")
  ) %>%
  mutate(
    Rank1 = sapply(parts, function(x) x[1]),  # Extract before 1st comma
    Rank2 = sapply(parts, function(x) x[2]),  # Extract before 2nd comma
    Rank3 = sapply(parts, function(x) x[3]),  # Extract before 3rd comma
    Rank4 = sapply(parts, function(x) x[4]),  # Extract before 4th comma
    Rank5 = sapply(parts, function(x) x[5]),  # Extract before 5th comma
    Rank6 = sapply(parts, function(x) ifelse(length(x) > 5, x[6], NA))  # Extract after 5th comma
  ) %>%
  select(-parts)

items_Prob <- c("49", "50", "64", "65", "67", "68")
for (item in items_Prob) {
  Distance_Prob[[paste0("current_", item)]] <- NA_integer_
}


Distance_Prob <- Distance_Prob %>%
  rowwise() %>%
  mutate(
    across(
      starts_with("current_"),
      ~ {
        item_number <- str_remove(cur_column(), "current_")  # Extract the item number
        case_when(
          Rank1 == item_number ~ 1,
          Rank2 == item_number ~ 2,
          Rank3 == item_number ~ 3,
          Rank4 == item_number ~ 4,
          Rank5 == item_number ~ 5,
          Rank6 == item_number ~ 6,
          TRUE ~ 1 # Distance_A %>% mutate(NA_count = rowSums(is.na(select(., starts_with("current_"))))); this code somehow results in the first item always gets an NA, so manually fix this error
        )
      }
    )
  ) %>%
  ungroup()

### No rows should have any repeated 1 in the "current_" columns ###
# Distance_A %>%
#   rowwise() %>%
#   mutate(
#     more_than_one_1 = sum(select(., starts_with("current_")) == 1, na.rm = TRUE) > 1
#   ) %>%
#   ungroup()%>%
#   filter(more_than_one_1) # NONE; good.


for (item in items_Prob) {
  Distance_Prob[[paste0("last_", item)]] <- lag(Distance_Prob[[paste0("current_", item)]])
}


Distance_Prob<-Distance_Prob%>%
  group_by(ResponseId)%>%
  rowwise() %>%
  mutate(
    current_item_moved = get(paste0("current_", item_moved)),  # Get the rank of the moved item from current columns
    last_item_moved = get(paste0("last_", item_moved)),        # Get the rank of the moved item from last columns
    # Determine the movement direction; we should not see any "no_change"
    move_direction = case_when(
      is.na(last_item_moved) ~ "no_change",  
      current_item_moved < last_item_moved ~ "up",
      current_item_moved > last_item_moved ~ "down",
      TRUE ~ "no_change"
    )
  ) %>%
  ungroup()


Distance_Prob <- Distance_Prob %>%
  group_by(ResponseId)%>%
  filter(step!=0) # need to retain step 0 for steps that come before

bug_respondent_Prob<-Distance_Prob%>%
  filter(move_direction=="no_change")%>%pull(ResponseId) # 0 respondent


# table(Distance_Prob$move_direction) #75.9

drag_and_drop_count_Amount_long <- drag_and_drop_count_Amount %>%
  pivot_longer(
    cols = starts_with("item_"),   # All columns starting with "item_"
    names_to = c("item_number", ".value"),  # Splits into item_number and value columns
    names_sep = "_moved."           # Splitting based on the "_moved." part
  )%>%
  mutate(
    condition = "Amount",
    item_number = as.numeric(gsub("item_", "", item_number)), 
    item.f = as.factor(case_when(
    item_number==49 ~ "Pr6_Amt1",
    item_number==50 ~ "Pr5_Amt2",
    item_number==64 ~ "Pr4_Amt3",
    item_number==65 ~ "Pr3_Amt4",
    item_number==67 ~ "Pr2_Amt5",
    item_number==68 ~ "Pr1_Amt6"
    ))
  )
drag_and_drop_count_Prob_long<-drag_and_drop_count_Prob%>%
  pivot_longer(
    cols = starts_with("item_"),   # All columns starting with "item_"
    names_to = c("item_number", ".value"),  # Splits into item_number and value columns
    names_sep = "_moved."           # Splitting based on the "_moved." part
  )%>%
  mutate(condition="Prob",
         item_number = as.numeric(gsub("item_", "", item_number)),
    item.f=as.factor(case_when(
    item_number==49 ~ "Pr6_Amt1",
    item_number==50 ~ "Pr5_Amt2",
    item_number==64 ~ "Pr4_Amt3",
    item_number==65 ~ "Pr3_Amt4",
    item_number==67 ~ "Pr2_Amt5",
    item_number==68 ~ "Pr1_Amt6"
    ))
  )

2.1 DV1: Drag Count

• Drag Count Indicator is used here

2.1.0 Distribution of Drag Count by item

drag_drop_counts_Amount <- drag_and_drop_count_Amount_long %>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  count(item.f,N) %>%
  group_by(item.f)%>%
  mutate(percentage = n / sum(n) * 100,
         condition="Amount")%>%
  ungroup()


drag_drop_counts_Prob <- drag_and_drop_count_Prob_long %>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  count(item.f,N) %>%
  group_by(item.f)%>%
  mutate(percentage = n / sum(n) * 100,
         condition="Prob")%>%
  ungroup()

# drag_and_drop_count_Amount_long%>%
#   group_by(item.f)%>%
#   summarise(subj_count=n()) 
# drag_and_drop_count_Prob_long%>%
#   group_by(item.f)%>%
#   summarise(subj_count=n()) 

drag_drop_counts_combined<-rbind(drag_drop_counts_Amount,drag_drop_counts_Prob)

ggplot(drag_drop_counts_combined, aes(x = factor(N), y = n)) +
  geom_bar(
    stat = "identity",
    # aes(fill = ifelse(item.f %in% c("Carpool5", "WFH3"), "highlight", "default")),
    color = "black"
  ) +
  geom_text(
    aes(
      label = paste0(n, " (", round(percentage, 1), "%)")
      # color = ifelse(item.f %in% c("Carpool5", "WFH3"), "highlight", "default")
    ),
    vjust = -0.5,
    size = 5,
    fontface="bold"
  ) +
  # scale_fill_manual(
  #   values = c("highlight" = "darkorange", "default" = "grey"),
  #   guide = "none"
  # ) +
  # scale_color_manual(
  #   values = c("highlight" = "darkorange", "default" = "grey"),
  #   guide = "none"
  # ) +
  labs(
    title = "Drag Count by item and Quiz Condition",
    x = "Drag Count",
    y = "Frequency"
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(size = 12, face = "bold"),  # Increased size and bold text
    plot.title = element_text(hjust = 0.5),
    axis.title = element_text(size = 12),  # Adjust axis titles size if needed
    axis.text = element_text(size = 10)    # Adjust axis labels size if needed
  ) +
  facet_wrap(~ item.f * condition,ncol=2) +
  ylim(0, 50)

2.1.1 Model-free visualization

• The following plot illustrates the mean and se of drag counts for each item, grouped by condition.

Coding Drag Count as a binary indicator variable

summary_data_Amount_ind<- drag_and_drop_count_Amount_long %>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  mutate(N=case_when(
    N==0~0,
    TRUE~1
  ))%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(drag_drop_mean = mean(N, na.rm = TRUE),
            drag_drop_sd = sd(N, na.rm = TRUE),
            n = n(),
            se = drag_drop_sd / sqrt(n),
            .groups = "drop")
summary_data_Prob_ind<- drag_and_drop_count_Prob_long %>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  mutate(N=case_when(
    N==0~0,
    TRUE~1
  ))%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(drag_drop_mean = mean(N, na.rm = TRUE),
            drag_drop_sd = sd(N, na.rm = TRUE),
            n = n(),
            se = drag_drop_sd / sqrt(n),
            .groups = "drop")

summary_data_combined_ind <- bind_rows(summary_data_Amount_ind, summary_data_Prob_ind)

custom_colors_amount <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

summary_data_combined_ind$item.f = factor(summary_data_combined_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)


# Plot
ggplot(summary_data_combined_ind, aes(x = condition, y = drag_drop_mean, 
                                      group = item.f, color = item.f, shape = item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = drag_drop_mean - se,
      ymax = drag_drop_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Count",
    title = "Mean Drag Count by Condition"
  ) +
  scale_color_manual(values = custom_colors_amount) +  
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )

2.1.3 Correlation with Attribute Values

• Note on attribute rank coding:
  • Across Amount and Prob Tasks, greater value indicates higher rank (i.e., 1=item in the bottom and 6=item at the top.)

dat_long <- dat %>%
  pivot_longer(
    cols = matches("Set1_L[1-6]_(Prob|Amt)"),
    names_to = c("lottery", ".value"),
    names_pattern = "Set1_(L[1-6])_(Prob|Amt)"
  ) %>%
  mutate(item.f = case_when(
    lottery == "L1" ~ "Pr6_Amt1",
    lottery == "L2" ~ "Pr5_Amt2",
    lottery == "L3" ~ "Pr4_Amt3",
    lottery == "L4" ~ "Pr3_Amt4",
    lottery == "L5" ~ "Pr2_Amt5",
    lottery == "L6" ~ "Pr1_Amt6"
  ))



drag_and_drop_count_Amount_long<-drag_and_drop_count_Amount_long%>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_amount%>%select(ResponseId,initial.items_49:initial.items_68),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6),
  N_ind=case_when(
    N==0~0,
    TRUE~1)
  )%>%
  select(-c(initial.items_49:initial.items_68))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))



# dat_D is frequency judgment of the intensity items 
# <!--     item_moved==41 ~ "Remote", -->
# <!--     item_moved==42 ~ "WFH3", -->
# <!--     item_moved==40 ~ "Walk", -->
# <!--     item_moved==44 ~ "Hybrid", -->
# <!--     item_moved==45 ~ "Carpool5", -->
# <!--     item_moved==43 ~ "Public" # 2025/02/04; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature 

summary_data_Amount <- drag_and_drop_count_Amount_long%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(drag_mean = mean(N_ind, na.rm = TRUE),
            drag_sd = sd(N_ind, na.rm = TRUE),
            n = n(),
            se = drag_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))


# Calculate correlation
cor_result <- cor.test(dat_long$Prob, dat_long$Amt)
cor_estimate <- round(cor_result$estimate, 2)

# Create plot with correlation in the caption
ggplot(summary_data_Amount, aes(x = Avg.Amount, y = Avg.Prob, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(
    title = "Attributes of Lotteries",
    x = "Mean Amt",
    y = "Mean Prob",
    subtitle = paste("Correlation in dat.long: r =", cor_estimate)
  ) +
  theme(
    axis.title = element_text(face = "bold"), 
    plot.subtitle = element_text(hjust = 0.5), 
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed")

Amount Task

• Aggregate Stats

ggplot(summary_data_Amount, aes(x = Avg.Amount, y = drag_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Count and Amount Attribute", subtitle = "Amount Task", x = "Avg. Amt", y = "Avg. Drag Count Indicator") +
  theme(axis.title = element_text(face = "bold"), 
        plot.subtitle = element_text(hjust = 0.5), 
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

ggplot(summary_data_Amount, aes(x = Avg.Prob, y = drag_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Count and Prob Attribute", subtitle = "Amount Task", x = "Avg. Prob", y = "Avg. Drag Count Indicator") +
  theme(axis.title = element_text(face = "bold"), 
        plot.subtitle = element_text(hjust = 0.5), 
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

• Predict Drag Count (Indicator) with attribute ranks
  • Model Specification: Drag Count predicted by Amount and Prob attribute values
  • within each condition, still wondering if it makes sense to add item random effect control here… Xuwen reading this paper recommended by Antonia to learn more

M1<-glmer(N_ind~Amt+Prob+(1|ResponseId),drag_and_drop_count_Amount_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))
M2<-glmer(N_ind~Amt+Prob+initial.rank+(1|ResponseId),drag_and_drop_count_Amount_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))
M3<-glmer(N_ind~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),drag_and_drop_count_Amount_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))

tab_model(M1,M2,M3,transform = NULL,pred.labels = c("Intercept", "Amount", "Prob","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Log-Odds	CI	p	Log-Odds	CI	p	Log-Odds	CI	p
Intercept	1.54	0.35 – 2.73	0.011	-1.22	-1.23 – -1.21	<0.001	-1.37	-3.51 – 0.77	0.210
Amount	0.01	-0.02 – 0.05	0.339	0.03	0.02 – 0.04	<0.001	0.03	-0.02 – 0.07	0.230
Prob	-0.04	-0.06 – -0.02	<0.001	-0.05	-0.06 – -0.05	<0.001	-0.06	-0.08 – -0.03	<0.001
Initial Rank [1]				5.32	5.31 – 5.33	<0.001	5.68	3.33 – 8.03	<0.001
Initial Rank [2]				4.18	4.17 – 4.19	<0.001	4.43	2.39 – 6.47	<0.001
Initial Rank [3]				3.97	3.96 – 3.98	<0.001	4.28	2.30 – 6.25	<0.001
Initial Rank [4]				3.09	3.08 – 3.10	<0.001	3.35	1.50 – 5.20	<0.001
Initial Rank [5]				2.43	2.42 – 2.45	<0.001	2.64	0.91 – 4.37	0.003
Random Effects
σ2	3.29			3.29			3.29
τ00	0.27 ResponseId			0.67 ResponseId			0.75 ResponseId
							0.00 item.f
ICC	0.07			0.17
N	28 ResponseId			28 ResponseId			28 ResponseId
							6 item.f
Observations	168			168			168
Marginal R2 / Conditional R2	0.403 / 0.448			0.662 / 0.719			0.720 / NA

library(sandwich)
library(miceadds)
library(glmmML)

# test <- miceadds::glm.cluster( data=drag_and_drop_count_Color_long, formula=N_ind~rank.color+rank.Prob+initial.rank,
#                 cluster=c("ResponseId","item.f"), family="binomial")
# summary(test)

Prob Task

• Aggregate Stats

drag_and_drop_count_Prob_long<-drag_and_drop_count_Prob_long%>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_prob%>%select(ResponseId,initial.items_64:initial.items_67),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
    initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6),
    N_ind=case_when(
    N==0~0,
    TRUE~1)
  )%>%
  select(-c(initial.items_64:initial.items_67))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))



# dat_D is frequency judgment of the intensity items 
# <!--     item_moved==41 ~ "Remote", -->
# <!--     item_moved==42 ~ "WFH3", -->
# <!--     item_moved==40 ~ "Walk", -->
# <!--     item_moved==44 ~ "Hybrid", -->
# <!--     item_moved==45 ~ "Carpool5", -->
# <!--     item_moved==43 ~ "Public" # 2025/02/04; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature 


summary_data_Prob <- drag_and_drop_count_Prob_long%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(drag_mean = mean(N_ind, na.rm = TRUE),
            drag_sd = sd(N_ind, na.rm = TRUE),
            n = n(),
            se = drag_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))

ggplot(summary_data_Prob, aes(x = Avg.Amount, y = drag_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Count and Amount Attribute", subtitle = "Prob Task", x = "Avg. Amt", y = "Avg. Drag Count Indicator") +
  theme(axis.title = element_text(face = "bold"), 
        plot.subtitle = element_text(hjust = 0.5), 
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

ggplot(summary_data_Prob, aes(x = Avg.Prob, y = drag_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Count and Prob Attribute", subtitle = "Prob Task", x = "Avg. Prob", y = "Avg. Drag Count Indicator") +
  theme(axis.title = element_text(face = "bold"), 
        plot.subtitle = element_text(hjust = 0.5), 
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

• Predict Drag Count (Indicator) with attribute ranks

M1<-glmer(N_ind~Amt+Prob+(1|ResponseId),drag_and_drop_count_Prob_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))
M2<-glmer(N_ind~Amt+Prob+initial.rank+(1|ResponseId),drag_and_drop_count_Prob_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))
M3<-glmer(N_ind~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),drag_and_drop_count_Prob_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))

tab_model(M1,M2,M3,transform=NULL,pred.labels = c("Intercept", "Amount Rank", "Prob Rank","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Log-Odds	CI	p	Log-Odds	CI	p	Log-Odds	CI	p
Intercept	1.21	0.10 – 2.31	0.032	-21.11	-876.90 – 834.68	0.961	-22.03	-14428.06 – 14384.00	0.998
Amount Rank	-0.06	-0.09 – -0.02	0.001	-0.08	-0.12 – -0.03	0.001	-0.08	-0.12 – -0.03	0.001
Prob Rank	0.01	-0.01 – 0.02	0.534	0.03	-0.01 – 0.07	0.138	0.03	-0.01 – 0.07	0.138
Initial Rank [1]				24.25	-831.54 – 880.04	0.956	25.17	-14380.86 – 14431.20	0.997
Initial Rank [2]				24.31	-831.48 – 880.10	0.956	25.24	-14380.79 – 14431.27	0.997
Initial Rank [3]				22.08	-833.71 – 877.88	0.960	23.01	-14383.02 – 14429.04	0.998
Initial Rank [4]				23.61	-832.18 – 879.40	0.957	24.53	-14381.50 – 14430.57	0.997
Initial Rank [5]				21.36	-834.43 – 877.15	0.961	22.28	-14383.75 – 14428.31	0.998
Random Effects
σ2	3.29			3.29			3.29
τ00	0.00 ResponseId			0.00 ResponseId			0.00 ResponseId
							0.00 item.f
N	27 ResponseId			27 ResponseId			27 ResponseId
							6 item.f
Observations	162			162			162
Marginal R2 / Conditional R2	0.317 / NA			0.961 / NA			0.963 / NA

# test <- miceadds::glm.cluster( data=drag_and_drop_count_Prob_long, formula=N_ind~rank.Amount+rank.Prob+initial.rank,
#                 cluster=c("ResponseId"), family="binomial")
# summary(test)

Model with Combined Datasets

• Amount and Prob Attribute values are centered before being entered into the model.
• For condition, the reference level is Amount
• Model Specification: Drag count (indicator) predicted by Amount.c + Prob.c + condition + interaction between condition and attribute ranks

# 1. need to center things 
# 2. need to do a collinearity check.

drag_and_drop_count_Amount_long$condition<-"Amount"
drag_and_drop_count_Prob_long$condition<-"Prob"
  
drag_and_drop_count_long.combined<-rbind(drag_and_drop_count_Amount_long, drag_and_drop_count_Prob_long)%>%
  mutate(Prob.c=Prob-mean(Prob),
         Amount.c=Amt-mean(Amt))

M1<-glmer(N_ind~Amount.c*condition+Prob.c*condition+(1|ResponseId),drag_and_drop_count_long.combined,family=binomial)
M2<-glmer(N_ind~Amount.c*condition+Prob.c*condition+initial.rank+(1|ResponseId),drag_and_drop_count_long.combined,family=binomial)
M3<-glmer(N_ind~Amount.c*condition+Prob.c*condition+initial.rank+(1|ResponseId)+(1|item.f),drag_and_drop_count_long.combined,family=binomial)
 
# M1<-lmer(N_ind~rank.Amount.c*condition+rank.Prob.c*condition+(rank.Amount|ResponseId)+(rank.Prob|ResponseId),drag_and_drop_count_long.combined)
# M2<-lmer(N_ind~rank.Amount.c*condition+rank.Prob.c*condition+initial.rank+(rank.Amount|ResponseId)+(rank.Prob|ResponseId),drag_and_drop_count_long.combined)
# M3<-lmer(N_ind~rank.Amount.c*condition+rank.Prob.c*condition+initial.rank+(rank.Amount|ResponseId)+(rank.Prob|ResponseId)+(rank.Amount|item.f)+(rank.Prob|item.f),drag_and_drop_count_long.combined)

tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank","Condition [Prob]","Prob Rank", "Amount Rank x Condition [Prob]","Prob Rank x Condition [Prob]", "Ini. Rank [1]","Ini. Rank [2]","Ini. Rank [3]","Ini. Rank [4]","Ini. Rank [5]"), dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Odds Ratios	CI	p	Odds Ratios	CI	p	Odds Ratios	CI	p
Intercept	1.44	0.97 – 2.14	0.074	0.02	0.01 – 0.09	<0.001	0.02	0.01 – 0.09	<0.001
Amount Rank	1.01	0.98 – 1.05	0.351	1.03	0.99 – 1.08	0.170	1.03	0.99 – 1.08	0.169
Condition [Prob]	0.89	0.52 – 1.54	0.681	0.82	0.39 – 1.71	0.596	0.82	0.39 – 1.71	0.596
Prob Rank	0.96	0.94 – 0.98	<0.001	0.95	0.93 – 0.97	<0.001	0.95	0.93 – 0.97	<0.001
Amount Rank x Condition [Prob]	0.93	0.89 – 0.97	0.002	0.89	0.84 – 0.95	<0.001	0.89	0.84 – 0.95	<0.001
Prob Rank x Condition [Prob]	1.05	1.02 – 1.08	0.001	1.07	1.03 – 1.11	<0.001	1.07	1.03 – 1.11	<0.001
Ini. Rank [1]				534.53	88.81 – 3217.25	<0.001	534.59	88.82 – 3217.66	<0.001
Ini. Rank [2]				339.05	59.65 – 1927.28	<0.001	339.04	59.64 – 1927.26	<0.001
Ini. Rank [3]				109.33	21.45 – 557.34	<0.001	109.36	21.45 – 557.55	<0.001
Ini. Rank [4]				131.06	25.41 – 675.99	<0.001	131.08	25.41 – 676.13	<0.001
Ini. Rank [5]				35.78	7.87 – 162.68	<0.001	35.78	7.87 – 162.68	<0.001
Random Effects
σ2	3.29			3.29			3.29
τ00	0.00 ResponseId			0.09 ResponseId			0.09 ResponseId
							0.00 item.f
ICC				0.03			0.03
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.360 / NA			0.720 / 0.727			0.720 / 0.727

# test <- miceadds::glm.cluster( data=drag_and_drop_count_long.combined, formula=N_ind~rank.Amount.c*condition+rank.Prob.c*condition+initial.rank,
#                 cluster=c("ResponseId"), family="binomial")
# summary(test)

# test <- glmmML::glmmML(N_ind~rank.Amount.c*condition+rank.Prob.c*condition+initial.rank, data = drag_and_drop_count_long.combined, cluster = ResponseId)
# summary(test) # no variance?? then look into variance>

• Collinearity Check

  • Caution: The following preliminary tests assume independent observations and do not account for the multi-level structure of the data. Neds to dig in more.

  • VIF > 5 suggests high multicollinearity. Pass

  • GVIF extends VIF for categorical predictors. typically interpreted using GVIF^(1/(2×df)) < 2 as a guideline. Pass

library(car)
M1_lm<-lm(N_ind~Amount.c*condition+Prob.c*condition,drag_and_drop_count_long.combined)
M2_lm<-lm(N_ind~Amount.c*condition+Prob.c*condition+initial.rank,drag_and_drop_count_long.combined)
print("Model w/o ini. position")

## [1] "Model w/o ini. position"

vif_M1 <- car::vif(M1_lm)
vif_M1

##           Amount.c          condition             Prob.c Amount.c:condition 
##           3.784398           1.000028           3.844015           3.802994 
##   condition:Prob.c 
##           3.862643

print("Model w/ ini. position")

## [1] "Model w/ ini. position"

vif_M2 <- car::vif(M2_lm)
vif_M2

##                        GVIF Df GVIF^(1/(2*Df))
## Amount.c           3.804673  1        1.950557
## condition          1.000028  1        1.000014
## Prob.c             3.891442  1        1.972674
## initial.rank       1.051011  5        1.004988
## Amount.c:condition 3.850733  1        1.962328
## condition:Prob.c   3.894833  1        1.973533

Nested Model

• Nested Model returned consistent results for the rank variables, and appears easier to interpret/write up.
  • We created nested versions of the rank variables by coding them as follows: – When the condition matches the nested variable (e.g., condition == “Amount” for Amount/Prob rank [nested within Amount] ), we used mean centered value. This helps reduce multicollearity with the condition variable, see Collinearity Check below. – When the condition does not match, the value was set to 0.
• One question is how to interpret the coefficient of condition?

drag_and_drop_count_long.combined<-drag_and_drop_count_long.combined%>%
  mutate(Amt.Nested_Amount=case_when(
    condition == "Amount" ~ Amt,
    condition == "Prob" ~ 0
  ),
  Amt.Nested_Prob=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~  Amt
  ),
  Prob.Nested_Amount=case_when(
    condition == "Amount" ~ Prob,
    condition == "Prob" ~ 0
  ),
  Prob.Nested_Prob=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Prob
  ),
  Amt.Nested_Amount.c=case_when(
    condition == "Amount" ~Amount.c,
    condition == "Prob" ~ 0
  ),
  Amt.Nested_Prob.c=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Amount.c
  ),
  Prob.Nested_Amount.c=case_when(
    condition == "Amount" ~Prob.c,
    condition == "Prob" ~ 0
  ),
  Prob.Nested_Prob.c=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Prob.c
  )
  )

M1<-glmer(N_ind~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+(1|ResponseId),drag_and_drop_count_long.combined,family=binomial)
M2<-glmer(N_ind~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+(1|ResponseId),drag_and_drop_count_long.combined,family=binomial)

M3<-glmer(N_ind~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+(1|ResponseId)+(1|item.f),drag_and_drop_count_long.combined,family=binomial)

tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank [Nested in Amount]","Amount Rank [Nested in Prob]","Prob Rank [Nested in Amount]","Prob Rank [Nested in Prob]","Condition [Prob]", "Ini. Rank [1]","Ini. Rank [2]","Ini. Rank [3]","Ini. Rank [4]","Ini. Rank [5]"), dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"),transform = NULL)

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Log-Odds	CI	p	Log-Odds	CI	p	Log-Odds	CI	p
Intercept	0.36	-0.03 – 0.76	0.074	-3.74	-5.11 – -2.36	<0.001	-3.74	-5.11 – -2.36	<0.001
Amount Rank [Nested in Amount]	0.01	-0.02 – 0.04	0.351	0.03	-0.01 – 0.07	0.169	0.03	-0.01 – 0.07	0.169
Amount Rank [Nested in Prob]	-0.06	-0.09 – -0.02	0.001	-0.08	-0.12 – -0.04	<0.001	-0.08	-0.12 – -0.04	<0.001
Prob Rank [Nested in Amount]	-0.04	-0.06 – -0.02	<0.001	-0.05	-0.08 – -0.03	<0.001	-0.05	-0.08 – -0.03	<0.001
Prob Rank [Nested in Prob]	0.01	-0.01 – 0.02	0.534	0.01	-0.01 – 0.04	0.291	0.01	-0.01 – 0.04	0.291
Condition [Prob]	-0.11	-0.66 – 0.43	0.681	-0.20	-0.93 – 0.53	0.596	-0.20	-0.93 – 0.53	0.596
Ini. Rank [1]				6.28	4.49 – 8.08	<0.001	6.28	4.49 – 8.08	<0.001
Ini. Rank [2]				5.83	4.09 – 7.56	<0.001	5.83	4.09 – 7.56	<0.001
Ini. Rank [3]				4.69	3.07 – 6.32	<0.001	4.69	3.07 – 6.32	<0.001
Ini. Rank [4]				4.88	3.24 – 6.52	<0.001	4.88	3.24 – 6.52	<0.001
Ini. Rank [5]				3.58	2.06 – 5.09	<0.001	3.58	2.06 – 5.09	<0.001
Random Effects
σ2	3.29			3.29			3.29
τ00	0.00 ResponseId			0.09 ResponseId			0.09 ResponseId
							0.00 item.f
ICC				0.03			0.03
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.360 / NA			0.720 / 0.727			0.720 / 0.727

print("Models showing Beta rather than Odds Ratio:")

## [1] "Models showing Beta rather than Odds Ratio:"

tab_model(
  M1, M2, M3,
  pred.labels = c("Intercept", 
                  "Amount Rank [Nested in Amount]",
                  "Amount Rank [Nested in Prob]",
                  "Prob Rank [Nested in Amount]",
                  "Prob Rank [Nested in Prob]",
                  "Condition [Prob]", 
                  "Ini. Rank [1]",
                  "Ini. Rank [2]",
                  "Ini. Rank [3]",
                  "Ini. Rank [4]",
                  "Ini. Rank [5]"),
  dv.labels = c("Subj. Random_eff", "Add Ini. Position", "Add Item Random_eff"),
  transform = NULL
)

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Log-Odds	CI	p	Log-Odds	CI	p	Log-Odds	CI	p
Intercept	0.36	-0.03 – 0.76	0.074	-3.74	-5.11 – -2.36	<0.001	-3.74	-5.11 – -2.36	<0.001
Amount Rank [Nested in Amount]	0.01	-0.02 – 0.04	0.351	0.03	-0.01 – 0.07	0.169	0.03	-0.01 – 0.07	0.169
Amount Rank [Nested in Prob]	-0.06	-0.09 – -0.02	0.001	-0.08	-0.12 – -0.04	<0.001	-0.08	-0.12 – -0.04	<0.001
Prob Rank [Nested in Amount]	-0.04	-0.06 – -0.02	<0.001	-0.05	-0.08 – -0.03	<0.001	-0.05	-0.08 – -0.03	<0.001
Prob Rank [Nested in Prob]	0.01	-0.01 – 0.02	0.534	0.01	-0.01 – 0.04	0.291	0.01	-0.01 – 0.04	0.291
Condition [Prob]	-0.11	-0.66 – 0.43	0.681	-0.20	-0.93 – 0.53	0.596	-0.20	-0.93 – 0.53	0.596
Ini. Rank [1]				6.28	4.49 – 8.08	<0.001	6.28	4.49 – 8.08	<0.001
Ini. Rank [2]				5.83	4.09 – 7.56	<0.001	5.83	4.09 – 7.56	<0.001
Ini. Rank [3]				4.69	3.07 – 6.32	<0.001	4.69	3.07 – 6.32	<0.001
Ini. Rank [4]				4.88	3.24 – 6.52	<0.001	4.88	3.24 – 6.52	<0.001
Ini. Rank [5]				3.58	2.06 – 5.09	<0.001	3.58	2.06 – 5.09	<0.001
Random Effects
σ2	3.29			3.29			3.29
τ00	0.00 ResponseId			0.09 ResponseId			0.09 ResponseId
							0.00 item.f
ICC				0.03			0.03
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.360 / NA			0.720 / 0.727			0.720 / 0.727

# M_robust <- lm_robust(N_ind~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank,drag_and_drop_count_long.combined, clusters = ~ResponseId+item.f)
# tab_model(M_robust)

• Collinearity Check

library(car)
M1_lm<-lm(N_ind~Amt.Nested_Amount+Amt.Nested_Prob+Prob.Nested_Amount+Prob.Nested_Prob+condition+initial.rank,drag_and_drop_count_long.combined)
M1_lm.2<-lm(N_ind~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank,drag_and_drop_count_long.combined)

print("Nested Variable w raw rank")

## [1] "Nested Variable w raw rank"

vif_M1 <- car::vif(M1_lm)
vif_M1

##                        GVIF Df GVIF^(1/(2*Df))
## Amt.Nested_Amount  2.986549  1        1.728163
## Amt.Nested_Prob    3.112660  1        1.764273
## Prob.Nested_Amount 3.168903  1        1.780141
## Prob.Nested_Prob   3.248764  1        1.802433
## condition          8.738075  1        2.956023
## initial.rank       1.051011  5        1.004988

print("Nested Variable w/ mean centered values")

## [1] "Nested Variable w/ mean centered values"

Vif_M1.2 <- car::vif(M1_lm.2)
Vif_M1.2

##                          GVIF Df GVIF^(1/(2*Df))
## Amt.Nested_Amount.c  1.961926  1        1.400688
## Amt.Nested_Prob.c    2.014593  1        1.419364
## Prob.Nested_Amount.c 1.975531  1        1.405536
## Prob.Nested_Prob.c   1.993983  1        1.412085
## condition            1.000028  1        1.000014
## initial.rank         1.051011  5        1.004988

2.2 DV2: Drag Order

• Drag order is the sequence in which items are dragged and dropped. Items that are not dragged are assigned a value of (1 + the total number of dragged items). For example, if a participant moves item A three times, item B twice, and item C once, while items D, E, and F remain untouched, the drag order is:
  • A = 1, B = 2, C = 3, D = E = F = 4.
  • This coding approach simplifies cases where an item is touched multiple times (as in the example). However, as seen, it is relatively rare that participants drag the same item repeatedly, justifying this simplification.

touch_order_analysis_Amount<-RankProcess_Amount%>%
  filter(step!=0)%>%
  group_by(ResponseId)%>%
  arrange(step)%>%
  filter(!duplicated(item_moved))%>% # retains only the first instance
  mutate(order=row_number())%>%
  ungroup()%>%
  mutate(condition="Amount")


touch_order_analysis.long_Amount <- expand_grid(
  ResponseId = unique(touch_order_analysis_Amount$ResponseId),
  item.f = unique(touch_order_analysis_Amount$item.f)
)

order_max.SUBJ_Amount<-touch_order_analysis.long_Amount%>%
  left_join(touch_order_analysis_Amount%>%select(ResponseId,item.f,order),by=c("ResponseId","item.f"))%>%
  left_join(touch_order_analysis_Amount%>%select(ResponseId,condition)%>%filter(!duplicated(ResponseId)),by=c("ResponseId"))%>%
  group_by(ResponseId)%>%
  summarize(max_order=max(order,na.rm = T))

touch_order_analysis.long_Amount<-touch_order_analysis.long_Amount%>%
  left_join(touch_order_analysis_Amount%>%select(ResponseId,item.f,order),by=c("ResponseId","item.f"))%>%
  left_join(touch_order_analysis_Amount%>%select(ResponseId,condition)%>%filter(!duplicated(ResponseId)),by=c("ResponseId"))%>%left_join(order_max.SUBJ_Amount,by="ResponseId")%>%
  mutate(order = case_when(!is.na(order)~order,
                           TRUE~max_order+1))

touch_order_analysis_Prob<-RankProcess_Prob%>%
  filter(step!=0)%>%
  group_by(ResponseId)%>%
  arrange(step)%>%
  filter(!duplicated(item_moved))%>%
  mutate(order=row_number())%>%
  ungroup()%>%
  mutate(condition="Prob")



touch_order_analysis.long_Prob <- expand_grid(
  ResponseId = unique(touch_order_analysis_Prob$ResponseId),
  item.f = unique(touch_order_analysis_Prob$item.f)
)


order_max.SUBJ_Prob<-touch_order_analysis.long_Prob%>%
  left_join(touch_order_analysis_Prob%>%select(ResponseId,item.f,order),by=c("ResponseId","item.f"))%>%
  left_join(touch_order_analysis_Prob%>%select(ResponseId,condition)%>%filter(!duplicated(ResponseId)),by=c("ResponseId"))%>%
  group_by(ResponseId)%>%
  summarize(max_order=max(order,na.rm = T))

touch_order_analysis.long_Prob<-touch_order_analysis.long_Prob%>%
  left_join(touch_order_analysis_Prob%>%select(ResponseId,item.f,order),by=c("ResponseId","item.f"))%>%
  left_join(touch_order_analysis_Prob%>%select(ResponseId,condition)%>%filter(!duplicated(ResponseId)),by=c("ResponseId"))%>%left_join(order_max.SUBJ_Prob,by="ResponseId")%>%
  mutate(order = case_when(!is.na(order)~order,
                           TRUE~max_order+1))



# length(unique(touch_order_analysis.long_A$ResponseId)) #142, good.
# touch_order_analysis.long_A%>%
#   group_by(ResponseId)%>%
#   summarize(n_6=n_distinct(item.f))%>%
#    filter(n_6!=6) # none, good
# psych::describe(drag_order_analysis.long$order) # between 1 and 6, good.

2.2.0 Distribution of Drag Order by item

touch_order_Amount <- touch_order_analysis.long_Amount %>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  count(item.f,order,condition) %>%
  group_by(item.f)%>%
  mutate(percentage = n / sum(n) * 100)%>%
  ungroup()

touch_order_Prob <- touch_order_analysis.long_Prob %>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  count(item.f,order,condition) %>%
  group_by(item.f)%>%
  mutate(percentage = n / sum(n) * 100)%>%
  ungroup()
touch_order_combined<-rbind(touch_order_Prob,touch_order_Amount)

# drag_drop_counts%>%
#   group_by(item.f)%>%
#   summarise(subj_count=sum(n)) # all 389, good.

ggplot(touch_order_combined, aes(x = factor(order), y = n)) +
  geom_bar(
    stat = "identity",
    color = "black"
  ) +
  geom_text(
    aes(
      label = paste0(n, " (", round(percentage, 1), "%)")
    ),
    vjust = -0.5,
    size = 5,
    fontface="bold"
  ) +
  labs(
    title = "Drag Order by item and Condition",
    x = "Drag Order",
    y = "Frequency"
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(size = 12, face = "bold"),  # Facet label adjustments
    plot.title = element_text(hjust = 0.5, face = "bold"),
    axis.title = element_text(size = 12),
    axis.text = element_text(size = 10)
  ) +
  facet_wrap(~ item.f * condition,ncol = 2) +
  ylim(0, 30)

2.2.0 (Descriptive Cont.) Distribution of Mean Drag Order

mean_order.subj_Prob <- touch_order_analysis.long_Prob %>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  group_by(ResponseId)%>%
  mutate(mean_order = mean(order),
         condition="Prob")%>%
  ungroup()
mean_order.subj_Amount<- touch_order_analysis.long_Amount %>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  group_by(ResponseId)%>%
  mutate(mean_order = mean(order),
         condition="Amount")%>%
  ungroup()
# mean_order.subj%>%
#   filter(is.na(mean_order)) # none, good
# drag_drop_counts%>%
#   group_by(item.f)%>%
#   summarise(subj_count=sum(n)) # all 389, good.

mean_order.subj_combined<-rbind(mean_order.subj_Amount,mean_order.subj_Prob)

ggplot(mean_order.subj_combined, aes(x = mean_order)) +
  geom_density(fill = "lightblue", color = "black", alpha = 0.5) +
  geom_rug(sides = "b", color = "blue") +  # Rug plot along the bottom (x-axis) for individual data points
  labs(
    title = "Density Plot of Mean Drag Order",
    x = "Mean Drag Order",
    y = "Density"
  ) +
  facet_grid(~condition)

2.2.1 Model-free visualization

summary_data_Amount<- touch_order_analysis.long_Amount%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(order_mean = mean(order, na.rm = TRUE),
            order_sd = sd(order, na.rm = TRUE),
            n = n(),
            se = order_sd / sqrt(n),  # Standard error
            .groups = "drop")


summary_data_Prob <- touch_order_analysis.long_Prob%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(order_mean = mean(order, na.rm = TRUE),
            order_sd = sd(order, na.rm = TRUE),
            n = n(),
            se = order_sd / sqrt(n),  # Standard error
            .groups = "drop")


summary_data_combined <- bind_rows(summary_data_Amount, summary_data_Prob)


custom_Amounts_color <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

summary_data_combined_ind$item.f = factor(summary_data_combined_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)



ggplot(summary_data_combined, aes(x = condition, y = order_mean, 
                                      group = item.f, color = item.f, shape = item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = order_mean - se,
      ymax = order_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Order",
    title = "Mean Drag Order by Condition"
  ) +
  scale_color_manual(values = custom_Amounts_color) +  
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )

2.2.3 Correlation with Attribute Values

Amount Task

• Aggregate Stats

touch_order_analysis.long_Amount<-touch_order_analysis.long_Amount%>%
    filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_amount%>%select(ResponseId,initial.items_49:initial.items_68),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6)
  )%>%
  select(-c(initial.items_49:initial.items_68))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))


summary_data_Amount <- touch_order_analysis.long_Amount%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(order_mean = mean(order, na.rm = TRUE),
            order_sd = sd(order, na.rm = TRUE),
            n = n(),
            se = order_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))

ggplot(summary_data_Amount, aes(x = Avg.Amount, y = order_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Order and Amount Attribute", subtitle = "Amount Task", x = "Avg. Amt", y = "Avg. Drag Order") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed")

ggplot(summary_data_Amount, aes(x = Avg.Prob, y = order_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Order and Prob Attribute", subtitle = "Amount Task", x = "Avg. Prob", y = "Avg. Drag Order") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

• Predict Drag Order with attribute ranks

  • Model Specification: Drag Count predicted by Amount and Prob attribute values

  • Note: A negative sign was added to the order DV. So a positive coefficient indicates that a higher value of the predictor contributes to the item being ranked first

M1<-lmer(order~Amt+Prob+(1|ResponseId),touch_order_analysis.long_Amount)
M2<-lmer(order~Amt+Prob+initial.rank+(1|ResponseId),touch_order_analysis.long_Amount)
M3<-lmer(order~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),touch_order_analysis.long_Amount)
tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank", "Prob Rank","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	3.40	2.97 – 3.83	<0.001	4.37	3.89 – 4.85	<0.001	4.02	3.18 – 4.87	<0.001
Amount Rank	-0.04	-0.05 – -0.03	<0.001	-0.03	-0.04 – -0.03	<0.001	-0.02	-0.04 – -0.00	0.018
Prob Rank	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001	0.01	0.00 – 0.03	0.048
Initial Rank [1]				-1.27	-1.70 – -0.83	<0.001	-1.26	-1.68 – -0.84	<0.001
Initial Rank [2]				-1.24	-1.68 – -0.80	<0.001	-1.18	-1.61 – -0.75	<0.001
Initial Rank [3]				-1.30	-1.74 – -0.86	<0.001	-1.22	-1.65 – -0.80	<0.001
Initial Rank [4]				-1.08	-1.52 – -0.64	<0.001	-1.00	-1.42 – -0.58	<0.001
Initial Rank [5]				-0.86	-1.30 – -0.42	<0.001	-0.84	-1.27 – -0.42	<0.001
Random Effects
σ2	0.91			0.69			0.63
τ00	0.02 ResponseId			0.05 ResponseId			0.06 ResponseId
							0.17 item.f
ICC	0.02			0.07			0.27
N	28 ResponseId			28 ResponseId			28 ResponseId
							6 item.f
Observations	168			168			168
Marginal R2 / Conditional R2	0.527 / 0.536			0.626 / 0.654			0.496 / 0.632

# M1_robust <- lm_robust(-order ~ rank.Amount + rank.Prob, data = touch_order_analysis.long_Amount, clusters = ResponseId)
# M2_robust <- lm_robust(-order ~ rank.Amount + rank.Prob + initial.rank, data = touch_order_analysis.long_Amount, clusters = ResponseId)
# M3_robust <- lm_robust(-order ~ rank.Amount + rank.Prob + initial.rank, data = touch_order_analysis.long_Amount, clusters = interaction(ResponseId, item.f))
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

Prob Task

• Aggregate Stats

touch_order_analysis.long_Prob<-touch_order_analysis.long_Prob%>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_prob%>%select(ResponseId,initial.items_64:initial.items_67),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6)
  )%>%
  select(-c(initial.items_64:initial.items_67))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))



# dat_D is frequency judgment of the intensity items
# <!--     item_moved==41 ~ "Remote", -->
# <!--     item_moved==42 ~ "WFH3", -->
# <!--     item_moved==40 ~ "Walk", -->
# <!--     item_moved==44 ~ "Hybrid", -->
# <!--     item_moved==45 ~ "Carpool5", -->
# <!--     item_moved==43 ~ "Public" # 2025/02/04; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature


summary_data_Prob <- touch_order_analysis.long_Prob%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(order_mean = mean(order, na.rm = TRUE),
            order_sd = sd(order, na.rm = TRUE),
            n = n(),
            se = order_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))


ggplot(summary_data_Prob, aes(x = Avg.Amount, y = order_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Order and Amount Attribute", subtitle = "Prob Task", x = "Avg. Amt", y = "Avg. Drag Order") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed")

ggplot(summary_data_Prob, aes(x = Avg.Prob, y = order_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Order and Prob Attribute", subtitle = "Prob Task", x  = "Avg. Prob", y = "Avg. Drag Order") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

M1<-lmer(order~Amt+Prob+(1|ResponseId),touch_order_analysis.long_Prob)
M2<-lmer(order~Amt+Prob+initial.rank+(1|ResponseId),touch_order_analysis.long_Prob)
M3<-lmer(order~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),touch_order_analysis.long_Prob)

tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank", "Prob Rank","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	3.32	2.86 – 3.78	<0.001	4.50	4.05 – 4.94	<0.001	4.44	3.88 – 5.00	<0.001
Amount Rank	0.02	0.01 – 0.03	<0.001	0.02	0.01 – 0.03	<0.001	0.02	0.01 – 0.04	<0.001
Prob Rank	-0.02	-0.03 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001
Initial Rank [1]				-1.82	-2.25 – -1.40	<0.001	-1.82	-2.25 – -1.40	<0.001
Initial Rank [2]				-1.71	-2.13 – -1.28	<0.001	-1.69	-2.11 – -1.27	<0.001
Initial Rank [3]				-1.65	-2.07 – -1.22	<0.001	-1.63	-2.05 – -1.20	<0.001
Initial Rank [4]				-1.59	-2.02 – -1.17	<0.001	-1.56	-1.99 – -1.14	<0.001
Initial Rank [5]				-1.15	-1.58 – -0.73	<0.001	-1.12	-1.54 – -0.69	<0.001
Random Effects
σ2	1.00			0.62			0.60
τ00	0.00 ResponseId			0.00 ResponseId			0.00 ResponseId
							0.03 item.f
N	27 ResponseId			27 ResponseId			27 ResponseId
							6 item.f
Observations	162			162			162
Marginal R2 / Conditional R2	0.449 / NA			0.660 / NA			0.665 / NA

# M1_robust <- lm_robust(-order ~ rank.Amount + rank.Prob, data = touch_order_analysis.long_Prob, clusters = ResponseId)
# M2_robust <- lm_robust(-order ~ rank.Amount + rank.Prob + initial.rank, data = touch_order_analysis.long_Prob, clusters = ResponseId)
# M3_robust <- lm_robust(-order ~ rank.Amount + rank.Prob + initial.rank, data = touch_order_analysis.long_Prob, clusters = interaction(ResponseId, item.f))
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

Model with Combined Datasets

• Amount and Prob Attribute values are centered before being entered into the model.

touch_order_analysis.long_Amount$condition<-"Amount"
touch_order_analysis.long_Prob$condition<-"Prob"
  
touch_order_analysis.long.combined<-rbind(touch_order_analysis.long_Prob, touch_order_analysis.long_Amount)%>%
  mutate(Prob.c=Prob-mean(Prob),
         Amount.c=Amt-mean(Amt))

M1<-lmer(order~Amount.c*condition+Prob.c*condition+(1|ResponseId),touch_order_analysis.long.combined)
M2<-lmer(order~Amount.c*condition+Prob.c*condition+initial.rank+(1|ResponseId),touch_order_analysis.long.combined)
M3<-lmer(order~Amount.c*condition+Prob.c*condition+initial.rank+(1|ResponseId)+(1|item.f),touch_order_analysis.long.combined)

tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank","Condition [Prob]","Prob Rank", "Amount Rank x Condition [Prob]","Prob Rank x Condition [Prob]", "Ini. Rank [1]","Ini. Rank [2]","Ini. Rank [3]","Ini. Rank [4]","Ini. Rank [5]"), dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	3.09	2.95 – 3.24	<0.001	4.23	3.99 – 4.47	<0.001	4.23	3.99 – 4.47	<0.001
Amount Rank	-0.04	-0.05 – -0.02	<0.001	-0.03	-0.04 – -0.03	<0.001	-0.03	-0.04 – -0.03	<0.001
Condition [Prob]	-0.00	-0.22 – 0.21	0.972	-0.00	-0.18 – 0.18	0.979	-0.00	-0.18 – 0.18	0.979
Prob Rank	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001
Amount Rank x Condition [Prob]	0.05	0.04 – 0.07	<0.001	0.06	0.04 – 0.07	<0.001	0.06	0.04 – 0.07	<0.001
Prob Rank x Condition [Prob]	-0.03	-0.04 – -0.02	<0.001	-0.03	-0.04 – -0.02	<0.001	-0.03	-0.04 – -0.02	<0.001
Ini. Rank [1]				-1.54	-1.85 – -1.23	<0.001	-1.54	-1.85 – -1.23	<0.001
Ini. Rank [2]				-1.47	-1.78 – -1.16	<0.001	-1.47	-1.78 – -1.16	<0.001
Ini. Rank [3]				-1.47	-1.78 – -1.16	<0.001	-1.47	-1.78 – -1.16	<0.001
Ini. Rank [4]				-1.33	-1.64 – -1.02	<0.001	-1.33	-1.64 – -1.02	<0.001
Ini. Rank [5]				-1.00	-1.31 – -0.70	<0.001	-1.00	-1.31 – -0.70	<0.001
Random Effects
σ2	0.96			0.67			0.67
τ00	0.00 ResponseId			0.01 ResponseId			0.01 ResponseId
							0.00 item.f
ICC				0.01
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.490 / NA			0.640 / 0.644			0.642 / NA

# M1_robust <- lm_robust(-order~rank.Amount.c*condition+rank.Prob.c*condition,touch_order_analysis.long.combined, clusters = ResponseId)
# M2_robust <- lm_robust(-order ~ rank.Amount.c*condition+rank.Prob.c*condition+initial.rank, data = touch_order_analysis.long.combined, clusters = ResponseId)
# M3_robust <- lm_robust(-order ~ rank.Amount.c*condition+rank.Prob.c*condition+initial.rank, data = touch_order_analysis.long.combined, clusters = interaction(ResponseId, item.f))
# 
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

• Collinearity Check

  • Caution: The following preliminary tests assume independent observations and do not account for the multi-level structure of the data. Neds to dig in more.

  • VIF > 5 suggests high multicollinearity. Pass

  • GVIF extends VIF for categorical predictors. typically interpreted using GVIF^(1/(2×df)) < 2 as a guideline. Pass

M1_lm<-lm(order~Amount.c*condition+Prob.c*condition,touch_order_analysis.long.combined)
M2_lm<-lm(order~Amount.c*condition+Prob.c*condition+initial.rank,touch_order_analysis.long.combined)

print("Model w/o ini. position")

## [1] "Model w/o ini. position"

vif_M1 <- car::vif(M1_lm)
vif_M1

##           Amount.c          condition             Prob.c Amount.c:condition 
##           3.784398           1.000028           3.844015           3.802994 
##   condition:Prob.c 
##           3.862643

print("Model w/ ini. position")

## [1] "Model w/ ini. position"

vif_M2 <- car::vif(M2_lm)
vif_M2

##                        GVIF Df GVIF^(1/(2*Df))
## Amount.c           3.804673  1        1.950557
## condition          1.000028  1        1.000014
## Prob.c             3.891442  1        1.972674
## initial.rank       1.051011  5        1.004988
## Amount.c:condition 3.850733  1        1.962328
## condition:Prob.c   3.894833  1        1.973533

# examine<-Distance_Amount%>%filter(ResponseId%in%Amount_correct_subj)
# table(examine$move_direction) #79/(29+79), 73%
# examine<-Distance_Prob%>%filter(ResponseId%in%Prob_correct_subj)
# table(examine$move_direction) # 88/(28+88) 76%

Nested Models

##### Nested Model
touch_order_analysis.long.combined<-touch_order_analysis.long.combined%>%
  mutate(Amt.Nested_Amount=case_when(
    condition == "Amount" ~Amt,
    condition == "Prob" ~ 0
  ),
  Amt.Nested_Prob=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Amt
  ),
  Prob.Nested_Amount=case_when(
    condition == "Amount" ~Prob,
    condition == "Prob" ~ 0
  ),
  Prob.Nested_Prob=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Prob
  ),
  Amt.Nested_Amount.c=case_when(
    condition == "Amount" ~Amount.c,
    condition == "Prob" ~ 0
  ),
  Amt.Nested_Prob.c=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Amount.c
  ),
  Prob.Nested_Amount.c=case_when(
    condition == "Amount" ~Prob.c,
    condition == "Prob" ~ 0
  ),
  Prob.Nested_Prob.c=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Prob.c
  ))

M1<-lmer(order~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+(1|ResponseId),touch_order_analysis.long.combined)
M2<-lmer(order~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+(1|ResponseId),touch_order_analysis.long.combined)
M3<-lmer(order~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+(1|ResponseId)+(1|item.f),touch_order_analysis.long.combined)

tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank [Nested in Amount]","Amount Rank [Nested in Prob]","Prob Rank [Nested in Amount]","Prob Rank [Nested in Prob]","Condition [Prob]", "Ini. Rank [1]","Ini. Rank [2]","Ini. Rank [3]","Ini. Rank [4]","Ini. Rank [5]"), dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	3.09	2.95 – 3.24	<0.001	4.23	3.99 – 4.47	<0.001	4.23	3.99 – 4.47	<0.001
Amount Rank [Nested in Amount]	-0.04	-0.05 – -0.02	<0.001	-0.03	-0.04 – -0.03	<0.001	-0.03	-0.04 – -0.03	<0.001
Amount Rank [Nested in Prob]	0.02	0.01 – 0.03	<0.001	0.02	0.01 – 0.03	<0.001	0.02	0.01 – 0.03	<0.001
Prob Rank [Nested in Amount]	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001
Prob Rank [Nested in Prob]	-0.02	-0.03 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001
Condition [Prob]	-0.00	-0.22 – 0.21	0.972	-0.00	-0.18 – 0.18	0.979	-0.00	-0.18 – 0.18	0.979
Ini. Rank [1]				-1.54	-1.85 – -1.23	<0.001	-1.54	-1.85 – -1.23	<0.001
Ini. Rank [2]				-1.47	-1.78 – -1.16	<0.001	-1.47	-1.78 – -1.16	<0.001
Ini. Rank [3]				-1.47	-1.78 – -1.16	<0.001	-1.47	-1.78 – -1.16	<0.001
Ini. Rank [4]				-1.33	-1.64 – -1.02	<0.001	-1.33	-1.64 – -1.02	<0.001
Ini. Rank [5]				-1.00	-1.31 – -0.70	<0.001	-1.00	-1.31 – -0.70	<0.001
Random Effects
σ2	0.96			0.67			0.67
τ00	0.00 ResponseId			0.01 ResponseId			0.01 ResponseId
							0.00 item.f
ICC				0.01
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.490 / NA			0.640 / 0.644			0.642 / NA

# M_robust <- lm_robust(-order~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+item.f,touch_order_analysis.long.combined, clusters = ResponseId)
# tab_model(M_robust)

• Collinearity Check

library(car)
M1_lm<-lm(order~Amt.Nested_Amount+Amt.Nested_Prob+Prob.Nested_Amount+Prob.Nested_Prob+condition+initial.rank,touch_order_analysis.long.combined)
M1_lm.2<-lm(order~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank,touch_order_analysis.long.combined)

print("Nested Variable Mean Centered values")

## [1] "Nested Variable Mean Centered values"

Vif_M1.2 <- car::vif(M1_lm.2)
Vif_M1.2

##                          GVIF Df GVIF^(1/(2*Df))
## Amt.Nested_Amount.c  1.961926  1        1.400688
## Amt.Nested_Prob.c    2.014593  1        1.419364
## Prob.Nested_Amount.c 1.975531  1        1.405536
## Prob.Nested_Prob.c   1.993983  1        1.412085
## condition            1.000028  1        1.000014
## initial.rank         1.051011  5        1.004988

print("Nested Variable w raw values")

## [1] "Nested Variable w raw values"

vif_M1 <- car::vif(M1_lm)
vif_M1

##                        GVIF Df GVIF^(1/(2*Df))
## Amt.Nested_Amount  2.986549  1        1.728163
## Amt.Nested_Prob    3.112660  1        1.764273
## Prob.Nested_Amount 3.168903  1        1.780141
## Prob.Nested_Prob   3.248764  1        1.802433
## condition          8.738075  1        2.956023
## initial.rank       1.051011  5        1.004988

2.3 DV3: Drag Distance

• Replication of Drag Direction Pattern: 66% and 78% of drag and drops resulted in the item being ranked higher in the Amount and Prob Task respectively.

• Focuses exclusively on the first drag: While it is possible to calculate and model the distance for each instance an item is dragged and dropped, we simplify the analysis by retaining only the first drag-and-drop instance for each respondent. This is is justified by prior analyses showing that multiple drag-and-drop instances are rare. I also did an alternative analysis using the mean distance across all drag-and-drop instances. The results below were consistent.

• Coding of Distance:

  • After each dragging item, the distance is calculated as Last Position - Current Position of the dragged item. Positive values indicate that the item was ranked up (e.g., moved from 2nd place to the 1st place), and positive values indicate that the item is ranked down (e.g., moved from 1st place to the second place). items that are not dragged for each respondent are assigned a distance of 0

2.3.1 Distribution of Drag Distance

# length(unique(Distance_Amount$ResponseId))
# table(Distance_Amount$move_direction)
# length(unique(Distance_Prob$ResponseId))
# table(Distance_Prob$move_direction)

Distance_Amount.cleanup<-Distance_Amount%>%
  separate(timing, into = c("drag_time", "drop_time"), sep = ", ", convert = TRUE)%>%
  mutate(distance_49=current_49-last_49,
         distance_50=current_50-last_50,
         distance_64=current_64-last_64,
         distance_65=current_65-last_65,
         distance_67=current_67-last_67,
         distance_68=current_68-last_68,
         DD_diff=drop_time-drag_time,
         condition="Amount")%>%
  select(drag_time,DD_diff,distance_49,distance_50,distance_64,distance_65,distance_67,distance_68,order,item.f,step,ResponseId,condition)

Distance_Amount.cleanup<-Distance_Amount.cleanup%>%
  group_by(ResponseId)%>%
  arrange(step)%>%
  filter(!duplicated(item.f))%>%
  ungroup()

unique_ResponseIds_Amount <- Distance_Amount %>%
  distinct(ResponseId) %>%
  pull(ResponseId) # Extract as a vector





Distance_Amount.cleanup.df <- expand.grid(ResponseId = unique_ResponseIds_Amount,
                                    item.f = c("Pr6_Amt1","Pr5_Amt2","Pr4_Amt3","Pr3_Amt4","Pr2_Amt5", "Pr1_Amt6")) 


Distance_Amount.cleanup.df<-Distance_Amount.cleanup.df%>%
  left_join(Distance_Amount.cleanup%>%select(ResponseId,item.f,distance_49,distance_50,distance_64,distance_65,distance_67,distance_68,drag_time,DD_diff),by=c("ResponseId","item.f"))



Distance_Amount.cleanup.df<-Distance_Amount.cleanup.df%>%
  arrange(ResponseId)%>%
  mutate(distance=case_when(item.f=="Pr6_Amt1" ~ distance_49,
                            item.f=="Pr5_Amt2" ~ distance_50,
                            item.f=="Pr4_Amt3" ~ distance_64,
                            item.f=="Pr3_Amt4" ~ distance_65,
                            item.f=="Pr2_Amt5" ~ distance_67,
                            item.f=="Pr1_Amt6" ~ distance_68,
                            ),
         distance=case_when(is.na(distance)~0, # items that are not moved get a distance of 0
                            TRUE ~ distance),
         distance.abs=abs(distance))

summary_stats <- Distance_Amount.cleanup.df %>%
  group_by(item.f) %>%
  summarize(
    mean_distance = mean(distance, na.rm = TRUE),
    median_distance = median(distance, na.rm = TRUE)
  )

custom_Amounts_color <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

Distance_Amount.cleanup.df$item.f<- factor(Distance_Amount.cleanup.df$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)




ggplot(Distance_Amount.cleanup.df ,
       aes(x = -distance, fill = item.f)) +
  geom_histogram(binwidth = 1, alpha = 0.3, position = "identity") +
  labs(
    title = "Distribution of Drag Distance - Amount Task",
    x = "Distance",
    y = "Count",
    fill = "item"
  ) +
  theme_minimal()+
  facet_grid(~item.f)+
  xlim(6,-6)+
    scale_fill_manual(values = custom_Amounts_color)

Distance_Prob.cleanup<-Distance_Prob%>%
  separate(timing, into = c("drag_time", "drop_time"), sep = ", ", convert = TRUE)%>%
  mutate(distance_49=current_49-last_49,
         distance_50=current_50-last_50,
         distance_64=current_64-last_64,
         distance_65=current_65-last_65,
         distance_67=current_67-last_67,
         distance_68=current_68-last_68,
         DD_diff=drop_time-drag_time,
         condition="Amount")%>%
  select(drag_time,DD_diff,distance_49,distance_50,distance_64,distance_65,distance_67,distance_68,order,item.f,step,ResponseId,condition)

Distance_Prob.cleanup<-Distance_Prob.cleanup%>%
  group_by(ResponseId)%>%
  arrange(step)%>%
  filter(!duplicated(item.f))%>%
  ungroup()

unique_ResponseIds_Prob <- Distance_Prob %>%
  distinct(ResponseId) %>%
  pull(ResponseId) # Extract as a vector


Distance_Prob.cleanup.df <- expand.grid(ResponseId = unique_ResponseIds_Prob,
                                    item.f = c("Pr6_Amt1","Pr5_Amt2","Pr4_Amt3","Pr3_Amt4","Pr2_Amt5", "Pr1_Amt6"))




Distance_Prob.cleanup.df<-Distance_Prob.cleanup.df%>%
  left_join(Distance_Prob.cleanup%>%select(ResponseId,item.f,distance_49,distance_50,distance_64,distance_65,distance_67,distance_68,drag_time,DD_diff),by=c("ResponseId","item.f"))




Distance_Prob.cleanup.df<-Distance_Prob.cleanup.df%>%
  arrange(ResponseId)%>%
  mutate(distance=case_when(item.f=="Pr6_Amt1" ~ distance_49,
                            item.f=="Pr5_Amt2" ~ distance_50,
                            item.f=="Pr4_Amt3" ~ distance_64,
                            item.f=="Pr3_Amt4" ~ distance_65,
                            item.f=="Pr2_Amt5" ~ distance_67,
                            item.f=="Pr1_Amt6" ~ distance_68,
                            ),
         distance=case_when(is.na(distance)~0, # items that are not moved get a distance of 0
                            TRUE ~ distance),
         distance.abs=abs(distance))

summary_stats <- Distance_Prob.cleanup.df %>%
  group_by(item.f) %>%
  summarize(
    mean_distance = mean(distance, na.rm = TRUE),
    median_distance = median(distance, na.rm = TRUE)
  )



custom_colors_Prob <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

 Distance_Prob.cleanup.df$item.f<- factor(Distance_Prob.cleanup.df$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)

ggplot(Distance_Prob.cleanup.df ,
       aes(x = -distance, fill = item.f)) +
  geom_histogram(binwidth = 1, alpha = 0.3, position = "identity") +
  labs(
    title = "Distribution of Drag Distance - Prob Task",
    x = "Distance",
    y = "Count",
    fill = "item"
  ) +
  theme_minimal()+
  facet_grid(~item.f)+
    scale_fill_manual(values = custom_colors_Prob)+
  xlim(6,-6)

2.3.2 Model-Free Visualization

Distance_Amount_cleanup.df.test<-Distance_Amount.cleanup.df%>%
  select(ResponseId, item.f,distance,distance.abs)%>%
  mutate(condition="Amount")
Distance_Prob_cleanup.df.test<-Distance_Prob.cleanup.df%>%
  select(ResponseId, item.f,distance,distance.abs)%>%
  mutate(condition="Prob")

Distance_cleanup.df.combined<-rbind(Distance_Amount_cleanup.df.test,Distance_Prob_cleanup.df.test)

summary_distance_data <- Distance_cleanup.df.combined %>%
  mutate(condition=as.factor(condition),
         distance.abs=(distance))%>%
  group_by(condition, item.f) %>%
  summarize(
    distance_mean = -mean(distance, na.rm = TRUE),
    distance_sd = sd(distance, na.rm = TRUE),
    n = n(),
    se = distance_sd / sqrt(n),
    .groups = "drop"
  )



custom_colors_Amount <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)



summary_data_combined_ind$item.f = factor(summary_data_combined_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)


ggplot(summary_distance_data, aes(x = condition, y = distance_mean, group = item.f, color = item.f,shape=item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = distance_mean - se,
      ymax = distance_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Distance",
    title = "Mean Drag Distance by Condition"
  ) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )+
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
    scale_color_manual(values = custom_colors_Amount)

• If we plot the ABSOLUTE VALUE of Distance:

summary_distance_data <- Distance_cleanup.df.combined %>%
  mutate(condition=as.factor(condition),
         distance.abs=abs(distance))%>%
  group_by(condition, item.f) %>%
  summarize(
    distance_mean = mean(distance.abs, na.rm = TRUE),
    distance_sd = sd(distance.abs, na.rm = TRUE),
    n = n(),
    se = distance_sd / sqrt(n),
    .groups = "drop"
  )
custom_colors_Amount <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)



summary_data_combined_ind$item.f = factor(summary_data_combined_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)

ggplot(summary_distance_data, aes(x = condition, y = distance_mean, group = item.f, color = item.f,shape=item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = distance_mean - se,
      ymax = distance_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Order",
    title = "Mean Drag Order by Condition"
  ) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )+
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
    scale_color_manual(values = custom_colors_Amount)

2.3.3 Correlation with Attribute Values

Amount Task

• Aggregate Stats

Distance_Amount.cleanup.df<-Distance_Amount.cleanup.df%>%
    filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_amount%>%select(ResponseId,initial.items_49:initial.items_68),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6)
  )%>%
  select(-c(initial.items_49:initial.items_68))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))




summary_data_Amount <- Distance_Amount.cleanup.df%>%
  dplyr::group_by(item.f) %>%
  summarize(distance_mean = mean(distance, na.rm = TRUE),
            distance_sd = sd(distance, na.rm = TRUE),
            n = n(),
            se = distance_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))

• Model Specification: Drag Count predicted by Amount and Prob attribute rank
• Note: A negative sign was added to the distance DV. So a positive coefficient indicates that a higher value of the predictor contributes to the item being ranked further up

ggplot(summary_data_Amount, aes(x = Avg.Amount, y = -distance_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Distance and Amount Attribute", subtitle = "Amount Task", x = "Avg. Amt", y = "Avg. Drag Distance") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

ggplot(summary_data_Amount, aes(x = Avg.Prob, y = -distance_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Distance and Prob Attribute", subtitle = "Amount Task", x = "Avg. Prob", y = "Avg. Drag Distance") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

• Predict Drag Count (Indicator) with attribute ranks

M1<-lmer(-distance~Amt+Prob+(1|ResponseId),Distance_Amount.cleanup.df)
M2<-lmer(-distance~Amt+Prob+initial.rank+(1|ResponseId),Distance_Amount.cleanup.df)
M3<-lmer(-distance~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),Distance_Amount.cleanup.df)
tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank", "Prob Rank","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	1.30	0.79 – 1.80	<0.001	0.06	-0.34 – 0.47	0.762	0.06	-0.34 – 0.47	0.764
Amount Rank	0.03	0.02 – 0.04	<0.001	0.02	0.02 – 0.03	<0.001	0.02	0.02 – 0.03	<0.001
Prob Rank	-0.02	-0.03 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001
Initial Rank [1]				2.44	2.10 – 2.78	<0.001	2.44	2.09 – 2.78	<0.001
Initial Rank [2]				2.10	1.75 – 2.45	<0.001	2.10	1.75 – 2.45	<0.001
Initial Rank [3]				1.58	1.23 – 1.92	<0.001	1.58	1.23 – 1.92	<0.001
Initial Rank [4]				1.06	0.71 – 1.40	<0.001	1.06	0.71 – 1.40	<0.001
Initial Rank [5]				0.66	0.32 – 1.00	<0.001	0.66	0.32 – 1.00	<0.001
Random Effects
σ2	1.25			0.42			0.42
τ00	0.04 ResponseId			0.18 ResponseId			0.18 ResponseId
							0.00 item.f
ICC	0.03			0.30			0.30
N	28 ResponseId			28 ResponseId			28 ResponseId
							6 item.f
Observations	168			168			168
Marginal R2 / Conditional R2	0.459 / 0.476			0.747 / 0.823			0.746 / 0.823

# M1_robust <- lm_robust(-distance ~ rank.Amount + rank.Prob, data = Distance_Amount.cleanup.df, clusters = ResponseId)
# M2_robust <- lm_robust(-distance ~ rank.Amount + rank.Prob + initial.rank, data = Distance_Amount.cleanup.df, clusters = ResponseId)
# M3_robust <- lm_robust(-distance ~ rank.Amount + rank.Prob + initial.rank, data = Distance_Amount.cleanup.df, clusters = interaction(ResponseId, item.f))
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

Prob Task

• Aggregate Stats

Distance_Prob.cleanup.df<-Distance_Prob.cleanup.df%>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_prob%>%select(ResponseId,initial.items_64:initial.items_67),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6)
  )%>%
  select(-c(initial.items_64:initial.items_67))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))



summary_data_Prob <- Distance_Prob.cleanup.df%>%
  dplyr::group_by(item.f) %>%
  summarize(distance_mean = mean(distance, na.rm = TRUE),
            distance_sd = sd(distance, na.rm = TRUE),
            n = n(),
            se = distance_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))

ggplot(summary_data_Prob, aes(x = Avg.Amount, y = -distance_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Distance and Amount Attribute", subtitle = "Prob Task", x = "Avg. Amt", y = "Avg. Drag Distance") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

ggplot(summary_data_Prob, aes(x = Avg.Prob, y = -distance_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Distance and Prob Attribute", subtitle = "Prob Task", x = "Avg. Prob", y = "Avg. Drag Distance") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

M1<-lmer(-distance~Amt+Prob+(1|ResponseId),Distance_Prob.cleanup.df)
M2<-lmer(-distance~Amt+Prob+initial.rank+(1|ResponseId),Distance_Prob.cleanup.df)
M3<-lmer(-distance~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),Distance_Prob.cleanup.df)
tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank", "Prob Rank","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	0.98	0.44 – 1.52	<0.001	0.04	-0.42 – 0.49	0.875	0.03	-0.55 – 0.60	0.929
Amount Rank	-0.02	-0.03 – -0.01	0.003	-0.03	-0.03 – -0.02	<0.001	-0.02	-0.04 – -0.01	<0.001
Prob Rank	0.02	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001
Initial Rank [1]				2.42	2.04 – 2.80	<0.001	2.43	2.05 – 2.81	<0.001
Initial Rank [2]				1.78	1.40 – 2.16	<0.001	1.79	1.41 – 2.17	<0.001
Initial Rank [3]				1.37	0.98 – 1.76	<0.001	1.36	0.98 – 1.74	<0.001
Initial Rank [4]				0.79	0.41 – 1.17	<0.001	0.77	0.40 – 1.15	<0.001
Initial Rank [5]				0.49	0.11 – 0.87	0.012	0.48	0.10 – 0.86	0.013
Random Effects
σ2	1.27			0.50			0.48
τ00	0.16 ResponseId			0.30 ResponseId			0.30 ResponseId
							0.03 item.f
ICC	0.11			0.37			0.40
N	27 ResponseId			27 ResponseId			27 ResponseId
							6 item.f
Observations	162			162			162
Marginal R2 / Conditional R2	0.308 / 0.387			0.619 / 0.760			0.608 / 0.766

# M1_robust <- lm_robust(-distance ~ rank.Amount + rank.Prob, data = Distance_Prob.cleanup.df, clusters = ResponseId)
# M2_robust <- lm_robust(-distance ~ rank.Amount + rank.Prob + initial.rank, data = Distance_Prob.cleanup.df, clusters = ResponseId)
# M3_robust <- lm_robust(-distance ~ rank.Amount + rank.Prob + initial.rank, data = Distance_Prob.cleanup.df, clusters = interaction(ResponseId, item.f))
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

Model with Combined Datasets

• Amount and Prob Attribute Ranks are centered before being entered into the model.

Distance_Amount.cleanup.df$condition<-"Amount"
Distance_Prob.cleanup.df$condition<-"Prob"
Distance.cleanup.combined<-rbind(Distance_Amount.cleanup.df,Distance_Prob.cleanup.df)%>%
  mutate(Prob.c=Prob-mean(Prob),
         Amount.c=Amt-mean(Amt))


M1<-lmer(-distance~Amount.c*condition+Prob.c*condition+(1|ResponseId),Distance.cleanup.combined)
M2<-lmer(-distance~Amount.c*condition+Prob.c*condition+initial.rank+(1|ResponseId),Distance.cleanup.combined)
M3<-lmer(-distance~Amount.c*condition+Prob.c*condition+initial.rank+(1|ResponseId)+(1|item.f),Distance.cleanup.combined)

tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank","Condition [Prob]","Prob Rank", "Amount Rank x Condition [Prob]","Prob Rank x Condition [Prob]", "Ini. Rank [1]","Ini. Rank [2]","Ini. Rank [3]","Ini. Rank [4]","Ini. Rank [5]"), dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	1.21	1.01 – 1.41	<0.001	-0.03	-0.29 – 0.23	0.833	-0.03	-0.29 – 0.23	0.833
Amount Rank	0.03	0.02 – 0.04	<0.001	0.02	0.02 – 0.03	<0.001	0.02	0.02 – 0.03	<0.001
Condition [Prob]	-0.07	-0.32 – 0.17	0.550	-0.06	-0.22 – 0.10	0.484	-0.06	-0.22 – 0.10	0.484
Prob Rank	-0.02	-0.03 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001
Amount Rank x Condition [Prob]	-0.05	-0.06 – -0.03	<0.001	-0.05	-0.06 – -0.04	<0.001	-0.05	-0.06 – -0.04	<0.001
Prob Rank x Condition [Prob]	0.03	0.02 – 0.05	<0.001	0.03	0.03 – 0.04	<0.001	0.03	0.03 – 0.04	<0.001
Ini. Rank [1]				2.43	2.15 – 2.70	<0.001	2.43	2.15 – 2.70	<0.001
Ini. Rank [2]				1.94	1.66 – 2.22	<0.001	1.94	1.66 – 2.22	<0.001
Ini. Rank [3]				1.47	1.20 – 1.75	<0.001	1.47	1.20 – 1.75	<0.001
Ini. Rank [4]				0.93	0.65 – 1.20	<0.001	0.93	0.65 – 1.20	<0.001
Ini. Rank [5]				0.58	0.30 – 0.85	<0.001	0.58	0.30 – 0.85	<0.001
Random Effects
σ2	1.27			0.54			0.54
τ00	0.09 ResponseId			0.17 ResponseId			0.17 ResponseId
							0.00 item.f
ICC	0.07			0.24
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.389 / 0.429			0.686 / 0.760			0.741 / NA

# Robustness check: consistent
# M1_robust <- lm_robust(-distance~rank.Amount.c*condition+rank.Prob.c*condition,Distance.cleanup.combined, clusters = ResponseId)
# M2_robust <- lm_robust(-distance ~ rank.Amount.c*condition+rank.Prob.c*condition+initial.rank, data = Distance.cleanup.combined, clusters = ResponseId)
# M3_robust <- lm_robust(-distance ~ rank.Amount.c*condition+rank.Prob.c*condition+initial.rank, data = Distance.cleanup.combined, clusters = interaction(ResponseId, item.f))
# 
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

• Collinearity Check

  • Caution: The following preliminary tests assume independent observations and do not account for the multi-level structure of the data. Neds to dig in more.

  • VIF > 5 suggests high multicollinearity. Pass

  • GVIF extends VIF for categorical predictors. typically interpreted using GVIF^(1/(2×df)) < 2 as a guideline. Pass

M1_lm<-lm(-distance~Amount.c*condition+Prob.c*condition,Distance.cleanup.combined)
M2_lm<-lm(-distance~Amount.c*condition+Prob.c*condition+initial.rank,Distance.cleanup.combined)

print("Model w/o ini. position")

## [1] "Model w/o ini. position"

vif_M1 <- car::vif(M1_lm)
vif_M1

##           Amount.c          condition             Prob.c Amount.c:condition 
##           3.784398           1.000028           3.844015           3.802994 
##   condition:Prob.c 
##           3.862643

print("Model w/ ini. position")

## [1] "Model w/ ini. position"

vif_M2 <- car::vif(M2_lm)
vif_M2

##                        GVIF Df GVIF^(1/(2*Df))
## Amount.c           3.804673  1        1.950557
## condition          1.000028  1        1.000014
## Prob.c             3.891442  1        1.972674
## initial.rank       1.051011  5        1.004988
## Amount.c:condition 3.850733  1        1.962328
## condition:Prob.c   3.894833  1        1.973533

Nested Models

##### Nested Model
Distance.cleanup.combined<-Distance.cleanup.combined%>%
  mutate(Amt.Nested_Amount=case_when(
    condition == "Amount" ~Amt,
    condition == "Prob" ~ 0
  ),
  Amt.Nested_Prob=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Amt
  ),
  Prob.Nested_Amount=case_when(
    condition == "Amount" ~Prob,
    condition == "Prob" ~ 0
  ),
  Prob.Nested_Prob=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Prob
  ),
  Amt.Nested_Amount.c=case_when(
    condition == "Amount" ~Amount.c,
    condition == "Prob" ~ 0
  ),
  Amt.Nested_Prob.c=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Amount.c
  ),
  Prob.Nested_Amount.c=case_when(
    condition == "Amount" ~ Prob.c,
    condition == "Prob" ~ 0
  ),
  Prob.Nested_Prob.c=case_when(
    condition == "Amount" ~ 0,
    condition == "Prob" ~ Prob.c
  ))

M1<-lmer(-distance~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+(1|ResponseId),Distance.cleanup.combined)
M2<-lmer(-distance~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+(1|ResponseId),Distance.cleanup.combined)
M3<-lmer(-distance~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+(1|ResponseId)+(1|item.f),Distance.cleanup.combined)


tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank [Nested in Amount]","Amount Rank [Nested in Prob]","Prob Rank [Nested in Amount]","Prob Rank [Nested in Prob]","Condition [Prob]", "Ini. Rank [1]","Ini. Rank [2]","Ini. Rank [3]","Ini. Rank [4]","Ini. Rank [5]"), dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	1.21	1.01 – 1.41	<0.001	-0.03	-0.29 – 0.23	0.833	-0.03	-0.29 – 0.23	0.833
Amount Rank [Nested in Amount]	0.03	0.02 – 0.04	<0.001	0.02	0.02 – 0.03	<0.001	0.02	0.02 – 0.03	<0.001
Amount Rank [Nested in Prob]	-0.02	-0.03 – -0.01	0.003	-0.03	-0.03 – -0.02	<0.001	-0.03	-0.03 – -0.02	<0.001
Prob Rank [Nested in Amount]	-0.02	-0.03 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001	-0.02	-0.02 – -0.01	<0.001
Prob Rank [Nested in Prob]	0.02	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001	0.01	0.01 – 0.02	<0.001
Condition [Prob]	-0.07	-0.32 – 0.17	0.550	-0.06	-0.22 – 0.10	0.484	-0.06	-0.22 – 0.10	0.484
Ini. Rank [1]				2.43	2.15 – 2.70	<0.001	2.43	2.15 – 2.70	<0.001
Ini. Rank [2]				1.94	1.66 – 2.22	<0.001	1.94	1.66 – 2.22	<0.001
Ini. Rank [3]				1.47	1.20 – 1.75	<0.001	1.47	1.20 – 1.75	<0.001
Ini. Rank [4]				0.93	0.65 – 1.20	<0.001	0.93	0.65 – 1.20	<0.001
Ini. Rank [5]				0.58	0.30 – 0.85	<0.001	0.58	0.30 – 0.85	<0.001
Random Effects
σ2	1.27			0.54			0.54
τ00	0.09 ResponseId			0.17 ResponseId			0.17 ResponseId
							0.00 item.f
ICC	0.07			0.24
N	29 ResponseId			29 ResponseId			29 ResponseId
							6 item.f
Observations	330			330			330
Marginal R2 / Conditional R2	0.389 / 0.429			0.686 / 0.760			0.741 / NA

# M_robust <- lm_robust(-distance~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank+item.f,Distance.cleanup.combined, clusters = ResponseId)
# tab_model(M_robust)

• Collinearity Check

M1_lm<-lm(distance~Amt.Nested_Amount+Amt.Nested_Prob+Prob.Nested_Amount+Prob.Nested_Prob+condition+initial.rank,Distance.cleanup.combined)
M1_lm.2<-lm(distance~Amt.Nested_Amount.c+Amt.Nested_Prob.c+Prob.Nested_Amount.c+Prob.Nested_Prob.c+condition+initial.rank,Distance.cleanup.combined)

print("Nested Variable w/ Mean Centered values")

## [1] "Nested Variable w/ Mean Centered values"

Vif_M1.2 <- car::vif(M1_lm.2)
Vif_M1.2

##                          GVIF Df GVIF^(1/(2*Df))
## Amt.Nested_Amount.c  1.961926  1        1.400688
## Amt.Nested_Prob.c    2.014593  1        1.419364
## Prob.Nested_Amount.c 1.975531  1        1.405536
## Prob.Nested_Prob.c   1.993983  1        1.412085
## condition            1.000028  1        1.000014
## initial.rank         1.051011  5        1.004988

print("Nested Variable w raw values")

## [1] "Nested Variable w raw values"

vif_M1 <- car::vif(M1_lm)
vif_M1

##                        GVIF Df GVIF^(1/(2*Df))
## Amt.Nested_Amount  2.986549  1        1.728163
## Amt.Nested_Prob    3.112660  1        1.764273
## Prob.Nested_Amount 3.168903  1        1.780141
## Prob.Nested_Prob   3.248764  1        1.802433
## condition          8.738075  1        2.956023
## initial.rank       1.051011  5        1.004988

2.4 Correlation Between Measures

• Note on Coding: Drag count, order, and distance variables are coded such that greater values indicator drag and dropped more often, first, and further up.
  • Drag_Count: An indicator variable for whether an item is dragged and dropped
  • Order (coded so that the sign is flipped (adding a negative value)): greater value means dragged and dropped ealier
  • Distance: greater value means dragged and dropped further (up)
• Feel free to pause for a second to think about what to expect…

Amount Task

Distance_Amount.cleanup.df$item.f<-factor(Distance_Amount.cleanup.df$item.f,ordered = F)
Correlation.examine_Amount<-drag_and_drop_count_Amount_long%>%
  left_join(touch_order_analysis.long_Amount%>%select(ResponseId,order,item.f),by=c("ResponseId","item.f"))%>%
  left_join(Distance_Amount.cleanup.df%>%select(ResponseId,distance,item.f),by=c("ResponseId","item.f"))%>%
  mutate(Drag_Count.Ind=N_ind,
         order=-order,
         distance=-distance)

• Ploting below the the correlation between drag measures by item.

• Here is a summary plot

#--- Define a function to extract correlations for a given item ---#
get_item_correlations <- function(item_name) {
  # Filter data for the current item
  df_item <- Correlation.examine_Amount %>% filter(item.f == item_name)

  # Compute correlations: OC (Order ~ Drag_Count.Ind), OD (Order ~ Distance), CD (Drag_Count.Ind ~ Distance)
  oc_test <- cor.test(df_item$order, df_item$Drag_Count.Ind)
  od_test <- cor.test(df_item$order, df_item$distance)
  cd_test <- cor.test(df_item$Drag_Count.Ind, df_item$distance)

  # Create a tibble summarizing the results for this item
  tibble(
    item = item_name,
    measure = c("OC", "OD", "CD"),
    correlation = c(oc_test$estimate, od_test$estimate, cd_test$estimate),
    p_value = c(oc_test$p.value, od_test$p.value, cd_test$p.value)
  )
}


items <- c("Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")

results <- map_df(items, get_item_correlations) %>%
  mutate(
    # Convert item to factor and manually set levels based on numeric order
    item = as.factor(item),
    item = factor(item, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE),
    correlation = round(correlation, 2),
    p_value = round(p_value, 3),
    signif = if_else(p_value < 0.05, "Significant", "Not Significant")
    )%>%
mutate(Correlation = case_when(
      measure=="OC" ~ "Drag Order & Count",
      measure=="OD" ~ "Drag Order &  Distance",
      measure=="CD" ~ "Drag Count  &  Distance"))

custom_colors <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)


Amount_p2<-ggplot(results, aes(x = Correlation, y = correlation, group = item, color = item, shape = signif)) +
  geom_line(size = 1) +
  geom_point(size = 4) +
  theme_minimal() +
  labs(
    title = "Correlation Between Drag Measures by Item",
    x = "Variables",
    y = "Correlation Coefficient",
    color = "Item",
    shape = "Significance (<.05)"
  ) +
  scale_color_manual(values = custom_colors)+
    theme(
    axis.title.x = element_text(size = 16, face = "bold"),  # Bold and increase x-axis title
    axis.text.x = element_text(size = 14, face = "bold")    # Bold and increase x-axis text
  )

Amount_p2

• Pr6_Amt1

ggpairs(Correlation.examine_Amount%>%filter(item.f=="Pr6_Amt1"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr5_Amt2

ggpairs(Correlation.examine_Amount%>%filter(item.f=="Pr5_Amt2"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr4_Amt3

ggpairs(Correlation.examine_Amount%>%filter(item.f=="Pr4_Amt3"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr3_Amt4

ggpairs(Correlation.examine_Amount%>%filter(item.f=="Pr3_Amt4"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr2_Amt5

ggpairs(Correlation.examine_Amount%>%filter(item.f=="Pr2_Amt5"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr1_Amt6

ggpairs(Correlation.examine_Amount%>%filter(item.f=="Pr1_Amt6"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

Prob Task

Distance_Prob.cleanup.df$item.f<-factor(Distance_Prob.cleanup.df$item.f,ordered = F)
Correlation.examine_Prob<-drag_and_drop_count_Prob_long%>%
  left_join(touch_order_analysis.long_Prob%>%select(ResponseId,order,item.f),by=c("ResponseId","item.f"))%>%
  left_join(Distance_Prob.cleanup.df%>%select(ResponseId,distance,item.f),by=c("ResponseId","item.f"))%>%
  mutate(Drag_Count.Ind=N_ind,
         order=-order,
         distance=-distance)

• Plotting below the the correlation between drag measures by item.

• Here is a summary plot

#--- Define a function to extract correlations for a given item ---#
get_item_correlations <- function(item_name) {
  # Filter data for the current item
  df_item <- Correlation.examine_Prob %>% filter(item.f == item_name)

  # Compute correlations: OC (Order ~ Drag_Count.Ind), OD (Order ~ Distance), CD (Drag_Count.Ind ~ Distance)
  oc_test <- cor.test(df_item$order, df_item$Drag_Count.Ind)
  od_test <- cor.test(df_item$order, df_item$distance)
  cd_test <- cor.test(df_item$Drag_Count.Ind, df_item$distance)

  # Create a tibble summarizing the results for this item
  tibble(
    item = item_name,
    measure = c("OC", "OD", "CD"),
    correlation = c(oc_test$estimate, od_test$estimate, cd_test$estimate),
    p_value = c(oc_test$p.value, od_test$p.value, cd_test$p.value)
  )
}

items <- c("Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")

results <- map_df(items, get_item_correlations) %>%
  mutate(
    # Convert item to factor and manually set levels based on numeric order
    item = as.factor(item),
    item = factor(item, levels = rev(c("Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE),
    correlation = round(correlation, 2),
    p_value = round(p_value, 3),
    signif = if_else(p_value < 0.05, "Significant", "Not Significant")
    )%>%
mutate(Correlation = case_when(
      measure=="OC" ~ "Drag Order & Count",
      measure=="OD" ~ "Drag Order &  Distance",
      measure=="CD" ~ "Drag Count  &  Distance"))

custom_colors <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

Prob<-ggplot(results, aes(x = Correlation, y = correlation, group = item, color = item, shape = signif)) +
  geom_line(size = 1) +
  geom_point(size = 4) +
  theme_minimal() +
  labs(
    title = "Correlation Between Drag Measures by Item",
    x = "Variables",
    y = "Correlation Coefficient",
    color = "Item",
    shape = "Significance (<.05)"
  ) +
  scale_color_manual(values = custom_colors)+
    theme(
    axis.title.x = element_text(size = 16, face = "bold"),  # Bold and increase x-axis title
    axis.text.x = element_text(size = 14, face = "bold")    # Bold and increase x-axis text
  )
Prob

• Pr6_Amt1

ggpairs(Correlation.examine_Prob%>%filter(item.f=="Pr6_Amt1"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr5_Amt2

ggpairs(Correlation.examine_Prob%>%filter(item.f=="Pr5_Amt2"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr4_Amt3

ggpairs(Correlation.examine_Prob%>%filter(item.f=="Pr4_Amt3"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr3_Amt4

ggpairs(Correlation.examine_Prob%>%filter(item.f=="Pr3_Amt4"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr2_Amt5

ggpairs(Correlation.examine_Prob%>%filter(item.f=="Pr2_Amt5"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

• Pr1_Amt6

ggpairs(Correlation.examine_Prob%>%filter(item.f=="Pr1_Amt6"),
                   c("Drag_Count.Ind","order","distance"),
                   lower = list(continuous = wrap("points", position = position_jitter(height = 1, width = 0.2))),
                   diag = list(continuous = "density"))

2.5 Time Analysis

TimeAnalysis.Amount<-Distance_Amount%>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  separate(timing, into = c("drag_time", "drop_time"), sep = ", ", convert = TRUE)%>%
  mutate(DD_diff=drop_time-drag_time,
         condition="Amount")%>%
  select(step,ResponseId,condition,item.f,drag_time,drop_time,DD_diff,current_49:current_68)

duplicated.n<-nrow(TimeAnalysis.Amount)
item<-c("Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")


TimeAnalysis.Amount <- TimeAnalysis.Amount %>%
  uncount(weights = 6) 

TimeAnalysis.Amount$item.f<- rep(item, times = duplicated.n)
TimeAnalysis.Amount<-TimeAnalysis.Amount%>%
  mutate(current_rank=case_when(
    item.f=="Pr6_Amt1" ~ current_49,
    item.f=="Pr5_Amt2" ~ current_50,
    item.f=="Pr4_Amt3" ~ current_64,
    item.f=="Pr3_Amt4" ~ current_65,
    item.f=="Pr2_Amt5" ~ current_67,
    item.f=="Pr1_Amt6" ~ current_68
  ))%>%
  select(-c(current_49:current_68))

item_Amounts <- c("Pr6_Amt1" = "#1b9e77", "Pr5_Amt2" = "#d95f02", 
                 "Pr4_Amt3" = "#7570b3", "Pr3_Amt4" = "#e7298a", 
                 "Pr2_Amt5" = "#66a61e", "Pr1_Amt6" = "#e6ab02")

item_shapes <- c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                 "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                 "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)
# TimeAnalysis.Amount #one more step here to expand the dataset

TimeAnalysis.Amount.expand <- expand_grid(
  ResponseId = unique(TimeAnalysis.Amount$ResponseId),
  step = unique(TimeAnalysis.Amount$step),
  item.f = unique(TimeAnalysis.Amount$item.f)
) %>%
  left_join(
    TimeAnalysis.Amount %>% select(ResponseId, step, item.f, current_rank),
    by = c("ResponseId", "step", "item.f")
  ) %>%
  arrange(ResponseId, item.f, step) %>%
  group_by(ResponseId, item.f) %>%
  fill(current_rank, .direction = "down")%>%
  ungroup()


Summary.Amount <- TimeAnalysis.Amount.expand %>%
  group_by(step, item.f) %>%
  summarize(mean.current_rank = 7-mean(current_rank),
            sd.current_rank = sd(current_rank),
            n = n(),  
            se = sd.current_rank / sqrt(n),  
            .groups = "drop")



initial.rank<-touch_order_analysis.long_Amount%>%
  filter(ResponseId%in%Amount_NoneNeg_subj)%>%
  group_by(item.f)%>%
  mutate(initial.rank=as.numeric(initial.rank))%>%
  summarize(mean.current_rank = 7-mean(initial.rank),
            sd.current_rank = sd(initial.rank),
            n = n(),  
            se = sd.current_rank / sqrt(n),  
            .groups = "drop")%>%
  mutate(step=0)

Summary.Amount<-rbind(Summary.Amount,
                     initial.rank)

ggplot(Summary.Amount, aes(x = step, y = mean.current_rank, 
                          color = item.f,  shape = item.f)) +
  geom_line(size = 1) +  
  geom_point(size = 6, fill = "white") +  
  geom_errorbar(aes(ymin = mean.current_rank - se, ymax = mean.current_rank + se), 
                width = 0.3, size = 1.2, alpha = 0.8) + 
  scale_color_manual(values = item_Amounts) +  
  scale_shape_manual(values = item_shapes) +  
  labs(title = "Mean Rank by Step (Amount Task)",
       x = "Step",
       y = "Mean Rank",
       color = "Item",
       linetype = "Item",
       shape = "Item") +
  theme_minimal() +  # Clean theme
  theme(legend.position = "right",
    axis.title.x = element_text(face = "bold", size = 14),  # Bold x-axis label
    axis.title.y = element_text(face = "bold", size = 14),  # Bold y-axis label
    axis.text.x = element_text(face = "bold", size = 12),   # Bold x-axis text
    axis.text.y = element_text(face = "bold", size = 12)    # Bold y-axis text
  )+
  scale_y_continuous(breaks = 6:1) +
  scale_x_continuous(breaks = 0:6) 

# this dataset contains observation of items being moved multiple times!
TimeAnalysis.Prob<-Distance_Prob%>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  separate(timing, into = c("drag_time", "drop_time"), sep = ", ", convert = TRUE)%>%
  mutate(DD_diff=drop_time-drag_time,
         condition="Prob")%>%
  select(step,ResponseId,condition,item.f,drag_time,drop_time,DD_diff,current_49:current_68)

duplicated.n<-nrow(TimeAnalysis.Prob)
item<-c("Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")

TimeAnalysis.Prob <- TimeAnalysis.Prob %>%
  uncount(weights = 6) 
TimeAnalysis.Prob$item.f<- rep(item, times = duplicated.n)

TimeAnalysis.Prob<-TimeAnalysis.Prob%>%
  mutate(current_rank=case_when(
    item.f=="Pr6_Amt1" ~ current_49,
    item.f=="Pr5_Amt2" ~ current_50,
    item.f=="Pr4_Amt3" ~ current_64,
    item.f=="Pr3_Amt4" ~ current_65,
    item.f=="Pr2_Amt5" ~ current_67,
    item.f=="Pr1_Amt6" ~ current_68
  ))%>%
  select(-c(current_49:current_68))

item_Amounts <- c("Pr6_Amt1" = "#1b9e77", "Pr5_Amt2" = "#d95f02", 
                 "Pr4_Amt3" = "#7570b3", "Pr3_Amt4" = "#e7298a", 
                 "Pr2_Amt5" = "#66a61e", "Pr1_Amt6" = "#e6ab02")

item_shapes <- c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                 "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                 "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)

TimeAnalysis.Prob.expand <- expand_grid(
  ResponseId = unique(TimeAnalysis.Prob$ResponseId),
  step = unique(TimeAnalysis.Prob$step),
  item.f = unique(TimeAnalysis.Prob$item.f)
) %>%
  left_join(
    TimeAnalysis.Prob %>% select(ResponseId, step, item.f, current_rank),
    by = c("ResponseId", "step", "item.f")
  ) %>%
  arrange(ResponseId, item.f, step) %>%
  group_by(ResponseId, item.f) %>%
  fill(current_rank, .direction = "down")%>%
  ungroup()


Summary.Prob <- TimeAnalysis.Prob.expand %>%
  group_by(step, item.f) %>%
  summarize(mean.current_rank = 7-mean(current_rank),
            sd.current_rank = sd(current_rank),
            n = n(),  
            se = sd.current_rank / sqrt(n),  
            .groups = "drop")


initial.rank<-touch_order_analysis.long_Prob%>%
  filter(ResponseId%in%Prob_NoneNeg_subj)%>%
  group_by(item.f)%>%
  mutate(initial.rank=as.numeric(initial.rank))%>%
  summarize(mean.current_rank = 7- mean(initial.rank),
            sd.current_rank = sd(initial.rank),
            n = n(),  
            se = sd.current_rank / sqrt(n),  
            .groups = "drop")%>%
  mutate(step=0)

Summary.Prob<-rbind(Summary.Prob,
                     initial.rank)

ggplot(Summary.Prob, aes(x = step, y = mean.current_rank, 
                          color = item.f,  shape = item.f)) +
  geom_line(size = 1) +  
  geom_point(size = 6, fill = "white") +  
  geom_errorbar(aes(ymin = mean.current_rank - se, ymax = mean.current_rank + se), 
                width = 0.3, size = 1.2, alpha = 0.8) + 
  scale_color_manual(values = item_Amounts) +  
  scale_shape_manual(values = item_shapes) +  
  labs(title = "Mean Rank by Step (Prob Task)",
       x = "Step",
       y = "Mean Rank",
       color = "Item",
       linetype = "Item",
       shape = "Item") +
  theme_minimal() +  # Clean theme
  theme(legend.position = "right",
    axis.title.x = element_text(face = "bold", size = 14),  # Bold x-axis label
    axis.title.y = element_text(face = "bold", size = 14),  # Bold y-axis label
    axis.text.x = element_text(face = "bold", size = 12),   # Bold x-axis text
    axis.text.y = element_text(face = "bold", size = 12)    # Bold y-axis text
  )+
  scale_y_continuous(breaks = 6:1) +
  scale_x_continuous(breaks = 0:6) 

3. Preference Analysis

• Rank by how much you would like to play each lottery

3.1 1ST Preference Task

Need a section that explores objetcive rank here before digging into DROPT data * What is the overall pattern? (mean and spread) * do people rank lotteries differently? * are preferences stable across the 2 ranking tasks?

rank_data <- dat %>%
  select(
    ResponseId,
    `49` = rank_Pref1_49,
    `50` = rank_Pref1_50,
    `64` = rank_Pref1_64,
    `65` = rank_Pref1_65,
    `67` = rank_Pref1_67,
    `68` = rank_Pref1_68
  ) %>%
  pivot_longer(
    -ResponseId,  # keep ResponseId fixed
    names_to = "item_moved",
    values_to = "Subj_rank"
  ) %>%
  mutate(
    item_moved = as.integer(item_moved),
    item_label = case_when(
      item_moved == 49 ~ "Pr6_Amt1",
      item_moved == 50 ~ "Pr5_Amt2",
      item_moved == 64 ~ "Pr4_Amt3",
      item_moved == 65 ~ "Pr3_Amt4",
      item_moved == 67 ~ "Pr2_Amt5",
      item_moved == 68 ~ "Pr1_Amt6"
    ),
    item_label = factor(item_label, levels = c("Pr6_Amt1", "Pr5_Amt2", "Pr4_Amt3", "Pr3_Amt4", "Pr2_Amt5", "Pr1_Amt6"))
  )

ggplot(rank_data, aes(x = item_label, y = 7 - Subj_rank)) +  # Reverse code: 6 = top rank
  geom_violin(trim = FALSE, fill = "lightblue", color = "darkblue", alpha = 0.5) +
  geom_jitter(width = 0.15, height = 0, alpha = 0.6, size = 1.5, color = "black") +
  stat_summary(fun = mean, geom = "point", shape = 21, size = 3, fill = "red", color = "red") +
  labs(
    title = "Distribution of Pref1 Ranks by Item",
    x = "Item",
    y = "Rank (6 = Top)"
  ) +
  scale_y_continuous(breaks = 1:6, limits = c(1, 6)) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

### The following focuses on quizes A and B, the two quizes with focal items

RankProcess_Prefer1<-dat%>%
  select(ResponseId,RankProcess_Prefer1)%>%
  separate_rows(RankProcess_Prefer1, sep = "}") %>% #separate data into long format... 
  mutate(RankProcess_Prefer1 = gsub("[{}]", "", RankProcess_Prefer1))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_Prefer1!="")%>% # an empty obs is generated for each subject, removed
  separate(RankProcess_Prefer1, into = c("timing", "order"), sep = ";")%>%
# RankProcess%>%
#   filter(is.na(order)) #none
  group_by(ResponseId)%>%
  mutate(step=row_number()-1)%>% # first row records the initial position of items.
  select(step,everything())%>%
  ungroup()

### Check order column format ###

#### RankProcess Check #####
RankProcess_Prefer1$order <- trimws(RankProcess_Prefer1$order)
is_valid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Prefer1$order)
bug_respondent_Prefer1 <- RankProcess_Prefer1 %>%
  filter(!is_valid) %>%
  pull(ResponseId)# exclude 0 respondent with incorrect format data.

# RankProcess_A%>%
#   filter(ResponseId=="R_61SsQv6Vz0cWHQt") # this respondent has a duplicated row; needs to be removed; we tentatively remove this respondent entirely. But perhaps we only need to remove the duplicate row?

RankProcess_Prefer1<-RankProcess_Prefer1%>%
  filter(!ResponseId %in% c(bug_respondent_Prefer1)) # remove data from respondents with NA item_moved columns entirely. - Other Data Recording Issue
#### RankProcess Check DONE #####

#### Done Addressing Incorrect Data Recording ####


RankProcess_all_Prefer1<-dat%>%
  select(ResponseId,RankProcess_all_Prefer1)%>%
  separate_rows(RankProcess_all_Prefer1, sep = "}") %>%
  mutate(RankProcess_all_Prefer1 = gsub("[{}]", "", RankProcess_all_Prefer1))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_all_Prefer1!="")%>%
  separate(RankProcess_all_Prefer1, into = c("timing", "order_all"), sep = ";")


RankProcess_Prefer1<-RankProcess_Prefer1%>%
  left_join(RankProcess_all_Prefer1,by=c("ResponseId","timing"))%>%
  mutate(item_moved= sub(",.*", "", order_all))%>% # # Retain only the value before the first comma. This is because the we are asking JavaScript to capture the order at the moment of mousedown, with RankProcess_all, prior to Qualtrics fully integrating the order. Additionally, the moved item consistently appears first in the recorded sequence (tested with the "inspect" function), a feature we use to identify the item taken. This behavior should be periodically checked to confirm if Qualtrics updates any underlying processes. # 10/25/2024 Xuwen.
  ungroup()%>%
  mutate(item_moved=as.numeric(item_moved),
         item.f=as.factor(case_when(
    item_moved==49 ~ "Pr6_Amt1",
    item_moved==50 ~ "Pr5_Amt2",
    item_moved==64 ~ "Pr4_Amt3",
    item_moved==65 ~ "Pr3_Amt4",
    item_moved==67 ~ "Pr2_Amt5",
    item_moved==68 ~ "Pr1_Amt6" # 2024/11/26; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature
  )))



#### Address Incorrect Data Recording ####

na_subj_Prefer1<-RankProcess_Prefer1%>%
  filter(is.na(item_moved))%>%
  pull(ResponseId)  # some respondents have missing item moved - menaing that there are items in  rank process that cannot be matched from Rank process all. This only occurs in rare cases and remove data from these responents.
# one participant identified

#### RankProcess ALL Check  #####
RankProcess_Prefer1$order_all <- trimws(RankProcess_Prefer1$order_all)
Invalid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Prefer1$order_all)
bug_respondent_Prefer1 <- RankProcess_Prefer1 %>%
  filter(Invalid & timing!=0) %>%
  pull(ResponseId)
#### RankProcess ALL Check DONE #####

RankProcess_Prefer1<-RankProcess_Prefer1%>%
  filter(!ResponseId %in% c(na_subj_Prefer1,bug_respondent_Prefer1))

# RankProcess_A%>%
#   filter(is.na(item_moved)) # order_all variable was somehow not recorded in these rows. 

drag_and_drop_count_Prefer1<-RankProcess_Prefer1%>%
  filter(step!=0)%>% # step=0 shows initial rank. Remove this.
  group_by(ResponseId)%>%
  summarize(item_49_moved.N=sum(item_moved==49),
            item_50_moved.N=sum(item_moved==50),
            item_64_moved.N=sum(item_moved==64),
            item_65_moved.N=sum(item_moved==65),
            item_67_moved.N=sum(item_moved==67),
            item_68_moved.N=sum(item_moved==68))%>%
  ungroup() 


### Data Wrangling for Drag distance - in order to identify data recording where a bug had appeared to occur ###

Distance_Prefer1<-RankProcess_Prefer1 %>%
  group_by(ResponseId)%>%
  mutate(
    # Split the string into parts based on commas
    parts = str_split(order, ",")
  ) %>%
  mutate(
    Rank1 = sapply(parts, function(x) x[1]),  # Extract before 1st comma
    Rank2 = sapply(parts, function(x) x[2]),  # Extract before 2nd comma
    Rank3 = sapply(parts, function(x) x[3]),  # Extract before 3rd comma
    Rank4 = sapply(parts, function(x) x[4]),  # Extract before 4th comma
    Rank5 = sapply(parts, function(x) x[5]),  # Extract before 5th comma
    Rank6 = sapply(parts, function(x) ifelse(length(x) > 5, x[6], NA))  # Extract after 5th comma
  ) %>%
  select(-parts)

items_Prefer1 <- c("49", "50", "64", "65", "67", "68")
for (item in items_Prefer1) {
  Distance_Prefer1[[paste0("current_", item)]] <- NA_integer_
}


Distance_Prefer1 <- Distance_Prefer1 %>%
  rowwise() %>%
  mutate(
    across(
      starts_with("current_"),
      ~ {
        item_number <- str_remove(cur_column(), "current_")  # Extract the item number
        case_when(
          Rank1 == item_number ~ 1,
          Rank2 == item_number ~ 2,
          Rank3 == item_number ~ 3,
          Rank4 == item_number ~ 4,
          Rank5 == item_number ~ 5,
          Rank6 == item_number ~ 6,
          TRUE ~ 1 # Distance_A %>% mutate(NA_count = rowSums(is.na(select(., starts_with("current_"))))); this code somehow results in the first item always gets an NA, so manually fix this error
        )
      }
    )
  ) %>%
  ungroup()

### No rows should have any repeated 1 in the "current_" columns ###
# Distance_A %>%
#   rowwise() %>%
#   mutate(
#     more_than_one_1 = sum(select(., starts_with("current_")) == 1, na.rm = TRUE) > 1
#   ) %>%
#   ungroup()%>%
#   filter(more_than_one_1) # NONE; good.


for (item in items_Prefer1) {
  Distance_Prefer1[[paste0("last_", item)]] <- lag(Distance_Prefer1[[paste0("current_", item)]])
}


Distance_Prefer1<-Distance_Prefer1%>%
  group_by(ResponseId)%>%
  rowwise() %>%
  mutate(
    current_item_moved = get(paste0("current_", item_moved)),  # Get the rank of the moved item from current columns
    last_item_moved = get(paste0("last_", item_moved)),        # Get the rank of the moved item from last columns
    # Determine the movement direction; we should not see any "no_change"
    move_direction = case_when(
      is.na(last_item_moved) ~ "no_change",  
      current_item_moved < last_item_moved ~ "up",
      current_item_moved > last_item_moved ~ "down",
      TRUE ~ "no_change"
    )
  ) %>%
  ungroup()


Distance_Prefer1 <- Distance_Prefer1 %>%
  group_by(ResponseId)%>%
  filter(step!=0) # need to retain step 0 for steps that come before

bug_respondent_Prefer1<-Distance_Prefer1%>%
  filter(move_direction=="no_change")%>%pull(ResponseId) # 0 respondent

# table(Distance_Prefer1$move_direction) 

drag_and_drop_count_Prefer1_long <- drag_and_drop_count_Prefer1 %>%
  pivot_longer(
    cols = starts_with("item_"),   # All columns starting with "item_"
    names_to = c("item_number", ".value"),  # Splits into item_number and value columns
    names_sep = "_moved."           # Splitting based on the "_moved." part
  )%>%
  mutate(
    condition = "Prefer 1ST",
    item_number = as.numeric(gsub("item_", "", item_number)), 
    item.f = as.factor(case_when(
    item_number==49 ~ "Pr6_Amt1",
    item_number==50 ~ "Pr5_Amt2",
    item_number==64 ~ "Pr4_Amt3",
    item_number==65 ~ "Pr3_Amt4",
    item_number==67 ~ "Pr2_Amt5",
    item_number==68 ~ "Pr1_Amt6"
    ))
  )

3.1.1 Drag Count

3.1.1.0 Distribution of Drag Count by item

drag_drop_counts_Prefer1 <- drag_and_drop_count_Prefer1_long %>%
  count(item.f,N) %>%
  group_by(item.f)%>%
  mutate(percentage = n / sum(n) * 100,
         condition="Amount")%>%
  ungroup()


ggplot(drag_drop_counts_Prefer1, aes(x = factor(N), y = n)) +
  geom_bar(
    stat = "identity",
    # aes(fill = ifelse(item.f %in% c("Carpool5", "WFH3"), "highlight", "default")),
    color = "black"
  ) +
  geom_text(
    aes(
      label = paste0(n, " (", round(percentage, 1), "%)")
      # color = ifelse(item.f %in% c("Carpool5", "WFH3"), "highlight", "default")
    ),
    vjust = -0.5,
    size = 5,
    fontface="bold"
  ) +
  # scale_fill_manual(
  #   values = c("highlight" = "darkorange", "default" = "grey"),
  #   guide = "none"
  # ) +
  # scale_color_manual(
  #   values = c("highlight" = "darkorange", "default" = "grey"),
  #   guide = "none"
  # ) +
  labs(
    title = "Drag Count by item and Quiz Condition",
    x = "Drag Count",
    y = "Frequency"
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(size = 12, face = "bold"),  # Increased size and bold text
    plot.title = element_text(hjust = 0.5),
    axis.title = element_text(size = 12),  # Adjust axis titles size if needed
    axis.text = element_text(size = 10)    # Adjust axis labels size if needed
  ) +
  facet_wrap(~ item.f,ncol=2) +
  ylim(0, 50)

3.1.1 Model-free visualization

• The following plot illustrates the mean and se of drag counts for each item, grouped by condition.

summary_data_Pefer1_ind<- drag_and_drop_count_Prefer1_long %>%
  mutate(N=case_when(
    N==0~0,
    TRUE~1
  ))%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(drag_drop_mean = mean(N, na.rm = TRUE),
            drag_drop_sd = sd(N, na.rm = TRUE),
            n = n(),
            se = drag_drop_sd / sqrt(n),
            .groups = "drop")

custom_colors_amount <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

summary_data_Pefer1_ind$item.f = factor(summary_data_Pefer1_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)


# Plot
ggplot(summary_data_Pefer1_ind, aes(x = condition, y = drag_drop_mean, 
                                      group = item.f, color = item.f, shape = item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = drag_drop_mean - se,
      ymax = drag_drop_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Count",
    title = "Mean Drag Count"
  ) +
  scale_color_manual(values = custom_colors_amount) +  
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )

3.1.3 Correlation with Attribute Values

• Note on attribute rank coding:
  • Across Amount and Prob Tasks, greater value indicates higher rank (i.e., 1=item in the bottom and 6=item at the top.)

dat_long <- dat %>%
  pivot_longer(
    cols = matches("Set1_L[1-6]_(Prob|Amt)"),
    names_to = c("lottery", ".value"),
    names_pattern = "Set1_(L[1-6])_(Prob|Amt)"
  ) %>%
  mutate(item.f = case_when(
    lottery == "L1" ~ "Pr6_Amt1",
    lottery == "L2" ~ "Pr5_Amt2",
    lottery == "L3" ~ "Pr4_Amt3",
    lottery == "L4" ~ "Pr3_Amt4",
    lottery == "L5" ~ "Pr2_Amt5",
    lottery == "L6" ~ "Pr1_Amt6"
  ))

drag_and_drop_count_Prefer1_long<-drag_and_drop_count_Prefer1_long%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_amount%>%select(ResponseId,initial.items_49:initial.items_68),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6),
  N_ind=case_when(
    N==0~0,
    TRUE~1)
  )%>%
  select(-c(initial.items_49:initial.items_68))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))

summary_data_Prefer1 <- drag_and_drop_count_Prefer1_long%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(drag_mean = mean(N_ind, na.rm = TRUE),
            drag_sd = sd(N_ind, na.rm = TRUE),
            n = n(),
            se = drag_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))

• Aggregate Stats

ggplot(summary_data_Prefer1, aes(x = Avg.Amount, y = drag_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Count and Amount Attribute", subtitle = "2ND Preference Task", x = "Avg. Amt", y = "Avg. Drag Count Indicator") +
  theme(axis.title = element_text(face = "bold"), 
        plot.subtitle = element_text(hjust = 0.5), 
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

ggplot(summary_data_Prefer1, aes(x = Avg.Prob, y = drag_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Count and Prob Attribute", subtitle = "1ST Preference Task", x = "Avg. Prob", y = "Avg. Drag Count Indicator") +
  theme(axis.title = element_text(face = "bold"), 
        plot.subtitle = element_text(hjust = 0.5), 
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

• Predict Drag Count (Indicator) with attribute ranks
  • Model Specification: Drag Count predicted by Amount and Prob attribute values
  • within each condition, still wondering if it makes sense to add item random effect control here… Xuwen reading this paper recommended by Antonia to learn more

M1<-glmer(N_ind~Amt+Prob+(1|ResponseId),drag_and_drop_count_Prefer1_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))
M2<-glmer(N_ind~Amt+Prob+initial.rank+(1|ResponseId),drag_and_drop_count_Prefer1_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))
M3<-glmer(N_ind~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),drag_and_drop_count_Prefer1_long,family=binomial,  control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))

tab_model(M1,M2,M3,transform = NULL,pred.labels = c("Intercept", "Amount", "Prob","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Log-Odds	CI	p	Log-Odds	CI	p	Log-Odds	CI	p
Intercept	0.92	0.00 – 1.84	0.049	0.87	-0.33 – 2.06	0.157	0.87	-0.33 – 2.06	0.157
Amount	-0.02	-0.05 – -0.00	0.031	-0.03	-0.05 – -0.00	0.029	-0.03	-0.05 – -0.00	0.029
Prob	-0.01	-0.02 – 0.01	0.364	-0.01	-0.02 – 0.01	0.370	-0.01	-0.02 – 0.01	0.370
Initial Rank [1]				0.62	-0.49 – 1.73	0.271	0.62	-0.49 – 1.73	0.271
Initial Rank [2]				0.22	-0.88 – 1.31	0.700	0.22	-0.88 – 1.31	0.700
Initial Rank [3]				-0.15	-1.22 – 0.92	0.783	-0.15	-1.22 – 0.92	0.783
Initial Rank [4]				-0.56	-1.64 – 0.53	0.313	-0.56	-1.64 – 0.53	0.313
Initial Rank [5]				0.35	-0.74 – 1.43	0.531	0.35	-0.74 – 1.43	0.531
Random Effects
σ2	3.29			3.29			3.29
τ00	0.00 ResponseId			0.00 ResponseId			0.00 ResponseId
							0.00 item.f
N	28 ResponseId			28 ResponseId			28 ResponseId
							6 item.f
Observations	168			168			168
Marginal R2 / Conditional R2	0.042 / NA			0.083 / NA			0.083 / NA

library(sandwich)
library(miceadds)
library(glmmML)

# test <- miceadds::glm.cluster( data=drag_and_drop_count_Color_long, formula=N_ind~rank.color+rank.Prob+initial.rank,
#                 cluster=c("ResponseId","item.f"), family="binomial")
# summary(test)

3.1.2 Drag Order

touch_order_analysis_Pref1<-RankProcess_Prefer1%>%
  filter(step!=0)%>%
  group_by(ResponseId)%>%
  arrange(step)%>%
  filter(!duplicated(item_moved))%>%
  mutate(order=row_number())%>%
  ungroup()%>%
  mutate(condition="Pref1")



touch_order_analysis.long_Prefer1 <- expand_grid(
  ResponseId = unique(touch_order_analysis_Pref1$ResponseId),
  item.f = unique(touch_order_analysis_Pref1$item.f)
)


order_max.SUBJ_Pref1<-touch_order_analysis.long_Prefer1%>%
  left_join(touch_order_analysis_Pref1%>%select(ResponseId,item.f,order),by=c("ResponseId","item.f"))%>%
  left_join(touch_order_analysis_Pref1%>%select(ResponseId,condition)%>%filter(!duplicated(ResponseId)),by=c("ResponseId"))%>%
  group_by(ResponseId)%>%
  summarize(max_order=max(order,na.rm = T))

touch_order_analysis.long_Pref1<-touch_order_analysis.long_Prefer1%>%
  left_join(touch_order_analysis_Pref1%>%select(ResponseId,item.f,order),by=c("ResponseId","item.f"))%>%
  left_join(touch_order_analysis_Pref1%>%select(ResponseId,condition)%>%filter(!duplicated(ResponseId)),by=c("ResponseId"))%>%left_join(order_max.SUBJ_Pref1,by="ResponseId")%>%
  mutate(order = case_when(!is.na(order)~order,
                           TRUE~max_order+1))

3.1.2.0 Distribution of Drag Order by item

touch_order_Pref1 <- touch_order_analysis.long_Pref1 %>%
  count(item.f,order,condition) %>%
  group_by(item.f)%>%
  mutate(percentage = n / sum(n) * 100)%>%
  ungroup()

ggplot(touch_order_Pref1, aes(x = factor(order), y = n)) +
  geom_bar(
    stat = "identity",
    color = "black"
  ) +
  geom_text(
    aes(
      label = paste0(n, " (", round(percentage, 1), "%)")
    ),
    vjust = -0.5,
    size = 5,
    fontface="bold"
  ) +
  labs(
    title = "Drag Order by item and Condition",
    x = "Drag Order",
    y = "Frequency"
  ) +
  theme_minimal() +
  theme(
    strip.text = element_text(size = 12, face = "bold"),  # Facet label adjustments
    plot.title = element_text(hjust = 0.5, face = "bold"),
    axis.title = element_text(size = 12),
    axis.text = element_text(size = 10)
  ) +
  facet_wrap(~ item.f ,ncol = 2) +
  ylim(0, 30)

3.1.2.0 (Descriptive Cont.) Distribution of Mean Drag Order

mean_order.subj_Pref1 <- touch_order_analysis.long_Pref1 %>%
  group_by(ResponseId)%>%
  mutate(mean_order = mean(order),
         condition="Pref1")%>%
  ungroup()
# mean_order.subj%>%
#   filter(is.na(mean_order)) # none, good
# drag_drop_counts%>%
#   group_by(item.f)%>%
#   summarise(subj_count=sum(n)) # all 389, good.

ggplot(mean_order.subj_Pref1, aes(x = mean_order)) +
  geom_density(fill = "lightblue", color = "black", alpha = 0.5) +
  geom_rug(sides = "b", color = "blue") +  # Rug plot along the bottom (x-axis) for individual data points
  labs(
    title = "Density Plot of Mean Drag Order",
    x = "Mean Drag Order",
    y = "Density"
  ) 

3.1.2.1 Model-free visualization

summary_data_Pref1<- touch_order_analysis.long_Pref1%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(order_mean = mean(order, na.rm = TRUE),
            order_sd = sd(order, na.rm = TRUE),
            n = n(),
            se = order_sd / sqrt(n),  # Standard error
            .groups = "drop")


custom_Amounts_color <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

summary_data_Pref1$item.f = factor(summary_data_Pref1$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)

ggplot(summary_data_Pref1, aes(x = condition, y = order_mean, 
                                      group = item.f, color = item.f, shape = item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = order_mean - se,
      ymax = order_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Order",
    title = "Mean Drag Order by Condition"
  ) +
  scale_color_manual(values = custom_Amounts_color) +  
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )

3.1.2.3 Correlation with Attribute Values

• Aggregate Stats

touch_order_analysis.long_Pref1<-touch_order_analysis.long_Pref1%>%
  mutate(rank.Amount=case_when(
    item.f=="Pr6_Amt1" ~1,
    item.f=="Pr5_Amt2" ~ 2,
    item.f== "Pr4_Amt3" ~ 3,
    item.f== "Pr3_Amt4" ~ 4,
    item.f == "Pr2_Amt5" ~ 5,
    item.f == "Pr1_Amt6" ~6
  ),
  rank.Prob=case_when(
    item.f=="Pr6_Amt1" ~6,
    item.f=="Pr5_Amt2" ~ 5,
    item.f== "Pr4_Amt3" ~ 4,
    item.f== "Pr3_Amt4" ~ 3,
    item.f == "Pr2_Amt5" ~ 2,
    item.f == "Pr1_Amt6" ~1))%>%
  left_join(initial.dat_amount%>%select(ResponseId,initial.items_49:initial.items_68),by="ResponseId")%>%
  mutate(initial.rank=case_when(
    item.f=="Pr6_Amt1" ~ initial.items_49,
    item.f=="Pr5_Amt2" ~ initial.items_50,
    item.f=="Pr4_Amt3" ~ initial.items_64,
    item.f=="Pr3_Amt4" ~ initial.items_65,
    item.f=="Pr2_Amt5" ~ initial.items_67,
    item.f=="Pr1_Amt6" ~ initial.items_68
  ),
  initial.rank=7-initial.rank,
  initial.rank = relevel(factor(initial.rank), ref = 6)
  )%>%
  select(-c(initial.items_49:initial.items_68))%>%
  left_join(dat_long%>%select(ResponseId,item.f,Prob,Amt),by=c("ResponseId","item.f"))


summary_data_Pref1 <- touch_order_analysis.long_Pref1%>%
  dplyr::group_by(condition, item.f) %>%
  summarize(order_mean = mean(order, na.rm = TRUE),
            order_sd = sd(order, na.rm = TRUE),
            n = n(),
            se = order_sd / sqrt(n),  # Standard error
            .groups = "drop",
            Avg.Amount=mean(Amt),
            Avg.Prob=mean(Prob))

ggplot(summary_data_Pref1, aes(x = Avg.Amount, y = order_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Order and Amount Attribute", subtitle = "1ST Preference Task", x = "Avg. Amt", y = "Avg. Drag Order") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed")

ggplot(summary_data_Pref1, aes(x = Avg.Prob, y = order_mean, label = item.f)) +
  geom_point(size = 3, color = "black") +
  geom_text(vjust = -1, hjust = 1) +
  theme_minimal() +
  labs(title = "Drag Order and Prob Attribute", subtitle = "1ST Preference Task", x = "Avg. Prob", y = "Avg. Drag Order") +
  theme(axis.title = element_text(face = "bold"),
        plot.subtitle = element_text(hjust = 0.5),
        plot.title = element_text(face = "bold", hjust = 0.5))+
  geom_smooth(method = "lm", se = FALSE, color = "blue", linetype = "dashed") 

• Predict Drag Order with attribute ranks

  • Model Specification: Drag Count predicted by Amount and Prob attribute values

  • Note: A negative sign was added to the order DV. So a positive coefficient indicates that a higher value of the predictor contributes to the item being ranked first

M1<-lmer(order~Amt+Prob+(1|ResponseId),touch_order_analysis.long_Pref1)
M2<-lmer(order~Amt+Prob+initial.rank+(1|ResponseId),touch_order_analysis.long_Pref1)
M3<-lmer(order~Amt+Prob+initial.rank+(1|ResponseId)+(1|item.f),touch_order_analysis.long_Pref1)
tab_model(M1,M2,M3,pred.labels = c("Intercept", "Amount Rank", "Prob Rank","Initial Rank [1]","Initial Rank [2]","Initial Rank [3]","Initial Rank [4]","Initial Rank [5]"),dv.labels = c("Subj. Random_eff","Add Ini. Position","Add Item Random_eff"))

	Subj. Random_eff			Add Ini. Position			Add Item Random_eff
Predictors	Estimates	CI	p	Estimates	CI	p	Estimates	CI	p
Intercept	3.32	2.70 – 3.93	<0.001	3.39	2.59 – 4.18	<0.001	3.39	2.59 – 4.18	<0.001
Amount Rank	-0.00	-0.02 – 0.01	0.540	-0.01	-0.02 – 0.01	0.495	-0.01	-0.02 – 0.01	0.495
Prob Rank	-0.01	-0.02 – 0.00	0.170	-0.01	-0.02 – 0.00	0.147	-0.01	-0.02 – 0.00	0.147
Initial Rank [1]				-0.36	-1.08 – 0.35	0.319	-0.36	-1.08 – 0.36	0.319
Initial Rank [2]				-0.21	-0.94 – 0.53	0.578	-0.21	-0.94 – 0.53	0.578
Initial Rank [3]				-0.02	-0.74 – 0.70	0.962	-0.02	-0.74 – 0.70	0.962
Initial Rank [4]				0.54	-0.18 – 1.26	0.138	0.54	-0.18 – 1.26	0.138
Initial Rank [5]				-0.23	-0.95 – 0.50	0.537	-0.23	-0.95 – 0.50	0.537
Random Effects
σ2	1.88			1.85			1.85
τ00	0.00 ResponseId			0.00 ResponseId			0.00 ResponseId
							0.00 item.f
N	28 ResponseId			28 ResponseId			28 ResponseId
							6 item.f
Observations	168			168			168
Marginal R2 / Conditional R2	0.013 / NA			0.056 / NA			0.056 / NA

# M1_robust <- lm_robust(-order ~ rank.Amount + rank.Prob, data = touch_order_analysis.long_Amount, clusters = ResponseId)
# M2_robust <- lm_robust(-order ~ rank.Amount + rank.Prob + initial.rank, data = touch_order_analysis.long_Amount, clusters = ResponseId)
# M3_robust <- lm_robust(-order ~ rank.Amount + rank.Prob + initial.rank, data = touch_order_analysis.long_Amount, clusters = interaction(ResponseId, item.f))
# tab_model(M1_robust, M2_robust, M3_robust,
#           pred.labels = c("Intercept", "Amount Rank", "Prob Rank", "Initial Rank [1]", "Initial Rank [2]", "Initial Rank [3]", "Initial Rank [4]", "Initial Rank [5]"),
#           dv.labels = c("Subj. Robust", "Add Ini. Position", "Add Item Robust"))

3.1.3 Drag Distance

3.1.3.0 Distribution of Drag Distance

# length(unique(Distance_Amount$ResponseId))
# table(Distance_Amount$move_direction)
# length(unique(Distance_Prob$ResponseId))
# table(Distance_Prob$move_direction)

Distance_Pref1.cleanup<-Distance_Prefer1%>%
  separate(timing, into = c("drag_time", "drop_time"), sep = ", ", convert = TRUE)%>%
  mutate(distance_49=current_49-last_49,
         distance_50=current_50-last_50,
         distance_64=current_64-last_64,
         distance_65=current_65-last_65,
         distance_67=current_67-last_67,
         distance_68=current_68-last_68,
         DD_diff=drop_time-drag_time,
         condition="Amount")%>%
  select(drag_time,DD_diff,distance_49,distance_50,distance_64,distance_65,distance_67,distance_68,order,item.f,step,ResponseId,condition)

Distance_Pref1.cleanup<-Distance_Pref1.cleanup%>%
  group_by(ResponseId)%>%
  arrange(step)%>%
  filter(!duplicated(item.f))%>%
  ungroup()

unique_ResponseIds_Pref1<- Distance_Prefer1 %>%
  distinct(ResponseId) %>%
  pull(ResponseId) # Extract as a vector





Distance_Pref1.cleanup.df <- expand.grid(ResponseId = unique_ResponseIds_Pref1,
                                    item.f = c("Pr6_Amt1","Pr5_Amt2","Pr4_Amt3","Pr3_Amt4","Pr2_Amt5", "Pr1_Amt6")) 


Distance_Pref1.cleanup.df<-Distance_Pref1.cleanup.df%>%
  left_join(Distance_Pref1.cleanup%>%select(ResponseId,item.f,distance_49,distance_50,distance_64,distance_65,distance_67,distance_68,drag_time,DD_diff),by=c("ResponseId","item.f"))



Distance_Pref1.cleanup.df<-Distance_Pref1.cleanup.df%>%
  arrange(ResponseId)%>%
  mutate(distance=case_when(item.f=="Pr6_Amt1" ~ distance_49,
                            item.f=="Pr5_Amt2" ~ distance_50,
                            item.f=="Pr4_Amt3" ~ distance_64,
                            item.f=="Pr3_Amt4" ~ distance_65,
                            item.f=="Pr2_Amt5" ~ distance_67,
                            item.f=="Pr1_Amt6" ~ distance_68,
                            ),
         distance=case_when(is.na(distance)~0, # items that are not moved get a distance of 0
                            TRUE ~ distance),
         distance.abs=abs(distance))

summary_stats <- Distance_Pref1.cleanup.df %>%
  group_by(item.f) %>%
  summarize(
    mean_distance = mean(distance, na.rm = TRUE),
    median_distance = median(distance, na.rm = TRUE)
  )

custom_Pref1s_color <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)

Distance_Pref1.cleanup.df$item.f<- factor(Distance_Pref1.cleanup.df$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)




ggplot(Distance_Pref1.cleanup.df ,
       aes(x = -distance, fill = item.f)) +
  geom_histogram(binwidth = 1, alpha = 0.3, position = "identity") +
  labs(
    title = "Distribution of Drag Distance - Pref1 Task",
    x = "Distance",
    y = "Count",
    fill = "item"
  ) +
  theme_minimal()+
  facet_grid(~item.f)+
  xlim(6,-6)+
    scale_fill_manual(values = custom_Pref1s_color)

3.1.3.1 Model-Free Visualization

Distance_Pref1_cleanup.df.test<-Distance_Pref1.cleanup.df%>%
  select(ResponseId, item.f,distance,distance.abs)%>%
  mutate(condition="Pref1")

summary_distance_data <- Distance_Pref1_cleanup.df.test %>%
  mutate(condition=as.factor(condition),
         distance.abs=(distance))%>%
  group_by(condition, item.f) %>%
  summarize(
    distance_mean = -mean(distance, na.rm = TRUE),
    distance_sd = sd(distance, na.rm = TRUE),
    n = n(),
    se = distance_sd / sqrt(n),
    .groups = "drop"
  )



custom_colors_Pref1 <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)



summary_data_combined_ind$item.f = factor(summary_data_combined_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)


ggplot(summary_distance_data, aes(x = condition, y = distance_mean, group = item.f, color = item.f,shape=item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = distance_mean - se,
      ymax = distance_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Distance",
    title = "Mean Drag Distance by Condition"
  ) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )+
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
    scale_color_manual(values = custom_colors_Pref1)

• If we plot the ABSOLUTE VALUE of Distance:

summary_distance_data <- Distance_Pref1_cleanup.df.test %>%
  mutate(condition=as.factor(condition),
         distance.abs=abs(distance))%>%
  group_by(condition, item.f) %>%
  summarize(
    distance_mean = mean(distance.abs, na.rm = TRUE),
    distance_sd = sd(distance.abs, na.rm = TRUE),
    n = n(),
    se = distance_sd / sqrt(n),
    .groups = "drop"
  )
custom_colors_Pref1 <- c(
  "Pr6_Amt1" = "#a6cee3",  # Light Blue
  "Pr5_Amt2" = "#6baed6",  # Medium Light Blue
  "Pr4_Amt3" = "#3182bd",  # Medium Blue
  "Pr3_Amt4" = "#08519c",  # Dark Blue
  "Pr2_Amt5" = "#08306b",  # Very Dark Blue
  "Pr1_Amt6" = "#041e42"   # Darkest Navy
)



summary_data_combined_ind$item.f = factor(summary_data_combined_ind$item.f, levels = rev(c(  "Pr6_Amt1","Pr5_Amt2", "Pr4_Amt3","Pr3_Amt4", "Pr2_Amt5","Pr1_Amt6")), ordered = TRUE)

ggplot(summary_distance_data, aes(x = condition, y = distance_mean, group = item.f, color = item.f,shape=item.f)) +
  geom_line(linewidth = 1, position = position_dodge(0.3)) +
  geom_point(size = 6, position = position_dodge(0.3)) +
  geom_errorbar(
    aes(
      ymin = distance_mean - se,
      ymax = distance_mean + se
    ),
    width = 0.2,
    position = position_dodge(0.3)
  ) +
  labs(
    x = "Condition",
    y = "Mean ± SE Drag Order",
    title = "Mean Drag Order by Condition"
  ) +
  theme_minimal() +
  theme(
    legend.position = "top", # Place legend at the top
    legend.title = element_text(face = "bold"),
    axis.title = element_text(face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )+
  scale_shape_manual(values = c("Pr6_Amt1" = 21, "Pr5_Amt2" = 22, 
                                "Pr4_Amt3" = 23, "Pr3_Amt4" = 24, 
                                "Pr2_Amt5" = 25, "Pr1_Amt6" = 11)) +
    scale_color_manual(values = custom_colors_Pref1)

3.2 2ND Preference Task

# psych::describe(dat$t_rank_pref2_instr._Page.Submit) # how long people spent reading the bonus instruction page for the 2nd Preference Task.

rank_data <- dat %>%
  select(
    ResponseId, PROLIFIC_PID,
    `49` = rank_Pref2_49,
    `50` = rank_Pref2_50,
    `64` = rank_Pref2_64,
    `65` = rank_Pref2_65,
    `67` = rank_Pref2_67,
    `68` = rank_Pref2_68,
    Set2_L1_Prob, Set2_L1_Amt,
    Set2_L2_Prob, Set2_L2_Amt,
    Set2_L3_Prob, Set2_L3_Amt,
    Set2_L4_Prob, Set2_L4_Amt,
    Set2_L5_Prob, Set2_L5_Amt,
    Set2_L6_Prob, Set2_L6_Amt
  ) %>%
  pivot_longer(
    cols = c(`49`, `50`, `64`, `65`, `67`, `68`),
    names_to = "item_moved",
    values_to = "Subj_rank"
  ) %>%
  mutate(
    item_moved = as.integer(item_moved),
    prob = case_when(
      item_moved == 49 ~ Set2_L1_Prob,
      item_moved == 50 ~ Set2_L2_Prob,
      item_moved == 64 ~ Set2_L3_Prob,
      item_moved == 65 ~ Set2_L4_Prob,
      item_moved == 67 ~ Set2_L5_Prob,
      item_moved == 68 ~ Set2_L6_Prob
    ),
    amt = case_when(
      item_moved == 49 ~ Set2_L1_Amt,
      item_moved == 50 ~ Set2_L2_Amt,
      item_moved == 64 ~ Set2_L3_Amt,
      item_moved == 65 ~ Set2_L4_Amt,
      item_moved == 67 ~ Set2_L5_Amt,
      item_moved == 68 ~ Set2_L6_Amt
    )
  ) %>%
  select(ResponseId, PROLIFIC_PID, item_moved, Subj_rank, prob, amt)

# select Bonus:
# set.seed(123)
# 
# bonus_payment <- rank_data %>%
#   group_by(ResponseId) %>%
#   sample_n(2) %>%
#   slice_min(Subj_rank, n = 1, with_ties = FALSE) %>%
#   ungroup()%>%
#   mutate(
#     win = rbinom(n(), 1, prob / 100),       # 1 = win, 0 = no win
#     payout = round(win * amt, 2)            # payout if win, else 0
#   )
# sum(bonus_payment$payout) # 12 won a total of 54.71
# bonus_payment # paid on June 4 via Prolific ET. Participants received a message via Prolific on whether they got a bonus.

rank_data <- dat %>%
  select(
    ResponseId,
    `49` = rank_Pref2_49,
    `50` = rank_Pref2_50,
    `64` = rank_Pref2_64,
    `65` = rank_Pref2_65,
    `67` = rank_Pref2_67,
    `68` = rank_Pref2_68
  ) %>%
  pivot_longer(
    -ResponseId,  # keep ResponseId fixed
    names_to = "item_moved",
    values_to = "Subj_rank"
  ) %>%
  mutate(
    item_moved = as.integer(item_moved),
    item_label = case_when(
      item_moved == 49 ~ "Pr6_Amt1",
      item_moved == 50 ~ "Pr5_Amt2",
      item_moved == 64 ~ "Pr4_Amt3",
      item_moved == 65 ~ "Pr3_Amt4",
      item_moved == 67 ~ "Pr2_Amt5",
      item_moved == 68 ~ "Pr1_Amt6"
    ),
    item_label = factor(item_label, levels = c("Pr6_Amt1", "Pr5_Amt2", "Pr4_Amt3", "Pr3_Amt4", "Pr2_Amt5", "Pr1_Amt6"))
  )

ggplot(rank_data, aes(x = item_label, y = 7 - Subj_rank)) +  # Reverse code: 6 = top rank
  geom_violin(trim = FALSE, fill = "lightblue", color = "darkblue", alpha = 0.5) +
  geom_jitter(width = 0.15, height = 0, alpha = 0.6, size = 1.5, color = "black") +
  stat_summary(fun = mean, geom = "point", shape = 21, size = 3, fill = "red", color = "red") +
  labs(
    title = "Distribution of Pref1 Ranks by Item",
    x = "Item",
    y = "Rank (6 = Top)"
  ) +
  scale_y_continuous(breaks = 1:6, limits = c(1, 6)) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

### The following focuses on quizes A and B, the two quizes with focal items

RankProcess_Prefer2<-dat%>%
  select(ResponseId,RankProcess_Prefer2)%>%
  separate_rows(RankProcess_Prefer2, sep = "}") %>% #separate data into long format... 
  mutate(RankProcess_Prefer2 = gsub("[{}]", "", RankProcess_Prefer2))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_Prefer2!="")%>% # an empty obs is generated for each subject, removed
  separate(RankProcess_Prefer2, into = c("timing", "order"), sep = ";")%>%
# RankProcess%>%
#   filter(is.na(order)) #none
  group_by(ResponseId)%>%
  mutate(step=row_number()-1)%>% # first row records the initial position of items.
  select(step,everything())%>%
  ungroup()

### Check order column format ###

#### RankProcess Check #####
RankProcess_Prefer2$order <- trimws(RankProcess_Prefer2$order)
is_valid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Prefer2$order)
bug_respondent_Prefer2 <- RankProcess_Prefer2 %>%
  filter(!is_valid) %>%
  pull(ResponseId)# exclude 0 respondent with incorrect format data.

# RankProcess_A%>%
#   filter(ResponseId=="R_61SsQv6Vz0cWHQt") # this respondent has a duplicated row; needs to be removed; we tentatively remove this respondent entirely. But perhaps we only need to remove the duplicate row?

RankProcess_Prefer2<-RankProcess_Prefer2%>%
  filter(!ResponseId %in% c(bug_respondent_Prefer2)) # remove data from respondents with NA item_moved columns entirely. - Other Data Recording Issue
#### RankProcess Check DONE #####

#### Done Addressing Incorrect Data Recording ####


RankProcess_all_Prefer2<-dat%>%
  select(ResponseId,RankProcess_all_Prefer2)%>%
  separate_rows(RankProcess_all_Prefer2, sep = "}") %>%
  mutate(RankProcess_all_Prefer2 = gsub("[{}]", "", RankProcess_all_Prefer2))%>% # Remove the remaining curly braces `{`
  filter(RankProcess_all_Prefer2!="")%>%
  separate(RankProcess_all_Prefer2, into = c("timing", "order_all"), sep = ";")


RankProcess_Prefer2<-RankProcess_Prefer2%>%
  left_join(RankProcess_all_Prefer2,by=c("ResponseId","timing"))%>%
  mutate(item_moved= sub(",.*", "", order_all))%>% # # Retain only the value before the first comma. This is because the we are asking JavaScript to capture the order at the moment of mousedown, with RankProcess_all, prior to Qualtrics fully integrating the order. Additionally, the moved item consistently appears first in the recorded sequence (tested with the "inspect" function), a feature we use to identify the item taken. This behavior should be periodically checked to confirm if Qualtrics updates any underlying processes. # 10/25/2024 Xuwen.
  ungroup()%>%
  mutate(item_moved=as.numeric(item_moved),
         item.f=as.factor(case_when(
    item_moved==49 ~ "Pr6_Amt1",
    item_moved==50 ~ "Pr5_Amt2",
    item_moved==64 ~ "Pr4_Amt3",
    item_moved==65 ~ "Pr3_Amt4",
    item_moved==67 ~ "Pr2_Amt5",
    item_moved==68 ~ "Pr1_Amt6" # 2024/11/26; verified these with Qualtrics Quiz Preview and using the "Inspect Element" feature
  )))



#### Address Incorrect Data Recording ####

na_subj_Prefer2<-RankProcess_Prefer2%>%
  filter(is.na(item_moved))%>%
  pull(ResponseId)  # some respondents have missing item moved - menaing that there are items in  rank process that cannot be matched from Rank process all. This only occurs in rare cases and remove data from these responents.
# one participant identified

#### RankProcess ALL Check  #####
RankProcess_Prefer2$order_all <- trimws(RankProcess_Prefer2$order_all)
Invalid <- grepl("^\\d+(,\\d+){5}$", RankProcess_Prefer2$order_all)
bug_respondent_Prefer2 <- RankProcess_Prefer2 %>%
  filter(Invalid & timing!=0) %>%
  pull(ResponseId)
#### RankProcess ALL Check DONE #####

RankProcess_Prefer2<-RankProcess_Prefer2%>%
  filter(!ResponseId %in% c(na_subj_Prefer2,bug_respondent_Prefer2))

# RankProcess_A%>%
#   filter(is.na(item_moved)) # order_all variable was somehow not recorded in these rows. 

drag_and_drop_count_Prefer2<-RankProcess_Prefer2%>%
  filter(step!=0)%>% # step=0 shows initial rank. Remove this.
  group_by(ResponseId)%>%
  summarize(item_49_moved.N=sum(item_moved==49),
            item_50_moved.N=sum(item_moved==50),
            item_64_moved.N=sum(item_moved==64),
            item_65_moved.N=sum(item_moved==65),
            item_67_moved.N=sum(item_moved==67),
            item_68_moved.N=sum(item_moved==68))%>%
  ungroup() 


### Data Wrangling for Drag distance - in order to identify data recording where a bug had appeared to occur ###

Distance_Prefer2<-RankProcess_Prefer2 %>%
  group_by(ResponseId)%>%
  mutate(
    # Split the string into parts based on commas
    parts = str_split(order, ",")
  ) %>%
  mutate(
    Rank1 = sapply(parts, function(x) x[1]),  # Extract before 1st comma
    Rank2 = sapply(parts, function(x) x[2]),  # Extract before 2nd comma
    Rank3 = sapply(parts, function(x) x[3]),  # Extract before 3rd comma
    Rank4 = sapply(parts, function(x) x[4]),  # Extract before 4th comma
    Rank5 = sapply(parts, function(x) x[5]),  # Extract before 5th comma
    Rank6 = sapply(parts, function(x) ifelse(length(x) > 5, x[6], NA))  # Extract after 5th comma
  ) %>%
  select(-parts)

items_Prefer2 <- c("49", "50", "64", "65", "67", "68")
for (item in items_Prefer2) {
  Distance_Prefer2[[paste0("current_", item)]] <- NA_integer_
}


Distance_Prefer2 <- Distance_Prefer2 %>%
  rowwise() %>%
  mutate(
    across(
      starts_with("current_"),
      ~ {
        item_number <- str_remove(cur_column(), "current_")  # Extract the item number
        case_when(
          Rank1 == item_number ~ 1,
          Rank2 == item_number ~ 2,
          Rank3 == item_number ~ 3,
          Rank4 == item_number ~ 4,
          Rank5 == item_number ~ 5,
          Rank6 == item_number ~ 6,
          TRUE ~ 1 # Distance_A %>% mutate(NA_count = rowSums(is.na(select(., starts_with("current_"))))); this code somehow results in the first item always gets an NA, so manually fix this error
        )
      }
    )
  ) %>%
  ungroup()

### No rows should have any repeated 1 in the "current_" columns ###
# Distance_A %>%
#   rowwise() %>%
#   mutate(
#     more_than_one_1 = sum(select(., starts_with("current_")) == 1, na.rm = TRUE) > 1
#   ) %>%
#   ungroup()%>%
#   filter(more_than_one_1) # NONE; good.


for (item in items_Prefer2) {
  Distance_Prefer2[[paste0("last_", item)]] <- lag(Distance_Prefer2[[paste0("current_", item)]])
}


Distance_Prefer2<-Distance_Prefer2%>%
  group_by(ResponseId)%>%
  rowwise() %>%
  mutate(
    current_item_moved = get(paste0("current_", item_moved)),  # Get the rank of the moved item from current columns
    last_item_moved = get(paste0("last_", item_moved)),        # Get the rank of the moved item from last columns
    # Determine the movement direction; we should not see any "no_change"
    move_direction = case_when(
      is.na(last_item_moved) ~ "no_change",  
      current_item_moved < last_item_moved ~ "up",
      current_item_moved > last_item_moved ~ "down",
      TRUE ~ "no_change"
    )
  ) %>%
  ungroup()


Distance_Prefer2 <- Distance_Prefer2 %>%
  group_by(ResponseId)%>%
  filter(step!=0) # need to retain step 0 for steps that come before

bug_respondent_Prefer2<-Distance_Prefer2%>%
  filter(move_direction=="no_change")%>%pull(ResponseId) # 0 respondent

table(Distance_Prefer2$move_direction) #

## 
## down   up 
##    5  103

Drag Count

Drag Order

Drag Distance

4. Binary Choices

4.1 Page Response Times

# each extract a dataset for each task and then do the psych mean thing

summarize_task <- function(data, column_name, task_name) {
  data %>%
    summarise(
      Task = task_name,
      Mean_t = mean(.data[[column_name]], na.rm = TRUE),
      Median_t = median(.data[[column_name]], na.rm = TRUE),
      SD = sd(.data[[column_name]], na.rm = TRUE),
      Min = min(.data[[column_name]], na.rm = TRUE),
      Max = max(.data[[column_name]], na.rm = TRUE),
      N = sum(!is.na(.data[[column_name]]))
    )
}

# Apply the function to each dataset


summary_1ST <- summarize_task(dat, "t_Binary1_Page.Submit", "1ST Choice")
summary_2ND <- summarize_task(dat, "t_Binary2_Page.Submit", "2ND Choice")
summary_3RD <- summarize_task(dat, "t_Binary3_Page.Submit",  "3RD Choice")
summary_4TH <- summarize_task(dat, "t_Binary4_Page.Submit", "4TH Choice")
summary_5TH <- summarize_task(dat, "t_Binary5_Page.Submit", "5TH Choice")
# summary_Binary <- summarize_task(dat, "t_Prob_Page.Submit", "Prob")



# Combine all summaries into one table
all_summaries <- bind_rows(summary_1ST,summary_2ND, summary_3RD, summary_4TH,summary_5TH )


# t.test(dat$t_Prob_Page.Submit,dat$rank_Amount_t_Page.Submit)
all_summaries