# How to highlight top N elements in each table column?

I have tables with column and row headings, similar to this one:

table = {{"",0.1,0.01},
{{1,0},1,3},
{{1,1},2,4}}


I want to highlight top N elements in each column.

As far as I understand, it should be among those lines:

1. Transpose table
2. Cut headings with Rest
3. Get per-row (transposed column) positions using PositionLargest
4. Somehow get full indices for the table
5. Transpose back
6. Pass the indices to Grid.

I'm stuck with 3-6:

1. perrowpos = Map[PositionLargest[Rest[#], 1] &, Rest[Transpose@table]]  for some tables returns Input {0.41,0.78} is not a real-valued vector. How can I fix this?

2. The mapping returns something like {{{2}}, {{2}}}. How can I transform this per-row list to a set of indices for the whole untransposed table?

3. Will the list of full indices can be passed to Grid Background as is?

• Does this produce the right positions? positions = MapIndexed[Join[{#1}, #2] + {1, 1} &, Flatten[PositionLargest /@ Transpose[Rest[table][[All, 2 ;;]]]]]; Jan 16 at 10:47

As an example in:

Using Highlighted and Ordering:

Clear["Global*"];
n = 2; (* number of highlighted positions *)
SeedRandom[2];

(* keep the data and headers separate *)
tdata = RandomInteger[{-10, 10}, {12, 8}];

ord = Ordering[#, -n] & /@ Transpose@tdata;

(* highlighted table, data only, no headers or labels *)
htable = MapAt[Highlighted, Transpose@tdata, Sequence @@@ pos] //
Transpose;

left = RandomWord["Noun", First@Dimensions@tdata];
top = {""}~Join~Alphabet[][[1 ;; Last@Dimensions@tdata]];

Prepend[Join[List /@ left, htable, 2], top] //
Grid[#, ItemSize -> {{8, 2}, {3, {2}}}
, Dividers -> All
, Alignment -> {{Left, {Center}}, Center}
] &


Clear["Global*"];
SeedRandom[2];
tdata = RandomInteger[{-10, 10}, {12, 8}];
top = {""}~Join~Alphabet[][[1 ;; Last@Dimensions@tdata]];
left = RandomWord["Noun", First@Dimensions@tdata];

ctable = Map[ColorData["TemperatureMap"][Rescale[#, {0, 1}]] &,
Rescale /@ (Ordering@Ordering@# & /@ Transpose@tdata) //
Transpose, {2}];
crules = Flatten[#, 1] &@
MapIndexed[#2 + 1 -> ctable[[Sequence @@ #2]] &, tdata, {2}];

Legended[
Grid[Prepend[Join[List /@ left, tdata, 2], top]
, Background -> {None, None, crules}
, ItemSize -> {{8, {2}}, {3, {2}}}
, Dividers -> All
, Alignment -> {{Left, {Center}}, Center}
]
, Placed[BarLegend[{"TemperatureMap", {1, First@Dimensions@tdata}}
, Ticks -> Range[0, First@Dimensions@tdata]
, LegendLabel -> Style["Order", Bold, 10]
]
, After]
]


For your example, we may first determine the position (row: pos of the largest element in each column (accounting for the header). Then we add the row number to pos, again accounting for the header. Finally we use the option "ItemStyle" of "Grid" to highlight the largest element in each column:

table = {{"", 0.1, 0.01}, {{1, 0}, 1, 3}, {{1, 1}, 2, 4}};
pos = PositionLargest /@ Rest[Transpose[Rest@table]];
i = 2;
pos = Append[# + 1, i++] & /@ pos;Grid[table, ItemStyle -> {Automatic, Automatic, Thread[pos -> Red]}]


We can use Dataset with custom functions as option settings for ItemStyle and Background:

itemStyle[topn_ : 2, topnstyle_ : Directive[Red, Bold], def_ : Black] :=
If[#2[[2]] > 1 && MemberQ[TakeLargest[#3[[2 ;;, #2[[2]]]], topn], #],
topnstyle, def]&

itemBackground[topn_ : 2, topnstyle_ : LightRed, def_ : White] :=
If[#2[[2]] > 1 && MemberQ[TakeLargest[#3[[2 ;;, #2[[2]]]], topn], #],
topnstyle, def]&


Examples:

Using example input from Syed's answer

SeedRandom[2];
tdata = RandomInteger[{-10, 10}, {12, 8}];
left = RandomWord["Noun", First@Dimensions@tdata];
top = {""}~Join~Alphabet[][[1 ;; Last@Dimensions@tdata]];
griddata = Prepend[Join[List /@ left, tdata, 2], top];

Grid[griddata, Dividers -> All]


Dataset[griddata, ItemStyle -> itemStyle[], Background -> itemBackground[]]


Highlight top 3 in every column:

Dataset[griddata, ItemStyle -> itemStyle[3], Background -> itemBackground[3]]


An alternative way to style cell backgrounds to get a heat-map:

itemBackground2[cs_String : "TemperatureMap", def_ : White] :=
If[#2[[2]] > 1,
Quiet@Lighter[ColorData[{cs, MinMax@#3[[2 ;;, 2 ;;]]}]@#], def] &

hm = Dataset[griddata,
ItemStyle -> itemStyle[1, Directive[Bold, 20]],
Background -> itemBackground2[]]


Legended[hm,
Placed[BarLegend[{"TemperatureMap", MinMax[tdata]},
LegendMarkerSize -> {20, 440}], After]]