tma coverage - 65.67%

Files
Source



# Pull unique sender, receiver, and modality values from a dataframe
get_unique_values <- function(
  df, 
  sender_cols, receiver_cols, 
  mode_column
) {
  # Extract unique values for each sender column
  unique_senders <- lapply(sender_cols, function(col) sort(unique(df[[col]])))
  names(unique_senders) <- sender_cols
  
  # Extract unique values for each receiver column
  unique_receivers <- lapply(receiver_cols, function(col) sort(unique(df[[col]])))
  names(unique_receivers) <- receiver_cols
  
  # Extract unique values for the mode column
  if (length(mode_column) == 0) {
    unique_modes <- list()
  } 
  # else if (mode_column == ATTR_NAMES$CONTEXT_ID) {
  #   unique_modes <- ATTR_NAMES$CONTEXT_ID;
  # }
  else {
    unique_modes <- sort(unique(df[[mode_column]]))
  }
  
  ret_list <- list(
    unique_senders = unique_senders,
    unique_receivers = unique_receivers,
    unique_modes = unique_modes
  )
  
  return(ret_list);
}


#' Generate a multidimensional array for window and weight parameters
#'
#' This function constructs a multidimensional array representing all combinations of sender(s), receiver(s), and mode(s),
#' with an additional axis for weight and window parameters. The resulting array can be used to efficiently look up or modify
#' window and weight values for each unique combination in your data, which is useful for network accumulation and modeling.
#'
#' @param df A data.frame containing the data to extract unique values for senders, receivers, and modes.
#' @param sender_cols Character vector of column names in `df` to use as sender(s). Can be empty or NULL if not applicable.
#' @param receiver_cols Character vector of column names in `df` to use as receiver(s). Can be empty or NULL if not applicable.
#' @param mode_column Character string giving the column name in `df` to use as the mode (e.g., modality, channel). Can be empty or NULL if not applicable.
#' @param default_window Numeric value to use as the default window for all combinations (default: 1).
#' @param default_weight Numeric value to use as the default weight for all combinations (default: 1).
#'
#' @return A multidimensional array with dimensions [sender(s), receiver(s), mode(s), weight/window], where the last axis has two levels: "weight" and "window".
#'         The array is initialized with the default weight and window values, and has named dimensions for easy indexing.
#'
#' @examples
#' df <- data.frame(sender = c("A", "B"), receiver = c("X", "Y"), mode = c("chat", "resource"))
#' arr <- context_tensor(df, sender_cols = "sender", receiver_cols = "receiver", mode_column = "mode")
#' arr["A", "X", "chat", "weight"] # Access the weight for sender A, receiver X, mode chat
#'
#' @export
context_tensor <- function(
  df, 
  sender_cols = NULL, 
  receiver_cols = NULL, 
  mode_column = ATTR_NAMES$CONTEXT_ID, 
  default_window = 1,
  default_weight = 1
) {
  unique_list = get_unique_values(df, sender_cols, receiver_cols, mode_column)
  weight_window_axis <- c("weight", "window");
  
  # Pull out unique senders, receivers, and modes from unique_list
  unique_senders <- unique_list$unique_senders
  unique_receivers <- unique_list$unique_receivers;
  unique_modes <- if(is.factor(unique_list$unique_modes))
      as.numeric(unique_list$unique_modes)
    else unique_list$unique_modes
  ;
  
  # Set dimension indices to unique values
  dim_names <- list()
  for (i in seq_along(sender_cols)) {
    dim_names[[paste0("sender_", i)]] <- unique_senders[[i]]
  }
  for (i in seq_along(receiver_cols)) {
    dim_names[[paste0("receiver_", i)]] <- unique_receivers[[i]]
  }
  if (length(unique_modes) > 0) {
    dim_names[["modes"]] <- unique_modes
  }
  dim_names[["weight_window"]] <- weight_window_axis
   
  # Set dims accordingly s.t. our array is [S, R, M, weight/window]
  dims <- c()
  dims <- c(sapply(unique_senders, length), sapply(unique_receivers, length))
  
  if (length(unique_modes > 0)) { 
    dims <- c(dims, length(unique_modes))
  }
  
  dims <- c(dims, length(weight_window_axis))

  # Init multidimensional array; include sender, receiver, mode columns; default weight; default window as attributes 
  multidim_arr <- array(0, dim = dims, dimnames = dim_names)
  multidim_arr <- array(rep(c(default_weight, default_window), each = prod(unlist(dims))/2), dim = dims, dimnames = dim_names)
  
  si <- seq_along(sender_cols);
  ri <- seq_along(receiver_cols) + ifelse(length(si) > 0, si[length(si)], 0);
  
  if(length(ri) > 0) {
    mi <- seq_along(ri) + ri[length(ri)];
  }
  else {
    mi <- 1;
  }
  
  attr(multidim_arr, "sender_cols") <- sender_cols
  attr(multidim_arr, "receiver_cols") <- receiver_cols
  attr(multidim_arr, "mode_column") <- mode_column
  attr(multidim_arr, "sender_inds") <- si
  attr(multidim_arr, "receiver_inds") <- ri
  attr(multidim_arr, "mode_inds") <- mi
  attr(multidim_arr, "default_window") <- default_window
  attr(multidim_arr, "default_weight") <- default_weight
  
  return(multidim_arr)
}

#' Deprecated Alias for context_tensor
#'
#' Use \code{context_tensor()} instead. This alias will be removed in a future release.
#'
#' @param ... Arguments passed to \code{context_tensor()}.
#' 
#' @return A multidimensional array with dimensions [sender(s), receiver(s), mode(s), weight/window], where the last axis has two levels: "weight" and "window".
#'         The array is initialized with the default weight and window values, and has named dimensions for easy indexing.
#'
#' @seealso \code{\link{context_tensor}}
#' @export
windows_weights <- function(...) {
  .Deprecated("context_tensor", "tma v0.2.0");
  do.call(context_tensor, list(...))
}

# If sender_cols, receiver_cols, or mode_column are empty, have our standin. Be sure to fill in 
# standin as expected in multidim_arr. 
# We do this so we don't fail when they don't specify senders/receivers/mode
preprocess <- function(
  df, 
  multidim_arr,
  use_standin = TRUE
) {
  # Get sender, receiver, and mode columns + unique values from multidim_arr
  sender_cols <- attr(multidim_arr, "sender_cols")
  receiver_cols <- attr(multidim_arr, "receiver_cols")
  mode_column <- attr(multidim_arr, "mode_column")
  
  unique_list = get_unique_values(df, sender_cols, receiver_cols, mode_column)
  # Pull out unique senders, receivers, and modes from unique_list
  unique_senders <- unique_list$unique_senders
  unique_receivers <- unique_list$unique_receivers
  unique_modes <- unique_list$unique_modes
  
  old_unique_senders <- unique_senders
  old_unique_receivers <- unique_receivers
  old_unique_modes <- unique_modes
  if (length(old_unique_senders) == 0) {
    old_unique_senders <- NA  # Placeholder for missing senders
  }
  if (length(old_unique_receivers) == 0) {
    old_unique_receivers <- NA  # Placeholder for missing receivers
  }
  if (length(old_unique_modes) == 0) {
    old_unique_modes <- NA # Placeholder for missing modes
  }
  
  # Ensure standin is present for any empty columns
  if(isTRUE(use_standin)) {
    if (length(sender_cols) == 0) {
      sender_cols <- "standin"
      unique_senders <- list(standin = "standin")
    }
    if (length(receiver_cols) == 0) {
      receiver_cols <- "standin"
      unique_receivers <- list(standin = "standin")
    }
    if (length(mode_column) == 0) {
      mode_column <- "standin"
      unique_modes <- "standin"
    }
  }
  
  # Create a new multidimensional array to hold expanded values
  weight_window_axis = c("weight", "window")
  
  # Construct dimension names dynamically
  dim_names <- list()
  for (i in seq_along(sender_cols)) {
    dim_names[[paste0("sender_", i)]] <- unique_senders[[i]]
  }
  for (i in seq_along(receiver_cols)) {
    dim_names[[paste0("receiver_", i)]] <- unique_receivers[[i]]
  }
  dim_names[["modes"]] <- unique_modes
  dim_names[["weight_window"]] <- weight_window_axis
  
  dims <- c()
  for (i in seq_along(sender_cols)) {
    dims <- c(dims, length(unique_senders[[i]]))
  }
  for (i in seq_along(receiver_cols)) {
    dims <- c(dims, length(unique_receivers[[i]]))
  }
  dims <- c(dims, length(unique_modes), length(weight_window_axis))
  
  new_multidim_arr <- array(0, dim = dims, dimnames = dim_names)
  
  combinations <- expand.grid(
    new_senders = do.call(paste, c(expand.grid(unique_senders), sep = "_")),
    new_receivers = do.call(paste, c(expand.grid(unique_receivers), sep = "_")),
    new_modes = unique_modes,
    old_senders = do.call(paste, c(expand.grid(old_unique_senders), sep = "_")),
    old_receivers = do.call(paste, c(expand.grid(old_unique_receivers), sep = "_")),
    old_modes = old_unique_modes,
    stringsAsFactors = FALSE
  )
  
  combinations <- combinations[
    (# just modality
      (combinations$new_senders == "standin" & combinations$new_receivers == "standin" & combinations$new_modes == combinations$old_modes) | 
        # just sender
        (combinations$new_senders == combinations$old_senders & combinations$new_receivers == "standin" & combinations$new_modes == "standin") | 
        # just receiver
        (combinations$new_senders == "standin" & combinations$new_receivers == combinations$old_receivers & combinations$new_modes == "standin") | 
        # modality + sender
        (combinations$new_senders ==  combinations$old_senders & combinations$new_receivers == "standin" & combinations$new_modes == combinations$old_modes) | 
        # modality + receiver
        (combinations$new_senders == "standin" & combinations$new_receivers == combinations$old_receivers & combinations$new_modes == combinations$old_modes) | 
        # sender + receiver
        (combinations$new_senders == combinations$old_senders & combinations$new_receivers == combinations$old_receivers & combinations$new_modes == "standin") | 
        # modality + sender + receiver
        (combinations$new_senders == combinations$old_senders & combinations$new_receivers == combinations$old_receivers & combinations$new_modes == combinations$old_modes)) 
    ,
  ]
  
  # remove NA rows
  combinations <- combinations[rowSums(is.na(combinations)) < ncol(combinations), ]
  
  for (i in seq_len(nrow(combinations))) {
    new_s <- combinations$new_senders[i]
    new_r <- combinations$new_receivers[i]
    new_m <- combinations$new_modes[i]
    orig_s <- combinations$old_senders[i]
    orig_r <- combinations$old_receivers[i]
    orig_m <- combinations$old_modes[i]
    
    new_index_list <- c(strsplit(new_s, "_")[[1]], strsplit(new_r, "_")[[1]], new_m)
    old_index_list <- c(strsplit(orig_s, "_")[[1]], strsplit(orig_r, "_")[[1]], orig_m)
    old_index_list <- old_index_list[!is.na(old_index_list) & old_index_list != "NA"]
    
    weight_new_index_list <- c(new_index_list, "weight")
    window_new_index_list <- c(new_index_list, "window")
    
    new_multidim_arr[matrix(as.vector(weight_new_index_list), 1)] <- do.call(`[`, c(list(multidim_arr), as.list(old_index_list), list("weight")))
    new_multidim_arr[matrix(as.vector(window_new_index_list), 1)] <- do.call(`[`, c(list(multidim_arr), as.list(old_index_list), list("window")))
  }
  
  # Return the updated multidimensional array and the new column identifiers
  result <- list(
    tensor = new_multidim_arr,
    sender_cols = sender_cols,
    receiver_cols = receiver_cols,
    mode_column = mode_column
  )
  
  
  return(result)
}


# Returns ground vectors to consider for a response line
# This should return the actual ground vectors from the context i.e. not just the codes
apply_windows <- function(
  multidim_arr, 
  sender_cols,
  receiver_cols,
  time_column,
  duration_column,
  mode_column,
  r_vec_qeid, 
  context, 
  codes, 
  time_unit = 'auto'
) {  
  # first line is response line--since we aren't including response lines, just provide a dummy vec w/ 0s @ codes
  if (nrow(context) == 1) { 
    temp_vec <- context[.N,]
    temp_vec[, codes] <- 0

    return(temp_vec)
  }
  
  # get response row; r_i is receiver values
  context_response_row <- context[.N];
  receiver_cols <- as.character(as.vector(receiver_cols))
  r_i <- unlist(context_response_row[, ..receiver_cols]);
  response_row_time_val <- context_response_row[[time_column]]; # get timestamp in response row
  context_ground_rows <- context[QEID != r_vec_qeid]; # get potential ground rows
  g_vecs <- context_ground_rows[,{
    # matrix with sender and modality values for all relevant ground rows
    sm_mat <- as.matrix(.SD[, c(unlist(sender_cols), mode_column), with = FALSE])

    # initialize receivers cols of the querying matrix
    # receivers <- list()
    # for (k in 1:length(receiver_cols)) {
    #   receivers[[k]] <- as.matrix(rep(r_i[[k]], nrow(sm_mat)))
    # }
    # receivers <- do.call(cbind, receivers)
    receivers <- matrix(r_i, nrow = .N, ncol = length(r_i), byrow = TRUE, dimnames = list( NULL, names(r_i)));

    # get matrix used to query multidim arr
    # if (nrow(sm_mat) == 1) {
    #   mult_arr_mat <- cbind(t(as.matrix(sm_mat[,1:length(sender_cols)])), receivers, sm_mat[,ncol(sm_mat)], "window")
    # } else {
    #   mult_arr_mat <- cbind(sm_mat[,1:length(sender_cols)], receivers, sm_mat[,ncol(sm_mat)], "window")
    # }
    # mult_arr_mat <- cbind(sm_mat[,1:length(sender_cols), drop = F], receivers, sm_mat[, ncol(sm_mat), drop = FALSE], "window");
    mult_arr_mat <- cbind(.SD[, c(sender_cols, mode_column), with = FALSE], receivers, "window")
    si <- seq_along(sender_cols);
    data.table::setcolorder(mult_arr_mat, c(si, seq_along(receiver_cols) + length(sender_cols) + 1, length(sender_cols) + 1, ncol(mult_arr_mat)))
    mult_arr_mat <- as.matrix(mult_arr_mat);

    # ensure vectors project forward in time far enough that they are kept in the ground
    .SD[as.vector((.SD[[time_column]] + as.numeric(multidim_arr[mult_arr_mat])) >= response_row_time_val), ];
  }]
  # browser()
  
  # context[[time_column]] <- as.POSIXct(context[[time_column]], origin = "1970-01-01")
  # 
  # 
  # g_vecs_i <- context[, {
  #   times = .SD[[time_column]]
  #   difftime(
  #     times +
  #     multidim_arr[as.matrix(
  #       .SD[, c(sender_cols, receiver_cols, mode_column), with = FALSE][, `:=`("window"="window")][, (receiver_cols) := .SD[.N, c(receiver_cols), with = FALSE]]
  #     )],
  #     times[.N],
  #     time_unit
  #   ) >= 0 & QEID != r_vec_qeid
  # }]
  # g_vecs <- context[g_vecs_i,]
  # # browser(expr = !identical(g_vecs_old, g_vecs))
  
  return(g_vecs)
}

# Applies weights to ground vectors for a response line 
# This should return the weighted ground vectors with just the codes
apply_weights <- function(
    multidim_arr, 
    sender_cols,
    receiver_cols,
    mode_column,
    codes,
    context,
    g_vecs 
) {
  # we have ground vectors w/ metadata

  # get response row and associated receivers
  context_response_row <- context[.N]; 
  receiver_cols <- as.character(as.vector(receiver_cols))
  r_i <- unlist(context_response_row[, ..receiver_cols]);
  
  # get weighting vector
  sm_mat <- as.matrix(g_vecs[, c(unlist(sender_cols), mode_column), with = FALSE]) 
  receivers <- list()
  for (k in 1:length(receiver_cols)) {
    receivers[[k]] <- as.matrix(rep(r_i[[k]], nrow(sm_mat)))
  }
  receivers <- do.call(cbind, receivers)
  
  # if (nrow(sm_mat) == 1) { 
  #   mult_arr_mat <- cbind(t(as.matrix(sm_mat[,1:length(sender_cols)])), receivers, sm_mat[, ncol(sm_mat)], "weight")
  # } else {
  # }
  mult_arr_mat <-cbind(sm_mat[,1:length(sender_cols), drop = FALSE], receivers, sm_mat[,ncol(sm_mat), drop = FALSE], "weight")
  weight_vec <-  as.numeric(multidim_arr[mult_arr_mat])
  
  # apply to all g_vecs
  g_w_vecs <- as.matrix(g_vecs[,..codes]) * weight_vec
  
  # g_w_vecs <- as.matrix(g_vecs[, {
  #   .SD[, c(codes), with = FALSE] * multidim_arr[as.matrix(
  #     .SD[, c(sender_cols, receiver_cols, mode_column), with = FALSE][, `:=`("weight"="weight")][, (receiver_cols) := .SD[.N, c(receiver_cols), with = FALSE]]
  #   )]
  # }])
  
  return(g_w_vecs)
}

# 0 out diagonal of a square matrix
f_diag <- function(
    mat # a square matrix
) {
  if (!is.matrix(mat) || nrow(mat) != ncol(mat)) {
    stop("Input must be a square matrix.")
  }
  
  diag(mat) <- 0
  return(mat)
}

accum_multidim <- function(
  time_column,
  codes, 
  context_model,
  tensor = context_tensor(context_model$model$raw.input), 
  duration_column = "", 
  norm_by = "No", # TODO: implement l1 normalization
  return_ena_set = FALSE,
  units = context_model[["model"]][["unit.labels"]],
  time_unit = 'auto',
  ... # TODO: implement binarization for T/ENA
) {
  .Deprecated("accumulate", "tma v0.2.0");
  multidim_arr <- tensor;

  df <- context_model$model$raw.input;
  result <- preprocess(df, multidim_arr);
  
  multidim_arr <- result$tensor
  sender_cols <- result$sender_cols
  receiver_cols <- result$receiver_cols
  mode_column <- result$mode_column
  
  adj_vector_names <- NULL;
  adj_vectors <- list()
  # units <- context_model[["model"]][["unit.labels"]]
  for (unit in units) {
    # List to store adjacency vectors for this unit
    adj_vector <- list()
    
    # Ensure context has column "standin" with values "standin" for all lines
    context <- context_model[["model"]][["contexts"]][[unit]]
    context[,"standin"] = "standin"
    
    # List to store connection matrices before accumulation for this unit
    counting_matrices <- list()
    counting_matrices_counter = 1
    
    # For each context, get unit's lines in that context (r_vec)
    context_unit_rows <- context[QEUNIT == unit];
    # print(paste("unit: ", unit));
    for (i in seq(1, nrow(context_unit_rows))) { # NOTE: now, i is the index within the rows corresponding to the units i.e. if the unit speaks 4 times in context, 1, ..., 4; NOT the absolute index in the context
      
      r_vec = context_unit_rows[i,] 
      
      # Get all lines *strictly* before this line, which are individual g_vec, and only get those that project
      # far enough
      r_vec_qeid <- context_unit_rows$QEID[i]; # this is the QE id; NOT the absolute index in the context 
      context_before_r_vec <- context[QEID <= r_vec_qeid];
      
      g_vecs <- apply_windows(multidim_arr, 
                              sender_cols, receiver_cols, 
                              time_column, duration_column, mode_column,
                              r_vec_qeid, context_before_r_vec, 
                              codes, time_unit)

      # ensure there are zero connections if g_vecs is empty
      if (nrow(g_vecs) == 0) {
        temp <- copy(r_vec) # make sure to deep copy this; shallow copy will also zero out r_vec
        temp[, (codes) := 0]
        g_vecs <- data.table(temp)
      }
      
      # Query multidimensional array to reweight g^w_vec = w^{srm} * g_vec
      g_w_vecs <- apply_weights(multidim_arr, sender_cols, receiver_cols, mode_column, codes, context_before_r_vec, g_vecs);
      
      # Sum all g^w_vec together as g^{ws}_vec
      g_ws_vec <- colSums(g_w_vecs)
      
      # Compute counting matrix = g^{ws}_vec r_vec^T + 0.5w_{resp}^{srm} * f_diag(r_vec r_vec^T)
      # get response vector; need to extract senders, receivers, modality
      
      sender_cols <-  as.character(as.vector(sender_cols))
      receiver_cols <- as.character(as.vector(receiver_cols))
      mode_column <-  as.character(as.vector(mode_column))
      
      s_response <- unlist(r_vec[, ..sender_cols]);
      r_response <- unlist(r_vec[, ..receiver_cols]);
      m_response <- unlist(r_vec[, ..mode_column]);
    
      w_rr = as.numeric(multidim_arr[matrix(c(s_response, r_response, m_response, "weight"), 1)])

      r_vec <- as.numeric(unname(c(r_vec[, ..codes])))
      g_ws_vec <- as.numeric(g_ws_vec)
      
      # ONA 
      if (return_ena_set == FALSE) { 
        counting_matrix = (g_ws_vec %*% t(r_vec)) + 0.5 * w_rr * f_diag(r_vec %*% t(r_vec))
      } 
      
      # ENA (w_rr * rr^T + (qr^T + rq^T))
      else { 
        counting_matrix = w_rr * (r_vec %*% t(r_vec)) + (g_ws_vec %*% t(r_vec) + r_vec %*% t(g_ws_vec)) 
      }
      
      counting_matrices[[counting_matrices_counter]] = counting_matrix
      counting_matrices_counter = counting_matrices_counter + 1
    }
    
    # Sum all counting matrices to get Omega matrix 
    omega_matrix = Reduce("+", counting_matrices)
    rownames(omega_matrix) = codes
    colnames(omega_matrix) = codes
    
    if (return_ena_set == FALSE) { # ONA
      # Make into adjacency vector
      row_col_combinations <- expand.grid(rownames(omega_matrix), colnames(omega_matrix))
      adj_vector_names <<- paste(row_col_combinations[,1], "&", row_col_combinations[,2])
      
      adj_vector <- omega_matrix[cbind(match(row_col_combinations[, 1], rownames(omega_matrix)), 
                                       match(row_col_combinations[, 2], colnames(omega_matrix)))]
      
      # adj_vector <- setNames(adj_vector, adj_vector_names)
    }
    else { 
      upper_indices <- which(upper.tri(omega_matrix, diag = FALSE)) 
      adj_vector <- omega_matrix[upper_indices]
      upper_rows <- rownames(omega_matrix)[row(omega_matrix)[upper_indices]]
      upper_cols <- colnames(omega_matrix)[col(omega_matrix)[upper_indices]]
      adj_vector_names <<- paste(upper_rows, "&", upper_cols)
      
      # adj_vector <- setNames(adj_vector, adj_vector_names)
    }
  
    if (norm_by == "l2") {
      l2_adj_vector <- sqrt(sum(adj_vector^2))
      normed_adj_vector <- adj_vector / l2_adj_vector
    } 
    else {
      normed_adj_vector <- adj_vector
    }
    
    # Save unit's adjacency vec
    adj_vectors[[unit]] <- normed_adj_vector
  }

  adj_key <- NULL
  if(return_ena_set == FALSE) {
    adj_key <- t(expand.grid(codes, codes))
  }
  else {
    adj_key <- namesToAdjacencyKey(codes)
  }
  adj_vector_names <- apply(adj_key, 2, paste, collapse = " & ")
  
  context_model$rotation <- structure(list(
    codes = codes,
    adjacency.key = structure(
      sapply(adj_vector_names, function(x) strsplit(x, " & ")[[1]], simplify = TRUE),
      dimnames = list( NULL, adj_vector_names)
    )
  ), class = c("ena.rotation.set", "list"));
  
  
  meta_cols <- context_model$`_function.params`$units.by;
  connection_counts <- data.table::rbindlist(lapply(units, function(ctx) {
    ctx_model <- context_model$model$contexts[[ctx]]
    ctx_unit <- attr(ctx_model, "tma.unit")
    ctx_adj <- adj_vectors[[ctx]];
    ctx_adj_dt <- as.data.table(matrix(ctx_adj, byrow = TRUE, nrow = 1, dimnames = list(NULL, adj_vector_names)))
  }));
  connection_counts <- connection_counts[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = adj_vector_names];
  connection_counts$ENA_UNIT <- units;
  # connection_counts <- cbind(connection_counts, data.table::rbindlist(lapply(context_model$model$contexts, attr, "tma.unit")))
  connection_counts <- cbind(connection_counts, data.table::rbindlist(lapply(units, function(u) attr(context_model$model$contexts[[u]], "tma.unit"))))
  
  for(jj in c("ENA_UNIT", meta_cols)) {
    data.table::set(connection_counts, j = jj, value = reclass(connection_counts[[jj]], "ena.metadata"));
  }
  # data.table::set(connection_counts, j = "QEUNIT", value = reclass(connection_counts$QEUNIT, "ena.metadata"));
  
  #data.table::rbindlist(lapply(context_model$model$contexts, attr, "tma.unit"));
  
  data.table::setcolorder(connection_counts, c("ENA_UNIT", meta_cols, adj_vector_names));
  
  context_model$connection.counts <- connection_counts;
  
  class(context_model$connection.counts) <- c("ena.connections", "ena.matrix", "data.table", "data.frame");
  
  context_model$meta.data <- context_model$connection.counts[, sapply(context_model$connection.counts, is, "ena.metadata"), with = FALSE];
  class(context_model$meta.data) = c("ena.matrix", class(context_model$meta.data));
  
  context_model$model$row.connection.counts <- structure(
    data.table::copy(context_model$connection.counts),
    class = c("row.connections", "ena.matrix", "data.table", "data.frame")
  );
  
    
  # Return accumulation (adjacency vecs for all units)
  return(context_model)
}

