R/backbone.extract.R

In KGodard1/Fastball-SourceCpp: Extracts the Backbone from Weighted Graphs

#' Extracts the backbone of a weighted network using results from a null model
#'
#' `backbone.extract` returns a binary or signed adjacency matrix
#'      containing the backbone that retains only the significant edges.
#'
#' @param backbone backbone: backbone S3 class object.
#' @param signed Boolean: TRUE if signed backbone is to be returned, FALSE if binary backbone is to be returned
#' @param alpha Real: significance level of hypothesis test(s)
#' @param fwer string: type of familywise error rate correction to be applied; c("none","bonferroni","holm"). If "holm", Holm Bonferroni Family-wise Error Rate test is used,
#'     if "bonferroni", Bonferroni Family-wise Error Rate test should be used. By default, the given 'alpha' value is used for all tests with no correction for family-wise error rates.
#' @param class string: the class of the returned backbone graph, one of c("original", "matrix", "sparseMatrix", "igraph", "network", "edgelist"), converted via \link{tomatrix}.
#'     If "original", the backbone graph returned is of the same class as the data used to generate the backbone object.
#' @param narrative Boolean: TRUE if suggested text for a manuscript is to be returned.
#' @return backbone graph: Binary or signed backbone graph of class given in parameter `class`.
#'
#' @details The "backbone" S3 class object is composed of two matrices, a summary dataframe and (optionally, if generated by using \link{fdsm}) a 'dyad_values' vector.
#'     This object is returned by \link{sdsm}, \link{fdsm}, \link{fixedrow}, \link{fixedcol}, \link{fixedfill}.
#' @details The Holm Bonferroni correction was originally a port from python code written by \href{ https://github.com/saref}{Dr. Samin Aref}.
#'     The authors thank Dr. Aref greatly for his contribution to this package!
#'
#' @export
#'
#' @examples
#' probs <- sdsm(davis)
#' bb <- backbone.extract(probs, alpha = .2, signed = TRUE, fwer = "none")
backbone.extract <- function(backbone, signed = FALSE, alpha = 0.05, fwer = "none", class = "original", narrative = FALSE){

  #### Argument Checks ####
  if ((alpha >= 1) | (alpha <= 0)) {stop("alpha must be between 0 and 1")}
  if ((class != "original")
      & (class != "matrix")
      & (class != "Matrix")
      & (class != "sparseMatrix")
      & (class != "igraph")
      & (class != "network")
      & (class != "edgelist"))
  {stop("incorrect class type, must be one of c(original, matrix, Matrix, sparseMatrix, igraph, network, edgelist)")}

  #### Extract Components of Backbone Object and Function ####
  positive <- as.matrix(backbone[[1]])
  negative <- as.matrix(backbone[[2]])
  summary <- backbone$summary
  model <- summary["Model",1]
  if (class == "original") {class <- summary["Input Class",1]}
  agents <- summary["Number of Rows",1]
  artifacts <- summary["Number of Columns",1]
  original.alpha <- alpha
  type <- "binary"
  if (signed == TRUE) {type <- "signed"}
  correction <- ""
  if (fwer == "bonferroni") {correction <- ", Bonferroni corrected"}
  if (fwer == "holm") {correction <- ", Holm-Bonferroni corrected"}

  if ((model == "Fixed Degree Sequence Model") & (fwer != "none")){
    warning("Use caution when applying Holm-Bonferroni or Bonferroni correction to backbones
             found via the Fixed Degree Sequence Method as the precision of the p-values
             depends on the number of trials.")
  }

  ### Auxiliary Values ###
  alpha <- alpha/2  #Alpha for each tail (all tests are two-tailed)
  n <- dim(positive)[1] #Number of nodes in backbone
  if (model=="Fixed Fill Model" | model=="Fixed Row Model" | model=="Fixed Column Model" |                 #For bipartite backbones,
      model=="Stochastic Degree Sequence Model" | model=="Fixed Degree Sequence Model") {m <- (n*(n-1))/2} #number of independent tests

  #### Find p-value in the More Extreme Tail ####
  backbone <- pmin(positive,negative)  #matrix of smaller p-value from positive and negative
  diag(backbone) <- NA  #remove diagonal

  #### FWER Computations ####
  ### FWER: No correction ###
  if(fwer=="none"){backbone <- (backbone < alpha)*1}  #significant edges

  ### FWER: Bonferroni correction ###
  if(fwer=="bonferroni"){
    alpha <- alpha/m  #bonferroni correction
    backbone <- (backbone < alpha)*1  #significant edges
  }

  ### FWER: Holm-Bonferroni correction ###
  if(fwer=="holm"){
    backbone[upper.tri(backbone)] <- NA  #remove upper triangle
    rank <- matrix(rank(backbone,na.last="keep",ties.method="random"),nrow=nrow(positive),ncol=ncol(positive)) #rank of pvalue
    holm.alphas <- alpha/(m-rank+1)  #Holm-Bonferroni step-down p-values
    backbone <- (backbone < holm.alphas)*rank  #ranks of *potentially* significant edges

    first.nonsig <- min(setdiff(c(0:m),backbone))  #find first non-significant edge rank
    backbone[backbone>=first.nonsig] <- 0  #set this and higher edge ranks as non-significant
    backbone[backbone>0] <- 1 #set remaining edge ranks as significant

    backbone[upper.tri(backbone)] <- 0  #fill upper triangle with 0s
    backbone <- backbone + t(backbone)  #fill the upper triangle with the lower triangle
  }

  #### Insert Edge Signs, Fill Diagonal of Backbone Matrix ####
  sign <- (negative<positive)*-1  #sign of edge, if it were significant
  sign[sign==0] <- 1
  backbone <- backbone*sign  #apply appropriate sign to significant edges
  if(signed==FALSE) {backbone[backbone==-1] <- 0}  #if binary backbone requested, change -1s to 0s
  if (model=="Fixed Fill Model" | model=="Fixed Row Model" | model=="Fixed Column Model" |                     #For bipartite backbones,
      model=="Stochastic Degree Sequence Model" | model=="Fixed Degree Sequence Model") {diag(backbone) <- 0}  #fill diagonal with 0s

  #### Display suggested manuscript text ####
  if (narrative == TRUE) {
    message("=== Suggested manuscript text and citations ===")
    message(" ")

    text <- paste0("From a bipartite graph containing ", agents, " agents and ", artifacts, " artifacts, we obtained the weighted bipartite projection, then extracted its ", type, " backbone using the backbone package (Domagalski, Neal, & Sagan, 2021).")
    text <- paste0(text, " Edges were retained in the backbone if their weights were statistically significant (alpha = ", original.alpha, correction,") by comparison to a null ", model)
    if (model == "Fixed Row Model") {text <- paste0(text, " (FRM; Neal, 2013).")}
    if (model == "Fixed Column Model") {text <- paste0(text, " (FCM; Neal, Domagalski, and Sagan, 2021).")}
    if (model == "Fixed Fill Model") {text <- paste0(text, " (FFM; Neal, Domagalski, and Sagan, 2021).")}
    if (model == "Stochastic Degree Sequence Model") {text <- paste0(text, " (SDSM; Neal, 2014).")}
    if (model == "Fixed Degree Sequence Model") {text <- paste0(text, " (FDSM; Zweig & Kaufmann, 2011).")}

    message(text)
    message("")
    message("Domagalski, R., Neal, Z. P., and Sagan, B. (2021). backbone: An R Package for Backbone Extraction of Weighted Graphs. PLoS ONE. https://doi.org/10.1371/journal.pone.0244363")
    message("")
    if (model == "Stochastic Degree Sequence Model") {message("Neal, Z. P. (2014). The backbone of bipartite projections: Inferring relationships from co-authorship, co-sponsorship, co-attendance and other co-behaviors. Social Networks, 39, 84-97. https://doi.org/10.1016/j.socnet.2014.06.001")}
    if (model == "Fixed Row Model") {message("Neal. Z. P. (2013). Identifying statistically significant edges in one-mode projections. Social Network Analysis and Mining, 3, 915-924. https://doi.org/10.1007/s13278-013-0107-y")}
    if (model == "Fixed Degree Sequence Model") {message("Zweig, K. A. and Kaufmann, M. (2011). A systematic approach to the one-mode projection of bipartite graphs. Social Network Analysis and Mining, 1, 187-218. https://doi.org/10.1007/s13278-011-0021-0")}
    if (model == "Fixed Column Model") {message("Neal, Z. P., Domagalski, R., and Sagan, B. 2021. Comparing models for extracting the backbone of bipartite projections. arXiv:2105.13396 [cs.SI]).")}
    if (model == "Fixed Fill Model") {message("Neal, Z. P., Domagalski, R., and Sagan, B. 2021. Comparing models for extracting the backbone of bipartite projections. arXiv:2105.13396 [cs.SI]).")}
  }

  backbone <- frommatrix(backbone, class)
  return(backbone)
}