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

#### Defines functions comparisonStreams

```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[])
})))
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

))
}
```
esm-ispm-unibe-ch/flow_contribution documentation built on Nov. 12, 2018, 4:36 p.m.