Mathematica Asked on January 13, 2021
I have the following Codes (developed by @Mr.Wizard and @kglr, respectively):
multiplierB[M_?MatrixQ,
sec_Integer] := ((#/Tr[#] & /@ N[M[Transpose]])[Transpose] //
Take[#, sec, sec] & // Inverse[IdentityMatrix[sec] - #] &);
UnweightedTransmission[matrixA_?MatrixQ,matrixB_?MatrixQ,t1_Real,
t2_Real] :=
Module[{indices =
Union @@ (Partition[#, 2, 1] & /@
FindPath[
AdjacencyGraph[
Map[Boole[t1 <= # <= t2] &,
matrixA, {-1}]], #[[1]], #2[[1]], [Infinity], All])},
HighlightGraph[
Graph[DirectedEdge @@@ indices,
EdgeWeight -> Extract[matrixB, indices],
EdgeLabels -> "EdgeWeight", ##3], {#, #2}]] &;
Example: Using the above Codes, I perform the following calculations:
mat = {{10, 60, 5, 9, 12, 4}, {20, 30, 40, 30, 30, 50}, {10, 20, 20, 90, 60, 200}, {30, 12, 24, 120, 90, 324}, {6, 24, 12, 21, 15, 222}, {24, 54, 299, 330, 93, 0}};
multp = multiplierB[mat, 5];
SeedRandom[01];
trans = RandomInteger[6, {5, 5}];
gr1 = UnweightedTransmission[multp, trans, 0.1, 1.5][{1}, {5},
VertexLabels -> "Name"]
gr1 = Graph[gr1,
VertexCoordinates ->
GraphEmbedding[gr1]]; (*fixes the vertex coordinates of "gr"*)
Below, I show the original digraph gr1
(on the left) and the digraph after deleting vertex 2
from gr1
(on the right). Obviously, EdgeWeight
s in gr1
are not preserved in the digraph on the right. How can I fix the coordinates of edges and weights in gr1
after deleting vertex 2
from gr1
? I tried the above operations with various examples, and all of them give the contradictory mapping of the edge weights after deleting a vertex from the original digraph.
{gr1, VertexDelete[gr1, {2}]}
Get help from others!
Recent Questions
Recent Answers
© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP