16
$\begingroup$

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.

$\endgroup$
1
  • $\begingroup$ ColorData["Atoms","Panel"] and ElementData[element,"IconColor"] are not the same colors in general. There are slight differences. $\endgroup$
    – hieron
    Aug 12, 2014 at 6:36

4 Answers 4

17
$\begingroup$
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

$\endgroup$
10
  • $\begingroup$ Welcome back with a +1 :) $\endgroup$
    – RunnyKine
    Aug 11, 2014 at 2:00
  • 1
    $\begingroup$ @RunnyKine Thanks! Too much boring work lately $\endgroup$ Aug 11, 2014 at 2:00
  • 3
    $\begingroup$ Leave those boring stuff and come have fun here. $\endgroup$
    – RunnyKine
    Aug 11, 2014 at 2:02
  • $\begingroup$ Thanks @belisarius. I Tried Hcolor = "Cr" /. ColorData["Atoms", "ColorRules"]; Ocolor = "Os" /. ColorData["Atoms", "ColorRules"]; ColorData["Atoms", "Panel"] /. {Hcolor :> Pink,Hcolor :> Pink} To change more than one color. Is it an uggly way? $\endgroup$
    – Zhozer
    Aug 11, 2014 at 2:06
  • $\begingroup$ @Zhozer See edit $\endgroup$ Aug 11, 2014 at 2:11
13
$\begingroup$

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.

$\endgroup$
5
  • $\begingroup$ @bobthechemist, can you find a way to display all or most of the features at the same time? $\endgroup$ Aug 11, 2014 at 18:05
  • $\begingroup$ @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. $\endgroup$ Aug 11, 2014 at 18:48
  • $\begingroup$ @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. $\endgroup$ Aug 11, 2014 at 20:17
  • $\begingroup$ @alancalvitti I see. Yes, I have given some alternate visualizations some thought, but non of that is ready for prime time yet. $\endgroup$ Aug 11, 2014 at 20:57
  • $\begingroup$ Wow, really cool, @bobthechemist . :) $\endgroup$
    – Zhozer
    Aug 20, 2014 at 16:09
7
$\begingroup$

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

$\endgroup$
0
6
$\begingroup$

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

$\endgroup$
2
  • $\begingroup$ Note: Caching bug corrected. $\endgroup$
    – Mr.Wizard
    Aug 12, 2014 at 3:28
  • 1
    $\begingroup$ @Zhozer You're welcome. I was wondering if anyone had noticed this answer. $\endgroup$
    – Mr.Wizard
    Aug 20, 2014 at 18:34

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.