tma coverage - 66.10%

Files
Source

# =============================================================================
# replace_door.R — Plug door() output back into an accumulation object
# =============================================================================

#' Replace raw co-occurrence columns with door-adjusted values
#'
#' After door(), co-occurrence columns are named door_<original "code & code">.
#' This function copies those values into accum$connection.counts, replacing
#' the raw co-occurrence columns, so model() / ena.make.set() use the door-adjusted
#' data without changing downstream code paths.
#'
#' @param accum Object from \code{tma::accumulate()}.
#' @param door_df Output of \code{door()} (must include \code{door_*} columns).
#' @return \code{accum} with updated \code{connection.counts}.
#' @export
replace_door <- function(accum, door_df) {
  if (!("connection.counts" %in% names(accum))) {
    stop("`accum` has no connection.counts")
  }
  conn <- accum$connection.counts
  if (!("ENA_UNIT" %in% names(conn)) && "QEUNIT" %in% names(conn)) {
    conn$ENA_UNIT <- as.character(conn$QEUNIT)
  }
  if (!("ENA_UNIT" %in% names(conn))) {
    stop("`accum$connection.counts` lacks ENA_UNIT (and QEUNIT)")
  }
  if (!("ENA_UNIT" %in% names(door_df)) && "QEUNIT" %in% names(door_df)) {
    door_df$ENA_UNIT <- as.character(door_df$QEUNIT)
  }
  if (!("ENA_UNIT" %in% names(door_df))) {
    stop("`door_df` lacks ENA_UNIT (and QEUNIT)")
  }

  nm <- names(conn)
  code_cols <- nm[grepl("\\s*&\\s*", nm) & vapply(conn, is.numeric, logical(1))]
  if (!length(code_cols)) {
    stop("No numeric co-occurrence columns (names with ' & ') in connection.counts")
  }

  prefix <- "door_"
  door_cols <- paste0(prefix, code_cols)
  missing <- setdiff(door_cols, names(door_df))
  if (length(missing)) {
    stop("Door table missing columns: ", paste(missing, collapse = ", "))
  }

  key_acc <- as.character(conn$ENA_UNIT)
  key_door <- as.character(door_df$ENA_UNIT)
  idx <- match(key_acc, key_door)
  if (anyNA(idx)) {
    bad <- which(is.na(idx))[seq_len(min(5L, sum(is.na(idx))))]
    stop("Cannot align by ENA_UNIT. Unmatched rows (examples): ",
         paste(bad, collapse = ", "))
  }

  table_class_before <- class(conn)
  use_datatable <- "data.table" %in% table_class_before

  for (k in seq_along(code_cols)) {
    j <- code_cols[k]
    dj <- door_cols[k]

    v <- door_df[[dj]][idx]
    if (!is.numeric(v)) {
      v <- suppressWarnings(as.double(as.character(v)))
    }
    if (any(!is.finite(v))) {
      stop("Non-finite values after replacement in column: ", j)
    }

    old_col_class <- class(conn[[j]])
    v <- structure(as.double(v), class = old_col_class)

    if (use_datatable) {
      data.table::set(conn, j = j, value = v)
    } else {
      conn[[j]] <- v
    }
  }

  class(conn) <- table_class_before
  accum$connection.counts <- conn
  accum
}

#' Apply door smoothing to an accumulation object
#'
#' This convenience wrapper runs \code{\link{door}()} on an accumulation object's
#' co-occurrence table and then writes the door-smoothed values back with
#' \code{\link{replace_door}()}. Use \code{\link{door}()} directly when you want
#' to inspect or compare the intermediate \code{door_*} columns before replacing
#' the accumulation values.
#'
#' @param accum Object from \code{tma::accumulate()}.
#' @param ... Arguments passed to \code{\link{door}()}, including
#'   \code{unit_col}, \code{time_col}, \code{method}, and method-specific
#'   settings.
#' @return \code{accum} with door-smoothed co-occurrence columns.
#' @export
door_accumulation <- function(accum, ...) {
  if ("connection.counts" %in% names(accum)) {
    conn <- accum$connection.counts
  } else if ("model" %in% names(accum) &&
             "row.connection.counts" %in% names(accum$model)) {
    conn <- accum$model$row.connection.counts
  } else {
    stop("`accum` must contain `connection.counts` or `model$row.connection.counts`.")
  }

  door_df <- door(conn, ...)
  replace_door(accum, door_df)
}



# 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)
}

# =============================================================================
# door.R — Apply the ETM door function to co-occurrence trajectories
# =============================================================================

COOCCURRENCE_NAME_REGEX <- "\\s*&\\s*"

cooccurrence_pair_column_names <- function(data) {
  nm <- names(data)
  is_pair <- grepl(COOCCURRENCE_NAME_REGEX, nm)
  is_num <- vapply(data, is.numeric, logical(1))
  nm[is_pair & is_num]
}

prefix_door_columns <- function(df_door, original_names) {
  stopifnot(ncol(df_door) == length(original_names))
  out <- as.data.frame(df_door, stringsAsFactors = FALSE)
  names(out) <- paste0("door_", original_names)
  out
}

attach_door_columns <- function(source_rows, cols_of_interest, door_only) {
  meta <- source_rows[, setdiff(names(source_rows), cols_of_interest), drop = FALSE]
  cbind(meta, door_only)
}

ensure_ena_unit_column <- function(data) {
  if ("ENA_UNIT" %in% names(data)) {
    return(data)
  }
  if ("QEUNIT" %in% names(data)) {
    data$ENA_UNIT <- as.character(data$QEUNIT)
    return(data)
  }
  data
}

assert_door_keys <- function(data, unit_col, time_col) {
  if (!unit_col %in% names(data)) {
    stop("`unit_col` not found: ", unit_col, ". Available: ",
         paste(names(data), collapse = ", "))
  }
  if (!time_col %in% names(data)) {
    stop("`time_col` not found in `data`: ", time_col,
         ". Include a monotonic row index in accumulation units.")
  }
  if (!is.character(data[[unit_col]]) && !is.factor(data[[unit_col]])) {
    stop("`unit_col` must be character or factor.")
  }
  if (!(is.numeric(data[[time_col]]) ||
        inherits(data[[time_col]], c("Date", "POSIXct", "POSIXt")))) {
    stop("`time_col` must be numeric, Date, or POSIXct. Convert before calling.")
  }
  if (any(is.na(data[[unit_col]]))) {
    bad <- which(is.na(data[[unit_col]]))[seq_len(min(5L, sum(is.na(data[[unit_col]]))))]
    stop("`unit_col` has NA (e.g. rows: ", paste(bad, collapse = ", "), ").")
  }
  if (any(is.na(data[[time_col]]))) {
    bad <- which(is.na(data[[time_col]]))[seq_len(min(5L, sum(is.na(data[[time_col]]))))]
    stop("`time_col` has NA (e.g. rows: ", paste(bad, collapse = ", "), ").")
  }
}

prepare_units_time_ordered <- function(data, unit_col, time_col) {
  data$ENA_UNIT_base <- trimws(as.character(data[[unit_col]]))
  if (!"ENA_UNIT" %in% names(data)) {
    data$ENA_UNIT <- data$ENA_UNIT_base
  }

  do.call(rbind, lapply(split(data, data$ENA_UNIT_base), function(df) {
    tvec <- df[[time_col]]
    if (any(duplicated(tvec))) {
      idx <- which(duplicated(tvec) | duplicated(tvec, fromLast = TRUE))
      show <- head(idx, 5L)
      stop("Duplicate ", time_col, " within unit '", df$ENA_UNIT_base[1L],
           "'. Example row positions: ", paste(show, collapse = ", "),
           ". Use a unique time key per row (e.g. Index).")
    }
    if (is.unsorted(tvec, strictly = TRUE)) {
      badpos <- which(diff(tvec) <= 0L)[1L]
      stop("Non-increasing ", time_col, " within unit '", df$ENA_UNIT_base[1L],
           "' near sorted positions ", badpos, " and ", badpos + 1L, ".")
    }
    df[order(tvec), , drop = FALSE]
  }))
}

.resolve_lookback_per_unit <- function(lookback_size, data, unit_col) {
  units <- unique(trimws(as.character(data[[unit_col]])))
  if (length(lookback_size) == 1L && is.numeric(lookback_size)) {
    return(stats::setNames(rep(as.integer(lookback_size), length(units)), units))
  }
  if (is.data.frame(lookback_size)) {
    uc <- intersect(c(unit_col, "unit", "UserName"), names(lookback_size))[1]
    lc <- intersect(c("lookback", "lookback_size", "door"), names(lookback_size))[1]
    if (is.na(uc) || is.na(lc)) {
      stop("lookback_size data.frame needs unit and lookback columns")
    }
    out <- stats::setNames(
      as.integer(lookback_size[[lc]]),
      as.character(lookback_size[[uc]])
    )
    return(out)
  }
  if (is.numeric(lookback_size) && !is.null(names(lookback_size))) {
    nm <- trimws(names(lookback_size))
    out <- structure(as.integer(lookback_size), names = nm)
    missing <- setdiff(units, nm)
    if (length(missing)) {
      stop("lookback_size missing units: ", paste(head(missing, 5L), collapse = ", "))
    }
    return(out)
  }
  stop("`lookback_size` must be a single integer, a named vector, or a data.frame")
}

#' Apply lookback door sliding window pooling to co-occurrence data
#'
#' @param data Data frame with co-occurrence columns
#' @param cols_of_interest Character vector of code-pair columns
#' @param lookback_size Window lookback size (single integer, named vector, or data.frame)
#' @param unit_col Name of column identifying unit
#' @param aggregate "sum" or "mean"
#' @param weighting "equal" or "linear"
#' @param segment_col Optional segment column to reset window
#' @return Data frame with door_* columns attached
#' @export
lookback_door <- function(
    data,
    cols_of_interest,
    lookback_size = 100L,
    unit_col = "ENA_UNIT_base",
    aggregate = c("sum", "mean"),
    weighting = c("equal", "linear"),
    segment_col = NULL) {
  aggregate <- match.arg(aggregate)
  weighting <- match.arg(weighting)

  if (!is.null(segment_col) && !(segment_col %in% names(data))) {
    stop("`segment_col` not found in `data`: ", segment_col)
  }

  lookback_map <- .resolve_lookback_per_unit(lookback_size, data, unit_col)
  units <- unique(data$ENA_UNIT_base)
  out <- vector("list", length(units))
  ui <- 0L

  for (u in units) {
    u_key <- as.character(u)
    idx <- match(u_key, names(lookback_map))
    if (is.na(idx)) {
      stop("No lookback_size for unit: ", u_key)
    }
    lb_u <- lookback_map[idx]
    unit_data <- as.data.frame(data[data$ENA_UNIT_base == u, , drop = FALSE])

    segments <- if (is.null(segment_col)) {
      list(unit_data)
    } else {
      split(unit_data, unit_data[[segment_col]], drop = TRUE)
    }

    seg_results <- lapply(segments, function(seg_df) {
      M <- as.matrix(seg_df[, cols_of_interest, drop = FALSE])
      n <- nrow(M)
      if (n == 0L) return(NULL)

      # Use libqe C++ acceleration if available
      segs_vec <- if (!is.null(segment_col)) as.integer(as.factor(seg_df[[segment_col]])) else integer(0)
      S <- libqe::door_lookback_block(
        block = M,
        lookback_size = as.integer(lb_u),
        aggregate_mean = (aggregate == "mean"),
        weighting_linear = (weighting == "linear"),
        segment_ids = segs_vec
      )

      door_mat <- prefix_door_columns(as.data.frame(S), cols_of_interest)
      attach_door_columns(seg_df, cols_of_interest, door_mat)
    })

    ui <- ui + 1L
    out[[ui]] <- do.call(rbind, seg_results)
  }

  do.call(rbind, out)
}

#' Apply EMA smoothing to co-occurrence data
#'
#' @param data Data frame with co-occurrence columns
#' @param cols_of_interest Character vector of code-pair columns
#' @param alpha Smoothing factor (0, 1]
#' @return Data frame with door_* columns attached
#' @export
ema_door <- function(data, cols_of_interest, alpha = 0.3) {
  mat_by_unit <- function(unit_data) {
    mat <- as.matrix(unit_data[, cols_of_interest, drop = FALSE])
    n <- nrow(mat)
    if (n == 0L) return(unit_data)

    out <- libqe::door_ema_block(block = mat, alpha = as.numeric(alpha))
    door_only <- prefix_door_columns(as.data.frame(out), cols_of_interest)
    attach_door_columns(unit_data, cols_of_interest, door_only)
  }

  units <- unique(data$ENA_UNIT_base)
  pieces <- lapply(units, function(u) {
    mat_by_unit(as.data.frame(data[data$ENA_UNIT_base == u, , drop = FALSE]))
  })
  do.call(rbind, pieces)
}

#' Apply LOESS smoothing to co-occurrence data
#'
#' @param data Data frame with co-occurrence columns
#' @param cols_of_interest Character vector of code-pair columns
#' @param time_col Strictly increasing time column
#' @param span LOESS span parameter
#' @param degree LOESS degree parameter (1 or 2)
#' @param family "gaussian" or "symmetric"
#' @return Data frame with door_* columns attached
#' @export
loess_door <- function(
    data,
    cols_of_interest,
    time_col,
    span = 0.3,
    degree = 1L,
    family = c("gaussian", "symmetric")) {
  family <- match.arg(family)
  units <- unique(data$ENA_UNIT_base)
  out <- vector("list", length(units))
  ui <- 0L

  for (u in units) {
    unit_data <- as.data.frame(data[data$ENA_UNIT_base == u, , drop = FALSE])
    x <- as.numeric(unit_data[[time_col]])
    n <- length(x)
    S <- matrix(NA_real_, nrow = n, ncol = length(cols_of_interest))

    for (j in seq_along(cols_of_interest)) {
      y <- unit_data[[cols_of_interest[j]]]
      if (all(is.na(y))) {
        S[, j] <- NA_real_
        next
      }
      fit <- tryCatch({
        stats::predict(
          stats::loess(
            y ~ x,
            span = span,
            degree = degree,
            family = family,
            control = stats::loess.control(
              surface = "direct",
              trace.hat = "approximate",
              iterations = 1L
            ),
            na.action = stats::na.exclude
          ),
          newdata = data.frame(x = x)
        )
      }, error = function(e) rep(NA_real_, n))
      S[, j] <- as.numeric(fit)
    }

    door_only <- prefix_door_columns(as.data.frame(S), cols_of_interest)
    ui <- ui + 1L
    out[[ui]] <- attach_door_columns(unit_data, cols_of_interest, door_only)
  }

  do.call(rbind, out)
}

.normalize_door_method <- function(method) {
  method <- as.character(method)
  allowed <- c("Lookback", "EMA", "LOESS")
  bad <- setdiff(method, allowed)
  if (length(bad)) {
    stop(
      "Unknown method: ", paste(bad, collapse = ", "),
      ". Use: Lookback, EMA, LOESS"
    )
  }
  unique(method)
}

.apply_post_norm <- function(res, pair_cols, post_norm) {
  if (post_norm != "l2") {
    return(res)
  }
  door_cols <- paste0("door_", pair_cols)
  door_cols <- door_cols[door_cols %in% names(res)]
  if (!length(door_cols)) {
    return(res)
  }
  M <- as.matrix(res[, door_cols, drop = FALSE])
  res[, door_cols] <- libqe::normalize_networks(M)
  res
}

.run_door_method <- function(
    data,
    method,
    pair_cols,
    time_col,
    unit_col,
    lookback_size,
    aggregate,
    weighting,
    segment_col,
    alpha,
    loess_span,
    loess_degree,
    loess_family,
    post_norm,
    verbose) {
  if (isTRUE(verbose)) {
    if (method == "Lookback") {
      lb_msg <- if (length(lookback_size) == 1L && is.numeric(lookback_size)) {
        as.character(lookback_size)
      } else {
        paste0("per-unit (", length(.resolve_lookback_per_unit(lookback_size, data, unit_col)), " units)")
      }
      message(
        "Lookback: lookback_size=", lb_msg,
        ", aggregate=", aggregate, ", weighting=", weighting,
        ", segment_col=", if (is.null(segment_col)) "NULL" else segment_col
      )
    } else if (method == "EMA") {
      message("EMA: alpha=", alpha)
    } else if (method == "LOESS") {
      message(
        "LOESS: span=", loess_span,
        ", degree=", loess_degree, ", family=", loess_family
      )
    }
  }

  res <- switch(
    method,
    Lookback = lookback_door(
      data,
      cols_of_interest = pair_cols,
      lookback_size = lookback_size,
      unit_col = unit_col,
      aggregate = aggregate,
      weighting = weighting,
      segment_col = segment_col
    ),
    EMA = ema_door(
      data,
      cols_of_interest = pair_cols,
      alpha = alpha
    ),
    LOESS = loess_door(
      data,
      cols_of_interest = pair_cols,
      time_col = time_col,
      span = loess_span,
      degree = loess_degree,
      family = loess_family
    ),
    stop("Unknown method: ", method)
  )

  .apply_post_norm(res, pair_cols, post_norm)
}

#' Apply the ETM door function to code-pair co-occurrence rows
#'
#' @param data Data frame from \code{accum$model$row.connection.counts}. If only
#'   \code{QEUNIT} is present (TMA default), it is copied to \code{ENA_UNIT} for
#'   alignment with \code{replace_door()}.
#' @param method One or more of \code{"Lookback"}, \code{"EMA"}, \code{"LOESS"}.
#' @param unit_col Column grouping the trajectory (e.g. \code{"UserName"}).
#' @param time_col Strictly increasing time column within each unit (e.g. \code{"Index"}).
#' @param post_norm \code{"none"} or \code{"l2"} row normalization on \code{door_*}
#'   columns after pooling.
#' @param lookback_size Lookback only — max rows in the backward pool. A single integer
#'   applies to all units; a named vector or data.frame (\code{unit} + \code{lookback})
#'   sets per-unit lookback sizes.
#' @param aggregate Lookback only — \code{"sum"} or \code{"mean"}.
#' @param weighting Lookback only — \code{"equal"} or \code{"linear"} ramp.
#' @param segment_col Lookback only — if set, the pool resets at each new segment level.
#' @param alpha EMA only — blend weight on the current row (0–1).
#' @param loess_span,loess_degree,loess_family LOESS only — passed to \code{stats::loess}.
#' @param verbose Print method settings.
#' @return A data frame when \code{length(method) == 1}; otherwise a named list of
#'   data frames.
#' @export
door <- function(
    data,
    method = "Lookback",
    unit_col,
    time_col,
    post_norm = c("none", "l2"),
    lookback_size = 100L,
    aggregate = c("sum", "mean"),
    weighting = c("equal", "linear"),
    segment_col = NULL,
    alpha = 0.3,
    loess_span = 0.3,
    loess_degree = 1L,
    loess_family = c("gaussian", "symmetric"),
    verbose = FALSE) {
  post_norm <- match.arg(post_norm)
  aggregate <- match.arg(aggregate)
  weighting <- match.arg(weighting)
  loess_family <- match.arg(loess_family)

  if (inherits(data, "data.table")) {
    data <- as.data.frame(data)
  }
  data <- ensure_ena_unit_column(data)

  assert_door_keys(data, unit_col, time_col)
  data <- prepare_units_time_ordered(data, unit_col, time_col)

  pair_cols <- cooccurrence_pair_column_names(data)
  if (length(pair_cols) == 0L) {
    stop("No numeric code-pair columns (names matching ' & ') found.")
  }

  methods <- .normalize_door_method(method)

  if (length(methods) == 1L) {
    return(.run_door_method(
      data = data,
      method = methods[[1L]],
      pair_cols = pair_cols,
      time_col = time_col,
      unit_col = unit_col,
      lookback_size = lookback_size,
      aggregate = aggregate,
      weighting = weighting,
      segment_col = segment_col,
      alpha = alpha,
      loess_span = loess_span,
      loess_degree = loess_degree,
      loess_family = loess_family,
      post_norm = post_norm,
      verbose = verbose
    ))
  }

  results <- vector("list", length(methods))
  names(results) <- methods
  for (m in methods) {
    results[[m]] <- .run_door_method(
      data = data,
      method = m,
      pair_cols = pair_cols,
      time_col = time_col,
      unit_col = unit_col,
      lookback_size = lookback_size,
      aggregate = aggregate,
      weighting = weighting,
      segment_col = segment_col,
      alpha = alpha,
      loess_span = loess_span,
      loess_degree = loess_degree,
      loess_family = loess_family,
      post_norm = post_norm,
      verbose = verbose
    )
  }
  results
}

# 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)
}

##' 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);
}

# Columns a rule compares to UNIT with `==` (either side, e.g.
# `GroupName == UNIT$GroupName` or `UNIT[["GroupName"]] == GroupName`).
unit_equality_columns <- function(expr) {
  unit_col <- function(e) {
    if (is.call(e) && length(e) == 3 &&
        (identical(e[[1]], as.name("$")) || identical(e[[1]], as.name("[["))) &&
        identical(e[[2]], as.name("UNIT"))) {
      return(as.character(e[[3]]));
    }
    NULL
  };
  found <- character(0);
  walk <- function(e) {
    if (is.expression(e) || is.list(e)) {
      for (el in e) walk(el);
    } else if (is.call(e)) {
      if (identical(e[[1]], as.name("==")) && length(e) == 3) {
        found <<- c(found, unit_col(e[[2]]), unit_col(e[[3]]));
      }
      for (arg in as.list(e)[-1]) walk(arg);
    }
  };
  walk(expr);
  unique(found)
}

