Resistance-Equivalent Graphs

Author

Eric W. Weisstein
September 5, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Resistance-EquivalentGraphs.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Resistance-EquivalentGraphs.html.

©2024 Wolfram Research, Inc. except for portions noted otherwise

Counts

Determined by resistance

A178944

Table[Count[Length/@Split[Sort[Hash/@ReadList[FileNameJoin[{$GraphDataDirectory,"Nodes","ResistanceDistance","ResistanceDistance_"<>If[n<10,"0",""]<>ToString[n]<>".m"}],String]]],1],{n,10}]

Length/@Table[GraphData["DeterminedByResistance",n],{n,10}]

Not determined by resistance

A178999

Table[Total[DeleteCases[Length/@Split[Sort[Hash/@ReadList[FileNameJoin[{$GraphDataDirectory,"Nodes","ResistanceDistance","ResistanceDistance_"<>If[n<10,"0",""]<>ToString[n]<>".m"}],String]]],1]],{n,10}]

Length/@Table[GraphData["NotDeterminedByResistance",n],{n,10}]

Special resistance-equivalent

SetDirectory[FileNameJoin[{$GraphDataDirectory,"Nodes","ResistanceDistance"}]]

20-Vertex

http://groups.google.com/group/comp.theory/msg/53976638ed387d76?dmode=source

Built-In

GraphData["Resistance*"]

GraphData/@%

FastIsomorphicQ@@(Graph/@GraphData["Resistance*"])

Factor[ChromaticPolynomial[Graph[{"ResistanceEquivalent",{20,1}}],x]]//Timing

Factor[ChromaticPolynomial[Graph[{"ResistanceEquivalent",{20,2}}],x]]//Timing

