Map function on the specified location

Question

list = Symbol /@ CharacterRange["a", "n"];
MapAt[Style[#, Red] &, list, List /@ {4, 9, 2}];
MapAt[Style[#, Green] &, %, List /@ {3, 5, 7}];
MapAt[Style[#, Blue] &, %, List /@ {8, 1, 6}]

I am sure there is a better way do this, could you give any better ideas?

Answer 1

If there's no formula or pattern to the colors, then you have to somehow manually indicate how to style each part. Here are a couple of ways to do that using Rule to encode key/value pairs (in the form part -> style):

styleRules1 = {{4, 9, 2} -> Red, {3, 5, 7} -> Green, {8, 1, 6} -> Blue};

styleRules2 = {4 | 9 | 2 -> RGBColor[1, 0, 0], 3 | 5 | 7 -> RGBColor[0, 1, 0], 
    8 | 1 | 6 -> RGBColor[0, 0, 1]};

Here's a function that can take a list of such styling rules and apply them to the parts:

stylePart[expr_, rules_] := 
 ReplacePart[expr, 
  styleRules /. HoldPattern@Rule[alt_, color_] :> (i : alt :> Style[expr[[i]], color])
  ]

Examples

stylePart[list, Flatten[Thread /@ styleRules1]]

stylePart[list, styleRules2]

---

Here is another way to use such rules:

saStyles = SparseArray[styleRules2, Length@list];

styleIt[x_, 0] := x;
styleIt[x_, style_] := Style[x, style];
MapThread[styleIt, {list, saStyles}]

Answer 2

With these definitions:

list=CharacterRange["a","n"];
colorRules={{4,9,2}-> Red,{3,5,7}-> Green,{8,1,6}-> Blue};

Here is one option using Fold

colorize[list_,colorRule_]:=MapAt[Style[#,colorRule[[1]]]&,list,List /@ colorRule[[2]]]
Fold[colorize,list,colorRules]

Here is another using Rules with MapIdexed

rule=Dispatch@Flatten@Join[Thread/@colorRules,{_-> ""}];
MapIndexed[Style[#,#2[[1]]/.rule]&,list]

Answer 3

I think the most straightforward way is to use Switch and MapIndexed:

colorF[l_, {i_}] := Switch[i,
   4 | 9 | 2, Style[l, Red],
   3 | 5 | 7, Style[l, Green],
   8 | 1 | 6, Style[l, Blue],
   _, l
   ];
MapIndexed[colorF, list]

Another possibility is ReplacePart:

ReplacePart[list,
 {i_ /; MatchQ[i, 4 | 9 | 2] :> Style[list[[i]], Red],
  i_ /; MatchQ[i, 3 | 5 | 7] :> Style[list[[i]], Green],
  i_ /; MatchQ[i, 8 | 1 | 6] :> Style[list[[i]], Blue]}]

Answer 4

This question looks like fun. Too bad I missed out on the early action. I don't have much time but two ideas came to mind. The first was assignments to Part which I believe ssch already did. The second is creating a list if functions and then using Inner and Compose as I did for Map a function across a list conditionally.

fns = Function /@ Thread@Style[#, {Red, Green, Blue}];

pos = {{4, 9, 2}, {3, 5, 7}, {8, 1, 6}};

fns2 = SparseArray[Join @@ Thread /@ Thread[pos -> fns], Length@list, Identity];

Inner[Compose, fns2, list, List]

I'll be back later to refine this and add comparative timings.

---

Update #1

I changed my code above to eliminate Alternatives which, at least in version 7, causes a considerable slow-down when applied to a large number of elements. I knew this, but I was in a hurry. I have replaced it with a double-Thread approach that scales better.

Nevertheless this SparseArray construct is slower than assignments to Part, which doesn't surprise me. I could use Part assignments to build the function list that is passed to Inner but then there is little reason I can see not to use the method directly. Part assignment is a favorite method of mine anyway, so here is my variation of the Part assignment method ssch already posted:

mapAtParts[expr_, fns_List, pos_List] /;
  Length[fns] == Length[pos] && Max[pos] <= Length[expr] :=
    Module[{w = expr},
      MapThread[w[[#]] = #2 /@ w[[#]]; &, {pos, fns}];
      w
    ]

Example:

mapAtParts[
  CharacterRange["a", "n"],
  Function /@ Thread @ Style[#, {Red, Green, Blue}],
  {{4, 9, 2}, {3, 5, 7}, {8, 1, 6}}
]

Note: as described here in the section "We're not done yet" if the functions are Listable it will be more efficient to use that, i.e. w[[#]] = #2 @ w[[#]]; &.

Answer 5

MapIndexed[{First@#2, #} &,  CharacterRange["a",  "n"]] /. 
 {{id : Alternatives @@ {4, 9, 2}, el_} :> Style[el, Red],
  {id : Alternatives @@ {3, 5, 7}, el_} :> Style[el, Green],
  {id : Alternatives @@ {8, 1, 6}, el_} :> Style[el, Blue],
  {_, el_} -> el
 }

Answer 6

By copying the list and then repeatedly replacing part of it:

list = Symbol /@ CharacterRange["a", "n"];
result = list;
result[[{4, 9, 2}]] = Style[#, Red] & /@ result[[{4, 9, 2}]];
result[[{3, 5, 7}]] = Style[#, Green] & /@ result[[{3, 5, 7}]];
result[[{8, 1, 6}]] = Style[#, Blue] & /@ result[[{8, 1, 6}]];
result
(* result is now same as question output *)

This could be put in a function to save some typing:

MapAtMany::usage = "MapAtMany[{{f1, {i1, j1, ...}}, {f2, {i2, j2, ...}}, ...}, expr]";

MapAtMany[fpart_, expr_] := Module[{res = expr},
   Scan[
    (res[[ #[[2]] ]] = #[[1]] /@ res[[ #[[2]] ]]) &
    , fpart];
   res];

list = Symbol /@ CharacterRange["a", "n"];
fpart = {
   {Style[#, Red] &, {4, 9, 2}},
   {Style[#, Green] &, {3, 5, 7}},
   {Style[#, Blue] &, {8, 1, 6}}};

MapAtMany[fpart, list]

Fold can also be used so you don't have to refer to % for each successive function:

Fold[
 MapAt[#2[[1]], #1, Transpose@{#2[[2]]}] &,
 list,
 fpart
 ]

Although tests suggest that the Fold method is much slower and worse at scaling.

Answer 7

Here's a straightforward way using a Table where you make the list and the colors, and then match them.

list = Symbol /@ CharacterRange["a", "n"];
color = {Red, Green, Blue};
Table[Style[list[[ii]], color[[Mod[ii, Length[color]] + 1]]], {ii, 1, Length[list]}]

If you wish to specify the colors manually, that's easy too

list = Symbol /@ CharacterRange["a", "n"];
color = {Black, Red, Green, Blue};
locations = {2, 3, 4, 2, 3, 4, 2, 2, 1, 1, 1, 1, 1, 1};
Table[Style[list[[ii]], color[[locations[[ii]]]]], {ii, 1, Length[list]}]

Here's a way that bypasses the Table and uses MapThread instead. You can choose the colors in col manually, by algorithm, or choose them randomly:

list = Symbol /@ CharacterRange["a", "n"];
cols = RandomChoice[{Red, Blue, Green, Black}, Length[list]];    
MapThread[Style[#1, #2] &, {list, cols}]

Answer 8

A simple straightforward way for 1D lists (with non-continuous style associations):

list = Join[CharacterRange["a", "n"], {"Input", "MSG", Blue, Italic}]
color = {{4, 9, 2} -> Red, {12, 5, 7} -> Green, {8, 1, 6} -> Blue};

rules = ReplacePart[{} & /@ list, Flatten[color /. x_Rule :> Thread@x]];

Grid[{list}, ItemStyle -> {rules}]
MapThread[Style, {list, rules}]

Answer 9

list = Symbol /@ CharacterRange["a", "n"];

Here is how I would do it. First I would define a function to make a set of substitution rules for any set of indices and any given color.

makeRules[vars : {_Symbol ..}, 
    indices : {_Integer?Positive ..}, 
    color : (_RGBColor | _GrayLevel | _Hue)] := 
  Map[Rule[vars[[#]], Style[vars[[#]], color]] &, indices]

Next I would generate the full set of rules needed for the whole list of symbols.

fullRules = Flatten[{
   makeRules[list, {4, 9, 2}, Red],
   makeRules[list, {3, 5, 7}, Green],
   makeRules[list, {8, 1, 6}, Blue]}]

Finally I would apply the rules to the given list.

list /. fullRules

Answer 10

Just to add to the variety:

fun[list_, pos_, colors_] :=
 Module[
  {styles},
  styles = Function[{x}, Style[x, #]] & /@ colors;
  list /. 
   Flatten[Thread /@ 
     MapThread[#1 -> #2 /@ #1 &, {list[[#]] & /@ pos, styles}]]
  ]

Then

fun[list, {{4, 9, 2}, {3, 5, 7}, {8, 1, 6}}, {Red, Green, Blue}]

yields the same result.

EDIT

Noting Mr. Wizard's correction and mainly as (my own) learning opportunity the following is essentially one of Mr. Wizard's approaches slightly different but mapping functions to positions not elements.

func[list_, pos_, col_] :=
 Module[
  {l, el, styles, rules},
  l = Length[list];
  styles = Function[{x}, Style[x, #]] & /@ col;
  rules = Flatten[Thread /@ MapThread[Rule[#1, #2] &, {pos, styles}]];
  el = ReplacePart[Table[Identity, {l}], rules];
  MapThread[Compose, {el, list}]
  ]

Then

func[list, {{4, 9, 2}, {3, 5, 7}, {8, 1, 6}}, {Red, Green, Blue}]

works