4
$\begingroup$

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

periodic table

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

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

enter image description here

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

$\endgroup$
  • $\begingroup$ 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}]] $\endgroup$ – Alex Trounev Oct 14 '18 at 4:42
  • $\begingroup$ Thank you @AlexTrounev. $\endgroup$ – kglr Oct 14 '18 at 5:02
  • $\begingroup$ 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. $\endgroup$ – J. M. will be back soon Oct 16 '18 at 4:14
  • $\begingroup$ @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. $\endgroup$ – kglr Oct 16 '18 at 5:20
  • $\begingroup$ Well, then you'll need to replace Thread[{"Nh", "Fl", "Mc"} -> {"Uut", "Uuq", "Uup"}] too for complete accuracy. ;) $\endgroup$ – J. M. will be back soon Oct 16 '18 at 5:23
9
$\begingroup$

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

enter image description here 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}}]]

enter image description here Original answer:

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]

enter image description here

$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Dinesh Shankar Oct 12 '18 at 2:10
  • 1
    $\begingroup$ @DineshShankar here is a way to get color bars: reference.wolfram.com/language/ref/BarLegend.html $\endgroup$ – b3m2a1 Oct 12 '18 at 2:26
  • $\begingroup$ Woa.. thanks. This is simpler than I thought. $\endgroup$ – Dinesh Shankar Oct 12 '18 at 12:09

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.