# MoleculePlot3D - how to replace spheres?

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). Commented Nov 19, 2020 at 16:43

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] Commented Nov 19, 2020 at 15:05
• +1 for beating @jason-b to a MoleculePlot question! Commented Nov 19, 2020 at 15:49
• @bobthechemist Thanks! (This reminds me that I should be doing more Chemistry with WL...) Commented Nov 19, 2020 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...) Commented Nov 19, 2020 at 16:10
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! Commented Nov 20, 2020 at 13:31

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 ->
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 ->
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.

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