##' 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;

  # UNIT$<col> holds every distinct value of <col> across the unit's rows, so
  # `col == UNIT$col` recycles when a unit spans several values and silently
  # selects the wrong rows. Warn (once per rule) when that happens.
  eq_unit_cols <- unit_equality_columns(hoo_args);
  warned <- FALSE;

  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);

    if (!warned && length(eq_unit_cols) > 0) {
      multi <- eq_unit_cols[lengths(UNIT[eq_unit_cols]) > 1];
      if (length(multi) > 0) {
        warned <<- TRUE;
        warning(sprintf(paste0(
          "Conversation rule compares %s to UNIT with `==`, but unit '%s' has ",
          "more than one value for it, so `==` recycles and selects the wrong ",
          "rows. Use `%%in%%` instead, e.g. `%s %%in%% UNIT$%s`."),
          paste0("`", multi, "`", collapse = ", "), unit_label, multi[1], multi[1]),
          call. = 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_
}

#' 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 each line's connection counts before they are summed per unit (unordered only; ordered counts are always summed raw). Ignored when `weight_by` is given.
#' @param weight_by Weight model applied to each line's connection counts before they are summed into the unit network (= rENA's `weight.by`): `"binary"` (unordered: each positive count becomes 1; ordered: raw directed counts), `"product"` (the raw, non-binarized counts), `"sqrt"`, or `"log1p"` (alias `"log"`). For unordered networks the weight is applied after each line is folded to the upper triangle; for ordered networks, to each directed cell. Defaults to `"binary"` when `binary = TRUE`, otherwise `"product"`. `model$row.connection.counts` always holds the raw, unweighted line counts.
#' @param misses Logical; if TRUE, also accumulate missed co-occurrences: for each response line, the (window-weighted) ground count of code i when code j is absent from the response, with no response self-term. Misses follow the connection counts through the same steps: ordered models keep the directed layout (ground i -> response j); unordered models fold each line to the upper triangle (i & j = i -> j + j -> i, self-misses dropped), and `weight_by` is applied per line. Defaults to TRUE; set FALSE to skip them (less memory for many codes or long data).
#' @param self_connections Logical, default FALSE. Unordered networks only: also include each code's self-connection (ground i x response i, weighted per line like the other columns) as a column of `connection.counts` (and of `miss.counts`, the self-misses), so the model's line weights, rotation and nodes include them. Columns then run A & A, A & B, B & B, A & C, ... (the upper triangle with the diagonal; see the adjacency key). Ordered networks always include the diagonal, so it has no effect there. `self.connection.counts` is kept separately either way.
#'
#' @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{self.connection.counts}{A data.table of each unit's self-connections, one column per code: each line's ground count of the code times its response count (the ordered network's diagonal, which unordered networks fold away), weighted per line by `weight_by` and summed per unit. Kept for ordered and unordered models; not used in the model.}
#'   \item{model$row.self.connection.counts}{A data.table of raw, unweighted per-line self-connections.}
#'   \item{miss.counts}{With `misses = TRUE`: a data.table of accumulated missed co-occurrences for each unit.}
#'   \item{self.miss.counts, model$row.self.miss.counts}{With `misses = TRUE`: self-misses (the code in the ground, absent from the response), per unit and per line, as for self-connections.}
#'   \item{model$row.miss.counts}{With `misses = TRUE`: a data.table of raw, unweighted row-level missed co-occurrences.}
#'   \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,
  weight_by = NULL,
  misses = TRUE,
  self_connections = FALSE
) {
  # Unordered only: ordered networks always carry the diagonal.
  diagonal <- isTRUE(self_connections) && !isTRUE(ordered)


  if (is.null(weight_by)) {
    weight_by <- if (isTRUE(binary)) "binary" else "product"
  }
  if (!is.character(weight_by) || length(weight_by) != 1) {
    stop("`weight_by` must be one of 'binary', 'product', 'sqrt', 'log1p'.")
  }

  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, diagonal = diagonal)
  ), 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

  # Levels along each tensor axis, in the order context_tensor() laid them out
  # (sorted unique values across the whole dataset), one entry per column of
  # `cols_to_encode`. A column with no tensor axis (the context-id placeholder
  # rENA passes as the mode column) gets NULL and its values pass through.
  cols_to_encode <- c(send_cols, recv_cols, mode_cols)
  tensor_levels  <- dimnames(tensor)
  axis_levels    <- c(
    lapply(seq_along(send_cols), function(i) tensor_levels[[paste0("sender_", i)]]),
    lapply(seq_along(recv_cols), function(i) tensor_levels[[paste0("receiver_", i)]]),
    lapply(seq_along(mode_cols), function(i) tensor_levels[["modes"]])
  )

  # Position of each row's value along its tensor axis (1-based). Looked up in
  # the tensor's own levels -- never re-encoded per context -- so a level maps
  # to the same slice of the tensor whichever levels a context happens to
  # contain, for character-valued and numeric columns alike.
  context_lookup <- function(ctx_rows) {
    lookup <- vapply(seq_along(cols_to_encode), function(i) {
      vals <- ctx_rows[[cols_to_encode[i]]]
      lv   <- axis_levels[[i]]
      if (is.null(lv)) return(as.numeric(vals))
      pos <- match(as.character(vals), lv)
      if (anyNA(pos)) {
        stop("Values in column '", cols_to_encode[i], "' are not levels of the ",
             "tensor: ", paste(unique(vals[is.na(pos)]), collapse = ", "),
             ". Build the tensor from the same data as the contexts.")
      }
      as.numeric(pos)
    }, numeric(nrow(ctx_rows)));
    matrix(lookup, nrow = nrow(ctx_rows), ncol = length(cols_to_encode))
  }

  # One libtma call per context (accumulate_unit_networks): it folds unordered
  # rows, applies the weight model per line, sums the lines and pulls out the
  # self-connection diagonal, for hits and (with misses) missed co-occurrences.
  # R only stacks the per-line rows into tables and adds up each unit's
  # per-context vectors (unit vectors are additive over lines).
  n_codes <- length(codes);
  result_cpp <- lapply(context_model$model$contexts, function(ctx) {
    ctx_fun <- function(ctx_o) {
      ctx__ <- data.table::copy(ctx_o);
      unit_context_lookup <- context_lookup(ctx__)

      unit_rows <- attr(ctx__, "tma.unit_rows")
      unit_to_last <- seq.int(last(unit_rows))
      ctx_unit_to_last <- ctx__[unit_to_last, ]
      res <- accumulate_unit_networks(
        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]],
        ordered = isTRUE(ordered),
        weight = weight_by,
        misses = isTRUE(misses),
        diagonal = diagonal
      )
      res$meta <- ctx_o[unit_rows, meta_cols, with = FALSE];
      res
    }

    if (is.data.frame(ctx)) list(ctx_fun(ctx)) else lapply(ctx, ctx_fun)
  });
  parts <- unlist(result_cpp, recursive = FALSE);

  conn_names <- if (isTRUE(ordered)) adj_vector_names_full else adj_vector_names;

  # Per-line rows: meta columns + one column per connection (or code), in QEID
  # order, as the row tables have always been laid out.
  row_table <- function(field, cols, table_class) {
    rows <- data.table::rbindlist(lapply(parts, function(pt) {
      m <- pt[[field]];
      dt <- data.table::as.data.table(matrix(m, nrow = nrow(m), dimnames = list(NULL, cols)));
      cbind(pt$meta, dt)
    }));
    rows <- reclass_columns(rows, rep(c("ena.metadata", "ena.co.occurrence"), c(length(meta_cols), length(cols))));
    data.table::setorderv(rows, "QEID");
    reclass(x = rows, table_class)
  };

  # Unit vectors: each unit's per-context vectors summed, units in the order
  # they first appear by QEID.
  unit_of <- vapply(parts, function(pt) as.character(pt$meta$QEUNIT[1]), character(1));
  first_qeid <- tapply(vapply(parts, function(pt) min(pt$meta$QEID), numeric(1)), unit_of, min);
  unit_order <- names(sort(first_qeid));
  unit_matrix <- function(field, cols) {
    m <- rowsum(do.call(rbind, lapply(parts, `[[`, field)), unit_of, reorder = FALSE);
    m <- m[unit_order, , drop = FALSE];
    colnames(m) <- cols;
    m
  };
  unit_first_meta <- function(by_cols) {
    first <- data.table::rbindlist(lapply(parts, `[[`, "meta"));
    data.table::setorderv(first, "QEID");
    first <- first[!duplicated(first$QEUNIT), ];
    first <- first[match(unit_order, as.character(first$QEUNIT)), by_cols, with = FALSE];
    first[, lapply(.SD, reclass, "ena.metadata"), .SDcols = by_cols]
  };

  row_connection_counts <- row_table("row_connection_counts", conn_names,
    if (isTRUE(ordered)) c("ordered.row.connections", "row.connections", "ena.matrix")
    else c("unordered.row.connections", "row.connections", "ena.matrix"));
  context_model$model$row.connection.counts <- row_connection_counts;

  # Column classes match the earlier aggregation: ordered unit sums keep the
  # ena.co.occurrence class, unordered ones are plain numerics; ordered tables
  # lead with the units_by columns, unordered with QEUNIT.
  unit_table <- function(field) {
    m <- unit_matrix(field, conn_names);
    vals <- lapply(seq_len(ncol(m)), function(j) {
      v <- unname(m[, j]);
      if (isTRUE(ordered)) reclass(v, "ena.co.occurrence") else v
    });
    names(vals) <- conn_names;
    cbind(unit_first_meta(if (isTRUE(ordered)) units_by else "QEUNIT"), data.table::as.data.table(vals))
  };

  cc_type <- NULL;
  if(isTRUE(ordered)) {
    class(context_model) <- c("ena.ordered.set", class(context_model));
    connection_counts <- reclass(x = unit_table("connection_counts"), c("ordered.ena.connections", "ena.connections", "ena.matrix"));
    cc_type <- "ordered.ena.connections";
  }
  else {
    class(context_model) <- c("ena.unordered.set", class(context_model));
    connection_counts <- unit_table("connection_counts");
    cc_type <- "unordered.ena.connections";
  }

  cc_meta <- data.table::rbindlist(lapply(result_cpp, function(rc) rc[[1]]$meta[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;

  # Self-connections: each line's ground i x response i (the ordered diagonal,
  # which unordered networks fold away), one column per code.
  self_table <- function(field) {
    m <- unit_matrix(field, codes);
    vals <- lapply(seq_len(ncol(m)), function(j) reclass(unname(m[, j]), "ena.co.occurrence"));
    names(vals) <- codes;
    reclass(cbind(cc_meta, data.table::as.data.table(vals)), c("self.connections", "ena.matrix"))
  };
  context_model$self.connection.counts <- self_table("self_connection_counts");
  context_model$model$row.self.connection.counts <- row_table("row_self_connection_counts", codes, c("row.self.connections", "ena.matrix"));

  if (isTRUE(misses)) {
    context_model$model$row.miss.counts <- row_table("row_miss_counts", conn_names,
      if (isTRUE(ordered)) c("ordered.row.connections", "row.connections", "ena.matrix")
      else c("unordered.row.connections", "row.connections", "ena.matrix"));
    miss_counts <- if (isTRUE(ordered))
      reclass(x = unit_table("miss_counts"), c("ordered.ena.connections", "ena.connections", "ena.matrix"))
    else unit_table("miss_counts");
    context_model$miss.counts <- reclass(cbind(cc_meta, miss_counts), c(cc_type, "ena.connections", "ena.matrix"));
    context_model$self.miss.counts <- self_table("self_miss_counts");
    context_model$model$row.self.miss.counts <- row_table("row_self_miss_counts", codes, c("row.self.connections", "ena.matrix"));
  }

  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;
  context_model$`_function.params`$weight_by   <- weight_by;
  context_model$`_function.params`$misses      <- isTRUE(misses);
  context_model$`_function.params`$self_connections <- diagonal;

  return(context_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 libtma 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()}.)
#' @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
  )
}

# =============================================================================
# tma_stability.R — Hyperparameter stability recommendation grid
# =============================================================================

#' Evaluate hyperparameter stability grid for door pooling
#'
#' Computes pairwise trajectory distance matrices across a grid of lookback sizes
#' or alpha values, then computes the matrix correlation between adjacent parameter
#' settings to find the "elbow" where trajectories stabilize.
#'
#' @param accum Object from \code{tma::accumulate()}.
#' @param unit_col Name of column identifying unit/speaker.
#' @param time_col Name of column identifying monotonic time.
#' @param param_type "lookback" or "ema".
#' @param param_values Numeric vector of parameter values to evaluate.
#' @param x_col Column name for x coordinate (default auto).
#' @param y_col Column name for y coordinate (default auto).
#' @param max_degree Polynomial degree for trajectory curves (default 3).
#' @return Data frame of parameter values and stability correlations.
#' @export
tma_stability_grid <- function(
    accum,
    unit_col,
    time_col,
    param_type = c("lookback", "ema"),
    param_values = NULL,
    x_col = NULL,
    y_col = NULL,
    max_degree = 3L) {
  param_type <- match.arg(param_type)

  if (is.null(param_values)) {
    param_values <- if (param_type == "lookback") {
      seq(5L, 50L, by = 5L)
    } else {
      seq(0.05, 0.5, by = 0.05)
    }
  }

  raw_df <- accum$model$row.connection.counts
  if (is.null(raw_df)) {
    raw_df <- accum$connection.counts
  }

  pair_cols <- cooccurrence_pair_column_names(raw_df)
  if (!length(pair_cols)) {
    stop("No co-occurrence columns found in accumulation.")
  }

  # Accumulate / replace door for each parameter value
  models <- lapply(param_values, function(pv) {
    d_df <- if (param_type == "lookback") {
      door(
        data = raw_df,
        method = "Lookback",
        unit_col = unit_col,
        time_col = time_col,
        lookback_size = as.integer(pv),
        verbose = FALSE
      )
    } else {
      door(
        data = raw_df,
        method = "EMA",
        unit_col = unit_col,
        time_col = time_col,
        alpha = as.numeric(pv),
        verbose = FALSE
      )
    }

    acc_mod <- replace_door(accum, d_df)
    acc_mod
  })

  # Compute stability correlations between adjacent parameter values
  n_params <- length(param_values)
  corrs <- numeric(n_params)
  corrs[1L] <- 1.0

  if (n_params > 1L) {
    for (i in 2:n_params) {
      m1 <- models[[i - 1L]]$connection.counts
      m2 <- models[[i]]$connection.counts

      # Select numeric connection columns
      c1 <- as.matrix(m1[, pair_cols, with = FALSE])
      c2 <- as.matrix(m2[, pair_cols, with = FALSE])

      corrs[i] <- libqe::dist_dist_correlation(c1, c2)
    }
  }

  data.frame(
    param = param_values,
    correlation = corrs,
    param_type = param_type,
    stringsAsFactors = FALSE
  )
}

# =============================================================================
# tma_trajectory.R — Trajectory curve fitting, derivatives, distance, and following
# =============================================================================

#' Fit polynomial parametric curve to ETM/TMA points normalized to t in [0, 1]
#'
#' @param pts data.frame or matrix of points
#' @param x_col Column name for x coordinate
#' @param y_col Column name for y coordinate
#' @param time_col Column name for time ordering
#' @param degree Fixed polynomial degree (optional)
#' @param max_degree Maximum degree to evaluate for LOOCV-2D (default 3)
#' @param criterion "loocv" or "aic"
#' @param fit_curve_with_zero_pts Logical; whether to retain (0,0) points
#' @param zero_eps Tolerance for detecting (0,0) points
#' @return List with fitted curve parameters, prediction closures, and metadata
#' @export
tma_fit_poly_curve <- function(
    pts,
    x_col = NULL,
    y_col = NULL,
    time_col = "RowID",
    degree = NULL,
    max_degree = 3L,
    criterion = c("loocv", "aic"),
    fit_curve_with_zero_pts = FALSE,
    zero_eps = 1e-8) {
  criterion <- match.arg(criterion)
  pts <- as.data.frame(pts)

  if (is.null(x_col) || !(x_col %in% names(pts))) {
    x_col <- intersect(c("SVD1", "MR1", "GMR1", "X1", "x"), names(pts))[1]
  }
  if (is.null(y_col) || !(y_col %in% names(pts))) {
    y_col <- intersect(c("SVD2", "MR2", "GMR2", "X2", "y"), names(pts))[1]
  }
  if (is.na(x_col) || is.na(y_col)) {
    stop("Cannot find dimension columns (SVD1/MR1/GMR1 and SVD2/MR2/GMR2) in pts.")
  }

  if (time_col %in% names(pts)) {
    pts <- pts[order(pts[[time_col]]), , drop = FALSE]
  }

  if (!isTRUE(fit_curve_with_zero_pts)) {
    keep <- (abs(pts[[x_col]]) > zero_eps) | (abs(pts[[y_col]]) > zero_eps)
    pts <- pts[keep, , drop = FALSE]
  }

  n <- nrow(pts)
  if (n < 2L) {
    stop("Need at least 2 non-zero points to fit a curve.")
  }

  points_mat <- as.matrix(pts[, c(x_col, y_col), drop = FALSE])
  fixed_deg <- if (!is.null(degree)) as.integer(degree) else 0L

  fit_res <- libqe::fit_trajectory_poly(
    points = points_mat,
    t = numeric(0),
    max_degree = as.integer(max_degree),
    fixed_degree = fixed_deg,
    criterion = criterion
  )

  coeffs_x <- fit_res$coeffs_x
  coeffs_y <- fit_res$coeffs_y

  pred_x <- function(t_new) {
    t_v <- as.numeric(t_new)
    res <- libqe::eval_trajectory_curve(coeffs_x, coeffs_y, t_v)
    res[, 1L]
  }

  pred_y <- function(t_new) {
    t_v <- as.numeric(t_new)
    res <- libqe::eval_trajectory_curve(coeffs_x, coeffs_y, t_v)
    res[, 2L]
  }

  structure(
    list(
      pred_x = pred_x,
      pred_y = pred_y,
      coeffs_x = coeffs_x,
      coeffs_y = coeffs_y,
      degree = fit_res$degree,
      cv_error = fit_res$cv_error,
      aic = fit_res$aic,
      t = fit_res$t,
      fitted_points = fit_res$fitted_points,
      n = n,
      x_col = x_col,
      y_col = y_col,
      time_col = time_col,
      pts = pts
    ),
    class = "tma_poly_curve"
  )
}

#' Evaluate analytical derivatives of a fitted polynomial curve
#'
#' @param curve Output of \code{tma_fit_poly_curve()}
#' @param n_eval Number of evaluation points in [0, 1]
#' @return Data frame of evaluated positions, velocity, speed, acceleration, heading turn rate, curvature
#' @export
tma_poly_derivative_profile <- function(curve, n_eval = 1000L) {
  if (is.null(curve$coeffs_x) || is.null(curve$coeffs_y)) {
    stop("`curve` must be a valid tma_poly_curve object.")
  }
  n_eval <- max(10L, as.integer(n_eval))
  t_eval <- seq(0, 1, length.out = n_eval)

  d <- libqe::eval_trajectory_derivatives(curve$coeffs_x, curve$coeffs_y, t_eval)

  # Also evaluate exact x and y coordinates
  pts <- libqe::eval_trajectory_curve(curve$coeffs_x, curve$coeffs_y, t_eval)

  data.frame(
    t = d$t,
    x = pts[, 1L],
    y = pts[, 2L],
    dx = d$vx,
    dy = d$vy,
    speed = d$speed,
    d2x = d$ax,
    d2y = d$ay,
    omega = d$heading_rate,
    kappa = d$curvature,
    stringsAsFactors = FALSE
  )
}

#' Locate critical points (heading turns, velocity zeros, inflections, curvature peaks)
#'
#' @param profile Output of \code{tma_poly_derivative_profile()}
#' @param speed_tol Minimum speed threshold for heading turns
#' @param zero_tol Numerical zero threshold
#' @param top_curvature Max curvature peaks to return
#' @return List of critical points
#' @export
tma_poly_critical_points <- function(
    profile,
    speed_tol = 1e-6,
    zero_tol = 1e-8,
    top_curvature = 5L) {

  .crossings <- function(t, z, x, y, label, speed = NULL, speed_tol = 1e-6) {
    n <- length(t)
    if (n < 3L) {
      return(data.frame(
        type = character(), t = numeric(), x = numeric(), y = numeric(),
        value = numeric(), stringsAsFactors = FALSE
      ))
    }
    rows <- list()
    for (i in seq_len(n - 1L)) {
      z1 <- z[i]; z2 <- z[i + 1L]
      if (is.na(z1) || is.na(z2)) next
      if (abs(z1) < zero_tol) z1 <- 0
      if (abs(z2) < zero_tol) z2 <- 0
      if (z1 == 0 && z2 == 0) next
      if (z1 * z2 > 0) next
      if (!is.null(speed) && (speed[i] < speed_tol || speed[i + 1L] < speed_tol)) next
      denom <- z2 - z1
      frac <- if (abs(denom) < 1e-15) 0.5 else (-z1) / denom
      frac <- min(max(frac, 0), 1)
      ti <- t[i] + frac * (t[i + 1L] - t[i])
      xi <- x[i] + frac * (x[i + 1L] - x[i])
      yi <- y[i] + frac * (y[i + 1L] - y[i])
      rows[[length(rows) + 1L]] <- data.frame(
        type = label, t = ti, x = xi, y = yi,
        value = 0,
        stringsAsFactors = FALSE
      )
    }
    if (!length(rows)) {
      return(data.frame(
        type = character(), t = numeric(), x = numeric(), y = numeric(),
        value = numeric(), stringsAsFactors = FALSE
      ))
    }
    do.call(rbind, rows)
  }

  inner <- profile$t > 0 & profile$t < 1
  prof <- profile[inner, , drop = FALSE]

  heading_turns <- .crossings(
    prof$t, prof$omega, prof$x, prof$y, "heading_turn",
    speed = prof$speed, speed_tol = speed_tol
  )
  x_velocity_zeros <- .crossings(
    prof$t, prof$dx, prof$x, prof$y, "x_velocity_zero"
  )
  y_velocity_zeros <- .crossings(
    prof$t, prof$dy, prof$x, prof$y, "y_velocity_zero"
  )
  x_inflections <- .crossings(
    prof$t, prof$d2x, prof$x, prof$y, "x_second_deriv_zero"
  )
  y_inflections <- .crossings(
    prof$t, prof$d2y, prof$x, prof$y, "y_second_deriv_zero"
  )

  # Curvature peaks
  ak <- abs(prof$kappa)
  is_peak <- rep(FALSE, nrow(prof))
  if (nrow(prof) >= 3L) {
    for (i in 2:(nrow(prof) - 1L)) {
      if (prof$speed[i] < speed_tol) next
      if (ak[i] > ak[i - 1L] && ak[i] > ak[i + 1L]) is_peak[i] <- TRUE
    }
  }
  idx <- which(is_peak & prof$t > 0 & prof$t < 1)
  curvature_peaks <- if (length(idx) > 0L) {
    ord <- order(ak[idx], decreasing = TRUE)
    idx <- idx[ord]
    top_n <- min(length(idx), as.integer(top_curvature))
    idx <- idx[seq_len(top_n)]
    data.frame(
      type = "curvature_peak",
      t = prof$t[idx],
      x = prof$x[idx],
      y = prof$y[idx],
      value = prof$kappa[idx],
      stringsAsFactors = FALSE
    )
  } else {
    data.frame(
      type = character(), t = numeric(), x = numeric(), y = numeric(),
      value = numeric(), stringsAsFactors = FALSE
    )
  }

  list(
    heading_turns = heading_turns,
    x_velocity_zeros = x_velocity_zeros,
    y_velocity_zeros = y_velocity_zeros,
    x_inflections = x_inflections,
    y_inflections = y_inflections,
    curvature_peaks = curvature_peaks,
    all = rbind(
      heading_turns, x_velocity_zeros, y_velocity_zeros,
      x_inflections, y_inflections, curvature_peaks
    )
  )
}

#' Integrated Euclidean curve distance between two fitted trajectories
#'
#' @param curve_a First fitted trajectory
#' @param curve_b Second fitted trajectory
#' @param t_start Starting time in [0, 1]
#' @param t_end Ending time in [0, 1]
#' @return Distance value
#' @export
tma_curve_distance <- function(curve_a, curve_b, t_start = 0.0, t_end = 1.0) {
  libqe::integrated_trajectory_distance(
    curve_a$coeffs_x, curve_a$coeffs_y,
    curve_b$coeffs_x, curve_b$coeffs_y,
    as.numeric(t_start), as.numeric(t_end)
  )
}

#' Integrated lagged Euclidean distance between two fitted trajectories
#'
#' @param curve_a First trajectory
#' @param curve_b Second trajectory
#' @param lag Normalized time lag in [0, 1)
#' @param direction "a_follows_b", "b_follows_a", or "symmetric"
#' @return List with distance metrics
#' @export
tma_curve_distance_lag <- function(
    curve_a,
    curve_b,
    lag = 0.0,
    direction = c("a_follows_b", "b_follows_a", "symmetric")) {
  direction <- match.arg(direction)
  lag <- as.numeric(lag)[1L]
  if (lag < 0 || lag >= 1) {
    return(list(D = NA_real_, lag = lag, direction = direction))
  }

  d_ab <- libqe::lagged_trajectory_distance(
    curve_a$coeffs_x, curve_a$coeffs_y,
    curve_b$coeffs_x, curve_b$coeffs_y,
    lag
  )

  d_ba <- libqe::lagged_trajectory_distance(
    curve_b$coeffs_x, curve_b$coeffs_y,
    curve_a$coeffs_x, curve_a$coeffs_y,
    lag
  )

  d_val <- switch(
    direction,
    a_follows_b = d_ab,
    b_follows_a = d_ba,
    symmetric = mean(c(d_ab, d_ba))
  )

  list(
    lag = lag,
    direction = direction,
    D = d_val,
    D_a_follows_b = d_ab,
    D_b_follows_a = d_ba
  )
}

#' Discrete turn-lag distance between point sets of two conversants
#'
#' @param pts_a ETM point rows for agent A
#' @param pts_b ETM point rows for agent B
#' @param x_col Column name for x coordinate
#' @param y_col Column name for y coordinate
#' @param time_col Column name for turn index / timestamp
#' @param delta Signed integer turn lag
#' @return List with mean_distance and valid_count
#' @export
tma_signed_turn_lag <- function(
    pts_a,
    pts_b,
    x_col = "MR1",
    y_col = "MR2",
    time_col = "index",
    delta = 0L) {
  pa <- as.matrix(pts_a[, c(x_col, y_col)])
  pb <- as.matrix(pts_b[, c(x_col, y_col)])
  ta <- as.numeric(pts_a[[time_col]])
  tb <- as.numeric(pts_b[[time_col]])

  libqe::signed_turn_lag(pa, pb, ta, tb, as.integer(delta))
}

#' Discrete turn-lag optimization sweep across signed lags
#'
#' @param pts_a ETM point rows for agent A
#' @param pts_b ETM point rows for agent B
#' @param x_col Column name for x coordinate
#' @param y_col Column name for y coordinate
#' @param time_col Column name for turn index / timestamp
#' @param max_lag Max integer lag to sweep
#' @return List with best_lag, min_mean_distance, lags, and mean_distances
#' @export
tma_sweep_signed_turn_lags <- function(
    pts_a,
    pts_b,
    x_col = "MR1",
    y_col = "MR2",
    time_col = "index",
    max_lag = 15L) {
  pa <- as.matrix(pts_a[, c(x_col, y_col)])
  pb <- as.matrix(pts_b[, c(x_col, y_col)])
  ta <- as.numeric(pts_a[[time_col]])
  tb <- as.numeric(pts_b[[time_col]])

  libqe::sweep_signed_turn_lags(pa, pb, ta, tb, as.integer(max_lag))
}

#' Distance-distance Pearson correlation between two coordinate configurations
#'
#' @param X Matrix of coordinates 1
#' @param Y Matrix of coordinates 2
#' @return Pearson correlation r in [-1, 1]
#' @export
tma_dist_dist_correlation <- function(X, Y) {
  libqe::dist_dist_correlation(as.matrix(X), as.matrix(Y))
}

#' Adjacency Key
#'
#' @param codes character vector
#' @param upper logical, default, TRUE, returns the key for the upper triangle, FALSE - not implemented yet
#' @param diagonal logical, default FALSE. With \code{upper}, include the
#'   diagonal (self-connections): columns A & A, A & B, B & B, A & C, ... (the
#'   column-major upper triangle, as libqe's \code{connection_names(codes, TRUE)}).
#'
#' @export
#'
#' @return matrix
adjacency_key <- function(codes, upper = TRUE, diagonal = FALSE) {
  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)), diag = isTRUE(diagonal)));
    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 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))
  }
}

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		}

#' 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)
}

.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__"
)

/** @file accumulation.hpp
 *  @brief Accumulation primitives shared between the rENA stanza-window model
 *         and the tma ground/response/tensor model.
 *
 *  Both models reduce to the same core connection_matrix() operation; they
 *  differ in how ground and response vectors are assembled from the raw data.
 */
#ifndef LIBQE_ACCUMULATION_HPP
#define LIBQE_ACCUMULATION_HPP

#include <algorithm>
#include <armadillo>
#include <cctype>
#include <cmath>
#include <functional>
#include <stdexcept>
#include <string>
#include <vector>
#include <libqe/adjacency.hpp>

