5
$\begingroup$

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?

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

3 Answers 3

4
$\begingroup$

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;
pos = MapThread[
  Thread[{#1, #2}] &, {Range@Length@Transpose@tdata, ord}];

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

(* labels and headers *)

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

enter image description here

Addendum (heatmap)

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

enter image description here

$\endgroup$
3
$\begingroup$

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

enter image description here

$\endgroup$
3
$\begingroup$

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]

enter image description here

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

enter image description here Highlight top 3 in every column:

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

enter image description here

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

enter image description here

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

enter image description here

See also: New 12.1 Dataset Interactive Controls and Formatting Options

$\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.