16

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.

J. M.'s missing motivation
  • 124,525
  • 11
  • 401
  • 574
Zhozer
  • 407
  • 4
  • 9
  • ColorData["Atoms","Panel"] and ElementData[element,"IconColor"] are not the same colors in general. There are slight differences. – hieron Aug 12 '14 at 06:36

4 Answers4

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

Mathematica graphics

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

Mathematica graphics

Dr. belisarius
  • 115,881
  • 13
  • 203
  • 453
13

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

enter image description here

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.

bobthechemist
  • 19,693
  • 4
  • 52
  • 138
  • @bobthechemist, can you find a way to display all or most of the features at the same time? – alancalvitti Aug 11 '14 at 18:05
  • @alancalvitti I'm not sure I follow. If you mean coming up with color scales for all of the properties provided by ElementData then yes, in principle, but that would require a a bit of thought. A generic elementcolordata function would need to handle missing data, devise a way to sort non-numeric data, and probably decide whether linear or logarithmic color scaling is appropriate. – bobthechemist Aug 11 '14 at 18:48
  • @bobthechemist, btw, +1, not necessarily by color but any other visualization method, eg icons or other graphical markup. Also there seem to be alternative periodic tables and layouts, including spiral based. Jan Boeyens describes 4 tables in his Chemistry from First Principles. It would be nice to relate them. – alancalvitti Aug 11 '14 at 20:17
  • @alancalvitti I see. Yes, I have given some alternate visualizations some thought, but non of that is ready for prime time yet. – bobthechemist Aug 11 '14 at 20:57
  • Wow, really cool, @bobthechemist . :) – Zhozer Aug 20 '14 at 16:09
7

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

Rules created in the first line

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"] /. %

Resulting pane

sjdh
  • 7,757
  • 5
  • 37
  • 47
6

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:

enter image description here

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

enter image description here

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
]

enter image description here

Mr.Wizard
  • 271,378
  • 34
  • 587
  • 1,371