MoleculePlot3D - how to replace spheres?

Question

How to replace the spheres in the plot with other 3d figures, say "N" with a Cylinder, "O" with a Cuboid, and "H" with a sphere.

MoleculePlot3D[Molecule["Serine"], ColorRules -> {"H" -> Red, "O" -> Blue, "N" -> Green}]

I have been thinking that an option to do this would be useful, something equivalent to the VertexShapeFunction used by Graph, but for atoms. If this is something you would find useful also you could submit feedback to that effect (in product go to Help->Give feedback). — Jason B., Nov 19 '20 at 16:43

Anton Antonov · Answer 1 · 2020-11-20T13:30:11.790

How to replace the spheres in the plot with other 3d figures, say "N" with a Cylinder, "O" with a Cuboid, and "H" with a sphere.

This answer takes points from the GraphicsComplex object generated by MoleculePlot3D and makes related graphics objects replacements.

The colors are used to identify the atoms. (That is probably a weak way to identify, but it works...)

gr = MoleculePlot3D[Molecule["Serine"], 
   ColorRules -> {"H" -> Red, "O" -> Blue, "N" -> Green}];
gr

{grPoints, grSpec} =  Cases[gr[[1]], GraphicsComplex[p_, s___] :> {p, s}][[1]];

Define the replacement functions:

