Tag Info

New answers tagged

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 = ...


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]] ...


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: ...


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 ...


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], ...


0

Using a graph similar to the weighted graph example in the documentation FindGraphCommuinities >> Scope: vl = {1, 2, 3, 4, 5, 6, 7, 8}; el = {1 <-> 2, 1 <-> 3, 2 <-> 4, 3 <-> 4, 3 <-> 5, 4 <-> 6, 5 <-> 6, 5 <-> 7, 6 <-> 8, 7 <-> 8}; vc = {{3.24, 0.86}, {3.24, 0.02}, {2.2, 0.88}, {2.2, 0.}, ...


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}, ...


1

Maks = 6; (*Is this user input? Who knows.. who cares. I picked 6*) i = 1; While[i <= Dowo, For[x = 1, x <= Maks - 2, x++, W[i] = x; i = i + 1; If[Mod[x, 2] == 1, W[i] = Maks - 1; i = i + 1, (*else*) W[i] = Maks, i = i + 1]; ]; W[i] = Maks; i = i + 1; Maks = Maks + 2; ]; cells = Table[{0, 0}, ...


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, ...


0

just perform dfs (depth first search) on the graph. store vertices as they are explored and when returning from the vertex. like, a---b---c is a graph. on dfs, vertices will be stored as (a,b,c,b,a) . hence it is the desired path.


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 = ...


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 = ...


1

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


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 ...


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}, ...


0

Simulated annealing will get an algorithm that works the way you want... but will require more careful guidance / tweaking / adaptive adjustment than what I include below: Meas[G_, i_: 0] := Module[{ Ex = EdgeList[G], P = N[PropertyValue[{G, #}, VertexCoordinates] & /@ VertexList[G]] }, Return[If[i == 0, Max[Abs[ Map[Norm[#[[1]] - #[[2]]] &, ...


2

ClearAll[f1]; f1 = EdgeDelete[#2, Complement[EdgeList[#2], #]] &; Example: e = {1 <-> 2, 2 <-> 3}; gA = CompleteGraph[3, VertexLabels -> "Name", ImagePadding -> 20]; gA = SetProperty[{g, 2}, {VertexStyle -> Purple, VertexLabels -> Placed["Name", Center], VertexSize -> .15, VertexLabelStyle -> Directive[White, ...



Top 50 recent answers are included