R/create_ad_list.R

In psychmeta: Psychometric Meta-Analysis Toolkit

#' @title Create a tibble of artifact distributions by construct
#'
#' @description
#' Create a tibble of artifact distributions by construct
#'
#' @param ad_type Type of artifact distributions to be computed: Either "tsa" for Taylor series approximation or "int" for interactive.
#' @param n Vector or column name of sample sizes.
#' @param sample_id Optional vector of identification labels for samples/studies in the meta-analysis.
#' @param construct_x,construct_y Vector of construct names for constructs initially designated as "X" or "Y".
#' @param facet_x,facet_y Vector of facet names for constructs initially designated as "X" or "Y".
#' Facet names "global", "overall", and "total" are reserved to indicate observations that represent effect sizes that have already been composited or that represent construct-level measurements rather than facet-level measurements.
#' To avoid double-compositing, any observation with one of these reserved names will only be eligible for auto-compositing with other such observations and will not be combined with narrow facets.
#' @param measure_x,measure_y Vector of names for measures associated with constructs initially designated as "X" or "Y".
#' @param rxx Vector or column name of reliability estimates for X.
#' @param rxx_restricted Logical vector or column name determining whether each element of rxx is an incumbent reliability (\code{TRUE}) or an applicant reliability (\code{FALSE}).
#' @param ryy Vector or column name of reliability estimates for Y.
#' @param ryy_restricted Logical vector or column name determining whether each element of ryy is an incumbent reliability (\code{TRUE}) or an applicant reliability (\code{FALSE}).
#' @param ux Vector or column name of u ratios for X.
#' @param ux_observed Logical vector or column name determining whether each element of ux is an observed-score u ratio (\code{TRUE}) or a true-score u ratio (\code{FALSE}).
#' @param uy Vector or column name of u ratios for Y.
#' @param uy_observed Logical vector or column name determining whether each element of uy is an observed-score u ratio (\code{TRUE}) or a true-score u ratio (\code{FALSE}).
#' @param estimate_rxxa Logical argument to estimate rxxa values from other artifacts (\code{TRUE}) or to only used supplied rxxa values (\code{FALSE}). \code{TRUE} by default.
#' @param estimate_rxxi Logical argument to estimate rxxi values from other artifacts (\code{TRUE}) or to only used supplied rxxi values (\code{FALSE}). \code{TRUE} by default.
#' @param estimate_ux Logical argument to estimate ux values from other artifacts (\code{TRUE}) or to only used supplied ux values (\code{FALSE}). \code{TRUE} by default.
#' @param estimate_ut Logical argument to estimate ut values from other artifacts (\code{TRUE}) or to only used supplied ut values (\code{FALSE}). \code{TRUE} by default.
#' @param supplemental_ads Named list (named according to the constructs included in the meta-analysis) of supplemental artifact distribution information from studies not included in the meta-analysis. This is a list of lists, where the elements of a list associated with a construct are named like the arguments of the \code{create_ad()} function.
#' @param data Data frame containing columns whose names may be provided as arguments to vector arguments.
#' @param control Output from the \code{control_psychmeta()} function or a list of arguments controlled by the \code{control_psychmeta()} function. Ellipsis arguments will be screened for internal inclusion in \code{control}.
#' @param ... Additional arguments
#'
#' @param rxx_type,ryy_type String vector identifying the types of reliability estimates supplied. See documentation of \code{\link{ma_r}} for a full list of acceptable values.
#' @param k_items_x,k_items_y Numeric vector identifying the number of items in each scale.
#' @param moderators Matrix or column names of moderator variables to be used in the meta-analysis (can be a vector in the case of one moderator).
#' @param cat_moderators Logical scalar or vector identifying whether variables in the \code{moderators} argument are categorical variables (\code{TRUE}) or continuous variables (\code{FALSE}).
#' @param moderator_type Type of moderator analysis: "none" means that no moderators are to be used, "simple" means that moderators are to be examined one at a time, and
#' "hierarchical" means that all possible combinations and subsets of moderators are to be examined.
#' @param construct_order Vector indicating the order in which variables should be arranged, with variables listed earlier in the vector being preferred for designation as X.
#'
#' @return A tibble of artifact distributions
#' @export
#'
#' @examples
#' ## Examples to create Taylor series artifact distributions:
#' # Overall artifact distributions (not pairwise, not moderated)
#' create_ad_tibble(ad_type = "tsa",
#'                  n = n, rxx = rxxi, ryy = ryyi,
#'                  construct_x = x_name, construct_y = y_name,
#'                  sample_id = sample_id, moderators = moderator,
#'                  data = data_r_meas_multi,
#'                  control = control_psychmeta(pairwise_ads = FALSE,
#'                                              moderated_ads = FALSE))
#'
#' # Overall artifact distributions by moderator combination
#' create_ad_tibble(ad_type = "tsa",
#'                  n = n, rxx = rxxi, ryy = ryyi,
#'                  construct_x = x_name, construct_y = y_name,
#'                  sample_id = sample_id, moderators = moderator,
#'                  data = data_r_meas_multi,
#'                  control = control_psychmeta(pairwise_ads = FALSE,
#'                                              moderated_ads = TRUE))
#'
#' # Pairwise artifact distributions (not moderated)
#' create_ad_tibble(ad_type = "tsa",
#'                  n = n, rxx = rxxi, ryy = ryyi,
#'                  construct_x = x_name, construct_y = y_name,
#'                  sample_id = sample_id, moderators = moderator,
#'                  data = data_r_meas_multi,
#'                  control = control_psychmeta(pairwise_ads = TRUE,
#'                                                moderated_ads = FALSE))
#'
#' # Pairwise artifact distributions by moderator combination
#' create_ad_tibble(ad_type = "tsa",
#'                  n = n, rxx = rxxi, ryy = ryyi,
#'                  construct_x = x_name, construct_y = y_name,
#'                  sample_id = sample_id, moderators = moderator,
#'                  data = data_r_meas_multi,
#'                  control = control_psychmeta(pairwise_ads = TRUE,
#'                                              moderated_ads = TRUE))
create_ad_tibble <- function(ad_type = c("tsa", "int"),
                             n = NULL, sample_id = NULL,
                             construct_x = NULL, facet_x = NULL, measure_x = NULL,
                             construct_y = NULL, facet_y = NULL, measure_y = NULL,
                             rxx = NULL, rxx_restricted = TRUE, rxx_type = "alpha", k_items_x = NA,
                             ryy = NULL, ryy_restricted = TRUE, ryy_type = "alpha", k_items_y = NA,
                             ux = NULL, ux_observed = TRUE,
                             uy = NULL, uy_observed = TRUE,
                             estimate_rxxa = TRUE, estimate_rxxi = TRUE,
                             estimate_ux = TRUE, estimate_ut = TRUE,
                             moderators = NULL, cat_moderators = TRUE,
                             moderator_type = c("simple", "hierarchical", "none"),
                             construct_order = NULL,
                             supplemental_ads = NULL, data = NULL, control = control_psychmeta(), ...){

     call <- match.call()
     warn_obj1 <- record_warnings()

     ad_type <- match.arg(ad_type, c("tsa", "int"))
     moderator_type <- match.arg(moderator_type, choices = c("simple", "hierarchical", "none"))

     control_only <- list(...)$control_only
     if(is.null(control_only)) control_only <- FALSE

     if(control_only)
          control <- control_psychmeta(.psychmeta_ellipse_args = list(...),
                                       .control_psychmeta_arg = control)
     error_type <- control$error_type
     var_unbiased <- control$var_unbiased
     pairwise_ads <- control$pairwise_ads
     moderated_ads <- control$moderated_ads
     check_dependence <- control$check_dependence
     collapse_method <- control$collapse_method
     intercor <- control$intercor

     process_ads <- list(...)$process_ads
     if(is.null(process_ads)) process_ads <- TRUE

     formal_args <- formals(create_ad_tibble)
     formal_args[["..."]] <- NULL
     for(i in names(formal_args)) if(i %in% names(call)) formal_args[[i]] <- NULL
     call_full <- as.call(append(as.list(call), formal_args))

     if(!is.null(data)){
          data <- as.data.frame(data, stringsAsFactors = FALSE)

          if(deparse(substitute(n))[1] != "NULL")
               n <- match_variables(call = call_full[[match("n", names(call_full))]], arg = n, arg_name = "n", data = data)

          if(deparse(substitute(sample_id))[1] != "NULL")
               sample_id <- match_variables(call = call_full[[match("sample_id", names(call_full))]], arg = sample_id, arg_name = "sample_id", data = data)

          if(deparse(substitute(construct_x))[1] != "NULL")
               construct_x <- match_variables(call = call_full[[match("construct_x", names(call_full))]], arg = construct_x, arg_name = "construct_x", data = data)

          if(deparse(substitute(construct_y))[1] != "NULL")
               construct_y <- match_variables(call = call_full[[match("construct_y", names(call_full))]], arg = construct_y, arg_name = "construct_y", data = data)

          if(deparse(substitute(facet_x))[1] != "NULL")
               facet_x <- match_variables(call = call_full[[match("facet_x", names(call_full))]], arg = facet_x, arg_name = "facet_x", data = data)

          if(deparse(substitute(facet_y))[1] != "NULL")
               facet_y <- match_variables(call = call_full[[match("facet_y", names(call_full))]], arg = facet_y, arg_name = "facet_y", data = data)

          if(deparse(substitute(measure_x))[1] != "NULL")
               measure_x <- match_variables(call = call_full[[match("measure_x", names(call_full))]], arg = measure_x, arg_name = "measure_x", data = data)

          if(deparse(substitute(measure_y))[1] != "NULL")
               measure_y <- match_variables(call = call_full[[match("measure_y", names(call_full))]], arg = measure_y, arg_name = "measure_y", data = data)

          if(deparse(substitute(rxx))[1] != "NULL")
               rxx <- match_variables(call = call_full[[match("rxx", names(call_full))]], arg = rxx, arg_name = "rxx", data = data)

          if(deparse(substitute(rxx_restricted))[1] != "NULL")
               rxx_restricted <- match_variables(call = call_full[[match("rxx_restricted", names(call_full))]], arg = rxx_restricted, arg_name = "rxx_restricted", data = data)

          if(deparse(substitute(rxx_type))[1] != "NULL")
               rxx_type <- match_variables(call = call_full[[match("rxx_type", names(call_full))]], arg = rxx_type, arg_name = "rxx_type", data = data)

          if(deparse(substitute(k_items_x))[1] != "NULL")
               k_items_x <- match_variables(call = call_full[[match("k_items_x", names(call_full))]], arg = k_items_x, arg_name = "k_items_x", data = data)

          if(deparse(substitute(ryy))[1] != "NULL")
               ryy <- match_variables(call = call_full[[match("ryy", names(call_full))]], arg = ryy, arg_name = "ryy", data = data)

          if(deparse(substitute(ryy_restricted))[1] != "NULL")
               ryy_restricted <- match_variables(call = call_full[[match("ryy_restricted", names(call_full))]], arg = ryy_restricted, arg_name = "ryy_restricted", data = data)

          if(deparse(substitute(ryy_type))[1] != "NULL")
               ryy_type <- match_variables(call = call_full[[match("ryy_type", names(call_full))]], arg = ryy_type, arg_name = "ryy_type", data = data)

          if(deparse(substitute(k_items_y))[1] != "NULL")
               k_items_y <- match_variables(call = call_full[[match("k_items_y", names(call_full))]], arg = k_items_y, arg_name = "k_items_y", data = data)

          if(deparse(substitute(ux))[1] != "NULL")
               ux <- match_variables(call = call_full[[match("ux", names(call_full))]], arg = ux, arg_name = "ux", data = data)

          if(deparse(substitute(ux_observed))[1] != "NULL")
               ux_observed <- match_variables(call = call_full[[match("ux_observed", names(call_full))]], arg = ux_observed, arg_name = "ux_observed", data = data)

          if(deparse(substitute(uy))[1] != "NULL")
               uy <- match_variables(call = call_full[[match("uy", names(call_full))]], arg = uy, arg_name = "uy", data = data)

          if(deparse(substitute(uy_observed))[1] != "NULL")
               uy_observed <- match_variables(call = call_full[[match("uy_observed", names(call_full))]], arg = uy_observed, arg_name = "uy_observed", data = data)

          if(deparse(substitute(moderators))[1] != "NULL" & deparse(substitute(moderators))[1] != ".psychmeta_reserved_internal_mod_aabbccddxxyyzz")
                  moderators <- match_variables_df({{moderators}}, data = as_tibble(data, .name_repair = "minimal"), name = deparse(substitute(moderators)))
     }

     if(!moderated_ads) moderators <- NULL

     if(is.null(sample_id)) sample_id <- as.character(sample_id)
     null_construct_x <- is.null(construct_x)
     null_construct_y <- is.null(construct_y)
     if(null_construct_x) construct_x <- "X"
     if(null_construct_y) construct_y <- "Y"
     construct_x <- as.character(construct_x)
     construct_y <- as.character(construct_y)
     if(!is.null(measure_x)) measure_x <- as.character(measure_x)
     if(!is.null(measure_y)) measure_y <- as.character(measure_y)
     rxx_type <- as.character(rxx_type)
     ryy_type <- as.character(ryy_type)

     if(!is.null(moderators)){
          if(is.null(dim(moderators))){
               moderators <- as.data.frame(moderators, stringsAsFactors = FALSE)
               colnames(moderators) <- "Moderator"
          }

          moderator_names <- list(all = colnames(moderators),
                                  cat = colnames(moderators)[cat_moderators],
                                  noncat = colnames(moderators)[!cat_moderators])
          moderator_names <- lapply(moderator_names, function(x) if(length(x) == 0){NULL}else{x})

          if(any(cat_moderators)){
               moderator_levels <- lapply(as_tibble(moderators)[,cat_moderators], function(x){
                    lvls <- levels(x)
                    if(is.null(lvls)) lvls <- levels(factor(x))
                    lvls
               })
               names(moderator_levels) <- colnames(as_tibble(moderators, .name_repair = "minimal")[,cat_moderators])
          }else{
               moderator_levels <- NULL
          }

          moderators <- as.data.frame(moderators, stringsAsFactors = FALSE)
     }else{
          moderator_names <- list(all = NULL,
                                  cat = NULL,
                                  noncat = NULL)

          moderator_levels <- NULL
     }
     
     if(!inherits(intercor, "control_intercor")){
          if(is.list(intercor)){
               intercor <- do.call(control_intercor, args = intercor)
          }else{
               intercor <- control_intercor(sample_id = sample_id,
                                            construct_x = construct_x,
                                            construct_y = construct_y,
                                            construct_names = unique(c(construct_x, construct_y)),
                                            intercor_vec = intercor)
          }
     }

     full_data <- list(sample_id = sample_id, n = n,
                       construct_x = construct_x, facet_x = facet_x, measure_x = measure_x,
                       construct_y = construct_y, facet_y = facet_y, measure_y = measure_y,
                       rxx = rxx, rxx_restricted = rxx_restricted, rxx_type = rxx_type, k_items_x = k_items_x,
                       ryy = ryy, ryy_restricted = ryy_restricted, ryy_type = ryy_type, k_items_y = k_items_y,
                       ux = ux, ux_observed = ux_observed,
                       uy = uy, uy_observed = uy_observed)

     if(is.null(measure_x)) full_data$measure_x <- "No measure specified"
     if(is.null(measure_y)) full_data$measure_y <- "No measure specified"

     .n <- max(unlist(lapply(full_data, length)))
     for(i in names(full_data)) if(is.null(full_data[[i]])) full_data[[i]] <- rep(NA, .n)
     if(any(is.na(full_data$measure_x))) full_data$measure_x[is.na(full_data$measure_x)] <- "No measure specified"
     if(any(is.na(full_data$measure_y))) full_data$measure_y[is.na(full_data$measure_y)] <- "No measure specified"
     if(is.null(full_data$facet_x)) full_data$facet_x <- NA
     if(is.null(full_data$facet_y)) full_data$facet_y <- NA
     full_data <- data.frame(full_data, stringsAsFactors = FALSE)
     if(is.null(sample_id)) full_data$sample_id <- 1:nrow(full_data)

     valid_intercor <- !is.na(full_data$facet_x) | !is.na(full_data$facet_y)
     if(any(valid_intercor)){
          global_info <- identify_global(sample_id = full_data$sample_id,
                                         construct_x = full_data$construct_x, construct_y = full_data$construct_y,
                                         facet_x = full_data$facet_x, facet_y = full_data$facet_y,
                                         measure_x = full_data$measure_x, measure_y = full_data$measure_y)
          retain <- global_info$retain
          global_x <- tolower(full_data$facet_x) %in% c("overall", "global", "total")
          global_y <- tolower(full_data$facet_y) %in% c("overall", "global", "total")
          global_x[is.na(global_x)] <- global_y[is.na(global_y)] <- FALSE
          valid_facet <- valid_facet & !(global_x | global_y)

          .full_data <- as_tibble(full_data, .name_repair = "minimal")[valid_intercor,]
          .full_data$construct_x[!is.na(.full_data$facet_x)] <- paste0(.full_data$construct_x[!is.na(.full_data$facet_x)], ": ", .full_data$facet_x[!is.na(.full_data$facet_x)])
          .full_data$construct_y[!is.na(.full_data$facet_y)] <- paste0(.full_data$construct_y[!is.na(.full_data$facet_y)], ": ", .full_data$facet_y[!is.na(.full_data$facet_y)])
          full_data <- data.frame(rbind(as_tibble(full_data, .name_repair = "minimal")[retain,], .full_data), stringsAsFactors = FALSE)
     }

     additional_args <- NULL
     additional_args <- list(...)

     ma_arg_list <- list(ad_type = ad_type,
                         intercor = intercor, collapse_method = collapse_method, check_dependence = check_dependence,
                         estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi,
                         estimate_ux = estimate_ux, estimate_ut = estimate_ut,
                         var_unbiased = var_unbiased,
                         process_ads = process_ads, supplemental_ads = supplemental_ads, pairwise_ads = pairwise_ads)

     .out <- ma_wrapper(es_data = full_data, es_type = "artifact", ma_type = "bb", ma_fun = .ma_artifacts,
                        moderator_matrix = moderators, moderator_type = moderator_type, cat_moderators = cat_moderators,

                        ma_arg_list = ma_arg_list,
                        presorted_data = additional_args$presorted_data, analysis_id_variables = additional_args$analysis_id_variables,
                        moderator_levels = moderator_levels, moderator_names = moderator_names)

     .out$escalc <- .out$moderator_info <- NULL
     .out <- bind_cols(analysis_id = 1:nrow(.out), .out)

     if(pairwise_ads){
          .artifact_org_pair <- function(dat, construct_order = NULL){
               ad_list_names <- names(dat$meta_tables[[1]])
               construct_x <- unlist(lapply(strsplit(x = names(dat$meta_tables[[1]][[1]]), split = ", construct: "), function(x) x[2]))
               construct_y <- unlist(lapply(strsplit(x = names(dat$meta_tables[[1]][[2]]), split = ", construct: "), function(x) x[2]))

               out <- NULL
               for(i in 1:length(construct_x)){
                    .dat <- dat

                    construct_pair <- c(construct_x[i], construct_y[i])
                    if(!is.null(construct_order)){
                         construct_pair <- as.character(sort(factor(construct_pair, levels = construct_order)))
                    }

                    .dat <- bind_cols(construct_x = construct_pair[1],
                                      construct_y = construct_pair[2],
                                      dplyr::rename(.dat, ad_x = .data[["meta_tables"]]))
                    .dat$ad_y <- .dat$ad_x

                    if(construct_pair[1] == construct_x[i]){
                         .dat$ad_x[[1]] <- .dat$ad_x[[1]][[1]][[i]]
                         .dat$ad_y[[1]] <- .dat$ad_y[[1]][[2]][[i]]
                    }else{
                         .dat$ad_x[[1]] <- .dat$ad_x[[1]][[2]][[i]]
                         .dat$ad_y[[1]] <- .dat$ad_y[[1]][[1]][[i]]
                    }

                    out <- bind_rows(out, .dat)
               }
               out
          }
          dat <- .out[1,]

          out <- .out %>% group_by(.data$analysis_id) %>% do(.artifact_org_pair(dat = .data, construct_order = construct_order))
          if(!is.null(construct_order)){
               out$construct_x <- factor(out$construct_x, levels = construct_order)
               out$construct_y <- factor(out$construct_y, levels = construct_order)
          }
          out <- arrange(out, construct_x, construct_y)
     }else{
          .artifact_org_single <- function(dat){
               constructs <- names(dat$meta_tables[[1]])
               out <- NULL
               for(construct in constructs){
                    .dat <- dat
                    .dat <- bind_cols(construct_x = construct, dplyr::rename(.dat, ad_x = .data[["meta_tables"]]))
                    .dat$ad_x[[1]] <- .dat$ad_x[[1]][[construct]]
                    out <- bind_rows(out, .dat)
               }
               out
          }
          out <- .out %>% group_by(.data$analysis_id) %>% do(.artifact_org_single(dat = .data))
          if(!is.null(construct_order)){
               out$construct_x <- factor(out$construct_x, levels = construct_order)
          }
          out <- arrange(out, construct_x)
     }
     out <- ungroup(out)
     out$analysis_id <- NULL

     attributes(out) <- append(attributes(out), list(call_history = list(call),
                                                     warnings = clean_warning(warn_obj1 = warn_obj1, warn_obj2 = record_warnings()),
                                                     fyi = NULL))

     class(out) <- c("ad_tibble", class(out))

     return(out)
}