namespace qe {

/// @name Core adjacency math
/// @{

/** @brief Compute the connection matrix for one ground + response event pair.
 *
 *  @param[in] ground          Row vector of accumulated ground codes (length p).
 *  @param[in] response        Row vector of the focal (response) codes (length p).
 *  @param[in] response_weight Scalar weight applied to the response self-connection
 *                             term.  Defaults to 1.0.
 *  @param[in] ordered         When @c true, produces a directed (asymmetric) matrix:
 *                             @c ground→response cross-product plus
 *                             @c 0.5 * response_weight * response self-connection
 *                             (diagonal zeroed).
 *                             When @c false, produces a symmetric undirected matrix:
 *                             @c (response_weight * r⊗r) + g⊗r + r⊗g.
 *
 *  @returns A p × p connection matrix.
 *
 *  @note Equivalent to @c calculate_adjacency_matrix() in @c tma/code.cpp.
 */
inline arma::mat connection_matrix(
    arma::rowvec ground, arma::rowvec response,
    double response_weight = 1.0, bool ordered = true
) {
    arma::mat resp_self = response.t() * response;
    arma::mat g_by_r   = ground.t() * response;

    if (ordered) {
        resp_self.diag().zeros();
        return g_by_r + (0.5 * response_weight * resp_self);
    }
    return (response_weight * resp_self) + g_by_r + (response.t() * ground);
}

/// @}

/// @name Traditional stanza-window accumulation (rENA model)
/// @{

/** @brief Accumulate connection vectors for every row in one conversation using
 *         a stanza window.
 *
 *  For each focal row @c k in @p codes the function assembles a ground context
 *  from the surrounding window and calls connection_matrix().
 *
 *  @par Ordering semantics
 *  - @b Undirected (@p ordered = @c false, default — rENA stanza model): the
 *    window spans [@c k - window_back, @c k + window_forward]; the upper-triangle
 *    outer-product (code_connections) is computed and back/forward-reference
 *    corrections are subtracted.  Returns a matrix of shape
 *    @c n_rows × choose_two(n_codes).
 *  - @b Directed (@p ordered = @c true): focal row @c k is the response; the
 *    sum of prior rows [@c earliest, @c k−1] is the ground.
 *    connection_matrix() is called with @p ordered = @c true and the result is
 *    vectorised.  @p window_forward is ignored (future rows cannot be causal
 *    ground context).  Returns a matrix of shape @c n_rows × n_codes².
 *
 *  @param[in] codes          Code matrix for one conversation (n_rows × n_codes).
 *  @param[in] window_back    Number of prior rows included in the window
 *                            (1 = current row only; INT_MAX = all prior rows).
 *  @param[in] window_forward Number of future rows included in the window
 *                            (ignored when @p ordered is @c true).
 *  @param[in] binary         When @c true, clamp all positive entries to 1.
 *  @param[in] ordered        When @c true, use directed accumulation; when
 *                            @c false, use undirected stanza-window accumulation.
 *
 *  @returns Connection matrix (n_rows × connection_vector_length) where
 *           connection_vector_length is choose_two(n_codes) for undirected or
 *           n_codes² for directed.
 *
 *  @note Equivalent to @c ref_window_df() in @c rENA/ena.cpp (undirected case).
 */
inline arma::mat accumulate_stanza(
    arma::mat codes,
    int window_back    = 1,
    int window_forward = 0,
    bool binary        = true,
    bool ordered       = false
) {
    int n_rows  = codes.n_rows;
    int n_codes = codes.n_cols;
    const int INT_MAX_VAL = std::numeric_limits<int>::max();

    // Shared helper: earliest row index for focal row k
    auto get_earliest = [&](int row) -> int {
        if (window_back == INT_MAX_VAL || window_back == 0)
            return (window_back == 0) ? row : 0;
        return std::max(0, row - (window_back - 1));
    };

    if (ordered) {
        arma::mat out(n_rows, n_codes * n_codes, arma::fill::zeros);
        for (int row = 0; row < n_rows; row++) {
            int earliest = get_earliest(row);
            arma::rowvec response = codes.row(row);
            arma::rowvec ground(n_codes, arma::fill::zeros);
            if (row > earliest)
                ground = arma::sum(codes.rows(earliest, row - 1));
            out.row(row) = arma::vectorise(
                connection_matrix(ground, response, 1.0, true)).t();
        }
        if (binary) out.elem(arma::find(out > 0)).ones();
        return out;
    }

    // Undirected: existing rENA stanza-window logic
    int n_tri = choose_two(n_codes);
    arma::mat out(n_rows, n_tri, arma::fill::zeros);

    for (int row = 0; row < n_rows; row++) {
        int earliest = get_earliest(row);

        int latest = row;
        if (window_forward == INT_MAX_VAL || row + window_forward >= n_rows) {
            latest = n_rows - 1;
        } else if (window_forward > 0) {
            latest = std::min(n_rows - 1, row + window_forward);
        }

        arma::mat window_rows = codes.rows(earliest, latest);
        arma::mat summed      = arma::sum(window_rows);
        arma::rowvec to_ut    = code_connections(summed);

        // Back-reference correction
        int win_rows  = latest - earliest + 1;
        if (win_rows > 0 && window_back > 1 && row - 1 >= 0) {
            int head_rows = win_rows - 1 - window_forward;
            if (head_rows > 0) {
                arma::mat refs    = window_rows.head_rows(head_rows);
                arma::mat ref_sum = arma::sum(refs);
                to_ut -= code_connections(ref_sum);
            }
        }

        // Forward-reference correction
        if (window_forward > 0 && latest <= n_rows - 1) {
            int tail_rows = latest - row;
            if (tail_rows > 0) {
                arma::mat refs    = window_rows.tail_rows(tail_rows);
                arma::mat ref_sum = arma::sum(refs);
                to_ut -= code_connections(ref_sum);
            }
        }

        out.row(row) = to_ut;
    }

    if (binary) out.elem(arma::find(out > 0)).ones();
    return out;
}

/// @}

/// @name Ground/response accumulation (tma model)
/// @{

/** @brief Accumulate connections for a single unit from its context rows.
 *
 *  For every response row belonging to this unit, the function computes a
 *  weighted ground vector from all preceding context rows and calls
 *  connection_matrix().
 *
 *  @par Ordering semantics
 *  The connections are always accumulated directed (ground → response, as
 *  accumulate_unit_networks() does).  When @p ordered is @c false (default),
 *  that directed sum is folded once into the upper-triangle representation
 *  (length choose_two(p)); when @c true, the directed p² vector is returned.
 *  (Building the undirected connection_matrix() and then folding it would
 *  count every connection twice.)
 *
 *  @param[in] codes      Full context matrix visible to this unit (n × p).
 *  @param[in] unit_rows  0-based indices of the rows that belong to this unit.
 *  @param[in] decay_fn   Callback with signature
 *                        @c arma::vec(arma::vec distances) that maps a vector
 *                        of distances (0 = current row, 1 = one step back, …)
 *                        to a vector of scalar weights; default behaviour is a
 *                        simple rectangular window.
 *  @param[in] ordered    When @c true, return a directed flat vector (length p²);
 *                        when @c false, return an undirected upper-triangle flat
 *                        vector (length choose_two(p)).
 *
 *  @returns Flat connection vector of length choose_two(p) (undirected) or p²
 *           (directed).
 *
 *  @note Equivalent to @c accumulate_network() in @c tma/code.cpp, with the R
 *        function callback replaced by @c std::function.
 */
inline arma::rowvec accumulate_unit(
    const arma::mat& codes,
    const std::vector<int>& unit_rows,
    std::function<arma::vec(arma::vec)> decay_fn,
    bool ordered = false
) {
    int code_cnt = codes.n_cols;
    arma::mat g_w_vec(code_cnt, code_cnt, arma::fill::zeros);

    for (int unit_row : unit_rows) {
        if (unit_row == 0) continue;

        arma::rowvec response = codes.row(unit_row);

        // Ground rows: everything from 0 up to (and including) unit_row
        arma::uvec ground_indices = arma::regspace<arma::uvec>(0, 1, unit_row);
        arma::vec  distances(ground_indices.n_elem);
        for (arma::uword k = 0; k < ground_indices.n_elem; k++)
            distances[k] = static_cast<double>(unit_row - ground_indices[k]);

        arma::vec decay_weights = decay_fn(distances);

        arma::mat ground_codes   = codes.rows(ground_indices);
        arma::mat weighted       = ground_codes.each_col() % decay_weights;
        arma::rowvec g_summed    = arma::sum(weighted);

        // Exclude the response row's own contribution from the ground
        arma::rowvec g_no_resp   = g_summed - weighted.tail_rows(1).row(0);

        // Directed always; the fold below makes it undirected exactly once.
        g_w_vec += connection_matrix(g_no_resp, response, 1.0, /*ordered=*/true);
    }

    if (!ordered) return fold_directed_network(arma::vectorise(g_w_vec));
    return arma::vectorise(g_w_vec).t();
}

/// @}

/// @name Extended ground/response accumulation — returns per-row connection data
/// @{

/** @brief Result of accumulate_unit_with_rows().
 *
 *  Bundles the unit-level flat connection vector together with the per-response-row
 *  full p² connection matrices needed by tma's @c accumulate_network().
 */
struct UnitNetworks {
    arma::rowvec networks;      ///< Flat connection vector (choose_two(p) or p²).
    arma::mat    row_networks;  ///< Per-response-row directed p² matrix (n_unit_rows × p²), whatever @c ordered.
};

/** @brief Like accumulate_unit() but also returns the per-response-row connection
 *         matrix needed by tma's @c accumulate_network().
 *
 *  @param[in] codes      Full context matrix visible to this unit (n × p).
 *  @param[in] unit_rows  0-based indices of the rows that belong to this unit.
 *  @param[in] decay_fn   Callback with signature
 *                        @c arma::vec(int unit_row, arma::uvec ground_indices)
 *                        that returns a weight vector of length
 *                        @c ground_indices.n_elem.  The two-argument form lets
 *                        callers (e.g. the tma Rcpp wrapper) set R environment
 *                        variables before invoking the actual R decay function,
 *                        without any R-specific code leaking into libqe.
 *  @param[in] ordered    When @c true, @c networks is the directed flat vector
 *                        (length p²); when @c false, the directed sum folded
 *                        once to the undirected upper triangle (length
 *                        choose_two(p)).  @c row_networks are always directed.
 *
 *  @returns A UnitNetworks struct containing the aggregated connection vector
 *           and the per-response-row connection matrices.
 *
 *  @note Equivalent to @c accumulate_network() in @c tma/code.cpp (extended form).
 */
inline UnitNetworks accumulate_unit_with_rows(
    const arma::mat&                              codes,
    const std::vector<int>&                       unit_rows,
    std::function<arma::vec(int, arma::uvec)>     decay_fn,
    bool ordered = false
) {
    int code_cnt    = codes.n_cols;
    int n_unit_rows = unit_rows.size();

    arma::mat g_w_mat(code_cnt, code_cnt, arma::fill::zeros);
    arma::mat row_networks(n_unit_rows, code_cnt * code_cnt, arma::fill::zeros);

    for (int i = 0; i < n_unit_rows; ++i) {
        int unit_row = unit_rows[i];

        arma::uvec ground_indices = arma::regspace<arma::uvec>(0, 1, unit_row);
        arma::vec  decay_weights  = decay_fn(unit_row, ground_indices);

        arma::mat    ground_codes = codes.rows(ground_indices);
        arma::mat    weighted     = ground_codes.each_col() % decay_weights;
        arma::rowvec g_summed     = arma::sum(weighted);
        arma::rowvec g_no_resp    = g_summed - weighted.tail_rows(1).row(0);

        arma::rowvec response = codes.row(unit_row);
        // Directed always; the fold below makes it undirected exactly once.
        arma::mat    conn     = connection_matrix(g_no_resp, response, 1.0, /*ordered=*/true);
        g_w_mat += conn;
        row_networks.row(i) = arma::vectorise(conn).t();
    }

    UnitNetworks result;
    if (!ordered)
        result.networks = fold_directed_network(arma::vectorise(g_w_mat));
    else
        result.networks = arma::vectorise(g_w_mat).t();
    result.row_networks = row_networks;
    return result;
}

/// @}

/// @name Tensor-based multi-modal accumulation (tma model)
/// @{

/** @brief Compute the linear index into a column-major multi-dimensional array.
 *
 *  @param[in] indices  Per-dimension index values (0-based).
 *  @param[in] dims     Size of each dimension.
 *
 *  @returns The scalar column-major flat index.
 *
 *  @note Equivalent to @c flat_index() in @c tma/code.cpp.
 */
inline int flat_index(const std::vector<int>& indices,
                               const std::vector<int>& dims) {
    if (indices.size() != dims.size())
        throw std::invalid_argument("Number of indices must match number of dimensions.");
    size_t linear = 0, stride = 1;
    for (size_t v = 0; v < indices.size(); ++v) {
        if (dims[v] <= 0 || indices[v] < 0 || indices[v] >= dims[v])
            throw std::out_of_range("Tensor index out of range for its dimension.");
        linear += static_cast<size_t>(indices[v]) * stride;
        stride *= static_cast<size_t>(dims[v]);
    }
    return static_cast<int>(linear);
}

/** @brief Result of apply_tensor_unit().
 *
 *  Bundles the unit-level aggregated connection vector together with the
 *  per-response-row connection matrices used by the tma tensor accumulation.
 */
struct TensorNetworks {
    arma::rowvec connection_counts;      ///< Unit-level flat vector (p²).
    arma::mat    row_connection_counts;  ///< Per-response-row connection matrix (n_unit_rows × p²).
    /// Per-response-row in-window ground rows (0-based context indices), visited
    /// order (ri-1 .. 0). Populated only when apply_tensor_unit() is called with
    /// return_members = true; empty otherwise. Feeds the webtool Data View
    /// window-span hover (tma design dataview-flexible-window.md).
    std::vector<std::vector<int>>    row_window_members;
    /// Per-response-row resolved window size for each member above (parallel to
    /// row_window_members). Populated only when return_members = true.
    std::vector<std::vector<double>> row_window_wins;
    /// Unit-level missed co-occurrences (p², directed): Σ over response rows of
    /// miss_matrix(). Populated only when return_misses = true; empty otherwise.
    arma::rowvec miss_counts;
    /// Per-response-row missed co-occurrences (n_unit_rows × p², directed).
    /// Populated only when return_misses = true; empty otherwise.
    arma::mat    row_miss_counts;
};

/** @brief Missed co-occurrences for one ground + response event pair.
 *
 *  The counterpart of connection_matrix()'s ground→response term: entry
 *  (i, j) is the ground weight of code @c i when code @c j is @em absent from
 *  the response, i.e. @c ground.t() * [response == 0].  Laid out like the
 *  ordered connection matrix (ground i → response j at @c j*p+i once
 *  vectorised), with no response self-term.  Unordered networks fold it the
 *  same way as connections (finalize_row_connections() /
 *  aggregate_row_connections()).
 *
 *  @param[in] ground    Row vector of accumulated (weighted) ground codes (length p).
 *  @param[in] response  Row vector of the response codes (length p).
 *
 *  @returns A p × p missed-co-occurrence matrix.
 */
inline arma::mat miss_matrix(const arma::rowvec& ground, const arma::rowvec& response) {
    arma::rowvec absent = arma::conv_to<arma::rowvec>::from(response == 0);
    return ground.t() * absent;
}

/** @brief Pure-C++ port of the tma @c apply_tensor() inner logic.
 *
 *  For each response row in @p unit_rows, the function looks up window and
 *  weight values from the tensor, collects all ground rows that fall within the
 *  response row's window, and calls connection_matrix() to accumulate the
 *  connection counts.
 *
 *  @param[in] tensor          Flat column-major array containing window and
 *                             weight values indexed by the factor dimensions.
 *  @param[in] dims            Sizes of each dimension of @p tensor.
 *  @param[in] dims_sender     Tensor axis indices corresponding to sender factors.
 *  @param[in] dims_receiver   Tensor axis indices corresponding to receiver
 *                             factors; these axes are overridden to the response
 *                             row's values when looking up window sizes for
 *                             ground rows.
 *  @param[in] dims_mode       Tensor axis indices corresponding to mode factors.
 *  @param[in] context_lookup  Integer matrix (n_context_rows × n_factors, 0-based)
 *                             mapping each context row to its factor level indices.
 *  @param[in] unit_rows       0-based response-row indices for this unit.
 *  @param[in] codes           Full context code matrix (n_context_rows × n_codes).
 *  @param[in] times           Timestamp associated with each context row
 *                             (length n_context_rows).
 *  @param[in] ordered         When @c true, produce a directed full p² result;
 *                             when @c false, produce an undirected upper-triangle
 *                             result.
 *  @param[in] return_members  When @c true, also record each response row's
 *                             in-window ground rows and window sizes.
 *  @param[in] return_misses   When @c true, also compute missed co-occurrences
 *                             (see miss_matrix()) from the same ground vector.
 *                             Rows are directed p², like row_connection_counts;
 *                             @c miss_counts is their unfolded sum.
 *
 *  @returns A TensorNetworks struct containing the unit-level connection counts
 *           and the per-response-row connection counts (plus misses / window
 *           members when requested).
 *
 *  @note Equivalent to the inner loop of @c apply_tensor() in @c tma/code.cpp.
 */
inline TensorNetworks apply_tensor_unit(
    const arma::vec&        tensor,
    const std::vector<int>& dims,
    const std::vector<int>& dims_sender,
    const std::vector<int>& dims_receiver,
    const std::vector<int>& dims_mode,
    const arma::imat&       context_lookup,
    const std::vector<int>& unit_rows,
    const arma::mat&        codes,
    const arma::vec&        times,
    bool ordered = true,
    bool return_members = false,
    bool return_misses = false
) {
    const int  WINDOW_DIM  = 1;
    const int  WEIGHT_DIM  = 0;
    const bool IS_DEFAULT  = (dims.size() == 1 && dims[0] == 2);

    int code_cnt    = codes.n_cols;
    int n_unit_rows = static_cast<int>(unit_rows.size());
    int ctx_cols    = static_cast<int>(context_lookup.n_cols);

    // Validate shapes up front: tensor[] and times[] are unchecked below, and
    // the bindings (WASM in particular) pass these straight from callers.
    {
        size_t tensor_len = 1;
        for (int d : dims) {
            if (d <= 0) throw std::invalid_argument("tensor dims must be positive");
            tensor_len *= static_cast<size_t>(d);
        }
        if (tensor_len != tensor.n_elem)
            throw std::invalid_argument("tensor length does not match the product of dims");
        if (!IS_DEFAULT && dims.size() != static_cast<size_t>(ctx_cols) + 1)
            throw std::invalid_argument("dims must have one entry per context column plus one");
        const arma::uword n_rows = codes.n_rows;
        if (times.n_elem < n_rows || (ctx_cols > 0 && context_lookup.n_rows < n_rows))
            throw std::invalid_argument("times and context_lookup must cover every code row");
        for (int ri : unit_rows)
            if (ri < 0 || static_cast<arma::uword>(ri) >= n_rows)
                throw std::out_of_range("unit row index out of range");
        for (int dim : dims_receiver)
            if (dim < 0 || dim > ctx_cols)
                throw std::out_of_range("receiver dimension out of range");
    }

    arma::mat g_w_mat(code_cnt, code_cnt, arma::fill::zeros);
    arma::mat row_conn(n_unit_rows, code_cnt * code_cnt, arma::fill::zeros);
    arma::mat row_miss;
    if (return_misses) row_miss.zeros(n_unit_rows, code_cnt * code_cnt);

    std::vector<std::vector<int>>    members_all;
    std::vector<std::vector<double>> wins_all;
    if (return_members) { members_all.reserve(n_unit_rows); wins_all.reserve(n_unit_rows); }

    int response_win    = 0;
    int response_weight = 0;
    if (IS_DEFAULT) {
        response_win    = static_cast<int>(tensor[1]);
        response_weight = static_cast<int>(tensor[0]);
    }

    for (int i = 0; i < n_unit_rows; ++i) {
        int    ri            = unit_rows[i];
        double response_time = times[ri];

        std::vector<int> resp_ctx(ctx_cols + 1);
        for (int j = 0; j < ctx_cols; ++j) resp_ctx[j] = context_lookup(ri, j);
        resp_ctx[ctx_cols] = WINDOW_DIM;

        if (!IS_DEFAULT)
            response_win = static_cast<int>(tensor[flat_index(resp_ctx, dims)]);

        std::vector<int>    gri_v;
        std::vector<double> grw_v;
        std::vector<double> grwin_v;
        arma::rowvec g_ws(code_cnt, arma::fill::zeros);

        if (ri > 0) {
            for (int gr = ri - 1; gr >= 0; --gr) {
                std::vector<int> row_v(ctx_cols + 1);
                for (int j = 0; j < ctx_cols; ++j) row_v[j] = context_lookup(gr, j);
                row_v[ctx_cols] = WINDOW_DIM;
                for (int dim : dims_receiver) row_v[dim] = resp_ctx[dim];

                double row_win = static_cast<double>(response_win);
                if (!IS_DEFAULT)
                    row_win = tensor[flat_index(row_v, dims)];

                if (times[gr] + row_win > response_time) {
                    gri_v.push_back(gr);
                    if (return_members) grwin_v.push_back(row_win);
                    row_v[ctx_cols] = WEIGHT_DIM;
                    double row_wgt = static_cast<double>(response_weight);
                    if (!IS_DEFAULT)
                        row_wgt = tensor[flat_index(row_v, dims)];
                    grw_v.push_back(row_wgt);
                }
            }

            if (!gri_v.empty()) {
                arma::uvec gri_u(gri_v.size());
                for (size_t k = 0; k < gri_v.size(); ++k) gri_u[k] = gri_v[k];
                arma::mat    gc  = codes.rows(gri_u);
                arma::colvec wts = arma::conv_to<arma::colvec>::from(grw_v);
                g_ws = arma::sum(gc.each_col() % wts, 0);
            }
        }

        if (!IS_DEFAULT) {
            resp_ctx[ctx_cols] = WEIGHT_DIM;
            response_weight = static_cast<int>(tensor[flat_index(resp_ctx, dims)]);
        }

        arma::rowvec row_vec = codes.row(ri);
        arma::mat resp = connection_matrix(
            g_ws, row_vec, static_cast<double>(response_weight), ordered);
        g_w_mat += resp;
        row_conn.row(i) = arma::vectorise(resp).t();
        if (return_misses)
            row_miss.row(i) = arma::vectorise(miss_matrix(g_ws, row_vec)).t();

        if (return_members) {
            members_all.push_back(std::move(gri_v));
            wins_all.push_back(std::move(grwin_v));
        }
    }

    TensorNetworks result;
    result.connection_counts     = arma::vectorise(g_w_mat).t();
    result.row_connection_counts = row_conn;
    if (return_members) {
        result.row_window_members = std::move(members_all);
        result.row_window_wins    = std::move(wins_all);
    }
    if (return_misses) {
        result.miss_counts     = arma::sum(row_miss, 0);
        result.row_miss_counts = std::move(row_miss);
    }
    return result;
}

/// @name Weight models (per-line co-occurrence transforms, = rENA's weight.by)
/// @{

/** @brief Transform applied to each line's connection counts before the
 *         per-unit sum.
 *
 *  Every model applies its weight at the same stage: after a response row's
 *  connection counts are computed (and, for unordered networks, folded to the
 *  upper triangle), and before rows are summed into the unit network. This is
 *  the stage legacy rENA applies @c weight.by (accumulate.data.R). Because
 *  sqrt(Σ) ≠ Σ sqrt, the transform must never be applied to unit totals.
 *
 *  - @c Binary  — unordered: clamp each positive count to 1 (presence).
 *                 Ordered: raw directed counts, unchanged — the established
 *                 behaviour of every ordered/ONA model (tma ignores binary).
 *  - @c Product — the non-binarized counts themselves ("summed cross
 *                 products" of the response row with its window).
 *  - @c Sqrt    — sqrt of each line's product count.
 *  - @c Log1p   — log(1 + x) of each line's product count.
 */
enum class WeightModel { Binary, Product, Sqrt, Log1p };

/** @brief Parse a weight-model name (case-insensitive).
 *
 *  Accepts @c "binary", @c "product", @c "sqrt", @c "log1p" and the alias
 *  @c "log" (rena-wasm's name for log1p).
 *  @throws std::invalid_argument for any other name.
 */
inline WeightModel weight_model_from_string(const std::string& name) {
    std::string s;
    s.reserve(name.size());
    for (char c : name) s += static_cast<char>(std::tolower(static_cast<unsigned char>(c)));

    if (s == "binary")               return WeightModel::Binary;
    if (s == "product")              return WeightModel::Product;
    if (s == "sqrt")                 return WeightModel::Sqrt;
    if (s == "log1p" || s == "log")  return WeightModel::Log1p;
    throw std::invalid_argument(
        "Unknown weight model '" + name + "'; expected one of "
        "'binary', 'product', 'sqrt', 'log1p'.");
}

/** @brief Map the legacy @c binary flag to a weight model
 *         (@c true → Binary, @c false → Product). */
inline WeightModel weight_model_from_bool(bool binary) {
    return binary ? WeightModel::Binary : WeightModel::Product;
}

/** @brief Apply a weight model in place to one line's connection vector. */
inline void apply_weight_model(arma::rowvec& v, WeightModel weight, bool ordered) {
    switch (weight) {
        case WeightModel::Binary:
            if (!ordered) v.elem(arma::find(v > 0)).ones();
            break;
        case WeightModel::Product:
            break;
        case WeightModel::Sqrt:
            v.transform([](double x) { return std::sqrt(x); });
            break;
        case WeightModel::Log1p:
            v.transform([](double x) { return std::log1p(x); });
            break;
    }
}

/// @}

/** @brief Finalise each per-response-row tensor connection vector.
 *
 *  The per-line step of tma's R aggregation of @c apply_tensor_unit()'s
 *  @c row_connection_counts (tma/R/accum_multidim_c.R), before any summing:
 *  unordered rows are folded to the upper triangle (@c as.unordered), then the
 *  weight model is applied; ordered rows keep the directed p² layout and have
 *  the weight model applied per cell.
 *
 *  Returned per row so callers can expose line-level connection counts
 *  (= R's @c model$row.connection.counts); summing the rows gives
 *  aggregate_row_connections().
 *
 *  @param[in] row_conn  Per-response-row directed connection matrix
 *                       (n_response_rows × p²), i.e.
 *                       @c TensorNetworks::row_connection_counts.
 *  @param[in] n_codes   Number of codes @c p.
 *  @param[in] ordered   @c true keeps directed p² rows; @c false folds each row
 *                       to @c choose_two(p).
 *  @param[in] weight    Per-line weight model (see WeightModel).
 *  @param[in] diagonal  Unordered only: keep self-connections in the folded
 *                       rows (libqe @c fold_directed_network with diagonal:
 *                       A & A, A & B, B & B, ...).  Ordered rows always
 *                       carry the diagonal.  Default @c false.
 *
 *  @returns Matrix of shape n_response_rows × p² (ordered) or
 *           n_response_rows × @c n_connections(p, diagonal) (unordered).
 */
inline arma::mat finalize_row_connections(
    const arma::mat& row_conn,
    int         n_codes,
    bool        ordered,
    WeightModel weight,
    bool        diagonal = false
) {
    const int n_rows = static_cast<int>(row_conn.n_rows);
    const int n_out  = ordered ? n_codes * n_codes : n_connections(n_codes, diagonal);
    arma::mat out(n_rows, n_out, arma::fill::zeros);

    for (int r = 0; r < n_rows; ++r) {
        arma::rowvec v = ordered
            ? arma::rowvec(row_conn.row(r))
            : fold_directed_network(arma::vectorise(row_conn.row(r)), diagonal);
        apply_weight_model(v, weight, ordered);
        out.row(r) = v;
    }
    return out;
}

/** @brief Aggregate per-response-row tensor connections into a unit vector.
 *
 *  Finalises each response row (fold + weight model, see
 *  finalize_row_connections()) and sums the rows — tma's R aggregation
 *  (@c as.unordered + @c colSums.ena.matrix), with the weight model applied at
 *  the same per-line stage legacy rENA applies @c weight.by.
 *
 *  This is the aggregation step tma performs in R; libqe's @c apply_tensor_unit
 *  intentionally returns the raw per-row matrix so callers can compose it.
 *  Kept as a standalone kernel function so the fold/weight/sum semantics live
 *  in one place shared by every binding, instead of being re-implemented in each
 *  wrapper layer.
 *
 *  @param[in] row_conn  Per-response-row directed connection matrix
 *                       (n_response_rows × p²).
 *  @param[in] n_codes   Number of codes @c p.
 *  @param[in] ordered   @c true: directed p² sums; @c false: fold to
 *                       @c choose_two(p) and sum.
 *  @param[in] weight    Per-line weight model (see WeightModel).
 *  @param[in] diagonal  Unordered only: keep self-connections (see
 *                       finalize_row_connections()).  Default @c false.
 *
 *  @returns Flat unit connection vector of length p² (ordered) or
 *           @c n_connections(p, diagonal) (unordered).
 */
inline arma::rowvec aggregate_row_connections(
    const arma::mat& row_conn,
    int         n_codes,
    bool        ordered,
    WeightModel weight,
    bool        diagonal = false
) {
    const int n_out = ordered ? n_codes * n_codes : n_connections(n_codes, diagonal);
    if (row_conn.n_rows == 0) return arma::rowvec(n_out, arma::fill::zeros);
    return arma::sum(finalize_row_connections(row_conn, n_codes, ordered, weight, diagonal), 0);
}

/** @brief Legacy form: @p binary selects Binary (@c true) or Product (@c false).
 *
 *  Unchanged behaviour for existing callers: ordered rows are summed raw
 *  (no binarization); unordered rows are folded and, when @p binary, clamped
 *  to presence before summing.
 */
inline arma::rowvec aggregate_row_connections(
    const arma::mat& row_conn,
    int  n_codes,
    bool ordered = false,
    bool binary  = true
) {
    return aggregate_row_connections(row_conn, n_codes, ordered,
                                     weight_model_from_bool(binary));
}

/** @brief Per-line self-connections: the diagonal of each directed row.
 *
 *  Entry (r, i) is line @c r's ground→response count for code @c i to itself,
 *  i.e. ground i × response i: the ordered network's diagonal, which unordered
 *  networks drop when they fold to the upper triangle.  Rows are taken from
 *  @c TensorNetworks::row_connection_counts (or @c row_miss_counts, giving
 *  self-misses: ground i present, response i absent), and the weight model is
 *  applied per line exactly as finalize_row_connections() applies it, so
 *  @c "binary" clamps unordered self-connections to 1 and leaves ordered ones
 *  raw.
 *
 *  @param[in] row_conn  Per-response-row directed matrix (n_response_rows × p²).
 *  @param[in] n_codes   Number of codes @c p.
 *  @param[in] ordered   Selects the weight model's ordered/unordered behaviour.
 *  @param[in] weight    Per-line weight model (see WeightModel).
 *
 *  @returns Matrix of shape n_response_rows × p.
 */
inline arma::mat finalize_self_connections(
    const arma::mat& row_conn,
    int         n_codes,
    bool        ordered,
    WeightModel weight
) {
    if (row_conn.n_cols != static_cast<arma::uword>(n_codes * n_codes))
        throw std::invalid_argument("row_conn must have n_codes^2 columns");
    const int n_rows = static_cast<int>(row_conn.n_rows);
    arma::mat out(n_rows, n_codes, arma::fill::zeros);
    for (int r = 0; r < n_rows; ++r) {
        arma::rowvec v(n_codes);
        for (int i = 0; i < n_codes; ++i) v[i] = row_conn(r, i * n_codes + i);
        apply_weight_model(v, weight, ordered);
        out.row(r) = v;
    }
    return out;
}

/** @brief Unit self-connection vector: finalize_self_connections() summed
 *         over the lines.
 *
 *  @returns Vector of length @c p.
 */
inline arma::rowvec aggregate_self_connections(
    const arma::mat& row_conn,
    int         n_codes,
    bool        ordered,
    WeightModel weight
) {
    if (row_conn.n_rows == 0) return arma::rowvec(n_codes, arma::fill::zeros);
    return arma::sum(finalize_self_connections(row_conn, n_codes, ordered, weight), 0);
}

/** @brief Apply the weight model per line to already-finalised rows.
 *
 *  For rows that are already folded (unordered) or directed (ordered) -- e.g.
 *  accumulate_unit_networks()'s raw @c row_connection_counts -- this is the
 *  weight step of finalize_row_connections() on its own, so callers that need
 *  per-line weighted rows (summing by unit to the weighted unit vector) get
 *  them without re-folding.
 *
 *  @param[in] rows     n_lines × n_cols raw rows.
 *  @param[in] ordered  Selects the weight model's ordered/unordered behaviour.
 *  @param[in] weight   Per-line weight model (see WeightModel).
 */
inline arma::mat weight_rows(const arma::mat& rows, bool ordered, WeightModel weight) {
    arma::mat out = rows;
    for (arma::uword r = 0; r < out.n_rows; ++r) {
        arma::rowvec v = out.row(r);
        apply_weight_model(v, weight, ordered);
        out.row(r) = v;
    }
    return out;
}

/// @}

/// @name Finished unit networks (one call per unit, for every binding)
/// @{

/** @brief Result of accumulate_unit_networks(): a unit's finished vectors plus
 *         its raw per-line rows.
 *
 *  "Raw" rows carry no weight model: ordered rows are the directed p² counts,
 *  unordered rows are folded to n_connections(p, diagonal) (as
 *  finalize_row_connections() with the product model). Unit vectors have the
 *  weight model applied per line before the sum. Miss fields are empty unless
 *  misses were requested.
 */
struct UnitAccumulation {
    arma::rowvec connection_counts;           ///< p² (ordered) or n_connections(p, diagonal)
    arma::mat    row_connection_counts;       ///< n_lines × (p² or n_connections(p, diagonal)), raw
    arma::rowvec self_connection_counts;      ///< p
    arma::mat    row_self_connection_counts;  ///< n_lines × p, raw
    arma::rowvec miss_counts;                 ///< as connection_counts (misses only)
    arma::mat    row_miss_counts;             ///< as row_connection_counts (misses only)
    arma::rowvec self_miss_counts;            ///< p (misses only)
    arma::mat    row_self_miss_counts;        ///< n_lines × p, raw (misses only)
};

/** @brief Accumulate one unit's networks end to end.
 *
 *  Runs apply_tensor_unit() for the directed per-line rows (and misses), then
 *  finalises them in one place: folds unordered rows, applies the weight model
 *  per line, sums the lines, and pulls out the self-connection diagonal --
 *  the steps every binding would otherwise repeat. Unit vectors are additive
 *  over lines, so a unit spread over several contexts is the sum of its
 *  per-context results.
 *
 *  Arguments as apply_tensor_unit(), plus:
 *  @param[in] ordered  @c true: directed p² networks; @c false: folded choose_two(p).
 *  @param[in] weight   Per-line weight model (see WeightModel).
 *  @param[in] misses   Also accumulate missed co-occurrences and self-misses.
 *  @param[in] diagonal Unordered only: self-connections (and self-misses) are
 *                      also columns of the connection (and miss) vectors, in
 *                      the A & A, A & B, B & B, ... layout.  Ordered networks
 *                      always carry them.  The separate self vectors are
 *                      returned either way.  Default @c false.
 */
inline UnitAccumulation accumulate_unit_networks(
    const arma::vec&        tensor,
    const std::vector<int>& dims,
    const std::vector<int>& dims_sender,
    const std::vector<int>& dims_receiver,
    const std::vector<int>& dims_mode,
    const arma::imat&       context_lookup,
    const std::vector<int>& unit_rows,
    const arma::mat&        codes,
    const arma::vec&        times,
    bool        ordered = false,
    WeightModel weight  = WeightModel::Binary,
    bool        misses  = true,
    bool        diagonal = false
) {
    const int p = static_cast<int>(codes.n_cols);
    // Directed rows always: ordered/unordered is decided in the finalise step.
    TensorNetworks tn = apply_tensor_unit(
        tensor, dims, dims_sender, dims_receiver, dims_mode,
        context_lookup, unit_rows, codes, times,
        /*ordered=*/true, /*return_members=*/false, /*return_misses=*/misses);

    UnitAccumulation out;
    out.connection_counts          = aggregate_row_connections(tn.row_connection_counts, p, ordered, weight, diagonal);
    out.row_connection_counts      = finalize_row_connections(tn.row_connection_counts, p, ordered, WeightModel::Product, diagonal);
    out.self_connection_counts     = aggregate_self_connections(tn.row_connection_counts, p, ordered, weight);
    out.row_self_connection_counts = finalize_self_connections(tn.row_connection_counts, p, true, WeightModel::Product);
    if (misses) {
        out.miss_counts          = aggregate_row_connections(tn.row_miss_counts, p, ordered, weight, diagonal);
        out.row_miss_counts      = finalize_row_connections(tn.row_miss_counts, p, ordered, WeightModel::Product, diagonal);
        out.self_miss_counts     = aggregate_self_connections(tn.row_miss_counts, p, ordered, weight);
        out.row_self_miss_counts = finalize_self_connections(tn.row_miss_counts, p, true, WeightModel::Product);
    }
    return out;
}

/// @}

/// @name Per-row co-occurrence and rolling window (rENA accumulation primitives)
/// @{

/** @brief Compute the upper-triangle co-occurrence vector for each row.
 *
 *  For each row, calls code_connections() and optionally binarizes the result.
 *
 *  @param[in] codes   Code matrix (n_rows × n_codes).
 *  @param[in] binary  When @c true, clamp all positive entries to 1.
 *
 *  @returns Matrix of shape n_rows × choose_two(n_codes).
 *
 *  @note Equivalent to @c rows_to_co_occurrences() in @c rENA/ena.cpp.
 */
inline arma::mat row_connections(
    const arma::mat& codes,
    bool binary = true
) {
    int n_rows = codes.n_rows;
    int n_tri  = choose_two(codes.n_cols);
    arma::mat out(n_rows, n_tri, arma::fill::zeros);
    for (int row = 0; row < n_rows; ++row)
        out.row(row) = code_connections(codes.row(row));
    if (binary) out.elem(arma::find(out > 0)).ones();
    return out;
}

/** @brief Rolling backward window sum of the raw code matrix.
 *
 *  For each focal row @c k, sums rows [@c max(0, k - window_size + 1), @c k].
 *  Returns a matrix of the same shape as @p codes — no upper-triangle transform
 *  is applied.  A @p window_size of 0 or less is treated as 1 (current row only).
 *
 *  @param[in] codes        Code matrix (n_rows × n_codes).
 *  @param[in] window_size  Number of rows to include in the backward window
 *                          (including the focal row).  Values <= 0 are clamped
 *                          to 1.
 *
 *  @returns Matrix of the same shape as @p codes containing the windowed sums.
 *
 *  @note Equivalent to @c ref_window_lag() in @c rENA/ena.cpp.
 */
inline arma::mat rolling_window_sum(
    const arma::mat& codes,
    int window_size = 1
) {
    int n_rows = codes.n_rows;
    arma::mat out(n_rows, codes.n_cols, arma::fill::zeros);
    for (int row = 0; row < n_rows; ++row) {
        int earliest = (window_size > 0)
            ? std::max(0, row - (window_size - 1))
            : row;  // guard: window_size <= 0 -> single row
        out.row(row) = arma::sum(codes.rows(earliest, row));
    }
    return out;
}

/// @}

} // namespace qe