(((-1+#))^17) # (3-3 #+((#)^2))&

Construction

ShowLabeledGraph[g1=Graph[List/@Join[
Partition[Range[11,16],2,1],
Partition[Range[5,10],2,1],
{5,16}+#&/@Range[4],
{{1,3},{2,4},{3,13},{4,14},{13,7},{14,8}}
],List/@{{3,4},{4,4},{3,3},{4,3},Sequence@@Flatten[Table[{i,j},{j,2},{i,6}],1],{2,0},{3,0},{4,0},{5,0}}]]

V/@{g1,g2}

ResistanceMatrix[g1]

ShowLabeledGraph[g2=DeleteEdges[Graph[List/@Join[
Partition[Range[11,16],2,1],
Partition[Range[5,10],2,1],
{5,16}+#&/@Range[4],
{{1,3},{2,15},{3,13},{4,14},{13,7},{14,8},{19,20}}],List/@{{3,4},{5,3},{3,3},{4,3},Sequence@@Flatten[Table[{i,j},{j,2},{i,6}],1],{2,0},{3,0},{4,0},{4,-1}}],{9,20}]]

SameQ@@(Sort[Flatten[ResistanceMatrix[#],1]]&/@{g1,g2})

GraphicsGrid[{GraphPlot[#,Method->None]&/@{g1,g2}}]

GraphDataString

file=OpenWrite["resist.m"]

WriteString[file,GraphDataString[g1,
"StandardName"->{"ResistanceEquivalent",{20,1}},
"Name"->"20-resistance-equivalent graph 1",
"Information"->"Resistance-EquivalentGraphs",
Debug->True,
TimeConstraint->300
]]

WriteString[file,GraphDataString[g2,
"StandardName"->{"ResistanceEquivalent",{20,2}},
"Name"->"20-resistance-equivalent graph 2",
"Information"->"Resistance-EquivalentGraphs",
Debug->True,
TimeConstraint->300
]]

Close[file]

60-Vertex biconnected

s=1/Sqrt[2.]

ShowLabeledGraph[treeA=Graph[List/@{{7,4},{4,2},{2,1},{2,5},{1,3},{3,6}},List/@{{0,0},{-.5,s},{.5,s},{-1,2s},{0,2s},{1,2s},{-1.5,3s}}]]

ShowLabeledGraph[treeB=Graph[List/@{{7,4},{4,2},{2,1},{3,5},{1,3},{3,6}},List/@{{0,0},{-.5,s},{.5,s},{-1,2s},{0,2s},{1,2s},{-1.5,3s}}]]

ShowLabeledGraph[gT=AddEdges[AddVertices[ChangeVertices[GraphUnion[treeA,treeB,treeA,treeB],Join[
((RotationMatrix[45.Degree].#)+{-1,s})&/@Vertices[treeA],
((RotationMatrix[-45.Degree].#)+{1,s})&/@Vertices[treeB],
((RotationMatrix[135.Degree].#)+{-1,-s})&/@Vertices[treeA],
((RotationMatrix[-135.Degree].#)+{1,-s})&/@Vertices[treeB]]],{{-.5,0},{.5,0}}],{{1,29},{15,29},{29,30},{30,8},{22,30}}]]

ShowGraph[gT2=GraphDouble[gT]]

ShowLabeledGraph[gU=AddEdges[AddVertices[ChangeVertices[GraphUnion[treeA,treeA,treeB,treeB],Join[
((RotationMatrix[45.Degree].#)+{-1,s})&/@Vertices[treeA],
((RotationMatrix[-45.Degree].#)+{1,s})&/@Vertices[treeA],
((RotationMatrix[135.Degree].#)+{-1,-s})&/@Vertices[treeB],
((RotationMatrix[-135.Degree].#)+{1,-s})&/@Vertices[treeB]]],{{-.5,0},{.5,0}}],{{1,29},{15,29},{29,30},{30,8},{22,30}}]]

TreeQ[gU]

ShowGraph[gU2=GraphDouble[gU]]

TreeQ[gU2]

FastIsomorphicQ[gT,gU]

FastIsomorphicQ[gT2,gU2]

GraphicsGrid[{GraphPlot[#,Method->None]&/@{gT,gU}}]

GraphicsGrid[{GraphPlot[#,Method->{"SpringElectricalEmbedding","RepulsiveForcePower"->-1.9}]&/@{gT2,gU2}}]

GraphData[{"ResistanceEquivalent",{60,#}}]&/@{1,2}

rs=ResistanceMatrix/@{gT2,gU2};

Equal@@(Sort/@Flatten/@Normal/@rs)

Embeddings

GraphData[{"ResistanceEquivalent",{60,#}}]&/@{1,2}

GraphData[{"ResistanceEquivalent",{60,#}},"Graph","All"]&/@{1,2}

GraphData[{"ResistanceEquivalent",{60,#}},"Embeddings"]&/@{1,2}

GraphData[{"ResistanceEquivalent",{60,#}},"EmbeddingClasses"]&/@{1,2}

{g1,g2}=PlanarGraph[GraphData[{"ResistanceEquivalent",{60,#}}],GraphLayout->"PlanarEmbedding"]&/@{1,2}

l={
{g={"ResistanceEquivalent",{60,1}},{0,List@ToCommonEdges[g1,GraphData[g]]//Round}},
{g={"ResistanceEquivalent",{60,2}},{0,List@ToCommonEdges[g2,GraphData[g]]//Round}}
}

PropertyReplace[l,"Embeddings","11.3"]

RenameGraphFiles[]

l2={#1,{0,{{"IntegerCoordinates","MinimalCrossing","Planar","Primary"}}}}&@@@l

PropertyReplace[l2,"EmbeddingClasses","11.3"]

RenameGraphFiles[]

GraphDataString

file=OpenWrite["res.m"]

WriteString[file,GraphDataString[gT2,
"StandardName"->{"ResistanceEquivalent",{60,1}},
"Name"->"60-resistance equivalent graph 1",
"Classes"->{"NotDeterminedByResistance"},
"Information"->"Resistance-EquivalentGraphs",
Debug->True,
TimeConstraint->120
]]

WriteString[file,GraphDataString[gU2,
"StandardName"->{"ResistanceEquivalent",{60,2}},
"Name"->"60-resistance equivalent graph 2",
"Classes"->{"NotDeterminedByResistance"},
"Information"->"Resistance-EquivalentGraphs",
Debug->True,
TimeConstraint->120
]]

Write files

SetDirectory[FileNameJoin[{$GraphDataDirectory,"Nodes","ResistanceDistance"}]]

Do[Graphs[i],{i,10}];//Timing//AbsoluteTiming

Monitor[Do[i=0;cnt=Length[Graphs[n]];Print[{n,Export[
"ResistanceDistance_"<>If[n<10,"0",""]<>ToString[n]<>".m",
With[{r=DeleteCases[Sort[Flatten[ResistanceMatrix[i++;#]],1],0]},If[r==={},{},{lcm=LCM@@Denominator[r],Tally[Sort[lcm r]]}]]&/@Graphs[n],
"Lines"
]//Timing}],{n,10}],Row[{n,": ",i,"/",cnt}]]

Compute 1-10 nodes

Compute

$GraphData10Nodes=GraphData[;;10];

(valid[#]=True)&/@$GraphData10Nodes;
valid[_]=False;

$GraphDataIndexRules=Association[(If[(c=Cases[GraphData[#,"StandardNames"],{_Integer,_Integer}])==={},Print[#];$Failed,c[[1]]]->#)&/@$GraphData10Nodes];

ComputeResistanceEquivalent[n_]:=Module[
(* Import[...,"Lines"] takes > 50 GB on a 5 GB file, so use ReadList[..., String] *)
{groups={n,#}&/@#[[All,2]]&/@Select[SplitBy[Sort[MapIndexed[{#,#2[[1]]}&,Hash/@ReadList[FileNameJoin[{$GraphDataDirectory,"Nodes","ResistanceDistance","ResistanceDistance_"<>If[n<10,"0",""]<>ToString[n]<>".m"}],String]]],First],Length[#]>1&],
c
},
groups=(groups/.$GraphDataIndexRules);
groups=Pick[groups,valid/@Or@@#&/@groups];
Flatten[((First[#]->SortBy[Rest[#],First[Flatten[{#}]]&])&/@Pick[c=NestList[RotateRight,#,Length[#]-1],valid/@c[[All,1]]])&/@groups]
]

Table[ComputeResistanceEquivalent[n],{n,8}]

ComputeResistanceEquivalent[9]

Length[%]

(cores=Join@@Monitor[Table[ComputeResistanceEquivalent[n],{n,10}],n])//Length//Timing

cores

cores[[All,1]]

CoresistanceGraphNames

l={#1,{0,#3}}&@@@DeleteCases[{#1,GraphData[#1,"CoresistanceGraphNames"],#2}&@@@cores,{_,x_,x_}]

PropertyReplace[l,"CoresistanceGraphNames","14.2"]

RenameGraphFiles[]

DeterminedByResistance === True

l2={#,{0,True}}&/@Select[Complement[GraphData[;;10],cores[[All,1]]],GraphData[#,"DeterminedByResistance"]=!=True&]

MissingFillin[l2,"DeterminedByResistance"]

RenameGraphFiles[]

DeterminedByResistance === False

l3={#,{0,False}}&/@Select[cores[[All,1]],GraphData[#,"DeterminedByResistance"]=!=False&]

MissingFillin[l3,"DeterminedByResistance"]

RenameGraphFiles[]

Compute >10 nodes

Compute

GraphData["ResistanceEquivalent*"]

GraphData[{"ResistanceEquivalent",{60,1}},"ResistanceMatrix"]

groups=SplitBy[Sort[{Sort[Flatten[Normal@GraphData[#,"ResistanceMatrix"]]],#}&/@Intersection[GraphData[11;;],GraphData["ResistanceMatrix","Defined"]]],First];

coresist=Pick[groups,Length/@groups,Except[1,_Integer]][[All,All,2]]

CoresistanceGraphNames

new=DeleteCases[
{#[[1]],GraphData[#[[1]],"CoresistanceGraphNames"],SortBy[Rest[#],Function[f,First[Flatten[{f}]]]]}&/@(Flatten[NestList[RotateRight,#,Length[#]-1]&/@coresist,1]),
{_,x_,x_}]

l={#1,{0,#3}}&@@@new

PropertyReplace[l,"CoresistanceGraphNames","14.2"]

RenameGraphFiles[]

DeterminedByResistance

l2={#,{0,False}}&/@Select[Flatten[coresist,1],GraphData[#,"DeterminedByResistance"]=!=False&]

MissingFillin[l2,"DeterminedByResistance"]

RenameGraphFiles[]