#' @rdname create_ad_tibble
#' @export
create_ad_list <- create_ad_tibble


#' Internal function for computing meta-analyses of artifacts
#'
#' @param data Data frame of bare-bones information.
#' @param ma_arg_list List of arguments to be used in the meta-analysis function.
#'
#' @return A list object containing the results of bare-bones meta-analyses of correlations.
#'
#' @keywords internal
.ma_artifacts <- function(data, ma_arg_list){

     ad_obj <- .create_ad_list_internal(full_data = data,
                                        ad_type = ma_arg_list$ad_type,
                                        intercor = ma_arg_list$intercor,
                                        collapse_method = ma_arg_list$collapse_method,
                                        check_dependence = ma_arg_list$check_dependence,
                                        estimate_rxxa = ma_arg_list$estimate_rxxa,
                                        estimate_rxxi = ma_arg_list$estimate_rxxi,
                                        estimate_ux = ma_arg_list$estimate_ux,
                                        estimate_ut = ma_arg_list$estimate_ut,
                                        var_unbiased = ma_arg_list$var_unbiased,
                                        process_ads = ma_arg_list$process_ads,
                                        supplemental_ads = ma_arg_list$supplemental_ads,
                                        pairwise_ads = ma_arg_list$pairwise_ads)

     list(meta = ad_obj,
          escalc = NULL)

}

