R/centrality_duo_plot.R

In InterconectaR: Psychological Network Analysis and Psychometric Insights

#' Dual Centrality Plot
#'
#' Creates a plot comparing two centrality measures.
#'
#' @param qgraph_obj A qgraph object.
#' @param network Estimated network object (e.g., from bootnet).
#' @param groups List of communities for bridge calculation.
#' @param measure0 Primary centrality measure name.
#' @param measure1 Secondary bridge measure name (NULL for single measure).
#' @param color_palette Character vector of colors.
#' @param use_abbrev Logical; use abbreviated node names.
#' @param labels Optional character vector of custom node labels.
#'
#' @return A list with `table` (a data frame with the centrality values of
#'   each node) and `plot` (a ggplot object).
#' @export
#' @examples
#' set.seed(123)
#' n <- 300
#' f1 <- rnorm(n)
#' f2 <- 0.3 * f1 + rnorm(n)
#' items <- data.frame(
#'   sapply(1:4, function(i) 0.7 * f1 + rnorm(n, 0, 0.7)),
#'   sapply(1:4, function(i) 0.7 * f2 + rnorm(n, 0, 0.7))
#' )
#' names(items) <- c(paste0("A", 1:4), paste0("B", 1:4))
#'
#' net <- bootnet::estimateNetwork(items, default = "EBICglasso")
#' g <- qgraph::qgraph(net$graph, DoNotPlot = TRUE)
#' res <- centrality_duo_plot(g, net,
#'                            groups = rep(c("A", "B"), each = 4),
#'                            measure1 = "Bridge Expected Influence (1-step)")
#' res$plot
#' @importFrom qgraph centralityTable
#' @importFrom dplyr %>% filter select arrange rename mutate inner_join bind_cols desc
#' @importFrom networktools bridge
#' @importFrom tibble tibble
#' @importFrom ggplot2 ggplot aes geom_point geom_line scale_color_manual labs theme_minimal theme element_text element_rect element_line
#' @importFrom tidyr pivot_longer
#' @importFrom forcats fct_reorder
#' @importFrom purrr map
#' @importFrom rlang quo sym !! :=
centrality_duo_plot <- function(qgraph_obj,
                                network,
                                groups = NULL,
                                measure0 = "ExpectedInfluence",
                                measure1 = NULL,
                                color_palette = c("#6C5CE7", "#00B894"),
                                use_abbrev = TRUE,
                                labels = NULL) {  # NUEVO PARAMETRO
  # Etiquetas para las metricas
  label0 <- measure0
  label1 <- measure1

  # --- Calcular centralidad principal ---
  ctbl <- centralityTable(network)

  # Obtener nombres completos
  full_names <- rownames(network$graph)
  if (is.null(full_names)) full_names <- colnames(network$graph)

  # NUEVO: Determinar que etiquetas usar
  if (!is.null(labels)) {
    # Validar longitud de labels personalizados
    if (length(labels) != length(full_names)) {
      stop(paste("La longitud de 'labels' (", length(labels),
                 ") debe coincidir con el n\u00famero de nodos (",
                 length(full_names), ")"))
    }
    qgraph_labels <- labels
  } else {
    # Usar etiquetas del qgraph
    qgraph_labels <- qgraph_obj$graphAttributes$Nodes$labels
  }

  # Crear mapeo de nombres completos a abreviaciones
  name_to_abbrev <- setNames(qgraph_labels, full_names)

  cents_expect <- ctbl %>%
    filter(measure == !!measure0) %>%
    select(full_name = node, value) %>%
    arrange(full_name) %>%
    rename(!!measure0 := value) %>%
    mutate(
      Abrev = name_to_abbrev[full_name]
    )

  # --- Calcular medidas de puente (si se solicitan) ---
  if (!is.null(measure1)) {

    # Validar que existan grupos
    if (is.null(groups)) {
      warning("No se pueden calcular medidas de puente sin definir grupos. Se omitir\u00e1 measure1.")
      measure1 <- NULL
      label1 <- NULL
    } else {

      tryCatch({
        # Calcular medidas de puente
        b_obj <- bridge(qgraph_obj,
                        communities    = groups,
                        useCommunities = "all",
                        normalize      = FALSE)

        # Validar resultado de bridge
        if (is.null(b_obj)) {
          warning("La funci\u00f3n bridge() devolvi\u00f3 NULL. Se omitir\u00e1 measure1.")
          measure1 <- NULL
          label1 <- NULL
        } else if (!measure1 %in% names(b_obj)) {
          warning(paste("La medida", measure1, "no se encontr\u00f3 en los resultados de bridge. Medidas disponibles:",
                        paste(names(b_obj), collapse = ", "), ". Se omitir\u00e1 measure1."))
          measure1 <- NULL
          label1 <- NULL
        } else {

          bridge_values <- b_obj[[measure1]]

          # Validar valores de puente
          if (is.null(bridge_values) || length(bridge_values) == 0) {
            warning(paste("La medida", measure1, "est\u00e1 vac\u00eda o es NULL. Se omitir\u00e1 measure1."))
            measure1 <- NULL
            label1 <- NULL
          } else {

            # MODIFICADO: Usar las etiquetas determinadas anteriormente
            # Validar longitud
            if (length(bridge_values) != length(qgraph_labels)) {
              warning(paste("Longitud de bridge_values (", length(bridge_values),
                            ") no coincide con qgraph_labels (", length(qgraph_labels),
                            "). Se omitir\u00e1 measure1."))
              measure1 <- NULL
              label1 <- NULL
            } else {

              # Crear tabla de bridge estandarizada
              bridge_data <- tibble(
                qgraph_label = qgraph_labels,
                raw_bridge   = as.numeric(bridge_values)
              ) %>%
                mutate(!!measure1 := as.numeric(scale(raw_bridge))) %>%
                select(-raw_bridge)

              # Mapear nombres completos
              name_mapping <- tibble(
                full_name    = full_names,
                qgraph_label = qgraph_labels
              )

              # Unir con abreviaciones
              bridge_data <- bridge_data %>%
                left_join(name_mapping, by = "qgraph_label") %>%
                mutate(
                  Abrev = name_to_abbrev[full_name]
                )

              # Combinar centralidad y puente
              cents2 <- inner_join(
                cents_expect,
                bridge_data %>% select(full_name, !!sym(measure1)),
                by = "full_name"
              )

              # Verificar join exitoso
              if (nrow(cents2) == 0) {
                if (nrow(cents_expect) == nrow(bridge_data)) {
                  cents2 <- bind_cols(
                    cents_expect,
                    bridge_data %>% select(!!sym(measure1))
                  )
                } else {
                  warning("No se pueden unir centralidad y puente por diferencia en n\u00famero de filas. Se omitir\u00e1 measure1.")
                  measure1 <- NULL
                  label1 <- NULL
                }
              }
            }
          }
        }
      }, error = function(e) {
        warning(paste("Error al calcular medidas de puente:", e$message, ". Se omitir\u00e1 measure1."))
        measure1 <- NULL
        label1 <- NULL
      })
    }
  }

  # --- Generar grafico con dos medidas ---
  if (!is.null(measure1) && !is.null(label1) && exists("cents2", inherits = FALSE)) {
    y_var     <- if (use_abbrev) quo(Abrev) else quo(full_name)

    # Transformar a formato largo para ggplot
    cents_long <- cents2 %>%
      pivot_longer(
        cols      = c(!!sym(measure0), !!sym(measure1)),
        names_to  = "Measure",
        values_to = "Value"
      )

    # Configurar paleta de colores
    pal    <- setNames(color_palette, c(label0, label1))
    breaks <- c(label0, label1)
    labels <- c(label0, label1)

    # Crear grafico
    Figura <- ggplot(cents_long,
                     aes(x = Value,
                         y = fct_reorder(!!y_var, Value),
                         color = Measure, group = Measure
                     )) +
      geom_point(size = 4, alpha = 0.8) +
      geom_line(linewidth = 1.2, alpha = 0.7) +
      theme_minimal() +
      labs(x = "z-score", y = "Nodos", color = "M\u00e9trica") +
      scale_color_manual(
        values = pal,
        breaks = breaks,
        labels = labels
      ) +
      theme(
        axis.text.y  = element_text(size = 12, face = "bold"),
        axis.text.x  = element_text(size = 12),
        axis.title   = element_text(size = 14, face = "bold"),
        legend.text  = element_text(size = 12),
        legend.title = element_text(size = 12, face = "bold"),
        legend.position = "bottom",
        panel.grid.major = element_line(color = "grey90", linewidth = 0.5),
        panel.grid.minor = element_line(color = "grey95", linewidth = 0.3),
        plot.background = element_rect(fill = "white", color = NA)
      )

    # Suprimir warnings al imprimir
    class(Figura) <- c("silent_gg", class(Figura))

    return(list(
      table = cents2 %>% arrange(desc(!!sym(measure0))),
      plot  = Figura
    ))

    # --- Generar grafico con una sola medida ---
  } else {
    cents_single <- cents_expect %>%
      select(full_name, Abrev, !!sym(measure0)) %>%
      arrange(desc(!!sym(measure0))) %>%
      rename(Value = !!sym(measure0))

    y_var <- if (use_abbrev) quo(Abrev) else quo(full_name)
    pal_single <- setNames(color_palette[1], label0)

    Figura <- ggplot(cents_single,
                     aes(x = Value,
                         y = fct_reorder(!!y_var, Value),
                         group = 1)) +
      geom_line(color = pal_single, linewidth = 1.2, alpha = 0.7) +
      geom_point(color = pal_single, size = 4, alpha = 0.8) +
      theme_minimal() +
      labs(x = "z-score", y = "Nodos", color = "M\u00e9trica") +
      scale_color_manual(
        values = pal_single,
        breaks = label0,
        labels = label0
      ) +
      theme(
        axis.text.y  = element_text(size = 12, face = "bold"),
        axis.text.x  = element_text(size = 12),
        axis.title   = element_text(size = 14, face = "bold"),
        legend.text  = element_text(size = 12),
        legend.title = element_text(size = 12, face = "bold"),
        legend.position = "bottom",
        panel.grid.major = element_line(color = "grey90", linewidth = 0.5),
        panel.grid.minor = element_line(color = "grey95", linewidth = 0.3),
        plot.background = element_rect(fill = "white", color = NA)
      )

    # Suprimir warnings al imprimir
    class(Figura) <- c("silent_gg", class(Figura))

    return(list(table = cents_single, plot = Figura))
  }
}