# Periodic table with color code

Is it possible to do this table (from here) in Mathematica?

In this table, the color code indicates the element’s dipolar character $$(~ m\mu_m^2)$$ in atomic units.

• Is it possible? Yes – user6014 Oct 11 '18 at 23:17
• Why did you not provide a source fo this table? – J. M. is in limbo Oct 12 '18 at 1:29
• Why the downvoter? This is the Figure 1 of this thesis. Sorry for that. – Dinesh Shankar Oct 12 '18 at 1:34
• @user6014 Thank you for that. Do you have any hint on how to do this? – Dinesh Shankar Oct 12 '18 at 1:36
• It seems that this question was not well accepted. Please close it and then delete. Sorry. – Dinesh Shankar Oct 12 '18 at 2:10

where I used the list dipolar from Okkes's answer

dipolar2 = Flatten[Reverse @
FoldPairList[TakeDrop, dipolar, {15, 15, 17, 17, 18, 18, 8, 8, 2}]]


and ColorData["Atoms", "Panel"] modified to remove Eventhandlers and to replace abbreviations for some elements to match the table in OP:

panel = Replace[ColorData["Atoms", "Panel"][[1, 1]] /.
EventHandler -> (# &), {"Lv" -> "Uuh", "Ts" -> "Uus", "Og" -> "Uuo",
"Nh" -> "Uut", "Fl" -> "Uuq", "Mc" -> "Uup"}, ∞]  ;


with color function "Rainbow" (with purple tones clippped):

ClearAll[dipF, cF, reColorF]
elements =  Cases[panel, Style[s_String, ___] :> s,  ∞];
dipF = # /. Dispatch[Thread[elements -> dipolar2]] &;
cF = ColorData["Rainbow"][Clip[Rescale[#^(1/3),
MinMax[(dipF /@ elements)^(1/3)]], {1/10, ∞}]] & ;
reColorF[highlighted_: {}] := # /. {_RGBColor, {r_Rectangle,
Inset[Style[a_, b___], c___]}} :>
{EdgeForm[a /. {Alternatives @@ highlighted -> {Opacity[1], Magenta,
Thickness[.004]}, _ -> None}], cF[dipF @ a],
{r, Inset[Style[Column[{Style[a, White, FontSize -> Scaled[.02]],
Style[dipF@a, FontSize -> Scaled[.015], FontColor -> White]},
Alignment -> Center, Spacings -> .15], b], c]}} &;

lgnd = BarLegend[{cF, {0, 25000}}, "TickSide" -> Left, LegendMarkerSize -> {50, 200}];
legend = RawBoxes @ Replace[ToBoxes[lgnd], Rule[FrameTicks, _] :>
Rule[FrameTicks, False], ∞];
highlighted = {"H", "He", "Li", "Na", "K", "Rb", "Cs", "Ca", "Sr",
"Cr", "Dy", "Er", "Yb"} ;

Legended[Show[reColorF[highlighted]@panel  , ImageSize -> 700], legend]


the picture above

• fix two lines of code: add a square bracket in the line dipF = # /. Dispatch[Thread[elements -> dipolar2] ]&;, remove the square bracket in the line dipolar2 = Flatten[Reverse @ FoldPairList[TakeDrop, dipolar, {15, 15, 17, 17, 18, 18, 8, 8, 2}]] – Alex Trounev Oct 14 '18 at 4:42
• Thank you @AlexTrounev. – kglr Oct 14 '18 at 5:02
• Personally I'd have skipped the {"Lv" -> "Uuh", "Ts" -> "Uus", "Og" -> "Uuo"}, since you are replacing the currently accepted symbols with the old deprecated ones. – J. M. is in limbo Oct 16 '18 at 4:14
• @J.M.iscomputer-less, good point. I too would have skipped the replacement (out of laziness) if the task weren't to replicate the picture in OP. – kglr Oct 16 '18 at 5:20
• Well, then you'll need to replace Thread[{"Nh", "Fl", "Mc"} -> {"Uut", "Uuq", "Uup"}] too for complete accuracy. ;) – J. M. is in limbo Oct 16 '18 at 5:23