.create_ad_list_internal <- function(full_data, intercor, collapse_method, check_dependence,
                                     estimate_rxxa, estimate_rxxi,
                                     estimate_ux, estimate_ut, var_unbiased,
                                     process_ads, supplemental_ads, pairwise_ads = pairwise_ads, ad_type){

     full_data <- as.data.frame(ungroup(full_data), stringsAsFactors = FALSE)
     sample_id <- full_data$sample_id
     construct_x <- full_data$construct_x
     construct_y <- full_data$construct_y

     construct_pair <- paste0("X = ", construct_x, ", Y = ", construct_y)
     data_x <- full_data[,c("sample_id", "n", "construct_x", "measure_x", "rxx", "rxx_restricted", "rxx_type", "k_items_x", "ux", "ux_observed")]
     data_y <- full_data[,c("sample_id", "n", "construct_y", "measure_y", "ryy", "ryy_restricted", "ryy_type", "k_items_y", "uy", "uy_observed")]
     colnames(data_y) <- colnames(data_x)

     ..create_ad_list_internal <- function(index){

          by(1:length(construct_pair), index, function(i){

               if(!is.null(sample_id) & check_dependence){

                    independent_arts <- by(1:length(i), full_data$sample_id[i], function(j){

                         .data <- full_data[i,][j,]

                         measure_averages <- by(.data, .data$measure_x, function(x){
                              out <- x[1,]
                              out$n <- mean(x$n, na.rm = TRUE)
                              if(all(is.na(x$n))){
                                   out$rxx <- mean(x$rxx, na.rm = TRUE)
                                   out$rxx_restricted <- as.logical(mean(x$rxx_restricted, na.rm = TRUE))
                                   out$rxx_type <- convert_consistency2reltype(consistency = as.logical(mean(convert_reltype2consistency(rel_type = x$rxx_type), na.rm = TRUE)))
                                   out$k_items_x <- suppressWarnings(mean(x$k_items_x, na.rm = TRUE))
                                   out$ux <- mean(x$ux, na.rm = TRUE)
                                   out$ux_observed <- as.logical(mean(x$ux_observed), na.rm = TRUE)
                              }else{
                                   out$rxx <- wt_mean(x = x$rxx)
                                   out$rxx_restricted <- as.logical(wt_mean(x = x$rxx_restricted, wt = x$n))
                                   out$rxx_type <- convert_consistency2reltype(consistency = as.logical(wt_mean(x = convert_reltype2consistency(rel_type = x$rxx_type), wt = x$n)))
                                   out$k_items_x <- suppressWarnings(wt_mean(x = x$k_items_x, wt = x$n))
                                   out$ux <- wt_mean(x = x$ux, wt = x$n)
                                   out$ux_observed <- as.logical(wt_mean(x = x$ux_observed, wt = x$n))
                              }
                              out
                         })

                         .data <- do.call(rbind, measure_averages)

                         if(nrow(.data) > 1){
                              if(collapse_method == "composite"){
                                   if(length(intercor) > 1){
                                        if(is.null(names(intercor))) stop("The values in the intercor vector must be named", call. = FALSE)

                                        .intercor <- intercor[paste(as.character(.data$sample_id)[1], as.character(.data$construct_x)[1])]
                                        if(is.na(.intercor)) .intercor <- intercor[as.character(.data$construct_x)[1]]

                                   }else{
                                        .intercor <- intercor
                                   }
                                   if(!is.na(.intercor)){
                                        n <- mean(.data$n, na.rm = TRUE)
                                        if(all(is.na(.data$n))){
                                             rxx <- composite_rel_scalar(mean_rel = mean(.data$rxx, na.rm = TRUE), k_vars = sum(!is.na(.data$rxx)), mean_intercor = .intercor)
                                             rxx_restricted <- as.logical(mean(x = .data$rxx_restricted, na.rm = TRUE))
                                             rxx_type <- convert_consistency2reltype(consistency = as.logical(mean(convert_reltype2consistency(rel_type = .data$rxx_type), na.rm = TRUE)))
                                             k_items_x <- suppressWarnings(mean(.data$k_items_x, na.rm = TRUE))
                                             ux  <- composite_u_scalar(mean_u = mean(.data$ux, na.rm = TRUE), k_vars = sum(!is.na(.data$ux)), mean_ri = .intercor)
                                             ux_observed <- as.logical(mean(.data$ux_observed, na.rm = TRUE))
                                        }else{
                                             rxx <- composite_rel_scalar(mean_rel = wt_mean(x = .data$rxx, wt = .data$n), k_vars = sum(!is.na(.data$rxx) & !is.na(.data$n)), mean_intercor = .intercor)
                                             rxx_restricted <- as.logical(wt_mean(x = .data$rxx_restricted, wt = .data$n))
                                             rxx_type <- convert_consistency2reltype(consistency = as.logical(wt_mean(x = convert_reltype2consistency(rel_type = .data$rxx_type), wt = .data$n)))
                                             k_items_x <- wt_mean(x = .data$k_items_x, wt = .data$n)
                                             ux  <- composite_u_scalar(mean_u = wt_mean(x = .data$ux, wt = .data$n), k_vars = sum(!is.na(.data$ux) & !is.na(.data$n)), mean_ri = .intercor)
                                             ux_observed <- as.logical(wt_mean(x = .data$ux_observed, wt = .data$n))
                                        }
                                   }else{
                                        warning("Valid same-construct intercorrelation not provided for construct'", as.character(.data$construct_x)[1],
                                                "' in sample '", .data$sample_id[1],
                                                "': '\n     Computing average instead of composite", call. = FALSE)

                                        n <- mean(.data$n, na.rm = TRUE)
                                        if(all(is.na(.data$n))){
                                             rxx <- mean(.data$rxx, na.rm = TRUE)
                                             rxx_restricted <- as.logical(mean(x = .data$rxx_restricted, na.rm = TRUE))
                                             rxx_type <- convert_consistency2reltype(consistency = as.logical(mean(convert_reltype2consistency(rel_type = .data$rxx_type), na.rm = TRUE)))
                                             k_items_x <- suppressWarnings(mean(.data$k_items_x, na.rm = TRUE))
                                             ux  <- mean(.data$ux, na.rm = TRUE)
                                             ux_observed <- as.logical(mean(.data$ux_observed, na.rm = TRUE))
                                        }else{
                                             n <- mean(.data$n, na.rm = TRUE)
                                             rxx <- wt_mean(x = .data$rxx, wt = .data$n)
                                             rxx_restricted <- as.logical(wt_mean(x = .data$rxx_restricted, wt = .data$n))
                                             rxx_type <- convert_consistency2reltype(consistency = as.logical(wt_mean(x = convert_reltype2consistency(rel_type = .data$rxx_type), wt = .data$n)))
                                             k_items_x <- wt_mean(x = .data$k_items_x, wt = .data$n)
                                             ux  <- wt_mean(x = .data$ux, wt = .data$n)
                                             ux_observed <- as.logical(wt_mean(x = .data$ux_observed, wt = .data$n))
                                        }
                                   }
                              }else if(collapse_method == "average"){
                                   n <- mean(.data$n, na.rm = TRUE)
                                   if(all(is.na(.data$n))){
                                        rxx <- mean(.data$rxx, na.rm = TRUE)
                                        rxx_restricted <- as.logical(mean(x = .data$rxx_restricted, na.rm = TRUE))
                                        rxx_type <- convert_consistency2reltype(consistency = as.logical(mean(convert_reltype2consistency(rel_type = .data$rxx_type), na.rm = TRUE)))
                                        k_items_x <- suppressWarnings(mean(.data$k_items_x, na.rm = TRUE))
                                        ux  <- mean(.data$ux, na.rm = TRUE)
                                        ux_observed <- as.logical(mean(.data$ux_observed, na.rm = TRUE))
                                   }else{
                                        n <- mean(.data$n, na.rm = TRUE)
                                        rxx <- wt_mean(x = .data$rxx, wt = .data$n)
                                        rxx_restricted <- as.logical(wt_mean(x = .data$rxx_restricted, wt = .data$n))
                                        rxx_type <- convert_consistency2reltype(consistency = as.logical(wt_mean(x = convert_reltype2consistency(rel_type = .data$rxx_type), wt = .data$n)))
                                        k_items_x <- wt_mean(x = .data$k_items_x, wt = .data$n)
                                        ux  <- wt_mean(x = .data$ux, wt = .data$n)
                                        ux_observed <- as.logical(wt_mean(x = .data$ux_observed, wt = .data$n))
                                   }
                              }
                         }else{
                              n <- as.numeric(.data$n)
                              rxx <- as.numeric(.data$rxx)
                              rxx_restricted <- as.logical(.data$rxx_restricted)
                              rxx_type <- as.character(.data$rxx_type)
                              k_items_x <- suppressWarnings(as.numeric(.data$k_items_x))
                              ux  <- as.numeric(.data$ux)
                              ux_observed <- as.logical(.data$ux_observed)
                         }

                         list(n = n,
                              rxx = rxx,
                              rxx_restricted = rxx_restricted,
                              rxx_type = rxx_type,
                              k_items_x = k_items_x,
                              ux = ux,
                              ux_observed = ux_observed)
                    })

                    n              <- unlist(lapply(independent_arts, function(x) x$n))
                    rxx            <- unlist(lapply(independent_arts, function(x) x$rxx))
                    rxx_restricted <- unlist(lapply(independent_arts, function(x) x$rxx_restricted))
                    rxx_type       <- unlist(lapply(independent_arts, function(x) x$rxx_type))
                    k_items_x      <- unlist(lapply(independent_arts, function(x) x$k_items_x))
                    ux             <- unlist(lapply(independent_arts, function(x) x$ux))
                    ux_observed    <- unlist(lapply(independent_arts, function(x) x$ux_observed))
               }else{
                    n <- full_data$n[i]
                    rxx <- full_data$rxx[i]
                    rxx_restricted <- full_data$rxx_restricted[i]
                    rxx_type <- full_data$rxx_type[i]
                    k_items_x <- full_data$k_items_x[i]
                    ux <- full_data$ux[i]
                    ux_observed <- full_data$ux_observed[i]
               }

               rxxa <-   if(!is.null(rxx)){if(any(!rxx_restricted)){rxx[!rxx_restricted]}else{NULL}}else{NULL}
               n_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){n[!rxx_restricted]}else{NULL}}else{NULL}
               rxxi <-   if(!is.null(rxx)){if(any(rxx_restricted)){rxx[rxx_restricted]}else{NULL}}else{NULL}
               n_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){n[rxx_restricted]}else{NULL}}else{NULL}
               ux <-     if(!is.null(ux)){if(any(ux_observed)){ux[ux_observed]}else{NULL}}else{NULL}
               n_ux <-   if(!is.null(ux)){if(any(ux_observed)){n[ux_observed]}else{NULL}}else{NULL}
               ut <-     if(!is.null(ux)){if(any(!ux_observed)){ux[!ux_observed]}else{NULL}}else{NULL}
               n_ut <-   if(!is.null(ux)){if(any(!ux_observed)){n[!ux_observed]}else{NULL}}else{NULL}

               rxxi_type <- if(!is.null(rxx)){if(any(rxx_restricted)){rxx_type[rxx_restricted]}else{NULL}}else{NULL}
               rxxa_type <- if(!is.null(rxx)){if(any(!rxx_restricted)){rxx_type[!rxx_restricted]}else{NULL}}else{NULL}
               k_items_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){k_items_x[rxx_restricted]}else{NULL}}else{NULL}
               k_items_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){k_items_x[!rxx_restricted]}else{NULL}}else{NULL}

               if(!is.null(rxxa)){
                    rxxa_type <- rxxa_type[!is.na(rxxa)]
                    n_rxxa <- n_rxxa[!is.na(rxxa)]
                    k_items_rxxa <- k_items_rxxa[!is.na(rxxa)]
                    rxxa <- rxxa[!is.na(rxxa)]
               }else{
                    k_items_rxxa <- rxxa_type <- n_rxxa <- rxxa <- NULL
               }

               if(!is.null(rxxi)){
                    rxxi_type <- rxxi_type[!is.na(rxxi)]
                    n_rxxi <- n_rxxi[!is.na(rxxi)]
                    k_items_rxxi <- k_items_rxxi[!is.na(rxxi)]
                    rxxi <- rxxi[!is.na(rxxi)]
               }else{
                    k_items_rxxi <- rxxi_type <- n_rxxi <- rxxi <- NULL
               }

               if(!is.null(ux)){
                    n_ux <- n_ux[!is.na(ux)]
                    ux <- ux[!is.na(ux)]
               }else{
                    n_ux <- ux <- NULL
               }

               if(!is.null(ut)){
                    n_ut <- n_ut[!is.na(ut)]
                    ut <- ut[!is.na(ut)]
               }else{
                    n_ut <- ut <- NULL
               }

               if(!is.null(supplemental_ads)){
                    if(full_data$construct_x[i][1] %in% names(supplemental_ads)){
                         .supplemental_ads <- supplemental_ads[[full_data$construct_x[i][1]]]
                    }else{
                         .supplemental_ads <- NULL
                    }
               }else{
                    .supplemental_ads <- NULL
               }

               if(all(is.na(n_rxxa))){
                    wt_rxxa <- rep(1, length(n_rxxa))
               }else{
                    wt_rxxa <- n_rxxa
               }

               if(all(is.na(n_rxxi))){
                    wt_rxxi <- rep(1, length(n_rxxi))
               }else{
                    wt_rxxi <- n_rxxi
               }

               if(all(is.na(n_ux))){
                    wt_ux <- rep(1, length(n_ux))
               }else{
                    wt_ux <- n_ux
               }

               if(all(is.na(n_ut))){
                    wt_ut <- rep(1, length(n_ut))
               }else{
                    wt_ut <- n_ut
               }

               ad_obj <- suppressWarnings(create_ad_supplemental(ad_type = ad_type,
                                                                 rxxa = rxxa, n_rxxa = n_rxxa, wt_rxxa = wt_rxxa, rxxa_type = rxxa_type, k_items_rxxa = k_items_rxxa,
                                                                 rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = wt_rxxi, rxxi_type = rxxi_type, k_items_rxxi = k_items_rxxi,
                                                                 ux = ux, ni_ux = n_ux, wt_ux = wt_ux,
                                                                 ut = ut, ni_ut = n_ut, wt_ut = wt_ut,
                                                                 estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi,
                                                                 estimate_ux = estimate_ux, estimate_ut = estimate_ut,
                                                                 var_unbiased = var_unbiased, supplemental_ads = .supplemental_ads, process_ads = process_ads))

               list(ad_obj = ad_obj,
                    construct = as.character(full_data$construct_x[i][1]))
          })
     }

     if(pairwise_ads){
          full_data <- data_x
          .ad_obj_list_x <- ..create_ad_list_internal(index = construct_pair)
          ad_obj_list_x <- list()
          for(i in 1:length(.ad_obj_list_x)) ad_obj_list_x[[i]] <- .ad_obj_list_x[[i]][[1]]
          names(ad_obj_list_x) <- as.character(lapply(.ad_obj_list_x, function(x) x[[2]]))
          class(ad_obj_list_x) <- c("ad_list", class(ad_obj_list_x))

          full_data <- data_y
          .ad_obj_list_y <- ..create_ad_list_internal(index = construct_pair)
          ad_obj_list_y <- list()
          for(i in 1:length(.ad_obj_list_y)) ad_obj_list_y[[i]] <- .ad_obj_list_y[[i]][[1]]
          names(ad_obj_list_y) <- as.character(lapply(.ad_obj_list_y, function(x) x[[2]]))
          class(ad_obj_list_y) <- c("ad_list", class(ad_obj_list_y))

          names(ad_obj_list_x) <- paste0("pair_id: ", 1:length(ad_obj_list_x), ", construct: ", names(ad_obj_list_x))
          names(ad_obj_list_y) <- paste0("pair_id: ", 1:length(ad_obj_list_y), ", construct: ", names(ad_obj_list_y))

          ad_obj_list <- list(ad_list_x = ad_obj_list_x,
                              ad_list_y = ad_obj_list_y)
     }else{
          full_data <- rbind(data_x, data_y)
          construct_pair <- c(construct_pair, construct_pair)
          .ad_obj_list <- ..create_ad_list_internal(index = full_data$construct_x)

          ad_obj_list <- list()
          for(i in 1:length(.ad_obj_list)) ad_obj_list[[i]] <- .ad_obj_list[[i]][[1]]
          names(ad_obj_list) <- as.character(lapply(.ad_obj_list, function(x) x[[2]]))
     }
     class(ad_obj_list) <- c("ad_list", class(ad_obj_list))

     ad_obj_list
}


