10
$\begingroup$

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}]
$\endgroup$
1
  • 1
    $\begingroup$ 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). $\endgroup$
    – Jason B.
    Nov 19, 2020 at 16:43

4 Answers 4

13
$\begingroup$

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

enter image description here

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

enter image description here


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

enter image description here

$\endgroup$
4
  • $\begingroup$ 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] $\endgroup$
    – Mikayel
    Nov 19, 2020 at 15:05
  • 1
    $\begingroup$ +1 for beating @jason-b to a MoleculePlot question! $\endgroup$ Nov 19, 2020 at 15:49
  • $\begingroup$ @bobthechemist Thanks! (This reminds me that I should be doing more Chemistry with WL...) $\endgroup$ Nov 19, 2020 at 16:08
  • $\begingroup$ @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...) $\endgroup$ Nov 19, 2020 at 16:10
4
$\begingroup$
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"] 

enter image description here

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

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

![enter image description here

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

enter image description here

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] 

enter image description here

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] 

enter image description here

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]  

enter image description here

$\endgroup$
1
  • 1
    $\begingroup$ Very nice, especially using BubbleChart3D! $\endgroup$ Nov 20, 2020 at 13:31
2
$\begingroup$

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

enter image description here

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

Cube as a primitives from a generic approaches

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

 "N" with a Cylinder, "O" with a Cuboid, and "H" with a sphere.

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.

$\endgroup$
0
$\begingroup$

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

enter image description here

m2 = Molecule["Caffeine"];

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

enter image description here

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

enter image description here

$\endgroup$

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.