# Accumulated threaded data
#
# @param ... passed along
#
# @return ENA set
accumulate_context_threads <- function(...) {
  args <- list(...);
  
  simple_window <- function(x) { (x < args$window_size) * 1 }
  if(!is.null(args$decay_function) && is.function(args$decay_function)) {
    simple_window <- args$decay_function;
  }
  no_weight <- function(x) { x };
  accumulate_contexts(
    x = args$x,
    codes = args$codes,
    return.dena.set = args$as_directed,
    return.ena.set = !args$as_directed,
    meta.data = args$meta.data,
    
    time.column = NULL,
    mask = NULL,
    # time.limit = NULL,
    
    decay.function = simple_window,
    weight.by = no_weight,
    mode.column = "Thread",
    context_filter = args$context_filter
  )
}

# Key change: Pass in argument z representing the weighted response vectors. y are unweighted response vectors
ground_response_crossprod <- function(
  x, y, z 
) {
  UNIT = NULL;
  UNIT_LABEL = NULL;
  eff_call_env <- new.env(parent = environment(ground_effect_function));
  environment(ground_effect_function) <- eff_call_env;
  assign("UNIT", UNIT, envir = eff_call_env);
  assign("UNIT_LABEL", UNIT_LABEL, envir = eff_call_env);
  
  # all_connection_matrices_raw <- list_vec_apply(all_only_ground_connections, responses.codes, ground_effect_function);
  all_connection_matrices_raw <- list_vec_apply(x, y, ground_effect_function);
  
  # Key change: z passed in here, so that we calculate the response matrices as matmul(z, r^T)
  # This way, the result is 1/2 * f_{diag}((w_rr) * rr^T), where f_{diag} is a function that 0s out 
  # the diagonal of a matrix, rather than 1/2 * f_{diag}(rr^T)
  # response_matrices <- lapply(y, function(x) tcrossprod(x) );
  response_matrices <- Map(function(zi, yi) zi %*% t(yi), z, y);
  these_self_connections <- lapply(response_matrices, function(x) {
    0.5 * (x - diag(diag(x)))
  })
  
  all_connection_matrices <- lapply(seq(all_connection_matrices_raw), function(i) {
    all_connection_matrices_raw[[i]] + these_self_connections[[i]]
  })
  dir_vecs <- t(sapply(all_connection_matrices, function(x) { dim(x) <- c(1, nrow(x)^2); (x) }));
  # print(dir_vecs);
  
  acc_call_env <- new.env(parent = environment(accumulate_unit_vectors_by));
  environment(accumulate_unit_vectors_by) <- acc_call_env;
  assign("UNIT", UNIT, envir = acc_call_env);
  assign("UNIT_LABEL", UNIT_LABEL, envir = acc_call_env);
  dir_vecs <- accumulate_unit_vectors_by(dir_vecs);
  # browser()
  
  return(dir_vecs)
}

#' accumulate_contexts
#'
#' @param x TBD
#' @param codes TBD
#' @param time.column TBD
#' @param decay.function TBD
#' @param mode.column TBD
#' @param mask TBD
#' @param weight.by TBD
#' @param meta.data TBD
#' @param return.dena.set TBD
#' @param return.ena.set TBD 
#' @param accumulate_unit_vectors_by TBD 
#' @param norm.by TBD
#' @param context_filter TBD
#' @param summarize_ground_using TBD
#' @param calculate_adj_vectors_using TBD
#' @param ground_effect_function TBD
#'
#' @return ENA set
#' @export
accumulate_contexts <- function(
  x,
  codes,
  decay.function = decay(simple_window, window_size = 4),
  time.column = NULL,
  mode.column = NULL,
  mask = NULL,
  weight.by = sqrt,
  norm.by = `_sphere_norm`,
  meta.data = NULL,
  return.dena.set = FALSE,
  return.ena.set = TRUE,
  context_filter = NULL,
  summarize_ground_using = colSums,
  calculate_adj_vectors_using = ground_response_crossprod,
  ground_effect_function = function(x, y) crossprod(t(x), y),
  accumulate_unit_vectors_by = colSums
) {
  data <- x$model$raw.input;
  f.contexts <- x$model$contexts; #context.object #$contexts
  units <- x$`_function.params`$units; 
  
  f.codes = codes
  f.time = time.column
  f.decay = decay.function
  f.mode = mode.column
  f.weighting.function = weight.by
  f.meta.data = meta.data
  f.units = as.data.frame(names(f.contexts))
  f.raw <- data.table::copy(data);
  f.raw$QEID <- seq(nrow(f.raw));
  
  use.modes = ifelse(any(is.null(f.mode)), FALSE, TRUE)
  use.meta = ifelse(any(is.null(f.meta.data)), FALSE, TRUE)
  use.mask = ifelse(is.matrix(mask), TRUE, FALSE)
  use.window = ifelse(is.null(f.time) || is.na(f.time), TRUE, FALSE)
  
  
  meta_cols <- x$`_function.params`$units.by;
  if(use.meta) {
    meta_cols <- unique(meta_cols, c(f.meta.data[!is.na(f.meta.data)]));
  }
  output.meta.data <- as.data.frame(f.raw[0, c(meta_cols), with = FALSE]);
  
  # initialize adjacency vector matrices
  undirected.adjacency.vectors = data.frame(matrix(0, nrow = 1, ncol = ncol(adjacency_key(f.codes))))[0,]
  directed.adjacency.vectors = data.frame(matrix(0, nrow = 1, ncol = length(f.codes)^2)[0,]);
  
  #create undirected mask if there are NAs in lower triangle of given mask
  if( use.mask ) {
    if ( any(is.na(mask[lower.tri(mask)])) ) {
      mask[lower.tri(mask)] = mask[upper.tri(mask)]
    }
  }
  else {
    mask <- matrix(1, nrow = length(f.codes), ncol = length(f.codes));
  }
  
  n = length(codes)
  blank.code.matrix = matrix(0, nrow = n, ncol = n, dimnames = list(codes, codes))
  unit.code.matrices <- structure(
    rep(
      list(list(
        directed.adjacency = blank.code.matrix,
        undirected.adjacency = structure(rep(0, ncol(blank.code.matrix)))
      )),
      length(names(f.contexts))
    ),
    names = names(f.contexts)
  );
  for( unit.index in seq(f.contexts)) {
    unit.contexts <- f.contexts[[unit.index]];
    if(is.numeric(unit.contexts)) {
      unit.contexts <- list(unit.contexts)
    }
    
    # browser to stop at mentor unit
    # if (unit.index == 3) { browser() } 
    
    this.unit <- attr(unit.contexts[[1]], "tma.unit");
    if(is.null(this.unit)) {
      this.unit <- attr(unit.contexts, "tma.unit");
    }
    unit.label <- paste(as.character(this.unit), collapse = "::");
    # Empty matrices for tracking unit vectors
    unit.directed.adjacency.vectors <- data.frame(matrix(0, nrow = 1, ncol = length(f.codes)^2)[0,]);
    unit.undirected.adjacency.vectors <- data.frame(matrix(0, nrow = 1, ncol = ncol(adjacency_key(f.codes))))[0,]

    if(is.data.frame(unit.contexts)) {
      unit.contexts <- list( unit.contexts );
    }
    
    # Each unit's contexts
    all_codes <- as.matrix(x$model$raw.input[, c(codes), with = FALSE])
    res_context <- lapply(seq(unit.contexts), function(context.index) {
      this.code.matrix <- blank.code.matrix;
      this.context.rows <- unit.contexts[[context.index]];
      if(is.numeric(this.context.rows)) {
        this.context <- x$model$raw.input[this.context.rows, ];
      }
      else {
        this.context <- x$model$raw.input[this.context.rows, , on = c("QEID")];
      }
      this.context$CID <- seq(nrow(this.context))
      # browser()
      # this_context_codes <- all_codes[this.context.rows,, drop = FALSE]
      this_context_codes <- all_codes[this.context$QEID,, drop = FALSE]
      this.unit.rows_tf <- this.context$QEUNIT == unit.label
      if(!is.null(context_filter)) {
        this.unit.rows_tf <- do.call(context_filter, list(unit = unit.label, context = this.context))  
      }
      this.unit.rows <- which(this.unit.rows_tf);
      if(use.window) {
        f.time <- "CID"
      }
      
      this.time <- this.context[[c(f.time)]];
      if(use.modes) {
        these.modes <- as.factor(this.context[[c(f.mode)]]);
      }
      
      if(length(this.unit.rows) > 0) {
        response.times <- this.time[this.unit.rows];
        
        grounds <- lapply(this.unit.rows, function(ur) {
          grounds <- vector(length = nrow(this.context))
          grounds[seq_len(ur)] <- TRUE
          attr(grounds, "tma.response.index") <- ur
          grounds
        })
        
        
        grounds.codes.raw <- lapply(grounds, function(xx) this_context_codes[xx,, drop = FALSE]);
        
        this.unit.resp.idx <- sapply(grounds, attr, which = "tma.response.index");
   
        responses.codes <- list_vec_apply(grounds.codes.raw, this.unit.resp.idx, function(x,y) { as.numeric(x[y,,drop = FALSE]) });
        
        grounds.modes <- rep(NA, length(responses.codes))
        if(use.modes) {
          grounds.modes <- lapply(grounds, function(x) these.modes[x]);
        }
        ground.times <- lapply(grounds, function(x) this.time[x])
        
        all.decays <- sapply(seq(grounds), function(wh) {
          call_env <- new.env(parent = environment(f.decay));
          RESPONSE_INDEX <- attr(grounds[[wh]], which = "tma.response.index")
          # RESPONSE <- this.context[RESPONSE_INDEX, ]
          ROWS <- grounds[[wh]]
          # CONTEXT <- this.context[this_rows, ]
          # RESPONSE <- CONTEXT[.N]
          assign("FULL_CONTEXT", this.context, envir = call_env)
          # assign("CONTEXT", CONTEXT, envir = call_env)
          assign("RESPONSE_INDEX", RESPONSE_INDEX, envir = call_env)
          assign("ROWS", ROWS, envir = call_env)
          
          environment(f.decay) <- call_env;
          
          subbed <- as.numeric(response.times[wh] - ground.times[[wh]])
          if(is.function(f.decay)) {
            f.decay(subbed)
            # CONTEXT[ , {
            #   assign("GROUND_ROW", .SD, envir = call_env);
            #   f.decay(subbed[.GRP])
            # }, by = which(grounds[[wh]])][[2]];
          }
          else if (use.modes) {
            mapply(FUN = function(xx, yy, INDEX) {
              do.call(xx, args = list(x = yy))
            }, f.decay[grounds.modes[[wh]]], subbed, which(grounds[[wh]]))
          }
        }, simplify = FALSE)
        
        
        grounds.codes = mapply(grounds.codes.raw, all.decays, FUN = function(x, y) {
          
          if(length(y) == 1) {
            x * y[[1]]
          }
          
          #otherwise this is a bit of fancy math that multiplies each row of the matrix
          #by a different scalar from a vector of scalars
          else {
            # browser()
            # sweep(x, MARGIN = 1, (y), FUN = `*`)
            x * y
          }
        }, SIMPLIFY = FALSE);
        
        this.responses.in.grounds <- list_vec_apply(grounds.codes, this.unit.resp.idx, function(x, g) { x[g, ] })
        these.grounds <- lapply(grounds.codes, function(x) summarize_ground_using(x) );
        
        all_only_ground_connections <- list_vec_apply(
          x = these.grounds,
          y = this.responses.in.grounds,
          fn = function(x, y) x - y
        );
        
        ##
        adj_call_env <- new.env(parent = environment(calculate_adj_vectors_using));
        environment(calculate_adj_vectors_using) <- adj_call_env;
        assign("UNIT", this.unit, envir = adj_call_env);
        assign("UNIT_LABEL", unit.label, envir = adj_call_env);
        assign("ground_effect_function", ground_effect_function, envir = adj_call_env);
        assign("accumulate_unit_vectors_by", accumulate_unit_vectors_by, envir = adj_call_env);
        # dir_vecs <- calculate_adj_vectors_using(all_only_ground_connections, responses.codes)
        # Key change: pass in weighted response vectors, this.responses.in.grounds, to calculate_adj_vectors_using
        # (currently ground_response_crossprod) as well 
        dir_vecs <- calculate_adj_vectors_using(all_only_ground_connections, responses.codes, this.responses.in.grounds)
        
        dim(dir_vecs) <- c( 1, length(dir_vecs) );
        
        data.frame(dir_vecs);
      }
    })
    
    unit.directed.adjacency.vectors <- data.table::rbindlist(res_context)
    directed.adjacency.vectors  <- rbind( directed.adjacency.vectors,  colSums(unit.directed.adjacency.vectors) );

    if(nrow(unit.directed.adjacency.vectors) > 0) {
      unit.undirected.adjacency.vectors <- unit.directed.adjacency.vectors[, {
        as.list(
          as.undirected.vector(as.undirected.matrix(matrix(unlist(.SD), ncol = sqrt(length(.SD)))))
        )
      }, by = seq(nrow(unit.directed.adjacency.vectors))][, -1]
    }
    
    undirected.adjacency.vectors <- rbind( undirected.adjacency.vectors, colSums(unit.undirected.adjacency.vectors) );
    
    output.meta.data <- rbind(output.meta.data, this.unit[, c(meta_cols), with = FALSE]);
  }
  
  #### Construct ENA Sets ----
  
  #add additional information for modeling
  directed.adjacency.vectors <- structure(
    lapply(directed.adjacency.vectors, reclass, cl = "ena.co.occurrence"), 
    class = c("ena.connections", "data.table", "data.frame"),
    names = apply(t(apply(matrix(c(rep(seq(f.codes), times = length(f.codes)), rep(seq(f.codes), each = length(f.codes))), ncol = 2), 2, function(x) f.codes[x])), 2, paste, collapse = " & ")
  );
  
  # lapply(undirected.adjacency.vectors, as.ena.co.occurrence), 
  undirected.adjacency.vectors <- structure(
    lapply(undirected.adjacency.vectors, reclass, cl = "ena.co.occurrence"), 
    class = c("ena.connections", "data.table", "data.frame"),
    names = apply(adjacency_key(f.codes), 2, paste, collapse = " & ")
  );
  
  # x$meta.data <- structure(
  #   lapply(output.meta.data, reclass, cl = "ena.metadata"), 
  #   class = c("ena.matrix", "data.table", "data.frame")
  # );
  x$meta.data <- data.table::copy(data.table::as.data.table(output.meta.data));
  set(x$meta.data, j = "ENA_UNIT", value = do.call(paste, c(lapply(x$`_function.params`$units.by, function(u) x$meta.data[[u]]), sep = "::")))
  for( i in colnames(x$meta.data) ) {
    data.table::set(x$meta.data, j = i, value = reclass(x$meta.data[[i]], "ena.metadata"))
  }
  class(x$meta.data) = c("ena.matrix", class(x$meta.data));
  
  # Standard ENA Set
  if(return.ena.set) {
    # x$meta.data[, c("ENA_UNIT") := merge_columns(x$meta.data, cols = x$`_function.params`$units.by, sep = "::")]
    # set(x$meta.data, j = "ENA_UNIT", value = do.call(paste, c(lapply(units.by, function(u) x$meta.data[[u]]), sep = "::")))
    # for( i in colnames(x$meta.data) ) {
    #   data.table::set(x$meta.data, j = i, value = reclass(x$meta.data[[i]], "ena.metadata"))
    # }
    
    x$rotation = structure(list(
      codes = f.codes,
      adjacency.key = structure(
        adjacency_key(f.codes),
        dimnames = list( NULL, names(undirected.adjacency.vectors))
      )
    ), class = c("ena.rotation.set", "list"));
    
    x$connection.counts <- data.table::copy(undirected.adjacency.vectors);
    x$connection.counts <- structure(cbind(x$meta.data, x$connection.counts), class = class(undirected.adjacency.vectors));
    
    # TODO: This needs to be updated to reflect the accumulation for each row in the data
    # enadata$accumulated.adjacency.vectors = data.table::as.data.table(undirected.adjacency.vectors)
    x$model$row.connection.counts <- structure(
      data.table::copy(x$connection.counts),
      class = c("row.connections", "ena.matrix", "data.table", "data.frame")
    );
    # browser()
    
    if(!is.null(norm.by)) {
      x$line.weights <- norm.by(x = as.matrix(undirected.adjacency.vectors))
    }
    
    output = x;
  }
  
  # Directed ENA Set
  else {
    dena_data = ena.set.directed(f.raw, f.units, NA, f.codes)
    dena_data$meta.data <- data.table::as.data.table(output.meta.data)
    dena_data$meta.data[, c("ENA_UNIT") := merge_columns(dena_data$meta.data, cols = x$`_function.params`$units.by, sep = "::")]
    for( i in colnames(dena_data$meta.data) ) {
      data.table::set(dena_data$meta.data, j = i, value = reclass(dena_data$meta.data[[i]], "ena.metadata"))
    }
    code_length <- length(dena_data$rotation$codes);
    dena_data$rotation$adjacency.key <- data.table::data.table(matrix(c(
      rep(1:code_length, each = code_length),
      rep(1:code_length, code_length)),
      byrow = TRUE, nrow = 2
    ))
    
    dena_data$connection.counts <- data.table::as.data.table(cbind(dena_data$meta.data, directed.adjacency.vectors))
    dena_data$model$row.connection.counts = data.table::as.data.table(cbind(dena_data$meta.data, directed.adjacency.vectors))
    
    dena_data$connection.counts = reclass(dena_data$connection.counts, c("ena.connections", "ena.matrix"))
    dena_data$model$row.connection.counts <- reclass(dena_data$model$row.connection.counts, c("row.connections", "ena.matrix"))
    
    if ( !is.null(norm.by) ) {
      dena_data$line.weights <- norm.by(x = as.matrix(directed.adjacency.vectors))
    }
    
    output = dena_data;
  }
  
  output$model$contexts <- f.contexts
  
  return(output)
}

#' Accumulate Connections from a Multidimensional Array and Context Model
#'
#' This function processes a context model and a multidimensional array of window/weight parameters to compute connection counts for each unit of analysis.
#' It applies the context model to the array, using sender, receiver, and mode columns (as defined in the array attributes), and accumulates co-occurrence or adjacency matrices for each unit. The result is a set of connection counts and row-level connection matrices, suitable for network analysis (e.g., ENA/ONA).
#'
#' @param context_model A context model object (as produced by `tma::contexts`) containing contexts for each unit of analysis.
#' @param codes Character vector of code names to use for constructing adjacency matrices.
#' @param tensor A multidimensional array (see `context_tensor`) containing window and weight values for each sender/receiver/mode combination. Defaults to an array generated from the context model's raw input.
#' @param time_column Character string giving the name of the time column in the context model. If NULL, uses the default context column ID.
#' @param ordered Logical; if TRUE (default), computes ordered adjacency matrices (ONA); if FALSE, computes unordered (ENA-style) matrices.
#' @param binary Logical; if TRUE (default), binarizes the connection counts (not currently implemented in this function).
#'
#' @return The input `context_model` with additional fields:
#'   \item{connection.counts}{A data.table of accumulated connection counts for each unit.}
#'   \item{model$row.connection.counts}{A data.table of row-level connection matrices for each unit.}
#'   \item{meta.data}{A data.table of metadata columns for each unit.}
#'   The class of the returned object is updated to reflect the type of accumulation (ordered or unordered).
#'
#' @details
#' This function is used to perform accumulation of network connections for each unit, based on the context model and tensor parameters. It supports both ordered and unordered accumulation, and returns results suitable for further network analysis or visualization.
#'
#' @export
accumulate <- function(
  context_model,
  codes,
  tensor = context_tensor(context_model$model$raw.input),
  time_column = NULL,
  ordered = FALSE,
  binary = TRUE
) {
  send_cols = attr(tensor, "sender_cols");
  recv_cols = attr(tensor, "receiver_cols");
  mode_cols = attr(tensor, "mode_column");

  if(is.null(time_column)) {
    time_column <- ATTR_NAMES$CONTEXT_COL_ID;
  }
  
  context_model$rotation <- structure(list(
    codes = codes,
    adjacency.key = adjacency_key(codes, !ordered)
  ), class = c("ena.rotation.set", "list"));
  adj_vector_names <- colnames(context_model$rotation$adjacency.key);
  adj_vector_names_full <- colnames(adjacency_key(codes, FALSE));
  
  ind_mat <- matrix(nrow = length(codes), ncol = length(codes));
  units_by <- context_model$`_function.params`$units.by;
  meta_cols <- c("QEID", "QEUNIT", units_by);
  
  mode_dim_1 <- dim(tensor)[1] == 1 && attr(tensor, "mode_column") == ATTR_NAMES$CONTEXT_ID;

  # Cache tensor attributes outside the loop
  tensor_dim <- attr(tensor, "dim")
  tensor_sender_inds <- attr(tensor, "sender_inds") - 1
  tensor_receiver_inds <- attr(tensor, "receiver_inds") - 1
  tensor_mode_inds <- attr(tensor, "mode_inds") - 1

  result_cpp <- lapply(context_model$model$contexts, function(ctx) {
    ctx_fun <- function(ctx_o) {
      ctx__ <- data.table::copy(ctx_o);
      # Assume columns are already numeric or factors; if not, convert once outside this function
      cols_to_encode <- c(send_cols, recv_cols, mode_cols)
      cols_to_encude_unq <- unique(cols_to_encode)
      if (!all(sapply(ctx__[ , ..cols_to_encode], is.numeric))) {
        ctx__[ , (cols_to_encude_unq) := lapply(.SD, function(x) as.numeric(as.factor(x))), .SDcols = unique(cols_to_encude_unq)]
      }
      unit_context_lookup <- as.matrix(ctx__[ , ..cols_to_encode])

      unit_rows <- attr(ctx__, "tma.unit_rows")
      this_unit <- attr(ctx__, "tma.unit")
      unit_to_last <- seq.int(last(unit_rows))
      ctx_unit_to_last <- ctx__[unit_to_last, ]
      res2 <- apply_tensor(
        tensor,
        tensor_dim,
        tensor_sender_inds,
        tensor_receiver_inds,
        tensor_mode_inds,
        unit_context_lookup[unit_to_last, , drop = FALSE] - 1,
        unit_rows - 1,
        as.matrix(ctx_unit_to_last[ , ..codes]),
        ctx_unit_to_last[[time_column]]
      )

      rcc <- data.table::as.data.table(res2$row_connection_counts);
      unit_row_meta <- ctx_o[unit_rows, meta_cols, with = FALSE];
      # rcc <- cbind(unit_row_meta, rcc)
      # browser()
      rcc[, names(unit_row_meta) := unit_row_meta]
      data.table::setcolorder(rcc, c(names(unit_row_meta), setdiff(names(rcc), names(unit_row_meta))))
      rcc
    }

    if(is.data.frame(ctx)) {
      res <- ctx_fun(ctx);
    }
    else {
      results <- lapply(ctx, ctx_fun);
      
      res <- data.table::rbindlist(results);
      res <- reclass(x = res, c("ordered.row.connections", "row.connections", "ena.matrix"));
    }
    
    return(res);
  });
  
  row_connection_counts <- rbindlist(result_cpp);
  # colnames(row_connection_counts) <- c(meta_cols, adj_vector_names_full);
  
  # browser()
  # row_connection_counts[, lapply(seq.int(nrow(.SD)), function(col_ind) {
  #   col <- .SD[[col_ind]];
  #   new_class_nm <- ifelse(col_ind <= length(meta_cols), "ena.metadata", "ena.co.occurrence");
  #   reclass(col, new_class_nm)
  # }), .SDcols = seq.int(ncol(row_connection_counts))];
  # browser()
  row_connection_counts <- reclass_columns(row_connection_counts, rep(c("ena.metadata","ena.co.occurrence"), c(length(meta_cols), length(adj_vector_names_full))))
  data.table::setorderv(row_connection_counts, "QEID");
  row_connection_counts <- reclass(x = row_connection_counts, c("ordered.row.connections", "row.connections", "ena.matrix"));
  colnames(row_connection_counts) <- c(meta_cols, adj_vector_names_full);
  context_model$model$row.connection.counts <- row_connection_counts;
  
  cc_type <- NULL;
  if(isTRUE(ordered)) {
    class(context_model) <- c("ena.ordered.set", class(context_model));
    # browser();
    # connection_counts <- data.table::as.data.table(do.call(rbind, lapply(result_cpp, colSums.ena.matrix, binary = FALSE)));
    # connection_counts <- data.table::as.data.table(do.call(rbind, lapply(result_cpp, function(rcpp) {
    #   colSums(as.matrix.ena.matrix(rcpp))  
    # })));
    connection_counts <- row_connection_counts[, lapply(.SD, sum), by = units_by, .SDcols = adj_vector_names_full];
    connection_counts <- reclass(x = connection_counts, c("ordered.ena.connections", "ena.connections", "ena.matrix"));
    # connection_counts <- connection_counts[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = colnames(connection_counts)];
    
    cc_type <- "ordered.ena.connections";
  }
  else {
    class(context_model) <- c("ena.unordered.set", class(context_model));
    
    context_model$model$row.connection.counts <- as.unordered(context_model$model$row.connection.counts);
    connection_counts <- context_model$model$row.connection.counts[, lapply(.SD, colSums.ena.matrix, binary = binary), by = "QEUNIT", .SDcols = adj_vector_names];

    # connection_counts <- connection_counts[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = adj_vector_names];
    cc_type <- "unordered.ena.connections";
  }
  
  cc_meta <- data.table::rbindlist(lapply(result_cpp, function(rc) rc[1, c("QEUNIT", units_by), with = FALSE]));
  cc_meta$ENA_UNIT <- context_model$model$unit.labels;
  cc_meta <- cc_meta[, lapply(.SD, reclass, "ena.metadata"), .SDcols = colnames(cc_meta)];
  
  connection_counts <- cbind(cc_meta, connection_counts)
  connection_counts <- reclass(connection_counts, c(cc_type, "ena.connections", "ena.matrix"));
  context_model$connection.counts <- connection_counts;
  
  context_model$meta.data <- context_model$connection.counts[, sapply(context_model$connection.counts, is, "ena.metadata"), with = FALSE];
  class(context_model$meta.data) = c("ena.matrix", class(context_model$meta.data));

  # 5a: persist the windowing config so the accumulated object is self-describing
  # (recreate-the-model intent) and consumable by tma.conversations2, which needs
  # the resolved per-modality window/weight tensor to reproduce the exact windows.
  # See design/dataview-flexible-window.md.
  context_model$`_function.params`$tensor      <- tensor;
  context_model$`_function.params`$mode_column <- mode_cols;
  context_model$`_function.params`$codes       <- codes;
  context_model$`_function.params`$time_column <- time_column;
  context_model$`_function.params`$ordered     <- ordered;
  context_model$`_function.params`$binary      <- binary;

  return(context_model);
}

