7
$\begingroup$

Using the following code,

air = {3, 1, 6};
water = {2, 4, 3};
road = {1, 0, 7};
root = {6, 1, 2};
clist = {"Belarus", "Georgia", "Armenia"};
BarChart[
 Transpose@{air, water},
 ChartLabels -> {clist, None},
 ChartLegends -> {"change in air", "flowing water"},
 ChartStyle -> {None, "Pastel"},
 FrameLabel -> {"", "Percent Change"},
 PlotTheme -> "Business"
        ]

I produce:

enter image description here

I also produce a Table of data associated with the BarChart by:

tab = TableForm[{air, water, road, root}, 
  TableHeadings -> {{"change in air", "flowing water", 
     "construction road", "agriculture root"}, None}]

I like to combine these two pieces of outputs (Barchart and Table) in the format given below:

enter image description here

I had difficulty joining the two pieces in such a way as to align the data columns with the associated country bars and moving the ChartLabels into the table in the same way as shown above. Using tones of the gray color in Table and Background is very useful to have a user-friendly look.

Improve this question
$\endgroup$
0

3 Answers 3

Reset to default
10
$\begingroup$ 
Clear["Global`*"]

air = {3, 1, 6};
water = {2, 4, 3};
road = {1, 0, 7};
root = {6, 1, 2};
clist = {"Belarus", "Georgia", "Armenia"};

legends = Row /@
   Transpose[{{" ", " ", " ", " "},
     ColorData["Pastel"] /@ Range[0, 1, 1/3],
     {" change in air", " flowing water",
      " construction road", " agriculture root"}}];

bc = BarChart[
   Transpose@{air, water, road, root}, ChartLabels -> {clist, None},
   ChartStyle -> {None, "Pastel"},
   PlotTheme -> "Business",
   AspectRatio -> 1.2];

Display

Column[{
  Grid[{{Rotate[
      Style["Percent Change", 10], Pi/2], bc}},
   ItemSize -> {{10, 14}, 7},
   Alignment -> Right],
  Grid[
   (Flatten /@
     Transpose[
      {legends, {air, water, road, root}}]),
   Dividers -> {False, Darker@Red},
   Alignment -> {{Left, Center}},
   Background ->
    {{Lighter[Gray, 0.8], {Lighter[Gray, 0.9]}}, 
     None},
   ItemSize -> {{12, 4, 4, 4}, Automatic}]},
 Spacings -> 0,
 Background -> Lighter[Gray, 0.9]]

enter image description here

EDIT: This is a rough cut at adjusting to a variable number of countries. It should give you something to experiment with and improve upon.

Clear["Global`*"]

air = {3, 1, 6, 3, 1, 6};
water = {2, 4, 3, 2, 4, 3};
road = {1, 0, 7, 1, 0, 7};
root = {6, 1, 2, 6, 1, 2};
clist = {"Belarus", "Georgia", "Armenia",
   "CountryA", "CountryB", "CountryC"};

legends = Row /@
   Transpose[{
     {" ", " ", " ", " "},
     ColorData["Pastel"] /@ Range[0, 1, 1/3],
     {" ", " ", " ", " "},
     {"change in air", "flowing water",
      "construction road", "agriculture root"}}];