#endif // LIBQE_ACCUMULATION_HPP

// [[Rcpp::depends(RcppArmadillo)]]
// Rcpp wrappers for libtma, the accumulation layer of the libqe C++
// libraries.  The headers live in inst/include/libtma/ (moved from libqe in
// its phase 4b split); they build on libqe's generic numerics, which come
// from LinkingTo: libqe.  The wrappers moved from libqe's libqe_rcpp.cpp with
// the same names, bodies and docs, and stay exported: tma is now where R code
// (rENA, ona) gets accumulation from.
#include <RcppArmadillo.h>
#include <libtma/accumulation.hpp>

using namespace Rcpp;

// =============================================================================
// Accumulation
// =============================================================================

//' Core connection matrix for one ground+response pair
//' @param ground          Numeric row vector of ground (context) code values
//' @param response        Numeric row vector of response code values
//' @param response_weight Scalar weight applied to the response self-connection
//' @param ordered         TRUE = directed; FALSE = undirected
//' @export
// [[Rcpp::export]]
arma::mat connection_matrix(arma::rowvec ground, arma::rowvec response,
                                         double response_weight = 1.0,
                                         bool ordered = true) {
    return qe::connection_matrix(ground, response, response_weight, ordered);
}

//' Traditional stanza-window accumulation (rENA model)
//'
//' For each row k in a single conversation's code matrix, accumulates
//' connections over a back/forward window.
//'
//' \strong{Undirected} (\code{ordered = FALSE}, default): upper-triangle
//' co-occurrences with back/forward-reference corrections.
//' Returns \code{n_rows × choose_two(n_codes)}.
//'
//' \strong{Directed} (\code{ordered = TRUE}): focal row k as response,
//' sum of prior window rows as ground, using the directed connection formula.
//' \code{window_forward} is ignored. Returns \code{n_rows × n_codes²}.
//'
//' @param codes          Numeric matrix (rows = lines, cols = codes) for ONE conversation
//' @param window_back    Number of prior lines in window (default 1); use .Machine$integer.max for Inf
//' @param window_forward Number of subsequent lines (default 0; ignored when ordered = TRUE)
//' @param binary         If TRUE, binarise non-zero connection counts
//' @param ordered        If TRUE, return directed n² output; FALSE (default) returns upper-tri
//' @return Undirected: (n_rows × choose_two(n_codes)); directed: (n_rows × n_codes²)
//' @export
// [[Rcpp::export]]
arma::mat accumulate_stanza(arma::mat codes,
                            int window_back    = 1,
                            int window_forward = 0,
                            bool binary        = true,
                            bool ordered       = false) {
    return qe::accumulate_stanza(codes, window_back, window_forward, binary, ordered);
}

//' Compute a column-major linear index into a multi-dimensional array
//'
//' Equivalent to tma's flat_index(). Throws if lengths of `indices`
//' and `dims` differ.
//'
//' @param indices 0-based integer vector of per-dimension indices
//' @param dims    Integer vector of array dimensions
//' @return Scalar integer linear index
//' @export
// [[Rcpp::export]]
int flat_index(std::vector<int> indices, std::vector<int> dims) {
    return qe::flat_index(indices, dims);
}

//' Per-row upper-triangle co-occurrence matrix
//'
//' For each row in \code{codes}, computes the pairwise code products
//' (upper-triangle) and optionally binarizes. Output has
//' \code{choose(n_codes, 2)} columns.
//'
//' @param codes  Numeric matrix (rows = observations, cols = codes)
//' @param binary If TRUE, binarise non-zero co-occurrences (default TRUE)
//' @return Numeric matrix (n_rows x choose_two(n_codes))
//' @export
// [[Rcpp::export]]
arma::mat row_connections(arma::mat codes, bool binary = true) {
    return qe::row_connections(codes, binary);
}

//' Rolling backward window sum of a code matrix
//'
//' For each row k, sums the raw code values over rows
//' \code{[max(0, k - window_size + 1), k]}. Returns a matrix of the same
//' shape as \code{codes}. \code{window_size <= 0} is treated as 1
//' (current row only).
//'
//' @param codes       Numeric matrix (rows = observations, cols = codes)
//' @param window_size Number of rows to look back (default 1)
//' @return Numeric matrix (same dimensions as \code{codes})
//' @export
// [[Rcpp::export]]
arma::mat rolling_window_sum(arma::mat codes, int window_size = 1) {
    return qe::rolling_window_sum(codes, window_size);
}

//' Ground/response accumulation for one unit (tma model)
//'
//' @param codes      Numeric matrix for the full context (n_rows x n_codes)
//' @param unit_rows  0-based integer vector of rows belonging to this unit
//' @param decay_fn   R function mapping a numeric distance vector to weights
//' @param ordered    TRUE = directed; FALSE = undirected (upper-tri)
//' @return Numeric vector of connection counts
//' @export
// [[Rcpp::export]]
arma::rowvec accumulate_unit(arma::mat codes, std::vector<int> unit_rows,
                                  Function decay_fn, bool ordered = false) {
    auto cpp_decay = [&](arma::vec distances) -> arma::vec {
        NumericVector d = wrap(distances);
        NumericVector w = decay_fn(d);
        return as<arma::vec>(w);
    };
    return qe::accumulate_unit(codes, unit_rows, cpp_decay, ordered);
}

//' Ground/response accumulation for one unit — returns unit vector and per-row matrix
//'
//' Equivalent to tma's accumulate_network() but without R-env-var setup.
//' The decay function receives a distance vector (response=0, older rows
//' have larger values) and returns a weight vector of the same length.
//'
//' @param codes      Numeric matrix (n_rows x n_codes)
//' @param unit_rows  0-based integer vector of rows belonging to this unit
//' @param decay_fn   R function(distances) -> weights
//' @param ordered    TRUE = directed (full p^2); FALSE = undirected (upper-tri)
//' @return List with `networks` (vector) and `row_networks` (matrix)
//' @export
// [[Rcpp::export]]
List accumulate_unit_with_rows(arma::mat codes, std::vector<int> unit_rows,
                                   Function decay_fn, bool ordered = false) {
    auto cpp_decay = [&](int unit_row, arma::uvec ground_indices) -> arma::vec {
        arma::vec dists(ground_indices.n_elem);
        for (arma::uword k = 0; k < ground_indices.n_elem; ++k)
            dists[k] = static_cast<double>(unit_row - ground_indices[k]);
        return as<arma::vec>(wrap(decay_fn(wrap(dists))));
    };
    qe::UnitNetworks r = qe::accumulate_unit_with_rows(codes, unit_rows, cpp_decay, ordered);
    return List::create(
        _("networks")     = r.networks,
        _("row_networks") = r.row_networks
    );
}

//' Tensor-based multi-modal accumulation for one unit (tma model)
//'
//' Pure-C++ port of tma's apply_tensor().  Accepts 0-based index vectors
//' for sender/receiver/mode dimensions and a pre-converted integer context
//' lookup matrix.
//'
//' @param tensor         Numeric vector (column-major flat tensor)
//' @param dims           Integer vector of tensor dimensions
//' @param dims_sender    0-based sender axis indices
//' @param dims_receiver  0-based receiver axis indices
//' @param dims_mode      0-based mode axis indices
//' @param context_lookup Integer matrix (n_context_rows x n_factors), 0-based
//' @param unit_rows      0-based response-row indices for this unit
//' @param codes          Numeric matrix (n_context_rows x n_codes)
//' @param times          Numeric vector of timestamps per context row
//' @param ordered        TRUE = directed; FALSE = undirected
//' @param misses         TRUE = also return missed co-occurrences: ground code
//'   i present while response code j is absent (n_codes^2, ground i ->
//'   response j at j*n+i; no response self-term). Raw directed rows, like
//'   `row_connection_counts`; fold them with `finalize_row_connections()` /
//'   `aggregate_row_connections()` for unordered networks.
//' @return List with `connection_counts` (vector) and `row_connection_counts`
//'   (matrix); with `misses = TRUE`, also `miss_counts` (vector) and
//'   `row_miss_counts` (matrix)
//' @export
// [[Rcpp::export]]
List apply_tensor(arma::vec tensor,
                     std::vector<int> dims,
                     std::vector<int> dims_sender,
                     std::vector<int> dims_receiver,
                     std::vector<int> dims_mode,
                     arma::imat context_lookup,
                     std::vector<int> unit_rows,
                     arma::mat codes,
                     arma::vec times,
                     bool ordered = true,
                     bool misses = false) {
    qe::TensorNetworks r = qe::apply_tensor_unit(
        tensor, dims, dims_sender, dims_receiver, dims_mode,
        context_lookup, unit_rows, codes, times, ordered,
        /*return_members=*/false, /*return_misses=*/misses);
    List out = List::create(
        _("connection_counts")     = r.connection_counts,
        _("row_connection_counts") = r.row_connection_counts
    );
    if (misses) {
        out["miss_counts"]     = r.miss_counts;
        out["row_miss_counts"] = r.row_miss_counts;
    }
    return out;
}

//' Apply the TMA window/weight tensor, additionally returning per-response-row
//' window membership.
//'
//' Identical to \code{apply_tensor()} but also returns, for each response
//' (reference) row, the in-window ground rows and their resolved window sizes.
//' Powers the webtool Data View per-modality window-span hover. Kept as a
//' separate export so \code{apply_tensor()}'s ABI (and tma's direct .Call to it)
//' is unchanged.
//'
//' @param tensor         Numeric vector (column-major flat tensor)
//' @param dims           Integer vector of tensor dimensions
//' @param dims_sender    0-based sender axis indices
//' @param dims_receiver  0-based receiver axis indices
//' @param dims_mode      0-based mode axis indices
//' @param context_lookup Integer matrix (n_context_rows x n_factors), 0-based
//' @param unit_rows      0-based response-row indices for this unit
//' @param codes          Numeric matrix (n_context_rows x n_codes)
//' @param times          Numeric vector of timestamps per context row
//' @param ordered        TRUE = directed; FALSE = undirected
//' @return List with \code{connection_counts}, \code{row_connection_counts},
//'   \code{row_window_members} (list of 1-based ground-row index vectors, in
//'   \code{unit_rows} order) and \code{row_window_wins} (parallel resolved
//'   window sizes).
//' @export
// [[Rcpp::export]]
List apply_tensor_members(arma::vec tensor,
                     std::vector<int> dims,
                     std::vector<int> dims_sender,
                     std::vector<int> dims_receiver,
                     std::vector<int> dims_mode,
                     arma::imat context_lookup,
                     std::vector<int> unit_rows,
                     arma::mat codes,
                     arma::vec times,
                     bool ordered = true) {
    qe::TensorNetworks r = qe::apply_tensor_unit(
        tensor, dims, dims_sender, dims_receiver, dims_mode,
        context_lookup, unit_rows, codes, times, ordered, /*return_members=*/true);
    List members(r.row_window_members.size());
    List wins(r.row_window_wins.size());
    for (size_t i = 0; i < r.row_window_members.size(); ++i) {
        IntegerVector iv(r.row_window_members[i].begin(), r.row_window_members[i].end());
        for (R_xlen_t k = 0; k < iv.size(); ++k) iv[k] += 1;   // 0-based -> 1-based
        members[i] = iv;
        wins[i] = NumericVector(r.row_window_wins[i].begin(), r.row_window_wins[i].end());
    }
    return List::create(
        _("connection_counts")     = r.connection_counts,
        _("row_connection_counts") = r.row_connection_counts,
        _("row_window_members")    = members,
        _("row_window_wins")       = wins
    );
}