#' Adjacency Key
#'
#' @param codes character vector
#' @param upper logical, default, TRUE, returns the key for the upper triangle, FALSE - not implemented yet
#' 
#' @export
#'
#' @return matrix
adjacency_key <- function(codes, upper = TRUE) {
  expanded <- expand.grid(codes, codes);
  rownames(expanded) <- apply(expanded, 1, paste, collapse = " & ");
  if(upper == TRUE) {
    upper_inds <- which(upper.tri(matrix(nrow = length(codes), ncol = length(codes))));
    t(expanded[upper_inds,])
  }
  else {
    t(expanded);
  }
}

list_vec_apply <- Vectorize(FUN = function(x, y = NULL, fn) {
  fn(x, y)
}, vectorize.args = c("x", "y"), SIMPLIFY = FALSE);


as.undirected.matrix <- function(x, m = matrix(1, nrow = nrow(x), ncol = ncol(x))) {
  upper_tri_indices <- upper.tri(x);
  ut_matrix <- x * m;
  ut_matrix[upper_tri_indices] <- ut_matrix[upper_tri_indices] + t(ut_matrix)[upper_tri_indices]
  
  #make matrix symmetrical
  ut_matrix[lower.tri(ut_matrix)] = NA
  
  ut_matrix
}

#' Extract Upper Triangular Elements
#' 
#' This function extracts the elements from the upper triangular part of a
#' matrix.
#' 
#' @param x A numeric matrix from which to extract upper triangular elements.
#' @param diag A logical value indicating whether to include the diagonal
#'   elements. Defaults to FALSE.
#' 
#' @return A vector containing the upper triangular elements of the matrix.
as.undirected.vector <- function(x, diag = FALSE) {
  upper_tri_indices <- upper.tri(x, diag = diag);
  x[upper_tri_indices]
}


as.ena.ordered.set <- function(x) {
  to <- c("ena.ordered.set")
  if(!inherits(x = x, what = "ena.set")) {
    to <- c(to, "ena.set")
  }
  class(x) <- c(to, class(x));
  return(x);
}
ena.set.directed <- function(data, units, conversations, codes, ...) {
  as.ena.ordered.set(
    list(
      meta.data = NULL,
      model = list(
        model.type = "Directed",
        raw.input = data.table::as.data.table(data)
      ),
      rotation = list (
        codes = codes,
        nodes = NULL
      ),
      plots = list(),
      "_function.params" = list(
        units = units,
        conversations = conversations,
        codes = codes
      )
    )
  )
}

# Reclass vector
#
# @param x vector
# @param cl character - new class
# @param stringsAsFactors logical, default: default.stringsAsFactors()
#
# @return vector with class: c(cl, class(x))
reclass <- function(x, cl, stringsAsFactors = FALSE) {
  if(!stringsAsFactors && is.factor(x)) {
    x <- as.character(x)
  }
  class(x) = c(cl, class(x))
  x
}

# Reclass columns of a data.frame or data.table
# @param df data.frame or data.table
# @param class_vec character vector of new classes, length must equal ncol(df)
# 
# @return data.frame or data.table with re-classed columns
reclass_columns <- function(df, class_vec) {
  stopifnot(length(class_vec) == ncol(df))
  for (i in seq_along(class_vec)) {
    df[[i]] <- reclass(df[[i]], class_vec[i])
  }
  df
}

# paste columns to together
#
# @param x coerced to data.frame prior to subseting cols
# @param cols character vector - default: colnames(x)
# @param sep character default "."
#
# @return character vector
merge_columns <- function(x, cols = colnames(x), sep = ".") {
  do.call(paste, c(as.data.frame(x)[, cols, drop = FALSE], sep = sep))
}

##
#' Convert Adjacency Key to Character (S3 method)
#'
#' This S3 method converts an adjacency key object (typically a 2-row matrix or list of pairs) into a character vector, concatenating each pair with ' & '.
#'
#' @param x An adjacency key object (matrix or list) to convert to character.
#' @param ... Additional arguments (unused).
#'
#' @return A character vector where each element is a concatenation of the adjacency key pair.
#' @export
'as.character.adjacency.key' <- function(x, ...) {
  mapply(paste, x[[1]], x[[2]], MoreArgs = list(sep = " & "))
}

#' Convert Adjacency Key to Double (S3 method)
#'
#' This S3 method converts an adjacency key object to a numeric (double) vector, applying as.numeric to each element.
#'
#' @param x An adjacency key object (matrix or list) to convert to numeric.
#' @param ... Additional arguments (unused).
#'
#' @return A numeric vector representation of the adjacency key.
#' @export
'as.double.adjacency.key' <- function(x, ...) {
  sapply(x, as.numeric)
}

##
#' Print Method for Network Matrix (S3 method)
#'
#' This S3 method prints a network matrix object, optionally including metadata. It adjusts the class and attaches adjacency key names for improved readability.
#'
#' @param x An object of class "network.matrix" to print.
#' @param include.meta Logical; whether to include metadata in the printout (currently not used).
#' @param ... Additional arguments passed to lower-level print methods.
#'
#' @return Invisibly returns the printed object.
#' @export
'print.network.matrix' <- function(x, include.meta = TRUE, ...) {
  x_ <- data.table::copy(x);
  x_model <- attr(x, "model");
  x_cls <- class(x);
  class(x_) <- x_cls[ (which(x_cls == "network.matrix") + 1):length(x_cls) ];
  if(!is.null(x_model)) {
    adj_key <- x_model$rotation$adjacency.key;
    attr(x_, "names") <- as.character(adj_key);
  }
  
  print(x_);
}

##
#' Extract Metadata or Columns from Network Matrix (S3 method)
#'
#' This S3 method allows convenient extraction of metadata columns from a network matrix object using the $ operator. If the requested column is metadata, it is returned from the model's meta.data; otherwise, the standard extraction is performed.
#'
#' @param x An object of class "network.matrix".
#' @param i Name of the column or metadata field to extract.
#'
#' @return The requested column or metadata field from the network matrix.
#' @export
"$.network.matrix" <- function (x, i) {
  meta.data <- attr(x, "model")$meta.data;
  meta.cols <- colnames(meta.data);
  
  # browser()
  if(data.table::`%chin%`(i, meta.cols)) {
    meta.data[[i]];
  }
  else {
    x[[i]];
  }
}

#' Title
#'
#' @param x TBD
#'
#' @return TBD
#' @export
"names.network.connections" <- function(x) {
  use.adjacency.key = getOption("tma.print.adjkey", TRUE);
  
  x_cls <- class(x);
  x_ <- data.table::copy(x);
  class(x_) <- x_cls[ (which(x_cls == "network.connections") + 1):length(x_cls) ]; 
  
  if(use.adjacency.key == TRUE) {
    x_model <- attr(x, "model");
    adj_key <- x_model$rotation$adjacency.key;
    as.character(adj_key);
  }
  else {
    names(x_);
  }
}

#' Re-class vector as network.connection
#'
#' @param x Vector to re-class
#'
#' @return re-classed vector
#' @export
as.network.connection <- function(x) {
  if(is.factor(x)) {
    x = as.character(x)
  }
  class(x) = c("network.connection", class(x))
  x
}

##
#' Convert Network Connections to Matrix (S3 method)
#'
#' This S3 method extracts the connection columns from a network connections object and returns them as a numeric matrix. It is used to facilitate matrix operations on network connection data.
#'
#' @param x An object of class "network.connections" (or compatible data.table/data.frame) containing connection columns (of class "network.connection").
#' @param ... Additional arguments passed to `as.matrix`.
#'
#' @return A numeric matrix of network connections (rows = units/contexts, columns = connections).
#'
#' @export
as.matrix.network.connections <- function(x, ...) {
  x_ <- data.table::copy(x);
  x_cls <- class(x);
  class(x_) <- x_cls[ (which(x_cls == "network.matrix") + 1):length(x_cls) ];
  code_columns <- which(sapply(x_, inherits, what = "network.connection"));
  as.matrix(x_[, c(code_columns), with = F], ...);
}

##
#' Column Sums for ENA Matrices (S3 method)
#'
#' This S3 method computes column sums for ENA matrix objects, with optional binarization. It is used to summarize connection counts across rows (e.g., for each unit or context).
#'
#' @param x An object of class "ena.matrix" (or compatible matrix/data.frame) containing connection data.
#' @param na.rm Logical; whether to remove missing values (passed to `colSums`).
#' @param dims Integer; which dimensions to sum over (passed to `colSums`).
#' @param binary Logical; if TRUE, binarizes the matrix before summing (i.e., all nonzero values become 1).
#'
#' @return A numeric vector of column sums for the matrix.
#'
#' @export
'colSums.ena.matrix' <- function(x, na.rm = FALSE, dims = 1L, binary = FALSE) {
  x_mat <- as.matrix(x);
  if(isTRUE(binary)) {
    x_mat[x_mat > 0] <- 1;
  }
  colSums(x_mat);  
}

#' Unorder Connections in a Matrix
#'
#' This function takes a matrix and creates an unordered version of its connections, combining upper and lower triangular elements.
#'
#' @param x A matrix or data frame containing the connections. The input should be a square matrix.
#'
#' @return A data.table with ordered connections, reclassified as "unordered.ena.connections", "ena.connections", and "ena.matrix".
#'
#' @export
'as.unordered.ordered.ena.connections' <- function(x) {
  m <- as.matrix.ena.matrix(x);  # strips ena.metadata cols before conversion
  sq_size <- sqrt(ncol(m));
  ind_mat <- matrix(seq.int(ncol(m)), nrow = sq_size, ncol = sq_size);
  ind_ut <- ind_mat[upper.tri(ind_mat)];
  ind_lt <- ind_mat[lower.tri(ind_mat)];
  
  # m_unordered <- data.table::as.data.table(m[, ind_ut, drop = FALSE] + m[, ind_lt, drop = FALSE]);
  m_unordered <- data.table::as.data.table(t(apply(m, 1, function(mm) (mm[as.vector(ind_mat)] + mm[as.vector(t(ind_mat))])[ind_ut], simplify = T)));
  m_unordered <- m_unordered[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = colnames(m_unordered)];
  
  m_unordered <- cbind(x[,find_meta_cols(x), with = FALSE], m_unordered);
  m_unordered <- reclass(x = m_unordered, c("unordered.ena.connections", "ena.connections", "ena.matrix"));
  
  m_unordered
}

##
#' Convert Ordered Row Connections to Unordered (S3 method)
#'
#' This S3 method takes a matrix or data frame of ordered row connections (e.g., from ONA) and produces an unordered version by summing upper and lower triangular elements for each connection.
#'
#' @param x An object of class "ordered.row.connections" (or compatible matrix/data.frame) containing ordered connection data. The input should be a square matrix or have square number of columns.
#'
#' @return A data.table with unordered row connections, reclassified as "unordered.row.connections", "row.connections", and "ena.matrix".
#'
#' @export
'as.unordered.ordered.row.connections' <- function(x) {
  # m <- as.matrix(x);
  m <- as.matrix.ena.matrix(x);
  sq_size <- sqrt(ncol(m));
  ind_mat <- matrix(seq.int(ncol(m)), nrow = sq_size, ncol = sq_size);
  ind_ut <- ind_mat[upper.tri(ind_mat, diag = FALSE)];
  ind_lt <- ind_mat[lower.tri(ind_mat, diag = FALSE)];
  
  # m_unordered <- data.table::as.data.table(m[, ind_ut, drop = FALSE] + m[, ind_lt, drop = FALSE]);
  m_unordered <- data.table::as.data.table(t(apply(m, 1, function(mm) (mm[as.vector(ind_mat)] + mm[as.vector(t(ind_mat))])[ind_ut], simplify = T)));
  m_unordered <- m_unordered[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = colnames(m_unordered)];
  
  m_unordered <- cbind(x[,find_meta_cols(x), with = FALSE], m_unordered);
  m_unordered <- reclass(x = m_unordered, c("unordered.row.connections", "row.connections", "ena.matrix"));
  
  m_unordered
}

#' Default Method for as.unordered
#'
#' This function provides the default method for handling the input \code{x} when no specific method is available.
#'
#' @param x Any object that you want to apply the default method to.
#'
#' @return The input object \code{x}, unchanged.
#' @export
'as.unordered.default' <- function(x){
  x
}

#' Convert to Unordered Factor
#'
#' This function is a generic method to convert an object to an unordered factor.
#' It dispatches methods based on the class of the input object.
#'
#' @param x An object to be converted to an unordered factor.
#'
#' @return An unordered factor representation of the input object.
#'
#' @export
'as.unordered' <- function(x) {
  UseMethod("as.unordered")
}

#region Moved from rENA ----

#' Find metadata columns
#'
#' @param x data.table (or frame) to search for columns of class ena.metadata
#'
#' @return logical vector
#' @export
find_meta_cols <- function(x) {
   sapply(x, is, class2 = "ena.metadata")
}

#' Remove meta columns from a data.table or data.frame
#'
#' This function removes columns of class `ena.meta.data` from the input object.
#'
#' @param x A `data.table` or `data.frame` object from which meta columns should be removed.
#'
#' @return A `data.frame` with columns of class `ena.meta.data` removed.
#' @export
remove_meta_data <- function(x) {
   as.data.frame(x)[, !find_meta_cols(x), drop = F]
}

#' Matrix without metadata
#'
#' @param x Object to convert to  a matrix
#' @param ... 	additional arguments to be passed to or from methods
#'
#' @return matrix
#' @export
as.matrix.ena.matrix <- function(x, ...) {
  class(x) = class(x)[-1]
  x = remove_meta_data(x)
  as.matrix(x, ...)
}

namesToAdjacencyKey <- function(vector, upper_triangle = TRUE) {
  upperTriIndices = connection_indices(length(vector)) + 1;
  matrix(vector[upperTriIndices], nrow=2)
}

#' @title Names to Adjacency Key
#'
#' @description Convert a vector of strings, representing the names of a square matrix, to an adjacency key matrix.
#'
#' @details Returns a matrix with 2 rows and choose(length(vector), 2) columns, where each column represents a unique pair of names from the input vector, corresponding to the upper triangle of a square matrix.
#'
#' @param vector Vector representing the names of a square matrix.
#' @param upper_triangle Not Implemented.
#'
#' @return A character matrix with 2 rows and choose(length(vector), 2) columns. Each column contains a pair of names representing a unique adjacency (edge) between nodes in the original square matrix.
#' @export
namesToAdjacencyKey <- function(vector, upper_triangle = TRUE) {
  upperTriIndices = connection_indices(length(vector)) + 1;
  matrix(vector[upperTriIndices], nrow=2)
}

CLASS_NAMES <- list(
  data = "qe.data",
  meta = "qe.metadata",
  code = "qe.code",
  unit = "qe.unit",
  horizon = "qe.horizon"
)

WARNINGS <- list(
  data_from_vector = "Cannot transform vectors to `qe.data`",
  null_metadata = "`metadata` must be supplied as a vector of column names. No metadata classified.",
  null_codes = "`codes` must be supplied as a vector of column names. No codes classified.",
  null_units = "`units` must be supplied as a vector of column names. No units classified.",
  null_horizon = "`horizon` must be supplied as a vector of column names. No horizon classified."
)

#' Convert an object to 'qe.data' class
#'
#' This function converts an object to the 'qe.data' class. If the object is not a data.frame or matrix, it is first converted to a data.table.
#'
#' @param x An object. The object to be converted to 'qe.data' class.
#'
#' @return The modified object with the 'qe.data' class.
#' @examples
#' library(data.table)
#'
#' dt <- data.table(
#'   ID = 1:5,
#'   Name = c("Alice", "Bob", "Charlie", "David", "Eve"),
#'   Age = c(25, 30, 35, 40, 45),
#'   Score = c(85, 90, 95, 80, 75)
#' )
#' dt <- as.qe.data(dt);
#' class(dt) # Should show 'qe.data' along with other classes
#'
#' @export
as.qe.data <- function(x) {
  if(!is.qe.data(x)) {
    if(is.vector(x)) {
      warning(WARNINGS$data_from_vector);
    }
    else {
      if(
         is.matrix(x) ||
        (is.data.frame(x) && !data.table::is.data.table(x))
      ) {
        x <- data.table::as.data.table(x);
      }
      class(x) <- c(CLASS_NAMES$data, class(x));
    }
  }

  # return(data.table::copy(x));
  return(x);
}

#' Convert a vector to 'qe.code' class
#'
#' This function converts a vector to the 'qe.code' class. If the vector is a factor, it is first converted to a character vector.
#'
#' @param x A vector. The vector to be converted to 'qe.code' class.
#'
#' @return The modified vector with the 'qe.code' class.
#' @examples
#' vec <- factor(c("A", "B", "C"))
#' vec <- as.qe.code(vec)
#' class(vec) # Should show 'qe.code' along with other classes
#' @export
as.qe.code <- function(x) {
  if(is.qe.code(x)) return(x);

  if(is.factor(x)) {
    x <- as.character(x);
  }
  class(x) <- c(CLASS_NAMES$code, class(x));

  return(x);
}

#' Convert a vector to 'qe.metadata' class
#'
#' This function converts a vector to the 'qe.metadata' class. If the vector is a factor, it is first converted to a character vector.
#'
#' @param x A vector. The vector to be converted to 'qe.metadata' class.
#'
#' @return The modified vector with the 'qe.metadata' class.
#' @examples
#' vec <- factor(c("A", "B", "C"))
#' vec <- as.qe.metadata(vec)
#' class(vec) # Should show 'qe.metadata' along with other classes
#' @export
as.qe.metadata <- function(x) {
  if(is.qe.metadata(x)) return(x);

  if(is.factor(x)) {
    x <- as.character(x);
  }
  class(x) <- c(CLASS_NAMES$meta, class(x));

  return(x);
}

#' Convert a vector to 'qe.unit' class
#'
#' This function converts a vector to the 'qe.unit' class. If the vector is a factor, it is first converted to a character vector.
#'
#' @param x A vector. The vector to be converted to 'qe.unit' class.
#'
#' @return The modified vector with the 'qe.unit' class.
#' @examples
#' vec <- factor(c("A", "B", "C"))
#' vec <- as.qe.unit(vec)
#' class(vec) # Should show 'qe.unit' along with other classes
#' @export
as.qe.unit <- function(x) {
  if(is.qe.unit(x)) return(x);

  if(is.factor(x)) {
    x <- as.character(x);
  }
  class(x) <- c(CLASS_NAMES$unit, class(x));

  return(x);
}

#' Convert a vector to 'qe.horizon' class
#'
#' This function converts a vector to the 'qe.horizon' class. If the vector is a factor, it is first converted to a character vector.
#'
#' @param x A vector. The vector to be converted to 'qe.horizon' class.
#'
#' @return The modified vector with the 'qe.horizon' class.
#' @examples
#' vec <- factor(c("A", "B", "C"))
#' vec <- as.qe.horizon(vec)
#' class(vec) # Should show 'qe.horizon' along with other classes
#' @export
as.qe.horizon <- function(x) {
  if(is.qe.horizon(x)) return(x);

  if(is.factor(x)) {
    x <- as.character(x);
  }
  class(x) <- c(CLASS_NAMES$horizon, class(x));

  return(x);
}

#' Check if an object is of class 'qe.data'
#'
#' This function checks if an object is of class 'qe.data'.
#'
#' @param x An object. The object to be checked.
#'
#' @return A logical value. TRUE if the object is of class 'qe.data', otherwise FALSE.
#' @examples
#' library(data.table)
#'
#' dt <- data.table(ID = 1:5)
#' class(dt) <- c("qe.data", class(dt))
#' is.qe.data(dt) # Should return TRUE
#' @export
is.qe.data <- function(x) {
  return(CLASS_NAMES$data %in% class(x));
}

