# Scale ID: 			NEO-PI
# Scale Name: 		NEO-FFI-3
# TILDA Variables: 	zNEOFFI_Agreeableness; zNEOFFI_Openness; zNEOFFI_Extraversion; zNEOFFI_Neuroticism; NEOFFI_Conscientiousness; NEOFFI_Agreeableness; NEOFFI_Openness; NEOFFI_Extraversion; NEOFFI_Neuroticism
# Dataset:      		TILDA Wave 2
# Author:       		Cathal McCrory
# Institution:  		The Irish Longitudinal Study on Ageing (TILDA)
# 
# Description:
# Generates personality subtyles for the NEO-FFI-3 Personality scale.
# 
# Version:      1.0
# Date:         2026-09-01
# Language:     R
#
# Assumption: the working data frame is called `data`.

# Create RecSCQPers1-RecSCQPers60 copies.
pers_items <- paste0("SCQPers", 1:60)
rec_items <- paste0("RecSCQPers", 1:60)
for (i in seq_along(pers_items)) {
  data[[rec_items[i]]] <- data[[pers_items[i]]]
}

missing_codes <- c(-1, -99, -812, -823, -834, -845)

# Total number of missing responses before recoding.
data$missingPersTot <- rowSums(
  sapply(rec_items, function(v) data[[v]] %in% missing_codes)
)
attr(data$missingPersTot, "label") <-
  "Total number of missing responses on the NEO-FFI-3 (range 0-60)"
print(table(data$missingPersTot, useNA = "ifany"))

dims <- list(
  Neurotic = c(1,6,11,16,21,26,31,36,41,46,51,56),
  Extrav = c(2,7,12,17,22,27,32,37,42,47,52,57),
  Openness = c(3,8,13,18,23,28,33,38,43,48,53,58),
  Agreeable = c(4,9,14,19,24,29,34,39,44,49,54,59),
  Conscient = c(5,10,15,20,25,30,35,40,45,50,55,60)
)

for (nm in names(dims)) {
  vars <- paste0("RecSCQPers", dims[[nm]])
  out <- paste0("missing_", nm)
  data[[out]] <- rowSums(sapply(vars, function(v) data[[v]] %in% missing_codes))
  print(table(data[[out]], useNA = "ifany"))
}

# Recode source 1-5 scoring to 0-4; special codes become missing.
for (v in rec_items) {
  x <- data[[v]]
  x[x %in% missing_codes] <- NA_real_
  x[!is.na(x)] <- x[!is.na(x)] - 1
  data[[v]] <- x
}

# TILDA anchored the poles opposite to the NEO-FFI-3 scoring direction
# for these items, so the source reverse-scores them after the 0-4 recode.
reverse_items <- c(
  2,3,4,5,6,7,8,10,11,13,17,20,21,22,25,26,29,32,34,35,36,37,
  38,40,41,43,47,49,50,51,52,53,56,58,60
)
for (i in reverse_items) {
  v <- paste0("RecSCQPers", i)
  data[[v]] <- 4 - data[[v]]
}

score_dimension <- function(data, out, item_numbers, missing_var,
                            restrict_imputation_by_total = FALSE) {
  vars <- paste0("RecSCQPers", item_numbers)

  # Initial ordinary sum.
  data[[out]] <- rowSums(data[vars], na.rm = FALSE)

  # Impute neutral response (2) when 1-4 dimension items are missing.
  eligible <- !is.na(data[[missing_var]]) &
              data[[missing_var]] >= 1 & data[[missing_var]] <= 4
  if (restrict_imputation_by_total) {
    eligible <- eligible & !is.na(data$missingPersTot) & data$missingPersTot < 10
  }

  for (v in vars) {
    data[[v]][eligible & is.na(data[[v]])] <- 2
  }

  # Source recomputes for everyone with 1-4 missing dimension items.
  recompute <- !is.na(data[[missing_var]]) &
               data[[missing_var]] >= 1 & data[[missing_var]] <= 4
  tmp <- rowSums(data[vars], na.rm = FALSE)
  data[[out]][recompute] <- tmp[recompute]

  # Do not retain a nonmissing score when 10+ total personality items are missing.
  data[[out]][!is.na(data[[out]]) &
              !is.na(data$missingPersTot) &
              data$missingPersTot >= 10] <- NA_real_

  data
}

data <- score_dimension(
  data, "NEOFFI_Neuroticism",
  c(1,6,11,16,21,26,31,36,41,46,51,56),
  "missing_Neurotic", FALSE
)
attr(data$NEOFFI_Neuroticism, "label") <-
  "NEO-FFI-3 - Neuroticism Score (range = 0-48)"

data <- score_dimension(
  data, "NEOFFI_Extraversion",
  c(2,7,12,17,22,27,32,37,42,47,52,57),
  "missing_Extrav", FALSE
)
attr(data$NEOFFI_Extraversion, "label") <-
  "NEO-FFI-3 - Extraversion Score (range = 0-48)"