Manipulate[
 bc = BarChart[
   Transpose[#[[;; nbr]] & /@ {air, water, road, root}],
   ChartLabels -> {clist[[;; nbr]], None},
   ChartStyle -> {None, "Pastel"},
   PlotTheme -> "Business",
   AspectRatio -> 1.2,
   ImageSize -> 60 nbr];
 Column[{Grid[{{Rotate[Style["Percent Change", 10], Pi/2], bc}}, 
    ItemSize -> {{10, 2 + 4 nbr}, (2 + 4 nbr)/1}, Alignment -> Right], 
   Grid[(Flatten /@ 
      Transpose[{legends, #[[;; nbr]] & /@ {air, water, road, root}}]), 
    Dividers -> {False, Darker@Red}, Alignment -> {{Left, Center}}, 
    Background -> {{Lighter[Gray, 0.8], {Lighter[Gray, 0.9]}}, None}, 
    ItemSize -> {Flatten[{12, ConstantArray[4, nbr]}], Automatic}]}, 
  Spacings -> 0, Background -> Lighter[Gray, 0.9]],
 {{nbr, 3, "number of countries"}, Range[2, Length@clist]},
 Paneled -> False]

enter image description here

Improve this answer
$\endgroup$
8
  • $\begingroup$ Thanks for a very nice picture. I appreciated both answers. There is a tiny issue with the linkage between the table and bar chart. In my replication, I noticed that columns of data in the table slightly move to the right when new data columns are added. Eventually, for a larger table, the data columns do not stay underneath the bar chart's country names. Is there a way to link the total length of all the bars for a country to the associated data column centered at the total length? This way, adding new data columns will be always aligned to country groups. $\endgroup$
    – Tugrul Temel
    Commented Dec 26, 2021 at 13:33
  • $\begingroup$ In my previous comment, I meant "width", not "length" of the bars. The width of the table columns should be linked to the width of all the bars for a given country. Sorry for this confusion. $\endgroup$
    – Tugrul Temel
    Commented Dec 26, 2021 at 13:47
  • $\begingroup$ What have you tried and what haven't you been able to resolve? What is the maximum number of countries that would be used? Do all of the countries need to be displayed at once, or could a dynamic view of a subset of them be used? If a dynamic view, can the subset be determined by just sliding through the list or do you need to pick an arbitrary subset of at most n of them. The length of the country names could become an issue, what is the longest name that is to be used? $\endgroup$
    – Bob Hanlon
    Commented Dec 26, 2021 at 14:12
  • $\begingroup$ I added a fourth country Timor-Leste and saw that the bar chart is smaller than the table. Proportionality is destroyed. I can use the UN country codes such as USA, GBR, TUR etc to get around this name problem. I have a list of 230 countries, and I will be choosing at most 20-25 countries at a time. The numbers in the table are of the form 2.5743 maximum. Since I use Dataset[], having a Manipulate code will be more convenient for quick selection of country and data. $\endgroup$
    – Tugrul Temel
    Commented Dec 26, 2021 at 16:30
  • 2
    $\begingroup$ You haven't addressed the most important question relative to the issues you raise "What have you tried and what haven't you been able to resolve?" Just saying you added more data doesn't reflect any effort. In any event, this goes way beyond the scope of the OP and should be put in a new question to include what you have tried to resolve the issues. $\endgroup$
    – Bob Hanlon
    Commented Dec 26, 2021 at 17:01
6
$\begingroup$

A custom DisplayFunction that adds legends and data table with columns aligned with group labels:

ClearAll[displayF]

displayF[lgnds_, tbl_, lbgrnd_: Automatic, tbgrnd_: Automatic, voffset_: 25, gap_:25] :=
 Module[{volist = Accumulate[Prepend[gap] @ ConstantArray[voffset, Length @ tbl]],
    hoffset = 1.1 Max[Ceiling[Rasterize[Style[#, "Graphics"], 
       "RasterSize"], 10][[1]] & /@ lgnds],
    hcoords = Map[MinMax @* Flatten] @
     Partition[Cases[#[[1]], (RectangleBox | Rectangle)[a_, b_, ___] :> 
       {First @ a, First @ b}, All], Length[tbl]],
    legendalign = ("MarkerLayout" /. Options[First@lgnds]) /. {"After" -> 1, _ -> -1},
    hrange, offsets, texts, tablelegend, ma},
   hrange = MinMax @ hcoords;
   ma = MovingAverage[volist, 2];
   offsets = Outer[Offset, Thread[{0, -ma}], Thread[{Mean /@ hcoords, 0}], 1];
   texts = Join @@ MapThread[Text[##, {0, 0}] &, {tbl, offsets}, 2];
   tablelegend = {lbgrnd /. Automatic -> Lighter[Gray, .5], 
     Rectangle @@ MapThread[Offset[{-#, -#2}, {hrange[[1]], 0}] &, 
        {{hoffset, 0}, volist[[{1, -1}]]}],
     tbgrnd /. Automatic -> Lighter[Gray, .8], 
     Rectangle @@ MapThread[Offset[{0, -#}, {#2, 0}] &, {volist[[{1, -1}]], hrange}],
     CapForm["Round"], Thick, Darker @ Red,  
     Table[Line[{Offset[{-hoffset, -i}, {hrange[[1]], 0}], 
          Offset[{0, -i}, {hrange[[2]], 0}]}], {i, volist}],
     Black, texts,
     MapThread[Inset[#, Offset[{- hoffset Boole[legendalign < 0], -#2}, 
         {hrange[[1]], 0}], {legendalign, Center}] &, {lgnds, ma}]};
   Show[#, Graphics @ tablelegend, PlotRange -> All]] &

Examples:

air = {3, 1, 6}; water = {2, 4, 3}; road = {1, 0, 7}; root = {6, 1, 2};
data = {air, water, road, root};

clist = {"Belarus", "Georgia", "Armenia"};

legendlabels = {"change in air", "flowing water", "construction road",
    "agriculture root"};

colors = ColorData["Rainbow"] /@ Rescale@Range[Length @ data];

legends = MapThread[
    SwatchLegend[{#}, {#2}, LegendLayout -> "Column", "MarkerLayout" -> "After"] &, 
   {colors, StringPadLeft[legendlabels]}];

BarChart[Transpose @ data,
 ChartLabels -> {Placed[clist, Below], None},
 ChartStyle -> {None, "Rainbow"},
 FrameLabel -> {{"PercentChange", None}, {None, None}},
 PlotTheme -> "Business",
 AspectRatio -> 2/3,
 ImageSize -> 600, 
 DisplayFunction -> displayF[legends, data]]

enter image description here

Let

legends2 = MapThread[SwatchLegend[{#}, {#2}, LegendLayout -> "Column"] &, 
   {colors, legendlabels}];

and use DisplayFunction -> displayF[legends2, data] to get:

enter image description here

Use

DisplayFunction -> 
  displayF[Append[{LegendMarkerSize -> 20, LegendMarkers -> "Bubble", 
     LabelStyle -> {White, 24}}] /@ legends, 
   Map[Map[Style[#, 24, White] &]] @ data, Black, Gray, 40]

to get

enter image description here

SeedRandom[1]
randomdata = RandomInteger[100, {5, 6}];

labels = RandomWord["Noun", 6];

legendLabels = Style[#, 14] & /@ Table[StringRiffle[RandomWord["Noun", 3]], 5];

swatchlegends = MapThread[
   SwatchLegend[{#}, {#2}, LegendLayout -> "Column", "MarkerLayout" -> "After"] &, 
   {ColorData["Pastel"] /@ Rescale[Range @ 5], legendLabels}];

BarChart[Transpose @ randomdata, 
 ChartLabels -> {Placed[labels, Below], None}, 
 ChartStyle -> {None, "Pastel"},
 FrameLabel -> {{"PercentChange", None}, {None, None}}, 
 PlotTheme -> "Business", AspectRatio -> 2/3, ImageSize -> 800, 
 DisplayFunction -> displayF[swatchlegends, 
   Map[Style[#, 14, White] &] /@ randomdata, Automatic, Black]]

enter image description here

twogroups = randomdata[[All, ;; 2]];

twolabels = labels[[;; 2]];

BarChart[Transpose @ twogroups , 
 ChartLabels -> {Placed[twolabels, Below], None}, 
 ChartStyle -> {None, "Pastel"},
 BarSpacing -> {.25, 2}, 
 FrameLabel -> {{"PercentChange", None}, {None, None}}, 
 PlotTheme -> "Business", AspectRatio -> 2/3, ImageSize -> 800, 
 DisplayFunction -> displayF[swatchlegends, 
   Map[Style[#, 14, White] &] /@ twogroups, Automatic, Black]]

enter image description here

Improve this answer
$\endgroup$
6
  • 1
    $\begingroup$ A perfect figure!!! Much much more beautiful than the original figure I posted. $\endgroup$
    – Tugrul Temel
    Commented Dec 28, 2021 at 15:54
  • $\begingroup$ Editions are very useful indeed. I tried to use them but somehow they did not work. I wonder whether you revised the displayF function. $\endgroup$
    – Tugrul Temel
    Commented Dec 30, 2021 at 10:51
  • 1
    $\begingroup$ @TugrulTemel, i made many revisions in the definition of displayF (you can see all the edits in revisions). The latest version works both in version 11.3.0 and version 13.0. $\endgroup$
    – kglr
    Commented Dec 30, 2021 at 11:44
  • $\begingroup$ I copied the entire code in a new notebook and run it. Still, the newly added legends2 and DisplayFunction->... with Bubble are not working but the rest is working just fine. I do not receive any error but the displayF is printed with no error message. $\endgroup$
    – Tugrul Temel
    Commented Dec 30, 2021 at 12:36
  • 1
    $\begingroup$ @TugrulTemel, by "use DisplayFunction -> displayF[legends2, data]" I meant replace DisplayFunction -> displayF[legends, data] above with DisplayFunction -> displayF[legends2, data]. $\endgroup$
    – kglr
    Commented Dec 30, 2021 at 13:58
3
$\begingroup$

Edit

ClearAll["Global`*"]
air = {3, 1, 6};
water = {2, 4, 3};
road = {1, 0, 7};
root = {6, 1, 2};
fig = BarChart[Transpose@{air, water}, ChartStyle -> {None, "Pastel"},
    FrameLabel -> {None, 
     Style["Percent Change", 13, Black, FontFamily -> "Helvetica"]}, 
   PlotTheme -> "Business", ImageSize -> 240, 
   ImagePadding -> {{Automatic, 1}, {5, 1}}, AspectRatio -> 1.5];
tab = TableForm[{air, water, road, root}, 
   TableHeadings -> {{Row[{RGBColor[
        0.7817626205714286, 0.5184517919999999, 0.9458540697142858], 
        Style["change in air", 13, FontFamily -> "Helvetica"]}, 
       Spacer[0.2]], 
      Row[{RGBColor[
        0.45017355885714305`, 0.7203669629714287, 0.9303642073142858],
         Style["flowing water", 13, FontFamily -> "Helvetica"]}, 
       Spacer[0.2]], 
      Style["construction road", 13, FontFamily -> "Helvetica"], 
      Style["agriculture root", 13, 
       FontFamily -> "Helvetica"]}, {Style["Belarus", 13, 
       FontFamily -> "Helvetica"], 
      Style["Georgia", 13, FontFamily -> "Helvetica"], 
      Style["Armenia", 13, FontFamily -> "Helvetica"]}}, 
   TableAlignments -> Center];
Overlay[{Graphics[{FaceForm[GrayLevel[0.9]], Rectangle[]}, 
   ImageSize -> 440], 
  Multicolumn[{fig, tab}, 1, Spacings -> 0, Alignment -> Right]}, 
 Alignment -> Center]

enter image description here

Original Answer

Here is a quick and dirty way to do it. This can be improved further.

air = {3, 1, 6};
water = {2, 4, 3};
road = {1, 0, 7};
root = {6, 1, 2};
clist = {"Belarus", "Georgia", "Armenia"};
fig = BarChart[Transpose@{air, water}, ChartLabels -> {clist, None}, 
   ChartStyle -> {None, "Pastel"}, 
   FrameLabel -> {"", "Percent Change"}, PlotTheme -> "Business"];

tab = TableForm[{air, water, road, root}, 
   TableHeadings -> {{Row[{RGBColor[
        0.7817626205714286, 0.5184517919999999, 0.9458540697142858], 
        "change in air"}, Spacer[0.2]], 
      Row[{RGBColor[
        0.45017355885714305`, 0.7203669629714287, 0.9303642073142858],
         "flowing water"}, Spacer[0.2]], "construction road", 
      "agriculture root"}, None}];

Overlay[{Graphics[{FaceForm[GrayLevel[0.9]], Rectangle[]}, 
   ImageSize -> 250], Multicolumn[{fig, tab}, 1, Alignment -> Right]},
  Alignment -> Center]

enter image description here

Improve this answer
$\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.