Clear[SphereToCuboid];
SphereToCuboid[s_Sphere] := 
  Map[Cuboid[# - {1, 1, 1}*s[[2]], # + {1, 1, 1}*s[[2]]] &, s[[1]]];
SphereToCuboid[{col_RGBColor, s_Sphere}] := 
  Map[{col, #} &, Flatten@List@SphereToCuboid[s]];
Clear[SphereToCylinder]
SphereToCylinder[s_Sphere, factor_ : 1.2] := 
  Map[Cylinder[{# - {0, 0, 1}s[[2]], # + {0, 0, 1}s[[2]]}, 
     factor*s[[2]]] &, s[[1]]];
SphereToCylinder[{col_RGBColor, s_Sphere}, factor_ : 1.2] := 
  Map[{col, #} &, Flatten@List@SphereToCylinder[s, factor]];
Clear[SphereToSphere]
SphereToSphere[s_Sphere, factor_ : 1.6] := 
  Map[Sphere[#, factor*s[[2]]] &, s[[1]]];
SphereToSphere[{col_RGBColor, s_Sphere}, factor_ : 1.6] := 
  Map[{col, #} &, Flatten@List@SphereToSphere[s, factor]];
Clear[SphereToPolyhedron]
SphereToPolyhedron[s_Sphere, pspec_, factor_ : 1.2] := 
  Map[Scale[
     GeometricTransformation[PolyhedronData[pspec, "GraphicsComplex"],
       TranslationTransform[#]], factor*s[[2]]] &, s[[1]]];
SphereToPolyhedron[{col_RGBColor, s_Sphere}, pspec_, factor : 1.2] := 
  Map[{col, #} &, Flatten@List@SphereToPolyhedron[s, pspec, factor]];

(SphereToSphere was defined for completeness.)

Make the replacement (using Pink for "N" instead of Red):

Graphics3D[gr[[1]] /. {
   (x : {Blue, Sphere[ps : {_?IntegerQ ..}, args___]}) :> {Blue, 
     SphereToCuboid[Sphere[grPoints[[ps]], args]]},
   (x : {Green, Sphere[ps : {_?IntegerQ ..}, args___]}) :> {Green, 
     SphereToCylinder[Sphere[grPoints[[ps]], args]]},
   (x : {Red, Sphere[ps : {_?IntegerQ ..}, args___]}) :> {Pink, 
     SphereToSphere[Sphere[grPoints[[ps]], args]]}
   }]

How could I replace not with a cylinder, but like something more complex like this: Graphics3D[{Red, Lighting -> "Neutral", Opacity[.9], PolyhedronData["SnubDodecahedron", "GraphicsComplex"]}, Boxed -> False]

Graphics3D[gr[[1]] /. {
   (x : {Blue, Sphere[ps : {_?IntegerQ ..}, args___]}) :> {Blue, 
     SphereToCuboid[Sphere[grPoints[[ps]], args]]},
   (x : {Green, Sphere[ps : {_?IntegerQ ..}, args___]}) :> {Green, 
     SphereToCylinder[Sphere[grPoints[[ps]], args]]},
   (x : {Red, Sphere[ps : {_?IntegerQ ..}, args___]}) :> {Pink, 
     SphereToPolyhedron[Sphere[grPoints[[ps]], args], 
      "SnubDodecahedron", 1]}
   }]

Thanks, quite complicated. How could I replace not with a cylinder, but like something more complex like this: Graphics3D[{Red, Lighting -> "Neutral", Opacity[.9], PolyhedronData["SnubDodecahedron", "GraphicsComplex"]}, Boxed -> False] — Mikayel, Nov 19 '20 at 15:05
@bobthechemist Thanks! (This reminds me that I should be doing more Chemistry with WL...) — Anton Antonov, Nov 19 '20 at 16:08
@Mikayel See my update -- I am only using polyhedron specifications, though. (Maybe with Inset certain Graphics3D objects with special lighting and color settings can be used, but I do not plan to investigate that...) — Anton Antonov, Nov 19 '20 at 16:10

kglr · Answer 2 · 2020-11-22T00:36:32.963

m = Molecule["Serine"];

atoms = m["AtomList"][[All, 1]];

atomCoords = m["AtomCoordinates"]["Magnitudes"];

Specify desired colors and primitives for the attoms:

colorRules = {"H" -> Red, "O" -> Blue, "N" -> Green, _ -> RGBColor[.4, .4, .4]};
newPrimsRules = {"H" -> Cuboid[-{1, 1, 1}, {1, 1, 1}], "N" -> Cylinder[], 
      "O" -> PolyhedronData["Dodecahedron"][[1]], _ -> Sphere[]};

First, plot m without the atoms using the option PlotTheme -> "Tubes"

mp1 = MoleculePlot3D[m, ColorRules -> colorRules , PlotTheme -> "Tubes"]

or using the option Method -> {"DrawAtoms" -> False}:

mp1 = MoleculePlot3D[m, ColorRules -> colorRules , Method -> {"DrawAtoms" -> False}]

Then use Graphics3D or Graph3D or BubbleChart3D to render the atoms and show the result with mp1:

Graphics3D

shapes = MapThread[{#, Translate[Scale[#2, 1/3], #3 ]} &, 
    {Replace[atoms, colorRules, 1], Replace[atoms, newPrimsRules, 1], atomCoords}];
Show[mp1, Graphics3D[shapes]]

Graph3D

vshapes = Replace[atoms, newPrimsRules, 1];
g3d = Graph3D[Range @ m["AtomCount"], {}, 
   VertexCoordinates -> atomCoords, 
   VertexStyle -> {v_ :> (atoms[[v]] /. colorRules)}, 
   VertexSize -> .5,
   VertexShapeFunction -> (Translate[Scale[vshapes[[#2]], #3], # ] &)];
Show[mp1, g3d]

BubbleChart3D

 bcdata = Append[#, 1] -> #2 & @@@ Transpose[{atomCoords, vshapes}];
bc3d = BubbleChart3D[bcdata, 
    ChartStyle -> Replace[atoms, colorRules, 1],
    ChartElementFunction -> (Translate[Scale[#3[[1]], 1/4], Most @ #2] &)];
Show[mp1, bc3d]

Using built-in ChartElementFunctions:

bcdatab = Append[#, 1] -> #2 & @@@ Transpose[{atomCoords, atoms}];
cElementRules = {"H" -> "MarkerBubble3D", "O" -> "SquareWaveCube",
    "N" -> "TriangleWaveCube", _ -> "ProfileCube"};
bc3db = BubbleChart3D[bcdatab, 
    ChartStyle -> Replace[atoms, colorRules, 1],
    BubbleSizes -> {.075, .075},
    ChartElementFunction -> (ChartElementData[#3[[1]] /. cElementRules ][##] &)];
Show[mp1, bc3db]

Very nice, especially using BubbleChart3D! – Anton Antonov Nov 20 '20 at 13:31 — Anton Antonov, Nov 20 '20 at 13:31

score 2 · Answer 3 · answered Nov 19 '20 at 20:49

This is duplicate to how can i access the internal function that plots a molecule from a formatted xy. This is unfortunately outdated.

mole = Import["ExampleData/Caffeine.xyz", "Rules"]

This is a list of 4 component. First is the Graphics3D with which @anton-antonov deals so nicely.

I present this solution:

Quiet[With[{types = "VertexTypes" /. mole}, 
  GraphPlot3D[g, 
   VertexCoordinates -> 
    MapThread[
      Rule, {Range@Length@#, #} &["VertexCoordinates" /. mole]][[All, 
      2, 1, 1]], 
   VertexShapeFunction -> ({Specularity[GrayLevel[1], 100], 
       ColorData["Atoms"]@types[[#2]], Cube[#1, 0.25]} &), 
   EdgeRenderingFunction -> ({Specularity[GrayLevel[1], 100], 
       EdgeForm[], ColorData["Atoms"]@types[[First@#2]], 
       Cylinder[{First[#1], Mean[#1]}, Scaled[0.015]], 
       ColorData["Atoms"]@types[[Last@#2]], 
       Cylinder[{Last[#1], Mean[#1]}, Scaled[0.015]]} &)]]]

This is better in performance because is does not do things twice and an expensive replace. OK. These are Cube all over.

So my solution is straightforward and as flexible as the other one:

g = MoleculeGraph[ mole[[2, 2]]]
Quiet[With[{types = "VertexTypes" /. mole}, 
  GraphPlot3D[g, 
   VertexCoordinates -> 
    MapThread[
      Rule, {Range@Length@#, #} &["VertexCoordinates" /. mole]][[All, 
      2, 1, 1]], 
   VertexShapeFunction -> ({Specularity[GrayLevel[1], 100], 
       ColorData["Atoms"]@types[[#2]], 
       Which[types[[#2]] === "N", 
        Cylinder[{#1, #1 + {0, 0, 1}}, 0.15], types[[#2]] === "H", 
        Sphere[#1, Scaled[0.025]], types[[#2]] === "O", 
        Cube[#1, 0.35], Not[MemberQ[types[[#2]], {"N", "H", "O"}]], 
        Sphere[#1, Scaled[0.025]]]} &), 
   EdgeRenderingFunction -> ({Specularity[GrayLevel[1], 100], 
       EdgeForm[], ColorData["Atoms"]@types[[First@#2]], 
       Cylinder[{First[#1], Mean[#1]}, Scaled[0.015]], 
       ColorData["Atoms"]@types[[Last@#2]], 
       Cylinder[{Last[#1], Mean[#1]}, Scaled[0.015]]} &)]]]

This is a solution matched to the present day version of Mathematica, I use V12.0.0, and how it treats Molecules and the knowledge built-in about chemistry molecules. This is experimental as the documentation page states. I make use of the triple structure and of GraphPlot3D which is updated in V12.0.0.

The step ahead from the referenced solution is MoleculeGraph. New is V12.0.0 too. So this solution is state-of-the-art in Mathematica and Wolfram Language. Have fun with the brand new soltuion.

kglr · Answer 4 · 2020-11-21T20:01:29.773

Post-process to replace Spheres with desired primitives:

ClearAll[coordsAssoc, postProcess]
coordsAssoc[mol_] := GroupBy[Transpose[{mol["AtomList"][[All, 1]], 
   mol["AtomCoordinates"]["Magnitudes"]}], First -> Last];
postProcess[mol_, newprimitives_] := ReplaceAll[
  Flatten[newprimitives /. HoldPattern[a_ -> p_] :>
  (Sphere[#, _] :> Translate[Scale[p, 1/3], #] & /@ coordsAssoc[mol][a])]][Normal@#]&

Examples:

m = Molecule["Serine"];
primitives = {"H" -> Cuboid[-{1, 1, 1}, {1, 1, 1}], "N" -> Cylinder[], 
         "O" -> PolyhedronData["Dodecahedron"][[1]]};
postProcess[m, primitives]@
 MoleculePlot3D[m, ColorRules -> {"H" -> Red, "O" -> Blue, "N" -> Green}]

m2 = Molecule["Caffeine"];
postProcess[m2, primitives]@
 MoleculePlot3D[m2, ColorRules -> {"H" -> Red, "O" -> Blue, "N" -> Green}]

We can use any 3D primitive (centered at the origin):

primitives2 = {"H" -> ChartElementData["MarkerBubble3D"][##], 
  "O" -> ChartElementData["SquareWaveCube", "RadialAmplitude" -> .4][##],
  "N" -> ChartElementData["PolyhedronBubble3D", 
     "Polyhedron" -> "Dodecahedron"][##]} &[{{-1, 1}, {-1, 1}, {-1, 1}}, {0, 0, 0}];
postProcess[m2, primitives2]@
 MoleculePlot3D[m2, ColorRules -> {"H" -> Red, "O" -> Blue, "N" -> Green}]

MoleculePlot3D - how to replace spheres?

4 Answers4

Graphics3D

Graph3D

BubbleChart3D