// Weight model from R: NULL (= "binary"), TRUE/FALSE (legacy binary flag) or a name.
static qe::WeightModel weight_model_from_sexp(SEXP weight) {
    if (Rf_isNull(weight)) return qe::WeightModel::Binary;
    if (TYPEOF(weight) == STRSXP && Rf_length(weight) == 1)
        return qe::weight_model_from_string(Rcpp::as<std::string>(weight));
    if (TYPEOF(weight) == LGLSXP && Rf_length(weight) == 1)
        return qe::weight_model_from_bool(Rcpp::as<bool>(weight));
    Rcpp::stop("`weight` must be TRUE/FALSE or one of 'binary', 'product', 'sqrt', 'log1p'.");
}

//' Finalise per-response-row tensor connections (fold + weight model)
//'
//' The per-line step of tma's aggregation, before any summing: unordered rows
//' are folded to the upper triangle, then the weight model is applied; ordered
//' rows keep the directed n*n layout with the weight applied per cell.
//'
//' Weight models are applied per line, before the unit sum (the stage legacy
//' rENA applies \code{weight.by}): \code{"binary"} clamps each unordered count
//' to 1 (ordered counts are left raw), \code{"product"} keeps the counts,
//' \code{"sqrt"} and \code{"log1p"} (alias \code{"log"}) transform each
//' line's product count.
//'
//' @param row_conn Numeric matrix (n_response_rows x n_codes^2) of per-row
//'   directed counts, i.e. \code{apply_tensor()$row_connection_counts}
//' @param n_codes  Number of codes
//' @param ordered  TRUE = keep directed n*n rows; FALSE = fold to choose(n, 2)
//' @param weight   Weight model name (\code{"binary"}, \code{"product"},
//'   \code{"sqrt"}, \code{"log1p"}), or TRUE/FALSE for the legacy binary flag
//'   (TRUE = \code{"binary"}, FALSE = \code{"product"}). NULL (default) =
//'   \code{"binary"}.
//' @param diagonal Unordered only: keep self-connections in the folded rows,
//'   as columns A & A, A & B, B & B, ... (ordered rows always carry them)
//' @return Numeric matrix (n_response_rows x n_codes^2, or x choose(n_codes, 2),
//'   or x n_codes(n_codes + 1)/2 with \code{diagonal})
//' @export
// [[Rcpp::export]]
arma::mat finalize_row_connections(arma::mat row_conn,
                                   int  n_codes,
                                   bool ordered = false,
                                   SEXP weight  = R_NilValue,
                                   bool diagonal = false) {
    return qe::finalize_row_connections(row_conn, n_codes, ordered,
                                        weight_model_from_sexp(weight), diagonal);
}

//' Aggregate per-response-row tensor connections into a unit vector
//'
//' Finalises each row (see \code{finalize_row_connections()}) and sums the
//' rows: tma's aggregation of \code{apply_tensor()$row_connection_counts},
//' with the weight model applied per line before the unit sum.
//'
//' @inheritParams finalize_row_connections
//' @return Numeric vector of length n_codes^2 (ordered) or choose(n_codes, 2)
//' @export
// [[Rcpp::export]]
NumericVector aggregate_row_connections(arma::mat row_conn,
                                        int  n_codes,
                                        bool ordered = false,
                                        SEXP weight  = R_NilValue,
                                        bool diagonal = false) {
    arma::rowvec out = qe::aggregate_row_connections(row_conn, n_codes, ordered,
                                                     weight_model_from_sexp(weight), diagonal);
    return NumericVector(out.begin(), out.end());
}

//' Per-line self-connections (diagonal of each directed row)
//'
//' Each line's ground-to-response count for a code to itself (ground i x
//' response i): the ordered network's diagonal, which unordered networks drop
//' when they fold to the upper triangle. Pass
//' \code{apply_tensor()$row_connection_counts}, or \code{$row_miss_counts}
//' for self-misses (ground i present, response i absent). The weight model is
//' applied per line as in \code{finalize_row_connections()}: \code{"binary"}
//' clamps unordered self-connections to 1 and leaves ordered ones raw.
//'
//' @inheritParams finalize_row_connections
//' @return Numeric matrix (n_response_rows x n_codes)
//' @export
// [[Rcpp::export]]
arma::mat finalize_self_connections(arma::mat row_conn,
                                    int  n_codes,
                                    bool ordered = false,
                                    SEXP weight  = R_NilValue) {
    return qe::finalize_self_connections(row_conn, n_codes, ordered,
                                         weight_model_from_sexp(weight));
}

//' Aggregate per-line self-connections into a unit vector
//'
//' \code{finalize_self_connections()} summed over the lines.
//'
//' @inheritParams finalize_row_connections
//' @return Numeric vector of length n_codes
//' @export
// [[Rcpp::export]]
NumericVector aggregate_self_connections(arma::mat row_conn,
                                         int  n_codes,
                                         bool ordered = false,
                                         SEXP weight  = R_NilValue) {
    arma::rowvec out = qe::aggregate_self_connections(row_conn, n_codes, ordered,
                                                      weight_model_from_sexp(weight));
    return NumericVector(out.begin(), out.end());
}

//' Apply the weight model per line to already-finalised rows
//'
//' The weight step of \code{finalize_row_connections()} on its own, for rows
//' that are already folded (unordered) or directed (ordered), such as
//' \code{accumulate_unit_networks()$row_connection_counts}.
//'
//' @param rows    Numeric matrix of raw per-line rows
//' @inheritParams finalize_row_connections
//' @return Numeric matrix, same shape as \code{rows}
//' @export
// [[Rcpp::export]]
arma::mat weight_rows(arma::mat rows, bool ordered = false, SEXP weight = R_NilValue) {
    return qe::weight_rows(rows, ordered, weight_model_from_sexp(weight));
}

//' Accumulate one unit's networks end to end
//'
//' One libtma call per unit: runs \code{apply_tensor()} for the directed
//' per-line rows (and misses), then folds unordered rows, applies the weight
//' model per line, sums the lines and pulls out the self-connection diagonal --
//' the steps \code{accumulate()} and every other binding share.
//'
//' @inheritParams apply_tensor
//' @param weight  Weight model name (\code{"binary"}, \code{"product"},
//'   \code{"sqrt"}, \code{"log1p"}), or TRUE/FALSE for the legacy binary flag.
//'   NULL (default) = \code{"binary"}.
//' @param misses  TRUE (default) = also accumulate missed co-occurrences and
//'   self-misses.
//' @param diagonal Unordered only: self-connections (and self-misses) are also
//'   columns of the connection (and miss) vectors, in the A & A, A & B,
//'   B & B, ... layout. The separate self vectors are returned either way.
//' @return List with \code{connection_counts} (n_codes^2 ordered, or
//'   choose(n_codes, 2)), \code{row_connection_counts} (raw per line, folded
//'   when unordered), \code{self_connection_counts} (n_codes),
//'   \code{row_self_connection_counts} (raw per line); with misses, also
//'   \code{miss_counts}, \code{row_miss_counts}, \code{self_miss_counts},
//'   \code{row_self_miss_counts}.
//' @export
// [[Rcpp::export]]
List accumulate_unit_networks(arma::vec tensor,
                              std::vector<int> dims,
                              std::vector<int> dims_sender,
                              std::vector<int> dims_receiver,
                              std::vector<int> dims_mode,
                              arma::imat context_lookup,
                              std::vector<int> unit_rows,
                              arma::mat codes,
                              arma::vec times,
                              bool ordered = false,
                              SEXP weight  = R_NilValue,
                              bool misses  = true,
                              bool diagonal = false) {
    qe::UnitAccumulation r = qe::accumulate_unit_networks(
        tensor, dims, dims_sender, dims_receiver, dims_mode,
        context_lookup, unit_rows, codes, times,
        ordered, weight_model_from_sexp(weight), misses, diagonal);
    List out = List::create(
        _("connection_counts")          = NumericVector(r.connection_counts.begin(), r.connection_counts.end()),
        _("row_connection_counts")      = r.row_connection_counts,
        _("self_connection_counts")     = NumericVector(r.self_connection_counts.begin(), r.self_connection_counts.end()),
        _("row_self_connection_counts") = r.row_self_connection_counts
    );
    if (misses) {
        out["miss_counts"]          = NumericVector(r.miss_counts.begin(), r.miss_counts.end());
        out["row_miss_counts"]      = r.row_miss_counts;
        out["self_miss_counts"]     = NumericVector(r.self_miss_counts.begin(), r.self_miss_counts.end());
        out["row_self_miss_counts"] = r.row_self_miss_counts;
    }
    return out;
}

1		# =============================================================================
2		# replace_door.R — Plug door() output back into an accumulation object
3		# =============================================================================
4
5		#' Replace raw co-occurrence columns with door-adjusted values
6		#'
7		#' After door(), co-occurrence columns are named door_<original "code & code">.
8		#' This function copies those values into accum$connection.counts, replacing
9		#' the raw co-occurrence columns, so model() / ena.make.set() use the door-adjusted
10		#' data without changing downstream code paths.
11		#'
12		#' @param accum Object from \code{tma::accumulate()}.
13		#' @param door_df Output of \code{door()} (must include \code{door_*} columns).
14		#' @return \code{accum} with updated \code{connection.counts}.
15		#' @export
16		replace_door <- function(accum, door_df) {
17	2x	if (!("connection.counts" %in% names(accum))) {
18	!	stop("`accum` has no connection.counts")
19		}
20	2x	conn <- accum$connection.counts
21	2x	if (!("ENA_UNIT" %in% names(conn)) && "QEUNIT" %in% names(conn)) {
22	2x	conn$ENA_UNIT <- as.character(conn$QEUNIT)
23		}
24	2x	if (!("ENA_UNIT" %in% names(conn))) {
25	!	stop("`accum$connection.counts` lacks ENA_UNIT (and QEUNIT)")
26		}
27	2x	if (!("ENA_UNIT" %in% names(door_df)) && "QEUNIT" %in% names(door_df)) {
28	!	door_df$ENA_UNIT <- as.character(door_df$QEUNIT)
29		}
30	2x	if (!("ENA_UNIT" %in% names(door_df))) {
31	!	stop("`door_df` lacks ENA_UNIT (and QEUNIT)")
32		}
33
34	2x	nm <- names(conn)
35	2x	code_cols <- nm[grepl("\\s&\\s", nm) & vapply(conn, is.numeric, logical(1))]
36	2x	if (!length(code_cols)) {
37	!	stop("No numeric co-occurrence columns (names with ' & ') in connection.counts")
38		}
39
40	2x	prefix <- "door_"
41	2x	door_cols <- paste0(prefix, code_cols)
42	2x	missing <- setdiff(door_cols, names(door_df))
43	2x	if (length(missing)) {
44	!	stop("Door table missing columns: ", paste(missing, collapse = ", "))
45		}
46
47	2x	key_acc <- as.character(conn$ENA_UNIT)
48	2x	key_door <- as.character(door_df$ENA_UNIT)
49	2x	idx <- match(key_acc, key_door)
50	2x	if (anyNA(idx)) {
51	!	bad <- which(is.na(idx))[seq_len(min(5L, sum(is.na(idx))))]
52	!	stop("Cannot align by ENA_UNIT. Unmatched rows (examples): ",
53	!	paste(bad, collapse = ", "))
54		}
55
56	2x	table_class_before <- class(conn)
57	2x	use_datatable <- "data.table" %in% table_class_before
58
59	2x	for (k in seq_along(code_cols)) {
60	2x	j <- code_cols[k]
61	2x	dj <- door_cols[k]
62
63	2x	v <- door_df[[dj]][idx]
64	2x	if (!is.numeric(v)) {
65	!	v <- suppressWarnings(as.double(as.character(v)))
66		}
67	2x	if (any(!is.finite(v))) {
68	!	stop("Non-finite values after replacement in column: ", j)
69		}
70
71	2x	old_col_class <- class(conn[[j]])
72	2x	v <- structure(as.double(v), class = old_col_class)
73
74	2x	if (use_datatable) {
75	2x	data.table::set(conn, j = j, value = v)
76		} else {
77	!	conn[[j]] <- v
78		}
79		}
80
81	2x	class(conn) <- table_class_before
82	2x	accum$connection.counts <- conn
83	2x	accum
84		}
85
86		#' Apply door smoothing to an accumulation object
87		#'
88		#' This convenience wrapper runs \code{\link{door}()} on an accumulation object's
89		#' co-occurrence table and then writes the door-smoothed values back with
90		#' \code{\link{replace_door}()}. Use \code{\link{door}()} directly when you want
91		#' to inspect or compare the intermediate \code{door_*} columns before replacing
92		#' the accumulation values.
93		#'
94		#' @param accum Object from \code{tma::accumulate()}.
95		#' @param ... Arguments passed to \code{\link{door}()}, including
96		#' \code{unit_col}, \code{time_col}, \code{method}, and method-specific
97		#' settings.
98		#' @return \code{accum} with door-smoothed co-occurrence columns.
99		#' @export
100		door_accumulation <- function(accum, ...) {
101	1x	if ("connection.counts" %in% names(accum)) {
102	1x	conn <- accum$connection.counts
103	!	} else if ("model" %in% names(accum) &&
104	!	"row.connection.counts" %in% names(accum$model)) {
105	!	conn <- accum$model$row.connection.counts
106		} else {
107	!	stop("`accum` must contain `connection.counts` or `model$row.connection.counts`.")
108		}
109
110	1x	door_df <- door(conn, ...)
111	1x	replace_door(accum, door_df)
112		}

