R/streamstatistics2.R

In esm-ispm-unibe-ch/flow_contribution: Contribution of studies in Network Meta-analysis

comparisonStreams = function(hatmatrix, comparison){
  
  library(rlist)
  library(igraph)
  
  directs <- hatmatrix$colNames
  
  hatMatrix <- hatmatrix$H
  
  rownames(hatMatrix) <- hatmatrix$rowNames
  
  split <- function (dir) {strsplit(dir,":")}
  
  dims <- dim(hatMatrix)
  
  #rows of comparison matrix 
  comparisons <- unlist(lapply(rownames(hatMatrix),unlist))
  
  comparisonToEdge <- function (comp) unlist (split(comp))
  
  directlist <- unlist(lapply(lapply(directs,split),unlist))
  # print(c("dir",directs))
  
  edgeList <- matrix( directlist, nc = 2, byrow = TRUE)
  # print(c("Edgelist"))
  # print(edgeList)
  
  g <- graph_from_edgelist(edgeList , directed=FALSE)
  g <- set.vertex.attribute(g,'label',value = V(g))
  g <- set.edge.attribute(g,'label',value = E(g))
  #print(V(g)$label)
  #print(V(g)$name)
  #print(E(g))
  
  setWeights <- function (g,comparison,conMat) {
    set.edge.attribute(g,"weight",value=rep(0,dims[2]))
  }
  
  
  getFlow <- function(g,edge) {return(E(g)[edge]$flow)}
  
  sv <- function (comparison) {split(comparison)[[1]][1][1]}
  
  tv <- function (comparison) {split(comparison)[[1]][2][1]}
  
  initRowGraph <- function(comparison) {
    dedgeList <- lapply(1:length(directs),function(comp) {
      if(hatMatrix[comparison,comp]>0){
        # print(c("not switched",directs[comp],hatMatrix[comparison,comp]))
        return (c(sv(directs[comp]),tv(directs[comp])))
      }else{
        # print(c("switched",directs[comp],hatMatrix[comparison,comp]))
        return (c(tv(directs[comp]),sv(directs[comp])))
      }
    })
    dedgeList <- matrix( unlist(dedgeList), nc = 2, byrow = TRUE)
    # gg <- setFlow(g,comparison)
    # E(gg)$weight <- rep(0,dims[2])
    # return(gg)
    flows<-abs(hatMatrix[comparison,])
    dg <- graph_from_edgelist(dedgeList , directed = TRUE)
    E(dg)[]$weight <- rep(0,dims[2])
    E(dg)[]$flow <- abs(hatMatrix[comparison,])
    V(dg)[]$label <- V(dg)[]$name
    # E(dg)[]$label <- E(dg)[]$flow
    dg <- set.edge.attribute(dg,'label',value = E(dg))
    # print(c("isdirected",is.directed(dg)))
    return(dg)
  }
  
  contribution = rep(0,dims[2])
  streams = list()
  names(contribution) <- c(1:dims[2])
  
  reducePath <- function (g,comparison,spl) {
    pl <- length(spl[[1]])
    splE <- lapply(spl[[1]], function(e){
      return (E(g)[e[]])
    })
    flow <- min(unlist(lapply(splE, function(e){
      return(e$flow[])
    })))
    path = toString(names(unlist(lapply(spl,function(e){c(head_of(g,e),tail_of(g,e))}))))
    streams <<- list.append(streams,data.frame(comp=comparison,length=floor(length(splE)),stream=path,flow=flow))
    # print(c("to shortest path einai :",spl))
    gg <- Reduce(function(g, e){
      elabel <- e$label
      # print(c("pame plevra:",e,"dld",e$label))
      pfl <- e$flow[]
      g <- set.edge.attribute(g,"flow",e, pfl-flow)
      # print(c("h e",e,"einai pragmatika h ",elabel))
      cw <-  e$weight[] + (flow[1]/pl) 
      # print(c("flow",flow,"eweight",e$weight[]))
      contribution[elabel] <<- cw
      return(set.edge.attribute(g,"weight",e, cw))
    },splE, g)
    # print(c("graph before deleting edges", E(gg)$label))
    emptyEdges <- Reduce(function(removedEdges, e){
      e <- E(gg)[e[]]
      if(e$flow[[1]][[1]]==0){
        removedEdges <- c(removedEdges, e)
      }
      return(removedEdges)
    },splE, c())
    # print(c("edges to be removed",emptyEdges))
    return(delete_edges(gg, emptyEdges))
    # print(c("graph after deleting edges", E(gg)$label))
  }
  
  reduceGraph <- function (g,comparison) {
    getshortest <- function (g,compariston) {
      floweights = lapply(edge_attr(g,"flow",E(g)), function(f){return(abs(2-f))})
      spths = suppressWarnings(
        get.shortest.paths(g,sv(comparison),tv(comparison),mode="out",output="epath",weights=floweights)
      )
      return(spths$epath)
    }
    # while(edge_connectivity(g,sv(comparison),tv(comparison))>0){
    spath <- getshortest(g,comparison)
    while(length(unlist(spath))>0){
      g <- reducePath(g,comparison,spath)
      spath <- getshortest(g,comparison)
    }
    # print("teleiwse")
    return(g)
  }
  
  # ptm <- proc.time()
  # gg <- reduceGraph (initRowGraph(comparison), comparison)
  reduceGraph (initRowGraph(comparison), comparison)
  # executionTime <- proc.time() - ptm
  # print(c("execution time",executionTime))
  
  names(contribution) <- directs
  contribution <- 100 * contribution
  
  return(list( streams=streams
              ,contribution=contribution
               
  ))
}