R/Functions_graph_utilities.R

In mjhelf/Metaboseek: Metaboseek platform

#' layout_components_qgraph
#' 
#' Generate subgraphs and sublayouts from a graph for Mseek interactive view.
#' 
#' @param graph an igraph object, needs to have an "id" vertex property
#' @param layout the layout function applied (from igraph or qgraph packages). 
#' Defaults to qgraph.layout.fruchtermanmeingold with some Mseek specific 
#' settings
#' @param ... arguments passed to layout (except if layout is 
#' qgraph.layout.fruchtermanreingold)
#' 
#' @import igraph
#' @import qgraph
#' 
#' @return a list of graph layouts, see \code{details}
#' 
#' @details Elements of the returned list
#' \itemize{
#' \item \code{layout} merged coordinates of all subgraphs
#' \item \code{subgraphs} result of \code{\link[igraph]{decompose}(graph)}
#' \item \code{sublayouts} list of layout coordinates for each subgraph
#' \item \code{subedgelist} list of edgelists for each subgraph
#' }
#' 
#' @examples
#' \dontrun{
#' 
#' g <- igraph::erdos.renyi.game(30, 3/30)
#' V(g)$id <- 1:30
#' 
#' l1 <- layout_components_qgraph(g, qgraph::qgraph.layout.fruchtermanreingold)
#' l2 <- layout_components_qgraph(g, igraph::layout_with_kk)
#' 
#' }
#' 
#' @export
layout_components_qgraph <- function (graph, layout, ...) 
{
  if (!is_igraph(graph)) {
    stop("Not a graph object")
  }
  
 
  
  V(graph)$id <- seq(vcount(graph))
  gl <- decompose(graph)
  el <- lapply(gl, get.edgelist, names = F)
  vl <- lapply(gl, vcount)
  al <- relist(8*(unlist(vl)^2), vl)
  rl <- relist((unlist(vl)^3.1), vl)
  if(is.character(layout)){
    layout <- eval(parse(text =  layout))
  }
  
  if(!identical(layout,qgraph.layout.fruchtermanreingold)){
    ll <- lapply(gl, layout, ...)}
  else{
    
    #if(length(el >1)){
    ll <- mapply(qgraph.layout.fruchtermanreingold,
                 el, vcount = vl, area = al, repulse.rad = rl, SIMPLIFY = F)
    #}else{
    # qgraph.layout.fruchtermanreingold(el[[1]], vcount = vl[[1]], area = al[[1]], repulse.rad = rl[[1]])
    #}
    
    #if(!is.list(ll)){ll <- list(ll)}
  }
  

  l <- merge_coords(gl, ll)
  l[unlist(sapply(gl, vertex_attr, "id")), ] <- l[]
  return(list(layout = l,
              subgraphs = gl,
              sublayouts = ll,
              subedgelist = el))
  

}


#' findsubgraph
#' 
#' Find the graph in a list of graphs that contains a vertex with a given id.
#' 
#' @param id ID of vertex
#' @param graphlist list of graphs, such as those in \code{$subgraphs} of objects 
#' generated by \code{\link{layout_components_qgraph}()}
#'
#' @import igraph
#' @export
findsubgraph <- function(id, graphlist){
  
  if(length(id) == 0){return(numeric(0))}
  
  for(i in seq(length(graphlist))){
    if(id %in% V(graphlist[[i]])$fixed__id){return(i)}
  }
  return(numeric(0))
}

