12
$\begingroup$

I am trying to efficiently extract sub-graphs from very large weighted directed graphs. I thought Subgraph would do this, but it does not, which seems a bit odd since edge weights are intrinsic properties of the graph.

First, a toy directed, weighted graph as an example:

size = 10;
rAm = Table[If[Or[i  == j, RandomReal[{0, 1}] < .8], Infinity, 
         RandomInteger[{1, 100}] - 1], {i, size}, {j, size}];
wAg = WeightedAdjacencyGraph[rAm]

enter image description here

Extracting the weighted adjacency matrix

MatrixForm[WeightedAdjacencyMatrix[wAg]

enter image description here

But when I extract a subgraph that includes the first 6 vertices, the edge weights are not preserved.

rSg = Subgraph[wAg, Range[6]]
WeightedAdjacencyMatrix[rSg] // MatrixForm

enter image description here

I would expect:

enter image description here

Edge weights do not come with the Subgraph even if I specify edges, as opposed to vertices.

Improve this question
$\endgroup$

4 Answers 4

Reset to default
6
$\begingroup$

Potential solution could be:

Clear[exWtSuGr];
exWtSuGr[gr_, verts_] := Module[{sg, el, ew, wAg}, {
    sg = Subgraph[gr, verts];
    el = EdgeList[sg];
    ew = PropertyValue[{gr, #}, EdgeWeight] & /@ el;
    wAg = Graph[verts, el, EdgeWeight -> ew]
    }[[1]]]

GR1 = exWtSuGr[wAg, Range[6]]
WeightedAdjacencyMatrix[GR1] // MatrixForm

enter image description here

Improve this answer
$\endgroup$
5
$\begingroup$

Why not just use WeightedAdjacencyGraph on the relevant part of the weighted adjacency matrix? The only issue with this approach is that WeightedAdjacencyGraph expects Infinity for missing edges instead of 0. The following function accounts for this:

subgraph[g_, v_] := WeightedAdjacencyGraph @ fixBackground @ WeightedAdjacencyMatrix[g][[v, v]]
fixBackground[sa_SparseArray] := Replace[
    sa,
    Verbatim[SparseArray][a_, b_, _, c__] :> SparseArray[a, b, Infinity, c]
]

Using a version of your example:

SeedRandom[0];
size=10;
rAm=Table[If[Or[i==j,RandomReal[{0,1}]<.8],Infinity,RandomInteger[{1,100}]-1],{i,size},{j,size}];
wAg=WeightedAdjacencyGraph[rAm]

enter image description here

we get (note the correct adjacency matrix):

subgraph[wAg, {1,3,5,7,9}]
WeightedAdjacencyMatrix[%] //MatrixForm //TeXForm

enter image description here

$\left( \begin{array}{ccccc} 0 & 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0 & 14 \\ 95 & 97 & 0 & 0 & 0 \\ 0 & 0 & 25 & 0 & 76 \\ 0 & 0 & 0 & 0 & 0 \\ \end{array} \right)$

The graph looks the same as what is returned by Subgraph:

enter image description here

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ This is basically what I do (and what I almost posted earlier today). IGWeightedAdjacencyGraph from IGraph/M can use any element to indicate a non-existent connection, so adding Infinity wouldn't be necessary. Some minor problems with your implementation: 1. the null graph has no adjacency matrix and therefore needs special handling. 2. directedness needs to be explicitly transferred, otherwise a directed graph that is identical to its reverse will get converted to undirected. 3. the vertex names may not be identical to the vertex indices; they may not even be integers. $\endgroup$
    – Szabolcs
    Jan 6, 2018 at 19:32
  • 1
    $\begingroup$ I had this when I decided not to post after all (because the performance gain wasn't significant enough, and if performance were the goal, other, much uglier solutions could help). $\endgroup$
    – Szabolcs
    Jan 6, 2018 at 19:35
2
$\begingroup$

Or maybe:

subGraphWeightLookup = 
 Association[Thread[EdgeList[wAg] -> 
 DeleteCases[
  Flatten[ReplacePart[Normal[WeightedAdjacencyMatrix[wAg]], 
    Position[rAm, 0] -> -1]], 0]]] /. x_ /; x == -1 -> 0;

(The -1 is a dummy variable allowing reinsertion of '0' elements.)

Subgraph[wAg, Range[6], 
 EdgeWeight -> (subGraphWeightLookup[#] & /@ 
    EdgeList[Subgraph[wAg, Range[6]]])]

WeightedAdjacencyMatrix[%] // MatrixForm
Improve this answer
$\endgroup$
2
$\begingroup$

IGraph/M now includes IGWeightedSubgraph, a function to extract subgraphs while preserving edge weights. Unlike the adjacency matrix method, it also works with multigraphs.

This is reliable and marginally faster than the original solution by GraphMan. It makes use of IGraph/M.

ClearAll[subgraph]
subgraph[g_?MultigraphQ, vs_List] := $Failed
subgraph[g_?MixedGraphQ, vs_List] := $Failed
subgraph[wg_?GraphQ, {}] := IGEmptyGraph[] (* also works around bug in M versions where Subgraph fails on empty graphs *)
subgraph[wg_?IGEdgeWeightedQ, vs_List] :=
    With[{ind = VertexIndex[wg, #] & /@ vs},
      IGWeightedAdjacencyGraph[
       VertexList[wg][[ind]],
       WeightedAdjacencyMatrix[wg][[ind, ind]],
       DirectedEdges -> DirectedGraphQ[wg]
      ]
    ]
subgraph[g_?GraphQ, vs_List] := Subgraph[g, vs]
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.