1		# =============================================================================
2		# door.R — Apply the ETM door function to co-occurrence trajectories
3		# =============================================================================
4
5		COOCCURRENCE_NAME_REGEX <- "\\s&\\s"
6
7		cooccurrence_pair_column_names <- function(data) {
8	3x	nm <- names(data)
9	3x	is_pair <- grepl(COOCCURRENCE_NAME_REGEX, nm)
10	3x	is_num <- vapply(data, is.numeric, logical(1))
11	3x	nm[is_pair & is_num]
12		}
13
14		prefix_door_columns <- function(df_door, original_names) {
15	4x	stopifnot(ncol(df_door) == length(original_names))
16	4x	out <- as.data.frame(df_door, stringsAsFactors = FALSE)
17	4x	names(out) <- paste0("door_", original_names)
18	4x	out
19		}
20
21		attach_door_columns <- function(source_rows, cols_of_interest, door_only) {
22	4x	meta <- source_rows[, setdiff(names(source_rows), cols_of_interest), drop = FALSE]
23	4x	cbind(meta, door_only)
24		}
25
26		ensure_ena_unit_column <- function(data) {
27	3x	if ("ENA_UNIT" %in% names(data)) {
28	!	return(data)
29		}
30	3x	if ("QEUNIT" %in% names(data)) {
31	1x	data$ENA_UNIT <- as.character(data$QEUNIT)
32	1x	return(data)
33		}
34	2x	data
35		}
36
37		assert_door_keys <- function(data, unit_col, time_col) {
38	3x	if (!unit_col %in% names(data)) {
39	!	stop("`unit_col` not found: ", unit_col, ". Available: ",
40	!	paste(names(data), collapse = ", "))
41		}
42	3x	if (!time_col %in% names(data)) {
43	!	stop("`time_col` not found in `data`: ", time_col,
44	!	". Include a monotonic row index in accumulation units.")
45		}
46	3x	if (!is.character(data[[unit_col]]) && !is.factor(data[[unit_col]])) {
47	!	stop("`unit_col` must be character or factor.")
48		}
49	3x	if (!(is.numeric(data[[time_col]]) \|\|
50	3x	inherits(data[[time_col]], c("Date", "POSIXct", "POSIXt")))) {
51	!	stop("`time_col` must be numeric, Date, or POSIXct. Convert before calling.")
52		}
53	3x	if (any(is.na(data[[unit_col]]))) {
54	!	bad <- which(is.na(data[[unit_col]]))[seq_len(min(5L, sum(is.na(data[[unit_col]]))))]
55	!	stop("`unit_col` has NA (e.g. rows: ", paste(bad, collapse = ", "), ").")
56		}
57	3x	if (any(is.na(data[[time_col]]))) {
58	!	bad <- which(is.na(data[[time_col]]))[seq_len(min(5L, sum(is.na(data[[time_col]]))))]
59	!	stop("`time_col` has NA (e.g. rows: ", paste(bad, collapse = ", "), ").")
60		}
61		}
62
63		prepare_units_time_ordered <- function(data, unit_col, time_col) {
64	3x	data$ENA_UNIT_base <- trimws(as.character(data[[unit_col]]))
65	3x	if (!"ENA_UNIT" %in% names(data)) {
66	2x	data$ENA_UNIT <- data$ENA_UNIT_base
67		}
68
69	3x	do.call(rbind, lapply(split(data, data$ENA_UNIT_base), function(df) {
70	4x	tvec <- df[[time_col]]
71	4x	if (any(duplicated(tvec))) {
72	!	idx <- which(duplicated(tvec) \| duplicated(tvec, fromLast = TRUE))
73	!	show <- head(idx, 5L)
74	!	stop("Duplicate ", time_col, " within unit '", df$ENA_UNIT_base[1L],
75	!	"'. Example row positions: ", paste(show, collapse = ", "),
76	!	". Use a unique time key per row (e.g. Index).")
77		}
78	4x	if (is.unsorted(tvec, strictly = TRUE)) {
79	!	badpos <- which(diff(tvec) <= 0L)[1L]
80	!	stop("Non-increasing ", time_col, " within unit '", df$ENA_UNIT_base[1L],
81	!	"' near sorted positions ", badpos, " and ", badpos + 1L, ".")
82		}
83	4x	df[order(tvec), , drop = FALSE]
84		}))
85		}
86
87		.resolve_lookback_per_unit <- function(lookback_size, data, unit_col) {
88	2x	units <- unique(trimws(as.character(data[[unit_col]])))
89	2x	if (length(lookback_size) == 1L && is.numeric(lookback_size)) {
90	2x	return(stats::setNames(rep(as.integer(lookback_size), length(units)), units))
91		}
92	!	if (is.data.frame(lookback_size)) {
93	!	uc <- intersect(c(unit_col, "unit", "UserName"), names(lookback_size))[1]
94	!	lc <- intersect(c("lookback", "lookback_size", "door"), names(lookback_size))[1]
95	!	if (is.na(uc) \|\| is.na(lc)) {
96	!	stop("lookback_size data.frame needs unit and lookback columns")
97		}
98	!	out <- stats::setNames(
99	!	as.integer(lookback_size[[lc]]),
100	!	as.character(lookback_size[[uc]])
101		)
102	!	return(out)
103		}
104	!	if (is.numeric(lookback_size) && !is.null(names(lookback_size))) {
105	!	nm <- trimws(names(lookback_size))
106	!	out <- structure(as.integer(lookback_size), names = nm)
107	!	missing <- setdiff(units, nm)
108	!	if (length(missing)) {
109	!	stop("lookback_size missing units: ", paste(head(missing, 5L), collapse = ", "))
110		}
111	!	return(out)
112		}
113	!	stop("`lookback_size` must be a single integer, a named vector, or a data.frame")
114		}
115
116		#' Apply lookback door sliding window pooling to co-occurrence data
117		#'
118		#' @param data Data frame with co-occurrence columns
119		#' @param cols_of_interest Character vector of code-pair columns
120		#' @param lookback_size Window lookback size (single integer, named vector, or data.frame)
121		#' @param unit_col Name of column identifying unit
122		#' @param aggregate "sum" or "mean"
123		#' @param weighting "equal" or "linear"
124		#' @param segment_col Optional segment column to reset window
125		#' @return Data frame with door_* columns attached
126		#' @export
127		lookback_door <- function(
128		data,
129		cols_of_interest,
130		lookback_size = 100L,
131		unit_col = "ENA_UNIT_base",
132		aggregate = c("sum", "mean"),
133		weighting = c("equal", "linear"),
134		segment_col = NULL) {
135	2x	aggregate <- match.arg(aggregate)
136	2x	weighting <- match.arg(weighting)
137
138	2x	if (!is.null(segment_col) && !(segment_col %in% names(data))) {
139	!	stop("`segment_col` not found in `data`: ", segment_col)
140		}
141
142	2x	lookback_map <- .resolve_lookback_per_unit(lookback_size, data, unit_col)
143	2x	units <- unique(data$ENA_UNIT_base)
144	2x	out <- vector("list", length(units))
145	2x	ui <- 0L
146
147	2x	for (u in units) {
148	3x	u_key <- as.character(u)
149	3x	idx <- match(u_key, names(lookback_map))
150	3x	if (is.na(idx)) {
151	!	stop("No lookback_size for unit: ", u_key)
152		}
153	3x	lb_u <- lookback_map[idx]
154	3x	unit_data <- as.data.frame(data[data$ENA_UNIT_base == u, , drop = FALSE])
155
156	3x	segments <- if (is.null(segment_col)) {
157	3x	list(unit_data)
158		} else {
159	!	split(unit_data, unit_data[[segment_col]], drop = TRUE)
160		}
161
162	3x	seg_results <- lapply(segments, function(seg_df) {
163	3x	M <- as.matrix(seg_df[, cols_of_interest, drop = FALSE])
164	3x	n <- nrow(M)
165	!	if (n == 0L) return(NULL)
166
167		# Use libqe C++ acceleration if available
168	3x	segs_vec <- if (!is.null(segment_col)) as.integer(as.factor(seg_df[[segment_col]])) else integer(0)
169	3x	S <- libqe::door_lookback_block(
170	3x	block = M,
171	3x	lookback_size = as.integer(lb_u),
172	3x	aggregate_mean = (aggregate == "mean"),
173	3x	weighting_linear = (weighting == "linear"),
174	3x	segment_ids = segs_vec
175		)
176
177	3x	door_mat <- prefix_door_columns(as.data.frame(S), cols_of_interest)
178	3x	attach_door_columns(seg_df, cols_of_interest, door_mat)
179		})
180
181	3x	ui <- ui + 1L
182	3x	out[[ui]] <- do.call(rbind, seg_results)
183		}
184
185	2x	do.call(rbind, out)
186		}
187
188		#' Apply EMA smoothing to co-occurrence data
189		#'
190		#' @param data Data frame with co-occurrence columns
191		#' @param cols_of_interest Character vector of code-pair columns
192		#' @param alpha Smoothing factor (0, 1]
193		#' @return Data frame with door_* columns attached
194		#' @export
195		ema_door <- function(data, cols_of_interest, alpha = 0.3) {
196	1x	mat_by_unit <- function(unit_data) {
197	1x	mat <- as.matrix(unit_data[, cols_of_interest, drop = FALSE])
198	1x	n <- nrow(mat)
199	!	if (n == 0L) return(unit_data)
200
201	1x	out <- libqe::door_ema_block(block = mat, alpha = as.numeric(alpha))
202	1x	door_only <- prefix_door_columns(as.data.frame(out), cols_of_interest)
203	1x	attach_door_columns(unit_data, cols_of_interest, door_only)
204		}
205
206	1x	units <- unique(data$ENA_UNIT_base)
207	1x	pieces <- lapply(units, function(u) {
208	1x	mat_by_unit(as.data.frame(data[data$ENA_UNIT_base == u, , drop = FALSE]))
209		})
210	1x	do.call(rbind, pieces)
211		}
212
213		#' Apply LOESS smoothing to co-occurrence data
214		#'
215		#' @param data Data frame with co-occurrence columns
216		#' @param cols_of_interest Character vector of code-pair columns
217		#' @param time_col Strictly increasing time column
218		#' @param span LOESS span parameter
219		#' @param degree LOESS degree parameter (1 or 2)
220		#' @param family "gaussian" or "symmetric"
221		#' @return Data frame with door_* columns attached
222		#' @export
223		loess_door <- function(
224		data,
225		cols_of_interest,
226		time_col,
227		span = 0.3,
228		degree = 1L,
229		family = c("gaussian", "symmetric")) {
230	!	family <- match.arg(family)
231	!	units <- unique(data$ENA_UNIT_base)
232	!	out <- vector("list", length(units))
233	!	ui <- 0L
234
235	!	for (u in units) {
236	!	unit_data <- as.data.frame(data[data$ENA_UNIT_base == u, , drop = FALSE])
237	!	x <- as.numeric(unit_data[[time_col]])
238	!	n <- length(x)
239	!	S <- matrix(NA_real_, nrow = n, ncol = length(cols_of_interest))
240
241	!	for (j in seq_along(cols_of_interest)) {
242	!	y <- unit_data[[cols_of_interest[j]]]
243	!	if (all(is.na(y))) {
244	!	S[, j] <- NA_real_
245	!	next
246		}
247	!	fit <- tryCatch({
248	!	stats::predict(
249	!	stats::loess(
250	!	y ~ x,
251	!	span = span,
252	!	degree = degree,
253	!	family = family,
254	!	control = stats::loess.control(
255	!	surface = "direct",
256	!	trace.hat = "approximate",
257	!	iterations = 1L
258		),
259	!	na.action = stats::na.exclude
260		),
261	!	newdata = data.frame(x = x)
262		)
263	!	}, error = function(e) rep(NA_real_, n))
264	!	S[, j] <- as.numeric(fit)
265		}
266
267	!	door_only <- prefix_door_columns(as.data.frame(S), cols_of_interest)
268	!	ui <- ui + 1L
269	!	out[[ui]] <- attach_door_columns(unit_data, cols_of_interest, door_only)
270		}
271
272	!	do.call(rbind, out)
273		}
274
275		.normalize_door_method <- function(method) {
276	3x	method <- as.character(method)
277	3x	allowed <- c("Lookback", "EMA", "LOESS")
278	3x	bad <- setdiff(method, allowed)
279	3x	if (length(bad)) {
280	!	stop(
281	!	"Unknown method: ", paste(bad, collapse = ", "),
282	!	". Use: Lookback, EMA, LOESS"
283		)
284		}
285	3x	unique(method)
286		}
287
288		.apply_post_norm <- function(res, pair_cols, post_norm) {
289	3x	if (post_norm != "l2") {
290	3x	return(res)
291		}
292	!	door_cols <- paste0("door_", pair_cols)
293	!	door_cols <- door_cols[door_cols %in% names(res)]
294	!	if (!length(door_cols)) {
295	!	return(res)
296		}
297	!	M <- as.matrix(res[, door_cols, drop = FALSE])
298	!	res[, door_cols] <- libqe::normalize_networks(M)
299	!	res
300		}
301
302		.run_door_method <- function(
303		data,
304		method,
305		pair_cols,
306		time_col,
307		unit_col,
308		lookback_size,
309		aggregate,
310		weighting,
311		segment_col,
312		alpha,
313		loess_span,
314		loess_degree,
315		loess_family,
316		post_norm,
317		verbose) {
318	3x	if (isTRUE(verbose)) {
319	!	if (method == "Lookback") {
320	!	lb_msg <- if (length(lookback_size) == 1L && is.numeric(lookback_size)) {
321	!	as.character(lookback_size)
322		} else {
323	!	paste0("per-unit (", length(.resolve_lookback_per_unit(lookback_size, data, unit_col)), " units)")
324		}
325	!	message(
326	!	"Lookback: lookback_size=", lb_msg,
327	!	", aggregate=", aggregate, ", weighting=", weighting,
328	!	", segment_col=", if (is.null(segment_col)) "NULL" else segment_col
329		)
330	!	} else if (method == "EMA") {
331	!	message("EMA: alpha=", alpha)
332	!	} else if (method == "LOESS") {
333	!	message(
334	!	"LOESS: span=", loess_span,
335	!	", degree=", loess_degree, ", family=", loess_family
336		)
337		}
338		}
339
340	3x	res <- switch(
341	3x	method,
342	3x	Lookback = lookback_door(
343	3x	data,
344	3x	cols_of_interest = pair_cols,
345	3x	lookback_size = lookback_size,
346	3x	unit_col = unit_col,
347	3x	aggregate = aggregate,
348	3x	weighting = weighting,
349	3x	segment_col = segment_col
350		),
351	3x	EMA = ema_door(
352	3x	data,
353	3x	cols_of_interest = pair_cols,
354	3x	alpha = alpha
355		),
356	3x	LOESS = loess_door(
357	3x	data,
358	3x	cols_of_interest = pair_cols,
359	3x	time_col = time_col,
360	3x	span = loess_span,
361	3x	degree = loess_degree,
362	3x	family = loess_family
363		),
364	3x	stop("Unknown method: ", method)
365		)
366
367	3x	.apply_post_norm(res, pair_cols, post_norm)
368		}
369
370		#' Apply the ETM door function to code-pair co-occurrence rows
371		#'
372		#' @param data Data frame from \code{accum$model$row.connection.counts}. If only
373		#' \code{QEUNIT} is present (TMA default), it is copied to \code{ENA_UNIT} for
374		#' alignment with \code{replace_door()}.
375		#' @param method One or more of \code{"Lookback"}, \code{"EMA"}, \code{"LOESS"}.
376		#' @param unit_col Column grouping the trajectory (e.g. \code{"UserName"}).
377		#' @param time_col Strictly increasing time column within each unit (e.g. \code{"Index"}).
378		#' @param post_norm \code{"none"} or \code{"l2"} row normalization on \code{door_*}
379		#' columns after pooling.
380		#' @param lookback_size Lookback only — max rows in the backward pool. A single integer
381		#' applies to all units; a named vector or data.frame (\code{unit} + \code{lookback})
382		#' sets per-unit lookback sizes.
383		#' @param aggregate Lookback only — \code{"sum"} or \code{"mean"}.
384		#' @param weighting Lookback only — \code{"equal"} or \code{"linear"} ramp.
385		#' @param segment_col Lookback only — if set, the pool resets at each new segment level.
386		#' @param alpha EMA only — blend weight on the current row (0–1).
387		#' @param loess_span,loess_degree,loess_family LOESS only — passed to \code{stats::loess}.
388		#' @param verbose Print method settings.
389		#' @return A data frame when \code{length(method) == 1}; otherwise a named list of
390		#' data frames.
391		#' @export
392		door <- function(
393		data,
394		method = "Lookback",
395		unit_col,
396		time_col,
397		post_norm = c("none", "l2"),
398		lookback_size = 100L,
399		aggregate = c("sum", "mean"),
400		weighting = c("equal", "linear"),
401		segment_col = NULL,
402		alpha = 0.3,
403		loess_span = 0.3,
404		loess_degree = 1L,
405		loess_family = c("gaussian", "symmetric"),
406		verbose = FALSE) {
407	3x	post_norm <- match.arg(post_norm)
408	3x	aggregate <- match.arg(aggregate)
409	3x	weighting <- match.arg(weighting)
410	3x	loess_family <- match.arg(loess_family)
411
412	3x	if (inherits(data, "data.table")) {
413	1x	data <- as.data.frame(data)
414		}
415	3x	data <- ensure_ena_unit_column(data)
416
417	3x	assert_door_keys(data, unit_col, time_col)
418	3x	data <- prepare_units_time_ordered(data, unit_col, time_col)
419
420	3x	pair_cols <- cooccurrence_pair_column_names(data)
421	3x	if (length(pair_cols) == 0L) {
422	!	stop("No numeric code-pair columns (names matching ' & ') found.")
423		}
424
425	3x	methods <- .normalize_door_method(method)
426
427	3x	if (length(methods) == 1L) {
428	3x	return(.run_door_method(
429	3x	data = data,
430	3x	method = methods[[1L]],
431	3x	pair_cols = pair_cols,
432	3x	time_col = time_col,
433	3x	unit_col = unit_col,
434	3x	lookback_size = lookback_size,
435	3x	aggregate = aggregate,
436	3x	weighting = weighting,
437	3x	segment_col = segment_col,
438	3x	alpha = alpha,
439	3x	loess_span = loess_span,
440	3x	loess_degree = loess_degree,
441	3x	loess_family = loess_family,
442	3x	post_norm = post_norm,
443	3x	verbose = verbose
444		))
445		}
446
447	!	results <- vector("list", length(methods))
448	!	names(results) <- methods
449	!	for (m in methods) {
450	!	results[[m]] <- .run_door_method(
451	!	data = data,
452	!	method = m,
453	!	pair_cols = pair_cols,
454	!	time_col = time_col,
455	!	unit_col = unit_col,
456	!	lookback_size = lookback_size,
457	!	aggregate = aggregate,
458	!	weighting = weighting,
459	!	segment_col = segment_col,
460	!	alpha = alpha,
461	!	loess_span = loess_span,
462	!	loess_degree = loess_degree,
463	!	loess_family = loess_family,
464	!	post_norm = post_norm,
465	!	verbose = verbose
466		)
467		}
468	!	results
469		}

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		##' 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	85x	model <- x;
13	85x	if ( is.data.frame(x) ) {
14	85x	model <- list(
15	85x	model = list (
16	85x	model.type = "TMA",
17	85x	raw.input = data.table::as.data.table( x ),
18	85x	row.connection.counts = as.data.frame(matrix(nrow = nrow( x ), ncol = 0))
19		)
20		)
21	85x	class(model) <- c("ena.set", class(model))
22		}
23
24	85x	model$model$raw.input[[ATTR_NAMES$CONTEXT_ID]] <- 1;
25	85x	model$model$raw.input$QEID <- seq(nrow(model$model$raw.input));
26	85x	data.table::setkeyv(x = model$model$raw.input, cols = c("QEID"));
27
28		# raw_input <- model$model$raw.input;
29	85x	model$`_function.params`$units.by <- by;
30
31	85x	all_units <- model$model$raw.input[, ..by];
32	85x	unique_units <- unique(all_units);
33	85x	model$`_function.params`$units <- all_units;
34
35	85x	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	85x	model$model$contexts <- structure(rep(list(c()), length(unique_unit_labels)), names = unique_unit_labels);
39	85x	model$model$unit.labels <- unique_unit_labels;
40	85x	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	85x	return(model);
44		}
45
46		# Columns a rule compares to UNIT with `==` (either side, e.g.
47		# `GroupName == UNIT$GroupName` or `UNIT[["GroupName"]] == GroupName`).
48		unit_equality_columns <- function(expr) {
49	106x	unit_col <- function(e) {
50	14x	if (is.call(e) && length(e) == 3 &&
51	14x	(identical(e[[1]], as.name("$")) \|\| identical(e[[1]], as.name("[["))) &&
52	14x	identical(e[[2]], as.name("UNIT"))) {
53	7x	return(as.character(e[[3]]));
54		}
55	7x	NULL
56		};
57	106x	found <- character(0);
58	106x	walk <- function(e) {
59	1013x	if (is.expression(e) \|\| is.list(e)) {
60	1x	for (el in e) walk(el);
61	1012x	} else if (is.call(e)) {
62	487x	if (identical(e[[1]], as.name("==")) && length(e) == 3) {
63	7x	found <<- c(found, unit_col(e[[2]]), unit_col(e[[3]]));
64		}
65	906x	for (arg in as.list(e)[-1]) walk(arg);
66		}
67		};
68	106x	walk(expr);
69	106x	unique(found)
70		}
71
72		##' Apply a Subsetting Rule to TMA Contexts (Internal)
73		#'
74		#' Internal helper to apply a logical subsetting rule ("hoo rule") to each unit's context in a TMA model object.
75		#' Updates the contexts for each unit by including only rows that match the rule.
76		#'
77		#' @param x A TMA model object as produced by [units()].
78		#' @param ... Logical expression(s) specifying the subsetting rule to apply. If not provided, uses the `rule` argument.
79		#' @param rule A single logical expression to use as the subsetting rule (alternative to ...).
80		#'
81		#' @return The input TMA model object with updated contexts for each unit, where each context contains only rows matching the rule.
82		hoo <- function(x, ..., rule = NULL) {
83	103x	units <- x$`_function.params`$units;
84	103x	unit_contexts <- x$model$contexts;
85
86	103x	hoo_args <- substitute(...);
87	103x	if( is.null(hoo_args) ) {
88	103x	hoo_args <- rule;
89		}
90
91	103x	raw_input <- x$model$raw.input;
92
93		# UNIT$<col> holds every distinct value of <col> across the unit's rows, so
94		# `col == UNIT$col` recycles when a unit spans several values and silently
95		# selects the wrong rows. Warn (once per rule) when that happens.
96	103x	eq_unit_cols <- unit_equality_columns(hoo_args);
97	103x	warned <- FALSE;
98
99	103x	unique_units <- unique(units);
100	103x	updated_contexts <- lapply(seq(nrow(unique_units)), function(i) {
101	627x	this_unit <- unique_units[i,];
102	627x	this_unit <- this_unit[, lapply(.SD, reclass, "ena.metadata"), .SDcols = colnames(this_unit)];
103
104	627x	unit_label <- paste(this_unit, collapse = "::");
105		# UNIT <- raw_input[as.list(this_unit), , on = names(this_unit)];
106	627x	UNIT <- mapply(raw_input[as.list(this_unit), , on = names(this_unit)], FUN = unique, SIMPLIFY = FALSE);
107
108	627x	if (!warned && length(eq_unit_cols) > 0) {
109	50x	multi <- eq_unit_cols[lengths(UNIT[eq_unit_cols]) > 1];
110	50x	if (length(multi) > 0) {
111	2x	warned <<- TRUE;
112	2x	warning(sprintf(paste0(
113	2x	"Conversation rule compares %s to UNIT with `==`, but unit '%s' has ",
114	2x	"more than one value for it, so `==` recycles and selects the wrong ",
115	2x	"rows. Use `%%in%%` instead, e.g. `%s %%in%% UNIT$%s`."),
116	2x	paste0("`", multi, "`", collapse = ", "), unit_label, multi[1], multi[1]),
117	2x	call. = FALSE);
118		}
119		}
120
121	627x	this_context <- unit_contexts[[unit_label]];
122	627x	ret <- sort(unique(c(this_context, raw_input[eval(hoo_args), , which = TRUE])));
123	626x	attr(x = ret, which = "tma.unit") <- this_unit;
124	626x	ret
125		});
126	102x	names(updated_contexts) <- names(unit_contexts)
127
128	102x	x$model$contexts <- updated_contexts; #unit_contexts;
129
130	102x	x
131		}
132
133		#' Capture Subsetting Rules as Expressions
134		#'
135		#' 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.
136		#'
137		#' @param ... Logical expressions specifying the conditions for subsetting data. These expressions are captured unevaluated and returned as a list.
138		#'
139		#' @return A list of unevaluated expressions representing subsetting rules.
140		#'
141		#' @examples
142		#'
143		#' rules(
144		#' modality %in% "chat" & chatGroup %in% UNIT$chatGroup & condition %in% UNIT$condition,
145		#' modality %in% "resource" & userID %in% UNIT$userID & condition %in% UNIT$condition
146		#' )
147		#'
148		#' @export
149		rules <- function(...) {
150	18x	rlang::exprs(...)
151		}
152
153		#' Conversation rules
154		#'
155		#' @param ... list of rules
156		#'
157		#' @return callable expressions, see `rlang::exprs`
158		#' @export
159		conversation_rules <- function(...) {
160	36x	rlang::exprs(...)
161		}
162
163		##' Create Contexts for Units of Analysis
164		#'
165		#' 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.
166		#'
167		#' @param x A data.frame or TMA model object containing the raw input data.
168		#' @param hoo_rules A list of logical expressions (see [rules()]) specifying how to subset the data for each context/unit.
169		#' @param units_by Character vector of column names to use for defining units of analysis (e.g., c("userID", "condition")).
170		#' @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).
171		#'
172		#' @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.
173		#'
174		#' @details
175		#' 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.
176		#'
177		#' @examples
178		#' data(test_mockdata, package = "tma")
179		#' mock_data <- test_mockdata[test_mockdata$chatGroup == "PAM",]
180		#' unit_cols <- c("userID", "condition")
181		#' codes <- c("A", "B", "C")
182		#' HOO_rules_model <- rules(
183		#' modality %in% "chat" & chatGroup %in% UNIT$chatGroup & condition %in% UNIT$condition,
184		#' modality %in% "resource" & userID %in% UNIT$userID & condition %in% UNIT$condition
185		#' )
186		#'
187		#' context_model <- contexts(
188		#' x = mock_data,
189		#' units = unit_cols,
190		#' hoo_rules = HOO_rules_model
191		#' )
192		#' str(context_model$model$contexts)
193		#'
194		#' @export
195		contexts <- function(x, hoo_rules, units_by = NULL, split_rules = NULL) {
196	85x	x_ <- units(x, units_by);
197
198	85x	for(r in hoo_rules) {
199	103x	x_ <- hoo(x_, rule = r);
200		}
201
202	84x	raw_input <- x_$model$raw.input;
203	84x	split_expr_valid <- TRUE;
204	84x	err_found <- 0;
205	84x	tryCatch(expr = rlang::enexpr(split_rules), error = function(e) {
206	!	err_found <<- 1;
207	!	print(e$message)
208	84x	}, warning = function(w) {
209	!	err_found <<- 2;
210	84x	}, finally = {
211	84x	if(err_found != 0) {
212	!	split_expr_valid <- FALSE;
213		}
214		})
215
216	84x	if(split_expr_valid) {
217	84x	split_rules_expr <- rlang::enexpr(split_rules);
218
219	84x	if( !is.null(split_rules_expr) ) {
220	4x	unit_contexts <- x_$model$contexts;
221	4x	model_units <- x_$`_function.params`$units;
222
223		# if ( is.function (split_rules) ) {
224	4x	if( is(split_rules, "function") ) {
225	4x	unique_units <- unique(model_units);
226	4x	unit_contexts_res <- apply(unique_units, 1, function(u) {
227	192x	unit_label <- paste(u, collapse = "::");
228	192x	res <- do.call(what = split_rules, args = list(unit = u, raw_input[unit_contexts[[unit_label]]]));
229	192x	attr(res, "tma.unit") <- attr(unit_contexts[[unit_label]], "tma.unit");
230	192x	res2 <- lapply(res, function(r) {
231	384x	r[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(r));
232	384x	attr(r, "tma.unit") <- attr(res, "tma.unit");
233	384x	attr(r, "tma.unit_rows") <- which(r$QEUNIT == unit_label)
234	384x	r
235		});
236	192x	res2
237		});
238	4x	names(unit_contexts_res) <- apply(unique_units, 1, paste, collapse = "::"); #names(unit_contexts);
239	4x	unit_contexts <- unit_contexts_res;
240		}
241		else {
242	!	if( !inherits(x = split_rules_expr, what = "call") ) {
243	!	for(i in seq(split_rules_expr)) {
244	!	unit_contexts <- lapply(unit_contexts, function(uc) {
245	!	lapply(split(x = raw_input[uc,], by = as.character(split_rules)), function(x) {
246	!	unit_tbl <- attr(x = uc, "tma.unit");
247	!	unit_label <- paste0(unit_tbl, collapse = "::");
248
249	!	x[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(x));
250	!	attr(x = x, which = "tma.unit") <- attr(x = uc, "tma.unit");
251	!	attr(x = x, which = "tma.unit_rows") <- which(x$QEUNIT == unit_label);
252	!	x
253		});
254		})
255		}
256		}
257		else {
258	!	for( i in seq(split_rules) ) {
259	!	if ( is.name(split_rules[[i]]) ){
260		# unit_contexts <- lapply(unit_contexts, split, by = as.character(split_rules[[i]]))
261	!	unit_contexts <- lapply(unit_contexts, function(uc) {
262	!	split(x = raw_input[uc,], by = as.character(split_rules[[i]]))
263		})
264		}
265		else {
266	!	stop("THIS NEEDS UPDATING (1)")
267	!	units_to_split <- model_units[eval(split_rules[[i]][[2]]), , which = TRUE]
268	!	unit_contexts[units_to_split] <- lapply(unit_contexts[units_to_split], split, by = names(split_rules[i]))
269		}
270		}
271		}
272		}
273
274	4x	x_$model$contexts <- unit_contexts;
275		}
276		else {
277	80x	unit_contexts <- x_$model$contexts;
278	80x	model_units <- x_$`_function.params`$units;
279	80x	unique_units <- unique(model_units);
280	80x	unit_contexts_res <- apply(unique_units, 1, function(u) {
281		# unit_label <- paste(u, collapse = "::");
282	380x	unit_label <- paste(trimws(u), collapse = "::");
283	380x	res <- raw_input[unit_contexts[[unit_label]]];
284	380x	res[[ATTR_NAMES$CONTEXT_COL_ID]] <- seq.int(nrow(res));
285
286	380x	attr(res, "tma.unit") <- attr(unit_contexts[[unit_label]], "tma.unit");
287	380x	attr(res, "tma.unit_rows") <- which(res$QEUNIT == unit_label);
288	380x	res
289		});
290	80x	names(unit_contexts_res) <- apply(unique_units, 1, paste, collapse = "::"); #names(unit_contexts);
291	80x	unit_contexts <- unit_contexts_res;
292	80x	x_$model$contexts <- unit_contexts;
293		}
294		}
295
296		# x_list <- list2env(x_);
297		# class(x_list) <- c("ena.set", class(x_list));
298		# return(x_list);
299	84x	x_
300		}

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 each line's connection counts before they are summed per unit (unordered only; ordered counts are always summed raw). Ignored when `weight_by` is given.
12		#' @param weight_by Weight model applied to each line's connection counts before they are summed into the unit network (= rENA's `weight.by`): `"binary"` (unordered: each positive count becomes 1; ordered: raw directed counts), `"product"` (the raw, non-binarized counts), `"sqrt"`, or `"log1p"` (alias `"log"`). For unordered networks the weight is applied after each line is folded to the upper triangle; for ordered networks, to each directed cell. Defaults to `"binary"` when `binary = TRUE`, otherwise `"product"`. `model$row.connection.counts` always holds the raw, unweighted line counts.
13		#' @param misses Logical; if TRUE, also accumulate missed co-occurrences: for each response line, the (window-weighted) ground count of code i when code j is absent from the response, with no response self-term. Misses follow the connection counts through the same steps: ordered models keep the directed layout (ground i -> response j); unordered models fold each line to the upper triangle (i & j = i -> j + j -> i, self-misses dropped), and `weight_by` is applied per line. Defaults to TRUE; set FALSE to skip them (less memory for many codes or long data).
14		#' @param self_connections Logical, default FALSE. Unordered networks only: also include each code's self-connection (ground i x response i, weighted per line like the other columns) as a column of `connection.counts` (and of `miss.counts`, the self-misses), so the model's line weights, rotation and nodes include them. Columns then run A & A, A & B, B & B, A & C, ... (the upper triangle with the diagonal; see the adjacency key). Ordered networks always include the diagonal, so it has no effect there. `self.connection.counts` is kept separately either way.
15		#'
16		#' @return The input `context_model` with additional fields:
17		#' \item{connection.counts}{A data.table of accumulated connection counts for each unit.}
18		#' \item{model$row.connection.counts}{A data.table of row-level connection matrices for each unit.}
19		#' \item{self.connection.counts}{A data.table of each unit's self-connections, one column per code: each line's ground count of the code times its response count (the ordered network's diagonal, which unordered networks fold away), weighted per line by `weight_by` and summed per unit. Kept for ordered and unordered models; not used in the model.}
20		#' \item{model$row.self.connection.counts}{A data.table of raw, unweighted per-line self-connections.}
21		#' \item{miss.counts}{With `misses = TRUE`: a data.table of accumulated missed co-occurrences for each unit.}
22		#' \item{self.miss.counts, model$row.self.miss.counts}{With `misses = TRUE`: self-misses (the code in the ground, absent from the response), per unit and per line, as for self-connections.}
23		#' \item{model$row.miss.counts}{With `misses = TRUE`: a data.table of raw, unweighted row-level missed co-occurrences.}
24		#' \item{meta.data}{A data.table of metadata columns for each unit.}
25		#' The class of the returned object is updated to reflect the type of accumulation (ordered or unordered).
26		#'
27		#' @details
28		#' 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.
29		#'
30		#' @export
31		accumulate <- function(
32		context_model,
33		codes,
34		tensor = context_tensor(context_model$model$raw.input),
35		time_column = NULL,
36		ordered = FALSE,
37		binary = TRUE,
38		weight_by = NULL,
39		misses = TRUE,
40		self_connections = FALSE
41		) {
42		# Unordered only: ordered networks always carry the diagonal.
43	74x	diagonal <- isTRUE(self_connections) && !isTRUE(ordered)
44
45
46	74x	if (is.null(weight_by)) {
47	36x	weight_by <- if (isTRUE(binary)) "binary" else "product"
48		}
49	74x	if (!is.character(weight_by) \|\| length(weight_by) != 1) {
50	1x	stop("`weight_by` must be one of 'binary', 'product', 'sqrt', 'log1p'.")
51		}
52
53	73x	send_cols = attr(tensor, "sender_cols");
54	73x	recv_cols = attr(tensor, "receiver_cols");
55	73x	mode_cols = attr(tensor, "mode_column");
56
57	73x	if(is.null(time_column)) {
58	65x	time_column <- ATTR_NAMES$CONTEXT_COL_ID;
59		}
60
61	73x	context_model$rotation <- structure(list(
62	73x	codes = codes,
63	73x	adjacency.key = adjacency_key(codes, !ordered, diagonal = diagonal)
64	73x	), class = c("ena.rotation.set", "list"));
65	73x	adj_vector_names <- colnames(context_model$rotation$adjacency.key);
66	73x	adj_vector_names_full <- colnames(adjacency_key(codes, FALSE));
67
68	73x	ind_mat <- matrix(nrow = length(codes), ncol = length(codes));
69	73x	units_by <- context_model$`_function.params`$units.by;
70	73x	meta_cols <- c("QEID", "QEUNIT", units_by);
71
72	73x	mode_dim_1 <- dim(tensor)[1] == 1 && attr(tensor, "mode_column") == ATTR_NAMES$CONTEXT_ID;
73
74		# Cache tensor attributes outside the loop
75	73x	tensor_dim <- attr(tensor, "dim")
76	73x	tensor_sender_inds <- attr(tensor, "sender_inds") - 1
77	73x	tensor_receiver_inds <- attr(tensor, "receiver_inds") - 1
78	73x	tensor_mode_inds <- attr(tensor, "mode_inds") - 1
79
80		# Levels along each tensor axis, in the order context_tensor() laid them out
81		# (sorted unique values across the whole dataset), one entry per column of
82		# `cols_to_encode`. A column with no tensor axis (the context-id placeholder
83		# rENA passes as the mode column) gets NULL and its values pass through.
84	73x	cols_to_encode <- c(send_cols, recv_cols, mode_cols)
85	73x	tensor_levels <- dimnames(tensor)
86	73x	axis_levels <- c(
87	73x	lapply(seq_along(send_cols), function(i) tensor_levels[[paste0("sender_", i)]]),
88	73x	lapply(seq_along(recv_cols), function(i) tensor_levels[[paste0("receiver_", i)]]),
89	73x	lapply(seq_along(mode_cols), function(i) tensor_levels[["modes"]])
90		)
91
92		# Position of each row's value along its tensor axis (1-based). Looked up in
93		# the tensor's own levels -- never re-encoded per context -- so a level maps
94		# to the same slice of the tensor whichever levels a context happens to
95		# contain, for character-valued and numeric columns alike.
96	73x	context_lookup <- function(ctx_rows) {
97	691x	lookup <- vapply(seq_along(cols_to_encode), function(i) {
98	718x	vals <- ctx_rows[[cols_to_encode[i]]]
99	718x	lv <- axis_levels[[i]]
100	365x	if (is.null(lv)) return(as.numeric(vals))
101	353x	pos <- match(as.character(vals), lv)
102	353x	if (anyNA(pos)) {
103	1x	stop("Values in column '", cols_to_encode[i], "' are not levels of the ",
104	1x	"tensor: ", paste(unique(vals[is.na(pos)]), collapse = ", "),
105	1x	". Build the tensor from the same data as the contexts.")
106		}
107	352x	as.numeric(pos)
108	691x	}, numeric(nrow(ctx_rows)));
109	690x	matrix(lookup, nrow = nrow(ctx_rows), ncol = length(cols_to_encode))
110		}
111
112		# One libtma call per context (accumulate_unit_networks): it folds unordered
113		# rows, applies the weight model per line, sums the lines and pulls out the
114		# self-connection diagonal, for hits and (with misses) missed co-occurrences.
115		# R only stacks the per-line rows into tables and adds up each unit's
116		# per-context vectors (unit vectors are additive over lines).
117	73x	n_codes <- length(codes);
118	73x	result_cpp <- lapply(context_model$model$contexts, function(ctx) {
119	451x	ctx_fun <- function(ctx_o) {
120	691x	ctx__ <- data.table::copy(ctx_o);
121	691x	unit_context_lookup <- context_lookup(ctx__)
122
123	690x	unit_rows <- attr(ctx__, "tma.unit_rows")
124	690x	unit_to_last <- seq.int(last(unit_rows))
125	690x	ctx_unit_to_last <- ctx__[unit_to_last, ]
126	690x	res <- accumulate_unit_networks(
127	690x	tensor,
128	690x	tensor_dim,
129	690x	tensor_sender_inds,
130	690x	tensor_receiver_inds,
131	690x	tensor_mode_inds,
132	690x	unit_context_lookup[unit_to_last, , drop = FALSE] - 1,
133	690x	unit_rows - 1,
134	690x	as.matrix(ctx_unit_to_last[ , ..codes]),
135	690x	ctx_unit_to_last[[time_column]],
136	690x	ordered = isTRUE(ordered),
137	690x	weight = weight_by,
138	690x	misses = isTRUE(misses),
139	690x	diagonal = diagonal
140		)
141	689x	res$meta <- ctx_o[unit_rows, meta_cols, with = FALSE];
142	689x	res
143		}
144
145	240x	if (is.data.frame(ctx)) list(ctx_fun(ctx)) else lapply(ctx, ctx_fun)
146		});
147	71x	parts <- unlist(result_cpp, recursive = FALSE);
148
149	71x	conn_names <- if (isTRUE(ordered)) adj_vector_names_full else adj_vector_names;
150
151		# Per-line rows: meta columns + one column per connection (or code), in QEID
152		# order, as the row tables have always been laid out.
153	71x	row_table <- function(field, cols, table_class) {
154	278x	rows <- data.table::rbindlist(lapply(parts, function(pt) {
155	2734x	m <- pt[[field]];
156	2734x	dt <- data.table::as.data.table(matrix(m, nrow = nrow(m), dimnames = list(NULL, cols)));
157	2734x	cbind(pt$meta, dt)
158		}));
159	278x	rows <- reclass_columns(rows, rep(c("ena.metadata", "ena.co.occurrence"), c(length(meta_cols), length(cols))));
160	278x	data.table::setorderv(rows, "QEID");
161	278x	reclass(x = rows, table_class)
162		};
163
164		# Unit vectors: each unit's per-context vectors summed, units in the order
165		# they first appear by QEID.
166	71x	unit_of <- vapply(parts, function(pt) as.character(pt$meta$QEUNIT[1]), character(1));
167	71x	first_qeid <- tapply(vapply(parts, function(pt) min(pt$meta$QEID), numeric(1)), unit_of, min);
168	71x	unit_order <- names(sort(first_qeid));
169	71x	unit_matrix <- function(field, cols) {
170	278x	m <- rowsum(do.call(rbind, lapply(parts, `[[`, field)), unit_of, reorder = FALSE);
171	278x	m <- m[unit_order, , drop = FALSE];
172	278x	colnames(m) <- cols;
173	278x	m
174		};
175	71x	unit_first_meta <- function(by_cols) {
176	139x	first <- data.table::rbindlist(lapply(parts, `[[`, "meta"));
177	139x	data.table::setorderv(first, "QEID");
178	139x	first <- first[!duplicated(first$QEUNIT), ];
179	139x	first <- first[match(unit_order, as.character(first$QEUNIT)), by_cols, with = FALSE];
180	139x	first[, lapply(.SD, reclass, "ena.metadata"), .SDcols = by_cols]
181		};
182
183	71x	row_connection_counts <- row_table("row_connection_counts", conn_names,
184	71x	if (isTRUE(ordered)) c("ordered.row.connections", "row.connections", "ena.matrix")
185	71x	else c("unordered.row.connections", "row.connections", "ena.matrix"));
186	71x	context_model$model$row.connection.counts <- row_connection_counts;
187
188		# Column classes match the earlier aggregation: ordered unit sums keep the
189		# ena.co.occurrence class, unordered ones are plain numerics; ordered tables
190		# lead with the units_by columns, unordered with QEUNIT.
191	71x	unit_table <- function(field) {
192	139x	m <- unit_matrix(field, conn_names);
193	139x	vals <- lapply(seq_len(ncol(m)), function(j) {
194	849x	v <- unname(m[, j]);
195	444x	if (isTRUE(ordered)) reclass(v, "ena.co.occurrence") else v
196		});
197	139x	names(vals) <- conn_names;
198	139x	cbind(unit_first_meta(if (isTRUE(ordered)) units_by else "QEUNIT"), data.table::as.data.table(vals))
199		};
200
201	71x	cc_type <- NULL;
202	71x	if(isTRUE(ordered)) {
203	23x	class(context_model) <- c("ena.ordered.set", class(context_model));
204	23x	connection_counts <- reclass(x = unit_table("connection_counts"), c("ordered.ena.connections", "ena.connections", "ena.matrix"));
205	23x	cc_type <- "ordered.ena.connections";
206		}
207		else {
208	48x	class(context_model) <- c("ena.unordered.set", class(context_model));
209	48x	connection_counts <- unit_table("connection_counts");
210	48x	cc_type <- "unordered.ena.connections";
211		}
212
213	71x	cc_meta <- data.table::rbindlist(lapply(result_cpp, function(rc) rc[[1]]$meta[1, c("QEUNIT", units_by), with = FALSE]));
214	71x	cc_meta$ENA_UNIT <- context_model$model$unit.labels;
215	71x	cc_meta <- cc_meta[, lapply(.SD, reclass, "ena.metadata"), .SDcols = colnames(cc_meta)];
216
217	71x	connection_counts <- cbind(cc_meta, connection_counts)
218	71x	connection_counts <- reclass(connection_counts, c(cc_type, "ena.connections", "ena.matrix"));
219	71x	context_model$connection.counts <- connection_counts;
220
221		# Self-connections: each line's ground i x response i (the ordered diagonal,
222		# which unordered networks fold away), one column per code.
223	71x	self_table <- function(field) {
224	139x	m <- unit_matrix(field, codes);
225	139x	vals <- lapply(seq_len(ncol(m)), function(j) reclass(unname(m[, j]), "ena.co.occurrence"));
226	139x	names(vals) <- codes;
227	139x	reclass(cbind(cc_meta, data.table::as.data.table(vals)), c("self.connections", "ena.matrix"))
228		};
229	71x	context_model$self.connection.counts <- self_table("self_connection_counts");
230	71x	context_model$model$row.self.connection.counts <- row_table("row_self_connection_counts", codes, c("row.self.connections", "ena.matrix"));
231
232	71x	if (isTRUE(misses)) {
233	68x	context_model$model$row.miss.counts <- row_table("row_miss_counts", conn_names,
234	68x	if (isTRUE(ordered)) c("ordered.row.connections", "row.connections", "ena.matrix")
235	68x	else c("unordered.row.connections", "row.connections", "ena.matrix"));
236	68x	miss_counts <- if (isTRUE(ordered))
237	68x	reclass(x = unit_table("miss_counts"), c("ordered.ena.connections", "ena.connections", "ena.matrix"))
238	68x	else unit_table("miss_counts");
239	68x	context_model$miss.counts <- reclass(cbind(cc_meta, miss_counts), c(cc_type, "ena.connections", "ena.matrix"));
240	68x	context_model$self.miss.counts <- self_table("self_miss_counts");
241	68x	context_model$model$row.self.miss.counts <- row_table("row_self_miss_counts", codes, c("row.self.connections", "ena.matrix"));
242		}
243
244	71x	context_model$meta.data <- context_model$connection.counts[, sapply(context_model$connection.counts, is, "ena.metadata"), with = FALSE];
245	71x	class(context_model$meta.data) = c("ena.matrix", class(context_model$meta.data));
246
247		# 5a: persist the windowing config so the accumulated object is self-describing
248		# (recreate-the-model intent) and consumable by tma.conversations2, which needs
249		# the resolved per-modality window/weight tensor to reproduce the exact windows.
250		# See design/dataview-flexible-window.md.
251	71x	context_model$`_function.params`$tensor <- tensor;
252	71x	context_model$`_function.params`$mode_column <- mode_cols;
253	71x	context_model$`_function.params`$codes <- codes;
254	71x	context_model$`_function.params`$time_column <- time_column;
255	71x	context_model$`_function.params`$ordered <- ordered;
256	71x	context_model$`_function.params`$binary <- binary;
257	71x	context_model$`_function.params`$weight_by <- weight_by;
258	71x	context_model$`_function.params`$misses <- isTRUE(misses);
259	71x	context_model$`_function.params`$self_connections <- diagonal;
260
261	71x	return(context_model);
262		}

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

