How to change element color in Periodic Table?

Question

The command

ColorData["Atoms", "Panel"]

generates a periodic table.

As I don't want to reinvent the wheel, I asked myself how to change the color of each cell in the periodic table, (hydrogen -> pink, iron, gray etc.). I want to do it in the simples way. How can I do that?

Since

ElementData[Element, "IconColor"]

is protected I dont have any idea.

Answer 1

myAtoms = {"H", "Li", "Na"};
defCols = myAtoms /. ColorData["Atoms", "ColorRules"];
newCols = {Pink, Yellow, LightBlue};
ColorData["Atoms", "Panel"] /. Thread[defCols -> newCols]

Edit:

Changing the font color isn't related to the ColorRules, but to the special formatting used by the Panel. So it's cumbersome, but you can see that Mma uses a similar approach to the following, since the only font colors that get changed are those of the three elements I selected:

newCols = {Red, Darker@Darker@Yellow, Blue};
nt = ColorData["Atoms", "Panel"] /. Thread[defCols -> newCols];

gl = GrayLevel;
nt /. {r : RGBColor@c__, e_[{r1__, Inset[Style[r2__, gl@_], r3__]}, r0__]} :> 
      {r, e[{r1, Inset[Style[r2, ColorConvert[r, "Grayscale"] /. gl@a_ :> gl@UnitBox@a], r3]}, r0]}

Answer 2

I know you said you didn't want to reinvent the wheel, but sometimes, it's fun to do so. The code below creates a palette with a Periodic Table and a few buttons to make useful tool tips. It shows how one might change the colors based on properties grabbed from ElementData. Note that this code was written for version 9, and if you wish to use it in version 10, you must first execute:

SetSystemOptions[SystemOptions["DataOptions"] /. True -> False]

Pardon some of the obfuscatory symbols; the code originates from my (failed) attempt to create a tweetable interactive periodic table.

CreatePalette[Manipulate[
  Column[{
    Evaluate[Grid[Table[{i, j}, {i, 7}, {j, 18}]]] /.
      Thread[
       Evaluate[
         Partition[
          MapThread[ElementData[#1, #2] &, 
           Transpose[Tuples[{Range[112], {"Period", "Group"}}]]], 
          2]] -> Evaluate[
         Item[Tooltip[ElementData[#, "Symbol"], 
             ElementData[#, popup]], Background -> color[#], 
            Frame -> True] & /@ Range[112]]] /. {{_, _} -> ""},
    Grid[{Item[
         Tooltip[ElementData[#, "Symbol"], ElementData[#, popup]], 
         Background -> color[#]] & /@ Range[57, 70], 
      Item[Tooltip[ElementData[#, "Symbol"], ElementData[#, popup]], 
         Background -> color[#]] & /@ Range[89, 102]}, Frame -> All]
    }, Alignment -> Center, Spacings -> {0, 1}, 
   BaseStyle -> {FontSize -> 10}],
  {{popup, "Name", "Show me the:"}, {"Name", 
    "AtomicNumber" -> "Atomic number", "AtomicMass" -> "Atomic mass", 
    "ElectronConfigurationString" -> 
     "\!\(\*SuperscriptBox[\(e\), \(-\)]\) config"}},
  {{color, bcd, "Color by"}, {ncd -> Tooltip["None", "No color"], 
    bcd -> Tooltip["Block", "s,p,d,f"], 
    pcd -> Tooltip["Phase", "Solid, Liquid, Gas"], 
    mcd -> Tooltip["Metal", "Metal, Nonmetal, Metalloid"]}},
  Initialization :> {
    ncd[x_] := White;
    bcd[x_] := 
     ColorData[11][
      ElementData[x, "Block"] /. {"s" -> 1, "p" -> 2, "d" -> 3, 
        "f" -> 4}];
    pcd[x_] := 
     ColorData[13][
      Switch[ElementData[x, "Phase"], "Gas", 6, "Liquid", 2, "Solid", 
       1, _, 5]];
    mcd[x_] := 
     Which[#[[1]], LightBlue, #[[2]], LightGreen, #[[3]], LightRed] &[
      MemberQ[ElementData[x, "Memberships"], #] & /@ {"Metal", 
        "Nonmetal", "Metalloid"} ];
    }], WindowTitle -> "Periodic Table"]

The part that is relevant to you is in the Initialization rule where I define ncd, bcd, pcd, and mcd. ncd sets all elements to the same color, bcd uses the block pulled from ElementData, and the last two pull characteristics from ElementData as well, using that information in slightly different ways. Hope this is helpful to someone.

Answer 3

This example picks the colors according to atomic weight, which are loaded from ElementData[]. Like belisarius's answer, it generates a list of rules to replace colors

which is then applied to the pane.

Rule @@@ Transpose[{ColorData["Atoms", "ColorList"] , 
   ColorData["NeonColors"][QuantityMagnitude@ElementData[#,"AtomicMass"]/200] &
   /@ Flatten@ColorData["Atoms", "Range"]}]
ColorData["Atoms", "Panel"] /. %

Answer 4

It seems to me that there are two natural approaches: (1) modifying color rules before the panel is created or (2) post-processing the output to replace recognizable colors. belisarius already showed a method for the second so I shall address the first.

This method is more robust than the post-processing one. See the final example below.

Modifying the color rules

The color rules are loaded through this call:

DataPaclets`ColorDataDump`getColorSchemeData["Atoms"]

From the definition:

DataPaclets`ColorDataDump`colorSchemes

The data looks like this:

For easy replacement of colors I propose:

subColors[cdat_List, {rules__} | rules_Rule] :=
  MapAt[ReplacePart[MapAt[PositionIndex @ cdat[[4]], 1] /@ {rules}], cdat, 5]

(Ignore any messages; I recommend putting Off[Pattern::patv] in your kernel init.m.)

This allows us to replace rules in the data with e.g.

subColors[data, {"H" -> Pink, "Fe" -> Gray}]

We can now use this replacement function in a wrapper function like this:

SetAttributes[withScheme, HoldFirst]

subColors[cdat_List, {rules__} | rules_Rule] :=
  MapAt[ReplacePart[MapAt[PositionIndex @ cdat[[4]], 1] /@ {rules}], cdat, 5]

withScheme[body_, scheme_, rules_] :=
  With[{CS := DataPaclets`ColorDataDump`colorSchemes},
    ColorData[1, 1] (*preload*);
    Internal`InheritedBlock[{CS, ColorData},
      Unprotect[ColorData]; ColorData[scheme] =.;
      CS = MapAt[subColors[#, rules] &, CS, Position[CS, {{scheme, ___}, __}]];
      body
    ]
  ]

Now:

withScheme[
  ColorData["Atoms", "Panel"],
  "Atoms",
  {"H" -> Pink, "Fe" -> Gray, "Ti" -> Red, "Hs" -> Blue}
]

This is intended for use with any Named color scheme. Because colors are modified before they are used this will even affect applications of the colors where they are later modified, e.g. with Darker:

withScheme[
 Graphics[{ColorData["Crayola", "SkyBlue"] ~Darker~ #, Rectangle[]}] & /@ {.1, .5, .8},
 "Crayola",
 "SkyBlue" -> Red
]