#' simplifyGraph
#' 
#' Assign a color from a range of colors to all values in a numeric vector 
#' (datarange). NOTE: Edges are expected to not have a direction.
#' 
#' TODO: Debug and simplify this function
#' 
#' @param nodes a node table
#' @param edges an edge table with "from" and "to" as the first two columns. 
#' "From" and "to" have to refer to rownumbers of nodes.
#' @param mergebyedges indices by of those edges in edges that link 
#' two nodes that should be joined
#'
simplifyGraph <- function(nodes, edges, mergebyedges){
  
  if(length(mergebyedges) == 0){
    return(list(nodes = nodes,
                edges = as.data.frame(edges)))
  }
  
  edges[,1] <- as.integer(edges[,1])
  edges[,2] <- as.integer(edges[,2])
  
  
  nodes$edgeGroup = numeric(nrow(nodes))
  
  
  
  edges <- as.data.frame(edges)
  
  other_edges <- edges[-mergebyedges,]
  
  edges <- edges[mergebyedges,]
  
  for(i in seq(nrow(nodes))){
    
    if(nodes$edgeGroup[i] == 0){
      nodes$edgeGroup[i] <- i
    }
    
    selTargets <- edges[edges[,1] == i,2]
    
    if(length(selTargets) > 0){
      
      #this way, all nodes with any connections below throeshold will be in group even if it is a single link
      if(is.na(any(nodes$edgeGroup[selTargets] != 0)) 
         | !is.logical(any(nodes$edgeGroup[selTargets] != 0)) 
         | length(any(nodes$edgeGroup[selTargets] != 0)) == 0){
        
      }
      
      if(any(nodes$edgeGroup[selTargets] != 0)){
        
        supergroup <- nodes$edgeGroup[nodes$edgeGroup[selTargets] != 0][1]
        
        nodes$edgeGroup[c(i,selTargets)] <- supergroup
        
        
      }else{
        nodes$edgeGroup[selTargets] <- i
      }
      
    }
    
  }
  
  
  
  
  groups <- nodes$edgeGroup
  group = unique(groups)
  
  res_l <- lapply(group, function(group,groups,nodes){
    
    sel <- which(groups == group)
    
    # dt <- data.table(nodes[1,])
    if(length(sel) == 1){
      return(nodes[sel,])
    }
    
    
    return(as.data.frame(mapply(function(col,coln){
      
      if(coln == "mzmin"){
        return(min(col))
      }
      
      if(coln == "mzmax"){
        return(max(col))
      }
      
      if(coln == "rtmin"){
        return(min(col))
      }
      
      if(coln == "rtmax"){
        return(max(col))
      }      
      
      if(coln == "fixed__id"){
        return(paste(col, collapse = " "))
      }
      
      if(coln == "MS2scans"){
        if(!any(col != "")){return("")}
        return(paste(col[which(col != "")], collapse = "|"))
      }
      
      if(!is.numeric(col)){
        return(paste(col, collapse = " "))
      }
      
      if(is.numeric(col)){
        return(mean(col))
      }
      
      
      
      return("ERROR")
      
    }, col = nodes[sel,],
    coln = colnames(nodes),
    SIMPLIFY = F), stringsAsFactors = F))
    
    
    
  }, groups, nodes)
  
  res <- list(nodes = as.data.frame(data.table::rbindlist(res_l)))
  
  res$nodes <- data.frame(id = seq(nrow(res$nodes)),res$nodes[,colnames(res$nodes) != "id"], stringsAsFactors = F)
  
  mergetracking <- lapply(res$nodes$edgeGroup, function(ind, df){
    which(df$edgeGroup == ind)
  }, df = nodes)
  
  mergeedges <- other_edges
  
  if(nrow(other_edges) < 1){
    
    res$edges <- other_edges
    return(res)
    
  }
  
  for(i in seq(length(mergetracking)) ){
    
    mergeedges[other_edges[,1] %in% mergetracking[[i]],1] <- i
    mergeedges[other_edges[,2] %in% mergetracking[[i]],2] <- i
    
  }
  
  mergeedges <- mergeedges[mergeedges[,1] != mergeedges[,2],]
  
  #make sure that from is always < to, prevents having multiple edges between node with different direction
  if(nrow(mergeedges) > 1){
    
    asm <- as.matrix(mergeedges[,1:2])
    
    mergeedges[,1] <- Biobase::rowMin(asm)
    mergeedges[,2] <- Biobase::rowMax(asm)
    
  }else{
    mergeedges[1,1:2] <- c(min(mergeedges[1,1:2]), max(mergeedges[1,1:2]))
    
    
  }
  
  splitedges <- split(mergeedges, list(mergeedges[,1], mergeedges[,2]), drop = T)
  
  
  res$edges <- as.data.frame(data.table::rbindlist(lapply(splitedges, function(tab){
    
    outp <- data.frame(from = tab[1,1],
                       to = tab[1,2],
                       stringsAsFactors = F)
    
    for( i in colnames(tab)[c(-1,-2)] ){
      
      if(is.numeric(tab[[i]])){
        
        outp[[i]] <- mean(tab[[i]])
        outp[[paste0("min_",i)]] <- min(tab[[i]])
        outp[[paste0("max_",i)]] <- max(tab[[i]])
        outp[[paste0("median_",i)]] <- median(tab[[i]])
        
        
      }
      else{
        
        outp[[i]] <- paste(unique(tab[[i]]), collapse = " ")
        
      }
      
    }
    outp[["mergedEdges"]] <- nrow(tab)
    
    return(outp)
    
  })), stringsAsFactors = F)
  
  return(res)
  
}