New answers tagged graphs-and-networks
3
Correct me if I'm wrong, you're looking for 10,000 lists each with length 13, every element can be {1,2,3,4} and each list has at least 5 hamming distances from the rest.
It's probably beyond the realm of this community to use other languages but since it's substantially faster, I decide to write this answer with Julia (from version 12.1 can be run inside ...
6
Might be faster to cull as you go. I compile the selection function (possibly it can be made faster). Also I set the history length to zero although that does not help too much because the Select entails a big memory hit at least one time.
$HistoryLength = 0;
selectHam =
Compile[{{ll, _Integer, 2}, {vec, _Integer, 1}, {n, _Integer}},
Select[ll, (Min[...
0
You could use Reap and Sow and a loop over possible pairs. Here is a small example:
all = Tuples[Range[2], 3];
res = Reap[
Do[If[HammingDistance[all[[i]], all[[j]]] > 2,
Sow[{all[[i]], all[[j]]}]], {i, Length[all]}, {j, 1, i - 1}];
][[2]];
res
9
Edit-3
{m, n, o} = {3, 5, 7};
Graphics[{EdgeForm[Blue], FaceForm[],
RegularPolygon[#, {1, 0},
6] & /@ (Sqrt[
3] SolveValues[{0 <= x <= o - 1, 0 <= y <= n - 1,
0 <= z <= m - 1, x == 0 || y == 0 || z == 0}, {x, y, z},
Integers] . CirclePoints[{1, Pi/6}, 3])}]
{x, y, z} = {7, 5, 3};
bases = CirclePoints[{1,...
4
Define findParent as:
ClearAll[findParent]
findParent = Thread[# -> WikidataData[#,
ExternalIdentifier["WikidataID", "P279", <|"Label" -> "SubclassOf"|>]] ] &;
edges = Flatten[findParent /@ list3];
Graph[edges,
VertexShapeFunction ->
(Text[Framed @ Style[#2["Label"] /. ...
0
A recursive approach to generate the walks:
ClearAll[nextEdges, addEdge, startWith, eWalks, vWalks]
nextEdges[g_] := AssociationThread[VertexList[g],
Thread[DirectedEdge[#, AdjacencyList[g][[#]]]] & /@ VertexList[g]]
addEdge[g_, wpath_][edges_] := Append[edges, #] & /@
(Select[nextEdges[g]@edges[[-1, -1]], PropertyValue[{g, #}, EdgeLabels] == ...
5
ClearAll[wWalks]
wWalks[g_, wpath_] := Module[{dg = DirectedGraph @ g, edgetuples},
edgetuples = Tuples[EdgeList[dg, _?(Function[e,
PropertyValue[{dg, e}, EdgeLabels] == #])] & /@ wpath];
PadRight[VertexList @ #, 1 + Length @ wpath, "Periodic"] & /@
Select[And @@ Equal @@@ Partition[#[[2 ;; -2]], 2] & @ Flatten @ (...
0
You need not reinvent the wheel. If I correctly understand your "My goal is to find the number of paths path = {1, 2, 3} in it", the FindPath command does the job.
W = {1, 2, 3};n = 5; $RecursionLimit = 10^4;el = EdgeList[CompleteGraph[n]];
g = CompleteGraph[n, VertexLabels -> "Name",
EdgeLabels -> Table[el[[i]] -> RandomChoice[...
4
According to Wikipedia, a graph is Apollonian if it is chordal and maximal planar. IGraph/M implements checks for these. Thus we can use
Needs["IGraphM`"]
apollonianQ[g_?UndirectedGraphQ] := IGChordalQ[g] && IGMaximalPlanarQ[g]
Let us generate a few non-isomorphic Apollonian networks on v=8 vertices using rejection sampling:
v = 8;
Table[
...
5
Update 2:
ClearAll[nG0]
nG0 = NestGraph[x |-> (F @@ (List @@ x + {#, 1}) & /@ {1, 3, 5}),
F[2, 1], #,
VertexLabels -> {v_ :> Placed[v[[1]], Center]}, ##2,
VertexSize -> Large, VertexStyle -> LightOrange] &;
Examples:
nG0[#, ImageSize -> 1 -> 50] & /@ {3, 5} // Row
Original answer:
ClearAll[f, nG]
f = Apply[...
5
Not pretty, but it works
NestGraph[Function[x, C @@ (List @@ x + {1, #}) & /@ {-1, 0, 1}],
C[0, 2], 3, VertexLabels -> C[x_, y_] :> 3 x + 2 y - 2]
Here C is used as an artificial wrapper to represent a 'point', since using bare lists would mess with both the initial specification of C[0,2] and the function nesting.
As Michael E2 hints, it's not ...
8
My package IGraph/M has several functions for this.
But before you get started, think carefully about what you mean by "random". I am going to assume that you want to generate each such matrix (i.e. each corresponding simple labelled graph) with equal probability, i.e. you want to do uniform sampling. This is not easy to do. There are two main ...
11
ClearAll[f]
f[n_, k_] := Module[{r = PadRight[ConstantArray[1, k], n - 1],
ca = ConstantArray[k, n], mi},
While[Total[mi = MapIndexed[Insert[#, 0, #2[[1]]] &,
Table[RandomSample[r], n]]] != ca]; mi]
Examples:
SeedRandom[1]
Row[Grid[Through[{MatrixForm,
AdjacencyGraph[#, VertexLabels -> Automatic, ImageSize -> Small] &}@#] &...
3
You can use FindInstance:
f[n_, k_, numsolutions_, seed_] := With[{
vars = Array[v, {n, n}]},
With[{
constraints = And @@ Flatten[{
Total[#] == k & /@ vars,
Total[#] == k & /@ Transpose[vars],
Total[Diagonal[vars]] == 0,
# <= 1 & /@ Flatten[vars]
}]},
vars /.
FindInstance[constraints, ...
5
You can use the pattern
_?(yourCondition @ PropertyValue[{g, #}, EdgeWeight] &)
or the pattern
e_ /; (yourCondition @ PropertyValue[{g, e}, EdgeWeight]
Examples:
g1 = CompleteGraph[4, EdgeWeight -> Range[6],
VertexLabels -> Automatic, EdgeLabels -> "EdgeWeight"]
g2 = EdgeDelete[g1, _?(OddQ @ PropertyValue[{g1, #}, EdgeWeight] &...
2
To find just one such subgraph:
FindClique[g, {6}]
(* {{14, 15, 19, 25, 33, 41}} *)
To find lots of them (here, at most 1000):
FindClique[g, {6}, 1000]
(* {{21, 25, 26, 31, 33, 50}, {21, 25, 26, 31, 33, 49},
{21, 25, 26, 31, 33, 47}, {21, 25, 26, 31, 33, 43},
{21, 22, 25, 26, 31, 33}, {9, 21, 25, 26, 31, 33},
{5, 21, 25, 26, 31,...
5
I'll start from the code given by flinty in the comment in order not to do this work again. Let us name his end result as firstStage:
img = Import["https://i.stack.imgur.com/ujHq1.png"];
vtxmask = Closing[Binarize@img, 2];
edgemask = Binarize@ImageMultiply[ColorNegate@img, vtxmask];
firstStage =
Pruning@Thinning@
ImageAdd[edgemask, ...
3
The problems in the first graph I've addressed in the comments.
This is what I've managed to do for the second graph. There is a fine tuning involved in the Closing filter radius and the threshold values. Once it finds the vertices, it works by thickening the image first (using an Erosion) then seeding random points along lines between pairs of points and ...
21
g = IndexGraph[
MorphologicalGraph[
Thinning[ColorNegate[Binarize[pic]], Method -> "MedialAxis"]]]
Then you can merge vertices that are close each other:
pts = GraphEmbedding[g];
Median[EuclideanDistance[pts[[#[[1]]]], pts[[#[[2]]]]] & /@
EdgeList[g]]
13.0384
f = Nearest[Thread[pts -> Range[Length[pts]]]]
merge = Select[f[#, {...
12
First, use the method of deleting the branch points developed in this answer:
img = Import["https://i.stack.imgur.com/aLhGVm.png"];
imb = Thinning[ColorNegate@Binarize@img];
edges = DeleteSmallComponents@MorphologicalTransform[imb,
If[#[[2, 2]] == 1 && Total[#, 2] == 3, 1, 0] &];
edgesLabeled = MorphologicalComponents[edges];
...
1
In PlanarFaceList, the outer face is the one with a negative orientation.
First define the function to find orientation of faces:
pOrientation[pts_] :=
With[{p = First[Ordering[pts]]},
NegativelyOrientedPoints[
pts[[Mod[{p - 1, p, p + 1}, Length[pts], 1]]]]]
and define function to add edges based on this:
addEdges[g_] :=
Block[{v, gg, coords, f, ...
Top 50 recent answers are included