#' Check if an object is of class 'qe.code'
#'
#' This function checks if an object is of class 'qe.code'.
#'
#' @param x An object. The object to be checked.
#'
#' @return A logical value. TRUE if the object is of class 'qe.code', otherwise FALSE.
#' @examples
#' dt <- 1:5
#' class(dt) <- c("qe.code", class(dt))
#' is.qe.code(dt) # Should return TRUE
#' @export
is.qe.code <- function(x) {
  return(CLASS_NAMES$code %in% class(x));
}

#' Check if an object is of class 'qe.metadata'
#'
#' This function checks if an object is of class 'qe.metadata'.
#'
#' @param x An object. The object to be checked.
#'
#' @return A logical value. TRUE if the object is of class 'qe.metadata', otherwise FALSE.
#' @examples
#' dt <- 1:5
#' class(dt) <- c("qe.metadata", class(dt))
#' is.qe.metadata(dt) # Should return TRUE
#' @export
is.qe.metadata <- function(x) {
  return(CLASS_NAMES$meta %in% class(x));
}


#' Check if an object is of class 'qe.unit'
#'
#' This function checks if an object is of class 'qe.unit'.
#'
#' @param x An object. The object to be checked.
#'
#' @return A logical value. TRUE if the object is of class 'qe.unit', otherwise FALSE.
#' @examples
#' dt <- 1:5
#' class(dt) <- c("qe.unit", class(dt))
#' is.qe.unit(dt) # Should return TRUE
#' @export
is.qe.unit <- function(x) {
  return(CLASS_NAMES$unit %in% class(x));
}

#' Check if an object is of class 'qe.horizon'
#'
#' This function checks if an object is of class 'qe.horizon'.
#'
#' @param x An object. The object to be checked.
#'
#' @return A logical value. TRUE if the object is of class 'qe.horizon', otherwise FALSE.
#' @examples
#' dt <- 1:5
#' class(dt) <- c("qe.horizon", class(dt))
#' is.qe.horizon(dt) # Should return TRUE
#' @export
is.qe.horizon <- function(x) {
  return(CLASS_NAMES$horizon %in% class(x));
}

#' accumulate_threads
#'
#' @param data TBD
#' @param units_by TBD
#' @param conversation_rules TBD
#' @param code_cols TBD
#' @param ... TBD
#' @param conversation_splits TBD
#' @param as_directed TBD
#' @param window_size TBD
#' @param meta_data TBD
#'
#'
#' @return TBD
#' @export
accumulate_threads <- function(
  data,
  units_by,
  conversation_rules,
  code_cols,
  ...,
  conversation_splits = NULL,
  as_directed = FALSE,
  window_size = 4,
  meta_data = units_by
) {
  if(!data.table::is.data.table(data)) {
    data <- data.table::as.data.table(data);
  }
  
  model <- contexts(
    x = data,
    units_by = units_by,
    hoo_rules = conversation_rules,
    split_rules = conversation_splits
  );
  model <- accumulate_context_threads(
    x = model, 
    codes = code_cols,
    as_directed = as_directed,
    window_size = window_size,
    meta.data = meta_data,
    ...
  );
  
  return(model);
}

##
#' @title Find conversations by unit
#'
#' @description
#' Identify and extract rows corresponding to conversations for specified units in a dataset or context model. Useful for subsetting and analyzing conversational windows in network analysis.
#'
#' @details
#' This function groups rows by conversation (using `conversation.by` columns), identifies which rows are associated with the specified units and codes, and returns indices for each conversation, as well as metadata about which rows to include or exclude.
#'
#' @param x A data.frame or context model containing conversation data.
#' @param units Character vector of unit identifiers to extract conversations for.
#' @param units.by Character vector of column names specifying unit grouping (default: from context model attributes).
#' @param codes Character vector of code columns to use for identifying coded rows.
#' @param conversation.by Character vector of column names to group by conversation.
#' @param window Integer; window size for co-occurrence (default: 4).
#' @param conversation.exclude Character vector of conversation keys to exclude.
#' @param id_col Character; column name for unit IDs (default: "QEUNIT").
#'
#' @return A list with elements:
#'   \item{conversations}{List of row indices for each conversation.}
#'   \item{unitConvs}{Unique conversation keys for the specified units.}
#'   \item{allRows}{All row indices included for the units.}
#'   \item{unitRows}{Row indices for the units with codes.}
#'   \item{convRows}{All row indices for the unit's conversations.}
#'   \item{toRemove}{Rows not meeting co-occurrence criteria.}
#'
#' @export
tma.conversations = function(
  x, units, 
  units.by = NULL, codes = NULL, conversation.by = NULL, 
  window = 4, conversation.exclude = c(),
  id_col = "QEUNIT"
) {
  if(is.null(units.by)) {
    units.by = x$`_function.params`$units.by;
    if(is.null(units.by)) {
      stop("Unable to find values for `units.by`")
    }
  }
  
  if(is(x, "data.frame")) {
    rawAcc2 = data.table::data.table(x);
  }
  else {
    rawAcc2 = x$model$raw.input;
  }

  rawAcc2$KEYCOL = merge_columns(rawAcc2, conversation.by);
  conversationsTable2 = rawAcc2[, paste(.I, collapse = ","), by = c(conversation.by)];
  rows2 = lapply(conversationsTable2$V1, function(x) as.numeric(unlist(strsplit(x, split=","))));
  names(rows2) = merge_columns(conversationsTable2, conversation.by);
  unitRows2 = rawAcc2[[id_col]];

  codedRows = rawAcc2[, rowSums(.SD), .SDcols = codes] > 0
  codedUnitRows2 = which(unitRows2 %in% units & codedRows)
  codedUnitRows2 = codedUnitRows2[!(codedUnitRows2 %in% as.vector(unlist(rows2[conversation.exclude])))]
  codedUnitRowConvs2 = rawAcc2[codedUnitRows2, KEYCOL];

  codedUnitRowConvsAll = NULL;
  codedUnitRowConvsAll2 = NULL;
  unitRowsNotCooccurred = c()
  if(length(codedUnitRows2) > 0) {
    codedUnitRowConvsAll = unique(unlist(sapply(X = 1:length(codedUnitRows2), simplify = F, FUN = function(x) {
      thisConvRows = rows2[[codedUnitRowConvs2[x]]]
      thisRowInConv = which(thisConvRows == codedUnitRows2[x])
      winUse = ifelse(is.infinite(window), thisRowInConv, window)
      thisRowAndWindow = rep(thisRowInConv,winUse) - (winUse-1):0
      # coOccursFound = all(rawAcc2[thisConvRows[thisRowAndWindow[thisRowAndWindow > 0]], lapply(.SD, sum), .SDcols=codes] > 0)
      coOccursFound = sum(rawAcc2[thisConvRows[thisRowAndWindow[thisRowAndWindow > 0]], lapply(.SD, sum), .SDcols=codes]) > 1
      # browser(expr = { thisConvRows[thisRowInConv] == 12 })
      if(coOccursFound) {
        thisConvRows[thisRowAndWindow[thisRowAndWindow > 0]]
      }
      else {
        unitRowsNotCooccurred <<- c(unitRowsNotCooccurred, thisConvRows[thisRowInConv]);
        
        NULL
      }
    })))
  }

  # browser()
  unitConvs <- unique(rawAcc2[codedUnitRows2, KEYCOL]);
  return(list(
    conversations = as.list(rows2),
    unitConvs = unitConvs,
    allRows = codedUnitRowConvsAll,
    unitRows = codedUnitRows2,
    convRows = unique(unlist(sapply(unitConvs, function(x) { rows2[[x]] }))),
    toRemove = unitRowsNotCooccurred
  ));
}


#' @title Interactive Conversation Viewer
#'
#' @description
#' Launch an interactive HTML viewer for conversations and codes for a specified unit or set of units. Useful for exploring and validating conversation windows and code assignments in the TMA workflow.
#'
#' @param x A context model or data.frame containing conversation data.
#' @param wh Character or integer; unit(s) to view.
#' @param text_col Character; column name for text (default: "text").
#' @param units.by Character vector of unit grouping columns (default: from context model attributes).
#' @param conversation.by Character vector of conversation grouping columns (default: from context model attributes).
#' @param codes Character vector of code columns (default: from context model attributes).
#' @param window_size Integer; window size for co-occurrence (default: from context model attributes).
#' @param more_cols Character vector of additional columns to include in the viewer.
#' @param in_browser Logical; if TRUE, open in system browser, otherwise use RStudio viewer (default: FALSE).
#' @param id_col Character; column name for unit IDs (default: "QEUNIT").
#'
#' @return A list containing the viewer data and metadata (invisibly). The function is called for its side effect of launching the viewer.
#' @export
view <- function(
  x, wh, 
  text_col = "text", 
  units.by = x$`_function.params`$units.by,
  conversation.by = x$`_function.params`$conversation.by,
  codes = x$rotation$codes,
  window_size = x$`_function.params`$window_size,
  more_cols = NULL,
  in_browser = FALSE,
  id_col = "QEUNIT"
) {
  unit_conv <- tma.conversations(x = x, units = wh, units.by = units.by, conversation.by = conversation.by, codes = codes, window = window_size, id_col = id_col);
  # rows <- x$model$contexts[[wh]];
  # if(is.null(rows)) {
  #   stop(paste0("Now rows found for context: ", wh));
  # }

  cols <- unique(c("QEID", id_col, units.by, conversation.by, text_col, more_cols, codes));
  cols <- cols[cols %in% colnames(x$model$raw.input)];
  tbl <- x$model$raw.input[unit_conv$convRows, cols, with = FALSE];
  unit_conv$unitRows <- unit_conv$unitRows;
  unit_conv$toRemove <- unit_conv$toRemove;
  unit_conv$data <- tbl;
  unit_conv$units <- wh;
  unit_conv$window <- window_size;

  if(requireNamespace("jsonlite", quietly = TRUE) == FALSE) {
    stop("Please install the `jsonlite` package to use this function.")
  }
  
  tbl_json <- jsonlite::toJSON(unit_conv, auto_unbox = TRUE);

  tmp_html <- tempfile(fileext = ".html")
  html_lines <- readLines(system.file(package="tma", paste0("apps/viewer.html")));
  html_lines[grepl("//_ENA_MODEL_//", x = html_lines)] <- paste0("data = ", tbl_json, ";");
  writeLines(text = html_lines, con = tmp_html);
  
  if(in_browser == TRUE) {
    browseURL(tmp_html);
  }
  else {
    rstudioapi::viewer(tmp_html)
  }
}

#' Conversation membership and per-modality window spans (Data View v2)
#'
#' TMA-aware successor to \code{tma.conversations()}. For each unit's coded
#' reference rows it returns the co-occurring rows within that row's
#' \emph{per-modality} window, plus a \code{rowWindows} payload that drives the
#' webtool Data View window-span hover.
#'
#' Unlike \code{tma.conversations()} (which predates the window/weight matrix and
#' uses a single scalar window), this derives windows from the resolved tensor
#' persisted on the accumulated object (\code{x$`_function.params`$tensor}) and
#' calls the libqe primitive \code{apply_tensor_members()} — the SAME code path
#' the network uses — so the Data View can't drift from the network.
#'
#' @param x An accumulated tma set (from \code{accumulate()}); must carry
#'   \code{_function.params$tensor} and \code{_function.params$mode_column}
#'   (populated by \code{accumulate()} since the 5a change).
#' @param codes Code column names. Defaults to \code{_function.params$codes}.
#' @param id_col Row-identity column. Default \code{"QEID"}.
#'
#' @return A list with \code{unitRows}, \code{allRows}, \code{toRemove} (row ids)
#'   and \code{rowWindows}: a named list keyed by reference row id, each
#'   \code{list(refMode, members = list(list(row, mode, distance, admittedBy,
#'   window, coOccurs)))}. (\code{conversations}/\code{unitConvs} grouping is
#'   layered on by the caller/server, mirroring \code{tma.conversations()}.)
#' @importFrom libqe apply_tensor_members
#' @export
tma.conversations2 <- function(x, codes = NULL, id_col = "QEID") {
  fp <- x$`_function.params`
  tensor <- fp$tensor
  if (is.null(tensor))
    stop("x lacks _function.params$tensor; re-accumulate with a tma build that persists it (5a).")
  if (is.null(codes)) codes <- fp$codes
  mode_col    <- attr(tensor, "mode_column")
  time_column <- if (!is.null(fp$time_column)) fp$time_column else ATTR_NAMES$CONTEXT_COL_ID

  send_cols <- attr(tensor, "sender_cols")
  recv_cols <- attr(tensor, "receiver_cols")
  mode_cols <- attr(tensor, "mode_column")
  tensor_dim           <- attr(tensor, "dim")
  tensor_sender_inds   <- attr(tensor, "sender_inds")   - 1
  tensor_receiver_inds <- attr(tensor, "receiver_inds") - 1
  tensor_mode_inds     <- attr(tensor, "mode_inds")     - 1

  rowWindows  <- list()
  allRows     <- integer()
  unitRowsAll <- integer()
  toRemove    <- integer()

  cols_to_encode <- c(send_cols, recv_cols, mode_cols)
  cols_unq       <- unique(cols_to_encode)
  # Global factor levels for the context (mode/sender/receiver) columns. A
  # per-context as.factor() would collapse a single-modality conversation to
  # level 1 and read the WRONG modality's window cell -- e.g. a SecondHalf-only
  # context reading FirstHalf's window (accumulate() dodges this only because
  # its columns are pre-factored with global levels upstream). Encoding each
  # context against these global levels keeps the row lookup aligned with the
  # tensor's physical axes.
  #
  # The tensor's own per-axis dimnames ARE that global order
  # (context_tensor -> get_unique_values -> sort(unique(.))), and -- unlike
  # x$model$raw.input -- they survive when this runs on a set reused from an
  # ena.generate session (raw.input is stripped off the returned set). Prefer
  # them; fall back to raw.input only if an axis has no usable names.
  dn          <- dimnames(tensor)
  axis_levels <- function(cc) {
    si <- match(cc, send_cols); if (!is.na(si)) return(dn[[paste0("sender_", si)]])
    ri <- match(cc, recv_cols); if (!is.na(ri)) return(dn[[paste0("receiver_", ri)]])
    if (length(mode_cols) && cc == mode_cols)   return(dn[["modes"]])
    NULL
  }
  raw_full   <- x$model$raw.input
  ctx_levels <- lapply(cols_unq, function(cc) {
    ax <- axis_levels(cc)
    if (!is.null(ax))               as.character(ax)
    else if (!is.null(raw_full))    as.character(sort(unique(raw_full[[cc]])))
    else stop("tma.conversations2: cannot resolve global levels for column ", cc)
  })
  names(ctx_levels) <- cols_unq

  process_ctx <- function(ctx_o) {
    unit_rows <- attr(ctx_o, "tma.unit_rows")
    if (is.null(unit_rows) || length(unit_rows) == 0) return(invisible())

    # ---- prep identical to accumulate() so windows match the network ----
    ctx__ <- data.table::copy(ctx_o)
    if (length(cols_to_encode) && !all(sapply(ctx__[, ..cols_to_encode], is.numeric))) {
      ctx__[, (cols_unq) := lapply(cols_unq, function(cc) match(as.character(ctx__[[cc]]), ctx_levels[[cc]]))]
    }
    unit_context_lookup <- as.matrix(ctx__[, ..cols_to_encode])
    unit_to_last <- seq.int(unit_rows[length(unit_rows)])
    ctx_unit_to_last <- ctx__[unit_to_last, ]

    res <- apply_tensor_members(
      tensor, tensor_dim, tensor_sender_inds, tensor_receiver_inds, tensor_mode_inds,
      unit_context_lookup[unit_to_last, , drop = FALSE] - 1,
      unit_rows - 1,
      as.matrix(ctx_unit_to_last[, ..codes]),
      ctx_unit_to_last[[time_column]]
    )

    # ---- reshape membership -> rowWindows (using original, unencoded values) ----
    ids     <- ctx_o[[id_col]]
    modev   <- as.character(ctx_o[[mode_col]])
    codeMat <- as.matrix(ctx_o[, ..codes])

    for (i in seq_along(unit_rows)) {
      ur   <- unit_rows[i]                 # 1-based position in ctx_o
      # A reference row must itself carry >=1 of the queried (edge) codes --
      # rows with none are not connection references for this edge.
      if (sum(codeMat[ur, ]) == 0) next
      mem  <- res$row_window_members[[i]]  # 1-based positions in ctx_unit_to_last (== ctx_o[<= last])
      wins <- res$row_window_wins[[i]]

      # Edge co-occurrence: EVERY queried code appears somewhere in the window
      # (the reference row + its in-window members) -- i.e. the edge's endpoints
      # both fall inside the window, not merely >=2 code instances.
      windowHasCoOccur <- all(colSums(codeMat[c(mem, ur), , drop = FALSE]) > 0)
      members <- lapply(seq_along(mem), function(k) {
        g <- mem[k]
        list(row = ids[g], mode = modev[g], distance = ur - g,
             admittedBy = modev[g], window = wins[k],
             coOccurs = unname((sum(codeMat[g, ]) > 0) && windowHasCoOccur))
      })
      rowWindows[[as.character(ids[ur])]] <<- list(refMode = modev[ur], members = members)
      unitRowsAll <<- c(unitRowsAll, ids[ur])
      if (windowHasCoOccur) allRows <<- c(allRows, ids[c(mem, ur)]) else toRemove <<- c(toRemove, ids[ur])
    }
  }

  for (ctx in x$model$contexts) {
    if (is.data.frame(ctx)) process_ctx(ctx) else lapply(ctx, process_ctx)
  }

  list(
    unitRows   = unique(unitRowsAll),
    allRows    = unique(allRows),
    toRemove   = unique(toRemove),
    rowWindows = rowWindows
  )
}


#' @title Internal: Simple window decay (legacy)
#' @description
#' Internal helper for window decay, used in TMA v0.1.0. Not exported. Kept for backward compatibility with legacy decay function creation.
#' 
#' @param x Numeric vector of time differences.
#' @param args List of arguments (expects `window_size`).
#' @return Numeric vector (0/1) indicating whether each value is within the window.
#' @export
simple_window <- function(x, args = NULL) { 
  .Deprecated("tma::context_tensor", "tma v0.2.0");
  (x <= args$window_size) * 1 
}

#' @title Internal: Decay function factory (legacy)
#' @description
#' Internal factory for creating decay functions, used in TMA v0.1.0. Not exported. Kept for backward compatibility with legacy code.
#' 
#' @param what Function to use as the decay kernel.
#' @param ... Named parameters to pass to `what`.
#' @return A function that applies the specified decay kernel to its input.
#' @export 
decay <- function(what, ...) {
  .Deprecated("tma::context_tensor", "tma v0.2.0");
  args <- list(...);
  function(x) {
    do.call(what, list(x = x, args = args))
  }
}

#' Apply windowing and weighting to context data for network accumulation
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' `apply_tensor_old` is a deprecated alias for the tensor-based accumulation
#' function.  Use [accumulate()] for the full TMA accumulation pipeline.
#'
#' @param tensor NumericVector. Flat multi-dimensional context_tensor array.
#' @param dims IntegerVector. Dimensions of the original context_tensor array.
#' @param dims_sender Integer vector. 0-based indices of sender dimensions.
#' @param dims_receiver Integer vector. 0-based indices of receiver dimensions.
#' @param dims_mode Integer vector. 0-based indices of mode dimensions.
#' @param context_matrix NumericMatrix. Context lookup matrix (rows = context lines, cols = factors).
#' @param unit_rows Integer vector. 0-based response-row indices for this unit.
#' @param codes Numeric matrix. Code matrix (nrow = context lines, ncol = number of codes).
#' @param times Numeric vector. Timestamp per context row.
#' @param ordered Logical. TRUE = directed; FALSE = undirected upper-triangle.
#' @return List with \code{row_connection_counts} and \code{connection_counts}.
#' @export
apply_tensor_old <- function(tensor, dims, dims_sender, dims_receiver, dims_mode,
                              context_matrix, unit_rows, codes, times,
                              ordered = TRUE) {
  apply_tensor(tensor, dims, dims_sender, dims_receiver, dims_mode,
                  context_matrix, unit_rows, codes, times, ordered)
}

##' Set Units of Analysis for a TMA Model
#'
#' Internal helper to initialize and label units of analysis in a TMA model object.
#' Given a data.frame and a set of columns, this function creates a model structure
#' with unit labels and context placeholders for each unique unit.
#'
#' @param x A data.frame or TMA model object containing the raw input data.
#' @param by Character vector of column names to use for defining units of analysis (e.g., c("userID", "condition")).
#'
#' @return A TMA model object with unit labels and empty context slots for each unit.
units <- function(x, by) {
  model <- x;
  if ( is.data.frame(x) ) {
    model <- list(
      model = list (
        model.type = "TMA",
        raw.input = data.table::as.data.table( x ),
        row.connection.counts = as.data.frame(matrix(nrow = nrow( x ), ncol = 0))
      )
    )
    class(model) <- c("ena.set", class(model))
  }
  
  model$model$raw.input[[ATTR_NAMES$CONTEXT_ID]] <- 1;
  model$model$raw.input$QEID <- seq(nrow(model$model$raw.input));
  data.table::setkeyv(x = model$model$raw.input, cols = c("QEID"));
  
  # raw_input <- model$model$raw.input;
  model$`_function.params`$units.by <- by;
  
  all_units <- model$model$raw.input[, ..by];
  unique_units <- unique(all_units);
  model$`_function.params`$units <- all_units;
  
  unique_unit_labels <- apply(unique_units, 1, function(y) paste((y), collapse = "::"));

  # model$model$contexts <- structure(rep(list(model$model$raw.input[0,]), length(unique_unit_labels)), names = unique_unit_labels);
  model$model$contexts <- structure(rep(list(c()), length(unique_unit_labels)), names = unique_unit_labels);
  model$model$unit.labels <- unique_unit_labels;
  model$model$raw.input$QEUNIT <- apply(all_units, 1, function(y) paste((y), collapse = "::"));
  # model$model$raw.input[, QEUNIT:=paste(.SD, collapse = "::"), .SDcols = names(all_units), by=1:nrow(model$model$raw.input)]
  
  return(model);
}

##' Apply a Subsetting Rule to TMA Contexts (Internal)
#'
#' Internal helper to apply a logical subsetting rule ("hoo rule") to each unit's context in a TMA model object.
#' Updates the contexts for each unit by including only rows that match the rule.
#'
#' @param x A TMA model object as produced by [units()].
#' @param ... Logical expression(s) specifying the subsetting rule to apply. If not provided, uses the `rule` argument.
#' @param rule A single logical expression to use as the subsetting rule (alternative to ...).
#'
#' @return The input TMA model object with updated contexts for each unit, where each context contains only rows matching the rule.
hoo <- function(x, ..., rule = NULL) {
  units <- x$`_function.params`$units;
  unit_contexts <- x$model$contexts;

  hoo_args <- substitute(...);
  if( is.null(hoo_args) ) {
    hoo_args <- rule;
  }

  raw_input <- x$model$raw.input;
  
  unique_units <- unique(units);
  updated_contexts <- lapply(seq(nrow(unique_units)), function(i) {
    this_unit <- unique_units[i,];
    this_unit <- this_unit[, lapply(.SD, reclass, "ena.metadata"), .SDcols = colnames(this_unit)];
    
    unit_label <- paste(this_unit, collapse = "::");
    # UNIT <- raw_input[as.list(this_unit), , on = names(this_unit)];
    UNIT <- mapply(raw_input[as.list(this_unit), , on = names(this_unit)], FUN = unique, SIMPLIFY = FALSE);

    this_context <- unit_contexts[[unit_label]];
    ret <- sort(unique(c(this_context, raw_input[eval(hoo_args), , which = TRUE])));
    attr(x = ret, which = "tma.unit") <- this_unit;
    ret
  });
  names(updated_contexts) <- names(unit_contexts)
  
  x$model$contexts <- updated_contexts; #unit_contexts; 
  
  x
}

