6
$\begingroup$

I'm trying to format a raster-style table with row and column headings and in which each cell is shaded according to the value in the cell, and the value of the cell is displayed in as text in a contrasting shade, for example

I can kludge something together that works:

drawTable[s_] := With[
  {
   probs = Reverse[Table[RandomReal[], {Length[s]}, {Length[s]}]]
   },
  Show[Graphics[
    Raster[
     Append[
      Transpose[Prepend[Transpose[1 - probs], Table[1, {Length[s]}]]],
       Table[1, {Length[s] + 1}]]
     ]
    ],
   Epilog -> { 
     Table[
      Text[Style[s[[i]], Bold, GrayLevel[0.2]], {0.5, 
        Length[s] - i + 0.5}], {i, Length[s]}],
     Table[
      Text[Style[s[[i]], Bold, GrayLevel[0.2]], {i + 0.5, 
        Length[s] + 0.4}], {i, Length[s]}],
     Table[ 
      {GrayLevel[If[# <= 0.5, 0, 1] &[probs[[i, j]]]], Text[
        If[# == 0 , "", #] &[Round[#, N[10^-3]] ] &[probs[[i, j]]],
        {.5 + j, -.5 + i}]
       },
      {i, Length[s]}, {j, Length[s]}]       
     }
   ]
  ]

drawTable[{"A", "B", "C", "D", "E", "F", "H"}]

But there has to be an easier way. I've arrived at positioning by quite a bit of trial and error, resulting in a quite a bit of appending, transposing and un-transposing, and tweaking of positions, and even then the result isn't perfect (for example there is extra blank space above and to the left).

Is there a better way to go about this, either strategically (what a different API) or tactically (being smarter about list handling, especially)?


FWIW, in the actual scenario, I need more control over the formatting of the digits and of the text used for the headings, so I expect Text and Style are needed.

$\endgroup$
7
$\begingroup$

Maybe this:

icol[r_, c_] := Item[Style[NumberForm[r, {4,3}], c], Background -> GrayLevel[r]];
item[r_Real /; 0 <= r <= 1] := If[r > 0.5, icol[r, Black], icol[r, White]];
Grid[Map[item, RandomReal[1, {4, 4}], {2}], 
  ItemStyle -> "Text", 
  ItemSize -> {5, 5}, 
  Alignment -> {Center, Center}]

enter image description here

To add the row and column headers:

Grid[
 MapThread[
 Join,
 {{{""}, {"A"}, {"B"}, {"C"}, {"D"}},
 Join[{{"A", "B", "C", "D"}},
  Map[item, RandomReal[1, {4, 4}], {2}]]}],
 ItemStyle -> "Text",
 ItemSize -> {5, 5},
 Alignment -> {Center, Center}]

enter image description here

$\endgroup$
  • $\begingroup$ And the row and column labels? $\endgroup$ – orome Nov 10 '14 at 18:39
  • $\begingroup$ You should be able to prepend a row and column to your data (with no styling) $\endgroup$ – Arnoud Buzing Nov 10 '14 at 18:46
  • $\begingroup$ The shading is reverse: see the example (that's were all the Transposes came from). $\endgroup$ – orome Nov 10 '14 at 21:13
7
$\begingroup$

You can avoid Item and do this by referencing the Grid positions directly in Background and ItemStyle:

SeedRandom[1];
tmp = RandomReal[{0, 1}, {4, 4}];

Now:

Grid[tmp,
 Alignment -> {Center, Center},
 Background -> {None, None,Flatten[MapIndexed[#2 -> GrayLevel[1 - #1] &, tmp, {2}], 1]},
 ItemSize -> {10, 5},
 ItemStyle -> {None, None,Flatten[MapIndexed[#2 -> If[#1 > 0.5, White, Black] &, tmp, {2}],1]}
]

enter image description here

Edit

Realised I forgot to add your headers.

labels = {"", "A", "B", "C", "D"};

Grid[Join[List /@ labels, Join[{Rest@labels}, tmp], 2],
 Alignment -> {{Right, {Center}}, {Bottom, {Center}}},
 Background -> {None, None,Flatten[MapIndexed[1 + #2 -> GrayLevel[1 - #1] &, tmp, {2}], 1]},
 ItemSize -> {All, 5},
 ItemStyle -> {None, None,Flatten[MapIndexed[1 + #2 -> If[#1 > 0.5, White, Black] &,tmp, {2}], 1]},
 Spacings -> {{0, {3}}, {0, {3}}}]

enter image description here

$\endgroup$
  • 1
    $\begingroup$ That's a nice factoring. $\endgroup$ – orome Nov 10 '14 at 21:31
5
$\begingroup$
n = 7;
mat = Round[RandomReal[{0, 1}, {n, n}], 0.01];
ft = Transpose[{Range[n], Take[CharacterRange["A", "Z"], n]}];

ArrayPlot[
 mat,
 Epilog -> MapIndexed[Text[#1, #2 - 1/2] &, Transpose @ Reverse @ mat, {2}] /.
  Text[a_, b_] :> Text[Style[PaddedForm[a, {3, 2}], If[a > 0.5, White, Black]], b],
 FrameTicks -> {ft, ft},
 Mesh -> True,
 PlotTheme -> "Detailed",
 ImageSize -> 400]

enter image description here

ArrayPlot[
 Round[RandomReal[{-1, 1}, {4, 4}], 0.01],
 ColorFunction -> "RedGreenSplit",
 Epilog -> 
  MapIndexed[Text[Framed[#1, Background -> White], #2 - 1/2] &,
   Transpose @ Reverse @ mat, {2}],
 Mesh -> True,
 PlotTheme -> "Detailed",
 ImageSize -> 400]

enter image description here

$\endgroup$
  • $\begingroup$ If you change some ArrayPlot options (FrameTicks -> {{ft, None}, {None, ft}}, FrameTicksStyle -> Directive[Opacity[1], Black], FrameStyle -> Opacity[0]), you get an almost exact reproduction of OP's example! $\endgroup$ – Aisamu Nov 11 '14 at 17:50
2
$\begingroup$

Another way to use Graphics and Raster:

ClearAll[rF, tF, lF];
tF = Transpose[{Range[Length@#] - 1/2,Style[#, "Panel", 18] & /@ #}] &;
(* in some versions you might need Style[#, "Panel", 18, Background -> Transparent] & *)

lF = Text[Style[#, If[# <= .5, White, Black], "Panel", 16, Background -> Transparent],#2 - 1/2] &;

rF = With[{m = N@Round[RandomReal[1, {1, 1} Length@#], 1/100]},
    Graphics[{Raster[m], MapIndexed[lF, Transpose@m, {2}]},
     Frame -> True, FrameTicks -> {{tF@Reverse[#], None}, {None, tF@#}}]] &;

rF@RandomSample[CharacterRange["A", "Z"], 7]

enter image description here

Update: Just in case we want colors other than GrayLevel

lF2 = Text[Style[#, ColorData["TemperatureMap"][#], "Panel", 16, 
     Background -> Transparent], #2 - 1/2] &;

rF2 = With[{m = N@Round[RandomReal[1, {1, 1} Length@#], 1/100]}, 
    Graphics[{Raster[m, ColorFunction -> "TemperatureMap"], 
      MapIndexed[lF2, Transpose@m, {2}] /. 
       RGBColor -> Composition[Darker, Darker, RGBColor, Reverse[{##}] &]}, 
     Frame -> True, FrameTicks -> {{tF@Reverse[#], None}, {None, tF@#}}]] &;

rF2@RandomSample[CharacterRange["A", "Z"], 7]

enter image description here

$\endgroup$
  • $\begingroup$ (+1) It seems that you forgot Background -> Transparent in the definition for tF: I get gray background for the tick labels without it. $\endgroup$ – Alexey Popkov Nov 11 '14 at 12:22
  • $\begingroup$ @AlexeyPopkov, thank you. Ii think this may be a version/os issue; in version 9.0.1.0 (windows 8) it works as expected as is. I will add the option to tF. $\endgroup$ – kglr Nov 11 '14 at 12:28
1
$\begingroup$

Here is one more option using Grid.

data=Round[RandomReal[1,{5,5}],0.01];

colorIt[data_List]:=Module[{style},
    style=Item[Style[#,FontColor->ColorNegate@GrayLevel[#]],Background->GrayLevel[#]]&;
    Map[style,data,{-1}]
]

labelIt[label_List][data_List]:=Join[List/@Prepend[label,Null], Join[{label}, data], 2]

Grid[
     labelIt[{"A","B","C","D","E"}]@colorIt@data
     ,ItemSize->{4,4}
]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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