Project: s41467-024-45889-6 | Function: F_Ricci2 (r)

system: You are an expert R programmer implementing algorithms from scientific papers.
Complete the masked function based on the algorithm description.
Follow R best practices and maintain consistent code style.
Return **only** the complete R function code.

user: Complete this R function:

**DESCRIPTION:** Calculates Ricci curvature on weighted graphs for cellular trajectories analysis. Implements discrete Ricci curvature computation based on weighted adjacency matrices representing cell-cell relationships.

**KEY TERMS:** {
  "i,j": "graph nodes (cells)",
  "a": "weighted adjacency matrix",
  "D": "degree vector",
  "neighbs": "neighborhood structure",
  "q,q2": "normalized edge weights"
}

**CONTEXT CODE:** ######################################################
#####Preliminaries: ##################################
#####x= n x T matrix of expression values, rows index genes, columns index time points
#####int.red= n x n adjacency matrix describing how the proteins corresponding to the genes interact:
#####
#####first compute the degree of each gene and the inverse

apply(int.red,1,sum)->deg
1/deg->D

#####generate a list to index the neighbours of each gene
lapply(1:nrow(int.red), function(i){
  print(i)
  return(which(int.red[i,]>0))
})->neighbs

#####define the Forman Ricci curvature using node weights W_i=1/deg(i); w_ij=1/xi*xj
F_Ricci_curvature <- function(a, D, neighbs) {
  # Validate inputs
  if (!is.matrix(a)) stop("a must be a matrix")
  if (!is.numeric(D) || length(D) != nrow(a)) stop("D must be a numeric vector")
  if (!is.list(neighbs) || length(neighbs) != nrow(a)) stop("neighbs must be a list")

  # Initialize Ricci curvature matrix
  F_Ricci_mat <- matrix(NA, nrow = nrow(a), ncol = nrow(a))

  # Iterate over edges
  for (i in 1:nrow(a)) {
    for (j in neighbs[[i]]) {
      if (i < j) {
        F_val <- F_Ricci2(i, j, a)
        F_Ricci_mat[i, j] <- F_val
        F_Ricci_mat[j, i] <- F_val
      }
    }
  }

  return(F_Ricci_mat)
}

F_Ricci2 <- function(i, j, a) {
  # Validate inputs
  if (i == j) return(NA_real_)
  w_e <- a[i, j]
  if (is.na(w_e) || w_e <= 0) return(NA_real_)

  # Node weights (assumed available in the calling environment)
  W_i <- 1 / sum(a[i, ])
  W_j <- 1 / sum(a[j, ])

  # Neighbours excluding the edge of interest
  Ni <- which(a[i, ] > 0)
  Nj <- which(a[j, ] > 0)
  Ni_other <- Ni[Ni != j]
  Nj_other <- Nj[Nj != i]

  # Edge weights for adjacent edges
  w_ik <- if (length(Ni_other) > 0) a[i, Ni_other] else numeric(0)
  w_jl <- if (length(Nj_other) > 0) a[j, Nj_other] else numeric(0)

  # Filter positive adjacent edge weights (safety)
  if (length(w_ik) > 0) w_ik <- w_ik[w_ik > 0]
  if (length(w_jl) > 0) w_jl <- w_jl[w_jl > 0]

  # Compute the summed terms
  sum_i <- 0
  if (length(w_ik) > 0) {
    sum_i <- W_i * sum(1 / sqrt(w_e * w_ik))
  }
  sum_j <- 0
  if (length(w_jl) > 0) {
    sum_j <- W_j * sum(1 / sqrt(w_e * w_jl))
  }

  # Forman-Ricci curvature (common weighted graph formulation)
  F_val <- (W_i + W_j) / w_e - (sum_i + sum_j)
  return(F_val)
}

F_Ricci_row <- function(i, a, neighbs) {
  return(mapply(function(j) {
    return(F_Ricci2(i, j, a))
  }, neighbs[[i]]))
}

compute_scalar_Ricci_curvature <- function(x, int_red) {
  n <- nrow(x)
  deg <- apply(int_red, 1, sum)
  D <- 1 / deg
  neighbs <- lapply(1:n, function(i) {
    return(which(int_red[i, ] > 0))
  })

  F_G_full_vec <- mcmapply(function(i) {
    v <- x[, i]
    a <- outer(v, v)
    a[which(int_red == 0)] <- 0
    F_Ricci_mat <- mapply(function(j) {
      return(F_Ricci_row(j, a, neighbs))
    }, 1:n)
    F_n <- mapply(function(k) {
      return(sum(unlist(F_Ricci_mat[[k]])))
    }, 1:length(F_Ricci_mat))
    return(F_n)
  }, 1:ncol(x), mc.cores = 8)

  return(F_G_full_vec)
}

compute_stationary_distribution <- function(x, int_red) {
  n <- nrow(x)
  mu_full_vec <- mcmapply(function(i) {
    v <- x[, i]
    a <- outer(v, v)
    a[which(int_red == 0)] <- 0
    b <- apply(a, 1, sum)
    c <- a / b
    mu <- b / sum(b)
    return(mu)
  }, 1:ncol(x), mc.cores = 8)

  return(mu_full_vec)
}

compute_total_Ricci_curvature <- function(F_G_full_vec, mu_full_vec, D) {
  F_G_pre_sum <- mu_full_vec * D * F_G_full_vec
  F_G <- apply(F_G_pre_sum, 2, sum)
  return(F_G)
}

compute_nodal_entropies <- function(x, int_red) {
  n <- nrow(x)
  ent_full_vec <- mapply(function(i) {
    v <- x[, i]
    a <- outer(v, v)
    a[which(int_red == 0)] <- 0
    b <- apply(a, 1, sum)
    c <- a / b
    e <- apply(c, 1, function(x) -sum(x * log(x, base = 2)))
    return(e)


Complete the function implementation replacing "stop("Not implemented")".