#' Capture Subsetting Rules as Expressions
#'
#' Allows users to supply conditions for subsetting rows from their data. The collected unevaluated expressions are intended to be used as the `hoo_rules` parameter in the `contexts()` function within the TMA workflow.
#'
#' @param ... Logical expressions specifying the conditions for subsetting data. These expressions are captured unevaluated and returned as a list.
#'
#' @return A list of unevaluated expressions representing subsetting rules.
#' 
#' @examples
#' 
#' rules(
#'   modality %in% "chat" & chatGroup %in% UNIT$chatGroup & condition %in% UNIT$condition, 
#'   modality %in% "resource" & userID %in% UNIT$userID & condition %in% UNIT$condition
#' )
#' 
#' @export
rules <- function(...) {
  rlang::exprs(...)
}

#' Conversation rules
#'
#' @param ... list of rules
#'
#' @return callable expressions, see `rlang::exprs`
#' @export
conversation_rules <- function(...) {
  rlang::exprs(...)
}

##' Create Contexts for Units of Analysis
#'
#' This function generates context data for each unit of analysis in your dataset, applying subsetting rules ("hoo rules") and optional splitting rules to organize the data for network accumulation.
#'
#' @param x A data.frame or TMA model object containing the raw input data.
#' @param hoo_rules A list of logical expressions (see [rules()]) specifying how to subset the data for each context/unit.
#' @param units_by Character vector of column names to use for defining units of analysis (e.g., c("userID", "condition")).
#' @param split_rules Optional. Either a function or an expression specifying how to further split each context (e.g., by time period or other grouping variable).
#'
#' @return A TMA model object with updated contexts for each unit, where each context is a data.table containing only the relevant rows for that unit and context. The object includes attributes for unit labels and context row indices.
#'
#' @details
#' This function is a core part of the TMA workflow. It first applies the specified `hoo_rules` to subset the data for each unit, then (optionally) applies `split_rules` to further divide each context. The resulting contexts are used in subsequent accumulation and network analysis steps.
#'
#' @examples
#' data(test_mockdata, package = "tma")
#' mock_data <- test_mockdata[test_mockdata$chatGroup == "PAM",]
#' unit_cols <- c("userID", "condition")
#' codes <- c("A", "B", "C")
#' HOO_rules_model <- rules(
#'   modality %in% "chat" & chatGroup %in% UNIT$chatGroup & condition %in% UNIT$condition, 
#'   modality %in% "resource" & userID %in% UNIT$userID & condition %in% UNIT$condition
#' )
#'  
#' context_model <- contexts(
#'   x = mock_data,
#'   units = unit_cols,
#'   hoo_rules = HOO_rules_model
#' )
#' str(context_model$model$contexts)
#'
#' @export
contexts <- function(x, hoo_rules, units_by = NULL, split_rules = NULL) {
  x_ <- units(x, units_by);
  
  for(r in hoo_rules) {
    x_ <- hoo(x_, rule = r);
  }

  raw_input <- x_$model$raw.input;
  split_expr_valid <- TRUE;
  err_found <- 0;
  tryCatch(expr = rlang::enexpr(split_rules), error = function(e) {
      err_found <<- 1;
      print(e$message)
  }, warning = function(w) { 
      err_found <<- 2;
  }, finally = {
      if(err_found != 0) {
        split_expr_valid <- FALSE;
      }
  })
  
  if(split_expr_valid) {
    split_rules_expr <- rlang::enexpr(split_rules);
    
    if( !is.null(split_rules_expr) ) {
      unit_contexts <- x_$model$contexts;
      model_units <- x_$`_function.params`$units;
  
      # if ( is.function (split_rules) ) {
      if( is(split_rules, "function") ) {
        unique_units <- unique(model_units);
        unit_contexts_res <- apply(unique_units, 1, function(u) {
          unit_label <- paste(u, collapse = "::");
          res <- do.call(what = split_rules, args = list(unit = u, raw_input[unit_contexts[[unit_label]]]));
          attr(res, "tma.unit") <- attr(unit_contexts[[unit_label]], "tma.unit");
          res2 <- lapply(res, function(r) {
            r[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(r));
            attr(r, "tma.unit") <- attr(res, "tma.unit");
            attr(r, "tma.unit_rows") <- which(r$QEUNIT == unit_label)
            r
          });
          res2
        });
        names(unit_contexts_res) <- apply(unique_units, 1, paste, collapse = "::"); #names(unit_contexts);
        unit_contexts <- unit_contexts_res;
      }
      else {
        if( !inherits(x = split_rules_expr, what = "call") ) {
          for(i in seq(split_rules_expr)) {
            unit_contexts <- lapply(unit_contexts, function(uc) {
              lapply(split(x = raw_input[uc,], by = as.character(split_rules)), function(x) {
                unit_tbl <- attr(x = uc, "tma.unit");
                unit_label <- paste0(unit_tbl, collapse = "::");
                
                x[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(x));
                attr(x = x, which = "tma.unit") <- attr(x = uc, "tma.unit");
                attr(x = x, which = "tma.unit_rows") <- which(x$QEUNIT == unit_label);
                x
              });
            })
          }
        }
        else {
          for( i in seq(split_rules) ) {
            if ( is.name(split_rules[[i]]) ){
              # unit_contexts <- lapply(unit_contexts, split, by = as.character(split_rules[[i]]))
              unit_contexts <- lapply(unit_contexts, function(uc) {
                split(x = raw_input[uc,], by = as.character(split_rules[[i]]))
              })
            }
            else {
              stop("THIS NEEDS UPDATING (1)")
              units_to_split <- model_units[eval(split_rules[[i]][[2]]), , which = TRUE]
              unit_contexts[units_to_split] <- lapply(unit_contexts[units_to_split], split, by = names(split_rules[i]))
            }
          }
        }
      }
      
      x_$model$contexts <- unit_contexts;
    }
    else {
      unit_contexts <- x_$model$contexts;
      model_units <- x_$`_function.params`$units;
      unique_units <- unique(model_units);
      unit_contexts_res <- apply(unique_units, 1, function(u) {
        # unit_label <- paste(u, collapse = "::");
        unit_label <- paste(trimws(u), collapse = "::");
        res <- raw_input[unit_contexts[[unit_label]]];
        res[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(res));
        
        attr(res, "tma.unit") <- attr(unit_contexts[[unit_label]], "tma.unit");
        attr(res, "tma.unit_rows") <- which(res$QEUNIT == unit_label);
        res
      });
      names(unit_contexts_res) <- apply(unique_units, 1, paste, collapse = "::"); #names(unit_contexts);
      unit_contexts <- unit_contexts_res;
      x_$model$contexts <- unit_contexts;
    }
  }
  
  # x_list <- list2env(x_);
  # class(x_list) <- c("ena.set", class(x_list));
  # return(x_list);
  x_
}

1		`_sphere_norm` <- function(x) {
2	7x	x <- as.matrix(x);
3	7x	r <- nrow(x);
4	7x	output <- matrix(0,r,ncol(x));
5
6	7x	for (p in 1:r) {
7	21x	vlength <- (sum(x[p,]^2))^(1/2)
8	21x	if (!is.na(vlength)) {
9	21x	if (vlength>0) {
10	19x	output[p,] <- ( x[p,] / vlength )
11		}
12		}
13		}
14
15	7x	return(output);
16		}

.onLoad <- function(libname, pkgname) {
  globalVariables(c(
    "..units_by", "..by", ".I", "QEID", "CID", "..conversations",
    "KEYCOL", "QEUNIT", "..sender_cols", "..receiver_cols", "..mode_column",
    "..codes", "..cols_to_encode"
  ))
}


## Attributes for special columns in data.tables, currently used when 
## creating contexts

#' Special attribute names for context columns
#'
#' A named list of string constants used as attribute keys for special columns in data.tables
#' within the TMA package, primarily for context creation and identification.
#'
#' @format A named list with elements:
#' \describe{
#'   \item{CONTEXT_ID}{A string used to identify the context table column.}
#'   \item{CONTEXT_COL_ID}{A string used to identify the context row ID column.}
#' }
#' @keywords internal
#' @export
ATTR_NAMES <- list(
  CONTEXT_ID = "__CONTEXT_TBL__",
  CONTEXT_COL_ID = "__CONTEXT_ROWID__"
)

1		#' Accumulate Connections from a Multidimensional Array and Context Model
2		#'
3		#' This function processes a context model and a multidimensional array of window/weight parameters to compute connection counts for each unit of analysis.
4		#' It applies the context model to the array, using sender, receiver, and mode columns (as defined in the array attributes), and accumulates co-occurrence or adjacency matrices for each unit. The result is a set of connection counts and row-level connection matrices, suitable for network analysis (e.g., ENA/ONA).
5		#'
6		#' @param context_model A context model object (as produced by `tma::contexts`) containing contexts for each unit of analysis.
7		#' @param codes Character vector of code names to use for constructing adjacency matrices.
8		#' @param tensor A multidimensional array (see `context_tensor`) containing window and weight values for each sender/receiver/mode combination. Defaults to an array generated from the context model's raw input.
9		#' @param time_column Character string giving the name of the time column in the context model. If NULL, uses the default context column ID.
10		#' @param ordered Logical; if TRUE (default), computes ordered adjacency matrices (ONA); if FALSE, computes unordered (ENA-style) matrices.
11		#' @param binary Logical; if TRUE (default), binarizes the connection counts (not currently implemented in this function).
12		#'
13		#' @return The input `context_model` with additional fields:
14		#' \item{connection.counts}{A data.table of accumulated connection counts for each unit.}
15		#' \item{model$row.connection.counts}{A data.table of row-level connection matrices for each unit.}
16		#' \item{meta.data}{A data.table of metadata columns for each unit.}
17		#' The class of the returned object is updated to reflect the type of accumulation (ordered or unordered).
18		#'
19		#' @details
20		#' This function is used to perform accumulation of network connections for each unit, based on the context model and tensor parameters. It supports both ordered and unordered accumulation, and returns results suitable for further network analysis or visualization.
21		#'
22		#' @export
23		accumulate <- function(
24		context_model,
25		codes,
26		tensor = context_tensor(context_model$model$raw.input),
27		time_column = NULL,
28		ordered = FALSE,
29		binary = TRUE
30		) {
31	11x	send_cols = attr(tensor, "sender_cols");
32	11x	recv_cols = attr(tensor, "receiver_cols");
33	11x	mode_cols = attr(tensor, "mode_column");
34
35	11x	if(is.null(time_column)) {
36	3x	time_column <- ATTR_NAMES$CONTEXT_COL_ID;
37		}
38
39	11x	context_model$rotation <- structure(list(
40	11x	codes = codes,
41	11x	adjacency.key = adjacency_key(codes, !ordered)
42	11x	), class = c("ena.rotation.set", "list"));
43	11x	adj_vector_names <- colnames(context_model$rotation$adjacency.key);
44	11x	adj_vector_names_full <- colnames(adjacency_key(codes, FALSE));
45
46	11x	ind_mat <- matrix(nrow = length(codes), ncol = length(codes));
47	11x	units_by <- context_model$`_function.params`$units.by;
48	11x	meta_cols <- c("QEID", "QEUNIT", units_by);
49
50	11x	mode_dim_1 <- dim(tensor)[1] == 1 && attr(tensor, "mode_column") == ATTR_NAMES$CONTEXT_ID;
51
52		# Cache tensor attributes outside the loop
53	11x	tensor_dim <- attr(tensor, "dim")
54	11x	tensor_sender_inds <- attr(tensor, "sender_inds") - 1
55	11x	tensor_receiver_inds <- attr(tensor, "receiver_inds") - 1
56	11x	tensor_mode_inds <- attr(tensor, "mode_inds") - 1
57
58	11x	result_cpp <- lapply(context_model$model$contexts, function(ctx) {
59	78x	ctx_fun <- function(ctx_o) {
60	78x	ctx__ <- data.table::copy(ctx_o);
61		# Assume columns are already numeric or factors; if not, convert once outside this function
62	78x	cols_to_encode <- c(send_cols, recv_cols, mode_cols)
63	78x	cols_to_encude_unq <- unique(cols_to_encode)
64	78x	if (!all(sapply(ctx__[ , ..cols_to_encode], is.numeric))) {
65	24x	ctx__[ , (cols_to_encude_unq) := lapply(.SD, function(x) as.numeric(as.factor(x))), .SDcols = unique(cols_to_encude_unq)]
66		}
67	78x	unit_context_lookup <- as.matrix(ctx__[ , ..cols_to_encode])
68
69	78x	unit_rows <- attr(ctx__, "tma.unit_rows")
70	78x	this_unit <- attr(ctx__, "tma.unit")
71	78x	unit_to_last <- seq.int(last(unit_rows))
72	78x	ctx_unit_to_last <- ctx__[unit_to_last, ]
73	78x	res2 <- apply_tensor(
74	78x	tensor,
75	78x	tensor_dim,
76	78x	tensor_sender_inds,
77	78x	tensor_receiver_inds,
78	78x	tensor_mode_inds,
79	78x	unit_context_lookup[unit_to_last, , drop = FALSE] - 1,
80	78x	unit_rows - 1,
81	78x	as.matrix(ctx_unit_to_last[ , ..codes]),
82	78x	ctx_unit_to_last[[time_column]]
83		)
84
85	78x	rcc <- data.table::as.data.table(res2$row_connection_counts);
86	78x	unit_row_meta <- ctx_o[unit_rows, meta_cols, with = FALSE];
87		# rcc <- cbind(unit_row_meta, rcc)
88		# browser()
89	78x	rcc[, names(unit_row_meta) := unit_row_meta]
90	78x	data.table::setcolorder(rcc, c(names(unit_row_meta), setdiff(names(rcc), names(unit_row_meta))))
91	78x	rcc
92		}
93
94	78x	if(is.data.frame(ctx)) {
95	78x	res <- ctx_fun(ctx);
96		}
97		else {
98	!	results <- lapply(ctx, ctx_fun);
99
100	!	res <- data.table::rbindlist(results);
101	!	res <- reclass(x = res, c("ordered.row.connections", "row.connections", "ena.matrix"));
102		}
103
104	78x	return(res);
105		});
106
107	11x	row_connection_counts <- rbindlist(result_cpp);
108		# colnames(row_connection_counts) <- c(meta_cols, adj_vector_names_full);
109
110		# browser()
111		# row_connection_counts[, lapply(seq.int(nrow(.SD)), function(col_ind) {
112		# col <- .SD[[col_ind]];
113		# new_class_nm <- ifelse(col_ind <= length(meta_cols), "ena.metadata", "ena.co.occurrence");
114		# reclass(col, new_class_nm)
115		# }), .SDcols = seq.int(ncol(row_connection_counts))];
116		# browser()
117	11x	row_connection_counts <- reclass_columns(row_connection_counts, rep(c("ena.metadata","ena.co.occurrence"), c(length(meta_cols), length(adj_vector_names_full))))
118	11x	data.table::setorderv(row_connection_counts, "QEID");
119	11x	row_connection_counts <- reclass(x = row_connection_counts, c("ordered.row.connections", "row.connections", "ena.matrix"));
120	11x	colnames(row_connection_counts) <- c(meta_cols, adj_vector_names_full);
121	11x	context_model$model$row.connection.counts <- row_connection_counts;
122
123	11x	cc_type <- NULL;
124	11x	if(isTRUE(ordered)) {
125	10x	class(context_model) <- c("ena.ordered.set", class(context_model));
126		# browser();
127		# connection_counts <- data.table::as.data.table(do.call(rbind, lapply(result_cpp, colSums.ena.matrix, binary = FALSE)));
128		# connection_counts <- data.table::as.data.table(do.call(rbind, lapply(result_cpp, function(rcpp) {
129		# colSums(as.matrix.ena.matrix(rcpp))
130		# })));
131	10x	connection_counts <- row_connection_counts[, lapply(.SD, sum), by = units_by, .SDcols = adj_vector_names_full];
132	10x	connection_counts <- reclass(x = connection_counts, c("ordered.ena.connections", "ena.connections", "ena.matrix"));
133		# connection_counts <- connection_counts[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = colnames(connection_counts)];
134
135	10x	cc_type <- "ordered.ena.connections";
136		}
137		else {
138	1x	class(context_model) <- c("ena.unordered.set", class(context_model));
139
140	1x	context_model$model$row.connection.counts <- as.unordered(context_model$model$row.connection.counts);
141	1x	connection_counts <- context_model$model$row.connection.counts[, lapply(.SD, colSums.ena.matrix, binary = binary), by = "QEUNIT", .SDcols = adj_vector_names];
142
143		# connection_counts <- connection_counts[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = adj_vector_names];
144	1x	cc_type <- "unordered.ena.connections";
145		}
146
147	11x	cc_meta <- data.table::rbindlist(lapply(result_cpp, function(rc) rc[1, c("QEUNIT", units_by), with = FALSE]));
148	11x	cc_meta$ENA_UNIT <- context_model$model$unit.labels;
149	11x	cc_meta <- cc_meta[, lapply(.SD, reclass, "ena.metadata"), .SDcols = colnames(cc_meta)];
150
151	11x	connection_counts <- cbind(cc_meta, connection_counts)
152	11x	connection_counts <- reclass(connection_counts, c(cc_type, "ena.connections", "ena.matrix"));
153	11x	context_model$connection.counts <- connection_counts;
154
155	11x	context_model$meta.data <- context_model$connection.counts[, sapply(context_model$connection.counts, is, "ena.metadata"), with = FALSE];
156	11x	class(context_model$meta.data) = c("ena.matrix", class(context_model$meta.data));
157
158		# 5a: persist the windowing config so the accumulated object is self-describing
159		# (recreate-the-model intent) and consumable by tma.conversations2, which needs
160		# the resolved per-modality window/weight tensor to reproduce the exact windows.
161		# See design/dataview-flexible-window.md.
162	11x	context_model$`_function.params`$tensor <- tensor;
163	11x	context_model$`_function.params`$mode_column <- mode_cols;
164	11x	context_model$`_function.params`$codes <- codes;
165	11x	context_model$`_function.params`$time_column <- time_column;
166	11x	context_model$`_function.params`$ordered <- ordered;
167	11x	context_model$`_function.params`$binary <- binary;
168
169	11x	return(context_model);
170		}

