What is the best way to draw a shaded table?

Question

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.

Answer 1

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}]

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}]

Answer 2

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]}
]

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}}}]

Answer 3

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]

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]

Answer 4

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]

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]

Answer 5

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}
]