16
$\begingroup$

enter image description here

Recently I see more and more data-viz called "Animated bar chart race". Some random examples, and note, how smoothly and organically everything changes in these videos.:

I hope there is a trick to adopt BarChart for this. But nothing comes to mind than quite direct and elaborate hijacking of rectangles from BarChart

Cases[BarChart[{1,2,3}],_Rectangle,Infinity]

{Rectangle[{0.548798,0.},{1.4512,1.},RoundingRadius->0], Rectangle[{1.5488,0.},{2.4512,2.},RoundingRadius->0], Rectangle[{2.5488,0.},{3.4512,3.},RoundingRadius->0]}

and doing some tedious time dependent moving of coordinates. It is not clear to me how one can very comprehensively select a speed of rectangle motion and what is the best data structure to be fed into BarChartRace function. Do I provide just "frames" of data samples (which seems ideal, with a lot of automation figuring out the animation rates and looks) or do I need to provide some time stamps etc.? Also, note, not only the bars length is affected, but the identity of each bar and plot range need to be tracked, for example here are two sequential frames where lengths changed and bars moved which is the elementary thing that needs to be animated:

{BarChart[{1,2,3},ChartStyle->{Red,Green,Blue},PlotRange->7],
BarChart[{3.5,4,7},ChartStyle->{Blue,Green,Red},PlotRange->7]}

enter image description here

I did not try yet to deep, because I keep thinking that maybe there is a package already somewhere or a few neat tricks to make this work easily that folks here are aware of. Any solution is highly-highly appreciated.

Tentative basic scenario

Questionable, but in mind mind it looks something like... At a given moment we have some example data (like number of animals) - called data-frame. We got more dogs than cats, so dog bar is 1st by rank in the data-viz:

<|"cat"->5,"dog"->7|>

Some growth or decrease happens. Event 1 leading to swapping of bars is that rankings changed, now we got more cats than dogs and the cat's bar is 1st in data-viz:

<|"cat"->11,"dog"->8|>

Another type of event is introduction of a new player (bird):

<|"cat"->13,"dog"->11,"bird"->23|>

So I assume we have a sequence of data-frames:

{<|"cat"->5,"dog"->7|>,
<|"cat"->11,"dog"->8|>,
<|"cat"->13,"dog"->11,"bird"->23|>}

fed into the function BarChartRace that figures out the animation automatically.

I also think that at least 2 ways of animation is possible: via GIF/MP4-like and via Dynamic/Manipulate-like things.

Again this is just a (questionable) thought, anything else along these lines is welcome. Thank you!

Real data

If one wants to try this on real data, there are many examples. From GDP of countries to currencies to stocks to movie rankings etc. A very clean sample dataset where there is no missing values is WikipediaData for colors:

data={WikipediaData["Red","DailyPageHits"],
WikipediaData["Blue","DailyPageHits"],
WikipediaData["Green","DailyPageHits"],
WikipediaData["Black","DailyPageHits"],
WikipediaData["White","DailyPageHits"]};

One can easily see where swapping action will happen:

DateListPlot[(MeanFilter[#1, Quantity[1, "Months"]] & ) /@ data, 
  PlotStyle -> {Red, Blue, Green,Black,White},PlotTheme->"Marketing"]

enter image description here

Note the data are absolutely uniform and easy to use - daily basis, nothing missing, all equal length:

Length/@Normal/@data

{2320,2320,2320,2320,2320}

$\endgroup$
2

3 Answers 3

14
$\begingroup$

Update 3: A custom ChartElementFunction that grows and sorts rectangles:

ClearAll[sortedGrowingBars]
sortedGrowingBars[t_, cedf_ : Automatic, o : OptionsPattern[]] := 
 Module[{minmaxy = (1 - t) #[[2]] + 
      t (#3[[1, 1]] + {0, Subtract @@ Reverse@#[[2]]})}, 
  {EdgeForm[], 
   ChartElementData[cedf /. Automatic -> "Rectangle", o][{{#[[1, 1]], 
     (1 - t) #3[[1, 3]] + t #[[1, 2]]}, minmaxy}, ##2], 
   Opacity[1], Text[Style[NumberForm[
     Round[N[(1 - t) #3[[1, 3]] + t #[[1, 2]]], .01], {3, 2}], 16], 
      Offset[{10, 0}, {(1 - t) #3[[1, 3]] + t #[[1, 2]], 
         Mean[minmaxy]}], {-1, 0}], 
    Text[Style[#3[[1, 2]], 16], 
      Offset[{-10, 0}, {First@First[#], Mean[minmaxy]}], {1, 0}]}] &

Examples:

SeedRandom[1];
labels = RandomWord["Noun", 5];
values = RandomSample[Range[10], 5];
starts = ConstantArray[0, 5];

data = Thread[values -> 
   Transpose[{Ordering @ Ordering @ values, labels, starts}]];


Animate[BarChart[data, BarOrigin -> Left, "BarStartingValue" -> 1, 
   ChartStyle -> "Rainbow", ChartBaseStyle -> Opacity[.9], 
   ChartElementFunction -> 
     sortedGrowingBars[t, "FadingRectangle", "GradientOrigin" -> Right],
   PlotRange -> {{Automatic, 1 + Max@values}, All},
   Axes -> False, ImageSize -> 600], 
 {t, 0, 1, 1/50}, DisplayAllSteps -> True]

enter image description here


Update 2: if we pass ranks, labels and starting values as metadata for each data element we can combine sortBars and a slightly modified version of growingBar to get a ChartElementFunction that gives the desired result:

ClearAll[growingBar, sortBars, racingBars]

growingBar[t_, cedf_: Automatic,  o : OptionsPattern[]] := 
   {EdgeForm[], 
    ChartElementData[cedf /. Automatic -> "Rectangle", o][
     {{#[[1, 1]], (1 - t) #3[[1, 3]] + t #[[1, 2]]}, #[[2]]}, ##2], 
    Text[Style[NumberForm[Round[(1 - t) #3[[1, 3]] + t #[[1, 2]], .01], {3, 2}], 16], 
     Offset[{10, 0}, {(1 - t) #3[[1, 3]] + t #[[1, 2]], Mean @ Last @ #}], {-1, 0}], 
    Text[Style[#3[[1, 2]], 16], 
      Offset[{-10, 0}, {t, 1} {First @ First @ #, Mean @ Last @ #}], {1, 0}]} &;

sortBars[t_, cedf_: Automatic, o : OptionsPattern[]] := 
 Module[{minmaxy = (1 - t) #[[2]] + 
      t (#3[[1, 1]] + {0, Subtract @@ Reverse @ #[[2]]})}, 
  {EdgeForm[], 
   ChartElementData[cedf /. Automatic -> "Rectangle", o][{#[[1]], minmaxy}, ##2], 
   Text[Style[NumberForm[Round[ N@#2, .01], {3, 2}], 16], 
     Offset[{10, 0}, { Last@First@#, Mean[minmaxy]}], {-1, 0}], 
   Text[Style[#3[[1, 2]], 16], 
     Offset[{-10, 0}, { First@First@#, Mean[minmaxy]}], {1, 0}]}] &

racingBars[t1_, sortspeed_: 1, rest___] := 
  If[t1 >= 1, sortBars[sortspeed (t1 - 1), rest][##], growingBar[t1, rest][##]] &;

Examples:

SeedRandom[1];
labels = RandomWord["Noun", 5];
values = RandomSample[Range[10], 5];
starts = ConstantArray[0, 5];

data = Thread[values -> Transpose[{Ordering@Ordering@values, labels, starts}]];

Dynamic @ BarChart[data, 
  BarOrigin -> Left, 
  "BarStartingValue" -> 1,
  ChartStyle -> "Rainbow", 
  ChartElementFunction -> racingBars[Clock[{0, 2, 1/100}, 10, 1]], 
  PlotRange -> {{Automatic, 1 + Max@values}, All}, 
  Axes -> False, 
  ImageSize -> 600]

enter image description here

Use sortspeed = 10; and racingBars[Clock[{0, 1 + 1/sortspeed, 1/100}, 10, 1], sortspeed] to make sorting 10 times faster than growing:

enter image description here

If we replace starts = ConstantArray[0, 5] with start = RandomSample[Range @ 10, 5] (to give each bar its own starting value) we get

enter image description here

Update: A custom chart element function to sort the bars:

ClearAll[sortBars]
sortBars[t_, cedf_: Automatic, o : OptionsPattern[]] := 
 Module[{minmaxy = (1 - t) #[[2]] + t (#3[[1, 1]] + {0, Subtract @@ Reverse@#[[2]]})},
   {EdgeForm[], 
    ChartElementData[cedf /. Automatic -> "Rectangle", o][{#[[1]], minmaxy}, ##2], 
    Text[Style[NumberForm[Round[ N @ #2, .01], {3, 2}], 16], 
     Offset[{10, 0}, { Last @ First @ #, Mean[minmaxy]}], {-1, 0}], 
    Text[Style[#3[[1, 2]], 16], 
       Offset[{-10, 0}, { First @ First @ #, Mean[minmaxy]}], {1, 0}]}] &

Example:

SeedRandom[1];
labels = RandomWord["Noun", 5];

values = RandomSample[Range[10], 5];

Attach to values the ranks and labels as metadata :

data2 = Thread[values -> Transpose[{Ordering @ Ordering @ values, labels}]];

clock2 := Clock[{0, 1, 1/100}, 3, 1]

Dynamic @ BarChart[data2, 
  BarOrigin -> Left, 
  ChartStyle -> "Rainbow", 
  ChartElementFunction -> sortBars[clock2], 
  PlotRange -> {{Automatic, 1 + Max@values}, All}, 
  Axes -> False, 
  ImageSize -> 500, 
  "BarStartingValue" -> 1]

enter image description here

TODO: (Hoping that we have not painted ourselves into a corner) find a way to combine growingBar and sortBars with two synchronized clocks.

Original answer:

For starters, for the easier part, we can use a custom ChartElementFunction:

ClearAll[growingBar]
growingBar[t_, cedf_: Automatic, o : OptionsPattern[]] := 
   {EdgeForm[], 
    ChartElementData[cedf /. Automatic -> "Rectangle", o][
      {{#[[1, 1]], t #[[1, 2]]}, #[[2]]}, ##2], 
    Text[Style[NumberForm[Round[t N@#2, .01], {3, 2}], 16], 
      Offset[{10, 0}, {t, 1} {Last@First@#, Mean@Last@#}], {-1, 0}], 
    Text[Style[#3[[1]], 16], 
     Offset[{-10, 0}, {t, 1} {First@First@#, Mean@Last@#}], {1, 0}]} &;

Examples:

SeedRandom[1];
labels = RandomWord["Noun", 5];
values = RandomSample[Range[10], 5];

data = Thread[values -> labels];

We can use Clock + Dynamic to dynamically update the parameter passed to growingBar:

clock1 := Clock[{0, 1, 1/100}, 15, 1]

Dynamic[BarChart[data, 
  BarOrigin -> Left, 
  ChartStyle -> "Rainbow", 
  ChartElementFunction -> growingBar[clock1], 
  PlotRange -> {{Automatic, 1 + Max @ values}, All}, Axes -> False, 
  ImageSize -> 500]]

enter image description here

Use growingBar[clock1, "FadingRectangle", "GradientOrigin" -> Right] to get

enter image description here

TODO: I think we can extend this approach by (1) passing the ranks of data elements as metadata, (2) adding another argument to growingBar to indicate the vertical positions of the rectangles, and (3) controlling the second argument using a second Clock.

$\endgroup$
3
  • 2
    $\begingroup$ The bar-swapping animation is the key and most challenging part :-) But this is excellent start, @kglr, thank you! A thought cross my mind that basic data structure for each frame could be Association -- in that way each specific bar can be tracked easily. $\endgroup$ Nov 6, 2021 at 4:44
  • $\begingroup$ Cool bar-sapping action! +1. I updated my question a bit to help brainstorming. Thank you very much for your effort. $\endgroup$ Nov 6, 2021 at 15:45
  • $\begingroup$ This is great and a very important question, bravo Vitaliy. With all the programming that has gone into @kglr 's answer, I wonder whether it might not be relatively easy to switch to graphics primitives with rectangles that would get re-sorted every time the sorting order changes. $\endgroup$
    – Nicholas G
    Nov 7, 2021 at 14:24
3
$\begingroup$

The simple switching of the lider can be done easy:

values = Table[RandomReal[{0, i}, 5], {i, 1, 35}];
labels = RandomWord["Noun", 5];

anim = Table[
   data = Sort@Thread[values[[i]] -> labels];
   BarChart[data[[All, 1]],
    BarOrigin -> Left,
    ChartStyle -> "Rainbow",
    LabelingFunction -> After,
    ChartLabels -> Placed[data[[All, 2]], Before],
    PlotRange -> {{Automatic, 5 + Max@values[[i]]}, All},
    Axes -> False,
    ImageSize -> 500, GridLines -> Automatic],
   {i, 1, Length@values, 1}];

enter image description here

However, it works without any nice effects like fading etc..

$\endgroup$
1
  • $\begingroup$ I appreciate your effort, but this is not what the question is about :-) Many folks here understand it is easy to change the order and height of the bars. The smooth animation is the point of the question. $\endgroup$ Nov 6, 2021 at 15:48
2
$\begingroup$

Using Graphics with parametrized Rectangle primitives:

ClearAll[racingRectangles, ranks]

ranks = Ordering @* Ordering;

racingRectangles[t_, spacing_: .1][starts_, ends_, labels_, cd_: "Rainbow"] := 
 Module[{ord = Ordering @ starts}, 
  MapThread[{#4, EdgeForm[Darker @ #4], 
     Rectangle[{0, #3}, {(1 - t) # + t #2, #3 + 1 - spacing}], 
     Text[Style[NumberForm[Round[(1 - t) # + t #2, .01], {3, 2}], 16],
       Offset[{10, 0}, { (1 - t) # + t #2, #3 + (1 - spacing)/2}], {-1, 0}], 
     Text[Style[#5, 16], Offset[{-10, 0}, { 0, #3 + (1 - spacing)/2}], {1, 0}]} &, 
    {Sort @ starts, 
     ends[[ord]], 
     ranks[(1 - t) starts + t ends][[ord]], 
     ColorData[cd] /@ Rescale[ends[[ord]]], 
     labels[[ord]]}]]

Examples:

SeedRandom[1];
labels = RandomWord["Noun", 5];
starts = RandomReal[{0, 2}, 5];
ends = RandomSample[Range[10], 5];

Dynamic @ Graphics[
  racingRectangles[Clock[{0, 1, 1/100}, 15, 1]][starts, ends, labels],
  ImageSize -> 600, 
  PlotRange -> {{Automatic, 1 + Max @ ends}, {0, Automatic}}, 
  PlotRangePadding -> Scaled[.05]]

enter image description here

Manipulate[
 Graphics[racingRectangles[t][starts, ends, labels], 
  ImageSize -> 600, 
  PlotRange -> {{Automatic, 1 + Max @ ends}, Automatic}, 
  PlotRangePadding -> Scaled[.05]], 
{t, 0, 1, Appearance -> "Open"}]

enter image description here

TODO: Make sorting smoother when rankings change.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.