mathematicaでこのダイナミックプロットはどのように可能ですか？

Question

ここはBBCのダイナミックgraphicsです。 Mathematicaでグラフィックスを再現することは可能かもしれないと思っています。我々はMMAで利用可能ないくつかの魅力的なグラフィックストリックが表示されます答えるの過程で

。それがここで質問をする唯一の理由です。

更新：

私はちょうどBBCはそれを行うには、簡単なJavaScriptを使用していることを確認。彼らは静的な画像を手動で作成し、Flashベースのイベント処理を使用していません。したがって、すべての画像は静的なエンティティです。一度国をクリックすると、ユニークな画像が生成されます。他の国の場合は、他の画像を表示します。 PowerPoint、Visio、またはPhotoshopを使用して、それぞれのケースごとに個別のイメージを生成することができます。ブラウザでJavaScriptを無効にして、ページをリロードするだけでこれを確認できます。

私は、これらの1枚の写真はMMAから作成できることを理解しています。いくつかの答えは正しい方向性を示しています。だから私はこれまでに来た最高の答えを受け入れています。

Answer 1

ちょうど別のスターター：

a = Point[{0, 0}]; 
b = .75 Tuples[{1, -1}, 2][[{3, 1, 2, 4}]]; 
PieChart[ 
{ 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[1]], {0, 0}, #}] & /@ b})], 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[2]], {0, 0}, #}] & /@ b})], 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[3]], {0, 0}, #}] & /@ b})], 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[4]], {0, 0}, #}] & /@ b})], 
    } 
, 
SectorOrigin -> {Automatic, 1}, 
Epilog -> Dynamic@a] 

編集よりコンパクト：

a = Point[{0, 0}]; 
b = .75 Tuples[{1, -1}, 2][[{3, 1, 2, 4}]]; 
PieChart[ 
ReleaseHold[Replace[Table[ 
    List[1, 
    ReplaceAll[ 
     Hold[a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{k, {0, 0}, #}] & /@ b}], k -> i]], 
    {i, b}], List -> Button, {2}, Heads -> True]] 
, 
SectorOrigin -> {Automatic, 1}, 
Epilog -> Dynamic@a] 

Answer 2

これは完全な回答ではありませんが、コメントには長すぎます。私はそれから「盗む」ために皆を奨励し、

g = RandomGraph[{5, 12}, DirectedEdges -> True]; 

SetterBar[Dynamic[v], VertexList[g]] 

Dynamic@HighlightGraph[ 
    g, {Style[Cases[EdgeList[g], v \[DirectedEdge] _], 
    Directive[Thick, Black]], Style[v, Red]}, 
    GraphLayout -> "CircularEmbedding", EdgeStyle -> Lighter@Gray, 
    VertexLabels -> "Name"] 

次のステップはSetterBarを交換するEventHandlerに包まれたオブジェクトとVertexShapeFunctionを使用している:-)それを完了します。

Answer 3

このためのいくつかのより基本的なフットワーク：

g[\[Alpha]_, \[Beta]_, color_] := Module[{t}, 
t = Graphics[{{Thickness[.03], Arrowheads[{.15}], color, 
    Arrow[ 
    BezierCurve[{{Cos[\[Alpha]], Sin[\[Alpha]]}, {0, 
     0}, {Cos[\[Beta]], Sin[\[Beta]]}}]]}}, 
PlotRange -> 1.5, ImageSize -> 512, Background -> None]; 
ImageCompose[Blur[t, 15], t] 
] 

one = Fold[ImageCompose, 
g[0, \[Pi]/3, Blue], {g[0, \[Pi]/2, Blue], g[0, \[Pi], Blue], 
g[0, 4 \[Pi]/3, Blue]}] 

two = Fold[ImageCompose, 
g[\[Pi]/3, 0, Yellow], {g[\[Pi]/3, \[Pi]/2, Yellow], 
g[\[Pi]/3, \[Pi], Yellow], g[\[Pi]/3, 4 \[Pi]/3, Yellow]}] 

DynamicModule[{pick = 1}, 
ClickPane[ 
    Dynamic@If[pick == 1, one, two], 
    Function[{point}, If[First[point] < 256, pick = 1, pick = 2]]] 
]