1		# =============================================================================
2		# tma_stability.R — Hyperparameter stability recommendation grid
3		# =============================================================================
4
5		#' Evaluate hyperparameter stability grid for door pooling
6		#'
7		#' Computes pairwise trajectory distance matrices across a grid of lookback sizes
8		#' or alpha values, then computes the matrix correlation between adjacent parameter
9		#' settings to find the "elbow" where trajectories stabilize.
10		#'
11		#' @param accum Object from \code{tma::accumulate()}.
12		#' @param unit_col Name of column identifying unit/speaker.
13		#' @param time_col Name of column identifying monotonic time.
14		#' @param param_type "lookback" or "ema".
15		#' @param param_values Numeric vector of parameter values to evaluate.
16		#' @param x_col Column name for x coordinate (default auto).
17		#' @param y_col Column name for y coordinate (default auto).
18		#' @param max_degree Polynomial degree for trajectory curves (default 3).
19		#' @return Data frame of parameter values and stability correlations.
20		#' @export
21		tma_stability_grid <- function(
22		accum,
23		unit_col,
24		time_col,
25		param_type = c("lookback", "ema"),
26		param_values = NULL,
27		x_col = NULL,
28		y_col = NULL,
29		max_degree = 3L) {
30	!	param_type <- match.arg(param_type)
31
32	!	if (is.null(param_values)) {
33	!	param_values <- if (param_type == "lookback") {
34	!	seq(5L, 50L, by = 5L)
35		} else {
36	!	seq(0.05, 0.5, by = 0.05)
37		}
38		}
39
40	!	raw_df <- accum$model$row.connection.counts
41	!	if (is.null(raw_df)) {
42	!	raw_df <- accum$connection.counts
43		}
44
45	!	pair_cols <- cooccurrence_pair_column_names(raw_df)
46	!	if (!length(pair_cols)) {
47	!	stop("No co-occurrence columns found in accumulation.")
48		}
49
50		# Accumulate / replace door for each parameter value
51	!	models <- lapply(param_values, function(pv) {
52	!	d_df <- if (param_type == "lookback") {
53	!	door(
54	!	data = raw_df,
55	!	method = "Lookback",
56	!	unit_col = unit_col,
57	!	time_col = time_col,
58	!	lookback_size = as.integer(pv),
59	!	verbose = FALSE
60		)
61		} else {
62	!	door(
63	!	data = raw_df,
64	!	method = "EMA",
65	!	unit_col = unit_col,
66	!	time_col = time_col,
67	!	alpha = as.numeric(pv),
68	!	verbose = FALSE
69		)
70		}
71
72	!	acc_mod <- replace_door(accum, d_df)
73	!	acc_mod
74		})
75
76		# Compute stability correlations between adjacent parameter values
77	!	n_params <- length(param_values)
78	!	corrs <- numeric(n_params)
79	!	corrs[1L] <- 1.0
80
81	!	if (n_params > 1L) {
82	!	for (i in 2:n_params) {
83	!	m1 <- models[[i - 1L]]$connection.counts
84	!	m2 <- models[[i]]$connection.counts
85
86		# Select numeric connection columns
87	!	c1 <- as.matrix(m1[, pair_cols, with = FALSE])
88	!	c2 <- as.matrix(m2[, pair_cols, with = FALSE])
89
90	!	corrs[i] <- libqe::dist_dist_correlation(c1, c2)
91		}
92		}
93
94	!	data.frame(
95	!	param = param_values,
96	!	correlation = corrs,
97	!	param_type = param_type,
98	!	stringsAsFactors = FALSE
99		)
100		}

1		# =============================================================================
2		# tma_trajectory.R — Trajectory curve fitting, derivatives, distance, and following
3		# =============================================================================
4
5		#' Fit polynomial parametric curve to ETM/TMA points normalized to t in [0, 1]
6		#'
7		#' @param pts data.frame or matrix of points
8		#' @param x_col Column name for x coordinate
9		#' @param y_col Column name for y coordinate
10		#' @param time_col Column name for time ordering
11		#' @param degree Fixed polynomial degree (optional)
12		#' @param max_degree Maximum degree to evaluate for LOOCV-2D (default 3)
13		#' @param criterion "loocv" or "aic"
14		#' @param fit_curve_with_zero_pts Logical; whether to retain (0,0) points
15		#' @param zero_eps Tolerance for detecting (0,0) points
16		#' @return List with fitted curve parameters, prediction closures, and metadata
17		#' @export
18		tma_fit_poly_curve <- function(
19		pts,
20		x_col = NULL,
21		y_col = NULL,
22		time_col = "RowID",
23		degree = NULL,
24		max_degree = 3L,
25		criterion = c("loocv", "aic"),
26		fit_curve_with_zero_pts = FALSE,
27		zero_eps = 1e-8) {
28	3x	criterion <- match.arg(criterion)
29	3x	pts <- as.data.frame(pts)
30
31	3x	if (is.null(x_col) \|\| !(x_col %in% names(pts))) {
32	!	x_col <- intersect(c("SVD1", "MR1", "GMR1", "X1", "x"), names(pts))[1]
33		}
34	3x	if (is.null(y_col) \|\| !(y_col %in% names(pts))) {
35	!	y_col <- intersect(c("SVD2", "MR2", "GMR2", "X2", "y"), names(pts))[1]
36		}
37	3x	if (is.na(x_col) \|\| is.na(y_col)) {
38	!	stop("Cannot find dimension columns (SVD1/MR1/GMR1 and SVD2/MR2/GMR2) in pts.")
39		}
40
41	3x	if (time_col %in% names(pts)) {
42	3x	pts <- pts[order(pts[[time_col]]), , drop = FALSE]
43		}
44
45	3x	if (!isTRUE(fit_curve_with_zero_pts)) {
46	!	keep <- (abs(pts[[x_col]]) > zero_eps) \| (abs(pts[[y_col]]) > zero_eps)
47	!	pts <- pts[keep, , drop = FALSE]
48		}
49
50	3x	n <- nrow(pts)
51	3x	if (n < 2L) {
52	!	stop("Need at least 2 non-zero points to fit a curve.")
53		}
54
55	3x	points_mat <- as.matrix(pts[, c(x_col, y_col), drop = FALSE])
56	3x	fixed_deg <- if (!is.null(degree)) as.integer(degree) else 0L
57
58	3x	fit_res <- libqe::fit_trajectory_poly(
59	3x	points = points_mat,
60	3x	t = numeric(0),
61	3x	max_degree = as.integer(max_degree),
62	3x	fixed_degree = fixed_deg,
63	3x	criterion = criterion
64		)
65
66	3x	coeffs_x <- fit_res$coeffs_x
67	3x	coeffs_y <- fit_res$coeffs_y
68
69	3x	pred_x <- function(t_new) {
70	!	t_v <- as.numeric(t_new)
71	!	res <- libqe::eval_trajectory_curve(coeffs_x, coeffs_y, t_v)
72	!	res[, 1L]
73		}
74
75	3x	pred_y <- function(t_new) {
76	!	t_v <- as.numeric(t_new)
77	!	res <- libqe::eval_trajectory_curve(coeffs_x, coeffs_y, t_v)
78	!	res[, 2L]
79		}
80
81	3x	structure(
82	3x	list(
83	3x	pred_x = pred_x,
84	3x	pred_y = pred_y,
85	3x	coeffs_x = coeffs_x,
86	3x	coeffs_y = coeffs_y,
87	3x	degree = fit_res$degree,
88	3x	cv_error = fit_res$cv_error,
89	3x	aic = fit_res$aic,
90	3x	t = fit_res$t,
91	3x	fitted_points = fit_res$fitted_points,
92	3x	n = n,
93	3x	x_col = x_col,
94	3x	y_col = y_col,
95	3x	time_col = time_col,
96	3x	pts = pts
97		),
98	3x	class = "tma_poly_curve"
99		)
100		}
101
102		#' Evaluate analytical derivatives of a fitted polynomial curve
103		#'
104		#' @param curve Output of \code{tma_fit_poly_curve()}
105		#' @param n_eval Number of evaluation points in [0, 1]
106		#' @return Data frame of evaluated positions, velocity, speed, acceleration, heading turn rate, curvature
107		#' @export
108		tma_poly_derivative_profile <- function(curve, n_eval = 1000L) {
109	1x	if (is.null(curve$coeffs_x) \|\| is.null(curve$coeffs_y)) {
110	!	stop("`curve` must be a valid tma_poly_curve object.")
111		}
112	1x	n_eval <- max(10L, as.integer(n_eval))
113	1x	t_eval <- seq(0, 1, length.out = n_eval)
114
115	1x	d <- libqe::eval_trajectory_derivatives(curve$coeffs_x, curve$coeffs_y, t_eval)
116
117		# Also evaluate exact x and y coordinates
118	1x	pts <- libqe::eval_trajectory_curve(curve$coeffs_x, curve$coeffs_y, t_eval)
119
120	1x	data.frame(
121	1x	t = d$t,
122	1x	x = pts[, 1L],
123	1x	y = pts[, 2L],
124	1x	dx = d$vx,
125	1x	dy = d$vy,
126	1x	speed = d$speed,
127	1x	d2x = d$ax,
128	1x	d2y = d$ay,
129	1x	omega = d$heading_rate,
130	1x	kappa = d$curvature,
131	1x	stringsAsFactors = FALSE
132		)
133		}
134
135		#' Locate critical points (heading turns, velocity zeros, inflections, curvature peaks)
136		#'
137		#' @param profile Output of \code{tma_poly_derivative_profile()}
138		#' @param speed_tol Minimum speed threshold for heading turns
139		#' @param zero_tol Numerical zero threshold
140		#' @param top_curvature Max curvature peaks to return
141		#' @return List of critical points
142		#' @export
143		tma_poly_critical_points <- function(
144		profile,
145		speed_tol = 1e-6,
146		zero_tol = 1e-8,
147		top_curvature = 5L) {
148
149	!	.crossings <- function(t, z, x, y, label, speed = NULL, speed_tol = 1e-6) {
150	!	n <- length(t)
151	!	if (n < 3L) {
152	!	return(data.frame(
153	!	type = character(), t = numeric(), x = numeric(), y = numeric(),
154	!	value = numeric(), stringsAsFactors = FALSE
155		))
156		}
157	!	rows <- list()
158	!	for (i in seq_len(n - 1L)) {
159	!	z1 <- z[i]; z2 <- z[i + 1L]
160	!	if (is.na(z1) \|\| is.na(z2)) next
161	!	if (abs(z1) < zero_tol) z1 <- 0
162	!	if (abs(z2) < zero_tol) z2 <- 0
163	!	if (z1 == 0 && z2 == 0) next
164	!	if (z1 * z2 > 0) next
165	!	if (!is.null(speed) && (speed[i] < speed_tol \|\| speed[i + 1L] < speed_tol)) next
166	!	denom <- z2 - z1
167	!	frac <- if (abs(denom) < 1e-15) 0.5 else (-z1) / denom
168	!	frac <- min(max(frac, 0), 1)
169	!	ti <- t[i] + frac * (t[i + 1L] - t[i])
170	!	xi <- x[i] + frac * (x[i + 1L] - x[i])
171	!	yi <- y[i] + frac * (y[i + 1L] - y[i])
172	!	rows[[length(rows) + 1L]] <- data.frame(
173	!	type = label, t = ti, x = xi, y = yi,
174	!	value = 0,
175	!	stringsAsFactors = FALSE
176		)
177		}
178	!	if (!length(rows)) {
179	!	return(data.frame(
180	!	type = character(), t = numeric(), x = numeric(), y = numeric(),
181	!	value = numeric(), stringsAsFactors = FALSE
182		))
183		}
184	!	do.call(rbind, rows)
185		}
186
187	!	inner <- profile$t > 0 & profile$t < 1
188	!	prof <- profile[inner, , drop = FALSE]
189
190	!	heading_turns <- .crossings(
191	!	prof$t, prof$omega, prof$x, prof$y, "heading_turn",
192	!	speed = prof$speed, speed_tol = speed_tol
193		)
194	!	x_velocity_zeros <- .crossings(
195	!	prof$t, prof$dx, prof$x, prof$y, "x_velocity_zero"
196		)
197	!	y_velocity_zeros <- .crossings(
198	!	prof$t, prof$dy, prof$x, prof$y, "y_velocity_zero"
199		)
200	!	x_inflections <- .crossings(
201	!	prof$t, prof$d2x, prof$x, prof$y, "x_second_deriv_zero"
202		)
203	!	y_inflections <- .crossings(
204	!	prof$t, prof$d2y, prof$x, prof$y, "y_second_deriv_zero"
205		)
206
207		# Curvature peaks
208	!	ak <- abs(prof$kappa)
209	!	is_peak <- rep(FALSE, nrow(prof))
210	!	if (nrow(prof) >= 3L) {
211	!	for (i in 2:(nrow(prof) - 1L)) {
212	!	if (prof$speed[i] < speed_tol) next
213	!	if (ak[i] > ak[i - 1L] && ak[i] > ak[i + 1L]) is_peak[i] <- TRUE
214		}
215		}
216	!	idx <- which(is_peak & prof$t > 0 & prof$t < 1)
217	!	curvature_peaks <- if (length(idx) > 0L) {
218	!	ord <- order(ak[idx], decreasing = TRUE)
219	!	idx <- idx[ord]
220	!	top_n <- min(length(idx), as.integer(top_curvature))
221	!	idx <- idx[seq_len(top_n)]
222	!	data.frame(
223	!	type = "curvature_peak",
224	!	t = prof$t[idx],
225	!	x = prof$x[idx],
226	!	y = prof$y[idx],
227	!	value = prof$kappa[idx],
228	!	stringsAsFactors = FALSE
229		)
230		} else {
231	!	data.frame(
232	!	type = character(), t = numeric(), x = numeric(), y = numeric(),
233	!	value = numeric(), stringsAsFactors = FALSE
234		)
235		}
236
237	!	list(
238	!	heading_turns = heading_turns,
239	!	x_velocity_zeros = x_velocity_zeros,
240	!	y_velocity_zeros = y_velocity_zeros,
241	!	x_inflections = x_inflections,
242	!	y_inflections = y_inflections,
243	!	curvature_peaks = curvature_peaks,
244	!	all = rbind(
245	!	heading_turns, x_velocity_zeros, y_velocity_zeros,
246	!	x_inflections, y_inflections, curvature_peaks
247		)
248		)
249		}
250
251		#' Integrated Euclidean curve distance between two fitted trajectories
252		#'
253		#' @param curve_a First fitted trajectory
254		#' @param curve_b Second fitted trajectory
255		#' @param t_start Starting time in [0, 1]
256		#' @param t_end Ending time in [0, 1]
257		#' @return Distance value
258		#' @export
259		tma_curve_distance <- function(curve_a, curve_b, t_start = 0.0, t_end = 1.0) {
260	1x	libqe::integrated_trajectory_distance(
261	1x	curve_a$coeffs_x, curve_a$coeffs_y,
262	1x	curve_b$coeffs_x, curve_b$coeffs_y,
263	1x	as.numeric(t_start), as.numeric(t_end)
264		)
265		}
266
267		#' Integrated lagged Euclidean distance between two fitted trajectories
268		#'
269		#' @param curve_a First trajectory
270		#' @param curve_b Second trajectory
271		#' @param lag Normalized time lag in [0, 1)
272		#' @param direction "a_follows_b", "b_follows_a", or "symmetric"
273		#' @return List with distance metrics
274		#' @export
275		tma_curve_distance_lag <- function(
276		curve_a,
277		curve_b,
278		lag = 0.0,
279		direction = c("a_follows_b", "b_follows_a", "symmetric")) {
280	!	direction <- match.arg(direction)
281	!	lag <- as.numeric(lag)[1L]
282	!	if (lag < 0 \|\| lag >= 1) {
283	!	return(list(D = NA_real_, lag = lag, direction = direction))
284		}
285
286	!	d_ab <- libqe::lagged_trajectory_distance(
287	!	curve_a$coeffs_x, curve_a$coeffs_y,
288	!	curve_b$coeffs_x, curve_b$coeffs_y,
289	!	lag
290		)
291
292	!	d_ba <- libqe::lagged_trajectory_distance(
293	!	curve_b$coeffs_x, curve_b$coeffs_y,
294	!	curve_a$coeffs_x, curve_a$coeffs_y,
295	!	lag
296		)
297
298	!	d_val <- switch(
299	!	direction,
300	!	a_follows_b = d_ab,
301	!	b_follows_a = d_ba,
302	!	symmetric = mean(c(d_ab, d_ba))
303		)
304
305	!	list(
306	!	lag = lag,
307	!	direction = direction,
308	!	D = d_val,
309	!	D_a_follows_b = d_ab,
310	!	D_b_follows_a = d_ba
311		)
312		}
313
314		#' Discrete turn-lag distance between point sets of two conversants
315		#'
316		#' @param pts_a ETM point rows for agent A
317		#' @param pts_b ETM point rows for agent B
318		#' @param x_col Column name for x coordinate
319		#' @param y_col Column name for y coordinate
320		#' @param time_col Column name for turn index / timestamp
321		#' @param delta Signed integer turn lag
322		#' @return List with mean_distance and valid_count
323		#' @export
324		tma_signed_turn_lag <- function(
325		pts_a,
326		pts_b,
327		x_col = "MR1",
328		y_col = "MR2",
329		time_col = "index",
330		delta = 0L) {
331	!	pa <- as.matrix(pts_a[, c(x_col, y_col)])
332	!	pb <- as.matrix(pts_b[, c(x_col, y_col)])
333	!	ta <- as.numeric(pts_a[[time_col]])
334	!	tb <- as.numeric(pts_b[[time_col]])
335
336	!	libqe::signed_turn_lag(pa, pb, ta, tb, as.integer(delta))
337		}
338
339		#' Discrete turn-lag optimization sweep across signed lags
340		#'
341		#' @param pts_a ETM point rows for agent A
342		#' @param pts_b ETM point rows for agent B
343		#' @param x_col Column name for x coordinate
344		#' @param y_col Column name for y coordinate
345		#' @param time_col Column name for turn index / timestamp
346		#' @param max_lag Max integer lag to sweep
347		#' @return List with best_lag, min_mean_distance, lags, and mean_distances
348		#' @export
349		tma_sweep_signed_turn_lags <- function(
350		pts_a,
351		pts_b,
352		x_col = "MR1",
353		y_col = "MR2",
354		time_col = "index",
355		max_lag = 15L) {
356	1x	pa <- as.matrix(pts_a[, c(x_col, y_col)])
357	1x	pb <- as.matrix(pts_b[, c(x_col, y_col)])
358	1x	ta <- as.numeric(pts_a[[time_col]])
359	1x	tb <- as.numeric(pts_b[[time_col]])
360
361	1x	libqe::sweep_signed_turn_lags(pa, pb, ta, tb, as.integer(max_lag))
362		}
363
364		#' Distance-distance Pearson correlation between two coordinate configurations
365		#'
366		#' @param X Matrix of coordinates 1
367		#' @param Y Matrix of coordinates 2
368		#' @return Pearson correlation r in [-1, 1]
369		#' @export
370		tma_dist_dist_correlation <- function(X, Y) {
371	!	libqe::dist_dist_correlation(as.matrix(X), as.matrix(Y))
372		}

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

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 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		.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		)