data <- score_dimension(
  data, "NEOFFI_Openness",
  c(3,8,13,18,23,28,33,38,43,48,53,58),
  "missing_Openness", FALSE
)
attr(data$NEOFFI_Openness, "label") <-
  "NEO-FFI-3 - Openness to Experience Score (range = 0-48)"

data <- score_dimension(
  data, "NEOFFI_Agreeableness",
  c(4,9,14,19,24,29,34,39,44,49,54,59),
  "missing_Agreeable", TRUE
)
attr(data$NEOFFI_Agreeableness, "label") <-
  "NEO-FFI-3 - Agreeableness Score (range = 0-48)"

data <- score_dimension(
  data, "NEOFFI_Conscientiousness",
  c(5,10,15,20,25,30,35,40,45,50,55,60),
  "missing_Conscient", TRUE
)
attr(data$NEOFFI_Conscientiousness, "label") <-
  "NEO-FFI-3 - Conscientiousness Score (range = 0-48)"

# Standardised scores. R's sd() uses the sample SD, matching Stata egen std().
zscore <- function(x) {
  (x - mean(x, na.rm = TRUE)) / sd(x, na.rm = TRUE)
}

data$zNEOFFI_Neuroticism <- zscore(data$NEOFFI_Neuroticism)
data$zNEOFFI_Extraversion <- zscore(data$NEOFFI_Extraversion)
data$zNEOFFI_Openness <- zscore(data$NEOFFI_Openness)
data$zNEOFFI_Agreeableness <- zscore(data$NEOFFI_Agreeableness)
data$zNEOFFI_Conscientiousness <- zscore(data$NEOFFI_Conscientiousness)

attr(data$zNEOFFI_Neuroticism, "label") <-
  "Standardised scores on the NEO-FFI-3 Neuroticism dimension"
attr(data$zNEOFFI_Extraversion, "label") <-
  "Standardised scores on the NEO-FFI-3 Extraversion dimension"
attr(data$zNEOFFI_Openness, "label") <-
  "Standardised scores on the NEO-FFI-3 Openness dimension"
attr(data$zNEOFFI_Agreeableness, "label") <-
  "Standardised scores on the NEO-FFI-3 Agreeableness dimension"
attr(data$zNEOFFI_Conscientiousness, "label") <-
  "Standardised scores on the NEO-FFI-3 Conscientiousness dimension"

profile_score <- function(x, cuts) {
  out <- rep(NA_real_, length(x))
  out[!is.na(x) & x >= cuts[1] & x <= cuts[2]] <- 1
  out[!is.na(x) & x >= cuts[3] & x <= cuts[4]] <- 2
  out[!is.na(x) & x >= cuts[5] & x <= cuts[6]] <- 3
  out[!is.na(x) & x >= cuts[7] & x <= cuts[8]] <- 4
  out[!is.na(x) & x >= cuts[9] & x <= cuts[10]] <- 5
  out
}

data$NEOFFI_Neuroticism_profile <- profile_score(
  data$NEOFFI_Neuroticism, c(0,8, 9,16, 17,25, 26,32, 33,48))
data$NEOFFI_Extraversion_profile <- profile_score(
  data$NEOFFI_Extraversion, c(0,18, 19,24, 25,31, 32,37, 38,48))
data$NEOFFI_Openness_profile <- profile_score(
  data$NEOFFI_Openness, c(0,18, 19,24, 25,31, 32,38, 39,48))
data$NEOFFI_Agreeableness_profile <- profile_score(
  data$NEOFFI_Agreeableness, c(0,22, 23,28, 29,35, 36,41, 42,48))
data$NEOFFI_Conscientiousness_profile <- profile_score(
  data$NEOFFI_Conscientiousness, c(0,22, 23,28, 29,35, 36,41, 42,48))

profile_labels <- c(
  "Very low" = 1, "Low" = 2, "Average" = 3, "High" = 4, "Very High" = 5
)

for (v in c("NEOFFI_Neuroticism_profile", "NEOFFI_Extraversion_profile",
            "NEOFFI_Openness_profile", "NEOFFI_Agreeableness_profile",
            "NEOFFI_Conscientiousness_profile")) {
  attr(data[[v]], "labels") <- profile_labels
}

attr(data$NEOFFI_Neuroticism_profile, "label") <-
  "Profile score on the NEO-FFI-3 NEUROTICISM dimension"
attr(data$NEOFFI_Extraversion_profile, "label") <-
  "Profile score on the NEO-FFI-3 EXTRAVERSION dimension"
attr(data$NEOFFI_Openness_profile, "label") <-
  "Profile score on the NEO-FFI-3 OPENNESS dimension"
attr(data$NEOFFI_Agreeableness_profile, "label") <-
  "Profile score on the NEO-FFI-3 AGREEABLENESS dimension"
attr(data$NEOFFI_Conscientiousness_profile, "label") <-
  "Profile score on the NEO-FFI-3 CONSCIENTIOUSNESS dimension"

summary(data[c(
  "NEOFFI_Neuroticism", "NEOFFI_Extraversion", "NEOFFI_Openness",
  "NEOFFI_Agreeableness", "NEOFFI_Conscientiousness"
)])