Edit 2:

dipolar = {327, 413, 4135, 4372, 2715, 0, 11907, 7026, 24700, 25100,
21017, 12593, 4128, 0, 29, 200, 2242, 1509, 831, 74, 0, 7446,
4473, 15893, 16250, 13359, 8196, 2703, 0, 252,
223, 0, 471, 96, 0, 6800, 9720, 9936, 4496, 280, 0, 32, 0, 2592,
2637, 1176, 0, 133, 0, 317, 65, 0, 4655, 6848, 6920, 3121, 197, 0,
23, 0, 1881, 1881, 840, 0, 85, 0, 128, 162, 258, 3455, 2450,
4952, 3705, 0, 108, 0, 13, 0, 1096, 1148, 508, 0, 39, 0, 65, 85,
18, 1872, 1373, 2010, 2122, 1467, 64, 0, 8, 0, 674, 711, 320, 0,
23, 0, 3, 0, 279, 289, 142, 0, 7, 0, 1, 0, 126, 144, 76, 0, 1, 0};
minMax = MinMax@((dipolar)^(1/3)) // N;
data = Delete[Join @@ Table[{i, j}, {j, 10}, {i, 1, 18}],
Join @@ {List /@ Range[2], List /@ Range[18, 20],
List /@ Range[36, 54], List /@ Range[57, 57],
List /@ Range[75, 75], List /@ Range[129, 138],
List /@ Range[147, 156], List /@ Range[164, 179]}];
data2 = Flatten /@ Partition[Riffle[(dipolar)^(1/3), data], 2];

Legended[Graphics[{EdgeForm[{Black}],
ColorData["DarkRainbow"][Rescale[First[#], minMax]],
Rectangle[Rest[#]], Black,
Text[First[#]^3, Rest[#] + {0.5, 0.5}]  } & /@ data2],
BarLegend[{"DarkRainbow", minMax},
Ticks -> {{0, 0}, {10, 1000}, {17.09975946676697,
5000}, {21.54434690031884, 10000}, {29.24017738212866,
25000}}]]


Edit: Just replace dipolar with the original data and change $$\{0,1\}$$ with min and max of dipolar data..

dipolar = RandomReal[1, 118];

data = Delete[Join @@ Table[{i, j}, {j, 10}, {i, 1, 18}],
Join @@ {List /@ Range[2], List /@ Range[18, 20],
List /@ Range[36, 54], List /@ Range[57, 57],
List /@ Range[75, 75], List /@ Range[129, 138],
List /@ Range[147, 156], List /@ Range[164, 179]}];

data2 = Flatten /@ Partition[Riffle[dipolar, data], 2];

Legended[Graphics[{EdgeForm[{Black}],
ColorData["ThermometerColors"][Rescale[First[#], {0, 1}]],
Rectangle[Rest[#]]} & /@ data2],
BarLegend[{"ThermometerColors", {0, 1}}]]


Here is starting point. Now you need to paint each individual square with the dipolar data..

data = Delete[Join @@ Table[{i, j}, {j, 10}, {i, 1, 18}],
Join @@ {List /@ Range[2], List /@ Range[18, 20],
List /@ Range[36, 54], List /@ Range[57, 57],
List /@ Range[75, 75], List /@ Range[129, 138],
List /@ Range[147, 156], List /@ Range[164, 179]}];
Graphics[Rectangle[#] & /@ data]
`

• Hum. Thank you for your help. I thought there was another way to do the color bar. I think there must be another solftwere that does this automatically. – Dinesh Shankar Oct 12 '18 at 2:10
• @DineshShankar here is a way to get color bars: reference.wolfram.com/language/ref/BarLegend.html – b3m2a1 Oct 12 '18 at 2:26
• Woa.. thanks. This is simpler than I thought. – Dinesh Shankar Oct 12 '18 at 12:09