1		# Accumulated threaded data
2		#
3		# @param ... passed along
4		#
5		# @return ENA set
6		accumulate_context_threads <- function(...) {
7	!	args <- list(...);
8
9	!	simple_window <- function(x) { (x < args$window_size) * 1 }
10	!	if(!is.null(args$decay_function) && is.function(args$decay_function)) {
11	!	simple_window <- args$decay_function;
12		}
13	!	no_weight <- function(x) { x };
14	!	accumulate_contexts(
15	!	x = args$x,
16	!	codes = args$codes,
17	!	return.dena.set = args$as_directed,
18	!	return.ena.set = !args$as_directed,
19	!	meta.data = args$meta.data,
20
21	!	time.column = NULL,
22	!	mask = NULL,
23		# time.limit = NULL,
24
25	!	decay.function = simple_window,
26	!	weight.by = no_weight,
27	!	mode.column = "Thread",
28	!	context_filter = args$context_filter
29		)
30		}
31
32		# Key change: Pass in argument z representing the weighted response vectors. y are unweighted response vectors
33		ground_response_crossprod <- function(
34		x, y, z
35		) {
36	21x	UNIT = NULL;
37	21x	UNIT_LABEL = NULL;
38	21x	eff_call_env <- new.env(parent = environment(ground_effect_function));
39	21x	environment(ground_effect_function) <- eff_call_env;
40	21x	assign("UNIT", UNIT, envir = eff_call_env);
41	21x	assign("UNIT_LABEL", UNIT_LABEL, envir = eff_call_env);
42
43		# all_connection_matrices_raw <- list_vec_apply(all_only_ground_connections, responses.codes, ground_effect_function);
44	21x	all_connection_matrices_raw <- list_vec_apply(x, y, ground_effect_function);
45
46		# Key change: z passed in here, so that we calculate the response matrices as matmul(z, r^T)
47		# This way, the result is 1/2 * f_{diag}((w_rr) * rr^T), where f_{diag} is a function that 0s out
48		# the diagonal of a matrix, rather than 1/2 * f_{diag}(rr^T)
49		# response_matrices <- lapply(y, function(x) tcrossprod(x) );
50	21x	response_matrices <- Map(function(zi, yi) zi %*% t(yi), z, y);
51	21x	these_self_connections <- lapply(response_matrices, function(x) {
52	84x	0.5 * (x - diag(diag(x)))
53		})
54
55	21x	all_connection_matrices <- lapply(seq(all_connection_matrices_raw), function(i) {
56	84x	all_connection_matrices_raw[[i]] + these_self_connections[[i]]
57		})
58	21x	dir_vecs <- t(sapply(all_connection_matrices, function(x) { dim(x) <- c(1, nrow(x)^2); (x) }));
59		# print(dir_vecs);
60
61	21x	acc_call_env <- new.env(parent = environment(accumulate_unit_vectors_by));
62	21x	environment(accumulate_unit_vectors_by) <- acc_call_env;
63	21x	assign("UNIT", UNIT, envir = acc_call_env);
64	21x	assign("UNIT_LABEL", UNIT_LABEL, envir = acc_call_env);
65	21x	dir_vecs <- accumulate_unit_vectors_by(dir_vecs);
66		# browser()
67
68	21x	return(dir_vecs)
69		}
70
71		#' accumulate_contexts
72		#'
73		#' @param x TBD
74		#' @param codes TBD
75		#' @param time.column TBD
76		#' @param decay.function TBD
77		#' @param mode.column TBD
78		#' @param mask TBD
79		#' @param weight.by TBD
80		#' @param meta.data TBD
81		#' @param return.dena.set TBD
82		#' @param return.ena.set TBD
83		#' @param accumulate_unit_vectors_by TBD
84		#' @param norm.by TBD
85		#' @param context_filter TBD
86		#' @param summarize_ground_using TBD
87		#' @param calculate_adj_vectors_using TBD
88		#' @param ground_effect_function TBD
89		#'
90		#' @return ENA set
91		#' @export
92		accumulate_contexts <- function(
93		x,
94		codes,
95		decay.function = decay(simple_window, window_size = 4),
96		time.column = NULL,
97		mode.column = NULL,
98		mask = NULL,
99		weight.by = sqrt,
100		norm.by = `_sphere_norm`,
101		meta.data = NULL,
102		return.dena.set = FALSE,
103		return.ena.set = TRUE,
104		context_filter = NULL,
105		summarize_ground_using = colSums,
106		calculate_adj_vectors_using = ground_response_crossprod,
107		ground_effect_function = function(x, y) crossprod(t(x), y),
108		accumulate_unit_vectors_by = colSums
109		) {
110	7x	data <- x$model$raw.input;
111	7x	f.contexts <- x$model$contexts; #context.object #$contexts
112	7x	units <- x$`_function.params`$units;
113
114	7x	f.codes = codes
115	7x	f.time = time.column
116	7x	f.decay = decay.function
117	7x	f.mode = mode.column
118	7x	f.weighting.function = weight.by
119	7x	f.meta.data = meta.data
120	7x	f.units = as.data.frame(names(f.contexts))
121	7x	f.raw <- data.table::copy(data);
122	7x	f.raw$QEID <- seq(nrow(f.raw));
123
124	7x	use.modes = ifelse(any(is.null(f.mode)), FALSE, TRUE)
125	7x	use.meta = ifelse(any(is.null(f.meta.data)), FALSE, TRUE)
126	7x	use.mask = ifelse(is.matrix(mask), TRUE, FALSE)
127	7x	use.window = ifelse(is.null(f.time) \|\| is.na(f.time), TRUE, FALSE)
128
129
130	7x	meta_cols <- x$`_function.params`$units.by;
131	7x	if(use.meta) {
132	!	meta_cols <- unique(meta_cols, c(f.meta.data[!is.na(f.meta.data)]));
133		}
134	7x	output.meta.data <- as.data.frame(f.raw[0, c(meta_cols), with = FALSE]);
135
136		# initialize adjacency vector matrices
137	7x	undirected.adjacency.vectors = data.frame(matrix(0, nrow = 1, ncol = ncol(adjacency_key(f.codes))))[0,]
138	7x	directed.adjacency.vectors = data.frame(matrix(0, nrow = 1, ncol = length(f.codes)^2)[0,]);
139
140		#create undirected mask if there are NAs in lower triangle of given mask
141	7x	if( use.mask ) {
142	!	if ( any(is.na(mask[lower.tri(mask)])) ) {
143	!	mask[lower.tri(mask)] = mask[upper.tri(mask)]
144		}
145		}
146		else {
147	7x	mask <- matrix(1, nrow = length(f.codes), ncol = length(f.codes));
148		}
149
150	7x	n = length(codes)
151	7x	blank.code.matrix = matrix(0, nrow = n, ncol = n, dimnames = list(codes, codes))
152	7x	unit.code.matrices <- structure(
153	7x	rep(
154	7x	list(list(
155	7x	directed.adjacency = blank.code.matrix,
156	7x	undirected.adjacency = structure(rep(0, ncol(blank.code.matrix)))
157		)),
158	7x	length(names(f.contexts))
159		),
160	7x	names = names(f.contexts)
161		);
162	7x	for( unit.index in seq(f.contexts)) {
163	21x	unit.contexts <- f.contexts[[unit.index]];
164	21x	if(is.numeric(unit.contexts)) {
165	!	unit.contexts <- list(unit.contexts)
166		}
167
168		# browser to stop at mentor unit
169		# if (unit.index == 3) { browser() }
170
171	21x	this.unit <- attr(unit.contexts[[1]], "tma.unit");
172	21x	if(is.null(this.unit)) {
173	21x	this.unit <- attr(unit.contexts, "tma.unit");
174		}
175	21x	unit.label <- paste(as.character(this.unit), collapse = "::");
176		# Empty matrices for tracking unit vectors
177	21x	unit.directed.adjacency.vectors <- data.frame(matrix(0, nrow = 1, ncol = length(f.codes)^2)[0,]);
178	21x	unit.undirected.adjacency.vectors <- data.frame(matrix(0, nrow = 1, ncol = ncol(adjacency_key(f.codes))))[0,]
179
180	21x	if(is.data.frame(unit.contexts)) {
181	21x	unit.contexts <- list( unit.contexts );
182		}
183
184		# Each unit's contexts
185	21x	all_codes <- as.matrix(x$model$raw.input[, c(codes), with = FALSE])
186	21x	res_context <- lapply(seq(unit.contexts), function(context.index) {
187	21x	this.code.matrix <- blank.code.matrix;
188	21x	this.context.rows <- unit.contexts[[context.index]];
189	21x	if(is.numeric(this.context.rows)) {
190	!	this.context <- x$model$raw.input[this.context.rows, ];
191		}
192		else {
193	21x	this.context <- x$model$raw.input[this.context.rows, , on = c("QEID")];
194		}
195	21x	this.context$CID <- seq(nrow(this.context))
196		# browser()
197		# this_context_codes <- all_codes[this.context.rows,, drop = FALSE]
198	21x	this_context_codes <- all_codes[this.context$QEID,, drop = FALSE]
199	21x	this.unit.rows_tf <- this.context$QEUNIT == unit.label
200	21x	if(!is.null(context_filter)) {
201	!	this.unit.rows_tf <- do.call(context_filter, list(unit = unit.label, context = this.context))
202		}
203	21x	this.unit.rows <- which(this.unit.rows_tf);
204	21x	if(use.window) {
205	!	f.time <- "CID"
206		}
207
208	21x	this.time <- this.context[[c(f.time)]];
209	21x	if(use.modes) {
210	9x	these.modes <- as.factor(this.context[[c(f.mode)]]);
211		}
212
213	21x	if(length(this.unit.rows) > 0) {
214	21x	response.times <- this.time[this.unit.rows];
215
216	21x	grounds <- lapply(this.unit.rows, function(ur) {
217	84x	grounds <- vector(length = nrow(this.context))
218	84x	grounds[seq_len(ur)] <- TRUE
219	84x	attr(grounds, "tma.response.index") <- ur
220	84x	grounds
221		})
222
223
224	21x	grounds.codes.raw <- lapply(grounds, function(xx) this_context_codes[xx,, drop = FALSE]);
225
226	21x	this.unit.resp.idx <- sapply(grounds, attr, which = "tma.response.index");
227
228	84x	responses.codes <- list_vec_apply(grounds.codes.raw, this.unit.resp.idx, function(x,y) { as.numeric(x[y,,drop = FALSE]) });
229
230	21x	grounds.modes <- rep(NA, length(responses.codes))
231	21x	if(use.modes) {
232	9x	grounds.modes <- lapply(grounds, function(x) these.modes[x]);
233		}
234	21x	ground.times <- lapply(grounds, function(x) this.time[x])
235
236	21x	all.decays <- sapply(seq(grounds), function(wh) {
237	84x	call_env <- new.env(parent = environment(f.decay));
238	84x	RESPONSE_INDEX <- attr(grounds[[wh]], which = "tma.response.index")
239		# RESPONSE <- this.context[RESPONSE_INDEX, ]
240	84x	ROWS <- grounds[[wh]]
241		# CONTEXT <- this.context[this_rows, ]
242		# RESPONSE <- CONTEXT[.N]
243	84x	assign("FULL_CONTEXT", this.context, envir = call_env)
244		# assign("CONTEXT", CONTEXT, envir = call_env)
245	84x	assign("RESPONSE_INDEX", RESPONSE_INDEX, envir = call_env)
246	84x	assign("ROWS", ROWS, envir = call_env)
247
248	84x	environment(f.decay) <- call_env;
249
250	84x	subbed <- as.numeric(response.times[wh] - ground.times[[wh]])
251	84x	if(is.function(f.decay)) {
252	84x	f.decay(subbed)
253		# CONTEXT[ , {
254		# assign("GROUND_ROW", .SD, envir = call_env);
255		# f.decay(subbed[.GRP])
256		# }, by = which(grounds[[wh]])][[2]];
257		}
258	!	else if (use.modes) {
259	!	mapply(FUN = function(xx, yy, INDEX) {
260	!	do.call(xx, args = list(x = yy))
261	!	}, f.decay[grounds.modes[[wh]]], subbed, which(grounds[[wh]]))
262		}
263	21x	}, simplify = FALSE)
264
265
266	21x	grounds.codes = mapply(grounds.codes.raw, all.decays, FUN = function(x, y) {
267
268	84x	if(length(y) == 1) {
269	7x	x * y[[1]]
270		}
271
272		#otherwise this is a bit of fancy math that multiplies each row of the matrix
273		#by a different scalar from a vector of scalars
274		else {
275		# browser()
276		# sweep(x, MARGIN = 1, (y), FUN = `*`)
277	77x	x * y
278		}
279	21x	}, SIMPLIFY = FALSE);
280
281	84x	this.responses.in.grounds <- list_vec_apply(grounds.codes, this.unit.resp.idx, function(x, g) { x[g, ] })
282	21x	these.grounds <- lapply(grounds.codes, function(x) summarize_ground_using(x) );
283
284	21x	all_only_ground_connections <- list_vec_apply(
285	21x	x = these.grounds,
286	21x	y = this.responses.in.grounds,
287	21x	fn = function(x, y) x - y
288		);
289
290		##
291	21x	adj_call_env <- new.env(parent = environment(calculate_adj_vectors_using));
292	21x	environment(calculate_adj_vectors_using) <- adj_call_env;
293	21x	assign("UNIT", this.unit, envir = adj_call_env);
294	21x	assign("UNIT_LABEL", unit.label, envir = adj_call_env);
295	21x	assign("ground_effect_function", ground_effect_function, envir = adj_call_env);
296	21x	assign("accumulate_unit_vectors_by", accumulate_unit_vectors_by, envir = adj_call_env);
297		# dir_vecs <- calculate_adj_vectors_using(all_only_ground_connections, responses.codes)
298		# Key change: pass in weighted response vectors, this.responses.in.grounds, to calculate_adj_vectors_using
299		# (currently ground_response_crossprod) as well
300	21x	dir_vecs <- calculate_adj_vectors_using(all_only_ground_connections, responses.codes, this.responses.in.grounds)
301
302	21x	dim(dir_vecs) <- c( 1, length(dir_vecs) );
303
304	21x	data.frame(dir_vecs);
305		}
306		})
307
308	21x	unit.directed.adjacency.vectors <- data.table::rbindlist(res_context)
309	21x	directed.adjacency.vectors <- rbind( directed.adjacency.vectors, colSums(unit.directed.adjacency.vectors) );
310
311	21x	if(nrow(unit.directed.adjacency.vectors) > 0) {
312	21x	unit.undirected.adjacency.vectors <- unit.directed.adjacency.vectors[, {
313	21x	as.list(
314	21x	as.undirected.vector(as.undirected.matrix(matrix(unlist(.SD), ncol = sqrt(length(.SD)))))
315		)
316	21x	}, by = seq(nrow(unit.directed.adjacency.vectors))][, -1]
317		}
318
319	21x	undirected.adjacency.vectors <- rbind( undirected.adjacency.vectors, colSums(unit.undirected.adjacency.vectors) );
320
321	21x	output.meta.data <- rbind(output.meta.data, this.unit[, c(meta_cols), with = FALSE]);
322		}
323
324		#### Construct ENA Sets ----
325
326		#add additional information for modeling
327	7x	directed.adjacency.vectors <- structure(
328	7x	lapply(directed.adjacency.vectors, reclass, cl = "ena.co.occurrence"),
329	7x	class = c("ena.connections", "data.table", "data.frame"),
330	7x	names = apply(t(apply(matrix(c(rep(seq(f.codes), times = length(f.codes)), rep(seq(f.codes), each = length(f.codes))), ncol = 2), 2, function(x) f.codes[x])), 2, paste, collapse = " & ")
331		);
332
333		# lapply(undirected.adjacency.vectors, as.ena.co.occurrence),
334	7x	undirected.adjacency.vectors <- structure(
335	7x	lapply(undirected.adjacency.vectors, reclass, cl = "ena.co.occurrence"),
336	7x	class = c("ena.connections", "data.table", "data.frame"),
337	7x	names = apply(adjacency_key(f.codes), 2, paste, collapse = " & ")
338		);
339
340		# x$meta.data <- structure(
341		# lapply(output.meta.data, reclass, cl = "ena.metadata"),
342		# class = c("ena.matrix", "data.table", "data.frame")
343		# );
344	7x	x$meta.data <- data.table::copy(data.table::as.data.table(output.meta.data));
345	7x	set(x$meta.data, j = "ENA_UNIT", value = do.call(paste, c(lapply(x$`_function.params`$units.by, function(u) x$meta.data[[u]]), sep = "::")))
346	7x	for( i in colnames(x$meta.data) ) {
347	21x	data.table::set(x$meta.data, j = i, value = reclass(x$meta.data[[i]], "ena.metadata"))
348		}
349	7x	class(x$meta.data) = c("ena.matrix", class(x$meta.data));
350
351		# Standard ENA Set
352	7x	if(return.ena.set) {
353		# x$meta.data[, c("ENA_UNIT") := merge_columns(x$meta.data, cols = x$`_function.params`$units.by, sep = "::")]
354		# set(x$meta.data, j = "ENA_UNIT", value = do.call(paste, c(lapply(units.by, function(u) x$meta.data[[u]]), sep = "::")))
355		# for( i in colnames(x$meta.data) ) {
356		# data.table::set(x$meta.data, j = i, value = reclass(x$meta.data[[i]], "ena.metadata"))
357		# }
358
359	!	x$rotation = structure(list(
360	!	codes = f.codes,
361	!	adjacency.key = structure(
362	!	adjacency_key(f.codes),
363	!	dimnames = list( NULL, names(undirected.adjacency.vectors))
364		)
365	!	), class = c("ena.rotation.set", "list"));
366
367	!	x$connection.counts <- data.table::copy(undirected.adjacency.vectors);
368	!	x$connection.counts <- structure(cbind(x$meta.data, x$connection.counts), class = class(undirected.adjacency.vectors));
369
370		# TODO: This needs to be updated to reflect the accumulation for each row in the data
371		# enadata$accumulated.adjacency.vectors = data.table::as.data.table(undirected.adjacency.vectors)
372	!	x$model$row.connection.counts <- structure(
373	!	data.table::copy(x$connection.counts),
374	!	class = c("row.connections", "ena.matrix", "data.table", "data.frame")
375		);
376		# browser()
377
378	!	if(!is.null(norm.by)) {
379	!	x$line.weights <- norm.by(x = as.matrix(undirected.adjacency.vectors))
380		}
381
382	!	output = x;
383		}
384
385		# Directed ENA Set
386		else {
387	7x	dena_data = ena.set.directed(f.raw, f.units, NA, f.codes)
388	7x	dena_data$meta.data <- data.table::as.data.table(output.meta.data)
389	7x	dena_data$meta.data[, c("ENA_UNIT") := merge_columns(dena_data$meta.data, cols = x$`_function.params`$units.by, sep = "::")]
390	7x	for( i in colnames(dena_data$meta.data) ) {
391	21x	data.table::set(dena_data$meta.data, j = i, value = reclass(dena_data$meta.data[[i]], "ena.metadata"))
392		}
393	7x	code_length <- length(dena_data$rotation$codes);
394	7x	dena_data$rotation$adjacency.key <- data.table::data.table(matrix(c(
395	7x	rep(1:code_length, each = code_length),
396	7x	rep(1:code_length, code_length)),
397	7x	byrow = TRUE, nrow = 2
398		))
399
400	7x	dena_data$connection.counts <- data.table::as.data.table(cbind(dena_data$meta.data, directed.adjacency.vectors))
401	7x	dena_data$model$row.connection.counts = data.table::as.data.table(cbind(dena_data$meta.data, directed.adjacency.vectors))
402
403	7x	dena_data$connection.counts = reclass(dena_data$connection.counts, c("ena.connections", "ena.matrix"))
404	7x	dena_data$model$row.connection.counts <- reclass(dena_data$model$row.connection.counts, c("row.connections", "ena.matrix"))
405
406	7x	if ( !is.null(norm.by) ) {
407	7x	dena_data$line.weights <- norm.by(x = as.matrix(directed.adjacency.vectors))
408		}
409
410	7x	output = dena_data;
411		}
412
413	7x	output$model$contexts <- f.contexts
414
415	7x	return(output)
416		}

1		#' Adjacency Key
2		#'
3		#' @param codes character vector
4		#' @param upper logical, default, TRUE, returns the key for the upper triangle, FALSE - not implemented yet
5		#'
6		#' @export
7		#'
8		#' @return matrix
9		adjacency_key <- function(codes, upper = TRUE) {
10	57x	expanded <- expand.grid(codes, codes);
11	57x	rownames(expanded) <- apply(expanded, 1, paste, collapse = " & ");
12	57x	if(upper == TRUE) {
13	36x	upper_inds <- which(upper.tri(matrix(nrow = length(codes), ncol = length(codes))));
14	36x	t(expanded[upper_inds,])
15		}
16		else {
17	21x	t(expanded);
18		}
19		}
20
21		list_vec_apply <- Vectorize(FUN = function(x, y = NULL, fn) {
22	336x	fn(x, y)
23		}, vectorize.args = c("x", "y"), SIMPLIFY = FALSE);
24
25
26		as.undirected.matrix <- function(x, m = matrix(1, nrow = nrow(x), ncol = ncol(x))) {
27	21x	upper_tri_indices <- upper.tri(x);
28	21x	ut_matrix <- x * m;
29	21x	ut_matrix[upper_tri_indices] <- ut_matrix[upper_tri_indices] + t(ut_matrix)[upper_tri_indices]
30
31		#make matrix symmetrical
32	21x	ut_matrix[lower.tri(ut_matrix)] = NA
33
34	21x	ut_matrix
35		}
36
37		#' Extract Upper Triangular Elements
38		#'
39		#' This function extracts the elements from the upper triangular part of a
40		#' matrix.
41		#'
42		#' @param x A numeric matrix from which to extract upper triangular elements.
43		#' @param diag A logical value indicating whether to include the diagonal
44		#' elements. Defaults to FALSE.
45		#'
46		#' @return A vector containing the upper triangular elements of the matrix.
47		as.undirected.vector <- function(x, diag = FALSE) {
48	21x	upper_tri_indices <- upper.tri(x, diag = diag);
49	21x	x[upper_tri_indices]
50		}
51
52
53		as.ena.ordered.set <- function(x) {
54	7x	to <- c("ena.ordered.set")
55	7x	if(!inherits(x = x, what = "ena.set")) {
56	7x	to <- c(to, "ena.set")
57		}
58	7x	class(x) <- c(to, class(x));
59	7x	return(x);
60		}
61		ena.set.directed <- function(data, units, conversations, codes, ...) {
62	7x	as.ena.ordered.set(
63	7x	list(
64	7x	meta.data = NULL,
65	7x	model = list(
66	7x	model.type = "Directed",
67	7x	raw.input = data.table::as.data.table(data)
68		),
69	7x	rotation = list (
70	7x	codes = codes,
71	7x	nodes = NULL
72		),
73	7x	plots = list(),
74	7x	"_function.params" = list(
75	7x	units = units,
76	7x	conversations = conversations,
77	7x	codes = codes
78		)
79		)
80		)
81		}
82
83		# Reclass vector
84		#
85		# @param x vector
86		# @param cl character - new class
87		# @param stringsAsFactors logical, default: default.stringsAsFactors()
88		#
89		# @return vector with class: c(cl, class(x))
90		reclass <- function(x, cl, stringsAsFactors = FALSE) {
91	894x	if(!stringsAsFactors && is.factor(x)) {
92	!	x <- as.character(x)
93		}
94	894x	class(x) = c(cl, class(x))
95	894x	x
96		}
97
98		# Reclass columns of a data.frame or data.table
99		# @param df data.frame or data.table
100		# @param class_vec character vector of new classes, length must equal ncol(df)
101		#
102		# @return data.frame or data.table with re-classed columns
103		reclass_columns <- function(df, class_vec) {
104	11x	stopifnot(length(class_vec) == ncol(df))
105	11x	for (i in seq_along(class_vec)) {
106	170x	df[[i]] <- reclass(df[[i]], class_vec[i])
107		}
108	11x	df
109		}
110
111		# paste columns to together
112		#
113		# @param x coerced to data.frame prior to subseting cols
114		# @param cols character vector - default: colnames(x)
115		# @param sep character default "."
116		#
117		# @return character vector
118		merge_columns <- function(x, cols = colnames(x), sep = ".") {
119	7x	do.call(paste, c(as.data.frame(x)[, cols, drop = FALSE], sep = sep))
120		}
121
122		##
123		#' Convert Adjacency Key to Character (S3 method)
124		#'
125		#' This S3 method converts an adjacency key object (typically a 2-row matrix or list of pairs) into a character vector, concatenating each pair with ' & '.
126		#'
127		#' @param x An adjacency key object (matrix or list) to convert to character.
128		#' @param ... Additional arguments (unused).
129		#'
130		#' @return A character vector where each element is a concatenation of the adjacency key pair.
131		#' @export
132		'as.character.adjacency.key' <- function(x, ...) {
133	!	mapply(paste, x[[1]], x[[2]], MoreArgs = list(sep = " & "))
134		}
135
136		#' Convert Adjacency Key to Double (S3 method)
137		#'
138		#' This S3 method converts an adjacency key object to a numeric (double) vector, applying as.numeric to each element.
139		#'
140		#' @param x An adjacency key object (matrix or list) to convert to numeric.
141		#' @param ... Additional arguments (unused).
142		#'
143		#' @return A numeric vector representation of the adjacency key.
144		#' @export
145		'as.double.adjacency.key' <- function(x, ...) {
146	!	sapply(x, as.numeric)
147		}
148
149		##
150		#' Print Method for Network Matrix (S3 method)
151		#'
152		#' This S3 method prints a network matrix object, optionally including metadata. It adjusts the class and attaches adjacency key names for improved readability.
153		#'
154		#' @param x An object of class "network.matrix" to print.
155		#' @param include.meta Logical; whether to include metadata in the printout (currently not used).
156		#' @param ... Additional arguments passed to lower-level print methods.
157		#'
158		#' @return Invisibly returns the printed object.
159		#' @export
160		'print.network.matrix' <- function(x, include.meta = TRUE, ...) {
161	!	x_ <- data.table::copy(x);
162	!	x_model <- attr(x, "model");
163	!	x_cls <- class(x);
164	!	class(x_) <- x_cls[ (which(x_cls == "network.matrix") + 1):length(x_cls) ];
165	!	if(!is.null(x_model)) {
166	!	adj_key <- x_model$rotation$adjacency.key;
167	!	attr(x_, "names") <- as.character(adj_key);
168		}
169
170	!	print(x_);
171		}
172
173		##
174		#' Extract Metadata or Columns from Network Matrix (S3 method)
175		#'
176		#' This S3 method allows convenient extraction of metadata columns from a network matrix object using the $ operator. If the requested column is metadata, it is returned from the model's meta.data; otherwise, the standard extraction is performed.
177		#'
178		#' @param x An object of class "network.matrix".
179		#' @param i Name of the column or metadata field to extract.
180		#'
181		#' @return The requested column or metadata field from the network matrix.
182		#' @export
183		"$.network.matrix" <- function (x, i) {
184	!	meta.data <- attr(x, "model")$meta.data;
185	!	meta.cols <- colnames(meta.data);
186
187		# browser()
188	!	if(data.table::`%chin%`(i, meta.cols)) {
189	!	meta.data[[i]];
190		}
191		else {
192	!	x[[i]];
193		}
194		}
195
196		#' Title
197		#'
198		#' @param x TBD
199		#'
200		#' @return TBD
201		#' @export
202		"names.network.connections" <- function(x) {
203	!	use.adjacency.key = getOption("tma.print.adjkey", TRUE);
204
205	!	x_cls <- class(x);
206	!	x_ <- data.table::copy(x);
207	!	class(x_) <- x_cls[ (which(x_cls == "network.connections") + 1):length(x_cls) ];
208
209	!	if(use.adjacency.key == TRUE) {
210	!	x_model <- attr(x, "model");
211	!	adj_key <- x_model$rotation$adjacency.key;
212	!	as.character(adj_key);
213		}
214		else {
215	!	names(x_);
216		}
217		}
218
219		#' Re-class vector as network.connection
220		#'
221		#' @param x Vector to re-class
222		#'
223		#' @return re-classed vector
224		#' @export
225		as.network.connection <- function(x) {
226	!	if(is.factor(x)) {
227	!	x = as.character(x)
228		}
229	!	class(x) = c("network.connection", class(x))
230	!	x
231		}
232
233		##
234		#' Convert Network Connections to Matrix (S3 method)
235		#'
236		#' This S3 method extracts the connection columns from a network connections object and returns them as a numeric matrix. It is used to facilitate matrix operations on network connection data.
237		#'
238		#' @param x An object of class "network.connections" (or compatible data.table/data.frame) containing connection columns (of class "network.connection").
239		#' @param ... Additional arguments passed to `as.matrix`.
240		#'
241		#' @return A numeric matrix of network connections (rows = units/contexts, columns = connections).
242		#'
243		#' @export
244		as.matrix.network.connections <- function(x, ...) {
245	!	x_ <- data.table::copy(x);
246	!	x_cls <- class(x);
247	!	class(x_) <- x_cls[ (which(x_cls == "network.matrix") + 1):length(x_cls) ];
248	!	code_columns <- which(sapply(x_, inherits, what = "network.connection"));
249	!	as.matrix(x_[, c(code_columns), with = F], ...);
250		}
251
252		##
253		#' Column Sums for ENA Matrices (S3 method)
254		#'
255		#' This S3 method computes column sums for ENA matrix objects, with optional binarization. It is used to summarize connection counts across rows (e.g., for each unit or context).
256		#'
257		#' @param x An object of class "ena.matrix" (or compatible matrix/data.frame) containing connection data.
258		#' @param na.rm Logical; whether to remove missing values (passed to `colSums`).
259		#' @param dims Integer; which dimensions to sum over (passed to `colSums`).
260		#' @param binary Logical; if TRUE, binarizes the matrix before summing (i.e., all nonzero values become 1).
261		#'
262		#' @return A numeric vector of column sums for the matrix.
263		#'
264		#' @export
265		'colSums.ena.matrix' <- function(x, na.rm = FALSE, dims = 1L, binary = FALSE) {
266	720x	x_mat <- as.matrix(x);
267	720x	if(isTRUE(binary)) {
268	720x	x_mat[x_mat > 0] <- 1;
269		}
270	720x	colSums(x_mat);
271		}
272
273		#' Unorder Connections in a Matrix
274		#'
275		#' This function takes a matrix and creates an unordered version of its connections, combining upper and lower triangular elements.
276		#'
277		#' @param x A matrix or data frame containing the connections. The input should be a square matrix.
278		#'
279		#' @return A data.table with ordered connections, reclassified as "unordered.ena.connections", "ena.connections", and "ena.matrix".
280		#'
281		#' @export
282		'as.unordered.ordered.ena.connections' <- function(x) {
283	!	m <- as.matrix.ena.matrix(x); # strips ena.metadata cols before conversion
284	!	sq_size <- sqrt(ncol(m));
285	!	ind_mat <- matrix(seq.int(ncol(m)), nrow = sq_size, ncol = sq_size);
286	!	ind_ut <- ind_mat[upper.tri(ind_mat)];
287	!	ind_lt <- ind_mat[lower.tri(ind_mat)];
288
289		# m_unordered <- data.table::as.data.table(m[, ind_ut, drop = FALSE] + m[, ind_lt, drop = FALSE]);
290	!	m_unordered <- data.table::as.data.table(t(apply(m, 1, function(mm) (mm[as.vector(ind_mat)] + mm[as.vector(t(ind_mat))])[ind_ut], simplify = T)));
291	!	m_unordered <- m_unordered[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = colnames(m_unordered)];
292
293	!	m_unordered <- cbind(x[,find_meta_cols(x), with = FALSE], m_unordered);
294	!	m_unordered <- reclass(x = m_unordered, c("unordered.ena.connections", "ena.connections", "ena.matrix"));
295
296	!	m_unordered
297		}
298
299		##
300		#' Convert Ordered Row Connections to Unordered (S3 method)
301		#'
302		#' This S3 method takes a matrix or data frame of ordered row connections (e.g., from ONA) and produces an unordered version by summing upper and lower triangular elements for each connection.
303		#'
304		#' @param x An object of class "ordered.row.connections" (or compatible matrix/data.frame) containing ordered connection data. The input should be a square matrix or have square number of columns.
305		#'
306		#' @return A data.table with unordered row connections, reclassified as "unordered.row.connections", "row.connections", and "ena.matrix".
307		#'
308		#' @export
309		'as.unordered.ordered.row.connections' <- function(x) {
310		# m <- as.matrix(x);
311	1x	m <- as.matrix.ena.matrix(x);
312	1x	sq_size <- sqrt(ncol(m));
313	1x	ind_mat <- matrix(seq.int(ncol(m)), nrow = sq_size, ncol = sq_size);
314	1x	ind_ut <- ind_mat[upper.tri(ind_mat, diag = FALSE)];
315	1x	ind_lt <- ind_mat[lower.tri(ind_mat, diag = FALSE)];
316
317		# m_unordered <- data.table::as.data.table(m[, ind_ut, drop = FALSE] + m[, ind_lt, drop = FALSE]);
318	1x	m_unordered <- data.table::as.data.table(t(apply(m, 1, function(mm) (mm[as.vector(ind_mat)] + mm[as.vector(t(ind_mat))])[ind_ut], simplify = T)));
319	1x	m_unordered <- m_unordered[, lapply(.SD, reclass, "ena.co.occurrence"), .SDcols = colnames(m_unordered)];
320
321	1x	m_unordered <- cbind(x[,find_meta_cols(x), with = FALSE], m_unordered);
322	1x	m_unordered <- reclass(x = m_unordered, c("unordered.row.connections", "row.connections", "ena.matrix"));
323
324	1x	m_unordered
325		}
326
327		#' Default Method for as.unordered
328		#'
329		#' This function provides the default method for handling the input \code{x} when no specific method is available.
330		#'
331		#' @param x Any object that you want to apply the default method to.
332		#'
333		#' @return The input object \code{x}, unchanged.
334		#' @export
335		'as.unordered.default' <- function(x){
336	!	x
337		}
338
339		#' Convert to Unordered Factor
340		#'
341		#' This function is a generic method to convert an object to an unordered factor.
342		#' It dispatches methods based on the class of the input object.
343		#'
344		#' @param x An object to be converted to an unordered factor.
345		#'
346		#' @return An unordered factor representation of the input object.
347		#'
348		#' @export
349		'as.unordered' <- function(x) {
350	1x	UseMethod("as.unordered")
351		}
352
353		#region Moved from rENA ----
354
355		#' Find metadata columns
356		#'
357		#' @param x data.table (or frame) to search for columns of class ena.metadata
358		#'
359		#' @return logical vector
360		#' @export
361		find_meta_cols <- function(x) {
362	49x	sapply(x, is, class2 = "ena.metadata")
363		}
364
365		#' Remove meta columns from a data.table or data.frame
366		#'
367		#' This function removes columns of class `ena.meta.data` from the input object.
368		#'
369		#' @param x A `data.table` or `data.frame` object from which meta columns should be removed.
370		#'
371		#' @return A `data.frame` with columns of class `ena.meta.data` removed.
372		#' @export
373		remove_meta_data <- function(x) {
374	48x	as.data.frame(x)[, !find_meta_cols(x), drop = F]
375		}
376
377		#' Matrix without metadata
378		#'
379		#' @param x Object to convert to a matrix
380		#' @param ... additional arguments to be passed to or from methods
381		#'
382		#' @return matrix
383		#' @export
384		as.matrix.ena.matrix <- function(x, ...) {
385	48x	class(x) = class(x)[-1]
386	48x	x = remove_meta_data(x)
387	48x	as.matrix(x, ...)
388		}
389
390		namesToAdjacencyKey <- function(vector, upper_triangle = TRUE) {
391		upperTriIndices = connection_indices(length(vector)) + 1;
392		matrix(vector[upperTriIndices], nrow=2)
393		}
394
395		#' @title Names to Adjacency Key
396		#'
397		#' @description Convert a vector of strings, representing the names of a square matrix, to an adjacency key matrix.
398		#'
399		#' @details Returns a matrix with 2 rows and choose(length(vector), 2) columns, where each column represents a unique pair of names from the input vector, corresponding to the upper triangle of a square matrix.
400		#'
401		#' @param vector Vector representing the names of a square matrix.
402		#' @param upper_triangle Not Implemented.
403		#'
404		#' @return A character matrix with 2 rows and choose(length(vector), 2) columns. Each column contains a pair of names representing a unique adjacency (edge) between nodes in the original square matrix.
405		#' @export
406		namesToAdjacencyKey <- function(vector, upper_triangle = TRUE) {
407	!	upperTriIndices = connection_indices(length(vector)) + 1;
408	!	matrix(vector[upperTriIndices], nrow=2)
409		}

