439 lines
15 KiB
R
439 lines
15 KiB
R
# Mixed ANOVA Analysis for Domain Means
|
|
# EOHI Experiment Data Analysis - Domain Level Analysis
|
|
# Variables: NPast_mean_pref, NPast_mean_pers, NPast_mean_val, NPast_mean_life
|
|
# NFut_mean_pref, NFut_mean_pers, NFut_mean_val, NFut_mean_life
|
|
|
|
# Load required libraries
|
|
library(tidyverse)
|
|
library(ez)
|
|
library(car)
|
|
library(nortest) # For normality tests
|
|
library(ggplot2) # For plotting
|
|
library(emmeans) # For post-hoc comparisons
|
|
|
|
# Global options to remove scientific notation
|
|
options(scipen = 999)
|
|
|
|
setwd("C:/Users/irina/Documents/DND/EOHI/eohi1")
|
|
|
|
# Read the data
|
|
data <- read.csv("exp1.csv")
|
|
|
|
# Display basic information about the dataset
|
|
print(dim(data))
|
|
print(length(unique(data$pID)))
|
|
|
|
# Check experimental conditions
|
|
print(table(data$GROUP, data$TEMPORAL_DO, data$ITEM_DO))
|
|
|
|
# Check what domain mean columns are available
|
|
domain_mean_cols <- colnames(data)[grepl("mean_(pref|pers|val|life)", colnames(data))]
|
|
print(domain_mean_cols)
|
|
|
|
# Verify the specific variables we need
|
|
required_vars <- c("NPast_mean_pref", "NPast_mean_pers", "NPast_mean_val", "NPast_mean_life",
|
|
"NFut_mean_pref", "NFut_mean_pers", "NFut_mean_val", "NFut_mean_life")
|
|
|
|
missing_vars <- required_vars[!required_vars %in% colnames(data)]
|
|
if (length(missing_vars) > 0) {
|
|
print(paste("Warning: Missing variables:", paste(missing_vars, collapse = ", ")))
|
|
} else {
|
|
print("All required domain mean variables found!")
|
|
}
|
|
|
|
# Define domain mapping
|
|
domain_mapping <- data.frame(
|
|
variable = c("NPast_mean_pref", "NPast_mean_pers", "NPast_mean_val", "NPast_mean_life",
|
|
"NFut_mean_pref", "NFut_mean_pers", "NFut_mean_val", "NFut_mean_life"),
|
|
time = c(rep("Past", 4), rep("Future", 4)),
|
|
domain = rep(c("Preferences", "Personality", "Values", "Life"), 2),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
|
|
print(domain_mapping)
|
|
|
|
# Function to pivot data to long format
|
|
pivot_domain_means <- function(data, domain_mapping) {
|
|
long_data <- data.frame()
|
|
|
|
for (i in 1:nrow(domain_mapping)) {
|
|
var_name <- domain_mapping$variable[i]
|
|
time_level <- domain_mapping$time[i]
|
|
domain_level <- domain_mapping$domain[i]
|
|
|
|
# Check if variable exists
|
|
if (!var_name %in% colnames(data)) {
|
|
print(paste("Warning: Variable", var_name, "not found in data"))
|
|
next
|
|
}
|
|
|
|
# Create subset for this variable
|
|
subset_data <- data[, c("pID", "ResponseId", "TEMPORAL_DO", var_name)]
|
|
subset_data$TIME <- time_level
|
|
subset_data$DOMAIN <- domain_level
|
|
subset_data$MEAN_DIFFERENCE <- subset_data[[var_name]]
|
|
subset_data[[var_name]] <- NULL # Remove original column
|
|
|
|
# Add to long data
|
|
long_data <- rbind(long_data, subset_data)
|
|
}
|
|
|
|
# Convert to factors with proper levels
|
|
long_data$TIME <- factor(long_data$TIME, levels = c("Past", "Future"))
|
|
long_data$DOMAIN <- factor(long_data$DOMAIN, levels = c("Preferences", "Personality", "Values", "Life"))
|
|
long_data$pID <- as.factor(long_data$pID)
|
|
long_data$TEMPORAL_DO <- as.factor(long_data$TEMPORAL_DO)
|
|
|
|
return(long_data)
|
|
}
|
|
|
|
# Pivot data to long format
|
|
tryCatch({
|
|
long_data <- pivot_domain_means(data, domain_mapping)
|
|
}, error = function(e) {
|
|
print(paste("Error in data pivoting:", e$message))
|
|
stop("Cannot proceed without proper data structure")
|
|
})
|
|
|
|
print(dim(long_data))
|
|
print(length(unique(long_data$pID)))
|
|
print(levels(long_data$TIME))
|
|
print(levels(long_data$DOMAIN))
|
|
|
|
# Check data types
|
|
print(is.factor(long_data$TIME))
|
|
print(is.factor(long_data$DOMAIN))
|
|
print(is.factor(long_data$pID))
|
|
print(is.numeric(long_data$MEAN_DIFFERENCE))
|
|
|
|
# Show first 20 rows
|
|
print(utils::head(long_data, 20))
|
|
|
|
# Display structure and sample
|
|
str(long_data)
|
|
|
|
print(utils::head(long_data, 10))
|
|
|
|
# Show example data for one participant
|
|
participant_1_data <- long_data[long_data$pID == 1, c("pID", "TEMPORAL_DO", "TIME", "DOMAIN", "MEAN_DIFFERENCE")]
|
|
print(participant_1_data)
|
|
|
|
# =============================================================================
|
|
# DESCRIPTIVE STATISTICS
|
|
# =============================================================================
|
|
|
|
# Overall descriptive statistics by TIME and DOMAIN
|
|
desc_stats <- long_data %>%
|
|
group_by(TIME, DOMAIN) %>%
|
|
summarise(
|
|
n = n(),
|
|
mean = round(mean(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
variance = round(var(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
sd = round(sd(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
median = round(median(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
q1 = round(quantile(MEAN_DIFFERENCE, 0.25, na.rm = TRUE), 5),
|
|
q3 = round(quantile(MEAN_DIFFERENCE, 0.75, na.rm = TRUE), 5),
|
|
min = round(min(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
max = round(max(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Descriptive statistics by TIME and DOMAIN:")
|
|
print(desc_stats)
|
|
|
|
# Descriptive statistics by between-subjects factors
|
|
desc_stats_by_temporal <- long_data %>%
|
|
group_by(TEMPORAL_DO, TIME, DOMAIN) %>%
|
|
summarise(
|
|
n = n(),
|
|
mean = round(mean(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
variance = round(var(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
sd = round(sd(MEAN_DIFFERENCE, na.rm = TRUE), 5),
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Descriptive statistics by TEMPORAL_DO, TIME, and DOMAIN:")
|
|
print(desc_stats_by_temporal)
|
|
|
|
|
|
# =============================================================================
|
|
# ASSUMPTION TESTING
|
|
# =============================================================================
|
|
|
|
# Remove missing values for assumption testing
|
|
long_data_clean <- long_data[!is.na(long_data$MEAN_DIFFERENCE), ]
|
|
print(paste("Data after removing missing values:", dim(long_data_clean)))
|
|
|
|
# 1. Missing values check
|
|
missing_summary <- long_data %>%
|
|
group_by(TIME, DOMAIN) %>%
|
|
summarise(
|
|
n_total = n(),
|
|
n_missing = sum(is.na(MEAN_DIFFERENCE)),
|
|
pct_missing = round(100 * n_missing / n_total, 2),
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Missing values by TIME and DOMAIN:")
|
|
print(missing_summary)
|
|
|
|
# 2. Outlier detection
|
|
outlier_summary <- long_data_clean %>%
|
|
group_by(TIME, DOMAIN) %>%
|
|
summarise(
|
|
n = n(),
|
|
mean = mean(MEAN_DIFFERENCE),
|
|
sd = sd(MEAN_DIFFERENCE),
|
|
q1 = quantile(MEAN_DIFFERENCE, 0.25),
|
|
q3 = quantile(MEAN_DIFFERENCE, 0.75),
|
|
iqr = q3 - q1,
|
|
lower_bound = q1 - 1.5 * iqr,
|
|
upper_bound = q3 + 1.5 * iqr,
|
|
n_outliers = sum(MEAN_DIFFERENCE < lower_bound | MEAN_DIFFERENCE > upper_bound),
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Outlier summary (IQR method):")
|
|
print(outlier_summary)
|
|
|
|
# 3. Normality tests
|
|
normality_results <- long_data_clean %>%
|
|
group_by(TIME, DOMAIN) %>%
|
|
summarise(
|
|
n = n(),
|
|
shapiro_W = ifelse(n >= 3 & n <= 5000,
|
|
shapiro.test(MEAN_DIFFERENCE)$statistic,
|
|
NA),
|
|
shapiro_p = ifelse(n >= 3 & n <= 5000,
|
|
shapiro.test(MEAN_DIFFERENCE)$p.value,
|
|
NA),
|
|
anderson_A = ifelse(n >= 7,
|
|
ad.test(MEAN_DIFFERENCE)$statistic,
|
|
NA),
|
|
anderson_p = ifelse(n >= 7,
|
|
ad.test(MEAN_DIFFERENCE)$p.value,
|
|
NA),
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Normality test results:")
|
|
print(normality_results)
|
|
|
|
# Note: Anderson-Darling p-values may appear identical due to machine precision limits
|
|
# All p-values are extremely small (< 2.2e-16) indicating strong non-normality
|
|
# The test statistics (A values) are actually different across conditions
|
|
|
|
# Debug: Check if Anderson-Darling test is working properly
|
|
print("\n=== DEBUG: Anderson-Darling Test Details ===")
|
|
|
|
# Get unique combinations of TIME and DOMAIN
|
|
unique_combos <- long_data_clean %>%
|
|
select(TIME, DOMAIN) %>%
|
|
distinct()
|
|
|
|
# Run Anderson-Darling test for each combination
|
|
for(i in 1:nrow(unique_combos)) {
|
|
time_val <- unique_combos$TIME[i]
|
|
domain_val <- unique_combos$DOMAIN[i]
|
|
|
|
# Subset data for this combination
|
|
subset_data <- long_data_clean %>%
|
|
filter(TIME == time_val, DOMAIN == domain_val)
|
|
|
|
cat("TIME:", time_val, "DOMAIN:", domain_val, "n =", nrow(subset_data), "\n")
|
|
|
|
# Run Anderson-Darling test
|
|
if(nrow(subset_data) >= 7) {
|
|
ad_result <- ad.test(subset_data$MEAN_DIFFERENCE)
|
|
print(ad_result)
|
|
} else {
|
|
cat("Sample size too small for Anderson-Darling test\n")
|
|
}
|
|
cat("\n")
|
|
}
|
|
|
|
# 4. Homogeneity of variance (Levene's test)
|
|
# Test homogeneity across TIME within each DOMAIN
|
|
homogeneity_time <- long_data_clean %>%
|
|
group_by(DOMAIN) %>%
|
|
summarise(
|
|
levene_F = leveneTest(MEAN_DIFFERENCE ~ TIME)$`F value`[1],
|
|
levene_p = leveneTest(MEAN_DIFFERENCE ~ TIME)$`Pr(>F)`[1],
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Homogeneity of variance across TIME within each DOMAIN:")
|
|
print(homogeneity_time)
|
|
|
|
# Test homogeneity across DOMAIN within each TIME
|
|
homogeneity_domain <- long_data_clean %>%
|
|
group_by(TIME) %>%
|
|
summarise(
|
|
levene_F = leveneTest(MEAN_DIFFERENCE ~ DOMAIN)$`F value`[1],
|
|
levene_p = leveneTest(MEAN_DIFFERENCE ~ DOMAIN)$`Pr(>F)`[1],
|
|
.groups = 'drop'
|
|
)
|
|
|
|
print("Homogeneity of variance across DOMAIN within each TIME:")
|
|
print(homogeneity_domain)
|
|
|
|
# =============================================================================
|
|
# HARTLEY'S F-MAX TEST WITH BOOTSTRAP CRITICAL VALUES
|
|
# =============================================================================
|
|
|
|
# Function to calculate Hartley's F-max ratio
|
|
calculate_hartley_ratio <- function(variances) {
|
|
max(variances, na.rm = TRUE) / min(variances, na.rm = TRUE)
|
|
}
|
|
|
|
# =============================================================================
|
|
# CALCULATE OBSERVED F-MAX RATIOS
|
|
# =============================================================================
|
|
|
|
# Test 1: Observed F-max across TIME within each DOMAIN
|
|
print("=== OBSERVED F-MAX RATIOS: TIME within each DOMAIN ===")
|
|
|
|
observed_time_ratios <- long_data_clean %>%
|
|
group_by(DOMAIN) %>%
|
|
summarise(
|
|
# Calculate variances for each TIME level within this domain
|
|
past_var = var(MEAN_DIFFERENCE[TIME == "Past"], na.rm = TRUE),
|
|
future_var = var(MEAN_DIFFERENCE[TIME == "Future"], na.rm = TRUE),
|
|
# Calculate F-max ratio
|
|
f_max_ratio = max(past_var, future_var) / min(past_var, future_var),
|
|
.groups = 'drop'
|
|
) %>%
|
|
select(DOMAIN, past_var, future_var, f_max_ratio)
|
|
|
|
print(observed_time_ratios)
|
|
|
|
# Test 2: Observed F-max across DOMAIN within each TIME
|
|
print("\n=== OBSERVED F-MAX RATIOS: DOMAIN within each TIME ===")
|
|
|
|
observed_domain_ratios <- long_data_clean %>%
|
|
group_by(TIME) %>%
|
|
summarise(
|
|
# Calculate variances for each DOMAIN level within this time
|
|
pref_var = var(MEAN_DIFFERENCE[DOMAIN == "Preferences"], na.rm = TRUE),
|
|
pers_var = var(MEAN_DIFFERENCE[DOMAIN == "Personality"], na.rm = TRUE),
|
|
val_var = var(MEAN_DIFFERENCE[DOMAIN == "Values"], na.rm = TRUE),
|
|
life_var = var(MEAN_DIFFERENCE[DOMAIN == "Life"], na.rm = TRUE),
|
|
# Calculate F-max ratio
|
|
f_max_ratio = max(pref_var, pers_var, val_var, life_var) / min(pref_var, pers_var, val_var, life_var),
|
|
.groups = 'drop'
|
|
) %>%
|
|
select(TIME, pref_var, pers_var, val_var, life_var, f_max_ratio)
|
|
|
|
print(observed_domain_ratios)
|
|
|
|
# Function to bootstrap critical values for Hartley's F-max test
|
|
bootstrap_hartley_critical <- function(data, group_var, response_var, n_iter = 1000) {
|
|
# Get unique groups and their sample sizes
|
|
groups <- unique(data[[group_var]])
|
|
n_groups <- length(groups)
|
|
|
|
# Calculate observed variances for each group
|
|
observed_vars <- data %>%
|
|
group_by(!!sym(group_var)) %>%
|
|
summarise(var = var(!!sym(response_var), na.rm = TRUE), .groups = 'drop') %>%
|
|
pull(var)
|
|
|
|
# Debug: Check for zero or invalid variances
|
|
if(any(observed_vars <= 0 | is.na(observed_vars))) {
|
|
cat("Warning: Invalid observed variances detected:", observed_vars, "\n")
|
|
observed_vars[observed_vars <= 0 | is.na(observed_vars)] <- 1e-10
|
|
}
|
|
|
|
# Calculate observed F-max ratio
|
|
observed_ratio <- calculate_hartley_ratio(observed_vars)
|
|
|
|
# Bootstrap under null hypothesis (equal variances)
|
|
# Resample from actual data to create equal variance scenario
|
|
pooled_data <- data[[response_var]]
|
|
|
|
# Bootstrap F-max ratios under null hypothesis
|
|
bootstrap_ratios <- replicate(n_iter, {
|
|
# Resample from pooled data for each group
|
|
sample_vars <- map_dbl(groups, ~ {
|
|
group_data <- data[data[[group_var]] == .x, response_var]
|
|
n_group <- length(group_data)
|
|
# Bootstrap sample from pooled data
|
|
bootstrap_sample <- sample(pooled_data, size = n_group, replace = TRUE)
|
|
sample_var <- var(bootstrap_sample, na.rm = TRUE)
|
|
# Debug: Check for zero variance or NA
|
|
if(is.na(sample_var) || sample_var == 0) {
|
|
cat("Warning: Zero or NA variance detected in bootstrap sample\n")
|
|
sample_var <- 1e-10
|
|
}
|
|
sample_var
|
|
})
|
|
hartley_ratio <- calculate_hartley_ratio(sample_vars)
|
|
# Debug: Check for invalid ratios
|
|
if(!is.finite(hartley_ratio)) {
|
|
cat("Warning: Invalid Hartley ratio:", hartley_ratio, "Sample vars:", sample_vars, "\n")
|
|
}
|
|
hartley_ratio
|
|
})
|
|
|
|
# Calculate critical value (95th percentile)
|
|
# Remove any NaN or infinite values
|
|
valid_ratios <- bootstrap_ratios[is.finite(bootstrap_ratios) & !is.na(bootstrap_ratios)]
|
|
|
|
# Debug: Check what's happening
|
|
cat("Total bootstrap ratios:", length(bootstrap_ratios), "\n")
|
|
cat("Valid bootstrap ratios:", length(valid_ratios), "\n")
|
|
cat("Sample of bootstrap ratios:", head(bootstrap_ratios, 5), "\n")
|
|
cat("Sample of valid ratios:", head(valid_ratios, 5), "\n")
|
|
|
|
if(length(valid_ratios) == 0) {
|
|
cat("All bootstrap ratios were invalid. Sample ratios:", head(bootstrap_ratios, 10), "\n")
|
|
stop("No valid bootstrap ratios generated")
|
|
}
|
|
|
|
critical_95 <- quantile(valid_ratios, 0.95, na.rm = TRUE)
|
|
|
|
return(list(
|
|
observed_ratio = observed_ratio,
|
|
critical_95 = critical_95,
|
|
bootstrap_ratios = bootstrap_ratios
|
|
))
|
|
}
|
|
|
|
# Test 1: Hartley's F-max across TIME within each DOMAIN
|
|
print("\n=== HARTLEY'S F-MAX TEST: TIME within each DOMAIN ===")
|
|
set.seed(123) # For reproducibility
|
|
|
|
hartley_time_results <- long_data_clean %>%
|
|
group_by(DOMAIN) %>%
|
|
summarise(
|
|
hartley_result = list(bootstrap_hartley_critical(cur_data(), "TIME", "MEAN_DIFFERENCE")),
|
|
.groups = 'drop'
|
|
) %>%
|
|
mutate(
|
|
observed_ratio = map_dbl(hartley_result, ~ .x$observed_ratio),
|
|
critical_95 = map_dbl(hartley_result, ~ .x$critical_95),
|
|
significant = observed_ratio > critical_95
|
|
) %>%
|
|
select(DOMAIN, observed_ratio, critical_95, significant)
|
|
|
|
print(hartley_time_results)
|
|
|
|
# Test 2: Hartley's F-max across DOMAIN within each TIME
|
|
print("\n=== HARTLEY'S F-MAX TEST: DOMAIN within each TIME ===")
|
|
|
|
hartley_domain_results <- long_data_clean %>%
|
|
group_by(TIME) %>%
|
|
summarise(
|
|
hartley_result = list(bootstrap_hartley_critical(cur_data(), "DOMAIN", "MEAN_DIFFERENCE")),
|
|
.groups = 'drop'
|
|
) %>%
|
|
mutate(
|
|
observed_ratio = map_dbl(hartley_result, ~ .x$observed_ratio),
|
|
critical_95 = map_dbl(hartley_result, ~ .x$critical_95),
|
|
significant = observed_ratio > critical_95
|
|
) %>%
|
|
select(TIME, observed_ratio, critical_95, significant)
|
|
|
|
print(hartley_domain_results)
|
|
|