https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Chemistry sorted by most likes. https://community.wolfram.com/groups/-/m/t/2411604 A new study group devoted to Differential Equations begins next Monday! A list of daily topics can be found on our [Daily Study Groups][1] page. This group will be led by one of our outstanding Wolfram certified instructors, Luke Titus, and will meet daily, Monday to Friday, over the next three weeks. Luke will share the excellent lesson videos created by him for the upcoming Wolfram U course "[Introduction to Differential Equations][2]". Study group sessions include time for exercises, discussion and Q&A. This study group will help you achieve the "Course Completion" certificate for the "Introduction to Differential Equations" course after you complete the course quizzes. Sign up: [Study group registration page][3] [1]: https://www.wolfram.com/wolfram-u/special-event/study-groups/ [2]: https://www.wolfram.com/wolfram-u/introduction-to-differential-equations/ [3]: https://www.bigmarker.com/series/daily-study-group-intro-to-differential-equations/series_details?utm_bmcr_source=community Devendra Kapadia 2021-11-22T16:35:30Z https://community.wolfram.com/groups/-/m/t/131302 I am reposting this here from the [url=http://mathematica.blogoverflow.com/]Stackexchange Mathematica blog[/url] so that more people might see it.  I'd be very happy to get some feedback on this plotting function.  If anyone can use the function, let me know how it works out for you, and if you'd recommend any changes.  If so, I can edit this post to have to most up-to-date version. As a chemist it is often useful to plot electronic orbitals. These are used to describe the wave function of electrons in atoms or molecules. Typically, these are output from electronic structure software in the form of a cube file, first developed by Gaussian. These files contain volumetric data for a given orbital on a three-dimensional grid. There exist many applications to visualize cube files, such as [url=http://www.ks.uiuc.edu/Research/vmd/plugins/molfile/cubeplugin.html]VMD [/url]or [url=http://www.gaussian.com/g_tech/gv5ref/results.htm]GaussView[/url], but I wanted to take advantage of Mathematica‘s capability to easily combine graphics, as well as the ability to automate the process in order to efficiently create frames for a [url=http://www.pnas.org/content/suppl/2013/09/05/1308604110.DCSupplemental/sm01.mp4]movie[/url]. First off, we need a function to extract the data from the cube file. In the process, we will create the text for an XYZ file, a format also developed by Gaussian. The function [b]OutForm[/b] is used here to mimic the printf function found in other programming languages. [mcode]OutForm[num_?NumericQ, width_Integer, ndig_Integer, OptionsPattern[]] := Module[{mant, exp, val}, {mant, exp} = MantissaExponent[num]; mant = ToString[NumberForm[mant, {ndig, ndig}]]; exp = If[Sign[exp] == -1, "-", "+"] <> IntegerString[exp, 10, 2]; val = mant <> "E" <> exp; StringJoin@PadLeft[Characters[val], width, " "] ]; ReadCube[cubeFileName_?StringQ] := Module[ {moltxt, nAtoms, lowerCorner, nx, ny, nz, xstep, ystep, zstep, atoms, desc1, desc2, xyzText, cubeDat, xgrid, ygrid, zgrid, dummy1, dummy2, atomicNumber, atomx, atomy, atomz, tmpString, headerTxt,bohr2angstrom}, bohr2angstrom = 0.529177249; moltxt = OpenRead[cubeFileName]; desc1 = Read[moltxt, String]; desc2 = Read[moltxt, String]; lowerCorner = {0, 0, 0}; {nAtoms, lowerCorner[[1]], lowerCorner[[2]], lowerCorner[[3]]} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; xyzText = ToString[nAtoms] <> "\n"; xyzText = xyzText <> desc1 <> desc2 <> "\n"; {nx, xstep, dummy1, dummy2} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; {ny, dummy1, ystep, dummy2} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; {nz, dummy1, dummy2, zstep} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; Do[ {atomicNumber, dummy1, atomx, atomy, atomz} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; xyzText = If[Sign[lowerCorner[[1]]] == 1, xyzText <> ElementData[atomicNumber, "Abbreviation"] <> OutForm[atomx, 17, 7] <> OutForm[atomy, 17, 7] <> OutForm[atomz, 17, 7] <> "\n", xyzText <> ElementData[atomicNumber, "Abbreviation"] <> OutForm[bohr2angstrom atomx, 17, 7] <> OutForm[bohr2angstrom atomy, 17, 7] <> OutForm[bohr2angstrom atomz, 17, 7] <> "\n"]; , {nAtoms}]; cubeDat = Partition[Partition[ReadList[moltxt, Number, nx ny nz], nz], ny]; Close[moltxt]; moltxt = OpenRead[cubeFileName]; headerTxt = Read[moltxt, Table[String, {2 + 4 + nAtoms}]]; Close[moltxt]; headerTxt = StringJoin@Riffle[headerTxt, "\n"]; xgrid = Range[lowerCorner[[1]], lowerCorner[[1]] + xstep (nx - 1), xstep]; ygrid = Range[lowerCorner[[2]], lowerCorner[[2]] + ystep (ny - 1), ystep]; zgrid = Range[lowerCorner[[3]], lowerCorner[[3]] + zstep (nz - 1), zstep]; {cubeDat, xgrid, ygrid, zgrid, xyzText, headerTxt} ];[/mcode] If you need to create a cube file, then the following function can be used: [mcode]WriteCube[cubeFileName_?StringQ, headerTxt_?StringQ, cubeData_] := Module[{stream}, stream = OpenWrite[cubeFileName, FormatType -> FortranForm]; WriteString[stream, headerTxt, "\n"]; Map[WriteString[stream, ##, "\n"] & @@ Riffle[ScientificForm[#, {3, 4}, NumberFormat -> (Row[{#1, "E", If[#3 == "", "+00", #3], "\t"}] &), NumberPadding -> {"", "0"}, NumberSigns -> {"-", " "}] & /@ #, "\n", {7, -1, 7}] &, cubeData, {2}]; Close[stream];][/mcode]Next we need the function to plot the orbital, [mcode]CubePlot[{cub_, xg_, yg_, zg_, xyz_}, plotopts : OptionsPattern[]] := Module[{xyzplot, bohr2picometer, datarange3D, pr}, bohr2picometer = 52.9177249; datarange3D = bohr2picometer {{xg[[1]], xg[[-1]]}, {yg[[1]], yg[[-1]]}, {zg[[1]], zg[[-1]]}}; xyzplot = ImportString[xyz, "XYZ"]; Show[xyzplot, ListContourPlot3D[Transpose[cub, {3, 2, 1}], Evaluate[FilterRules[{plotopts}, Options[ListContourPlot3D]]], Contours -> {-.02, .02}, ContourStyle -> {Blue, Red}, DataRange -> datarange3D, MeshStyle -> Gray, Lighting -> {{"Ambient", White}}], Evaluate[ FilterRules[{plotopts}, {ViewPoint, ViewVertical, ImageSize}]]] ]; [/mcode]Let’s look at an example. First we need to read in a cube file, download this cube file and place it in your base directory:  [url=https://dl.dropboxusercontent.com/s/rdsxcnqudn1s76n/cys-MO35.cube]cys-MO35cube[/url] [mcode]{cubedata,xg,yg,zg,xyz,header}= ReadCube["cys-MO35.cube"];[/mcode]Then plot it via[mcode]CubePlot[{cubedata, xg, yg, zg, xyz}][/mcode][img=width: 300px; height: 291px;]http://mathematica.blogoverflow.com/files/2013/09/pizCq-300x291.jpg[/img] When I want to create a movie file, I want all the images to have exactly the same [b]ViewAngle[/b], [b]ViewPoint[/b], and [b]ViewCenter[/b]. When you give these options to [b]CubePlot[/b], it feeds them directly to the [b]Show[/b] function [mcode]vp = {ViewCenter -> {0.5, 0.5, 0.5}, ViewPoint -> {1.072, 0.665, -3.13}, ViewVertical -> {0.443, 0.2477, 1.527}}; CubePlot[{cubedata, xg, yg, zg, xyz}, vp][/mcode][img=width: 280px; height: 300px;]http://mathematica.blogoverflow.com/files/2013/09/Q1mjs-280x300.jpg[/img] Finally, you can also give any options that normally go to [b]ListContourPlot3D[/b][mcode]CubePlot[{cubedata, xg, yg, zg, xyz}, vp, ContourStyle -> {Texture[ExampleData[{"ColorTexture", "Vavona"}]], Texture[ExampleData[{"ColorTexture", "Amboyna"}]]}, Contours -> {-.015, .015}][/mcode][img=width: 288px; height: 300px;]http://mathematica.blogoverflow.com/files/2013/09/fLyJ7-288x300.jpg[/img] Many thanks to Daniel Healion for the [b]ReadCube[/b] and [b]WriteCube[/b] functions. Jason Biggs 2013-09-27T18:35:45Z https://community.wolfram.com/groups/-/m/t/787142 ## General information and download links ## If you're interested in crystal structures, you can now download the Crystallica application from the Wolfram Library Archive, and then you can do things like this: Needs["Crystallica`"]; CrystalPlot[ {{5.4,0,0},{0,5.4,0},{0,0,5.4}}, {{0,0,0},{0,0,.5},{0,.5,0},{.5,0,0},{.24,.24,.24},{.24,.76,.76},{.76,.24,.76},{.76,.76,.24}}, {1,2,2,2,3,3,3,3}, AtomCol->{"Firebrick","YellowGreen",White},AtomRad->.4, BondStyle->2,BondDist->3, CellLineStyle->False,AddQ->True,Lighting->{{"Directional",White,ImageScaled[{0,0,1}]}},Background->Black] ![enter image description here][1] Here are the download links for Crystallica and two other packages you may need: [Crystallica][2] - contains the functions `CrystalPlot` and `CrystalChange` [CifImport][3] - contains an import function for CIF files [VaspImport][4] - contains an import function for files related to [VASP][5] Once you've installed Crystallica (by saving the entire Crystallica folder - not the zip archive - to `$USerBaseDirectory/Applications` and re-starting the Kernel), you can enter Crystallica into the Documentation Center and you'll find lots of useful examples. Most of the examples in this post are taken from the Documentation. For the other two packages, just install them and evaluate this: ?CifImport ?VaspImport I'll first show you a few things the `CrystalPlot` function can do when you already have crystal structure data inside Mathematica, wherever it may have come from. Then we'll take a look at how to get the data into Mathematica in the first place, which is where `CifImport` and `VaspImport` will come into play - but we'll get data from other sources as well. I'll cover the different import solutions in separate replies to this thread, because I have a feeling that I'll be rambling on and on and on... ## Simple plot ## Traditional ball-and-stick plots are usually just fine, so the simplest thing you can do is this: CrystalPlot[ {{4.5,0,0},{0,4.5,0},{0,0,3}}, {{0,0,0},{.5,.5,.5},{.2,.8,.5},{.3,.3,0},{.7,.7,0},{.8,.2,.5}}, {1,1,2,2,2,2}] ![enter image description here][6] As you can see, `CrystalPlot` expects three arguments. The first one contains the lattice vectors, which are simply the three vectors that create the parallelepiped that constitutes the cell. The second argument contains the atomic coordinates, but they're given in the basis of the lattice vectors (which is quite useful in crystallography). The third argument is a list of integers that gives the atom types, with one entry for each atom. If you want to plot a molecule instead, you can call `CrystalPlot` with just two arguments: A list of atom coordinates in cartesian space, and a list of atom types. Everything else you see in the plot - the atoms, bonds, colours, arrows etc. - represents the default settings of various layout options. ## Advanced atoms and bonds ## Let's take a look at some more advanced options just for fun. For instance, atoms and bonds can look any way you need them to, because you can specify your own functions for them. You can also fine-tune where to put bonds and what to do with their thickness and colour in a physically (or chemically) meaningful way, but I won't show that here. So here are some customized atoms and bonds: Row[Table[ CrystalPlot[{{4,0,0},{0,4,0},{0,0,4}},{{0,0,0},{.4,.4,.4},{.8,.8,.8}},{1,2,3}, AtomRad->{.4,1.2,.7},AtomFunction->style,ImageSize->400], {style,{ (Ball[#1,#2]&), (Scale[Sphere[#1,#2],{1,1,.5}]&), ({EdgeForm[Thick],Opacity[.7],Cuboid[#1-.5*#2,#1+.5*#2]}&) }}]] ![enter image description here][7] Row[Table[ CrystalPlot[{{0,0,0},{5,0,0},{2.5,4,0}},{1,2,3},BondDist->6,BondStyle->style,ImageSize->400], {style,{ 1, Function[{bonds,partcol},Table[{If[ii<.5,partcol[#,1],partcol[#,2]],Sphere[bonds[[#,1]]+ii*(bonds[[#,2]]-bonds[[#,1]]),.15]},{ii,0,1,1/9}]&/@Range[Length[bonds]]], Function[{bonds,partcol},Module[{spiral,points,rad=.05}, spiral[atoms_]:=Module[{scale=.5,dist=atoms[[2]]-atoms[[1]],curls=60,normal,rot,scaled}, normal=Table[{scale*Cos[ii],scale*Sin[ii],.1*ii},{ii,0,curls,\[Pi]/10}]; scaled={#[[1]],#[[2]],10*Norm[dist]/curls*#[[3]]}&/@normal; rot=scaled.Quiet[RotationMatrix[{dist,{0,0,1}}]]; Join[{atoms[[1]]},#+atoms[[1]]&/@(rot[[25;;-25]]),{atoms[[2]]}]]; points=spiral/@bonds; {partcol[#,1],Tube[BSplineCurve[points[[#,;;Round[Length[points[[#]]]/2]]],rad]],partcol[#,2],Tube[BSplineCurve[points[[#,Round[Length[points[[#]]]/2];;]],rad]]}&/@Range[Length[bonds]] ]] }}]] ![enter image description here][8] ## Lattice planes ## Crystallica can also add lattice planes to the plot. You can specify them using [h,k,l] Miller indices and distance to the origin. CrystalPlot[{{3,0,0},{0,3,0},{0,0,3}},{{0,0,0}},{1}, AddQ->True,AtomRad->.3,AtomCol->"CadmiumYellow",Sysdim->2,CellLineStyle->2, LatticePlanes->Table[{{1,1,1},dist},{dist,1,5}],ContourStyle->{"TerreVerte",Opacity[.7]},BoundaryStyle->Thick] ![enter image description here][9] ## Coordination polyhedra ## You can automatically search for and plot coordination polyhedra. This is not limited to the commonly occurring tetrahedra and octahedra - you can actually look for polyhedra with arbitrary numbers of corners. There are also options to fine-tune both the searching and the rendering. plot[corners_,mixed_]:=CrystalPlot[{{0,0,0},{0,0,1.8},{-.9,-1.5,-.6},{-.9,1.5,-.6},{1.7,0,-.6},{.8,.8,.8}},{1,2,2,2,2,3}, BondStyle->False,ImageSize->250, PolyMode[corners]->{"Show"->All,"AllowMixed"->mixed},PolyStyle[corners]->Directive[Opacity[.5],EdgeForm[Thick]]]; Grid[{{ "", "Search for polyhedra with \n4 corners", "Search for polyhedra with \n5 corners" },{ "Allow \nmixed corners", plot[4,True], plot[5,True] },{ "Don't allow \nmixed corners", plot[4,False], plot[5,False] }},Dividers->All] ![enter image description here][10] CrystalPlot[{{2.5,-4.3,0},{2.5,4.3,0},{0,0,5.5}}, {{.5,0,0},{0,.5,.7},{.5,.5,.3},{.2,.4,.5},{.6,.8,.2},{.2,.8,.8},{.8,.6,.5},{.4,.2,.2},{.8,.2,.8}},{1,1,1,2,2,2,2,2,2}, PolyMode[4]->True,PolyStyle[4]->EdgeForm[None],AddQ->True, Sysdim->2,AtomRad->0,CellLineStyle->False,AtomCol->{"SlateGray","Firebrick"}, ViewAngle->.4,ViewPoint->{3.2,0,1.1},ViewVertical->{.5,0,1.2}] ![enter image description here][11] ## Other things ## Visualization aside, you can also build supercells, change cell shapes, or add, remove and sort atoms... but that's a bit boring to read, so I'll refer you to the Documentation page of the `CrystalChange` function instead. If you're interested, we can use this thread to talk about any questions you may have, or you can share your use of the package (if you decide to use it). I'm not offering full support here, but I'll be floating around, and I'd like to hear your feedback. We don't have any intentions to be involved in further development. But if you have a good idea and some time, then by all means, work on it for yourself, or host it on your favourite code collaboration site. Bianca Eifert and Christian Heiliger [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=teaser.png&userId=69107 [2]: http://library.wolfram.com/infocenter/MathSource/9372/ [3]: http://library.wolfram.com/infocenter/MathSource/9373/ [4]: http://library.wolfram.com/infocenter/MathSource/9375/ [5]: http://vasp.at/ [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9692simple.png&userId=69107 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=atoms.png&userId=69107 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=bonds.png&userId=69107 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=planes.png&userId=69107 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=polys.png&userId=69107 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=polys2.png&userId=69107 [12]: http://rruff.geo.arizona.edu/AMS/CIF_text_files/13532_cif.txt [13]: http://cms.mpi.univie.ac.at/vasp/vasp/POSCAR_file.html [14]: http://wiki.jmol.org/index.php/File:Caffeine.mol Bianca Eifert 2016-02-05T18:43:18Z https://community.wolfram.com/groups/-/m/t/2026904 ![frontimage][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=imagefront.jpg&userId=1316061 [2]: https://www.wolframcloud.com/obj/88bd85e6-8a15-4fe1-ab85-7da71b0ce10b Claudio Chaib 2020-07-14T02:04:22Z https://community.wolfram.com/groups/-/m/t/1551098 ***NOTE: Download Full Article as a Notebook from the Attachment Below*** ---------- ![enter image description here][1] Interphase mass transfer operations such as gas absorption or liquid-liquid extraction pose a modeling challenge because the molar species concentration can jump between 2 states at the interface as shown below (from [here][2]). ![enter image description here][3] I wanted to see if I could create a Finite Element Method (FEM) model of jump conditions in the Wolfram Language. I found the results to be reasonable, aesthetically pleasing, and somewhat mesmerizing. The remainder of this post documents my workflow for those that might be interested. I have attached a notebook to reproduce the results. ## Preamble on analytical solutions to PDE's There seems to be quite a few posts where people are trying to find the analytical solution to a system of PDE's. Generally, closed formed analytical solutions only exist in rare-highly symmetric cases. Let us consider the heat equation below. $$\frac{\partial T}{\partial t}=\alpha \frac{\partial^2 T}{\partial x^2}$$ For the case of a semi-infinite bar subjected to a unit step change in temperature at $x=0$, Mathematica's DSolve\[\] handles this readily. u[x, t] /. First@DSolve[{ D[u[x, t], t] == alpha D[u[x, t], {x, 2}], u[x, 0] == 0, u[0, t] == UnitStep[t]}, u[x, t], {x, t}, Assumptions -> alpha > 0 && 0 < x] (*Erfc[x/(2*Sqrt[alpha]*Sqrt[t])]*) So far so good. Now, let us break symmetry by making it a finite bar of length $l$ (See [Documentation][4]). heqn = D[u[x, t], t] == alpha D[u[x, t], {x, 2}]; bc = {u[0, t] == 1, u[l, t] == 0}; ic = u[x, 0] == 0; sol = DSolve[{heqn, bc, ic}, u[x, t], {x, t}] (*{{u[x, t] -> 1 - x/l - (2*Inactive[Sum][Sin[(Pi*x*K[1])/l]/(E^((alpha*Pi^2*t*K[1]^2)/l^2)* K[1]), {K[1], 1, Infinity}])/Pi}}*) This little change going from a semi-infinite to finite domain has turned the solution into an unwieldy infinite sum. We should expect that it will only go down hill from here if we add additional complexity to the equation or system of equations. My advice is to abandon the search for an analytical solution quickly because it will likely take great effort and will be unlikely to yield a result. Instead, focus efforts on more productive avenues such as dimensional analysis and numerical solutions. # Introduction >"All models are wrong, some are useful." -- George E. P. Box >"However, many systems are highly complex, so that valid mathematical models of them are themselves complex, precluding any possibility of an analytical solution. In this case, the model must be studied by means of simulation, i.e. , numerically exercising the model for the inputs in question to see how they affect the output measures of performance." -- Dr. Averill Law, Simulation Modeling and Analysis I find the quotes above help me overcome inertia when starting a modeling and simulation project. Create your wrong model. Calibrate how wrong it is versus a known standard. If it is not too bad, put the model through its paces. One thing that I appreciate about the Wolfram Language is that I can document a modeling workflow development process from beginning to end in a single notebook. The typical model workflow development process includes: * A sketch of the system of interest. * Equations. * Initial development. * Simplification. * Non-dimensionalization for better scaling and reducing parameter space. * Mathematica implementation. * Mesh * Boundaries * Refinement * NDSolve set-up * Post-process results * Verification/Validation Mathematica notebooks tend to age well. I routinely resurrect notebooks that are over a decade old and they generally still work. ## Absorption I did a quick Google search on absorption and came across this figure describing gas absorption in an open access article by [Danish _et al_][5]. ![enter image description here][6] This image looked very similar to an image that I produced in a [related post](http://community.wolfram.com/groups/-/m/t/1470252) to the Wolfram community regarding porous media energy transport. ![enter image description here][7] The systems look so similar, that we ought to be able to reuse much of the modeling. An area of concern would be for gas absorption where the ratio of the gas diffusion coefficient to liquid diffusion coefficient can exceed 4 orders of magnitude. Such differences often can cause instability in numerical approaches. # Modeling ## System description For clarity, I always like to begin with a system description. Typically, absorption processes utilize gravity to create a thin liquid film to contact the gas. To reuse the modeling that we did for porous media, we will assume that gravity is in the positive $x$ direction leading us to the image below. ![enter image description here][8] We will assume that the liquid film is a uniform thickness and is laminar (note that for gas liquid contact the liquid velocity is fastest at the interface leading to the parabolic profile shown). We will assume that the gas has a uniform velocity. Further, we will assume that the incoming concentrations of the absorbing species are zero and we will impose a concentration of $C=C_0$ at the lower boundary. The basic dimensions of the box are shown below. For simplicity, we will make the height and length unit dimensions and set $R$ to be $\frac{1}{2}$. ![enter image description here][9] ## Balance equations ### Dilute species balance For the purposes of this exercise, we will consider the system to be dilute such that diffusion does not affect the overall flow velocities. Within a single phase, the molar balance of concentration is given by equation (1). We will assume steady-state operation with no reactions so that we can eliminate the red terms. $${\color{Red}{\frac{{\partial {C}}}{{\partial t}}}} + \mathbf{v} \cdot \nabla C - \nabla \cdot \mathcal{D} \nabla C - {\color{Red}{r^{'''}}} = 0 \qquad (1)$$ ### Species balance in each phase For convenience, I will denote the phases by a subscript G and L for gas and liquid with the understanding that these equations could also apply to a liquid-liquid extraction problem. This leads to the following concentration balance equations for the liquid and gas phases. $$\begin{gathered} \begin{matrix} \mathbf{v}_L \cdot \nabla C_L + \nabla \cdot \left(-\mathcal{D}_L \nabla C_L\right) = 0 & x,y\in \Omega_L & (2*) \\ \mathbf{v}_G \cdot \nabla C_G + \nabla \cdot \left(-\mathcal{D}_G \nabla C_G\right) = 0 & x,y\in \Omega_G & (3*) \\ \end{matrix} \end{gathered}$$ Or in Laplacian form $$\begin{gathered} \begin{matrix} \mathbf{v}_L \cdot \nabla C_L -\mathcal{D}_L \nabla^2 C_L = 0 & x,y\in \Omega_L & (2*) \\ \mathbf{v}_G \cdot \nabla C_G -\mathcal{D}_G \nabla^2 C_G = 0 & x,y\in \Omega_G & (3*) \\ \end{matrix} \end{gathered}$$ #### Creating a No-Flux Boundary Condition at the Interface To prevent the gas species diffusing into the liquid layer and _vice versa_, I will set the velocities to zero and the diffusion coefficients to a very small value in the other phase. From a visualization standpoint, it will appear that the gas species has diffused into the liquid layer and _vice versa_, but the flux is effectively zero. To clean up the visualization, we will define plot ranges by gas, interphase, and liquid regions. ### Species balance including a thin interphase region We will define a thin Interphase region between the 2 phases that will allow us to couple the phases in the interphase region via a source term creating the jump discontinuity in concentration as shown in the figure below. ![enter image description here][10] We will modify (2\*) and (3\*) with the coupling source term as shown below. $$\begin{gathered} \begin{matrix} \mathbf{v}_L \cdot \nabla C_L -\mathcal{D}_L \nabla^2 C_L - \sigma\left(\Omega \right )k\left(K C_G-C_L \right ) = 0 & x,y\in \Omega & (2) \\ \mathbf{v}_G \cdot \nabla C_G -\mathcal{D}_G \nabla^2 C_G + \sigma\left(\Omega \right )k\left(K C_G-C_L \right ) = 0 & x,y\in \Omega & (3) \\ \end{matrix} \end{gathered}$$ Where $K$ is a vapor-liquid equilibrium constant, $k$ is in interphase mass transfer coefficient (we will make this large because we want a fast approach to equilibrium), and $\sigma$ is a switch that turns on (=1) in the interface region and 0 otherwise. ## Dimensional analysis We will multiply equations (2) and (3) by $\frac{{R^2}}{C_0 \mathcal{D}_G}$ to obtain their non-dimensionalized forms (4) and (5). $$\begin{gathered} \begin{matrix} C_0\left (\frac{\mathbf{v}_L}{R} \cdot \nabla^* C_{L}^{*} -\frac{\mathcal{D}_L}{R^2} \nabla^{*2} C_{L}^{*} - \sigma\left(\Omega \right )k\left(K C_{G}^{*}-C_{L}^{*} \right ) \right ) = 0\left\| {\frac{{R^2}}{C_0 \mathcal{D}_G}} \right. \\ C_0\left (\frac{\mathbf{v}_G}{R} \cdot \nabla^* C_{G}^{*} -\frac{\mathcal{D}_G}{R^2} \nabla^{*2} C_{G}^{*} + \sigma\left(\Omega \right )k\left(K C_{G}^{*}-C_{L}^{*} \right ) \right ) = 0\left\| {\frac{{R^2}}{C_0 \mathcal{D}_G}} \right. \\ \end{matrix} \end{gathered}$$ $$\begin{gathered} \begin{matrix} \frac{\mathcal{D}_L}{\mathcal{D}_G} \frac{R\mathbf{v}_L}{\mathcal{D}_L} \cdot \nabla^* C_{L}^{*} -\delta \nabla^{*2} C_{L}^{*} - \sigma\left(\Omega \right )\kappa\left(K C_{G}^{*}-C_{L}^{*} \right ) = 0 \\ \frac{R\mathbf{v}_G}{\mathcal{D}_G} \cdot \nabla^* C_{G}^{*} - \nabla^{*2} C_{G}^{*} + \sigma\left(\Omega \right )\kappa\left(K C_{G}^{*}-C_{L}^{*} \right ) = 0\\ \end{matrix} \end{gathered}$$ $$\begin{gathered} \begin{matrix} \delta{Pe}_L\mathbf{v}_{L}^* \cdot \nabla^* C_{L}^{*} -\delta \nabla^{*2} C_{L}^{*} - \sigma\left(\Omega \right )\kappa\left(K C_{G}^{*}-C_{L}^{*} \right ) = 0 & (4) \\ {Pe}_G\mathbf{v}_{G}^* \cdot \nabla^* C_{G}^{*} - \nabla^{*2} C_{G}^{*} + \sigma\left(\Omega \right )\kappa\left(K C_{G}^{*}-C_{L}^{*} \right ) = 0 &(5)\\ \end{matrix} \end{gathered}$$ Where $$\delta=\frac{\mathcal{D}_L}{\mathcal{D}_G}$$ $$Pe_L=\frac{R\mathbf{v}_L}{\mathcal{D}_L}$$ $$Pe_G=\frac{R\mathbf{v}_G}{\mathcal{D}_G}$$ With a good dimensionless model in place, we can start with our Wolfram Language implementation. # Wolfram Language Implementation ## Mesh creation We start by loading the FEM package. Needs["NDSolve`FEM`"] When I started this effort, I considered co-current flow only. I realized that converting the model to counter-current flow was a simple matter of changing boundary markers. I wrapped the process up in a module that returns an association whose parameters can be used to set up an NDSolve solution. In the counter-current case, I changed the bottom boundary to a wall and the gas inlet concentration to 1. makeMesh[h_, l_, rat_, gf_, cf_] := Module[{bR, tp, bt, lf, rt, th, interfacel, interfaceg, buf, bnds, rgs, crds, lelms, boundaryMarker, bcEle, bmsh, liquidCenter, liquidReg, interfaceCenter, interfaceReg, gasCenter, gasReg, meshRegs, msh, mDic}, (* Domain Dimensions *) bR = rat h; tp = bR; bt = bR - h; lf = 0; rt = l; th = h/gf; interfacel = 0; interfaceg = interfacel - th; buf = 2.5 th; (* Use associations for clearer assignment later *) bnds = <|liquidinlet -> 1, gasinlet -> 2, bottom -> 3|>; rgs = <|gas -> 10, liquid -> 20, interface -> 15|>; (* Meshing Definitions *) (* Coordinates *) crds = {{lf, bt}(*1*), {rt, bt}(*2*), {rt, tp}(*3*), {lf, tp}(*4*), {lf, interfacel}(*5*), {rt, interfacel}(*6*), {lf, interfaceg}(*7*), {rt, interfaceg}(*8*)}; (* Edges *) lelms = {{1, 7}, {7, 5}, {5, 4}, {1, 2}, {2, 8}, {8, 6}, {6, 3}, {3, 4}, {5, 6}, {7, 8}}; (* Conditional Boundary Markers depending on configuration *) boundaryMarker := {bnds[gasinlet], bnds[liquidinlet], bnds[liquidinlet], bnds[bottom], 4, 4, 4, 4, 4, 4} /; cf == "Co"; boundaryMarker := {4, 4, bnds[liquidinlet], bnds[bottom], bnds[gasinlet], 4, 4, 4, 4, 4} /; cf == "Counter"; (* Create Boundary Mesh *) bcEle = {LineElement[lelms, boundaryMarker]}; bmsh = ToBoundaryMesh["Coordinates" -> crds, "BoundaryElements" -> bcEle]; (* 2D Regions *) (* Identify Center Points of Different Material Regions *) liquidCenter = {(lf + rt)/2, (tp + interfacel)/2}; liquidReg = {liquidCenter, rgs[liquid], 0.0005}; interfaceCenter = {(lf + rt)/2, (interfacel + interfaceg)/2}; interfaceReg = {interfaceCenter, rgs[interface], 0.5*0.000005}; gasCenter = {(lf + rt)/2, (bt + interfaceg)/2}; gasReg = {gasCenter, rgs[gas], 0.0005}; meshRegs = {liquidReg, interfaceReg, gasReg}; msh = ToElementMesh[bmsh, "RegionMarker" -> meshRegs, MeshRefinementFunction -> Function[{vertices, area}, Block[{x, y}, {x, y} = Mean[vertices]; If[ (y > interfaceCenter[[2]] - buf && y < interfaceCenter[[2]] + buf) || (y < bt + 1.5 buf && x < lf + 1.5 buf) , area > 0.0000125, area > 0.01 ] ] ] ]; mDic = <| height -> h, length -> l, ratio -> rat, gapfactor -> gf, r -> bR, top -> tp, bot -> bt, left -> lf, right -> rt, intl -> interfacel, intg -> interfaceg, intcx -> interfaceCenter[[1]], intcy -> interfaceCenter[[2]], buffer -> buf, mesh -> msh, bmesh -> bmsh, bounds -> bnds, regs -> rgs, cfg -> cf |>; mDic] Options[meshfn] = {height -> 1, length -> 1, ratio -> 0.5, gapfactor -> 100, config -> "Co"}; meshfn[OptionsPattern[]] := makeMesh[OptionValue[height], OptionValue[length], OptionValue[ratio], OptionValue[gapfactor], OptionValue[config]] We can create a mesh instance of a co-current flow case by invoking the meshfn\[\]. I will color the liquid inlet $\color{Green}{Green}$, the gas inlet $\color{Red}{Red}$ and the bottom boundary $\color{Orange}{Orange}$ (the rest of the boundaries are default). mDicCo = meshfn[config -> "Co"]; mDicCo[bmesh][ "Wireframe"["MeshElementMarkerStyle" -> Blue, "MeshElementStyle" -> {Green, Red, Orange, Black}, ImageSize -> Large]] ![enter image description here][11] By setting the optional config parameter to "Counter", we can easily generate a counter-current case as shown below (note how the gas inlet shifted to the right side. mDic = meshfn[config -> "Counter"]; mDic[bmesh][ "Wireframe"["MeshElementMarkerStyle" -> Blue, "MeshElementStyle" -> {Green, Red, Orange, Black}, ImageSize -> Large]] ![enter image description here][12] For the co-current case, the bottom wall and the gas inlet have inconsistent Dirichlet conditions. To reduce the effect, I refined the mesh in the lower left corner as shown below. ![enter image description here][13] I also meshed the interface region finely. ![enter image description here][14] Sometimes it can get confusing to setup alternative boundaries. To visualize the coordinate IDs, you could use something like: With[{pts = mDic[bmesh]["Coordinates"]}, Graphics[{Opacity[1], Black, GraphicsComplex[pts, Text[Style[ToString[#], Background -> White, 12], #] & /@ Range[Length[pts]]]}]] ![enter image description here][15] ## Solving and Visualization I have created a module that will solve and visualize depending on the mesh type (co-flow or counter-flow). Hopefully, it is well enough commented that further discussion is not needed. model[md_, kequil_, d_, pel_, peg_, title_] := Module[{n, pecletgas, por, vl, vg, fac, facg, coefl, coefg, dcliquidinletliquid, dcliquidinletgas, dcinletgas, dcgasinletliquid, dcgasinletgas, dcbottomliquid, dcbottomgas, eqnliquid, eqngas, eqns, ifun, pltl, pltint, pltg, pltarr, sz, grid, lf, rt, tp, bt, interfaceg, interfacel, interfaceCenterY, plrng, arrequil, arrdiff, arrgas, arrliq}, (*localize Mesh Dict Values*)lf = md[left]; rt = md[right]; tp = md[top]; bt = md[bot]; interfaceg = md[intg]; interfacel = md[intl]; interfaceCenterY = md[intcy]; (*Must swtich gas flow direction for counter-flow*) pecletgas = If[md[cfg] == "Co", peg, -peg]; (*Dimensionless Mass Transfer Coefficient in Interphase Region*) n = 10000; (*"Porosity" to weight concentration in interphase*) por[y_, intg_, intl_] := (y - intg)/(intl - intg); (*Region Dependent Properties with Piecewise \ Functions*)(*velocity*)(*Liquid parabolic profile*) vl = Evaluate[ Piecewise[{{{pel d (1 - (y/md[r])^2), 0}, ElementMarker == md[regs][liquid]}, {{pecletgas, 0}, ElementMarker == md[regs][gas]}, {{0, 0}, True}}]]; (*Gas Uniform Velocity*) vg = Evaluate[ Piecewise[{{{pecletgas, 0}, ElementMarker == md[regs][gas]}, {{pel d (1 - (y/md[r])^2), 0}, ElementMarker == md[regs][liquid]}, {{0, 0}, True}}]]; (*fac switches on mass transfer coefficient in interphase*) fac = Evaluate[If[ElementMarker == md[regs][interface], n, 0]]; (*diffusion coefficients*)(*Liquid*) coefl = Evaluate[ Piecewise[{{d, ElementMarker == md[regs][liquid]}, {1, ElementMarker == md[regs][interface]}, {d/1000000, True} (*Effectively No Flux at Interface*)}]]; (*Gas*)coefg = Evaluate[ Piecewise[{{1, ElementMarker == md[regs][gas]}, {1, ElementMarker == md[regs][interface]}, {d/1000000, True} (*Effectively No Flux at Interface*)}]]; (*Dirichlet Conditions for Liquid at Inlets*) dcliquidinletliquid = DirichletCondition[cl[x, y] == 0, ElementMarker == md[bounds][liquidinlet]]; dcliquidinletgas = DirichletCondition[cg[x, y] == 0, ElementMarker == md[bounds][liquidinlet]]; dcgasinletliquid = DirichletCondition[cl[x, y] == 0, ElementMarker == md[bounds][gasinlet]]; (*Conditional BCs for gas dependent on configuration*) dcgasinletgas := DirichletCondition[cg[x, y] == 0, ElementMarker == md[bounds][gasinlet]] /; md[cfg] == "Co"; dcgasinletgas := DirichletCondition[cg[x, y] == 1, ElementMarker == md[bounds][gasinlet]] /; md[cfg] == "Counter"; (*Dirichlet Conditions for the Bottom Wall*) dcbottomliquid = DirichletCondition[cl[x, y] == 0, ElementMarker == md[bounds][bottom]]; dcbottomgas = DirichletCondition[cg[x, y] == 1, ElementMarker == md[bounds][bottom]]; (*Balance Equations for Gas and Liquid Concentrations*) eqnliquid = vl.Inactive[Grad][cl[x, y], {x, y}] - coefl Inactive[Laplacian][cl[x, y], {x, y}] - fac (kequil cg[x, y] - cl[x, y]) == 0; eqngas = vg.Inactive[Grad][cg[x, y], {x, y}] - coefg Inactive[Laplacian][cg[x, y], {x, y}] + fac (kequil cg[x, y] - cl[x, y]) == 0; (*Equations to be solved depending on configuration*) eqns := {eqnliquid, eqngas, dcliquidinletliquid, dcliquidinletgas, dcgasinletliquid, dcgasinletgas, dcbottomliquid, dcbottomgas} /; md[cfg] == "Co"; eqns := {eqnliquid, eqngas, dcliquidinletliquid, dcliquidinletgas, dcgasinletliquid, dcgasinletgas} /; md[cfg] == "Counter"; (*Solve the PDE*) ifun = NDSolveValue[eqns, {cl, cg}, {x, y} \[Element] md[mesh]]; (*Visualizations*)(*Create Arrows to represent magnitude of \ dimensionless groups*)(*Equilibrium Arrow*) arrequil = {CapForm["Square"], Red, Arrowheads[0.03], Arrow[Tube[{{1 - 0.0125, 0.025, 1}, {1 - 0.0125, 0.025, kequil}}, 0.005], -0.03]}; (*Diffusion Arrow*) arrdiff = {Darker[Green, 1/2], Arrowheads[0.03, Appearance -> "Flat"], Arrow[Tube[{{-0.025, 0.0, 0.0 .025}, {-0.025, 0.5 (1 + Log10[d]/4), 0.025}}, 0.005], -0.03]}; (*Liquid Peclet Arrow*) arrliq = {Blue, Dashed, Arrowheads[1.5 0.03], Arrow[Tube[{{0.0, mDic[top] + 0.025, 0.035}, {pel/50, mDic[top] + 0.025, 0.035}}, 1.5 0.005], -0.03 1.5]}; (*Conditional Gas Peclet Arrow*) arrgas := {Black, Dashed, Arrowheads[1.5 0.03], Arrow[Tube[{{0.0, mDic[bot], 1.035}, {peg/50, mDic[bot], 1.035}}, 1.5 0.005], -0.03 1.5]} /; md[cfg] == "Co"; arrgas := {Black, Dashed, Arrowheads[1.5 0.03], Arrow[Tube[{{mDic[right], mDic[bot], 1.035}, {mDic[right] - peg/50, mDic[bot], 1.035}}, 1.5 0.005], -0.03 1.5]} /; md[cfg] == "Counter"; (*Set up plots*)(*Common plot options*) plrng = {{lf, rt}, {bt, tp}, {0, 1}}; SetOptions[Plot3D, PlotRange -> plrng, PlotPoints -> {200, 200}, ColorFunction -> Function[{x, y, z}, Directive[ColorData["DarkBands"][z]]], ColorFunctionScaling -> False, MeshFunctions -> {#3 &}, Mesh -> 18, AxesLabel -> Automatic, ImageSize -> Large]; (*Liquid Plot*) pltl = Plot3D[ifun[[1]][x, y], {x, lf, rt}, {y, interfacel, tp}, MeshStyle -> {Black, Thick}]; (*Interface region Plot*) pltint = Plot3D[ifun[[2]][x, y] (1 - por[y, interfaceg, interfacel]) + por[y, interfaceg, interfacel] ifun[[1]][x, y], {x, lf, rt}, {y, interfaceg, interfacel}, MeshStyle -> {DotDashed, Black, Thick}]; (*Gas Plot*) pltg = Plot3D[ifun[[2]][x, y], {x, lf, rt}, {y, bt, interfaceg}, MeshStyle -> {Dashed, Black, Thick}]; (*Grid Plot*)sz = 300; grid = Grid[{{Show[{pltl, pltint, pltg}, ViewProjection -> "Orthographic", ViewPoint -> Front, ImageSize -> sz, Background -> RGBColor[0.84`, 0.92`, 1.`], Boxed -> False], Show[{pltl, pltint, pltg}, ViewProjection -> "Orthographic", ViewPoint -> Left, ImageSize -> sz, Background -> RGBColor[0.84`, 0.92`, 1.`], Boxed -> False]}, {Show[{pltl, pltint, pltg}, ViewProjection -> "Orthographic", ViewPoint -> Top, ImageSize -> sz, Background -> RGBColor[0.84`, 0.92`, 1.`], Boxed -> False], Show[{pltl, pltint, pltg}, ViewProjection -> "Perspective", ViewPoint -> {Above, Left, Back}, ImageSize -> sz, Background -> RGBColor[0.84`, 0.92`, 1.`], Boxed -> False]}}, Dividers -> Center]; (*Reset Plot Options to Default*) SetOptions[Plot3D, PlotStyle -> Automatic]; pltarr = Grid[{{Text[Style[title, Blue, Italic, 24]]}, {Style[ StringForm[ "\!\(\*SubscriptBox[\(K\), \(C\)]\)=``, \[Delta]=``, \ \!\(\*SubscriptBox[\(Pe\), \(L\)]\)=``, and \ \!\(\*SubscriptBox[\(Pe\), \(G\)]\)=``", NumberForm[kequil, {3, 2}, NumberPadding -> {" ", "0"}], NumberForm[d, {5, 4}, NumberPadding -> {" ", "0"}], NumberForm[pel, {2, 1}, NumberPadding -> {" ", "0"}], NumberForm[peg, {2, 1}, NumberPadding -> {" ", "0"}]], 18]}, {Show[{pltl, pltint, pltg, Graphics3D[{arrequil, arrdiff, arrliq, arrgas}](*,arrequil, arrdiff,arrliq,arrgas*)}, ViewProjection -> "Perspective", ViewPoint -> {Above, Left, Back}, ImageSize -> 640, Background -> RGBColor[0.84`, 0.92`, 1.`], Boxed -> False, PlotRange -> {{md[left] - 0.05, md[right]}, {md[bot], md[top] + 0.05}, {0, 1 + 0.1}}]}}]; (*Return values*){ifun, {pltl, pltint, pltg}, pltarr, grid}]; Options[modelfn] = {md -> mDic, k -> 0.5, dratio -> 1, pel -> 50, peg -> 50, title -> "Test"}; modelfn[OptionsPattern[]] := model[OptionValue[md], OptionValue[k], OptionValue[dratio], OptionValue[pel], OptionValue[peg], OptionValue[title]] ## Testing of Meshing and Solving Modules Now, that we wrapped our meshing and solving work flow into modules, I will demonstrate how to create an instance of a simulation. (* Create a Co-Flow Mesh *) mDic = meshfn[config -> "Co"]; (* Simulate and return results *) res = modelfn[md -> mDic, k -> 0.5, dratio -> 0.1, pel -> 10, peg -> 5, title -> "Co-Flow"]; To visualize a 3D plot with arrows representing the magnitude of dimensionless parameters, we access the third part of the results list. res[[3]] ![enter image description here][16] The solid lines, dashed lines, and dashed-dotted lines represent contours of species concentration in the liquid, gas, and interphase regions, respectively. The $\color{Red}{Red}$ arrow is proportional to (1-K), the $\color{Green}{Green}$ arrow is proportional to the log of the diffusion ratio $\delta$, the $\color{Blue}{Blue}$ arrow is proportional to $Pe_L$, and the $\color{Black}{Black}$ arrow is proportional to $Pe_G$. Multiple views are contained in part 4 of the results list. res[[4]] ![enter image description here][17] ## Validation (Comparison to another code) Before continuing, it is always good practice to validate your model versus experiment or at least another code. The other code supports a partition conditions for the concentration jump so that I do not need to create an interface layer. The results are shown below: ![enter image description here][18] The contour plots look very similar to the image in the lower left corner of the grid plot. To be more quantitative, I have highlighted contours at approximately y=-0.15 and y=0.05 in the gas and liquid layers at x=1 corresponding to concentrations of 0.68 and 0.28, respectively. The first part of the results list returns an interpolation function of the liquid and gas species. We can see that we are within a percent of the other code, which is reasonable given that the interface layer is about 1% of the domain. This check gives me good confidence that my model is not too wrong and that I can start to make it useful (i.e., exercising the model by changing parameters). res[[1]][[2]][1, -0.15] (*0.6769985984321076`*) res[[1]][[1]][1, 0.05] (* 0.27374616012596314`*) # Generating Animations I like to animate. For me, animations are the best way to demonstrate how a system evolves as a function of time or parameter changes. We can export an animated gif file to study the effects of dimensionless parameter changes for both flow configurations as shown in the following code. It will take about 30 minutes per animation and about 5 GB of RAM. Undoubtedly, this code could be optimized for speed and memory usage, but you still can create a dozen animations while you sleep. SetDirectory[NotebookDirectory[]]; f = ((#1 - #2)/(#3 - #2)) &; (* Scale for progress bar *) mDic = meshfn[config -> "Counter"]; (* Create Mesh Instance *) Export["CounterFlow.gif", Monitor[ Table[ modelfn[md -> mDic, k -> kc, dratio -> 1, pel -> 0, peg -> 0, title -> "Counter-Flow"][[3]], {kc, 1, 0.01, -0.01} ], Grid[ {{"Total progress:", ProgressIndicator[ Dynamic[f[kc, 1, 0.01, -0.01]]]}, {"\!\(\*SubscriptBox[\(K\), \(C\)]\)=", \ {Dynamic@kc}}}] ], "AnimationRepetitions" -> \[Infinity]] # Examples I combined the co- (left) and counter-current (right) gif animations for several cases below. Péclet numbers approaching 100 start to look uninteresting visually (all the action is very close to the interface). This should inform the user that perhaps another model is in order with new assumptions to study the small-scale behavior near the interface. ## Changing the Equilibrium Constant @ No Flow ![enter image description here][19] As the equilibrium constant, $K$, reduces, the jump condition increases. ## Changing the Diffusion Ratio $\delta$ @ No Flow ![enter image description here][20] As the liquid-gas diffusion ratio, $\delta$, decreases, the concentration in the gas layer increases. We also see that the solution does not change much for $\delta<0.01$. ## Changing $Pe_L$ @ No Gas Flow ![enter image description here][21] As $Pe_L$ increases, the concentration gradient increases at the interface. ## Changing $Pe_G$ @ No Liquid Flow ![enter image description here][22] As $Pe_G$ increases, we see the concentration in the liquid layer decrease for co-flow and increase for counter-current flow. This should make sense since the inlet concentration for co-flow is 0 and 1 for counter-current flow. ## Changing the Diffusion Ratio $\delta$ @ Middle Conditions ![enter image description here][23] Again, we do not see much change for $\delta<0.01$. One may have noticed that the concentration in the liquid layer goes up as the diffusion coefficient ratio goes down, which may, at first, seem counterintuitive. The reason for this behavior is that the dimensionless velocity in the liquid layer depends on both $Pe_L$ and $\delta$ so it decreases with decreasing $\delta$. # Summary - Constructed an FEM model in the Wolfram Language to study concentration jump conditions in interphase mass transfer. - Results compare favorably to another code designed to handle jump conditions. - Showed several examples of the effect of dimensionless parameter changes on two model flow configurations. - Notebook provided. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=varyKlv0gv0.gif&userId=1402928 [2]: http://appliedchem.unideb.hu/Muvtan/Transport%20Processes%20and%20Unit%20Operations,%20Third%20Edition.pdf [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ConcJumps.png&userId=1402928 [4]: https://reference.wolfram.com/language/ref/DSolve.html [5]: https://ac.els-cdn.com/S0307904X07000601/1-s2.0-S0307904X07000601-main.pdf?_tid=adb2e542-50f1-44ce-ad9f-54ffaaa83bcb&acdnat=1539987146_3e6ce710d8016d91587f466be8e4ada7 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AbsorptionModel.png&userId=1402928 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=PMSystemDescription.png&userId=1402928 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AbsorptionSystem.png&userId=1402928 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Dimensions.png&userId=1402928 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AbsorptionSystem2.png&userId=1402928 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CoCurrentBoundaryMesh.png&userId=1402928 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CounterCurrentBoundaryMesh.png&userId=1402928 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CornerRefinement.png&userId=1402928 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Interface.png&userId=1402928 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CoordIDs.png&userId=1402928 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=testresult3.png&userId=1402928 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=TestGrid.png&userId=1402928 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=comsolresults.png&userId=1402928 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cmb_varyKld1v0gv0.gif&userId=1402928 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cmb_varydelta.gif&userId=1402928 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cmb_varyliqvelocity.gif&userId=1402928 [22]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cmb_varygasvelocity.gif&userId=1402928 [23]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cmb_varydeltalv5gv5.gif&userId=1402928 Tim Laska 2018-11-15T19:31:17Z https://community.wolfram.com/groups/-/m/t/1190717 I have just released a package entitled ["MoleculeViewer"][1], whose functionality is exactly what it says on the tin. This package was inspired in part by previous efforts by [@BoB LeSuer][at0] and [@Bianca Eifert][at1]. I took the best parts of [their][2] [packages][3], along with some of the good parts of the built-in molecule renderer, and added a few of my own tweaks. One noticeable tweak would be the depiction of multiple bonds (just like what is done in some physical models), as in the following image: MoleculeViewer["thiacloprid"] ![thiacloprid][4] The package has a number of other nifty features and auxiliary functions, like highlighting: MoleculeViewer["caffeine", Highlighted -> {"O", "N" -> Orange}] ![caffeine][5] and legends: MoleculeViewer[RunOpenBabel[GetChemSpider["calicheamicin", "InChI"]], PlotLegends -> True] ![calicheamicin][6] Before using the package, you will need to install [Open Babel][7] for some of its conversion functionality. Additionally, to use the [ChemSpider][8] search functionality, you will need to [register][9] to obtain an API key. Download the paclet from GitHub and [install in the usual manner][10]. Alternatively, using the technique featured [here][11], evaluate PacletInstall["MoleculeViewer", "Site" -> "http://raw.githubusercontent.com/tpfto/MoleculeViewer/master"] Documentation and a gallery are given as separate notebooks. [at0]: http://community.wolfram.com/web/bobthechemist [at1]: http://community.wolfram.com/web/biancaeifert [1]: https://github.com/tpfto/MoleculeViewer/releases [2]: https://github.com/biancaeifert/multi-bond-plot [3]: https://github.com/bobthechemist/molviewer [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=zotu8.png&userId=520181 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=eTaCP.png&userId=520181 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=nlZ63.png&userId=520181 [7]: http://openbabel.org/ [8]: http://www.chemspider.com/ [9]: http://www.chemspider.com/Register.aspx [10]: https://mathematica.stackexchange.com/a/141888 [11]: https://mathematica.stackexchange.com/questions/155123 J. M. 2017-09-23T15:31:37Z https://community.wolfram.com/groups/-/m/t/2546972 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/9f15876a-0afc-428f-809c-2859aec6189e Samikshaa Natarajan 2022-06-08T21:48:48Z https://community.wolfram.com/groups/-/m/t/2927764 ![Introducing the Wolfram ProteinVisualization paclet!][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Main2.bmp&userId=20103 [2]: https://www.wolframcloud.com/obj/353c8f22-23af-4a49-b43c-b0b0f1645249 Soutick Saha 2023-05-31T14:38:54Z https://community.wolfram.com/groups/-/m/t/1799757 # Introduction: *One problem in chemistry is finding all possible molecules, as there are rotations and reflections. All the possibilities of existence of halomethanes (even unstable ones) are addressed here. This is a question similar to the sequence: Doubly triangular numbers (A002817–OEIS, N. J. A. Sloane, Apr 18, 2017):* *“Number of inequivalent ways to color vertices of a square using <= n colors, allowing rotations and reflections* ...” , a(n)=n*(n+1)*(n^ 2+n+2)/8. *However as described in the sequence A002817–OEIS, only the total result of the possibilities is addressed, while here in this post I visually demonstrate all possibilities, both in list, 2D and 3D graphs and mass list.* # Function Code: With this function below it is possible to find and visualize **all possibilities of halomethanes**, taking into account all rotations and reflections of the molecules. I developed this function with some options (“Mode”) besides the list of terms. Examples of options: "Color", "Visual", "Visual3D", "Mass". Here the function demonstration is done with all halogens (except radioactive halogens, by choice), but any of the possible elements can be used as an argument in the function. Example: {"H"}, {"F", "Br", "I"}, {...} ... {"H", "F", "Cl", "Br", "I" }. Halomethanes[elem_, OptionsPattern[]] := Module[{eleu, z, cc, a, a1, f, rP, ap, n, b}, z = Length@elem; Options[Halomethanes] = {"Mode" -> "Table"}; eleu = elem[[1]]; a = Tuples[elem, 4] /. {"Cl" -> "D", "Br" -> "B"}; n[x_] := {x}; cc = {"C" -> GrayLevel[0.5], "F" -> RGBColor[1, 0.5, 0.5], "Cl" -> RGBColor[0, 0.56, 0], "Br" -> RGBColor[0.6, 0.4, 0.2], "I" -> RGBColor[1, 0, 0], "H" -> RGBColor[0, 1, 1]}; a1 = a[[1]]; f[a_] := Module[{bt, ct, dt, e1, e2, ft, gt, r1}, bt = Table[StringJoin[a[[b]]], {b, 1, Length@a}]; ct = Table[StringJoin@Table[a[[c]], 2], {c, 1, Length@a}]; dt = Table[ StringJoin[a[[d]][[4]], a[[d]][[3]], a[[d]][[2]], a[[d]][[1]]], {d, 1, Length@a}]; e1 = Table[ StringCases[ct[[i]], RegularExpression[bt[[1]]]], {i, 1, Length@ct}]; e2 = Table[ StringCases[ct[[i]], RegularExpression[dt[[1]]]], {i, 1, Length@ct}]; ft = Table[{Length@(e1[[j]]), Length@(e2[[j]])} /. {{2, 2} -> bt[[j]], {2, 0} -> bt[[j]], {0, 2} -> {"copy"}, {0, 0} -> bt[[j]], {2, 1} -> bt[[j]], {1, 2} -> {"copy"}, {1, 0} -> {"copy"}, {0, 1} -> {"copy"}, {1, 1} -> {"copy"}}, {j, 1, Length@ct}]; gt = Table[ StringPartition[DeleteCases[ft, {"copy"}][[o]], 1], {o, 1, Length@DeleteCases[ft, {"copy"}]}]; r1 = If[gt != {}, If[gt[[1]] == a[[1]], gt[[1]], {}], {}]; {rP = DeleteCases[r1, {}], ap = If[r1 != {}, DeleteCases[gt, r1], gt]}]; Do[b = AppendTo[n[a1], {a = f[a][[2]], f[a][[1]]}[[2]]], z*(z + 1)*(z^2 + z + 2)/8 - 1]; OptionValue[ "Mode"] /. {"Table" -> If[z == 1, {{eleu, eleu, eleu, eleu}}, b /. {"D" -> "Cl", "B" -> "Br"}], "Color" -> {TableForm[{{"H", Text[Style["Cyan", RGBColor[0, 1, 1], Medium]]}, {"F", Text[Style["Pink", RGBColor[1, 0.5, 0.5], Medium]]}, {"Cl", Text[Style["Green", RGBColor[0, 0.56, 0], Medium]]}, {"Br", Text[Style["Brown", RGBColor[0.6, 0.4, 0.2], Medium]]}, {"I", Text[Style["Red", RGBColor[1, 0, 0], Medium]]}}, TableHeadings -> {None, {"Atom", "Color"}}], If[z == 1, {Flatten@Table[elem, 4]}, b /. {"D" -> "Cl", "B" -> "Br"}] /. cc}, "Visual" -> If[z == 1, MoleculePlot[ Molecule[{"C", eleu, eleu, eleu, eleu}, {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 100], Table[MoleculePlot[ Molecule[ Join[{"C"}, (b /. {"D" -> "Cl", "B" -> "Br"})[[ h]]], {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 100], {h, 1, Length@b}]], "Visual3D" -> If[z == 1, MoleculePlot3D[ Molecule[{"C", eleu, eleu, eleu, eleu}, {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 100], Table[MoleculePlot3D[ Molecule[ Join[{"C"}, (b /. {"D" -> "Cl", "B" -> "Br"})[[ h]]], {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], ColorRules -> cc, ImageSize -> 80], {h, 1, Length@b}]], "Mass" -> If[z == 1, MoleculeValue[ Molecule[{"C", eleu, eleu, eleu, eleu}, {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], "MolecularMass"], Table[MoleculeValue[ Molecule[ Join[{"C"}, (b /. {"D" -> "Cl", "B" -> "Br"})[[ h]]], {Bond[{1, 2}], Bond[{1, 3}], Bond[{1, 4}], Bond[{1, 5}]}], "MolecularMass"], {h, 1, Length@b}]]}] # Visualization: - **TERMS TABLE**: In the simplest form, with only one argument, a list of all halomethane molecules is generated. rp = Halomethanes[{"H", "F", "Cl", "Br", "I"}] Length@rp ![im1][1] - **COLOR TABLE**: Optionally, a list of molecules with their respective illustrative colors is generated with the "Mode" -> "Color" option. Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Color"] ![im2][2] - **2D VISUAL TABLE**: Optionally, a list of molecules with 2D structural representations is generated with the "Mode" -> "Visual" option (the 2D model can better represent stereoisomerism than the 3D model). Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Visual"] ![im3][3] - **3D VISUAL TABLE** (interactive): Optionally, a list of molecules with 3D structural representations is generated with the "Mode" -> "Visual3D" option. This list is interactive, and each molecule can be rotated for better viewing (stereoisomerism is not very well represented in these 3D models as the representations are tetrahedral, for example, the isomers {"H","F","H","F"} and {"F","F","H”,”H”} are very similar in this view). Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Visual3D"] ![im4][4] - **MASS TABLE**: Finally, a list of the masses of all halomethanes can be generated with the argument "Mode" -> "Mass" (some of them, although unstable, are mentioned in the list). resp2 = Halomethanes[{"H", "F", "Cl", "Br", "I"}, "Mode" -> "Mass"] ![im5][5] Illustrative graph of the mass distributions of all possible halomethanes: ListPlot[resp2, AxesLabel -> {"n", "Mass(u)"}, LabelStyle -> Directive["Subsubsection", RGBColor[0.07, 0.5, 0.5]], PlotLabel -> "Halomethanes Mass", PlotRange -> {{0, 130}, {0, 550}}, PlotStyle -> Directive[RGBColor[0.91, 0.08, 0.5], PointSize[Large]], ImageSize -> Large] ![im6][6] **Link**: (Doubly triangular numbers, A002817–OEIS, sequence): https://oeis.org/A002817 Thanks. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=table1.png&userId=1316061 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=tableColor.png&userId=1316061 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graphtest.png&userId=1316061 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=visual3D.png&userId=1316061 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=tablemass.png&userId=1316061 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graph.png&userId=1316061 Claudio Chaib 2019-10-03T03:01:17Z https://community.wolfram.com/groups/-/m/t/2305648 ![enter image description here][1] Hello All, (I have set Independence Day (Observed) as my pencils-down moment to publicize a Wolfram Language/Mathematica package for performing computations and visualizing results from Quantum Theory of Atoms In Molecules (QTAIM) calculations on electronic structure theory wave functions. QTAIM endeavors the answer the question, "Are there discernable atoms inside of molecules?" The answer according to Bader and co-workers is yes, if you define an atom as the basin/union of all steepest ascent paths and a nucleus, which is the attractor. Since there is zero-flux between these regions, they are proper quantum subsystems, just like the molecule/crystal is. Here is the water molecule (H2O) in this representation: ![Atomic Basins][2] What motivated me to get going on creating a package was the new SliceVectorPlot3D routines, which make plotting these quantities a dream: ![Gradient Field on Planes of Symmetr][3] The code is hosted here: https://github.com/ecbrown/QTAIM.wl which has this code and more extensive discussion. Wolfram Language/Mathematica is great for this. Great algorithms like ABM differential equation solver, and excellent graphics for 2D/3D fields. I t features several ways to get data in, so it can be file-based or scripted from PySCF. Well, I should keep it brief, and I look forward to any comments you have. Best regards, Eric An overview of the methods and results can be found here: &[Wolfram Notebook][4] [DON'T DELETE: Original notebook]: https://www.wolframcloud.com/obj/c70b8f04-b2fd-45f1-9077-f9827fe82357 [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=QTAIM_hero.jpg&userId=20103 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7578atoms-are-defined-as-the-union-of-gradient-paths-and-attractor.png&userId=62741 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=stream-plot-3d-of-electron-density-gradient-of-water.png&userId=62741 [4]: https://www.wolframcloud.com/obj/71988d27-d090-4df4-84b6-ec3fd7564308 Eric Brown 2021-07-05T17:39:53Z https://community.wolfram.com/groups/-/m/t/3191339 ![Write it with proteins: protein structures that mimic letters of English alphabet][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7376Hero2.png&userId=20103 [2]: https://www.wolframcloud.com/obj/b42d5bf9-0757-49b0-bea6-3c2267ede4a1 Soutick Saha 2024-06-11T18:58:33Z https://community.wolfram.com/groups/-/m/t/981261 *SUPPLEMENTARY WOLFRAM MATERIALS for ARTICLE:* > Mias, G., Yusufaly, T., Roushangar, R. et al. > *MathIOmica: An Integrative Platform for Dynamic Omics*. Sci Rep 6, 37237 (2016). > NATURE Scientific Reports > https://doi.org/10.1038/srep37237 ---------- #Introduction: MathIOmica My [lab][2] has recently released a new package for *Mathematica*, focusing on bioinformatics: **MathIOmica** ([mathiomica.org][3], download at [GitHub][4]). The package is released under an MIT License and is available to use for free (requires *Mathematica* 10.4+). ##Background There has been ongoing effort on the analysis of multiple *omics* data from disparate biological sources. Multimodal data from various sources in now available, particularly with new enabling technologies under constant development (e.g. sequencing capabilities with next generation sequencing and the focus on [transcriptomics][5], i.e. the set of all transcripts (RNA) in a cell, or mass spectrometry use for [proteomics][6], i.e. the set of all proteins in a cell). The recently announced [Precision Medicine Initiative][7] will lead to more being produced in the next few years. This has led to the development of multiple bioinformatics tools and platforms, particularly for [R][8] and [Python][9], such as [Bioconductor][10] and [Biopython][11] aiming to integrate information from various omics, including in the context of personalized medicine [(Mias and Snyder, 2014)][12]. However, sophisticated mathematical methods to study the dynamics of omics data are still underdeveloped, particularly methods that address missing data and uneven sampling over time, as well as time-series classifications. ##Implementation Coming from a physics background and transitioning to genetics, I decided I wanted to develop a bioinformatics package for *Mathematica* written in the *Wolfram Language*. The *MathIOmica* package particularly focuses on the integration of multiple omics information from dynamic profiling in a personalized medicine profiling approach. Additionally, it provides essential functions to facilitate general bioinformatics analysis in *Mathematica*. This includes data importing and preprocessing, including normalizations, and clustering and visualization of the classification of dynamic data. *MathIOmica* includes annotations from [Gene Ontology][13], as well as [KEGG][14] pathway analyses. *MathIOmica* was built using *Wolfram Workbench* and includes inbuilt documentation accessible within Mathematica after installation. This first release is a first step, in which we wanted to develop a base for bioinformatics tools in the *Wolfram Language* and we are now working on more advanced functionality. The main functionality is summarized below (Figure from [Mias et. al, 2016][15]). ![Main MathIOmica Functionality][16] ##Example Using Transcriptome Data *MathIOmica* is meant to be used for biological data. Typically such data contains measurements, but also metadata. Additionally, multiple samples may be available. To parse such data we decided to create an `OmicsObject`, essentially an association of associations (Figure From from [Mias et. al, 2016][17]): ![OmicsObject][18] Multiple utilities exist within the package to create and handle OmicsObjects, and many examples. Here let us take a close look at an example using transcriptomics data from a pilot first integrative Personal Omics Profiling ([iPOP][19]) project as an implementation of using MathIOmica to look at dynamics of biological data. This study was meant as a prototype to observe the personal omics dynamics from a single person, including proteomics transcriptomics and metabolomics profiled from blood. Different samples (from 7 to 21 included here) were obtained at different time points. The time points included here correspond to days ranging from 186th to the 400th day of the study, (this can be represented in the following sample to day association: `<|7->186,8->255,9->289,10->290,11->292,12->294,13->297,14->301, 15->307,16->311,17->322,18->329,19->369,20->380,21->400|>`. On day 289 the subject of the study had a respiratory syncytial virus infection. Additionally, after day 301, the subject displayed high glucose levels and was eventually diagnosed with type 2 diabetes. All these data are included as part of *MathIOmica*'s examples. We first load the package (assuming it has been installed): <<`MathIOmica` Then we can load the OmicsObject associated with the transcriptome data: rnaExample = Get[FileNameJoin[{ConstantMathIOmicaExamplesDirectory, "rnaExample"}]] ![rnaExample][20] The outer keys correspond to the sample enumeration for a given day. We can convert these to actual days of the study and use `KeyMap` to change the outer labels: sampleToDays = <|"7" -> "186", "8" -> "255", "9" -> "289", "10" -> "290", "11" -> "292", "12" -> "294", "13" -> "297", "14" -> "301", "15" -> "307", "16" -> "311", "17" -> "322", "18" -> "329", "19" -> "369", "20" -> "380", "21" -> "400"|>; rnaLongitudinal = KeyMap[sampleToDays, rnaExample] Next, we can normalize our dataset. The inner measurements to be normalized are actual FPKM values ( fragments per kilobase of transcript per million mapped reads). A typical normalization used for RNA-Sequencing (RNA-Seq) FPKMs from transcriptomes across multiple samples is [quantile normalization][21]. rnaQuantileNormed = QuantileNormalization[rnaLongitudinal] We additionally do some basic quality control as an example. First we set all FPKMs that are 0 to Missing, i.e. 0 means nothing was detected so that gene fragment is actually Missing. rnaZeroTagged = LowValueTag[rnaQuantileNormed, 0] We then want to account for noisy measurements. If we assume all values less than unity are essentially noise and indistinguishable, we set them all to unity: rnaNoiseAdjusted = LowValueTag[rnaZeroTagged, 1, ValueReplacement -> 1] We then filter out data where the reference healthy point we want to compare against, which is day "255", is missing, and retain data with at least 3/4 of the points available : rnaFiltered = FilterMissing[rnaNoiseAdjusted, 3/4, Reference -> "255"] The following charts are generated that show the remaining points in the data, including the statistics for Missing tags: ![MissingPerComponent][22] ![MissingPieChart][23] We extract the times for the filtered RNA data using: timesRNA = TimeExtractor[rnaFiltered] The result is `timesRNA={186, 255, 289, 290, 292, 294, 297, 301, 307, 311, 322, 329, 369, 380, 400}`, a list of the days on which samples were taken in the study. For each gene we can now extract a time series (list of values) corresponding to these times: timeSeriesRNA = CreateTimeSeries[rnaFiltered] ![TimeSeries][24] We would next like to identify temporal trends in the data. To do this we first want to create a resampled distribution for the transcriptome dataset prior to classification and clustering to be able to compare against random time series from the same type of data. We repeat the steps in the processing as described above using a resampled set of measurements. For brevity all steps (9) are listed together: (*Bootstrap of 100000 time series*) rnaBootstrap = BootstrapGeneral[rnaLongitudinal, 100000]; (*1: quantile normalization*)rnaBootstrapQuantileNormed = QuantileNormalization[rnaBootstrap]; (*2: tag zero values*)rnaBootstrapZeroTagged = LowValueTag[rnaBootstrapQuantileNormed, 0]; (*3: tag noise*) rnaBootstrapNoiseAdjusted = LowValueTag[rnaBootstrapZeroTagged, 1, ValueReplacement -> 1]; (*4: filter missing*) rnaBootstrapFiltered = FilterMissing[rnaBootstrapNoiseAdjusted, 3/4, Reference -> "255", ShowPlots -> False]; (*5: create time series*) timeSeriesBootstrapRNA = CreateTimeSeries[rnaBootstrapFiltered]; (*6: take log*) timeSeriesBootstrapRNALog = SeriesApplier[Log, timeSeriesBootstrapRNA]; (*7: compare to reference healthy point*)rnaBootstrapCompared = SeriesInternalCompare[timeSeriesBootstrapRNALog, ComparisonIndex -> 2]; (*8: normalize series*)normedBootstrapRNACompared = SeriesApplier[Normalize, rnaBootstrapCompared]; (*9: remove constant series*)rnaBootstrapFinalTimeSeries = ConstantSeriesClean[normedBootstrapRNACompared]; Now we have the random distribution we can proceed with classification. We want to classify the temporal behavior of genes to identify common trends. This is done by the provided `TimeSeriesClassification` function. The function uses a few methods to help classify time series with uneven time sampling, and in this example we will use an approach that computes internally a [Lomb-Scargle][25] periodogram. Classification is then based on periodograms, and the data is classified into classes of major (highest intensity) frequencies and spikes (maxima or minima in real signal intensity), depending on cutoffs typically provided by simulation. Specifically, for a given signal $X_ j$, with length $N$, we have $N$ time measurements, namely $X_j=\left\{X_j\left(t_1\right),X_j\left(t_2\right),\text{...},X_j\left(t_N\right)\right\}$and can calculate the signal's periodogram (Lomb-Scargle method). The `TimeSeriesClassification` function uses the `n=Floor[N/2]` frequencies, $f_j=\left\{ f_{\text{j1}},f_{\text{j2}},\text{...},f_{\text{jk}},\text{...},f_{\text{jn}} \right\}$ and obtains corresponding `n` intensities, $I_j=\left\{I_{\text{j1}},I_{\text{j2}},\text{...},I_{\text{jn}}\right\}$. The default functionality is for $I_j$ to be calculated as a normalized vector. The maximum intensity of this vector, $I_{jk_{\text max}}=\text{Max}\left[I_j\right]$ corresponds to a dominant frequency $f_{jk_{\text max}}$, and occurs at some index $k_{\text max}$. For each signal $X_j$ we can then compare $I_{jk_{\text max}}$ to a cutoff intensity $I_{\text cutoff}$ to see if $I_{jk_{\text max}} > I_{\text cutoff}$. If so, the signal is placed in class $f_{k_{\text max}}$. A maximum of `n` classes is thus possible, and possible classes are labeled as $\left\{f_1,f_2,\text{...},f_k,\text{...},f_n\right\}$. The exact frequency list will depend on `n`, and hence the length of the input set times `N`, and is determined automatically by the classification functions. Signals that do not show a maximum intensity in frequency space above the cutoff intensity,i.e. signals $j$ for which $I_{ j k} \le I_{\text cutoff}$ for all $k$, are checked for sudden signal spikes at any time point,and if so classified as spike maxima or minima. For each signal not showing a maximum periodogram intensity, $\tilde{X_j}$, we can calculate the real signal maximum, $\text{max}_j=\text{Max}\left[\tilde{X_j}\right]$,and minimum $\text{min}_ j=\text{Min}\left[\tilde{X_j}\right]$, from signal intensities across all time points. We can compare these values against cutoffs $\left\{\text{Minimum Spike Cutoff}_n, \text{Maximum Spike Cutoff}_n\right\}$provided by the user: These cutoffs are dependent on the length of a time series, $n$, and typically would correspond to the 95th quantile of distributions of maxima and minima of randomly generated signals.These cutoff values are provided by the `SpikeCutoffs` option value for each length $n$ involved in the computation as part of an association for different lengths: $<|\ ..., n\rightarrow \{\text {Minimum Spike Cutoff}_n,\text{Maximum Spike Cutoff}_n\},\ ...,\\ \text{length } i\rightarrow \{\text{Minimum Spike Cutoff}_i,\text{Maximum Spike Cutoff}_ i\},...|>$. If a signal of length $n$, $\tilde{X_j}$, has $\text{max}_j > \text{Maximum Spike Cutoff}_n$, it is classified in the "SpikeMax" class, or otherwise if a signal $\tilde{X_j}$ has $\text{min}_ j < \text{Minimum Spike Cutoff}_n$, it is classified in the "SpikeMin" class. Signals for which the maximum signal intensity is not above the cutoffs are not reported. The default output for this "Lomb-Scargle" method by the `TimeSeriesClassification` function is an `Association` with outer keys being the classification classes $C$,where $C\in \left\{f_1,f_2,\text{...},f_k,\text{...},f_n,\ \text{SpikeMax},\text{ SpikeMin}\right\} $, inner keys being the class members,Subscript[signalsX, j],and each class member value being a list of $\{\{\text{periodogram intensity list for signal }X_j\}, \{\text{input data list for }X_j\}\}$. Before we classify our transcriptome data, we estimate for the "LombScargle" Method a 0.95 quantile cutoff from the bootstrap transcriptome data: q95RNA = QuantileEstimator[rnaBootstrapFinalTimeSeries, timesRNA] (*~0.85766 - this will vary depending on the simulation realization*) Next, we estimate the "Spikes" 0.95 quantile cutoff from the bootstrap transcriptome data : q95RNASpikes = QuantileEstimator[rnaBootstrapFinalTimeSeries, timesRNA, Method -> "Spikes"] (*<|12 -> {0.817567, -0.441325}, 13 -> {0.803445, -0.423142}, 14 -> {0.782053, -0.409893}, 15 -> {0.762132, -0.374392}|> This will also vary depending on the simulation realization*) Now we can classify the transcriptome time series data based on these cutoffs: rnaClassification = TimeSeriesClassification[rnaFinalTimeSeries,timesRNA,LombScargleCutoff -> q95RNA,SpikeCutoffs -> q95RNASpikes] ![Classification][26] We can get the number of members in each category: Query[All, Length]@rnaClassification (*<|"SpikeMax" -> 598, "SpikeMin" -> 8672, "f1" -> 62, "f2" -> 3, "f3" -> 14, "f4" -> 42, "f5" -> 14, "f6" -> 10, "f7" -> 57|>, This will depend on the precise cutoffs used.*) Also we can see what the frequencies are by simply running the LombScargle function over the desired times for one of the time series and set the FrequenciesOnly option: LombScargle[rnaFinalTimeSeries[[1]], timesRNA, FrequenciesOnly -> True] (*<|"f1" -> 0.00500668, "f2" -> 0.0104306, "f3" -> 0.0158545, "f4" -> 0.0212784, "f5" -> 0.0267023, "f6" -> 0.0321262, "f7" -> 0.0375501|>*) We now cluster our RNA data. A two-tier hierarchical clustering of the data is performed, using a set of two classification vectors, $\{\{\text{classification vector}_1\},\{\text{classification vector}_2\}\}$ for each time series to cluster the data pairwise. The vectors are typically the output from `TimeSeriesClassification`. Similarities at each clustering tier are then computed using in succession from each time series first $\{\text{classification vector}_1\}$, and subsequently $\{\text{classification vector}_2\}$ (which corresponds to the $\{\text{input data time series}\}$. The main idea is that signals can have similarity based on the periodogram - which will not be able to detect phase differences, and subsequent clustering based on real values which should detect phase differences. The result is grouping of the data based on similarity, denoted as G#S#, where G denotes the group based on the first clustering, and S denotes the corresponding subgroup for that group. For example G2S3 denotes the 3rd subgroup of group 2. rnaClusters = TimeSeriesClusters[rnaClassification, PrintDendrograms -> True] ![enter image description here][27] For each class we can generate a dendrogram/heatmap plot, with groupings represented on the left, and highlighted to represent the grouping level. The G, S, columns represent the groupings and subgroupings generated by the clustering. The legend shows the corresponding groupings and subgrouping, and the number of elements in each group subgroup. TimeSeriesDendrogramsHeatmaps[rnaClusters] ![DendrogramsHeamaps][28] ##Annotation Enumeration We can carry out Gene Ontology analysis using for all the classes and groups/subgroups. We only report terms for which there are at least 3 members (N.B. this may be a bit time consuming because of the number of tests running ~ few minutes). The output has enrichments for each class and group goAnalysisRNA = GOAnalysis[rnaClusters, OntologyLengthFilter -> 3, ReportFilter -> 3 ] Query[All, Keys]@goAnalysisRNA (*<|"SpikeMax" -> {"G1S1", "G1S2", "G1S3", "G1S4", "G1S5", "G1S6", "G1S7", "G1S8", "G1S9", "G1S10", "G1S11", "G1S12", "G1S13", "G1S14"}, "SpikeMin" -> {"G1S1", "G2S1", "G2S2"}, "f1" -> {"G1S1", "G1S2", "G2S1", "G2S2"}, "f2" -> {"G1S1", "G2S1"}, "f3" -> {"G1S1", "G1S2", "G2S1"}, "f4" -> {"G1S1", "G1S2"}, "f5" -> {"G1S1", "G1S2", "G2S1"}, "f6" -> {"G1S1", "G1S2"}, "f7" -> {"G1S1", "G1S2"}|>*) We can view results for any of the groups (and also check out the behavior using the heatmaps generated in the previous section Query["SpikeMax", "G1S1"]@goAnalysisRNA ![GOAnalysis][29] We can export the reports to excel spreadsheets, e.g., EnrichmentReportExport[goAnalysisRNA, OutputDirectory -> $UserDocumentsDirectory, AppendString -> "GOAnalysisRNA"]; We can also carry out KEGG: Kyoto Encyclopedia of Genes and Genomes pathway analysis for all the classes and groups/subgroups. We only report terms for which there are at least 2 members. Please note again that this is a time consuming computation for a large set (few minutes). keggAnalysisRNA = KEGGAnalysis[rnaClusters, ReportFilter -> 2]; We can then view results for any of the groups (and also check out the behavior using the heatmaps generated in the previous section), e.g.: Query["SpikeMax", "G1S2"]@keggAnalysisRNA ![KEGGPathways][30] Let us look at the genes in our data belonging to one of these pathways: pathwaymembers = Query["SpikeMax", "G1S2", 2, 3, 2, All, 1]@keggAnalysisRNA (*{{"CCL2", "RNA"}, {"MMP14", "RNA"}, {"CXCL10", "RNA"}} *) We can obtain a link to the KEGG pathway of interest: KEGGPathwayVisual["path:hsa04668"] (*<|"Pathway" -> "path:hsa04668", "Results" -> {"http://www.kegg.jp/kegg-bin/show_pathway?map=hsa04668"}|>*) And we can highlight the genes in the results in the pathway if we want (open the link in a browser to visualize): KEGGPathwayVisual["path:hsa04668", MemberSet -> pathwaymembers] (*<|"Pathway" -> "path:hsa04668","Results" -> {"http://www.kegg.jp/kegg-bin/show_pathway?map=hsa04668&multi_query=hsa%3A6347+%2380b2ff%2C%23000000%0D%0Ahsa%3A4323+%2380b2ff%2C%23000000%0D%0Ahsa%3A3627+%2380b2ff%2C%23000000%0D%0A"}|>*) The figure can also be downloaded directly (not shown here due to copyright - please check if this is appropriate based on nature of your institution -academic vs. not with KEGG directly or read license distributed with MathIOmica): KEGGPathwayVisual["path:hsa04668", ResultsFormat -> "Figure", MemberSet -> pathwaymembers] [1]: http://www.nature.com/articles/srep37237 [2]: http://georgemias.org [3]: https://mathiomica.org [4]: https://github.com/gmiaslab/mathiomica [5]: https://en.wikipedia.org/wiki/Transcriptome [6]: https://en.wikipedia.org/wiki/Proteomics "Proteomics" [7]: https://www.nih.gov/research-training/allofus-research-program [8]: https://www.r-project.org [9]: https://www.python.org [10]: https://www.bioconductor.org [11]: http://biopython.org/wiki/Biopython [12]: http://dx.doi.org/10.1007/s40484-013-0005-3 [13]: http://www.geneontology.org [14]: http://www.genome.jp/kegg/pathway.html [15]: http://dx.doi.org/10.1038/srep37237 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Figure_1.jpg&userId=73070 [17]: http://dx.doi.org/10.1038/srep37237 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Figure_2.jpg&userId=73070 [19]: http://dx.doi.org/10.1016/j.cell.2012.02.009 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ExampleMathIOmica_OmicsObject.bmp&userId=73070 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-12at4.44.05PM.png&userId=73070 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-12at4.44.19PM.png&userId=73070 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-14at10.19.11AM.png&userId=73070 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-14at10.19.11AM.png&userId=73070 [25]: https://en.wikipedia.org/wiki/Least-squares_spectral_analysis [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-14at12.35.02PM.png&userId=73070 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ExampleMathIOmica.bmp&userId=73070 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6583ExampleMathIOmica2.bmp&userId=73070 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ExampleMathIOmica3.bmp&userId=73070 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ExampleMathIOmica4.bmp&userId=73070 George Mias 2016-12-15T04:57:24Z https://community.wolfram.com/groups/-/m/t/2115501 # Proposal: *Wolfram's mineral database is an interesting resource. In this work I will explore and account for the different chemical elements that are part of each mineral to perform an analysis as a whole. Here, the quantities of each element in each mineral will not be addressed, but only the different atomic elements in each mineral. Also, here in this work I exclude minerals that are formed by only 1 chemical element, that is, I consider only compound minerals. The analysis is done in two parts, the first part is an analysis without taking into account the water that may or may not be in the mineral, that is, the mineral completely dehydrated (only its composition that is linked by covalent bonds etc), the second part I analyze the minerals together with the water. In addition to having obtained a ranking of chemical elements in relation to all available minerals, in the end I get a percentage of how many minerals have oxygen and how many minerals have associated water in their composition.* # Database: Of course, Wolfram's minerals database does not have all the minerals that exist, but it has a very decent amount, where we can make a very representative analysis. First we take the list of minerals in the database and calculate the number of entities: minerals = EntityList[Entity["Mineral"]]; Length@minerals ![im1][1] Now we will associate each mineral with its chemical formula and, also obtain all the atomic symbols. This operation can take 2 to 3 hours to complete the download from Wolfram's servers: formulas = Map[#["Formula"] &, minerals]; symbols = Map[#["AtomicSymbol"] &, EntityList[EntityClass["Element", All]]]; To quickly make this information available for later use, we can save the data as an .mx file with the help of DumpSave: filepath = FileNameJoin[{NotebookDirectory[], "formulas.mx"}]; filepath2 = FileNameJoin[{NotebookDirectory[], "symbols.mx"}]; DumpSave[filepath, {formulas}]; DumpSave[filepath2, {symbols}]; Quit[] That way we can retrieve the data for fast use whenever we want, using Get: SetDirectory[NotebookDirectory[]]; Get["formulas.mx"] Get["symbols.mx"] The definition of “symbols” below: symbols ![im2][2] Below is a simple function to have each mineral associated with its chemical formula in an easy way to visualize: threadFormula[m_, n_] := Thread[minerals[[m ;; n]] -> formulas[[m ;; n]]] // Grid[Partition[#, 1], Frame -> All, Alignment -> Left] &; threadFormula[1000, 1010] ![im3][3] # Data Excluding Water: Unfortunately the mineral formulas in the database are in a very complicated format to manipulate, as part is in String, part in Superscript, etc ... so we need to modify and alter the data in an intelligent way to obtain the formulas in a more computable form, at the same time we exclude water associated with minerals that have it: a1 = {StringDelete[StringDelete[ToString[#], "{"], "}"]} & /@ Table[Flatten@Apply[List, i, All], {i, formulas}]; a2 = Table[ StringDelete[ a1[[x]], {"(, H, 2, O, )", "H, 2, O", " ScriptBaselineShifts" ~~ __}], {x, 1, Length@a1}]; a2[[;; 10]] ![im4][4] Now extracting the different chemical elements for each mineral and excluding the minerals formed by just one chemical element. Note that the number of minerals went from 3878 to 3778: a3 = Union[#] & /@ Flatten[StringCases[#, ReverseSortBy[symbols, Length]] & /@ a2, 1]; a4 = Table[If[Length@a3[[z]] > 1, a3[[z]], Nothing], {z, 1, Length@a3}] Length@a4 ![im5][5] Finally, we can count the composition of different atomic elements that are part of all the minerals in the database. We can see that there are 70 different elements in this list: a5 = Association[Reverse@SortBy[Normal@Counts@Flatten@a4, Last]] Length@a5 ![im6][6] We can set up a Dataset with the elements and their position (ranking) that are part of all minerals for better visualization: Transpose[ Partition[ Keys@# -> Quantity[Position[Normal@a5, #][[1, 1]], IndependentUnit["position"]] & /@ Normal@a5 , 10]] // Dataset ![im7][7] For the next parts of this work we have to define the two rules below: rule1 = Thread[Flatten[Position[symbols, #] & /@ symbols] -> symbols]; rule2 = Join[{0 -> "Water"}, rule1]; With some manipulation of the data, we can for example reorganize the elements in the order they are in the periodic table, that is, in the order of the atomic number, as well as other useful lists to create some graphs and analyzes: b1 = Table[{Sort[Thread[{Keys@a5, Values@a5}]][[x, 1]], {Sort[Thread[{Keys@a5, Values@a5}]][[x, 2]]}}, {x, 1, Length@a5}]; b2 = Table[ Entity["Element", b1[[x, 1]]]["AtomicNumber"], {x, 1, Length@b1}]; b3 = SortBy[Table[{b2[[x]], b1[[x, 2, 1]]}, {x, 1, Length@b2}], First]; b4 = Association@ Table[(b3[[x, 1]] /. rule1) -> b3[[x, 2]], {x, 1, Length@b3}]; b5 = Table[{b3[[x, 1]] /. rule1, b3[[x, 2]]}, {x, 1, Length@b3}]; b4 ![im8][8] The first plot we have is the different chemical elements that form all the minerals in decreasing order of quantity in which they appear in the whole: ListPlot[Tooltip /@ a5, ImageSize -> 1000, PlotRange -> All, Axes -> {None, Automatic}, GridLines -> {None, Automatic}] ![im9][9] The next plot is the different chemical elements that make up all the mineral samples, but in the order of atomic number. This visualization is interesting because it relates to the periodic table: ListLinePlot[ Callout[#[[2]], Style[{#}, 10, Red, Bold], CalloutStyle -> Red] & /@ b5, ImageSize -> 1000, PlotRange -> All, PlotMarkers -> {Automatic, Scaled[0.01]}, GridLines -> {Table[{x, Dashed}, {x, 1, 70}], None}, PlotStyle -> Thin] ![im10][10] We can view it also in the form of WordCloud: WordCloud[b5, ImageSize -> Large] ![im11][11] # Result of Oxygen: To conclude the initial analysis, we can see in how many percent of the minerals that there is oxygen attached to the molecular structure in relation to all minerals. We see that this value can reach up to 80%: "OxygenInTotal" -> Quantity[N[100*b4["O"]/Length@a4], "Percent"] ![im12][12] # Data with Water: With some differences in relation to the first part of this work, instead of excluding water, we can define a new water entity to be included in the formula of the minerals that contain it: a2W = Table[ StringReplace[ a1[[x]], {"(, H, 2, O, )" -> "Water", "H, 2, O" -> "Water", " ScriptBaselineShifts" ~~ __ -> ""}], {x, 1, Length@a1}]; a2W[[;; 10]] ![im13][13] With a similar code, with only a few differences, we do the same extraction of atomic symbols plus water in each mineral. Again, we exclude minerals formed by only 1 chemical element: a3W = Union[#] & /@ Flatten[StringCases[#, ReverseSortBy[Join[symbols, {"Water"}], Length]] & /@ a2W, 1]; a4W = Table[ If[Length@a3W[[z]] > 1, a3W[[z]], Nothing], {z, 1, Length@a3W}] Length@a4W ![im14][14] And, again with some manipulation of the data, we created lists and associations to have the result in quantities (including water). Some of these definitions will also be used below to have some plots: a5W = Association[Reverse@SortBy[Normal@Counts@Flatten@a4W, Last]]; a5W Length@a5W b1W = Table[{Sort[Thread[{Keys@a5W, Values@a5W}]][[x, 1]], {Sort[Thread[{Keys@a5W, Values@a5W}]][[x, 2]]}}, {x, 1, Length@a5W}]; b2W = Table[ Entity["Element", b1W[[x, 1]]]["AtomicNumber"], {x, 1, Length@b1W}] /. {Missing[ "UnknownEntity", {"Element", "Water"}] -> 0}; b3W = SortBy[Table[{b2W[[x]], b1W[[x, 2, 1]]}, {x, 1, Length@b2W}], First]; b4W = Association@ Table[(b3W[[x, 1]] /. rule2) -> b3W[[x, 2]], {x, 1, Length@b3W}]; b5W = Table[{b3W[[x, 1]] /. rule2, b3W[[x, 2]]}, {x, 1, Length@b3W}]; ![im15][15] The water being included together with the decreasing order of the amounts of different chemical elements that are part of all minerals: ListPlot[Tooltip /@ a5W, ImageSize -> 1000, PlotRange -> All, Axes -> {None, Automatic}, GridLines -> {None, Automatic}] ![im16][16] A plot similar to that of the first part of the work, in ascending order of atomic number, but including water and it appears before hydrogen (water defined as position 0) just for viewing: ListLinePlot[ Callout[#[[2]], Style[{#}, 10, Red, Bold], CalloutStyle -> Red] & /@ b5W, ImageSize -> 1000, PlotRange -> All, PlotMarkers -> {Automatic, Scaled[0.01]}, GridLines -> {Table[{x, Dashed}, {x, 1, 71}], None}, PlotStyle -> Thin] ![im17][17] Visualization using WordCloud including water: WordCloud[a5W, ImageSize -> Large] ![im18][18] # Result of Water: In the way below we calculate how many percent of minerals have water associated with its composition in relation to all available minerals. We can see that an expressive part of them have water (hydrated minerals), more than 1/3 of them: "WaterInTotal" -> Quantity[N[100*a5W["Water"]/Length@a4W], "Percent"] ![im19][19] # Conclusion and Notes: - A significant amount of minerals have some oxygen in the chemical composition: 80% of them. - A good part of minerals have water associated with its molecule: 35% of them. It is worth mentioning that there may be some flaws in the exclusion and inclusion of water in the calculations, as for example, some organic minerals and some others may be erroneously influenced by the rules stipulated in this work. But it is a minority of these minerals, so although there is some variation in these percentages the value is satisfactorily approximate. In the future it would be interesting to also analyze the amounts of each chemical element in minerals and not only an analysis as presented here that only counts the different chemical elements. It proved difficult to do this type of analysis because the mineral formulas are in a complex format for computability. My personal opinion is: it is very interesting that in most minerals we can extract oxygen and water (more from the first than the second) with some physical-chemical treatment, sometimes this can be done in a simple way, sometimes in a complex way, but it demonstrates how there is enough oxygen and water inside the earth's crust, and not only coming from the oceans, from the very formation of our planet. Thanks. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1513im1.png&userId=1316061 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9107im2.png&userId=1316061 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7916im3.png&userId=1316061 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4965im4.png&userId=1316061 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7193im5.png&userId=1316061 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8332im6.png&userId=1316061 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1159im7.png&userId=1316061 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7568im8.png&userId=1316061 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2146im9.png&userId=1316061 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1588im10.png&userId=1316061 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2712im11.png&userId=1316061 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2750im12.png&userId=1316061 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7119im13.png&userId=1316061 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3232im14.png&userId=1316061 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4654im15.png&userId=1316061 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=im16.png&userId=1316061 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=im17.png&userId=1316061 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=im18.png&userId=1316061 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=im19.png&userId=1316061 Claudio Chaib 2020-11-15T23:14:04Z https://community.wolfram.com/groups/-/m/t/2429832 *WOLFRAM MATERIALS for the ARTICLE:* > Brunk, N.E., Twarock, R. > Percolation Theory Reveals Biophysical Properties of Virus-like Particles. > ACS Nano 2021, 15, 8, 12988–12995 > https://doi.org/10.1021/acsnano.1c01882 > [Full article in PDF][1] &[Wolfram Notebook][2] [1]: https://pubs.acs.org/doi/pdf/10.1021/acsnano.1c01882 [2]: https://www.wolframcloud.com/obj/0abc0e85-7445-4b0b-a3df-1a4ec57f1da7 Nicholas Brunk 2021-12-21T15:33:59Z https://community.wolfram.com/groups/-/m/t/828033 You may remember that I've already posted [packages for crystal structure plots][1]. I just wanted to dump a piece of code here that's based on these packages and will let you plot crystal structures from [VASP][2] input/output files on a webpage... in case anyone else is using VASP. For anyone who wants to try the app but doesn't have a VASP file handy, here's a sample you can copy and paste into a plain text file: Rutile 1.00000000000000 4.5937300000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 4.5937300000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 2.9581200000000000 Ti O 2 4 Direct 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.5000000000000000 0.5000000000000000 0.5000000000000000 0.3053000000000000 0.3053000000000000 0.0000000000000000 0.6947000000000000 0.6947000000000000 0.0000000000000000 0.8053000000000000 0.1947000000000000 0.5000000000000000 0.1947000000000000 0.8053000000000000 0.5000000000000000 The actual code is below the image. Have fun! ![enter image description here][3] CloudDeploy[FormFunction[{ {{"file", "Upload a VASP POSCAR or CONTCAR file here:"} -> <| "Interpreter" -> "UploadedFile"|>}, { {"sysdim", "Periodic repetitions"} -> <| "Interpreter" -> Restricted[ DelimitedSequence["Integer", " " | "," | ";" | "/" | "x" | "X"], 3], "Input" -> "1x1x1"|>, {"retractq", "Retract atoms to cell?"} -> <| "Interpreter" -> "Boolean", "Input" -> False|>, {"addq", "Add periodic duplicates of atoms?"} -> <| "Interpreter" -> "Boolean", "Input" -> False|>, {"atomrad", "Atom radius"} -> <|"Interpreter" -> "ComputedReal", "Input" -> 0.4|>, {"bonddist", "Maximum bond length"} -> <| "Interpreter" -> "ComputedReal", "Input" -> 2.1|>, {"monobond", "Want to pick your own bond color?"} -> <| "Interpreter" -> "Boolean", "Input" -> False|>, {"bondcol", "Bond color"} -> <|"Interpreter" -> "ComputedColor", "Input" -> GrayLevel[.8]|>, {"bondrad", "Bond radius"} -> <|"Interpreter" -> "ComputedReal", "Input" -> 0.1|>, {"linecol", "Cell outline color"} -> <| "Interpreter" -> "ComputedColor", "Input" -> Black|>, {"linerad", "Cell outline radius"} -> <| "Interpreter" -> "ComputedReal", "Input" -> 0.02|> }}, Module[{file, sysdim, retractq, addq, atomrad, bonddist, monobond, bondcol, bondrad, linecol, linerad, data, speciesQ, atomcol, chemoffset, chgoffset, lattscale, lattvec, coord, conf, coordP, confP, new, tubearrow, lines, atoms, tuples, bonds}, file = #file; sysdim = #sysdim; retractq = #retractq; addq = #addq; atomrad = #atomrad; bonddist = #bonddist; monobond = #monobond; bondcol = #bondcol; bondrad = #bondrad; linecol = #linecol; linerad = #linerad; (*import: *) data = Import[file, "Table"]; (*offset if chemical species are given: *) speciesQ = MatchQ[data[[6]], {_String ..}]; atomcol[type_] := If[speciesQ, ColorData["Atoms", data[[6, type]]], ColorData[97, type]]; chemoffset = If[speciesQ, 1, 0]; (*offset for missing "Selective Dynamics" line as is common in \ CHG/CHGCAR: *) chgoffset = If[TrueQ[Length[data[[chemoffset + 8]]] > 0] && MatchQ[data[[chemoffset + 8, 1]], _?NumericQ], -1, 0]; (*lattice vectors and atoms: *) lattvec = data[[3 ;; 5]]; lattscale = data[[2]]; If[TrueQ[Length[lattscale] == 1], lattscale = lattscale[[1]]]; If[TrueQ[Sign[lattscale] == -1], lattscale = (-lattscale/Det[lattvec])^(1/3)]; lattvec = If[TrueQ[Length[lattscale] == 3], N[lattscale[[#]]*lattvec[[#]]] & /@ Range[3], N[lattscale*lattvec]]; conf = Flatten[Join[ ConstantArray[#, data[[chemoffset + 6, #]]] & /@ Range[Length[data[[chemoffset + 6]]]]]]; coord = N[data[[chemoffset + chgoffset + 9 ;; (chemoffset + chgoffset + 8 + Total[data[[chemoffset + 6]]]), 1 ;; 3]]]; (*reprojection for cartesian coordinates: *) If[TrueQ[Length[data[[chemoffset + chgoffset + 8]]] > 0] && StringMatchQ[ToString[data[[chemoffset + chgoffset + 8, 1]]], "c*" | "k*", IgnoreCase -> True], If[TrueQ[Length[lattscale] == 3], coord = #*lattscale & /@ coord, coord = coord*lattscale]; coord = coord.Inverse[lattvec]]; {coordP, confP} = {coord, conf}; (*retraction, moving all atoms back into the cell: *) If[retractq, With[{retracttol = 10^-4}, coordP = Partition[ If[# > (1 - retracttol), # - 1, #] & /@ Flatten[# - Floor[#] & /@ coordP], 3]; new = DeleteDuplicates[Transpose[{coordP, confP}], (Norm[ Round[#1[[1]], retracttol] - Round[#2[[1]], retracttol] - Floor[Round[#1[[1]], retracttol]] + Floor[Round[#2[[1]], retracttol]]] < retracttol) && (#1[[2]] == #2[[2]]) &]; {coordP, confP} = Transpose[new]]]; (*periodic repetition: *) coordP = Flatten[Table[(# + {a, b, c}) & /@ coordP, {a, 0, sysdim[[1]] - 1}, {b, 0, sysdim[[2]] - 1}, {c, 0, sysdim[[3]] - 1}], 3]; confP = Flatten[ConstantArray[confP, Times @@ sysdim]]; (*add peridic duplicates if desired: *) If[TrueQ[addq], new = Transpose[{coordP, confP}]; new = Join[new, # + {{sysdim[[1]], 0, 0}, 0} & /@ Select[new, Abs[#[[1, 1]]] < 0.01 &], # + {{-sysdim[[1]], 0, 0}, 0} & /@ Select[new, Abs[#[[1, 1]]] > 0.99*sysdim[[1]] &]]; new = Join[new, # + {{0, sysdim[[2]], 0}, 0} & /@ Select[new, Abs[#[[1, 2]]] < 0.01 &], # + {{0, -sysdim[[2]], 0}, 0} & /@ Select[new, Abs[#[[1, 2]]] > 0.99*sysdim[[2]] &]]; new = Join[new, # + {{0, 0, sysdim[[3]]}, 0} & /@ Select[new, Abs[#[[1, 3]]] < 0.01 &], # + {{0, 0, -sysdim[[3]]}, 0} & /@ Select[new, Abs[#[[1, 3]]] > 0.99*sysdim[[3]] &]]; {coordP, confP} = Transpose[new]; ]; (*cell lines: *) tubearrow[{tail_, head_}] := With[{scale = .5*Sqrt[Mean[Norm /@ lattvec]*linerad]}, Tube[{tail, head - 4*scale*Normalize[head - tail], head - 4*scale*Normalize[head - tail], head}, {linerad, linerad, scale, 0}]]; lines = {linecol, Tube[#.lattvec, linerad] & /@ { {{0, 0, #}, {1, 0, #}, {1, 1, #}, {0, 1, #}, {0, 0, #}} & /@ {0, 1}, {{0, 0, #} & /@ {0, 1}, {1, 0, #} & /@ {0, 1}, {1, 1, #} & /@ {0, 1}, {0, 1, #} & /@ {0, 1}} }, tubearrow[{{0, 0, 0}, #}] & /@ lattvec}; (*atoms: *) atoms = Tooltip[{atomcol[confP[[#]]], Sphere[coordP[[#]].lattvec, atomrad]}, #] & /@ Range[Length[confP]]; (*bonds: *) tuples = Select[Subsets[Range[Length[confP]], {2}], Norm[(coordP[[#]].lattvec)[[1]] - (coordP[[#]].lattvec)[[2]]] < bonddist &]; bonds = If[TrueQ[tuples == {}], {}, If[monobond, {bondcol, Tube[coordP[[#]].lattvec, bondrad]}, Table[{atomcol[confP[[#[[ii]]]]], Tube[{coordP[[#[[ii]]]].lattvec, Total[coordP[[#]].lattvec]*.5}, bondrad]}, {ii, 1, 2}] ] & /@ tuples]; (*return the plot: *) Graphics3D[{lines, bonds, atoms}, ImageSize -> Large, BaseStyle -> {Specularity[Gray, 100]}, Boxed -> False, SphericalRegion -> True, Lighting -> "Neutral"] ] &, "PNG", AppearanceRules -> <| "Title" -> "Crystal Structure Viewer for VASP"|>], Permissions -> "Public"] [at0]: http://community.wolfram.com/web/chrishaydock137 [1]: http://community.wolfram.com/groups/-/m/t/787142 [2]: http://vasp.at/ [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdf4562y4thrwbdfva.gif&userId=11733 Bianca Eifert 2016-03-23T08:59:33Z https://community.wolfram.com/groups/-/m/t/3242770 ![enter image description here][1] Starting tomorrow, August 7, Wolfram U will hosting a weekly webinar series showcasing much of the new and improved functionality present in Version 14.1 of Wolfram Language. The first webinar will provide a broad overview of this release and subsequent versions will delve into detailed subareas like new mathematics functionality, improvements to the compiler, new astronomical and chemical visualizations, AI and LLMs and more. These sessions will be headed by developers from their respective fields, providing you with a unique opportunity to get a look at all of these topics straight from the source. The schedule is as follows: **August 7, 2024:** *An Overview of What's New and Improved in Version 14.1* This first session in the New in Wolfram 14.1 webinar series paints a big picture of the new release with special attention to Chat Notebooks, LLM functionality and the latest Wolfram tools for AI systems. **August 14, 2024:** *Mathematical Computation in Version 14.1* This session begins with an overview of the latest mathematical functionality in the new release and the new world of symbolic-dimensional arrays, stability analysis of dynamical systems and advances in PDE modeling. **August 21, 2024:** *Updates for the Wolfram Compiler, System Modeler and External Language Integration* This session covers performance updates for the Wolfram Compiler, what's new in System Modeler and the latest in external language integration. **August 28, 2024:** Visualizing and Computing Astronomical and Chemical Data and Historical Geography This session brings you experts sharing incredible advancements for computation with astronomical data, symbolic representation of 3D biomolecules and historical geography. **September 4, 2024:** New and Powerful Components for AI and LLMs In this webinar, you'll learn about Wolfram tools for AI, including connections and prompt engineering for large language models (LLMs), improvements in speech recognition and new video and audio processing functionality. These sessions are running for the next five Wednesdays at 11:00 AM Central US time. You can register for this five-part series [**HERE.**][2] We hope to see you there! (And if you can't make the live sessions, registering means that you'll receive a link to the recordings after each session right in your email!) [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=M14.1-WU.png&userId=1711324 [2]: https://www.bigmarker.com/series/new-in-wolfram-language-14-1/series_details?utm_bmcr_source=community Arben Kalziqi 2024-08-06T21:56:05Z https://community.wolfram.com/groups/-/m/t/2731070 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/cc77d065-e5fe-4f61-9b65-f65a5a4e5366 Theodore Mollano 2022-12-15T19:23:25Z https://community.wolfram.com/groups/-/m/t/2068787 This work is part of series of other posts avaialble here: - 1st post: [Organic Chemistry 1: Modeling Synthesis as Graphs][1] - 3rd post: [Organic Chemistry 3: Progress in Multi-Step Chemical Synthesis][2] ---- I post this in case anyone is interested in experimenting further along these lines, or in collaborating with me on an organic synthesis related project. This notebook shows my representation of various organic chemical reactions in Wolfram Language. &[Wolfram Notebook][3] [Original]: https://www.wolframcloud.com/obj/wolfram-community/Published/OrgSynProject.nb [1]: https://community.wolfram.com/groups/-/m/t/2073460 [2]: https://community.wolfram.com/groups/-/m/t/2071550 [3]: https://www.wolframcloud.com/obj/d25cd622-0699-461b-8652-425dc974e99d Leonardo Cabana 2020-09-01T13:44:29Z https://community.wolfram.com/groups/-/m/t/1835986 # Summary In this post I will show how to create a function called **VitaminData[ ]** using information available in the Wolfram Knowledgebase. This custom function will provide chemical and physical data, molecule visualizations, lists of food sources rich on a specific vitamin and other nutritional data. # Function, data, uses: - **List** By way of comparison, the vitamins in the list of entities: EntityList@EntityClass["Chemical", "Vitamins"] ![i1][1] The function I created has an extended list of vitamins, of course some are questionable and/or old definitions, but I found it interesting to add to the function for didactic reasons and to make the study more complete. VitaminData["List"] ![i2][2] - **Show** Using the function more simply we get the vitamin in the form of entity: VitaminData["A"] ![i3][3] With the optional “Show” we have several options, one of them is the 2D model: VitaminData["B12", "Show" -> "Model2D"] ![i4][4] Using “Show” for the 3D model: VitaminData["B12", "Show" -> "Model3D"] ![i5][5] We can visualize each bond in the molecule with "Show" and "Bonds": VitaminData["B5", "Show" -> "Bonds"] ![i6][6] We can count atoms and show their respective charges with "Show" and "Atoms": VitaminData["B12", "Show" -> "Atoms"] ![i7][7] To have the complete list of properties available in the optional “Show”, use “Properties”: VitaminData["A", "Show" -> "Properties"] ![i8][8] For example, the molecular mass: VitaminData["H", "Show" -> "MolecularMass"] ![i9][9] Another example of one of the properties from the list above is NFPALabel: VitaminData["K1", "Show" -> "NFPALabel"] ![i10][10] With the optional “Show” and “Data”, **all** properties of the above list are shown at once, interactively: VitaminData["C", "Show" -> "Data"] ![i11][11] - **Food** Another function option is “Food”, where the relative amount of each vitamin in a specific food is determined: VitaminData["C", "Food" -> "Banana"] ![i12][12] If we use the function only with “Food”, without naming the vitamin, the full list of vitamins for a specific food is shown: VitaminData["Food" -> "Apple"] ![i13][13] - **Nutritional Information** Another option for the function is “Nutri”, which is the nutritional information of foods in label form. Below is the example for four types of foods: Table[VitaminData[ "Nutri" -> n], {n, {"Banana", "Carrot", "Shrimp", "Salmon"}}] ![i14][14] # Code - **Code of the function *VitaminData[]***: VitaminData["List"] := VitaminData["A", "Show" -> "List"]; VitaminData[vita_, OptionsPattern[]] := Module[{Vitamin, vitamins, ss, cc, a0, a1, a2, a3, a4, a5, a6, a7, ai}, Options[VitaminData] = {"Show" -> "Entity"}; ss = {"A", "B1", "B2", "B3", "B4", "B5", "B6", "B12", "C", "D2", "D3", "H", "H1", "K1", "K3", "K5", "M", "P", "AlphaTocopherol", "DAlphaTocopherol", "Niacin", "Choline"}; Vitamin[vit_] := (vitamins = Join[Table[ Entity["Chemical", StringJoin["Vitamin", i]], {i, {"A", "B1", "B2", "B3", "B4", "B5", "B6", "B12", "C", "D2", "D3", "H", "H1", "K1", "K3", "K5", "M", "P"}}], Table[Entity["Chemical", j], {j, {"AlphaTocopherol", "DAlphaTocopherol", "Niacin", "Choline"}}]]; cc = vit /. AssociationThread[ss, Range@22]; vitamins[[cc]]); a0 = Thread[{ss, Vitamin[All]}]; a1 = Vitamin[vita]; a2 = Dataset[ EntityValue[Vitamin[vita], EntityValue[Vitamin[vita], "Properties"], "PropertyAssociation"]]; a3 = MoleculePlot[Vitamin[vita], ImageSize -> Large]; a4 = MoleculePlot3D[Vitamin[vita], ImageSize -> Large]; a5 = BondList@Vitamin[vita]; a6 = Counts@AtomList@Vitamin[vita]; a7 = Thread[{Map[Text[Style[#, Small]] &, DeleteCases[ StringReplace[ StringDelete[ EntityValue[Entity["Chemical", "VitaminA"], "Properties"] // InputForm // ToString, {"EntityProperty[", "Chemical", "]"}], {FromCharacterCode[32] -> ""}] // ToExpression, ""]], EntityValue[Entity["Chemical", "VitaminA"], "Properties"]}]; ai = EntityValue[Vitamin[vita], OptionValue["Show"]]; If[MemberQ[{"List", "Entity", "Data", "Model2D", "Model3D", "Bonds", "Atoms", "Mass", "Properties"}, OptionValue["Show"]] == True, OptionValue["Show"] /. {"List" -> a0, "Entity" -> a1, "Data" -> a2, "Model2D" -> a3, "Model3D" -> a4, "Bonds" -> a5, "Atoms" -> a6, "Properties" -> a7}, ai]] VitaminData["Nutri" -> al_] := {Entity["FoodType", al], Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{Entity["FoodType", al]}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", "NutritionLabel"]]}; VitaminData[x_, "Food" -> y_] := Module[{bb}, bb = Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{Entity["FoodType", y]}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", x /. AssociationThread[{"A", "B1", "B2", "B3", "B4", "B5", "B6", "B12", "C", "D2", "D3", "H", "H1", "K1", "K3", "K5", "M", "P", "AlphaTocopherol", "DAlphaTocopherol", "Niacin", "Choline"}, {"RelativeVitaminAContent", "RelativeThiaminContent", "RelativeRiboflavinContent", "NoData", "NoData", "RelativePantothenicAcidContent", "RelativeVitaminB6Content", "RelativeVitaminB12Content", "RelativeVitaminCContent", "RelativeVitaminD2Content", "RelativeVitaminD3Content", "RelativeBiotinContent", "NoData", "RelativeVitaminKContent", "RelativeVitaminKContent", "RelativeVitaminKContent", "RelativeFolicAcidContent", "NoData", "RelativeVitaminEContent", "RelativeVitaminEContent", "RelativeNiacinContent", "RelativeCholineContent"}]]]; If[QuantityQ[bb] == True, {x, bb}, {x, "NoData"}]]; VitaminData["Food" -> an_] := Map[VitaminData[#, "Food" -> an] &, {"A", "B1", "B2", "B3", "B4", "B5", "B6", "B12", "C", "D2", "D3", "H", "H1", "K1", "K3", "K5", "M", "P", "AlphaTocopherol", "DAlphaTocopherol", "Niacin", "Choline"}] # Food Ranking Below we can see that there are 1816 foods in the *Mathematica* database as “FoodType” entities. I decided to leave this option out of the VitaminData[] function because each evaluation takes a long time to perform. SparseArray@EntityList@Entity["FoodType"] ![i15][15] Below are some examples of vitamin ranking lists (top 10 foods) for all foods in the database. In this case I could specify some very specific types as well, such as Beta-Tocopherol (instead of Alpha-Tocopherol, for example) and vitamin D3: - **Vitamin C** MaximalBy[ Thread[{EntityList@Entity["FoodType"], Map[Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{#}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", "RelativeVitaminCContent"]] &, EntityList@Entity["FoodType"]]}], Last, UpTo[10]] ![i16][16] - **Vitamin A** MaximalBy[ Thread[{EntityList@Entity["FoodType"], Map[Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{#}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", "RelativeVitaminAContent"]] &, EntityList@Entity["FoodType"]]}], Last, UpTo[10]] ![i17][17] - **Vitamin B6** MaximalBy[ Thread[{EntityList@Entity["FoodType"], Map[Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{#}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", "RelativeVitaminB6Content"]] &, EntityList@Entity["FoodType"]]}], Last, UpTo[10]] ![i18][18] - **Beta-Tocopherol** MaximalBy[ Thread[{EntityList@Entity["FoodType"], Map[Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{#}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", "RelativeBetaTocopherolContent"]] &, EntityList@Entity["FoodType"]]}], Last, UpTo[10]] ![i19][19] - **Vitamin D3** MaximalBy[ Thread[{EntityList@Entity["FoodType"], Map[Entity[ "Food", {EntityProperty["Food", "FoodType"] -> ContainsExactly[{#}], EntityProperty["Food", "AddedFoodTypes"] -> ContainsExactly[{}]}][ EntityProperty["Food", "RelativeVitaminD3Content"]] &, EntityList@Entity["FoodType"]]}], Last, UpTo[10]] ![i20][20] These lists above were just a few examples of vitamin ranking using all foods in the database and could be extended to various other substances. Thanks. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7638i1.png&userId=1316061 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10099i2.png&userId=1316061 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6977i3.png&userId=1316061 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8926i4.png&userId=1316061 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6808i5.png&userId=1316061 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2171i6.png&userId=1316061 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9269i7.png&userId=1316061 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1613i8.png&userId=1316061 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3239i9.png&userId=1316061 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8715i10.png&userId=1316061 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6084i11.png&userId=1316061 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4882i12.png&userId=1316061 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7520i13.png&userId=1316061 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4489i14.png&userId=1316061 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4028i15.png&userId=1316061 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6591i16.png&userId=1316061 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i17.png&userId=1316061 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i18.png&userId=1316061 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i19.png&userId=1316061 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i20.png&userId=1316061 Claudio Chaib 2019-12-05T00:52:48Z https://community.wolfram.com/groups/-/m/t/1052348 #Introduction Perhaps there are already Mma-Procedures to calculate NMR-spectra, but I did not do a literature research. I post a notebook to calculate NMR-Spectra of simple spin I = 1/2 systems. The notebook comes in two parts. Part one uses a spin-product function approach, where the spin-product function a, a ,...b is used as e.g. phi [ 1, 1, ,...., -1 ]. The Hamiltonian is constructed according to different mT-values and the spectrum is calculated. Part two uses the "brute force" approach where all operators are mapped unto matrices (Kronecker-Products of individual matrix-operators) in the total spin-space. So here products of operators are matrix-products (in part 1 they are functions of functions) .Having the Hamiltonian and its Eigensystem the spectrum is calculated. Note that the number of lines of even small systems are growing rapidly. So it may well be that there is not enough memory to cope with a system you would like to consider. If you omit giving numbers to frequencies and coupling-constants you may get pure theoretical results. That works fine for two spins, but already for three spins - although here you will still get the Hamiltonian - very large outputs are generated, especially in the Eigensystems, So you should avoid that. It seems to be not too complicated to modify the approach in part two to include spins with I > 1/2. And certainly it is well possible to modify the code as to get an iterative procedure to fit data to spectra. I am aware that there are "professional" systems to do all this, but I just wanted to see how it could be done in Mathematica. #Part 1# Number of Spins nsp = 3; Input of Parameters freqs = {372.2, 364.4, 342, 6.083, 5.8}; JJ = ( { {0, .91, 17.9, 1, 1, 1}, {0, 0, 11.75, 1, 1, 1}, {0, 0, 0, 1, 1, 1}, {0, 0, 0, 0, 1, 1}, {0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0} } ); Do[\[Nu][i] = freqs[[i]], {i, 1, nsp}]; Do[J[i, k] = JJ[[i, k]], {i, 1, nsp - 1}, {k, i + 1, nsp}]; Basevectors base = Apply[\[CurlyPhi], IntegerDigits[#, 2, nsp] + 1 & /@ Table[j, {j, 0, 2^nsp - 1}] /. 2 -> -1, {1}] ![enter image description here][1] mT - Values mT = Table[-nsp/2 + j, {j, 0, nsp}] ![enter image description here][2] Number of lines in the spectrum ( = Sum[Binomial[nsp, k] Binomial[nsp, k + 1], {k, 0, nsp - 1}], because only transitions between states of different mT's give lines on non-zero intensity ) numberoflines = Binomial[2 nsp, nsp - 1] > 15 Rule for scalar products rscp = {\[CurlyPhi][x__]^2 -> 1, \[CurlyPhi][x__] \[CurlyPhi][y__] -> 0} ![enter image description here][3] SpinOperators cs[a_, j_] := Module[{t}, t = a; b = t[[j]]; t[[j]] = -b; t] Ix[v_, j_] := v/2 /. \[CurlyPhi][x___] :> \[CurlyPhi] @@ cs[{x}, j] Iy[v_, j_] := I v/2 /. \[CurlyPhi][x___] :> {x}[[j]] \[CurlyPhi] @@ cs[{x}, j] Iz[v_, j_] := v/2 /. \[CurlyPhi][x___] :> {x}[[j]] \[CurlyPhi][x] Example {Ix[\[CurlyPhi][4], 1], Ix[\[CurlyPhi][-1], 1], Iy[\[CurlyPhi][5], 1], Iy[\[CurlyPhi][-1], 1], Iz[\[CurlyPhi][6], 1], Iz[\[CurlyPhi][-1], 1]} ![enter image description here][7] Hamiltonian - Matrixelements Subscript[H, i,j] for (sub-)base b HH[b_, i_, j_] := (Sum[\[Nu][m] b[[j]] Iz[b[[i]], m], {m, 1, nsp}] + Sum[J[m, k] b[[ j]] (Ix[Ix[b[[i]], k], m] + Iy[Iy[b[[i]], k], m] + Iz[Iz[b[[i]], k], m]), {m, 1, nsp - 1}, {k, m + 1, nsp}] // Expand) /. rscp Example HH[base, 1, 1] > 546.94 HH[base, 1, 2] > 0 HH[base, 3, 5] > 0.455 Spinfunctions according to mT - value wf = Function[x, Select[base, Total[List @@ #] == 2 x &]] /@ mT ![enter image description here][8] Hamilton - Submatrices HSM[j_] := (nn = Length[wf[[j]]]; Table[HH[wf[[j]], m, n], {m, 1, nn}, {n, 1, nn}]) HSM[2]; % // MatrixForm ![enter image description here][9] HSM[2] /. {\[Nu][10] -> -\[Nu], \[Nu][11] -> 0, \[Nu][12] -> \[Nu], J[1, 2] -> J, J[1, 3] -> J, J[2, 3] -> J}; % // MatrixForm ![enter image description here][13] Get Eigenstates \[Congruent] all sets { freq, eigenvector } for different spin-states (mT values) frevec[n_] := Module[{es}, es = Eigensystem[HSM[n]]; {#[[1]], #[[2]].wf[[n]]} & /@ Transpose[es] ] eigenstates = frevec /@ Range[nsp + 1] ![enter image description here][14] Operator for calculating relative intensities IOP[x_] := Sum[Ix[x, n], {n, 1, nsp}] Calculating a spectral line = difference of eigenvalues and intensity line[a_, b_] := Module[{}, freq = Abs[a[[1]] - b[[1]]]; m2 = (Expand[a[[2]] IOP[b[[2]]]] /. rscp)^2; {freq, Sqrt[m2]}] Lorentzfunction LF[x_, x0_, a_, h_] := Module[{}, If[h == 0, h = 1]; 1/Sqrt[Pi] (a h/2)/(h^2/4 + Pi (x - x0)^2)] Calculating the spectrum spec = Table[0, {numberoflines}]; nL = 0; Do[ lk = Length[eigenstates[[i]]]; lk1 = Length[eigenstates[[i + 1]]]; Do[ Do[ nL = nL + 1; spec[[nL]] = line[eigenstates[[i, m]], eigenstates[[i + 1, n ]]], {n, 1, lk1} ], {m, 1, lk} ], {i, 1, Length[eigenstates] - 1}]; normalizer = Max[Transpose[spec][[2]]]; bb = {.95 Min[Transpose[spec][[1]]], 1.05 Max[Transpose[spec][[1]]]}; spec = {#[[1]], #[[2]]/normalizer} & /@ spec; spec pl1 = ListPlot[spec, Filling -> Axis] ![enter image description here][15] Show the spectrum with lines pl2 = Plot[ Plus @@ (LF[x, #[[1]], #[[2]], 1.5] & /@ spec), {x, bb[[1]], bb[[2]]}, PlotRange -> All, AxesOrigin -> {320, 0}] ![enter image description here][16] For some physical reason spectra are recorded so that frequencies grow from right to left. So the plot is reversed and compared to the experimental spectrum ( see http://www.users.csbsju.edu/~frioux/nmr/Speclab4.htm ) which is given below the plot. pl3 = Plot[ Plus @@ (LF[-x, #[[1]], #[[2]], 1.5] & /@ spec), {x, -bb[[2]], -bb[[ 1]]}, PlotRange -> All] ![enter image description here][17] #Part 2# nsp = 3; Input of Parameters freqs = {372.2, 364.4, 342, 6.083, 5.8}; JJ = ( { {0, .91, 17.9, 1, 1, 1}, {0, 0, 11.75, 1, 1, 1}, {0, 0, 0, 1, 1, 1}, {0, 0, 0, 0, 1, 1}, {0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0} } ); Do[\[Nu][i] = freqs[[i]], {i, 1, nsp}]; Do[J[i, k] = JJ[[i, k]], {i, 1, nsp - 1}, {k, i + 1, nsp}]; number of lines to be expected and dimension ot (total) spin - space (at least for spin 1/2 ) numberoflines = Binomial[2 nsp, nsp - 1] dimspsp = 2^nsp > 15 > 8 spin operators for spin I = 1/2 ix = ( { {0, 1}, {1, 0} } )/2; iy = ( { {0, -I}, {I, 0} } )/2; iz = ( {{1, 0}, {0, -1} } )/2; this function constructs the spin operator of particle j as matrix in the spin space of n particles Op[op_, n_, j_] := Module[{x, m}, x = Join[Table[{{1, 0}, {0, 1}}, {j - 1}], {op}, Table[{{1, 0}, {0, 1}}, {n - j}]]; m = SparseArray[KroneckerProduct[Sequence @@ x]] ] oIx[j_] := Op[ix, nsp, j] oIy[j_] := Op[iy, nsp, j] oIz[j_] := Op[iz, nsp, j] Hamiltonian HH = \!\( \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(nsp\)]\(\[Nu][i] oIz[ i]\)\) + \!\( \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(nsp - 1\)]\( \*UnderoverscriptBox[\(\[Sum]\), \(j = i + 1\), \(nsp\)]J[i, j] \((oIx[i] . oIx[j] + oIy[i] . oIy[j] + oIz[i] . oIz[j])\)\)\) > SparseArray[SequenceForm["<", 32, ">"], {8, 8}] Eigensystem for the Hamilton - Operator est = Transpose[Eigensystem[HH]] ![enter image description here][18] Intensity operator IOP1 = \!\( \*UnderoverscriptBox[\(\[Sum]\), \(j = 1\), \(nsp\)]\(oIx[j]\)\) > SparseArray[SequenceForm["<", 24, ">"], {8, 8}] line1[a_, b_] := Module[{}, freq = Abs[a[[1]] - b[[1]]]; m2 = (a[[2]].IOP1.b[[2]])^2; {freq, Sqrt[m2]}] Calculate spectrum, show it and display result from part 1 spec1 = Table[0, {Binomial[dimspsp, 2]}]; nL = 0; Do[ Do[ nL = nL + 1; spec1[[nL]] = line1[est[[u]], est[[v]]], {u, v + 1, dimspsp} ], {v, 1, dimspsp - 1} ] spec1 = Select[spec1, #[[2]] > 0. &]; normalizer = Max[Transpose[spec1][[2]]]; bb = {.95 Min[Transpose[spec][[1]]], 1.05 Max[Transpose[spec][[1]]]}; spec1 = {#[[1]], #[[2]]/normalizer} & /@ spec1; spec1 ListPlot[spec1, Filling -> Axis, FillingStyle -> Directive[Red, Thick]] Show[pl1] ![enter image description here][19] Plot the spectrum and compare with the result of the 1 st part pl4 = Plot[ Plus @@ (LF[x, #[[1]], #[[2]], 1.5] & /@ spec1), {x, bb[[1]], bb[[2]]}, PlotRange -> All, PlotStyle -> Red] Show[pl2] ![enter image description here][20] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.21.45.png&userId=95400 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.23.20.png&userId=95400 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.25.36.png&userId=95400 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.21.45.png&userId=95400 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.21.45.png&userId=95400 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.21.45.png&userId=95400 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.28.10.png&userId=95400 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.32.12.png&userId=95400 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.33.44.png&userId=95400 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.21.45.png&userId=95400 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.23.20.png&userId=95400 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.25.36.png&userId=95400 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.34.56.png&userId=95400 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.37.59.png&userId=95400 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.41.13.png&userId=95400 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.42.24.png&userId=95400 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.43.26.png&userId=95400 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.50.48.png&userId=95400 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.53.45.png&userId=95400 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at16.55.25.png&userId=95400 Hans Dolhaine 2017-04-04T08:36:27Z