## Internal function to harvest lists of artifact distributions from dataframes matching a known, internally imposed structure
.create_ad_list <- function(ad_type = c("tsa", "int"), sample_id, construct_x, construct_y, construct_pair, es_data, data_x, data_y, pairwise_ads = FALSE,
                            estimate_rxxa = TRUE, estimate_rxxi = TRUE, estimate_ux = TRUE, estimate_ut = TRUE,
                            var_unbiased = TRUE, supplemental_ads = NULL, process_ads = TRUE, ...){

     ad_type <- match.arg(ad_type, c("tsa", "int"))

     additional_args <- list(...)
     if(!is.null(additional_args$estimate_rxxa))
          estimate_rxxa <- additional_args$estimate_rxxa
     if(!is.null(additional_args$estimate_rxxi))
          estimate_rxxi <- additional_args$estimate_rxxi
     if(!is.null(additional_args$estimate_ux))
          estimate_ux <- additional_args$estimate_ux
     if(!is.null(additional_args$estimate_ut))
          estimate_ut <- additional_args$estimate_ut
     if(is.null(estimate_rxxa)) estimate_rxxa <- TRUE
     if(is.null(estimate_rxxi)) estimate_rxxi <- TRUE
     if(is.null(estimate_ux)) estimate_ux <- TRUE
     if(is.null(estimate_ut)) estimate_ut <- TRUE

     if(pairwise_ads){
          if(!is.null(sample_id)){
               unique_x <- !duplicated(paste(construct_pair, sample_id, construct_x))
               unique_y <- !duplicated(paste(construct_pair, sample_id, construct_y))
          }else{
               unique_x <- unique_y <- rep(TRUE, nrow(data_x))
          }

          data <- data.frame(es_data, data_x, data_y, stringsAsFactors = FALSE)
          ad_obj_list <- by(1:length(construct_pair), construct_pair, function(i){

               if(is.null(construct_x)) data$construct_x <- construct_x[i]
               if(is.null(construct_y)) data$construct_y <- construct_y[i]

               n <- data$n[i][unique_x[i] & unique_y[i]]

               rxx <- data$rxx[i][unique_x[i] & unique_y[i]]
               rxx_restricted <- data$rxx_restricted[i][unique_x[i] & unique_y[i]]
               rxx_type <- data$rxx_type[i][unique_x[i] & unique_y[i]]
               k_items_x <- data$k_items_x[i][unique_x[i] & unique_y[i]]
               ux <- data$ux[i][unique_x[i] & unique_y[i]]
               ux_observed <- data$ux_observed[i][unique_x[i] & unique_y[i]]

               ryy <- data$ryy[i][unique_x[i] & unique_y[i]]
               ryy_restricted <- data$ryy_restricted[i][unique_x[i] & unique_y[i]]
               ryy_type <- data$ryy_type[i][unique_x[i] & unique_y[i]]
               k_items_y <- data$k_items_y[i][unique_x[i] & unique_y[i]]
               uy <- data$uy[i][unique_x[i] & unique_x[i]]
               uy_observed <- data$uy_observed[i][unique_x[i] & unique_y[i]]

               rxxa <-   if(!is.null(rxx)){if(any(!rxx_restricted)){rxx[!rxx_restricted]}else{NULL}}else{NULL}
               n_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){n[!rxx_restricted]}else{NULL}}else{NULL}
               rxxi <-   if(!is.null(rxx)){if(any(rxx_restricted)){rxx[rxx_restricted]}else{NULL}}else{NULL}
               n_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){n[rxx_restricted]}else{NULL}}else{NULL}
               ux <-     if(!is.null(ux)){if(any(ux_observed)){ux[ux_observed]}else{NULL}}else{NULL}
               n_ux <-   if(!is.null(ux)){if(any(ux_observed)){n[ux_observed]}else{NULL}}else{NULL}
               ut <-     if(!is.null(ux)){if(any(!ux_observed)){ux[!ux_observed]}else{NULL}}else{NULL}
               n_ut <-   if(!is.null(ux)){if(any(!ux_observed)){n[!ux_observed]}else{NULL}}else{NULL}

               rxxi_type <- if(!is.null(rxx)){if(any(rxx_restricted)){rxx_type[rxx_restricted]}else{NULL}}else{NULL}
               rxxa_type <- if(!is.null(rxx)){if(any(!rxx_restricted)){rxx_type[!rxx_restricted]}else{NULL}}else{NULL}
               k_items_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){k_items_x[rxx_restricted]}else{NULL}}else{NULL}
               k_items_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){k_items_x[!rxx_restricted]}else{NULL}}else{NULL}


               ryya <-   if(!is.null(ryy)){if(any(!ryy_restricted)){ryy[!ryy_restricted]}else{NULL}}else{NULL}
               n_ryya <- if(!is.null(ryy)){if(any(!ryy_restricted)){n[!ryy_restricted]}else{NULL}}else{NULL}
               ryyi <-   if(!is.null(ryy)){if(any(ryy_restricted)){ryy[ryy_restricted]}else{NULL}}else{NULL}
               n_ryyi <- if(!is.null(ryy)){if(any(ryy_restricted)){n[ryy_restricted]}else{NULL}}else{NULL}
               uy <-     if(!is.null(uy)){if(any(uy_observed)){uy[uy_observed]}else{NULL}}else{NULL}
               n_uy <-   if(!is.null(uy)){if(any(uy_observed)){n[uy_observed]}else{NULL}}else{NULL}
               up <-     if(!is.null(uy)){if(any(!uy_observed)){uy[!uy_observed]}else{NULL}}else{NULL}
               n_up <-   if(!is.null(uy)){if(any(!uy_observed)){n[!uy_observed]}else{NULL}}else{NULL}

               ryyi_type <- if(!is.null(ryy)){if(any(ryy_restricted)){ryy_type[ryy_restricted]}else{NULL}}else{NULL}
               ryya_type <- if(!is.null(ryy)){if(any(!ryy_restricted)){ryy_type[!ryy_restricted]}else{NULL}}else{NULL}
               k_items_ryyi <- if(!is.null(ryy)){if(any(ryy_restricted)){k_items_y[ryy_restricted]}else{NULL}}else{NULL}
               k_items_ryya <- if(!is.null(ryy)){if(any(!ryy_restricted)){k_items_y[!ryy_restricted]}else{NULL}}else{NULL}

               if(!is.null(supplemental_ads)){
                    if(construct_x[i][1] %in% names(supplemental_ads)){
                         .supplemental_ads_x <- supplemental_ads[[construct_x[i][1]]]
                    }else{
                         .supplemental_ads_x <- NULL
                    }

                    if(construct_y[i][1] %in% names(supplemental_ads)){
                         .supplemental_ads_y <- supplemental_ads[[construct_y[i][1]]]
                    }else{
                         .supplemental_ads_y <- NULL
                    }
               }else{
                    .supplemental_ads_x <- .supplemental_ads_y <- NULL
               }


               ad_obj_x <- suppressWarnings(create_ad_supplemental(ad_type = ad_type,
                                                                   rxxa = rxxa, n_rxxa = n_rxxa, wt_rxxa = n_rxxa, k_items_rxxa = k_items_rxxa, rxxa_type = rxxa_type,
                                                                   rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = n_rxxi, k_items_rxxi = k_items_rxxi, rxxi_type = rxxi_type,
                                                                   ux = ux, ni_ux = n_ux, wt_ux = n_ux,
                                                                   ut = ut, ni_ut = n_ut, wt_ut = n_ut,
                                                                   estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi,
                                                                   estimate_ux = estimate_ux, estimate_ut = estimate_ut,
                                                                   var_unbiased = var_unbiased, supplemental_ads = .supplemental_ads_x, process_ads = process_ads))

               ad_obj_y <- suppressWarnings(create_ad_supplemental(ad_type = ad_type,
                                                                   rxxa = ryya, n_rxxa = n_ryya, wt_rxxa = n_ryya, k_items_rxxa = k_items_ryyi, rxxa_type = ryya_type,
                                                                   rxxi = ryyi, n_rxxi = n_ryyi, wt_rxxi = n_ryyi, k_items_rxxi = k_items_ryya, rxxi_type = ryyi_type,
                                                                   ux = uy, ni_ux = n_uy, wt_ux = n_uy,
                                                                   ut = up, ni_ut = n_up, wt_ut = n_up,
                                                                   estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi,
                                                                   estimate_ux = estimate_ux, estimate_ut = estimate_ut,
                                                                   var_unbiased = var_unbiased, supplemental_ads = .supplemental_ads_y, process_ads = process_ads))

               list(ad_obj_x = ad_obj_x, ad_obj_y = ad_obj_y)
          })
     }else{
          if(!is.null(sample_id)){
               unique_x <- !duplicated(paste(c(sample_id, sample_id), c(construct_x, construct_y)))
          }else{
               unique_x <- rep(TRUE, nrow(data_x) + nrow(data_y))
          }

          es_data <- rbind(es_data, es_data)
          colnames(data_y) <- colnames(data_x)
          data_x <- rbind(data_x, data_y)
          construct_pair <- c(construct_pair, construct_pair)
          construct_x <- c(construct_x, construct_y)

          ad_obj_list_x <- ad_obj_list_y <- by(1:length(construct_pair), construct_x, function(i){

               data <- data.frame(es_data[i,], data_x[i,], data_y[i,], stringsAsFactors = FALSE)
               if(!is.null(construct_x)) data <- data.frame(data, construct_x = construct_x[i], stringsAsFactors = FALSE)

               n <- es_data$n[i][unique_x[i]]

               rxx <- data_x$rxx[i][unique_x[i]]
               rxx_restricted <- data_x$rxx_restricted[i][unique_x[i]]
               k_items_x <- data$k_items_x[i][unique_x[i]]
               rxx_type <- data_x$rxx_type[i][unique_x[i]]
               ux <- data_x$ux[i][unique_x[i]]
               ux_observed <- data_x$ux_observed[i][unique_x[i]]

               rxxa <-   if(!is.null(rxx)){if(any(!rxx_restricted)){rxx[!rxx_restricted]}else{NULL}}else{NULL}
               n_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){n[!rxx_restricted]}else{NULL}}else{NULL}
               rxxi <-   if(!is.null(rxx)){if(any(rxx_restricted)){rxx[rxx_restricted]}else{NULL}}else{NULL}
               n_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){n[rxx_restricted]}else{NULL}}else{NULL}
               ux <-     if(!is.null(ux)){if(any(ux_observed)){ux[ux_observed]}else{NULL}}else{NULL}
               n_ux <-   if(!is.null(ux)){if(any(ux_observed)){n[ux_observed]}else{NULL}}else{NULL}
               ut <-     if(!is.null(ux)){if(any(!ux_observed)){ux[!ux_observed]}else{NULL}}else{NULL}
               n_ut <-   if(!is.null(ux)){if(any(!ux_observed)){n[!ux_observed]}else{NULL}}else{NULL}

               rxxi_type <- if(!is.null(rxx)){if(any(rxx_restricted)){rxx_type[rxx_restricted]}else{NULL}}else{NULL}
               rxxa_type <- if(!is.null(rxx)){if(any(!rxx_restricted)){rxx_type[!rxx_restricted]}else{NULL}}else{NULL}
               k_items_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){k_items_x[rxx_restricted]}else{NULL}}else{NULL}
               k_items_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){k_items_x[!rxx_restricted]}else{NULL}}else{NULL}

               if(!is.null(supplemental_ads)){
                    if(construct_x[i][1] %in% names(supplemental_ads)){
                         .supplemental_ads_x <- supplemental_ads[[construct_x[i][1]]]
                    }else{
                         .supplemental_ads_x <- NULL
                    }
               }else{
                    .supplemental_ads_x <- NULL
               }

               ad_obj_x <- suppressWarnings(create_ad_supplemental(ad_type = ad_type,
                                                                   rxxa = rxxa, n_rxxa = n_rxxa, wt_rxxa = n_rxxa, k_items_rxxa = k_items_rxxa, rxxa_type = rxxa_type,
                                                                   rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = n_rxxi, k_items_rxxi = k_items_rxxi, rxxi_type = rxxi_type,
                                                                   ux = ux, ni_ux = n_ux, wt_ux = n_ux,
                                                                   ut = ut, ni_ut = n_ut, wt_ut = n_ut,
                                                                   estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi,
                                                                   estimate_ux = estimate_ux, estimate_ut = estimate_ut,
                                                                   var_unbiased = var_unbiased, supplemental_ads = .supplemental_ads_x, process_ads = process_ads))
               list(ad_obj_x = ad_obj_x)
          })

          construct_pair_mat <- cbind(construct_pair, construct_x, construct_y)
          rownames(construct_pair_mat) <- construct_pair

          construct_pair_lvls <- levels(factor(construct_pair))
          construct_pair_mat <- construct_pair_mat[construct_pair_lvls,]
          if(is.null(dim(construct_pair_mat))){
               construct_pair_mat <- t(construct_pair_mat)
               rownames(construct_pair_mat) <- construct_pair_lvls
          }

          ad_obj_list <- list()
          for(i in construct_pair_lvls){
               ad_obj_list[[i]] <- list(ad_obj_x = ad_obj_list_x[[construct_pair_mat[i,2]]],
                                        ad_obj_y = ad_obj_list_y[[construct_pair_mat[i,3]]])
               attributes(ad_obj_list[[i]][["ad_obj_x"]]) <- attributes(ad_obj_list_x[[construct_pair_mat[i,2]]])
               attributes(ad_obj_list[[i]][["ad_obj_y"]]) <- attributes(ad_obj_list_y[[construct_pair_mat[i,3]]])
          }
          rm(ad_obj_list_x, ad_obj_list_y)
     }

     ad_obj_list
}