Tag Info

Hot answers tagged

8

For the part I would need to identify the relevant segments automatically. you can use vd2 = ConnectedComponents@Subgraph[g0, VertexList[g0, x_ /; (VertexDegree[g0, x] == 2)]] {{36, 43, 49, 48, 55, 63}, {41, 42, 47, 54, 62}, {39, 40, 46, 53}, {94, 95, 96}, {82, 92, 99}, {77, 78, 84}, {38, 45, 52}, {13, 17, 18}, {9, 10, 11}, {104, 105}, ...


8

This seems to work pretty well: r = 0.2/3; regions = RegionPlot[ Evaluate@Table[ Length@clique PDF[SmoothKernelDistribution[data[[clique]], r], {x, y}] > 1/(4 π r^2), {clique, mycliques}], {x, -2 r, 1 + 2 r}, {y, -2 r, 1 + 2 r}, Frame -> False]; Show[regions, Graph[mygraph, GraphStyle -> "BasicBlack"]] Further reading: ...


5

If you have V9 or V10, you can try CommunityGraphPlot: g = ExampleData[{"NetworkGraph", "ZacharyKarateClub"}] cliques = FindClique[g, Infinity, All] (* {{2, 1, 3, 4, 14}, {2, 1, 3, 4, 8}, {24, 30, 33, 34}, {9, 31, 33, 34}, {26, 25, 32}, {6, 7, 17}, {3, 9, 33}, {1, 4, 13}, {1, 3, 9}, {1, 6, 11}, {1, 6, 7}, {1, 5, 11}, {1, 5, 7}, {2, 1, 22}, ...


4

This is much faster in my machine: el = Sort /@ EdgeList[g]; eSF[pos_, vert_, kset_] := {c[[Position[kset, Sort@vert][[1, 1]]]], Line[pos]} genG[el_, kSet_] := System`Graph[el, EdgeShapeFunction -> (eSF[##, kSet] &), VertexLabels -> "Name"] all1 = genG[el, #] & /@ p; // Timing (* {0.790625, Null} *) The "new" PropertyValue[] is nice, but a ...


3

k[] is function defined by you and tri is making UndirectedEdge-s k[j_List] := Block[{t = j[[1]], r = j[[2]], i = j[[3]]},(2 t - 1) 2^(-i + r) 3^(-1 + i)] tri[{t_, r_, i_}] := {{t, r, i} <-> {t, r + 1, i}, {t, r + 1, i} <-> {t, r + 1, i + 1},{t, r + 1, i + 1} <-> {t, r, i}} I remaked your code like this for making Graph. d = 4; data ...


3

One can smooth the graph by averaging the position of each degree 2 vertex with its neighborhoods. In addition, if the vertex's original position is included in the average, the vertex will be pulled slightly toward it. (Thus four points are being averaged, hence the 0.25 below.) If one iterates this procedure, nice "curved" paths develop. coords = ...


3

For the default EdgeShapeFunction ("Arrow") you can specify the arrow sizes using the the Arrowheads directive with EdgeStyle or BaseStyle: Row[Graph[{1 -> 2, 2 -> 3, 3 -> 1}, ImageSize -> 300, EdgeStyle -> Arrowheads[#], (* or BaseStyle-> Arrowheads[#] *) PlotLabel -> Style[Row[{"Arrowheads[ ", ToString@#, " ]"}], 16, ...


2

Graphics`Mesh`MeshInit[]; cC = #[[ConvexHull[#]]]&/@ (PropertyValue[{mygraph, #}, VertexCoordinates] & /@ # & /@ mycliques); g2 = Graphics[{Opacity[.25], {Hue[RandomReal[]], Polygon[#]} & /@ cC}]; mygraph2 = Show[g2, HighlightGraph[mygraph, Subgraph[mygraph, #] & /@ mycliques]]; Row[{Panel@mygraph, Panel@mygraph2}, Spacer[15]] ...


2

plotOne[g_Graph] := Module[{probs, purgedTab, r = Range@Max@VertexDegree@g}, probs = {#, Probability[x == #, x \[Distributed] VertexDegree[g]]} & /@ r; purgedTab = DeleteCases[probs, {x_, y_} /; x y == 0]; ListLinePlot[Log@purgedTab, Filling -> Axis, Mesh -> Full, MeshStyle -> Directive[PointSize[Large], Black], ...


1

In Mathematica 10 it is easy to do with GeoDistance. Simply replace your g with the following lines stateToLocation = Rule[First[#], ToExpression[Rest[#]]] & /@ (StringSplit[stateData, ","]); edgeLabels = Thread[Rule[ EdgeList[g], (EdgeList[g] /. numberToState /. stateToLocation) /. UndirectedEdge -> GeoDistance]]; g = ...


1

Not sure if this is what you're after. The following is the steady state supposing null divergences except at the source: g = DirectedGraph[CompleteGraph[5], "Acyclic", VertexLabels -> "Name"] in[n_] := Tr[v[#]/VertexOutDegree[g, #] & /@ Complement[VertexInComponent[g, n, 1], {n}]] Solve[Join[{v[1] == 1}, Table[v[n] == in[n], {n, 2, ...


1

I'm hardly sure that I have understood your question fully, but does this give you the result that you want? Table[Probability[x == k, x \[Distributed] VertexDegree[j]], {j, allgraphs}, {k, Max[VertexDegree[j]]}] You need to specify the j iterator first, as the specification of k depends on j. On a more general note, I would say that if I want to ...


1

HighlightGraph combined with Style may be a good alternative: g1 = CompleteGraph[10, EdgeWeight -> eweights, VertexWeight -> vweights, ImageSize -> 300, VertexShapeFunction -> "Star", VertexSize -> .3, VertexStyle -> Orange, EdgeShapeFunction -> "FilledArcArrow", EdgeStyle -> Directive[{Blue, Thick}]]; vweights = ...


1

Try this: First[Timing[ all = Graph[g, EdgeStyle -> Thread[Rule[ Function[set, If[Length[set] > 1, Alternatives @@ set, First@set]] /@ #, c[[;; numColors]]]]] & /@ p]]



Only top voted, non community-wiki answers of a minimum length are eligible