Tag Info

New answers tagged

3

not quite what you asked for, but possibly useful: relationships = {1 <-> 2, 2 <-> 3, 2 <-> 4, 3 <-> 5, 2 <-> 6, 6 <-> 7, 4 <-> 8, 4 <-> 9}; numNodes = Max[relationships[[All, 2]]]; sizes = RandomReal[{0.25, 1}, numNodes]; xCoords = {0, 1, 2, 2, 3, 3, 4, 5, 5}; vars0 = Array[a, 9]; Manipulate[ vars = ...


0

This works for Mathematica 9.0 - The code above appears to work only for Mathematica 10.0. proc = DiscreteMarkovProcess[ 1, {{1/2, 1/2, 0, 0, 0}, {1/2, 1/2, 0, 0, 0}, {0, 1/2, 1/2, 0, 0}, {0, 0, 0, 0, 1}, {0, 0, 0, 1, 0}}]; Graph[proc, EdgeLabels -> {1 \[DirectedEdge] 2 -> Placed["\[Alpha]", .5], 1 \[DirectedEdge] 1 -> Placed["1-\[Alpha]", ...


1

It seems that the DiscreteMarkovProcess has directed edges, so you need use the [DirectedEdge] version in your EdgeLabels specification. In version 10 the following works: proc = DiscreteMarkovProcess[1, {{1/2, 1/2, 0, 0, 0}, {1/2, 1/2, 0, 0, 0}, {0, 1/2, 1/2, 0, 0}, {0, 0, 0, 0, 1}, {0, 0, 0, 1, 0}}]; ...


2

{af, bf, cf, pf, qf, rf, xf, yf, zf} = {a, b, c, p, q, r, x, y, z} /. NDSolve[{ a'[t]==20+0.03*a[t]-0.00005*a[t]*q[t]-0.0002*a[t]*y[t]-0.0743*a[t], b'[t]==0.03*b[t]+0.00005*a[t]*q[t]+0.0002*a[t]*y[t]-0.0743*b[t]-0.01072*b[t], c'[t]==0.03*b[t]+0.00005*a[t]*q[t]+0.0002*a[t]*y[t]-0.0743*c[t]+0.01072*b[t], p'[t] == 15 + 0.03*p[t] - 0.0001*p[t]*b[t] - ...


2

An alternative workaround is using igraph through my IGraphR package. minimum.size.separators gives all possible smallest vertex cuts. Example: << IGraphR` g = CycleGraph[5, VertexLabels -> "Name", VertexSize -> Large] vcs = IGraph["minimum.size.separators"][g] (* {{2., 5.}, {2., 4.}, {3., 5.}, {1., 3.}, {1., 4.}} *) HighlightGraph[g, #] ...


3

Just for fun to do recursively in contrast to in-built binary graphs, e[n_] := {n <-> 2 n, n <-> 2 n + 1}; gf[grp_, n_, opts : OptionsPattern[]] := Module[{vl, ne, ng}, vl = Sort@VertexList[grp]; ne = Flatten[e /@ vl[[-n ;;]]]; ng = EdgeAdd[VertexAdd[grp, ne[[All, 2]]], ne]; Graph[VertexList[ng], EdgeList[ng], ...


1

If your are looking for a Binary tree than this may work for you: fnBTree[n_] := CompleteKaryTree[Sequence @@ # , VertexLabels -> "Name"] & /@ Join[{{1, 1}, {2, 1}}, Table[{i + 1, 2}, {i, n - 2}]] Call fnBTree with n=4 fnBTree[4]


1

You could add set back to your EdgeShapeFunction: EdgeShapeFunction -> (If[#[[1]] != #[[-1]], {Arrowheads[ If[#2[[1]] == chr, {{0.04, 1}}, {{0.02, 0.2}, {0.02, 0.8}}]], Arrow[BSplineCurve[{#[[1]], {0, 0}, #[[-1]]}, SplineWeights -> {2, 1, 2}], .025]}, Opacity[0]] &)


-1

This seems perfectly legible to me: Arrowheads[If[#2[[1]] == chr, {{0.04, .98}}, {{0.02, 0.2}, {0.02, 0.8}}]]


5

Here is your initialization code: (*SeedRandom[30];*) (*initial coordinates of masses*) mass = RandomReal[{0, 3}, {4, 2}]; (*mass 1 is connected to {2,3} and so on*) spring = {{2, 3}, {1, 4}, {1, 4}, {2, 3}}; (*spring constant*) k = 2.; (*spring rest length*) l = 1.; (*step size*) step = 0.02; (*tolerance*) tol = 10^-10.; (*pinned masses*) pinned = {2, ...


5

ClearAll[cyclesF, edgesF] cyclesF = Map[FromCharacterCode, 64 + PermutationCycles[ToCharacterCode@# - 64][[1]], {-1}] &; edgesF = Developer`PartitionMap[DirectedEdge @@ # &, #, 2, 1, {1, 1}] & /@ cyclesF[#] &; str = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; colors = {Red, Green, Blue, Orange, Cyan, Yellow}; vl = cyclesF@str; el = ...


4

Not going to win a beauty contest, but you might get some ideas: string = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; rules[cycle_] := Thread[DirectedEdge[cycle, RotateLeft[cycle]]]; edges = MapIndexed[Style[#1, Thick, ColorData[2][#2[[1]]]] &, rules /@ PermutationCycles[LetterNumber /@ Characters[string], Identity], {2}]; verts = ...


5

s = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; pc = PermutationCycles[ToCharacterCode@s - 64] // First; Graph[Flatten[Thread[# -> RotateRight@#] & /@ pc], VertexLabels -> Table[i -> FromCharacterCode[i + 64], {i, Flatten@pc}], ImagePadding -> 12] Perhaps better: pc = (PermutationCycles[ToCharacterCode@s - 64] // First) /. ...


1

AdjacencyGraph[{{0, 1, 0, 1}, {0, 0, 1, 1}, {1, 0, 0, 1}, {1, 1, 1, 0}}, VertexLabels -> "Name"] If you wish to input the matrix interactively: Print["number of vertexes"]; n = Input[]; a = Table[Input[], {i, 1, n}]; AdjacencyGraph[a, VertexLabels -> "Name"] Then if, when prompted, you input $3$ for the number of vertexes, you'll be ...


2

This is bugged still in 10.1. If you are forced to live with the buggy function, here's a brute-force method that should work correctly: it checks the size of a minimum cut, and tries all subsets of vertices of that size. Below, I assume that VertexConnectivity still works correctly. g = CycleGraph[5, VertexLabels -> "Name"] DisconnectedGraphQ[g_] := ...


2

First, let us find all cycles in the graph. Then, we will filter out the ones that contain chords; this we can detect by checking if the $n$-vertex induced subgraph is isomorphic to a cycle of length $n$ or not. Let us use your graph as an example: g = Graph[{1 <-> 2, 1 <-> 3, 2 <-> 4, 4 <-> 5, 5 <-> 6, 4 <-> 6, 6 ...



Top 50 recent answers are included