1		CLASS_NAMES <- list(
2		data = "qe.data",
3		meta = "qe.metadata",
4		code = "qe.code",
5		unit = "qe.unit",
6		horizon = "qe.horizon"
7		)
8
9		WARNINGS <- list(
10		data_from_vector = "Cannot transform vectors to `qe.data`",
11		null_metadata = "`metadata` must be supplied as a vector of column names. No metadata classified.",
12		null_codes = "`codes` must be supplied as a vector of column names. No codes classified.",
13		null_units = "`units` must be supplied as a vector of column names. No units classified.",
14		null_horizon = "`horizon` must be supplied as a vector of column names. No horizon classified."
15		)
16
17		#' Convert an object to 'qe.data' class
18		#'
19		#' This function converts an object to the 'qe.data' class. If the object is not a data.frame or matrix, it is first converted to a data.table.
20		#'
21		#' @param x An object. The object to be converted to 'qe.data' class.
22		#'
23		#' @return The modified object with the 'qe.data' class.
24		#' @examples
25		#' library(data.table)
26		#'
27		#' dt <- data.table(
28		#' ID = 1:5,
29		#' Name = c("Alice", "Bob", "Charlie", "David", "Eve"),
30		#' Age = c(25, 30, 35, 40, 45),
31		#' Score = c(85, 90, 95, 80, 75)
32		#' )
33		#' dt <- as.qe.data(dt);
34		#' class(dt) # Should show 'qe.data' along with other classes
35		#'
36		#' @export
37		as.qe.data <- function(x) {
38	!	if(!is.qe.data(x)) {
39	!	if(is.vector(x)) {
40	!	warning(WARNINGS$data_from_vector);
41		}
42		else {
43		if(
44	!	is.matrix(x) \|\|
45	!	(is.data.frame(x) && !data.table::is.data.table(x))
46		) {
47	!	x <- data.table::as.data.table(x);
48		}
49	!	class(x) <- c(CLASS_NAMES$data, class(x));
50		}
51		}
52
53		# return(data.table::copy(x));
54	!	return(x);
55		}
56
57		#' Convert a vector to 'qe.code' class
58		#'
59		#' This function converts a vector to the 'qe.code' class. If the vector is a factor, it is first converted to a character vector.
60		#'
61		#' @param x A vector. The vector to be converted to 'qe.code' class.
62		#'
63		#' @return The modified vector with the 'qe.code' class.
64		#' @examples
65		#' vec <- factor(c("A", "B", "C"))
66		#' vec <- as.qe.code(vec)
67		#' class(vec) # Should show 'qe.code' along with other classes
68		#' @export
69		as.qe.code <- function(x) {
70	!	if(is.qe.code(x)) return(x);
71
72	!	if(is.factor(x)) {
73	!	x <- as.character(x);
74		}
75	!	class(x) <- c(CLASS_NAMES$code, class(x));
76
77	!	return(x);
78		}
79
80		#' Convert a vector to 'qe.metadata' class
81		#'
82		#' This function converts a vector to the 'qe.metadata' class. If the vector is a factor, it is first converted to a character vector.
83		#'
84		#' @param x A vector. The vector to be converted to 'qe.metadata' class.
85		#'
86		#' @return The modified vector with the 'qe.metadata' class.
87		#' @examples
88		#' vec <- factor(c("A", "B", "C"))
89		#' vec <- as.qe.metadata(vec)
90		#' class(vec) # Should show 'qe.metadata' along with other classes
91		#' @export
92		as.qe.metadata <- function(x) {
93	!	if(is.qe.metadata(x)) return(x);
94
95	!	if(is.factor(x)) {
96	!	x <- as.character(x);
97		}
98	!	class(x) <- c(CLASS_NAMES$meta, class(x));
99
100	!	return(x);
101		}
102
103		#' Convert a vector to 'qe.unit' class
104		#'
105		#' This function converts a vector to the 'qe.unit' class. If the vector is a factor, it is first converted to a character vector.
106		#'
107		#' @param x A vector. The vector to be converted to 'qe.unit' class.
108		#'
109		#' @return The modified vector with the 'qe.unit' class.
110		#' @examples
111		#' vec <- factor(c("A", "B", "C"))
112		#' vec <- as.qe.unit(vec)
113		#' class(vec) # Should show 'qe.unit' along with other classes
114		#' @export
115		as.qe.unit <- function(x) {
116	!	if(is.qe.unit(x)) return(x);
117
118	!	if(is.factor(x)) {
119	!	x <- as.character(x);
120		}
121	!	class(x) <- c(CLASS_NAMES$unit, class(x));
122
123	!	return(x);
124		}
125
126		#' Convert a vector to 'qe.horizon' class
127		#'
128		#' This function converts a vector to the 'qe.horizon' class. If the vector is a factor, it is first converted to a character vector.
129		#'
130		#' @param x A vector. The vector to be converted to 'qe.horizon' class.
131		#'
132		#' @return The modified vector with the 'qe.horizon' class.
133		#' @examples
134		#' vec <- factor(c("A", "B", "C"))
135		#' vec <- as.qe.horizon(vec)
136		#' class(vec) # Should show 'qe.horizon' along with other classes
137		#' @export
138		as.qe.horizon <- function(x) {
139	!	if(is.qe.horizon(x)) return(x);
140
141	!	if(is.factor(x)) {
142	!	x <- as.character(x);
143		}
144	!	class(x) <- c(CLASS_NAMES$horizon, class(x));
145
146	!	return(x);
147		}
148
149		#' Check if an object is of class 'qe.data'
150		#'
151		#' This function checks if an object is of class 'qe.data'.
152		#'
153		#' @param x An object. The object to be checked.
154		#'
155		#' @return A logical value. TRUE if the object is of class 'qe.data', otherwise FALSE.
156		#' @examples
157		#' library(data.table)
158		#'
159		#' dt <- data.table(ID = 1:5)
160		#' class(dt) <- c("qe.data", class(dt))
161		#' is.qe.data(dt) # Should return TRUE
162		#' @export
163		is.qe.data <- function(x) {
164	!	return(CLASS_NAMES$data %in% class(x));
165		}
166
167		#' Check if an object is of class 'qe.code'
168		#'
169		#' This function checks if an object is of class 'qe.code'.
170		#'
171		#' @param x An object. The object to be checked.
172		#'
173		#' @return A logical value. TRUE if the object is of class 'qe.code', otherwise FALSE.
174		#' @examples
175		#' dt <- 1:5
176		#' class(dt) <- c("qe.code", class(dt))
177		#' is.qe.code(dt) # Should return TRUE
178		#' @export
179		is.qe.code <- function(x) {
180	!	return(CLASS_NAMES$code %in% class(x));
181		}
182
183		#' Check if an object is of class 'qe.metadata'
184		#'
185		#' This function checks if an object is of class 'qe.metadata'.
186		#'
187		#' @param x An object. The object to be checked.
188		#'
189		#' @return A logical value. TRUE if the object is of class 'qe.metadata', otherwise FALSE.
190		#' @examples
191		#' dt <- 1:5
192		#' class(dt) <- c("qe.metadata", class(dt))
193		#' is.qe.metadata(dt) # Should return TRUE
194		#' @export
195		is.qe.metadata <- function(x) {
196	!	return(CLASS_NAMES$meta %in% class(x));
197		}
198
199
200		#' Check if an object is of class 'qe.unit'
201		#'
202		#' This function checks if an object is of class 'qe.unit'.
203		#'
204		#' @param x An object. The object to be checked.
205		#'
206		#' @return A logical value. TRUE if the object is of class 'qe.unit', otherwise FALSE.
207		#' @examples
208		#' dt <- 1:5
209		#' class(dt) <- c("qe.unit", class(dt))
210		#' is.qe.unit(dt) # Should return TRUE
211		#' @export
212		is.qe.unit <- function(x) {
213	!	return(CLASS_NAMES$unit %in% class(x));
214		}
215
216		#' Check if an object is of class 'qe.horizon'
217		#'
218		#' This function checks if an object is of class 'qe.horizon'.
219		#'
220		#' @param x An object. The object to be checked.
221		#'
222		#' @return A logical value. TRUE if the object is of class 'qe.horizon', otherwise FALSE.
223		#' @examples
224		#' dt <- 1:5
225		#' class(dt) <- c("qe.horizon", class(dt))
226		#' is.qe.horizon(dt) # Should return TRUE
227		#' @export
228		is.qe.horizon <- function(x) {
229	!	return(CLASS_NAMES$horizon %in% class(x));
230		}

1		#' accumulate_threads
2		#'
3		#' @param data TBD
4		#' @param units_by TBD
5		#' @param conversation_rules TBD
6		#' @param code_cols TBD
7		#' @param ... TBD
8		#' @param conversation_splits TBD
9		#' @param as_directed TBD
10		#' @param window_size TBD
11		#' @param meta_data TBD
12		#'
13		#'
14		#' @return TBD
15		#' @export
16		accumulate_threads <- function(
17		data,
18		units_by,
19		conversation_rules,
20		code_cols,
21		...,
22		conversation_splits = NULL,
23		as_directed = FALSE,
24		window_size = 4,
25		meta_data = units_by
26		) {
27	!	if(!data.table::is.data.table(data)) {
28	!	data <- data.table::as.data.table(data);
29		}
30
31	!	model <- contexts(
32	!	x = data,
33	!	units_by = units_by,
34	!	hoo_rules = conversation_rules,
35	!	split_rules = conversation_splits
36		);
37	!	model <- accumulate_context_threads(
38	!	x = model,
39	!	codes = code_cols,
40	!	as_directed = as_directed,
41	!	window_size = window_size,
42	!	meta.data = meta_data,
43		...
44		);
45
46	!	return(model);
47		}

1		##
2		#' @title Find conversations by unit
3		#'
4		#' @description
5		#' Identify and extract rows corresponding to conversations for specified units in a dataset or context model. Useful for subsetting and analyzing conversational windows in network analysis.
6		#'
7		#' @details
8		#' This function groups rows by conversation (using `conversation.by` columns), identifies which rows are associated with the specified units and codes, and returns indices for each conversation, as well as metadata about which rows to include or exclude.
9		#'
10		#' @param x A data.frame or context model containing conversation data.
11		#' @param units Character vector of unit identifiers to extract conversations for.
12		#' @param units.by Character vector of column names specifying unit grouping (default: from context model attributes).
13		#' @param codes Character vector of code columns to use for identifying coded rows.
14		#' @param conversation.by Character vector of column names to group by conversation.
15		#' @param window Integer; window size for co-occurrence (default: 4).
16		#' @param conversation.exclude Character vector of conversation keys to exclude.
17		#' @param id_col Character; column name for unit IDs (default: "QEUNIT").
18		#'
19		#' @return A list with elements:
20		#' \item{conversations}{List of row indices for each conversation.}
21		#' \item{unitConvs}{Unique conversation keys for the specified units.}
22		#' \item{allRows}{All row indices included for the units.}
23		#' \item{unitRows}{Row indices for the units with codes.}
24		#' \item{convRows}{All row indices for the unit's conversations.}
25		#' \item{toRemove}{Rows not meeting co-occurrence criteria.}
26		#'
27		#' @export
28		tma.conversations = function(
29		x, units,
30		units.by = NULL, codes = NULL, conversation.by = NULL,
31		window = 4, conversation.exclude = c(),
32		id_col = "QEUNIT"
33		) {
34	!	if(is.null(units.by)) {
35	!	units.by = x$`_function.params`$units.by;
36	!	if(is.null(units.by)) {
37	!	stop("Unable to find values for `units.by`")
38		}
39		}
40
41	!	if(is(x, "data.frame")) {
42	!	rawAcc2 = data.table::data.table(x);
43		}
44		else {
45	!	rawAcc2 = x$model$raw.input;
46		}
47
48	!	rawAcc2$KEYCOL = merge_columns(rawAcc2, conversation.by);
49	!	conversationsTable2 = rawAcc2[, paste(.I, collapse = ","), by = c(conversation.by)];
50	!	rows2 = lapply(conversationsTable2$V1, function(x) as.numeric(unlist(strsplit(x, split=","))));
51	!	names(rows2) = merge_columns(conversationsTable2, conversation.by);
52	!	unitRows2 = rawAcc2[[id_col]];
53
54	!	codedRows = rawAcc2[, rowSums(.SD), .SDcols = codes] > 0
55	!	codedUnitRows2 = which(unitRows2 %in% units & codedRows)
56	!	codedUnitRows2 = codedUnitRows2[!(codedUnitRows2 %in% as.vector(unlist(rows2[conversation.exclude])))]
57	!	codedUnitRowConvs2 = rawAcc2[codedUnitRows2, KEYCOL];
58
59	!	codedUnitRowConvsAll = NULL;
60	!	codedUnitRowConvsAll2 = NULL;
61	!	unitRowsNotCooccurred = c()
62	!	if(length(codedUnitRows2) > 0) {
63	!	codedUnitRowConvsAll = unique(unlist(sapply(X = 1:length(codedUnitRows2), simplify = F, FUN = function(x) {
64	!	thisConvRows = rows2[[codedUnitRowConvs2[x]]]
65	!	thisRowInConv = which(thisConvRows == codedUnitRows2[x])
66	!	winUse = ifelse(is.infinite(window), thisRowInConv, window)
67	!	thisRowAndWindow = rep(thisRowInConv,winUse) - (winUse-1):0
68		# coOccursFound = all(rawAcc2[thisConvRows[thisRowAndWindow[thisRowAndWindow > 0]], lapply(.SD, sum), .SDcols=codes] > 0)
69	!	coOccursFound = sum(rawAcc2[thisConvRows[thisRowAndWindow[thisRowAndWindow > 0]], lapply(.SD, sum), .SDcols=codes]) > 1
70		# browser(expr = { thisConvRows[thisRowInConv] == 12 })
71	!	if(coOccursFound) {
72	!	thisConvRows[thisRowAndWindow[thisRowAndWindow > 0]]
73		}
74		else {
75	!	unitRowsNotCooccurred <<- c(unitRowsNotCooccurred, thisConvRows[thisRowInConv]);
76
77	!	NULL
78		}
79		})))
80		}
81
82		# browser()
83	!	unitConvs <- unique(rawAcc2[codedUnitRows2, KEYCOL]);
84	!	return(list(
85	!	conversations = as.list(rows2),
86	!	unitConvs = unitConvs,
87	!	allRows = codedUnitRowConvsAll,
88	!	unitRows = codedUnitRows2,
89	!	convRows = unique(unlist(sapply(unitConvs, function(x) { rows2[[x]] }))),
90	!	toRemove = unitRowsNotCooccurred
91		));
92		}
93
94
95		#' @title Interactive Conversation Viewer
96		#'
97		#' @description
98		#' Launch an interactive HTML viewer for conversations and codes for a specified unit or set of units. Useful for exploring and validating conversation windows and code assignments in the TMA workflow.
99		#'
100		#' @param x A context model or data.frame containing conversation data.
101		#' @param wh Character or integer; unit(s) to view.
102		#' @param text_col Character; column name for text (default: "text").
103		#' @param units.by Character vector of unit grouping columns (default: from context model attributes).
104		#' @param conversation.by Character vector of conversation grouping columns (default: from context model attributes).
105		#' @param codes Character vector of code columns (default: from context model attributes).
106		#' @param window_size Integer; window size for co-occurrence (default: from context model attributes).
107		#' @param more_cols Character vector of additional columns to include in the viewer.
108		#' @param in_browser Logical; if TRUE, open in system browser, otherwise use RStudio viewer (default: FALSE).
109		#' @param id_col Character; column name for unit IDs (default: "QEUNIT").
110		#'
111		#' @return A list containing the viewer data and metadata (invisibly). The function is called for its side effect of launching the viewer.
112		#' @export
113		view <- function(
114		x, wh,
115		text_col = "text",
116		units.by = x$`_function.params`$units.by,
117		conversation.by = x$`_function.params`$conversation.by,
118		codes = x$rotation$codes,
119		window_size = x$`_function.params`$window_size,
120		more_cols = NULL,
121		in_browser = FALSE,
122		id_col = "QEUNIT"
123		) {
124	!	unit_conv <- tma.conversations(x = x, units = wh, units.by = units.by, conversation.by = conversation.by, codes = codes, window = window_size, id_col = id_col);
125		# rows <- x$model$contexts[[wh]];
126		# if(is.null(rows)) {
127		# stop(paste0("Now rows found for context: ", wh));
128		# }
129
130	!	cols <- unique(c("QEID", id_col, units.by, conversation.by, text_col, more_cols, codes));
131	!	cols <- cols[cols %in% colnames(x$model$raw.input)];
132	!	tbl <- x$model$raw.input[unit_conv$convRows, cols, with = FALSE];
133	!	unit_conv$unitRows <- unit_conv$unitRows;
134	!	unit_conv$toRemove <- unit_conv$toRemove;
135	!	unit_conv$data <- tbl;
136	!	unit_conv$units <- wh;
137	!	unit_conv$window <- window_size;
138
139	!	if(requireNamespace("jsonlite", quietly = TRUE) == FALSE) {
140	!	stop("Please install the `jsonlite` package to use this function.")
141		}
142
143	!	tbl_json <- jsonlite::toJSON(unit_conv, auto_unbox = TRUE);
144
145	!	tmp_html <- tempfile(fileext = ".html")
146	!	html_lines <- readLines(system.file(package="tma", paste0("apps/viewer.html")));
147	!	html_lines[grepl("//_ENA_MODEL_//", x = html_lines)] <- paste0("data = ", tbl_json, ";");
148	!	writeLines(text = html_lines, con = tmp_html);
149
150	!	if(in_browser == TRUE) {
151	!	browseURL(tmp_html);
152		}
153		else {
154	!	rstudioapi::viewer(tmp_html)
155		}
156		}

