I have a file with coordinates {x, y,z} of a fcc lattice.
In[0]: data = Import[
"D:\\AtomsDiffusion\\AtomsDiffusion\\bin\\PositionsAtomsMathematica.\
txt", "CSV"]
Out[0]: {{0, 0, 0}, {0, 0.707, 0.707}, {0.707, 0, 0.707}, {0.707, 0.707,
0}, {0, 0, 1.414}, {0, 0.707, 2.121}, {0.707, 0, 2.121}, {0.707,
0.707, 1.414}, {0, 1.414, 0}, {0, 2.121, 0.707}, {0.707, 1.414,
0.707}, {0.707, 2.121, 0}, {0, 1.414, 1.414}, {0, 2.121,
2.121}, {0.707, 1.414, 2.121}, {0.707, 2.121, 1.414}, {1.414, 0,
0}, {1.414, 0.707, 0.707}, {2.121, 0, 0.707}, {2.121, 0.707,
0}, {1.414, 0, 1.414}, {1.414, 0.707, 2.121}, {2.121, 0,
2.121}, {2.121, 0.707, 1.414}, {1.414, 1.414, 0}, {1.414, 2.121,
0.707}, {2.121, 1.414, 0.707}, {2.121, 2.121, 0}, {1.414, 1.414,
1.414}, {1.414, 2.121, 2.121}, {2.121, 1.414, 2.121}, {2.121, 2.121,
1.414}};
Using the function Graphics3D, I draw the coordinates:
In[1]: Graphics3D[{Opacity[.6], Ball[#, 0.5] & /# data}, Axes -> True]
Out:
How can I draw grid lines vertical, horizontal and diagonal,to be like here?
example
Following through on Bill's comment
lines = Catenate#Outer[List[##] &, data, data, 1];
dist = EuclideanDistance ### lines;
l2 = First /# DeleteCases[MapThread[{#1, (#2 > 0 && #2 < 1.5)} &,
{lines, dist}], {_, False}];
Show[Graphics3D[Line /# l2, Boxed -> False],
Graphics3D[{Ball[#, 0.2] & /# data}, Axes -> True]]
Help me, please!
There's the procedure operation[f_].
It works correctly and plot for functions:Cos,Sin. But, Unfortunately, it doesn't work for E^x and Log[E,x] and outputs errors, maybe because inputting not correct name of function or something else;(( What's the problem?
spxsin = {-1, -0.35, 0.3, 0.95, 1.6, 2.375, 3.15, 3.925, 4.7, 5.025,
5.35, 5.675, 6};
spxcos = {-1, -0.75, -0.5, -0.25, 0, 0.775, 1.55, 2.325, 3.1, 3.825,
4.55, 5.275, 6};
spxlny = {-1, 0.75, 2.5, 4.25, 6};
spxey = {-1, 0.75, 2.5, 4.25, 6};
operation[f_] := Block[{data},
data = Table[{x, f[x]}, {x, -1, 6, 0.1}];
Graphics[{Thick, Blue, Line[data],
Green, Table[Point[{spx[[i]], f[spx[[i]]]}], {i, 1, Length[spx]}],
Pink, Opacity[.7],
Table[Rectangle[{spx[[i]], f[spx[[i]]]}, {spx[[i + 1]],
f[spx[[i + 1]]]}], {i, 1, Length[spx] - 1}]
}, Axes -> True]]
Which[ f == Sin, spx := spxsin, f == Cos, spx := spxcos, f == E^x ,
spx := spxlny, f == Log, spx := spxey]
operation[Sin]
operation[Cos]
operation[E^x]
operation[Log]
Edit now tested: you can pass pure functions to your operation, so instead of: operation[E^x] try
operation[E^# &]
or for example if you wanted a base 2 log it would be
operation[Log[2,#]&]
A few other things to point out: Log fails simply because your x table range is negative.
Also, the Which statement you have doesn't do anything. Being outside your function, f is not defined so none of the conditionals are True. Moving Which inside the function, this works:
spxsin = {-1, -0.35, 0.3, 0.95, 1.6, 2.375, 3.15, 3.925, 4.7, 5.025,
5.35, 5.675, 6};
spxcos = {-1, -0.75, -0.5, -0.25, 0, 0.775, 1.55, 2.325, 3.1, 3.825,
4.55, 5.275, 6};
spxlny = {-1, 0.75, 2.5, 4.25, 6};
spxey = {-1, 0.75, 2.5, 4.25, 6};
operation[f_] :=
Block[{data}, data = Table[{x, f[x]}, {x, -1, 6, 0.1}];
Clear[spx];
Which[
TrueQ[f == Sin], spx := spxsin,
TrueQ[f == Cos], spx := spxcos ,
TrueQ[f == (E^# &)], spx := spxey ];
Graphics[{Thick, Blue, Line[data], Green,
Table[{PointSize[.1], Point[{spx[[i]], f[spx[[i]]]}]}, {i, 1, Length[spx]}],
Pink, Opacity[.7],
Table[Rectangle[{spx[[i]], f[spx[[i]]]}, {spx[[i + 1]],
f[spx[[i + 1]]]}], {i, 1, Length[spx] - 1}]}, Axes -> True,
AspectRatio -> 1/GoldenRatio]]
Note each which test is wrapped in TrueQ to ensure it is either True or False ( the test Sin==Cos is not false for all values and so does not return False )
operation[Sin]
operation[Cos]
operation[E^# &]
Now if you want Exp to also work you need to explicitly put that form in your Which statement. ( f==(E^#&) || f==Exp )
Euler's E needs to be entered as Esc ee Esc.
It looks to me at you entered is a standard E.
Note also that Exp is the exponential function in Mathematica.
I want to calculate an 2D array "tocalc" in which the elements are calculated based on tests on three other lists (z,b1,b2).
(*example data*)
z = Range[0, 100, 10];
x = Range[10];
b1 = ConstantArray[0., Length[x]];
tocalc = ConstantArray[0, {Length[x], Length[z]}];
b2 = {0, 20, 30, 40, 50, 40, 30, 20, 10, 0};
one solution to this would be
(*simple but slow solution*)
Do[
Do[
If[z[[k]] <= b2[[i]] && z[[k]] >= b1[[i]],
tocalc[[i, k]] = (b2[[i + 1]] - b2[[i - 1]])],
{k, 1, Length[z]}];,
{i, 2, Length[x] - 1}]
with the result
{{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {30, 30, 30, 0, 0, 0, 0, 0, 0, 0,
0}, {20, 20, 20, 20, 0, 0, 0, 0, 0, 0, 0}, {20, 20, 20, 20, 20, 0,
0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0}, {-20, -20, -20, -20, -20, 0, 0, 0, 0, 0,
0}, {-20, -20, -20, -20, 0, 0, 0, 0, 0, 0, 0}, {-20, -20, -20, 0, 0,
0, 0, 0, 0, 0, 0}, {-20, -20, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0}}
The Question: How can this be done efficiently in Mathematica?
If this is evaluated 10000 times then it would take then 3.66 seconds. While in Matlab this takes 0.04sec so Matlab is almost 100 times faster.
I know that the solution with the two Do loops is not perfect for Mathematica, so i tried several other solutions such as with MapIndexed, Table, functions, Conditionals, and so on. but all are not really faster maybe even slower the the two Do loops.
Here is one example with MapIndexed:
tocalc = ConstantArray[0, {Length[x], Length[z]}];
MapIndexed[
If[z[[Part[#2, 2]]] <= b2[[Part[#2, 1]]] &&
z[[Part[#2, 2]]] >= b1[[Part[#2, 1]]] && Part[#2, 1] >= 2 &&
Part[#2, 1] <= Length[x] - 1,
tocalc[[Part[#2, 1], Part[#2, 2]]] = (b2[[Part[#2, 1] + 1]] -
b2[[Part[#2, 1] - 1]]), 0.] &, tocalc, {2}];
The ideal solution should work for larger matrices and real numbers as well and also for more complicated conditionals.
---edit:
Since it looks some solutions to this are even slower in my real problem here is one example of it:
the Real-World Problem
b2 = {0.`, 0.`, 0.`, 990.3440201085594`, 1525.7589030785484`,
1897.6531659202747`, 2191.6073263357594`, 2433.0441988616717`,
2630.6658409463894`, 2799.347578394955`, 2944.656306810331`,
3070.718467691769`, 3179.485627984329`, 3272.3788096129415`,
3346.199103579602`, 3405.384848015466`, 3346.199103579602`,
3272.3788096129415`, 3179.485627984329`, 3070.718467691769`,
2944.656306810331`, 2799.347578394955`, 2630.6658409463894`,
2433.0441988616717`, 2191.6073263357594`, 1897.6531659202747`,
1525.7589030785484`, 990.3440201085594`, 0.`, 0.`, 0.`};
z = {0.`, 250.`, 500.`, 750.`, 1000.`, 1250.`, 1500.`, 1750.`, 2000.`,
2250.`, 2500.`, 2750.`, 3000.`, 3250.`,
3500.`}; (*z(k)*)
imax = 31; (*number of x(i)*)
b1 = ConstantArray[0., imax]; (*lower boundary, can be different form 0*)
deltax = 50000.`;
mmax = 10000.; (*number of calculations*)
A00 = 1.127190283243198`*^-12; (*somefactor*)
n = 3;
one solution:
f2C = Compile[{{b2, _Real, 1}, {z, _Real, 1}, {b1, _Real, 1}},
With[{zeros = {ConstantArray[0., Length[z]]}},
Join[zeros,
Table[If[
b1[[i]] <= z[[k]] <=
b2[[i]], -(A00*(Abs[(b2[[i + 1]] - b2[[i - 1]])/(2.0*
deltax)])^(n -
1.0)*(b2[[i]]^(n + 1.) - (b2[[i]] - z[[k]])^(n +
1.)))*((b2[[i + 1]] - b2[[i - 1]])/(2.0*deltax))
, 0.],
{i, 2, Length[b2] - 1}, {k, Length[z]}
], zeros]]
, CompilationTarget -> "C"];
The Result is
Timing[Do[f2C[b2, z, b1];, {mmax}]]
Out[85]= {81.3544, Null}
Thanks!
You can do something like below. You will need to figure out how you want to handle the boundaries though (where b2[[i+1]] or b2[[i-1]] is not defined).
f[x_, y_] := If[x[[1]] <= y <= x[[2]], x[[4]] - x[[3]], 0]
Here I restrain the level to which Outer goes, so that I do not need to change the head (as I was doing in the original response).
In[1309]:= Outer[f,
Transpose[{b1, b2, RotateRight[b2], RotateLeft[b2]}], z, 1]
Out[1309]= {{20, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {30, 30, 30, 0, 0, 0,
0, 0, 0, 0, 0}, {20, 20, 20, 20, 0, 0, 0, 0, 0, 0, 0}, {20, 20, 20,
20, 20, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0}, {-20, -20, -20, -20, -20, 0, 0, 0, 0, 0,
0}, {-20, -20, -20, -20, 0, 0, 0, 0, 0, 0, 0}, {-20, -20, -20, 0, 0,
0, 0, 0, 0, 0, 0}, {-20, -20, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {-10, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0}}
Speed check:
In[1298]:= Timing[
Do[Outer[f,
Apply[list,
Transpose[{b1, b2, RotateRight[b2], RotateLeft[b2]}], {1}],
z], {10^4}]]
Out[1298]= {2.68, Null}
We can compile the function to get better speed.
fC = Compile[{{x, _Integer, 1}, {y, _Integer}},
If[x[[1]] <= y <= x[[2]], x[[4]] - x[[3]], 0]];
In[1306]:= Timing[
Do[Outer[fC, Transpose[{b1, b2, RotateRight[b2], RotateLeft[b2]}], z,
1], {10^4}]]
Out[1306]= {0.8, Null}
--- edit ---
Variants include compiling the entire routine. Here is one such.
ff = Compile[{{b1, _Integer, 1}, {b2, _Integer, 1}, {z, _Integer,
1}},
With[{lc =
RotateRight[ListConvolve[{1, 0, -1}, b2, {-1, -1}, 0]]},
Table[
If[b1[[i]] <= z[[k]] <= b2[[i]], lc[[i]], 0], {i,
Length[b2]}, {k, Length[z]}
]]];
In[385]:= Timing[Do[ff[b1, b2, z], {10^4}]]
Out[385]= {0.24, Null}
If I add CompilationTarget -> "C" then it gets around twice as fast.
Another variant, in C code, gets under 0.1 seconds.
In[441]:=
ff2C = Compile[{{b1, _Integer, 1}, {b2, _Integer, 1}, {z, _Integer,
1}},
With[{zeros = {ConstantArray[0, Length[z]]}},
Join[zeros, Table[
If[b1[[i]] <= z[[k]] <= b2[[i]], b2[[i + 1]] - b2[[i - 1]],
0], {i, 2, Length[b2] - 1}, {k, Length[z]}
], zeros]], CompilationTarget -> "C"];
In[442]:= Timing[Do[ff2C[b1, b2, z], {10^4}]]
Out[442]= {0.04, Null}
In[443]:= ff2C[b1, b2, z]
Out[443]= {{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {30, 30, 30, 0, 0, 0, 0,
0, 0, 0, 0}, {20, 20, 20, 20, 0, 0, 0, 0, 0, 0, 0}, {20, 20, 20,
20, 20, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0}, {-20, -20, -20, -20, -20, 0, 0, 0, 0, 0,
0}, {-20, -20, -20, -20, 0, 0, 0, 0, 0, 0, 0}, {-20, -20, -20, 0, 0,
0, 0, 0, 0, 0, 0}, {-20, -20, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0}}
I would guess there are variants that may be faster still.
--- end edit ---
--- edit 2 ---
Of course, if you have global variables (that is, defined outside of your Compile), then there is a bit more work to do. I am aware of two possibilities. Prior to version 8 one would suck in constants using a With[] around the Compile, as below.
f2C = With[{n = n, deltax = deltax, A00 = A00},
Compile[{{b2, _Real, 1}, {z, _Real, 1}, {b1, _Real, 1}},
With[{zeros = {ConstantArray[0., Length[z]]}},
Join[zeros,
Table[If[
b1[[i]] <= z[[k]] <=
b2[[i]], -(A00*(Abs[(b2[[i + 1]] - b2[[i - 1]])/(2.0*
deltax)])^(n -
1.0)(b2[[i]]^(n + 1.) - (b2[[i]] - z[[k]])^(n +
1.)))((b2[[i + 1]] - b2[[i - 1]])/(2.0*deltax)),
0.], {i, 2, Length[b2] - 1}, {k, Length[z]}], zeros]],
CompilationTarget -> "C"]];
In version 8 the following achieves the same effect.
f2Cb = Compile[{{b2, _Real, 1}, {z, _Real, 1}, {b1, _Real, 1}},
With[{zeros = {ConstantArray[0., Length[z]]}},
Join[zeros,
Table[If[
b1[[i]] <= z[[k]] <=
b2[[i]], -(A00*(Abs[(b2[[i + 1]] - b2[[i - 1]])/(2.0*
deltax)])^(n -
1.0)(b2[[i]]^(n + 1.) - (b2[[i]] - z[[k]])^(n +
1.)))((b2[[i + 1]] - b2[[i - 1]])/(2.0*deltax)),
0.], {i, 2, Length[b2] - 1}, {k, Length[z]}], zeros]],
CompilationTarget -> "C",
CompilationOptions -> {"InlineExternalDefinitions" -> True}];
With either I get a result on the more realistic example in around 0.7 seconds, whereas my machine would take over 100 seconds without those globals being defined inside the Compile.
A more general approach might be to pass them as parameters (if they were likely to change rather than be constants). That would lead to a slightly slower run time though.
Regarding that option approach, you might have a look at ref/CompilationOptions in the Cocumentation Center
--- end edit 2 ---
I have an ODE and I solve it with NDSolve, then I plot the solution on a simplex in 2D.
Valid XHTML http://ompldr.org/vY2c5ag/simplex.jpg
Then I need to transform (align or just plot) this simplex in 3D at coordinates (1,0,0),(0,1,0),(0,0,1), so it looks like this scheme:
Valid XHTML http://ompldr.org/vY2dhMg/simps.png
I use ParametricPlot to do my plot so far. Maybe all I need is ParametricPlot3D, but I don't know how to call it properly.
Here is my code so far:
Remove["Global`*"];
phi[x_, y_] = (1*x*y)/(beta*x + (1 - beta)*y);
betam = 0.5;
betaf = 0.5;
betam = s;
betaf = 0.1;
sigma = 0.25;
beta = 0.3;
i = 1;
Which[i == 1, {betam = 0.40, betaf = 0.60, betam = 0.1,
betaf = 0.1, sigma = 0.25 , tmax = 10} ];
eta[x2_, y2_, p2_] = (betam + betaf + sigma)*p2 - betam*x2 -
betaf*y2 - phi[x2, y2];
syshelp = {x2'[t] == (betam + betaf + sigma)*p2[t] - betam*x2[t] -
phi[x2[t], y2[t]] - eta[x2[t], y2[t], p2[t]]*x2[t],
y2'[t] == (betaf + betam + sigma)*p2[t] - betaf*y2[t] -
phi[x2[t], y2[t]] - eta[x2[t], y2[t], p2[t]]*y2[t],
p2'[t] == -(betam + betaf + sigma)*p2[t] + phi[x2[t], y2[t]] -
eta[x2[t], y2[t], p2[t]]*p2[t]};
initialcond = {x2[0] == a, y2[0] == b, p2[0] == 1 - a - b};
tmax = 50;
solhelp =
Table[
NDSolve[
Join[initialcond, syshelp], {x2, y2, p2} , {t, 0, tmax},
AccuracyGoal -> 10, PrecisionGoal -> 15],
{a, 0.01, 1, 0.15}, {b, 0.01, 1 - a, 0.15}];
functions =
Map[{y2[t] + p2[t]/2, p2[t]*Sqrt[3]/2} /. # &, Flatten[solhelp, 2]];
ParametricPlot[Evaluate[functions], {t, 0, tmax},
PlotRange -> {{0, 1}, {0, 1}}, AspectRatio -> Automatic]
Third day with Mathematica...
You could find a map from the triangle in the 2D plot to the one in 3D using FindGeometricTransformation and use that in ParametricPlot3D to plot your function, e.g.
corners2D = {{0, 0}, {1, 0}, {1/2, 1}};
corners3D = {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};
fun[pts1_, pts2_] := FindGeometricTransform[Append[pts2, Mean[pts2]],
PadRight[#, 3] & /# Append[pts1, Mean[pts1]],
"Transformation" -> "Affine"][[2]]
ParametricPlot3D[Evaluate[fun[corners2D, corners3D][{##, 0}] & ### functions],
{t, 0, tmax}, PlotRange -> {{0, 1}, {0, 1}, {0, 1}}]
Since your solution has the property that x2[t]+y2[t]+p2[t]==1 it should be enough to plot something like:
functions3D = Map[{x2[t], y2[t], p2[t]} /. # &, Flatten[solhelp, 2]];
ParametricPlot3D[Evaluate[functions3D], {t, 0, tmax},
PlotRange -> {{0, 1}, {0, 1}, {0, 1}}]