1		// [[Rcpp::depends(RcppArmadillo)]]
2		// Rcpp wrappers for libtma, the accumulation layer of the libqe C++
3		// libraries. The headers live in inst/include/libtma/ (moved from libqe in
4		// its phase 4b split); they build on libqe's generic numerics, which come
5		// from LinkingTo: libqe. The wrappers moved from libqe's libqe_rcpp.cpp with
6		// the same names, bodies and docs, and stay exported: tma is now where R code
7		// (rENA, ona) gets accumulation from.
8		#include <RcppArmadillo.h>
9		#include <libtma/accumulation.hpp>
10
11		using namespace Rcpp;
12
13		// =============================================================================
14		// Accumulation
15		// =============================================================================
16
17		//' Core connection matrix for one ground+response pair
18		//' @param ground Numeric row vector of ground (context) code values
19		//' @param response Numeric row vector of response code values
20		//' @param response_weight Scalar weight applied to the response self-connection
21		//' @param ordered TRUE = directed; FALSE = undirected
22		//' @export
23		// [[Rcpp::export]]
24	2x	arma::mat connection_matrix(arma::rowvec ground, arma::rowvec response,
25		double response_weight = 1.0,
26		bool ordered = true) {
27	4x	return qe::connection_matrix(ground, response, response_weight, ordered);
28		}
29
30		//' Traditional stanza-window accumulation (rENA model)
31		//'
32		//' For each row k in a single conversation's code matrix, accumulates
33		//' connections over a back/forward window.
34		//'
35		//' \strong{Undirected} (\code{ordered = FALSE}, default): upper-triangle
36		//' co-occurrences with back/forward-reference corrections.
37		//' Returns \code{n_rows × choose_two(n_codes)}.
38		//'
39		//' \strong{Directed} (\code{ordered = TRUE}): focal row k as response,
40		//' sum of prior window rows as ground, using the directed connection formula.
41		//' \code{window_forward} is ignored. Returns \code{n_rows × n_codes²}.
42		//'
43		//' @param codes Numeric matrix (rows = lines, cols = codes) for ONE conversation
44		//' @param window_back Number of prior lines in window (default 1); use .Machine$integer.max for Inf
45		//' @param window_forward Number of subsequent lines (default 0; ignored when ordered = TRUE)
46		//' @param binary If TRUE, binarise non-zero connection counts
47		//' @param ordered If TRUE, return directed n² output; FALSE (default) returns upper-tri
48		//' @return Undirected: (n_rows × choose_two(n_codes)); directed: (n_rows × n_codes²)
49		//' @export
50		// [[Rcpp::export]]
51	10x	arma::mat accumulate_stanza(arma::mat codes,
52		int window_back = 1,
53		int window_forward = 0,
54		bool binary = true,
55		bool ordered = false) {
56	20x	return qe::accumulate_stanza(codes, window_back, window_forward, binary, ordered);
57		}
58
59		//' Compute a column-major linear index into a multi-dimensional array
60		//'
61		//' Equivalent to tma's flat_index(). Throws if lengths of `indices`
62		//' and `dims` differ.
63		//'
64		//' @param indices 0-based integer vector of per-dimension indices
65		//' @param dims Integer vector of array dimensions
66		//' @return Scalar integer linear index
67		//' @export
68		// [[Rcpp::export]]
69	8x	int flat_index(std::vector<int> indices, std::vector<int> dims) {
70	8x	return qe::flat_index(indices, dims);
71		}
72
73		//' Per-row upper-triangle co-occurrence matrix
74		//'
75		//' For each row in \code{codes}, computes the pairwise code products
76		//' (upper-triangle) and optionally binarizes. Output has
77		//' \code{choose(n_codes, 2)} columns.
78		//'
79		//' @param codes Numeric matrix (rows = observations, cols = codes)
80		//' @param binary If TRUE, binarise non-zero co-occurrences (default TRUE)
81		//' @return Numeric matrix (n_rows x choose_two(n_codes))
82		//' @export
83		// [[Rcpp::export]]
84	5x	arma::mat row_connections(arma::mat codes, bool binary = true) {
85	5x	return qe::row_connections(codes, binary);
86		}
87
88		//' Rolling backward window sum of a code matrix
89		//'
90		//' For each row k, sums the raw code values over rows
91		//' \code{[max(0, k - window_size + 1), k]}. Returns a matrix of the same
92		//' shape as \code{codes}. \code{window_size <= 0} is treated as 1
93		//' (current row only).
94		//'
95		//' @param codes Numeric matrix (rows = observations, cols = codes)
96		//' @param window_size Number of rows to look back (default 1)
97		//' @return Numeric matrix (same dimensions as \code{codes})
98		//' @export
99		// [[Rcpp::export]]
100	4x	arma::mat rolling_window_sum(arma::mat codes, int window_size = 1) {
101	4x	return qe::rolling_window_sum(codes, window_size);
102		}
103
104		//' Ground/response accumulation for one unit (tma model)
105		//'
106		//' @param codes Numeric matrix for the full context (n_rows x n_codes)
107		//' @param unit_rows 0-based integer vector of rows belonging to this unit
108		//' @param decay_fn R function mapping a numeric distance vector to weights
109		//' @param ordered TRUE = directed; FALSE = undirected (upper-tri)
110		//' @return Numeric vector of connection counts
111		//' @export
112		// [[Rcpp::export]]
113	7x	arma::rowvec accumulate_unit(arma::mat codes, std::vector<int> unit_rows,
114		Function decay_fn, bool ordered = false) {
115	17x	auto cpp_decay = [&](arma::vec distances) -> arma::vec {
116	17x	NumericVector d = wrap(distances);
117	17x	NumericVector w = decay_fn(d);
118	34x	return as<arma::vec>(w);
119		};
120	14x	return qe::accumulate_unit(codes, unit_rows, cpp_decay, ordered);
121		}
122
123		//' Ground/response accumulation for one unit — returns unit vector and per-row matrix
124		//'
125		//' Equivalent to tma's accumulate_network() but without R-env-var setup.
126		//' The decay function receives a distance vector (response=0, older rows
127		//' have larger values) and returns a weight vector of the same length.
128		//'
129		//' @param codes Numeric matrix (n_rows x n_codes)
130		//' @param unit_rows 0-based integer vector of rows belonging to this unit
131		//' @param decay_fn R function(distances) -> weights
132		//' @param ordered TRUE = directed (full p^2); FALSE = undirected (upper-tri)
133		//' @return List with `networks` (vector) and `row_networks` (matrix)
134		//' @export
135		// [[Rcpp::export]]
136	2x	List accumulate_unit_with_rows(arma::mat codes, std::vector<int> unit_rows,
137		Function decay_fn, bool ordered = false) {
138	8x	auto cpp_decay = [&](int unit_row, arma::uvec ground_indices) -> arma::vec {
139	8x	arma::vec dists(ground_indices.n_elem);
140	40x	for (arma::uword k = 0; k < ground_indices.n_elem; ++k)
141	96x	dists[k] = static_cast<double>(unit_row - ground_indices[k]);
142	16x	return as<arma::vec>(wrap(decay_fn(wrap(dists))));
143		};
144	2x	qe::UnitNetworks r = qe::accumulate_unit_with_rows(codes, unit_rows, cpp_decay, ordered);
145		return List::create(
146	4x	_("networks") = r.networks,
147	4x	_("row_networks") = r.row_networks
148		);
149		}
150
151		//' Tensor-based multi-modal accumulation for one unit (tma model)
152		//'
153		//' Pure-C++ port of tma's apply_tensor(). Accepts 0-based index vectors
154		//' for sender/receiver/mode dimensions and a pre-converted integer context
155		//' lookup matrix.
156		//'
157		//' @param tensor Numeric vector (column-major flat tensor)
158		//' @param dims Integer vector of tensor dimensions
159		//' @param dims_sender 0-based sender axis indices
160		//' @param dims_receiver 0-based receiver axis indices
161		//' @param dims_mode 0-based mode axis indices
162		//' @param context_lookup Integer matrix (n_context_rows x n_factors), 0-based
163		//' @param unit_rows 0-based response-row indices for this unit
164		//' @param codes Numeric matrix (n_context_rows x n_codes)
165		//' @param times Numeric vector of timestamps per context row
166		//' @param ordered TRUE = directed; FALSE = undirected
167		//' @param misses TRUE = also return missed co-occurrences: ground code
168		//' i present while response code j is absent (n_codes^2, ground i ->
169		//' response j at j*n+i; no response self-term). Raw directed rows, like
170		//' `row_connection_counts`; fold them with `finalize_row_connections()` /
171		//' `aggregate_row_connections()` for unordered networks.
172		//' @return List with `connection_counts` (vector) and `row_connection_counts`
173		//' (matrix); with `misses = TRUE`, also `miss_counts` (vector) and
174		//' `row_miss_counts` (matrix)
175		//' @export
176		// [[Rcpp::export]]
177	3x	List apply_tensor(arma::vec tensor,
178		std::vector<int> dims,
179		std::vector<int> dims_sender,
180		std::vector<int> dims_receiver,
181		std::vector<int> dims_mode,
182		arma::imat context_lookup,
183		std::vector<int> unit_rows,
184		arma::mat codes,
185		arma::vec times,
186		bool ordered = true,
187		bool misses = false) {
188		qe::TensorNetworks r = qe::apply_tensor_unit(
189		tensor, dims, dims_sender, dims_receiver, dims_mode,
190		context_lookup, unit_rows, codes, times, ordered,
191	3x	/return_members=/false, /return_misses=/misses);
192		List out = List::create(
193	6x	_("connection_counts") = r.connection_counts,
194	6x	_("row_connection_counts") = r.row_connection_counts
195		);
196	3x	if (misses) {
197	2x	out["miss_counts"] = r.miss_counts;
198	2x	out["row_miss_counts"] = r.row_miss_counts;
199		}
200	3x	return out;
201		}
202
203		//' Apply the TMA window/weight tensor, additionally returning per-response-row
204		//' window membership.
205		//'
206		//' Identical to \code{apply_tensor()} but also returns, for each response
207		//' (reference) row, the in-window ground rows and their resolved window sizes.
208		//' Powers the webtool Data View per-modality window-span hover. Kept as a
209		//' separate export so \code{apply_tensor()}'s ABI (and tma's direct .Call to it)
210		//' is unchanged.
211		//'
212		//' @param tensor Numeric vector (column-major flat tensor)
213		//' @param dims Integer vector of tensor dimensions
214		//' @param dims_sender 0-based sender axis indices
215		//' @param dims_receiver 0-based receiver axis indices
216		//' @param dims_mode 0-based mode axis indices
217		//' @param context_lookup Integer matrix (n_context_rows x n_factors), 0-based
218		//' @param unit_rows 0-based response-row indices for this unit
219		//' @param codes Numeric matrix (n_context_rows x n_codes)
220		//' @param times Numeric vector of timestamps per context row
221		//' @param ordered TRUE = directed; FALSE = undirected
222		//' @return List with \code{connection_counts}, \code{row_connection_counts},
223		//' \code{row_window_members} (list of 1-based ground-row index vectors, in
224		//' \code{unit_rows} order) and \code{row_window_wins} (parallel resolved
225		//' window sizes).
226		//' @export
227		// [[Rcpp::export]]
228	!	List apply_tensor_members(arma::vec tensor,
229		std::vector<int> dims,
230		std::vector<int> dims_sender,
231		std::vector<int> dims_receiver,
232		std::vector<int> dims_mode,
233		arma::imat context_lookup,
234		std::vector<int> unit_rows,
235		arma::mat codes,
236		arma::vec times,
237		bool ordered = true) {
238		qe::TensorNetworks r = qe::apply_tensor_unit(
239		tensor, dims, dims_sender, dims_receiver, dims_mode,
240	!	context_lookup, unit_rows, codes, times, ordered, /return_members=/true);
241	!	List members(r.row_window_members.size());
242	!	List wins(r.row_window_wins.size());
243	!	for (size_t i = 0; i < r.row_window_members.size(); ++i) {
244	!	IntegerVector iv(r.row_window_members[i].begin(), r.row_window_members[i].end());
245	!	for (R_xlen_t k = 0; k < iv.size(); ++k) iv[k] += 1; // 0-based -> 1-based
246	!	members[i] = iv;
247	!	wins[i] = NumericVector(r.row_window_wins[i].begin(), r.row_window_wins[i].end());
248		}
249		return List::create(
250	!	_("connection_counts") = r.connection_counts,
251	!	_("row_connection_counts") = r.row_connection_counts,
252	!	_("row_window_members") = members,
253	!	_("row_window_wins") = wins
254		);
255		}
256
257		// Weight model from R: NULL (= "binary"), TRUE/FALSE (legacy binary flag) or a name.
258	758x	static qe::WeightModel weight_model_from_sexp(SEXP weight) {
259	758x	if (Rf_isNull(weight)) return qe::WeightModel::Binary;
260	757x	if (TYPEOF(weight) == STRSXP && Rf_length(weight) == 1)
261	754x	return qe::weight_model_from_string(Rcpp::as<std::string>(weight));
262	3x	if (TYPEOF(weight) == LGLSXP && Rf_length(weight) == 1)
263	2x	return qe::weight_model_from_bool(Rcpp::as<bool>(weight));
264	1x	Rcpp::stop("`weight` must be TRUE/FALSE or one of 'binary', 'product', 'sqrt', 'log1p'.");
265		}
266
267		//' Finalise per-response-row tensor connections (fold + weight model)
268		//'
269		//' The per-line step of tma's aggregation, before any summing: unordered rows
270		//' are folded to the upper triangle, then the weight model is applied; ordered
271		//' rows keep the directed n*n layout with the weight applied per cell.
272		//'
273		//' Weight models are applied per line, before the unit sum (the stage legacy
274		//' rENA applies \code{weight.by}): \code{"binary"} clamps each unordered count
275		//' to 1 (ordered counts are left raw), \code{"product"} keeps the counts,
276		//' \code{"sqrt"} and \code{"log1p"} (alias \code{"log"}) transform each
277		//' line's product count.
278		//'
279		//' @param row_conn Numeric matrix (n_response_rows x n_codes^2) of per-row
280		//' directed counts, i.e. \code{apply_tensor()$row_connection_counts}
281		//' @param n_codes Number of codes
282		//' @param ordered TRUE = keep directed n*n rows; FALSE = fold to choose(n, 2)
283		//' @param weight Weight model name (\code{"binary"}, \code{"product"},
284		//' \code{"sqrt"}, \code{"log1p"}), or TRUE/FALSE for the legacy binary flag
285		//' (TRUE = \code{"binary"}, FALSE = \code{"product"}). NULL (default) =
286		//' \code{"binary"}.
287		//' @param diagonal Unordered only: keep self-connections in the folded rows,
288		//' as columns A & A, A & B, B & B, ... (ordered rows always carry them)
289		//' @return Numeric matrix (n_response_rows x n_codes^2, or x choose(n_codes, 2),
290		//' or x n_codes(n_codes + 1)/2 with \code{diagonal})
291		//' @export
292		// [[Rcpp::export]]
293	21x	arma::mat finalize_row_connections(arma::mat row_conn,
294		int n_codes,
295		bool ordered = false,
296		SEXP weight = R_NilValue,
297		bool diagonal = false) {
298		return qe::finalize_row_connections(row_conn, n_codes, ordered,
299	21x	weight_model_from_sexp(weight), diagonal);
300		}
301
302		//' Aggregate per-response-row tensor connections into a unit vector
303		//'
304		//' Finalises each row (see \code{finalize_row_connections()}) and sums the
305		//' rows: tma's aggregation of \code{apply_tensor()$row_connection_counts},
306		//' with the weight model applied per line before the unit sum.
307		//'
308		//' @inheritParams finalize_row_connections
309		//' @return Numeric vector of length n_codes^2 (ordered) or choose(n_codes, 2)
310		//' @export
311		// [[Rcpp::export]]
312	31x	NumericVector aggregate_row_connections(arma::mat row_conn,
313		int n_codes,
314		bool ordered = false,
315		SEXP weight = R_NilValue,
316		bool diagonal = false) {
317		arma::rowvec out = qe::aggregate_row_connections(row_conn, n_codes, ordered,
318	31x	weight_model_from_sexp(weight), diagonal);
319	58x	return NumericVector(out.begin(), out.end());
320		}
321
322		//' Per-line self-connections (diagonal of each directed row)
323		//'
324		//' Each line's ground-to-response count for a code to itself (ground i x
325		//' response i): the ordered network's diagonal, which unordered networks drop
326		//' when they fold to the upper triangle. Pass
327		//' \code{apply_tensor()$row_connection_counts}, or \code{$row_miss_counts}
328		//' for self-misses (ground i present, response i absent). The weight model is
329		//' applied per line as in \code{finalize_row_connections()}: \code{"binary"}
330		//' clamps unordered self-connections to 1 and leaves ordered ones raw.
331		//'
332		//' @inheritParams finalize_row_connections
333		//' @return Numeric matrix (n_response_rows x n_codes)
334		//' @export
335		// [[Rcpp::export]]
336	4x	arma::mat finalize_self_connections(arma::mat row_conn,
337		int n_codes,
338		bool ordered = false,
339		SEXP weight = R_NilValue) {
340		return qe::finalize_self_connections(row_conn, n_codes, ordered,
341	4x	weight_model_from_sexp(weight));
342		}
343
344		//' Aggregate per-line self-connections into a unit vector
345		//'
346		//' \code{finalize_self_connections()} summed over the lines.
347		//'
348		//' @inheritParams finalize_row_connections
349		//' @return Numeric vector of length n_codes
350		//' @export
351		// [[Rcpp::export]]
352	1x	NumericVector aggregate_self_connections(arma::mat row_conn,
353		int n_codes,
354		bool ordered = false,
355		SEXP weight = R_NilValue) {
356		arma::rowvec out = qe::aggregate_self_connections(row_conn, n_codes, ordered,
357	1x	weight_model_from_sexp(weight));
358	2x	return NumericVector(out.begin(), out.end());
359		}
360
361		//' Apply the weight model per line to already-finalised rows
362		//'
363		//' The weight step of \code{finalize_row_connections()} on its own, for rows
364		//' that are already folded (unordered) or directed (ordered), such as
365		//' \code{accumulate_unit_networks()$row_connection_counts}.
366		//'
367		//' @param rows Numeric matrix of raw per-line rows
368		//' @inheritParams finalize_row_connections
369		//' @return Numeric matrix, same shape as \code{rows}
370		//' @export
371		// [[Rcpp::export]]
372	8x	arma::mat weight_rows(arma::mat rows, bool ordered = false, SEXP weight = R_NilValue) {
373	8x	return qe::weight_rows(rows, ordered, weight_model_from_sexp(weight));
374		}
375
376		//' Accumulate one unit's networks end to end
377		//'
378		//' One libtma call per unit: runs \code{apply_tensor()} for the directed
379		//' per-line rows (and misses), then folds unordered rows, applies the weight
380		//' model per line, sums the lines and pulls out the self-connection diagonal --
381		//' the steps \code{accumulate()} and every other binding share.
382		//'
383		//' @inheritParams apply_tensor
384		//' @param weight Weight model name (\code{"binary"}, \code{"product"},
385		//' \code{"sqrt"}, \code{"log1p"}), or TRUE/FALSE for the legacy binary flag.
386		//' NULL (default) = \code{"binary"}.
387		//' @param misses TRUE (default) = also accumulate missed co-occurrences and
388		//' self-misses.
389		//' @param diagonal Unordered only: self-connections (and self-misses) are also
390		//' columns of the connection (and miss) vectors, in the A & A, A & B,
391		//' B & B, ... layout. The separate self vectors are returned either way.
392		//' @return List with \code{connection_counts} (n_codes^2 ordered, or
393		//' choose(n_codes, 2)), \code{row_connection_counts} (raw per line, folded
394		//' when unordered), \code{self_connection_counts} (n_codes),
395		//' \code{row_self_connection_counts} (raw per line); with misses, also
396		//' \code{miss_counts}, \code{row_miss_counts}, \code{self_miss_counts},
397		//' \code{row_self_miss_counts}.
398		//' @export
399		// [[Rcpp::export]]
400	693x	List accumulate_unit_networks(arma::vec tensor,
401		std::vector<int> dims,
402		std::vector<int> dims_sender,
403		std::vector<int> dims_receiver,
404		std::vector<int> dims_mode,
405		arma::imat context_lookup,
406		std::vector<int> unit_rows,
407		arma::mat codes,
408		arma::vec times,
409		bool ordered = false,
410		SEXP weight = R_NilValue,
411		bool misses = true,
412		bool diagonal = false) {
413		qe::UnitAccumulation r = qe::accumulate_unit_networks(
414		tensor, dims, dims_sender, dims_receiver, dims_mode,
415		context_lookup, unit_rows, codes, times,
416	693x	ordered, weight_model_from_sexp(weight), misses, diagonal);
417		List out = List::create(
418	2768x	_("connection_counts") = NumericVector(r.connection_counts.begin(), r.connection_counts.end()),
419	1384x	_("row_connection_counts") = r.row_connection_counts,
420	2768x	_("self_connection_counts") = NumericVector(r.self_connection_counts.begin(), r.self_connection_counts.end()),
421	1384x	_("row_self_connection_counts") = r.row_self_connection_counts
422		);
423	692x	if (misses) {
424	2046x	out["miss_counts"] = NumericVector(r.miss_counts.begin(), r.miss_counts.end());
425	682x	out["row_miss_counts"] = r.row_miss_counts;
426	2046x	out["self_miss_counts"] = NumericVector(r.self_miss_counts.begin(), r.self_miss_counts.end());
427	1364x	out["row_self_miss_counts"] = r.row_self_miss_counts;
428		}
429	692x	return out;
430		}