1		#' Conversation membership and per-modality window spans (Data View v2)
2		#'
3		#' TMA-aware successor to \code{tma.conversations()}. For each unit's coded
4		#' reference rows it returns the co-occurring rows within that row's
5		#' \emph{per-modality} window, plus a \code{rowWindows} payload that drives the
6		#' webtool Data View window-span hover.
7		#'
8		#' Unlike \code{tma.conversations()} (which predates the window/weight matrix and
9		#' uses a single scalar window), this derives windows from the resolved tensor
10		#' persisted on the accumulated object (\code{x$`_function.params`$tensor}) and
11		#' calls the libqe primitive \code{apply_tensor_members()} — the SAME code path
12		#' the network uses — so the Data View can't drift from the network.
13		#'
14		#' @param x An accumulated tma set (from \code{accumulate()}); must carry
15		#' \code{_function.params$tensor} and \code{_function.params$mode_column}
16		#' (populated by \code{accumulate()} since the 5a change).
17		#' @param codes Code column names. Defaults to \code{_function.params$codes}.
18		#' @param id_col Row-identity column. Default \code{"QEID"}.
19		#'
20		#' @return A list with \code{unitRows}, \code{allRows}, \code{toRemove} (row ids)
21		#' and \code{rowWindows}: a named list keyed by reference row id, each
22		#' \code{list(refMode, members = list(list(row, mode, distance, admittedBy,
23		#' window, coOccurs)))}. (\code{conversations}/\code{unitConvs} grouping is
24		#' layered on by the caller/server, mirroring \code{tma.conversations()}.)
25		#' @importFrom libqe apply_tensor_members
26		#' @export
27		tma.conversations2 <- function(x, codes = NULL, id_col = "QEID") {
28	!	fp <- x$`_function.params`
29	!	tensor <- fp$tensor
30	!	if (is.null(tensor))
31	!	stop("x lacks _function.params$tensor; re-accumulate with a tma build that persists it (5a).")
32	!	if (is.null(codes)) codes <- fp$codes
33	!	mode_col <- attr(tensor, "mode_column")
34	!	time_column <- if (!is.null(fp$time_column)) fp$time_column else ATTR_NAMES$CONTEXT_COL_ID
35
36	!	send_cols <- attr(tensor, "sender_cols")
37	!	recv_cols <- attr(tensor, "receiver_cols")
38	!	mode_cols <- attr(tensor, "mode_column")
39	!	tensor_dim <- attr(tensor, "dim")
40	!	tensor_sender_inds <- attr(tensor, "sender_inds") - 1
41	!	tensor_receiver_inds <- attr(tensor, "receiver_inds") - 1
42	!	tensor_mode_inds <- attr(tensor, "mode_inds") - 1
43
44	!	rowWindows <- list()
45	!	allRows <- integer()
46	!	unitRowsAll <- integer()
47	!	toRemove <- integer()
48
49	!	cols_to_encode <- c(send_cols, recv_cols, mode_cols)
50	!	cols_unq <- unique(cols_to_encode)
51		# Global factor levels for the context (mode/sender/receiver) columns. A
52		# per-context as.factor() would collapse a single-modality conversation to
53		# level 1 and read the WRONG modality's window cell -- e.g. a SecondHalf-only
54		# context reading FirstHalf's window (accumulate() dodges this only because
55		# its columns are pre-factored with global levels upstream). Encoding each
56		# context against these global levels keeps the row lookup aligned with the
57		# tensor's physical axes.
58		#
59		# The tensor's own per-axis dimnames ARE that global order
60		# (context_tensor -> get_unique_values -> sort(unique(.))), and -- unlike
61		# x$model$raw.input -- they survive when this runs on a set reused from an
62		# ena.generate session (raw.input is stripped off the returned set). Prefer
63		# them; fall back to raw.input only if an axis has no usable names.
64	!	dn <- dimnames(tensor)
65	!	axis_levels <- function(cc) {
66	!	si <- match(cc, send_cols); if (!is.na(si)) return(dn[[paste0("sender_", si)]])
67	!	ri <- match(cc, recv_cols); if (!is.na(ri)) return(dn[[paste0("receiver_", ri)]])
68	!	if (length(mode_cols) && cc == mode_cols) return(dn[["modes"]])
69	!	NULL
70		}
71	!	raw_full <- x$model$raw.input
72	!	ctx_levels <- lapply(cols_unq, function(cc) {
73	!	ax <- axis_levels(cc)
74	!	if (!is.null(ax)) as.character(ax)
75	!	else if (!is.null(raw_full)) as.character(sort(unique(raw_full[[cc]])))
76	!	else stop("tma.conversations2: cannot resolve global levels for column ", cc)
77		})
78	!	names(ctx_levels) <- cols_unq
79
80	!	process_ctx <- function(ctx_o) {
81	!	unit_rows <- attr(ctx_o, "tma.unit_rows")
82	!	if (is.null(unit_rows) \|\| length(unit_rows) == 0) return(invisible())
83
84		# ---- prep identical to accumulate() so windows match the network ----
85	!	ctx__ <- data.table::copy(ctx_o)
86	!	if (length(cols_to_encode) && !all(sapply(ctx__[, ..cols_to_encode], is.numeric))) {
87	!	ctx__[, (cols_unq) := lapply(cols_unq, function(cc) match(as.character(ctx__[[cc]]), ctx_levels[[cc]]))]
88		}
89	!	unit_context_lookup <- as.matrix(ctx__[, ..cols_to_encode])
90	!	unit_to_last <- seq.int(unit_rows[length(unit_rows)])
91	!	ctx_unit_to_last <- ctx__[unit_to_last, ]
92
93	!	res <- apply_tensor_members(
94	!	tensor, tensor_dim, tensor_sender_inds, tensor_receiver_inds, tensor_mode_inds,
95	!	unit_context_lookup[unit_to_last, , drop = FALSE] - 1,
96	!	unit_rows - 1,
97	!	as.matrix(ctx_unit_to_last[, ..codes]),
98	!	ctx_unit_to_last[[time_column]]
99		)
100
101		# ---- reshape membership -> rowWindows (using original, unencoded values) ----
102	!	ids <- ctx_o[[id_col]]
103	!	modev <- as.character(ctx_o[[mode_col]])
104	!	codeMat <- as.matrix(ctx_o[, ..codes])
105
106	!	for (i in seq_along(unit_rows)) {
107	!	ur <- unit_rows[i] # 1-based position in ctx_o
108		# A reference row must itself carry >=1 of the queried (edge) codes --
109		# rows with none are not connection references for this edge.
110	!	if (sum(codeMat[ur, ]) == 0) next
111	!	mem <- res$row_window_members[[i]] # 1-based positions in ctx_unit_to_last (== ctx_o[<= last])
112	!	wins <- res$row_window_wins[[i]]
113
114		# Edge co-occurrence: EVERY queried code appears somewhere in the window
115		# (the reference row + its in-window members) -- i.e. the edge's endpoints
116		# both fall inside the window, not merely >=2 code instances.
117	!	windowHasCoOccur <- all(colSums(codeMat[c(mem, ur), , drop = FALSE]) > 0)
118	!	members <- lapply(seq_along(mem), function(k) {
119	!	g <- mem[k]
120	!	list(row = ids[g], mode = modev[g], distance = ur - g,
121	!	admittedBy = modev[g], window = wins[k],
122	!	coOccurs = unname((sum(codeMat[g, ]) > 0) && windowHasCoOccur))
123		})
124	!	rowWindows[[as.character(ids[ur])]] <<- list(refMode = modev[ur], members = members)
125	!	unitRowsAll <<- c(unitRowsAll, ids[ur])
126	!	if (windowHasCoOccur) allRows <<- c(allRows, ids[c(mem, ur)]) else toRemove <<- c(toRemove, ids[ur])
127		}
128		}
129
130	!	for (ctx in x$model$contexts) {
131	!	if (is.data.frame(ctx)) process_ctx(ctx) else lapply(ctx, process_ctx)
132		}
133
134	!	list(
135	!	unitRows = unique(unitRowsAll),
136	!	allRows = unique(allRows),
137	!	toRemove = unique(toRemove),
138	!	rowWindows = rowWindows
139		)
140		}

1
2		#' @title Internal: Simple window decay (legacy)
3		#' @description
4		#' Internal helper for window decay, used in TMA v0.1.0. Not exported. Kept for backward compatibility with legacy decay function creation.
5		#'
6		#' @param x Numeric vector of time differences.
7		#' @param args List of arguments (expects `window_size`).
8		#' @return Numeric vector (0/1) indicating whether each value is within the window.
9		#' @export
10		simple_window <- function(x, args = NULL) {
11	!	.Deprecated("tma::context_tensor", "tma v0.2.0");
12	!	(x <= args$window_size) * 1
13		}
14
15		#' @title Internal: Decay function factory (legacy)
16		#' @description
17		#' Internal factory for creating decay functions, used in TMA v0.1.0. Not exported. Kept for backward compatibility with legacy code.
18		#'
19		#' @param what Function to use as the decay kernel.
20		#' @param ... Named parameters to pass to `what`.
21		#' @return A function that applies the specified decay kernel to its input.
22		#' @export
23		decay <- function(what, ...) {
24	!	.Deprecated("tma::context_tensor", "tma v0.2.0");
25	!	args <- list(...);
26	!	function(x) {
27	!	do.call(what, list(x = x, args = args))
28		}
29		}

1		#' Apply windowing and weighting to context data for network accumulation
2		#'
3		#' @description
4		#' `r lifecycle::badge("deprecated")`
5		#'
6		#' `apply_tensor_old` is a deprecated alias for the tensor-based accumulation
7		#' function. Use [accumulate()] for the full TMA accumulation pipeline.
8		#'
9		#' @param tensor NumericVector. Flat multi-dimensional context_tensor array.
10		#' @param dims IntegerVector. Dimensions of the original context_tensor array.
11		#' @param dims_sender Integer vector. 0-based indices of sender dimensions.
12		#' @param dims_receiver Integer vector. 0-based indices of receiver dimensions.
13		#' @param dims_mode Integer vector. 0-based indices of mode dimensions.
14		#' @param context_matrix NumericMatrix. Context lookup matrix (rows = context lines, cols = factors).
15		#' @param unit_rows Integer vector. 0-based response-row indices for this unit.
16		#' @param codes Numeric matrix. Code matrix (nrow = context lines, ncol = number of codes).
17		#' @param times Numeric vector. Timestamp per context row.
18		#' @param ordered Logical. TRUE = directed; FALSE = undirected upper-triangle.
19		#' @return List with \code{row_connection_counts} and \code{connection_counts}.
20		#' @export
21		apply_tensor_old <- function(tensor, dims, dims_sender, dims_receiver, dims_mode,
22		context_matrix, unit_rows, codes, times,
23		ordered = TRUE) {
24	!	apply_tensor(tensor, dims, dims_sender, dims_receiver, dims_mode,
25	!	context_matrix, unit_rows, codes, times, ordered)
26		}

1		##' Set Units of Analysis for a TMA Model
2		#'
3		#' Internal helper to initialize and label units of analysis in a TMA model object.
4		#' Given a data.frame and a set of columns, this function creates a model structure
5		#' with unit labels and context placeholders for each unique unit.
6		#'
7		#' @param x A data.frame or TMA model object containing the raw input data.
8		#' @param by Character vector of column names to use for defining units of analysis (e.g., c("userID", "condition")).
9		#'
10		#' @return A TMA model object with unit labels and empty context slots for each unit.
11		units <- function(x, by) {
12	19x	model <- x;
13	19x	if ( is.data.frame(x) ) {
14	19x	model <- list(
15	19x	model = list (
16	19x	model.type = "TMA",
17	19x	raw.input = data.table::as.data.table( x ),
18	19x	row.connection.counts = as.data.frame(matrix(nrow = nrow( x ), ncol = 0))
19		)
20		)
21	19x	class(model) <- c("ena.set", class(model))
22		}
23
24	19x	model$model$raw.input[[ATTR_NAMES$CONTEXT_ID]] <- 1;
25	19x	model$model$raw.input$QEID <- seq(nrow(model$model$raw.input));
26	19x	data.table::setkeyv(x = model$model$raw.input, cols = c("QEID"));
27
28		# raw_input <- model$model$raw.input;
29	19x	model$`_function.params`$units.by <- by;
30
31	19x	all_units <- model$model$raw.input[, ..by];
32	19x	unique_units <- unique(all_units);
33	19x	model$`_function.params`$units <- all_units;
34
35	19x	unique_unit_labels <- apply(unique_units, 1, function(y) paste((y), collapse = "::"));
36
37		# model$model$contexts <- structure(rep(list(model$model$raw.input[0,]), length(unique_unit_labels)), names = unique_unit_labels);
38	19x	model$model$contexts <- structure(rep(list(c()), length(unique_unit_labels)), names = unique_unit_labels);
39	19x	model$model$unit.labels <- unique_unit_labels;
40	19x	model$model$raw.input$QEUNIT <- apply(all_units, 1, function(y) paste((y), collapse = "::"));
41		# model$model$raw.input[, QEUNIT:=paste(.SD, collapse = "::"), .SDcols = names(all_units), by=1:nrow(model$model$raw.input)]
42
43	19x	return(model);
44		}
45
46		##' Apply a Subsetting Rule to TMA Contexts (Internal)
47		#'
48		#' Internal helper to apply a logical subsetting rule ("hoo rule") to each unit's context in a TMA model object.
49		#' Updates the contexts for each unit by including only rows that match the rule.
50		#'
51		#' @param x A TMA model object as produced by [units()].
52		#' @param ... Logical expression(s) specifying the subsetting rule to apply. If not provided, uses the `rule` argument.
53		#' @param rule A single logical expression to use as the subsetting rule (alternative to ...).
54		#'
55		#' @return The input TMA model object with updated contexts for each unit, where each context contains only rows matching the rule.
56		hoo <- function(x, ..., rule = NULL) {
57	37x	units <- x$`_function.params`$units;
58	37x	unit_contexts <- x$model$contexts;
59
60	37x	hoo_args <- substitute(...);
61	37x	if( is.null(hoo_args) ) {
62	37x	hoo_args <- rule;
63		}
64
65	37x	raw_input <- x$model$raw.input;
66
67	37x	unique_units <- unique(units);
68	37x	updated_contexts <- lapply(seq(nrow(unique_units)), function(i) {
69	156x	this_unit <- unique_units[i,];
70	156x	this_unit <- this_unit[, lapply(.SD, reclass, "ena.metadata"), .SDcols = colnames(this_unit)];
71
72	156x	unit_label <- paste(this_unit, collapse = "::");
73		# UNIT <- raw_input[as.list(this_unit), , on = names(this_unit)];
74	156x	UNIT <- mapply(raw_input[as.list(this_unit), , on = names(this_unit)], FUN = unique, SIMPLIFY = FALSE);
75
76	156x	this_context <- unit_contexts[[unit_label]];
77	156x	ret <- sort(unique(c(this_context, raw_input[eval(hoo_args), , which = TRUE])));
78	156x	attr(x = ret, which = "tma.unit") <- this_unit;
79	156x	ret
80		});
81	37x	names(updated_contexts) <- names(unit_contexts)
82
83	37x	x$model$contexts <- updated_contexts; #unit_contexts;
84
85	37x	x
86		}
87
88		#' Capture Subsetting Rules as Expressions
89		#'
90		#' Allows users to supply conditions for subsetting rows from their data. The collected unevaluated expressions are intended to be used as the `hoo_rules` parameter in the `contexts()` function within the TMA workflow.
91		#'
92		#' @param ... Logical expressions specifying the conditions for subsetting data. These expressions are captured unevaluated and returned as a list.
93		#'
94		#' @return A list of unevaluated expressions representing subsetting rules.
95		#'
96		#' @examples
97		#'
98		#' rules(
99		#' modality %in% "chat" & chatGroup %in% UNIT$chatGroup & condition %in% UNIT$condition,
100		#' modality %in% "resource" & userID %in% UNIT$userID & condition %in% UNIT$condition
101		#' )
102		#'
103		#' @export
104		rules <- function(...) {
105	18x	rlang::exprs(...)
106		}
107
108		#' Conversation rules
109		#'
110		#' @param ... list of rules
111		#'
112		#' @return callable expressions, see `rlang::exprs`
113		#' @export
114		conversation_rules <- function(...) {
115	1x	rlang::exprs(...)
116		}
117
118		##' Create Contexts for Units of Analysis
119		#'
120		#' This function generates context data for each unit of analysis in your dataset, applying subsetting rules ("hoo rules") and optional splitting rules to organize the data for network accumulation.
121		#'
122		#' @param x A data.frame or TMA model object containing the raw input data.
123		#' @param hoo_rules A list of logical expressions (see [rules()]) specifying how to subset the data for each context/unit.
124		#' @param units_by Character vector of column names to use for defining units of analysis (e.g., c("userID", "condition")).
125		#' @param split_rules Optional. Either a function or an expression specifying how to further split each context (e.g., by time period or other grouping variable).
126		#'
127		#' @return A TMA model object with updated contexts for each unit, where each context is a data.table containing only the relevant rows for that unit and context. The object includes attributes for unit labels and context row indices.
128		#'
129		#' @details
130		#' This function is a core part of the TMA workflow. It first applies the specified `hoo_rules` to subset the data for each unit, then (optionally) applies `split_rules` to further divide each context. The resulting contexts are used in subsequent accumulation and network analysis steps.
131		#'
132		#' @examples
133		#' data(test_mockdata, package = "tma")
134		#' mock_data <- test_mockdata[test_mockdata$chatGroup == "PAM",]
135		#' unit_cols <- c("userID", "condition")
136		#' codes <- c("A", "B", "C")
137		#' HOO_rules_model <- rules(
138		#' modality %in% "chat" & chatGroup %in% UNIT$chatGroup & condition %in% UNIT$condition,
139		#' modality %in% "resource" & userID %in% UNIT$userID & condition %in% UNIT$condition
140		#' )
141		#'
142		#' context_model <- contexts(
143		#' x = mock_data,
144		#' units = unit_cols,
145		#' hoo_rules = HOO_rules_model
146		#' )
147		#' str(context_model$model$contexts)
148		#'
149		#' @export
150		contexts <- function(x, hoo_rules, units_by = NULL, split_rules = NULL) {
151	19x	x_ <- units(x, units_by);
152
153	19x	for(r in hoo_rules) {
154	37x	x_ <- hoo(x_, rule = r);
155		}
156
157	19x	raw_input <- x_$model$raw.input;
158	19x	split_expr_valid <- TRUE;
159	19x	err_found <- 0;
160	19x	tryCatch(expr = rlang::enexpr(split_rules), error = function(e) {
161	!	err_found <<- 1;
162	!	print(e$message)
163	19x	}, warning = function(w) {
164	!	err_found <<- 2;
165	19x	}, finally = {
166	19x	if(err_found != 0) {
167	!	split_expr_valid <- FALSE;
168		}
169		})
170
171	19x	if(split_expr_valid) {
172	19x	split_rules_expr <- rlang::enexpr(split_rules);
173
174	19x	if( !is.null(split_rules_expr) ) {
175	!	unit_contexts <- x_$model$contexts;
176	!	model_units <- x_$`_function.params`$units;
177
178		# if ( is.function (split_rules) ) {
179	!	if( is(split_rules, "function") ) {
180	!	unique_units <- unique(model_units);
181	!	unit_contexts_res <- apply(unique_units, 1, function(u) {
182	!	unit_label <- paste(u, collapse = "::");
183	!	res <- do.call(what = split_rules, args = list(unit = u, raw_input[unit_contexts[[unit_label]]]));
184	!	attr(res, "tma.unit") <- attr(unit_contexts[[unit_label]], "tma.unit");
185	!	res2 <- lapply(res, function(r) {
186	!	r[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(r));
187	!	attr(r, "tma.unit") <- attr(res, "tma.unit");
188	!	attr(r, "tma.unit_rows") <- which(r$QEUNIT == unit_label)
189	!	r
190		});
191	!	res2
192		});
193	!	names(unit_contexts_res) <- apply(unique_units, 1, paste, collapse = "::"); #names(unit_contexts);
194	!	unit_contexts <- unit_contexts_res;
195		}
196		else {
197	!	if( !inherits(x = split_rules_expr, what = "call") ) {
198	!	for(i in seq(split_rules_expr)) {
199	!	unit_contexts <- lapply(unit_contexts, function(uc) {
200	!	lapply(split(x = raw_input[uc,], by = as.character(split_rules)), function(x) {
201	!	unit_tbl <- attr(x = uc, "tma.unit");
202	!	unit_label <- paste0(unit_tbl, collapse = "::");
203
204	!	x[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(x));
205	!	attr(x = x, which = "tma.unit") <- attr(x = uc, "tma.unit");
206	!	attr(x = x, which = "tma.unit_rows") <- which(x$QEUNIT == unit_label);
207	!	x
208		});
209		})
210		}
211		}
212		else {
213	!	for( i in seq(split_rules) ) {
214	!	if ( is.name(split_rules[[i]]) ){
215		# unit_contexts <- lapply(unit_contexts, split, by = as.character(split_rules[[i]]))
216	!	unit_contexts <- lapply(unit_contexts, function(uc) {
217	!	split(x = raw_input[uc,], by = as.character(split_rules[[i]]))
218		})
219		}
220		else {
221	!	stop("THIS NEEDS UPDATING (1)")
222	!	units_to_split <- model_units[eval(split_rules[[i]][[2]]), , which = TRUE]
223	!	unit_contexts[units_to_split] <- lapply(unit_contexts[units_to_split], split, by = names(split_rules[i]))
224		}
225		}
226		}
227		}
228
229	!	x_$model$contexts <- unit_contexts;
230		}
231		else {
232	19x	unit_contexts <- x_$model$contexts;
233	19x	model_units <- x_$`_function.params`$units;
234	19x	unique_units <- unique(model_units);
235	19x	unit_contexts_res <- apply(unique_units, 1, function(u) {
236		# unit_label <- paste(u, collapse = "::");
237	102x	unit_label <- paste(trimws(u), collapse = "::");
238	102x	res <- raw_input[unit_contexts[[unit_label]]];
239	102x	res[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(res));
240
241	102x	attr(res, "tma.unit") <- attr(unit_contexts[[unit_label]], "tma.unit");
242	102x	attr(res, "tma.unit_rows") <- which(res$QEUNIT == unit_label);
243	102x	res
244		});
245	19x	names(unit_contexts_res) <- apply(unique_units, 1, paste, collapse = "::"); #names(unit_contexts);
246	19x	unit_contexts <- unit_contexts_res;
247	19x	x_$model$contexts <- unit_contexts;
248		}
249		}
250
251		# x_list <- list2env(x_);
252		# class(x_list) <- c("ena.set", class(x_list));
253		# return(x_list);
254	19x	x_
255		}

1		.onLoad <- function(libname, pkgname) {
2	!	globalVariables(c(
3	!	"..units_by", "..by", ".I", "QEID", "CID", "..conversations",
4	!	"KEYCOL", "QEUNIT", "..sender_cols", "..receiver_cols", "..mode_column",
5	!	"..codes", "..cols_to_encode"
6		))
7		}
8
9
10		## Attributes for special columns in data.tables, currently used when
11		## creating contexts
12
13		#' Special attribute names for context columns
14		#'
15		#' A named list of string constants used as attribute keys for special columns in data.tables
16		#' within the TMA package, primarily for context creation and identification.
17		#'
18		#' @format A named list with elements:
19		#' \describe{
20		#' \item{CONTEXT_ID}{A string used to identify the context table column.}
21		#' \item{CONTEXT_COL_ID}{A string used to identify the context row ID column.}
22		#' }
23		#' @keywords internal
24		#' @export
25		ATTR_NAMES <- list(
26		CONTEXT_ID = "__CONTEXT_TBL__",
27		CONTEXT_COL_ID = "__CONTEXT_ROWID__"
28		)