Expectation Maximization Algorithm

I would like to use the expectation maximization algorithm within Mathematica. The issue is that I am very basic user and progress slowly with understanding functional programming.. I have found this "featured example" on Wolfram web page, where an algorithm for a mixture of 2 normal distributions is demonstrated. Now I would like to understand what is going on in order to change it later to be applicable to my problem (My problem is to estimate a mixture of 3 distributions, given the real data) Could please anyone explain line by line (or more coarsely) what is going on in this code? (And how would one go to use the real dataset (excel file)) Thanks a lot!               {Manipulate[      Module[{d1, d2, sim, updates},       SeedRandom[sr];       d1 = NormalDistribution[\[Mu]1, \[Sigma]1];       d2 = NormalDistribution[\[Mu]2, \[Sigma]2];       sim = With[{musAndsigmas =            RandomChoice[{p1,               1 - p1} -> {{\[Mu]1, \[Sigma]1}, {\[Mu]2, \[Sigma]2}},             numsamples]},         musAndsigmas[[All, 2]] RandomReal[NormalDistribution[],             numsamples] + musAndsigmas[[All, 1]]];       updates =         NestList[em[#, sim] &, {{-10, 5}, {5, 5}, {.2, .8}}, numiterations];       Grid[{{Show[{Histogram[sim, Automatic, "PDF",              PlotRange -> {{-30, 30}, {0, Automatic}}],             Plot[{updates[[-1, 3, 1]]*               PDF[Apply[NormalDistribution, updates[[-1, 1]]], x],               updates[[-1, 3, 2]]*               PDF[Apply[NormalDistribution, updates[[-1, 2]]],                 x]}, {x, -30, 30},              PlotStyle -> {{Red, Thick}, {Blue, Thick}},              PerformanceGoal -> "Speed", PlotRange -> All]},            ImageSize -> {400, 275},            AxesOrigin -> {-30,              0}]}, {Grid[{{Panel[              TableForm[updates[[-1, 1 ;; 2]],                     TableHeadings -> {updates[[-1, 3]], {"\[Mu]",                   "\[Sigma]"}}]]}}]}}]       ],      Style["first distribution", Bold],      {{\[Mu]1, 8}, -20, 20, ImageSize -> Tiny, Appearance -> "Labeled"},      {{\[Sigma]1, 5}, 1, 10, 1, ImageSize -> Tiny,        Appearance -> "Labeled"},      Delimiter,      Style["second distribution", Bold],      {{\[Mu]2, -12}, -20, 20, ImageSize -> Tiny, Appearance -> "Labeled"},      {{\[Sigma]2, 3}, 1, 10, 1, ImageSize -> Tiny,        Appearance -> "Labeled"},      Delimiter,      Style["probability", Bold],      {{p1, .3, "p"}, .1, .9, ImageSize -> Tiny, Appearance -> "Labeled"},      Delimiter,      Style["number of samples", Bold],      {{numsamples, 100, ""}, 50, 200, 10, ImageSize -> Tiny,        Appearance -> "Labeled"},      Style["number of iterations\nof EM algorithm", Bold],      {{numiterations, 3, ""}, 1, 20, 1, ImageSize -> Tiny,        Appearance -> "Labeled"},      Delimiter,      {{sr, 326, "random seed"}, 1, 9999, 1, ImageSize -> Tiny,        Appearance -> "Labeled"},      ControlPlacement -> Left,      Initialization :> (        problists[\[Theta]_, y_] := Block[{probs, totalprobs},          probs =            Table[\[Theta][[3, i]]*             Map[PDF[Apply[NormalDistribution, \[Theta][[i]]], #] &,               y], {i, 2}];          totalprobs = Total[probs];          Map[#/totalprobs &, probs]];        pi[j_, p_] := Mean[p[[j]]];        emu[sim_, j_, p_] := Total[sim*p[[j]]]/Total[p[[j]]];        emstd[sim_, j_, u_List, p_] := Total[(sim - u[[j]])^2*p[[j]]]/         Total[p[[j]]];        em[params_, sim_] := Module[{theprobs, mus, vars, probs},          theprobs = problists[params, sim];          mus = Map[emu[sim, #, theprobs] &, {1, 2}];          vars =            Map[emstd[sim, #, params[[1 ;; 2, 1]], theprobs] &, {1, 2}];          probs = Map[pi[#, theprobs] &, {1, 2}];          Append[Transpose[{mus, vars^.5}], probs]];        )]}


How to generate patterns by a list of integers

I have a list of integers `{3,4,2,2}`. This list will give patterns `{x_,_,y_,y_,_,_,z_,z_,w_,w_,x_}` and `{0,0,0,1,1,1,1,0,0,1,1}`. Notice that I want to assign successive `0,1` with the same symbol. How to make this? *edit Compare the patterns               {x_,_,y_,y_,_,_,z_,z_,w_,w_,x_}     {0, 0, 0,1, 1,1, 1,0,  0,1, 1 }     {1, _, 2,2, _,_, 3,3,  4,4, 1 }      Suppose I have symbols `{x_,y_,z_,w_}` (you may use `{a_,b_,c_,d_,...}`). To transform `lst={3,4,2,2}` to `{x_,_,y_,y_,_,_,z_,z_,w_,w_,x_}`, begin with `{x_,_,_,_,_,_,_,_,_,_,_}`. Then put `y_` at positions `lst[[1]]` and `lst[[1]]+1`. Then put `z_` at positions `lst[[1]]+lst[[2]]` and `lst[[1]]+lst[[2]]+1`. Then put `w_` at positions `lst[[1]]+lst[[2]]+lst[[3]]` and `lst[[1]]+lst[[2]]+lst[[3]]+1`. And finally put `x_` at the last position.


Image Processing: Finding Orientation and Position of Symmetry Axes

**Background** I'm currently toying with Principles of Design by Charlotte Jirousek in order to learn some basics of image processing. As main principals she suggests Balance, Proportion, Rhythm, Emphasis and Unity. I'm particularly interested in **Balance**. According to her definition: Balance is the concept of visual equilibrium, and relates to our physical sense of balance. It is a reconciliation of opposing forces in a composition that results in visual stability. Most successful compositions achieve balance in one of two ways: symmetrically or asymmetrically. Balance in a three dimensional object is easy to understand; if balance isn't achieved, the object tips over. To understand balance in a two dimensional composition, we must use our imaginations to carry this three dimensional analogy forward to the flat surface. ![Sample 2](http://i.stack.imgur.com/hw3vM.gif) Symmetrical balance can be described as having equal "weight" on equal sides of a centrally placed fulcrum. It may also be referred to as formal balance. When the elements are arranged equally on either side of a central axis, the result is Bilateral symmetry. This axis may be horizontal or vertical. It is also possible to build formal balance by arranging elements equally around a central point , resulting in radial symmetry. ![Sample 2](http://i.stack.imgur.com/lSEfx.gif) There is a variant of symmetrical balance called approximate symmetry in which equivalent but not identical forms are arranged around the fulcrum line. ![Sample 3](http://i.stack.imgur.com/ImbiH.gif) **Question** How can I find Orientation and Position of Symmetry Axes of the given figures? **Solution Directions** In fact this question meant to be a toy example for image processing. However, after some investigation this turns out to be a challenging subject in it self.See the link for related papers submitted and published in both computer vision and computer graphics as well as changing test images.   * Jens has a quite inspiring approach explained in his post.   * An alternative approach is suggested by Changming Sun, Deyi Si Fast Reflectional Symmetry Detection Using Orientation Histograms. In this approach Gradient Orientation Histogram is used.               o = Flatten@ImageData@GradientOrientationFilter[imag, 3];     w = Flatten@ImageData@GradientFilter[imag, 3];     \[ScriptCapitalA] = WeightedData[o, w];     \[ScriptCapitalD] = HistogramDistribution[\[ScriptCapitalA]];     t = Table[{x, PDF[\[ScriptCapitalD], x]}, {x, -\[Pi]/2, \[Pi]/2, 0.05}];     Max[t\[Transpose][[2]]]      As explained in the paper this gives the axes. Also available in Mathematica GradientOrientationFilter examples.   * Another approach could be based on component in Mathematica which may require additional image processing.


Can you recommend an efficient method for finding the least integer satisfying my inequality?

I tried find the minimum make $\frac{1}{2}+\frac{1}{2+\sqrt{2}}+\frac{1}{3 +\sqrt{3}}+...+\frac{1}{n+\sqrt{n}}>15$ Following code is so slow when I use condition               NestWhile[# + 1 &, 1, NSum[1.0/(i + Sqrt[i]), {i, #}] < 15 &]          Catch@Fold[If[#1 > 15, Throw@#2, #1 + 1.0/(#2 + Sqrt[#2])] &, 0.0,         Range[10^7]] // Timing      but these two are fast without condition               NSum[1.0/(i + Sqrt[i]), {i, 10^7}]          Fold[# + 1/(#2 + Sqrt[#2]) &, 0.0, Range[10^7]]      How can I improve my code make it efficiency if dont't use compilation? # Update: Use Bisection_method               num = 15;     f[x_] := NSum[1/(i + Sqrt[i]), {i, x}];     n = NestWhile[# + 1 &, 1, f[10^#] < num &]     min = 10^(n - 1);     max = 10^n;     mid = Round[(min + max)/2];     While[Abs[f[mid] - num] > 10^-6,        If[f[mid] >= num, max = mid - 1];       If[f[mid] <= num, min = mid + 1];       mid = Round[(min + max)/2];     ];     {min, mid, max}     Clear["`*"]


How does Plot work?

I considered the following function:               sin[x_] := Module[{},       Print["x=", x];       Sin[x]     ]      in _Mathematica_. Next, I tried to plot it using:               Plot[sin[t], {t, 0, 2 Pi}]      Surprisingly, the first three lines of output are:               x=0.000128356     x=t     x=1.28228*10^-7      Can someone explain this behavior? In this case it doesn't cause a problem, but in my "real" case it does. ### Summary acl's answer below offers, at its very beginning a solution to the specific problem. In very-short, the reason that this `x=t` appears is hidden somewhere in the way _Mathematica_ evaluates the functions. The answers below provide interesting insight into the way it works. The interested reader _should_ read all the answers and details below, they are invaluable, although might be behind the reach of some of the readers (like, partially, in my case).


Failing to import an .eps file

I have an .eps file which was created using GLE. There is nothing wrong with the file, GS View can read it correctly. However, when I use Mathematica to read it using               Import["dcl.eps"]      it returns `$Failed`. The particular .eps file can be found here EPS file I want to read this eps file so as to rasterize it, thus reducing its size. I'm using Mathematica v 9.0 under Win XP. Any ideas why Mathematica cannot read this file?


Extract data from WeatherData as a list of associations

Given weather data for 2013 and 2014 as follows:               t =        QuantityMagnitude[         WeatherData["California", "MeanTemperature", {{2013, 1, 1}, {2014, 1, 1}, "Day"}]          "Values"]];      how can I get the average temperature for each day during 2 years as a list of associations, for example: > >     January 1 -> 12 >      ... >      December 31 -> -20 >


How to count the integer grid numbers defined by inequalities?

I have the following code to show a red area defined by inequalities:               ClearAll["Global`*"];     p = Reduce[y <= 3/10 x + 18 && y > x^2/8, {x, y}]     r = RegionPlot[p, {x, -15, 18}, {y, -5, 25},         GridLines -> {Table[i, {i, -15, 18}], Table[j, {j, -5, 25}]},         PlotStyle -> Directive[{Opacity[0.5], Red}]];     bg = Graphics[{Opacity[0.2], Yellow, Rectangle[{-16, -6}, {19, 26}]}];     range = First /@        Differences /@ (PlotRange /. Options[r]); target = 1; Show[{r, bg},       AspectRatio -> (Last[range]/First[range]/target)]      which shows: ![enter image description here](http://i.stack.imgur.com/7KHXQ.png) How can I count those integer grids and highlight them with colored dots?


If statement condition based on variable without value does not cause error

This code works as expected:               isDefined = 2;     x = 1;     For[i = 1, i <= 3, i++,         If[x + i > isDefined, x = 100];         Print[StringJoin["i = ", ToString[i], ", x = ", ToString[x]]];     ]      It produces output:               i = 1, x = 1     i = 2, x = 100     i = 3, x = 100      This code does not work as I would expect it to:               x=1;     For[i=1,i<=3,i++,         If[x+i>notDefined,x=100];         Print[StringJoin["i = ",ToString[i],", x = ",ToString[x]]];     ]      It produces output:               i = 1, x = 1     i = 2, x = 1     i = 3, x = 1      In both, it starts with `x = 1`, so when `i = 2`, `x + i = 3 > 2`. Since 2 is the value assigned to the variable `isDefined`, `x` is set equal to 100. The second example is the same code, except instead of comparing `x + i` with the variable `isDefined`, it compares `x + i` with the variable `notDefined`, a variable I never defined. Instead of giving an error message and stopping, or somehow indicating that I told it to compare the value of `x + i` with something that has not been assigned a value, it keeps right on going and never gives any indication that anything is wrong. In the real code on which this example is based, I have lots of input data and I create output data based on calculations and conditions using the input data. I changed a variable name but accidentally left the old name in an if statement. The result was output that looked like the condition had never been met, when actually Mathematica just did what it did in the example above. Some programming languages won't compile/run if you try to do something like this, and if they don't do this by default, there's an option to specify that they shouldn't compile/run. I've looked through the preferences and online and can't find anything about this. I'd like to avoid the incorrect output that results from this problem. Does anyone have any ideas (other than the obvious solution of not making mistakes in the first place)?


Mathematica list element sort

I have a list, say,               cc = {{0.16441114380905922, 1}, {0.16441114380905922, 2},           {-0.16441114381135857, 4}, {0.3469323902621586, 3},           {-0.3469323902254179, 2}, {-0.26126804383825986, 3},           {0.2612680438599802, 2}, {-0.28969854537720147, 3},           {0.28969854538168743, 2}, {-7.968690709137364, 3},           {7.968690708910122, 2}, {-4.000091496006696, 3},           {4.000091495616817, 2}, {4.729024444062355, 3},           {-4.72902444452141, 2}, {4.729024444062355, 1}}      I want to get the following information:   1. all the $2\times1$ sub-lists with the same first element should be together (e.g., {x,y} and {x,z} should be together)   2. multiplicity of the first elements I am using `Tally` and `Sort` (also used `GatherBy`) but not much help so far. Thanks in advance.


how to use Tooltip with a Dynamic point

consider this example:               LocatorPane[Dynamic[pt],      Plot[Sin[x], {x, 0, 10},        Epilog -> {PointSize[Large], Point[Dynamic[pt]]},        PlotLabel -> Dynamic@pt], Appearance -> None]      I am trying to add `Tooltip` to the `pt` but without any success. the only thing I got is using `Tooltip` with the point like this: `Tooltip@Point[Dynamic[pt]]` but this will show the word `Point` also. any solution to use Tooltip with the point `pt` thanks


Solve[polynomial, x, Reals] doesn't get all real roots or correct ones?

_My main confusion is about the difference between the two code blocks at the end of this long spiel, but the spiel contains the code to create the polynomial if its coefficients are helpful for explaining the difference. Thanks in advance!_ I have this polynomial, `eu1-eu2`, of degree `n` (where `n` is a multiple of `3` between `3 and 93`, inclusive).               solutions = Simplify[Solve[eu1 == eu2]];     solutions = p /. solutions;     Select[solutions, Element[#, Reals] &]      and               p /. Simplify[Solve[eu1 == eu2, p, Reals]]      should return the same roots, from what I can tell. And they do, for lower values of `n`. But as `n` increases, at some point they start returning slightly different roots, and later on, the first code block returns a bunch of different roots while the second one usually returns one root repeated many times. As `n` increases, the second one's repeated root seems to be farther away from any of the roots gotten from the first one. The first one probably gets the true roots, since the size of "solutions" (which includes complex roots) equals `n`. But then what number is the second one getting? * * * Edit: `30` is the smallest `n` for which the number of roots is the same but the roots themselves are slightly different. Here the first method produces `{0.333794}` whereas the second produces `{0.333788}`. `33` is the smallest `n` for which the number of roots is different for each method. Here the first method produces `{0.251609, 0.251683, 0.273157, 0.274114, 0.3336}` whereas the second produces `{0.33363}`. * * * Edit: The code that sets up the polynomial is as follows:               n = 93;     q1 = (n - Mod[n, 3])/3;     q2 = q1;     upperbound = 0.5;          (mat1 = Array[0, {n, 3}];     prob1 = Array[0, {n, 1}];     prob2 = Array[0, {n, 1}];     prob3 = Array[0, {n, 1}];     For[m = 0, m <= n - 1, m++,     If[m + 1 - q1 != 0,      prob1[[m + 1, 1]] = q1/(m + 1);     prob2[[m + 1,      1]] = ((q2 - (n - m - 1))/(m + 1 - q1))*(1 - q1/(m + 1));     prob3[[m + 1, 1]] = 1 - prob1[[m + 1, 1]] - prob2[[m + 1, 1]];     mat1[[m + 1]] = {prob1[[m + 1, 1]], prob2[[m + 1, 1]],      prob3[[m + 1, 1]]},     mat1[[m + 1]] = {0, 0, 0}]])          (mat = Array[0, {n, 3}];     For[m = 0, m <= n - 1, m++,     If[m + 1 <= q1,      mat[[m + 1]] = {1, 0, 0},     mat[[m + 1]] = mat1[[m + 1]]]])          (mat3 = Array[0, {n, 3}];     prob4 = Array[0, {n, 1}];     prob5 = Array[0, {n, 1}];     prob6 = Array[0, {n, 1}];     For[m = 0, m <= n - 1, m++,     If[m + 1 - q2 != 0,      prob4[[m + 1,      1]] = ((q1 - (n - m - 1))/(m + 1 - q2))*(1 - q2/(m + 1));     prob5[[m + 1, 1]] = q2/(m + 1);     prob6[[m + 1, 1]] = 1 - prob4[[m + 1, 1]] - prob5[[m + 1, 1]];     mat3[[m + 1]] = {prob4[[m + 1, 1]], prob5[[m + 1, 1]],      prob6[[m + 1, 1]]},     mat3[[m + 1]] = {0, 0, 0}]])          (mat2 = Array[0, {n, 3}];     For[m = 0, m <= n - 1, m++,     If[m + 1 <= q2,      mat2[[m + 1]] = {0, 1, 0},     mat2[[m + 1]] = mat3[[m + 1]]]])          u = {{1 - p}, {p}, {0}};          (eu1 = 0;     For[m = 0, m <= n - 1, m++,     eu1 = eu1 + (mat[[m + 1]].u)*(p/upperbound)^     m*(1 - p/upperbound)^(n - m - 1)])     eu1 = Simplify[eu1];          (eu2 = 0;     For[m = 0, m <= n - 1, m++,     eu2 = eu2 + (mat2[[m + 1]].u)*(p/upperbound)^(n - m - 1)*(1 -      p/upperbound)^m])     eu2 = Simplify[eu2];      Also note that the following code results in the same solutions as the first code block:               Simplify[Solve[eu1 - eu2 == 0 && p < 15000, p, Complexes]]      Whereas this code results in the same solutions as the second code block:               Simplify[Solve[eu1 - eu2 == 0 && p < 15000, p, Reals]]      So it's something about allowing the function values to be complex vs. not allowing them to be complex. But I don't understand why my function would ever be complex when p is restricted to be real, since all of the coefficients are real. Also, how exactly does it restrict function values to be real while it's solving for the roots? And why are the roots different from the case where complex function values are allowed? Sorry that this is kind of a mess, but I would really appreciate any help you can provide!


How to "merge" various graphics 2d into one 3d graphic?

I did some calculations and as result got a 2D graphic, but at the beginning of the work I used a constant parameter. What I want is to make a 3D graphic with this parameter as an axis, varying from 1 to 100. How to proceed?


Input[] inside DynamicModule causing a kernel crash

I have those few lines of code causing a crash and I can't figure out why:               DynamicModule[{openNothing},      EventHandler[       Panel@Row@{          Button["Built In Funct", openNothing[]]}, {}],           Initialization :> (openNothing[] := (Input["bla", 1];))]      _Mathematica_ freezes for a few seconds and then says: > The kernel is not responding to a Dynamic Evaluation. [...] **WARNING:** It did make _Mathematica_ not responding at all. After the **force quit** the list of the recently opened notebooks were removed (I assume that the `~/.Mathematica/FrontEnd/init.m` has been removed.) I'm on _Fedora 19_ , _Mathematica_ 8.0.4. The same issue has been noticed under _Windows 7_ , _Mathematica_ 9.


Parametric Equation with restrictions on the independent variable

I'm sorry if this question was answered but I am completely new to _Mathematica_ , really learning as I go (background in Java). The questions I looked at that were suggested didn't make much sense with all the advanced parts being thrown around. For a Pre Calculus class I need to graph parametric equations. However, one of the questions is:               x = 2t     y = t + 5      with `-2 ≤ t ≤ 3`. How would I do this? So far I know the basic equation but I don't get the part with having the piecewise               ParametricPlot[{ 2 t, t + 5}, {t, -10, 10}]


Why is Plot3D giving me a surface with gaps?

I am trying to get plot for the band structure for graphene.               d = 10; (*Plot range*)      coupling := {{0, 2 Cos[Sqrt[3]*(#1)/2]*Cos[#2/2] + Cos[#2] +      I (2 Cos[Sqrt[3]*(#1)/2]*Sin[#2/2] - Sin[#2])},      {Conjugate[ 2 Cos[Sqrt[3]*(#1)/2]*Cos[#2/2] + Cos[#2] +         I (2 Cos[Sqrt[3]*(#1)/2]*Sin[#2/2] - Sin[#2])], 0}} &;     Plot3D[Eigenvalues[coupling[kx, ky]][[1]], {kx, -d, d}, {ky, -d, d}] (*Discontinuous*)     Plot3D[(Eigenvalues[coupling[kx, ky]][[1]])^2, {kx, -d, d}, {ky, -d, d}] (*Continuous*)      I am not able to understand why the surface in the first plot is coming out discontinuous; i.e., it has some gaps in the surface plot, whereas there are no gaps in the second plot, which simply plots the square of the function shown in the first plot. There is no physics that explains the gaps. Also, the effect is not periodic/predictable. By that I mean that on changing `d`, I am getting very different patterns of gaps all over the place. Is there some problem with my code or is 3D plot working incorrectly? How do I get rid of this error? ### Edit I am NOT talking about the spike at (0,0). I am attaching a picture of my plot for clarity. I am talking about the "ribbons" missing from the surface. ![enter image description here](http://i.stack.imgur.com/BdqjN.jpg) There are no "ribbons" in the case of the squared plot. ![enter image description here](http://i.stack.imgur.com/4T04v.jpg)


RandomVariate does not fill range of PDF of distribution

I've declared my own probability distribution as follows               dist[a_, b_] := ProbabilityDistribution[Cos[(b x)/2]^2 Sinc[a x]^2, {x, -400, 400}];      When I try to create a random variate using this probability distribution I only get data points in a range (-400, -245).               data = RandomVariate[dist[200, 500], 10^4];     Histogram[data, 200, "ProbabilityDensity"]      ![Histogram of prob. dist.](http://i.stack.imgur.com/suMFe.png) Just to clarify, this isn't an issue with the histogram, when I look at `data` it does only contain numbers in the range seen above.


Restrict SystemDialogInput to open certain file types

The documentation for `SystemDialogInput` shows how to restrict the types of files shown.               SystemDialogInput["FileOpen",".nb"]      ...only shows _Mathematica_ notebook files. This also works for other file extensions such as ".txt", ".html", etc., but doesn't work for other file types. If I have a tab delimited file that with extension ".data" and try:               SystemDialogInput["FileOpen",".data"]      ...the dialog box defaults to all files. Is there a way to only show other "non-standard" file types?


Evaluate outer function first

I'm new in Mathematica so this is maybe super easy to do, but I can't figure out how. I've got a function `plus[a,b]` that sums two numbers and I need to implement a function `derivation[a]` that will derive the input like this:               derivation[e_Integer] (* returns 0 *)     derivation[x] (* returns 1 *)      I've got a problem with this rule:               derivation[plus[a, b]] := plus[derivation[a], derivation[b]];      When I implement it this way, it doesn't work because plus is evaluated before derivation. I.E. `derivation[plus[x, 3]]` should return `1`. Is there some other way how to implement it?


How to batch rename a directory of files?

I have a directory of files with the pattern: `"some_number.some_name.pdf"` I want to remove the `"some_number."` part from all the files. How to do that? There are a few commands in my head: `FileNames`, `Map`, etc. But I don't know how to chain them together to achieve the task. Thanks in advance.


Exported graphics texture to eps is too dark

Why is the exported graphics eps file so dark? It looks much lighter (and better) as the Mathematica output appearing the notebook. After running               Map[SetOptions[#,       Prolog -> {{EdgeForm[], Texture[{{{0, 0, 0, 0}}}],         Polygon[#, VertexTextureCoordinates -> #] &[{{0, 0}, {1,            0}, {1, 1}}]}}] &, {Graphics3D, ContourPlot3D,       ListContourPlot3D, ListPlot3D, Plot3D, ListSurfacePlot3D,       ListVectorPlot3D, ParametricPlot3D, RegionPlot3D, RevolutionPlot3D,      SphericalPlot3D, VectorPlot3D, BarChart3D}];      and then trying to export               contourPotentialPlot2 =       ContourPlot[-3600. h^2 + 0.0297 h^4 - 5391.9 s^2 + 0.275 h^2 s^2 +       0.375 s^4, {h, -400, 400}, {s, -300, 300},       PlotRange -> {-1.4*10^8, 2*10^7}, Contours -> 15,       ContourStyle -> AbsoluteThickness[1], Axes -> True, Ticks -> None,       AxesStyle -> AbsoluteThickness[3], PlotPoints -> 30,       PlotRangePadding -> 0, Frame -> False,      ColorFunction -> "BrassTones"];          potential2 =        Plot3D[-3600. h^2 + 0.0297 h^4 - 5391.9 s^2 + 0.275 h^2 s^2 +        0.375 s^4, {h, -400, 400}, {s, -300, 300},        PlotRange -> {-1.4*10^8, 2*10^7}, ClippingStyle -> None,        MeshFunctions -> {#3 &}, Mesh -> 15,        MeshShading -> {{RGBColor[1, 1, 0]}, {RGBColor[1, 1, 1]}},        Lighting -> "Neutral"];          level = -1.4 10^8;      gr = Graphics3D[{Texture[ImageData[Rasterize[contourPotentialPlot2]]],        EdgeForm[], Polygon[{{-400, -300, level}, {400, -300, level}, {400, 300,        level}, {-400, 300, level}},        VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]},        Lighting -> "Neutral"];          pot2 = Show[potential2, gr, PlotRange -> All, BoxRatios -> {1, 1, .5},       FaceGrids -> {Back, Left}, Axes -> None, Boxed -> True,        Lighting -> "Neutral"]     Export["pot2.eps", pot2]      It looks like the first image below in the notebook file, but as an exported eps file, looks much darker as in the second image. How do I fix this? ![Mathematica output](http://i.stack.imgur.com/I19s3.png) ![Output file](http://i.stack.imgur.com/83T8z.png)


Function WeatherData fails

If I use WeatherData[] only some of my requests work. For example if I use               WeatherData[{"Chicago", 3}]      I get the correct output:               {"C3175", "KCGX", "C8163"}      But if I try               WeatherData["Chicago", "Temperature"]      I get:               $Failed      Other Collections of Curated Data like ChemicalData[] work fine, so I don't think it's a connection problem.


Strange phenomenon with Outer

Outer[Plus, ##] & @@ Array[{1, 2, 6, 24, 120, 720, 5040, 40320, 362880} &, 6]; // AbsoluteTiming     (* {0.979056, Null} *)          Outer[Plus, ##] & @@ Array[Range[9]! &, 6]; // AbsoluteTiming     (* {0.952055, Null} *)          Outer[Plus, ##] & @@ Array[Gamma[Range@9 + 1] &, 6]; // AbsoluteTiming     (* {0.010001, Null} *)      See the elapsed time, I used v9 on Win7 32bit. On v8, both of them are slow. How to explain this? Is it possible to make it faster on v8?


Construct a sum that evaluates its arguments but doesn't evaluate further

I'm trying to construct a sum like this:               Sum[body, range]      where `body` is $$\frac{1}{\sqrt{n!}}+\frac{1}{\sqrt{(n+1)!}}+\frac{1}{\sqrt{(n+2)!}}+\frac{1}{\sqrt{(n+3)!}}$$ and range is $\\{n,0,\infty \\}$.               body = 1/Sqrt[n!] + 1/Sqrt[(1 + n)!] + 1/Sqrt[(2 + n)!] + 1/Sqrt[(3 + n)!];      range = {n, 0, Infinity};      This can be done by               Sum[Evaluate@body, Evaluate@range]      Out==>$$\sum _{n=0}^{\infty } \left(\frac{1}{\sqrt{n!}}+\frac{1}{\sqrt{(n+1)!}}+\frac{1}{\sqrt{(n+2)!}}+\frac{1}{\sqrt{(n+3)!}}\right)$$ But _Mathematica_ takes a long time attempting to compute the sum, which I don't need it to do. Is there a way to prevent the computation of the sum but still evaluate the `body` and `range` parts? I tried the Trott-Strzebonski in-place evaluation trick:               HoldForm[Sum[body, range]] /. Sequence[x__] :> RuleCondition[Evaluate[x]]      But it didn't work. Where did I do wrong?


Compact form for domain ranges of many variables

When one sets up an equation to solve one often needs to specify conditions on the variables such as               { x>0 && y>0 && z>0 }      This is not a problem if only a few variables are involved. However, it is another matter when say, 50 are required. Is there a compact form one can use? Using               (...) && Table[x[[i]], {i,50}] > 0      within `Reduce[]` or `Solve[]` will not work.


Wrapper for inexact numeric complex numbers that maintains polar form

Related question: How can I convert a complex number a+b I to the exponent form A Exp(I phi)? _Mathematica_ insists on displaying complex number in form `a+I b` when `a` or `b` are not exact:               Clear["Global`*"]     z = 3 + 4 I;     Abs[z] Exp[I Arg[z]]      ![Mathematica graphics](http://i.stack.imgur.com/bDDfo.png)               z = 3.0 + 4 I;     Abs[z] Exp[I Arg[z]]      ![Mathematica graphics](http://i.stack.imgur.com/bbKpq.png) What I'd like is a `polarForm` wrapper that keeps the polar form even when `a` or `b` are not exact, like this:               Clear["Global`*"]     (z = 3.0 + 4 I) // polarForm      ![Mathematica graphics](http://i.stack.imgur.com/VSOB1.png)               (z = 3 + 4 I) // polarForm      ![Mathematica graphics](http://i.stack.imgur.com/LT0Dp.png) In the above, `polarForm` is the wrapper needed.


ParallelTable not firing

In[42]:=      ParallelTable[onePathList[s, parametri], {s, {1, 2, 3, 4}}]; // AbsoluteTiming          Out[42]= {14.771845, Null}          In[43]:=      Table[onePathList[s, parametri], {s, {1, 2, 3, 4}}]; // AbsoluteTiming          Out[43]= {14.649838, Null}      I am also watching on the ParallelKernelStatus window and on the TaskManager (I am on a Windows 7 machine with 8 physical cores) and there is zero sign of the parallel kernel running. On the other hand, 4 of them do start up when evaluating the ParallelTable cell the first time. (I have default options in config, and limited to 4 cores by licence). The function onePathList is defined in a package (see below for details) The vector "parametri" is a vector of real numbers, e.g. `parametri={333.333,333.333,116.667,1,0,1,18,0.001}` Any help greatly appreciated, thanks PS Function definitions from package               onePathList[\[Sigma]_, params_] :=      With[{Tmax = params[[7]], dt = params[[8]]},     RandomFunction[proc[\[Sigma], params], {0, Tmax, dt}]["PathStates"]]          proc[\[Sigma]_, params_] := With[{x0 = params[[6]]},     ItoProcess[{totForce[x, t, params], \[Sigma]}, {x, x0}, t]]          totForce[x_, t_, params_] :=      With[{a = params[[1]],      b = params[[2]], \[ScriptCapitalA] = params[[3]], \[Omega] =      params[[4]], \[Alpha] = params[[5]]}, (a x -      b x^3 + \[ScriptCapitalA] Sin[\[Omega] t + \[Alpha]])]


How to release $Mathematica$ from the $Pre HoldAllComplete lock

Not sure if posted before, but I'm asking this question from a _Mathematica_ fellow user who tried to load expressions, whose problem soon turned into a prison break game featuring the following code.               SetAttributes[hold, HoldAllComplete];     GetOut /: hold[GetOut] := Unset[$Pre];          $Pre = hold;      After executing this code, all subsequent evaluations are hold, including the GetOut "key" and the reset expression.               GetOut     $Pre = .      Are there any ways to unhold subsequent evaluations, in addition to rebooting _Mathematica_?


Curvature Manipulation: Vector Evaluation Error

I am building a mathematical simulation of curvature that will show the Osculation circle at each point on a curve. However my code keeps coming up with errors and `Manipulate` doesn't evaluate `r[[1]]`. I believe it keeps it as just an expression. It says: > Part::partd: Part specification r[[1]] is longer than depth of object. >>               r[t_] := {Cos[t], Sin[t]}     uT[t_] := Simplify[r'[t]/Norm[r'[t]], t \[Element] Reals]     x[t_] := r[[1]]     y[t_] := r[[2]]     OlcusionPoint[t_] :=       x[t](*-((((x'[t])^2+(y'[t])^2)*y'[t])/((x'[t]*y''[t])-(x''[t]*y'[       t])))*)// Evaluate     OclusionPoint2[t_] :=       y[t](*+((((x'[t])^2+(y'[t])^2)*x'[t])/((x'[t]*y''[t])-(x''[t]*y'[       t])))*)// Evaluate          Manipulate[      Show[Graphics[{RGBColor[0.6, 0.6, 0.8],          Disk[{OlcusionPoint[t], OclusionPoint2[t]},           Abs[1/(uT[t]/r'[t])]]}],        ParametricPlot[{Cos[t], Sin[t]}, {t, 0, 2 Pi}],        Graphics[{PointSize[.025], Point[{Cos[t], Sin[t]}]}]], {t, 0, 2 Pi}]


Plot isn't outputting a plot

I am trying to plot the magnitude complex function (f) with respect to w. For some reason, Plot is just displaying a set of axes, with no points. Any Idea what's going on here?               z02 = 50*2^.5     z01 = 50     z1 = 100     zin = z02*(zl + \[ImaginaryJ]*z02*tan (w))/(z02 + \[ImaginaryJ]*zl*tan (w))     gamma = (zin - z01)/(zin + z01)     f = abs[gamma]          Plot[abs[gamma], {w, 0, 6.28}]      Thanks!


RLink Java(TM) platform has stop working

I am trying to send to R a big function,it has only three variables but output is quite big.So when i "translate" that code from mathematica to look like R code and input it in REvaluate i get the popup window thats telling me that java(tm) platform se binary has stopped working.I succeeded the similar thing with same amount of code length but with this one I can't and I can't figure out what's wrong. Here is the code that's making trouble:               ClearAll[sigmasqr, a, ll, sll];     s = FinancialData["^gspc", "FractionalChange", {"2005/01/01", "2009/12/31"}][[All, 2]];          R[t_] := s[[t]]          sigmasqr[1, w_, a_, b_] = Variance[s]          sigmasqr[t_, w_, a_, b_] := w + a R[t - 1]^2 + b sigmasqr[t - 1, w, a, b]          ll[t_, w_, a_, b_] := -.5 (Log[2 \[Pi]] + Log[sigmasqr[t, w, a, b]] + R[t]^2/      sigmasqr[t, w, a, b]) // N          sll = Sum[ll[t, w, a, b], {t, 2, 100}];      So sll is a log likelihood sum for 100 returns,now I want to create a function that can be used in R's optim from this sll.Here is the code:               REvaluate["a1=function(w,a,b){" <> StringReplace[ToString[sll//InputForm], {"[" -> "(", "]" -> ")",      "L" -> "l", "*^" -> "*10^"}] <> "}"]      And here is where problem starts.. I found that the troublesome part starts from part 48 of the sum                   REvaluate["a1=function(w,a,b){" <> StringReplace[ToString[sll[[1;;47]]//InputForm], {"[" -> "(", "]" -> ")",      "L" -> "l", "*^" -> "*10^"}] <> "}"]      If you check you will see that it runs perfectly,but now if you run:                   REvaluate["a1=function(w,a,b){" <> StringReplace[ToString[sll[[48]]//InputForm], {"[" -> "(", "]" -> ")",      "L" -> "l", "*^" -> "*10^"}] <> "}"]      you will get a java platform stop working message.Is there a solution to this problem? I should say that I pasted the troublesome part in R to check did I forgat to change something in the form of code but,no it's working in R.


sum polynomial H(x,y)

I want to write and evaluate an expression something like $$H_1=\sum_{i+j=0}^3 e_{ij}x^iy^j$$ or $$H=\frac{\sum_{i+j=0}^3 e_{ij}x^iy^j}{\sum_{i+j=0}^3 a_{ij}x^iy^j}$$ with correct syntax.


Why does this integral have a complex component?

I wanted to find the probability of my normally-distributed random variable being at least 15, so I set up this integral:               Integrate[PDF[NormalDistribution[14, 3.7], x], {x, 15, Infinity}]      Imagine my surprise when I got this result:               0.393476 - 1.75334*10^-15 I      Granted, the angle is miniscule. But why is Mathematica producing this result? This happens even if I type in the PDF manually:               0.107822 E^(-0.036523 (-14 + x)^2)      My TI in rectangular mode returns a result equal to the real component of what Mathematica produces. No complex component. It doesn't make sense for a real-valued function to have complex area anyway. What's going on here? Whenever I see e's and i's in the same room I tend to blame Euler, but I'm having trouble figuring out what Mathematica is doing. Using the "proper" Mathematica command for computing this probability returns a value that agrees with my calculator.               Probability[15 <= x, x \[Distributed] NormalDistribution[14, 3.7]]      I just want to know why Mathematica thinks the integral has complex area.


Solve failing and not clear why

I define the function:                w[q_, n_, a_] := q/(4 Pi n r^2) (1 - Exp[-2 r/a] (2 (r/a)^2 + 2 (r/a) + 1))      I then want to solve:                q = 1.6*10^(-19);      n = 8.85*10^(-12);      a = 0.529*10^(-10);      Solve[w[q, n, a] == 1000, r]      This does not work and I do not understand why. I think there is a solution. Any ideas?


Unexpected Plot3D behaviour

The following illustrates what appears to be an incorrect `Plot3D` for this polynomial. I have forced the function to complex argument, changed ranges. In contrast, `ListPLot3D` behaves as expected. Is there something I am missing?               pol1 = x + 1 - x^2 - 2 + 3 x + 4 x^2;     pol2 = -2 Sqrt[x (1 - x^2)];     h[u_] := pol1^2 - pol2^2 /. x -> u      2D plots:               GraphicsColumn[{Plot[h[x], {x, -3, 1},         PlotLabel -> TraditionalForm[h[x]]],       Plot[Abs[h[x]], {x, -3, 1},         PlotLabel -> TraditionalForm[Abs@h[x]]]}, Frame -> All]      ![enter image description here](http://i.stack.imgur.com/ncYWL.png) `Plot3D`:               Plot3D[Abs@h[x + I y], {x, -3, 1}, {y, -1, 1}, Mesh -> None,       PlotPoints -> 100, PlotRange -> {0, 20},       PlotLabel -> Row[{"Plot3D of ", TraditionalForm[Abs@h[z]]}]]      ![enter image description here](http://i.stack.imgur.com/OvpPA.png) This appears to just be a translation of the real valued function along the y-axis and **not** the (or perhaps my) intended outcome...this can be easily confirmed by looking at adding even the smallest imaginary component to any of the 4 real roots. In contrast `ListPlot3D`:               sol = Solve[h[x] == 0, x];     pts = {#, 0, 0} & /@ (x /. sol);     Show[ListPlot3D[       Flatten[Table[{i, j, Abs@h[i + j I]}, {i, -3, 1, 0.1}, {j, -1, 1,           0.1}], 1], MeshFunctions -> (#2 &), Mesh -> {{0}},        MeshStyle -> {Red, Thick}, PlotRange -> {-1, 20}],       Graphics3D[{PointSize[0.04], Point[pts]}],       PlotLabel -> Row[{"ListPlot3D of ", TraditionalForm[Abs@h[z]]}]]      ![enter image description here](http://i.stack.imgur.com/sSfkM.gif) This nicely shows the four real roots and behaves as expected.


Sequence and boolean And

I'm trying to figure out if a calculation result it's a valid result. As it return a matrix, I need to test that every element it's a number, so I thought this could work...               numericTable = Range[12] ~Partition ~ 4;     check=( NumberQ/@Flatten@numericTable) /.List->Sequence ;     And[check]      This should return `True` or `False` depending if exist or not a non-numerical element in the matrix. But it returns               Sequence[True,True,True,True,True,True,True,True,True,True,True,True]      So I don't understand anything, because...               In[]:= Sequence[True,True,True,True,True,True,True,True,True,True,True,True]===check     And[Sequence[True,True,True,True,True,True,True,True,True,True,True,True]]     Out[]= True     Out[]= True      Where's the catch ???


Applying a general formula

We are a group of students who are struggling with transforming this formula to run in mathematica. In fact there are many formulas that we are struggling with, but if we are able to see how this is solved we should be able to see how it is done and apply it to the other formulas ourself. We tried using spares Array but was not able to compute it. ![enter image description here](http://i.stack.imgur.com/XCcXf.png)               Subscript[x, 1]={{1,2}}     Subscript[x, 2]={{1,3}}\[Transpose]     Subscript[x, 3]={{1,4}}\[Transpose]     e={{2,4,5}}\[Transpose]          T is set to 3. and Subscript[w, j]= 1-j/H               1/T\!\(     \*UnderoverscriptBox[\(\[Sum]\), \(t = 1\), \(T\)]     \*SuperscriptBox[     SubscriptBox[\(e\), \(t\)], \(2\)]\)Subscript[x, t]Subscript[x, t]\[Transpose]+1/TUnderoverscript[\[Sum], j=1, H-1]Subscript[w, j]Underoverscript[\[Sum], s=j+1, T]Subscript[e, s]Subscript[e, s-j](Subscript[x, s]Subscript[x, s-j]\[Transpose]+Subscript[x, s-j]Subscript[x, s]\[Transpose])


Plotting multiple curves with multiple axes (>2) on the same plot

I'm attempting to generate a graph that depicts mulitple time series, measured in different units (but with a common time scale) on the same graph. This is a generalization of the familiar 1-plot/scale (1 Plot, 2 Scale/Axis) question. Here is an example of what I'm trying to duplicate: http://home.trainingpeaks.com/athlete/workout/RKDN7DHUWEWZHGI6TCCMKNUSAU By way of background, this graph was data collected by a cycling computer used by a racer in an early stage of the 2014 Tour de France. Briefly, every t seconds, the cycling computer collects and calculates a set of measurements, including speed, temperature, distance traveled, power (in watts), rpm's, elevation, location, etc., along with a time stamp. These are then overlayed onto a single plot, using one of the variables (distance or time usually) as a common x-axis, and with a y-axis reflecting the units specific to that measurement. Doing any pair of these in Mathematica on a 2-scale plot is straightforward, but I'm stumped on how to depict more than 2 in the format shown above. Any suggestions would be most welcome! Cheers, Mark


Measuring execution time of code

How one can measure the execution time (time that is spent for code to finish) of a program in _Mathematica_? I understand that there are general timing functions (Timing, AbsoluteTiming, TimeUsed, etc.) that can be used for measuring CPU or wall time, but I don't know the pros/contras (and caveats) of the different methods.


Permanently set options such as metric units for W|A queries

Mathematica lets me be so lazy that I don't even have to switch to a browser to check the weather report: ![](http://i.stack.imgur.com/ZmUx4.png) The only problem is that it will automatically display the temperature and wind speed in Fahrenheit and miles per hour. Unfortunately I don't speak Fahrenheit and I'd like to see it in Celsius. When using W|A online, it is possible to create a user account and set W|A to metric permanently. Is it possible to set preferences such as this one permanently (at least for the duration of a session) when using W|A from within Mathematica?


How to put Labels in of a list of number in a chart?

I can´t put the labels 0,....,31 in this simple chart on the usual place, or better just over the Top of each bar How should I do?               f1[x_] := 12 x^5 - 975 x^4 + 28000 x^3 - 345000 x^2 + 1800000 x     a = Table[i, {i, 0, 31}]     fa = f1[a]          amix = Table[{i, f1[i]}, {i, 0, 31}]          atext = Table[ToString[i], {i, 0, 31}]     atext     BarChart[amix, ChartStyle -> "DarkRainbow",       ChartLabels -> {atext, Top}]


Is it possible to cause a notebook to be hidden when pressing the close button?

Is it possible to cause a notebook to be hidden (`Visible -> False`) instead of closing it when pressing the close button in the title bar? The `Messages` window seems to work this way. The `Notebooks[]` function will list it even when it is not visible (or it has been "closed"). Is this special behaviour, or is it possible to make any notebook window behave like this? * * * Motivation: As part of a user interface, I would like to gradually collect some information into a notebook (lets call it a "log-notebook"). The visibility of the log-notebook would be toggled with a button. This log- notebook should persist across kernel sessions, but not across front end sessions (it will never be saved).


How can I obtain more significant digits?

I type               f1[x_] := 12 x^5 - 975 x^4 + 28000 x^3 - 345000 x^2 + 1800000 x     N[f1[15.5], 15]      and obtain 3.74112*10^6 BUT It´s not true!!! the result is larger than this solution, I think... BACAUSE...                RealDigits[f1[15.5]]      gives me, the result {{3, 7, 4, 1, 1, 2, 0, 6, 8, 7, 5, 0, 0, 0, 0, 0}, 7} So,... I can´t understand that I tell Mathematica that I want to view 15 significative digits, and Mathematica DON´T show me 15 sgnificative digits!!!, only 6!! How I can obtain more digits???? with N[...] or with //N ??? * * * I can´t understand any differneces in precision with Mathematica               m1 = {15, 4, 8, 23, 10, 9, 5, 18, 30, 21}     m2 = {15`9, 4`9, 8`9, 23`9, 10`9, 9`9, 5`9, 18`9, 30`9, 21`9}     f1[x_] := 12 x^5 - 975 x^4 + 28000 x^3 - 345000 x^2 + 1800000 x     x0 = f1[m1]     x1 = N[f1[m1], 9]     x2 = N[f1[m2], 9]      In the last element of x_ you can see diferrences, and... I don´t know what is the best way to obtain an an result with a concrete number os significative digits. In x2, I tell Mathematica that I want 9 significative digits but the result is different from the last element of x1 and x0 and I don´t know what result is the correct! What´s the best way to obtain the good result with a given precision??, in this concrete situation? If you replace in the las line of code in x2 9 for 12 or 15, you obtain the same result!! I can´t understand the behaivour!!


ToExpression an array

I have a .dat file. I would like to convert a big array of strings(that's what I havein the .dat file) into an array of numbers, for example               a = {{"3,-3,0,5,5,0.000208"}, {"-3,-3,0,5,5,0.000208"},{"3,-3,0,5,5,0.000208"}};      into               b = {{3,-3,0,5,5,0.000208}, {-3,-3,0,5,5,0.000208},{3,-3,0,5,5,0.000208}};      I tried to do               ToExpression[a]      but it does not work. How can I do it? Thanks


Padding of matrix

I want to do padding of matrix               a = {{x,x},{x,u}};       to               b = {{x, x, x}, {x, u, u}, {x, x, x}}          c = {{x, x, x, x}, {x, u, u, u}, {x, x, x, x}, {x, x, x, x}}      and soon... How I can automatically do this?


Controlling output of graphics, the role of ";" and code structure/formatting

";" is described under Compound Expression as a delimiter, such that only the output of the last item in the compund expression is given. Situation: 1/ Print[] produces output whether followed by ";" or not. [Clearly an override is desirable so this makes sense for compound expressions] 2/ When combining graphics using Show[], appending ";" still suppresses output. Since "Show" is as conceptually active as "Print", is there a principle at work here (are there other instances)? 3/ If in procedural code a syntactically complete line is _not_ terminated with a ";", the following line is indented... which means Show[] in the middle of several lines of code upsets indentation and code legibility **Question** : if one has several graphics that one wishes to display without combining them what is the recommended approach, given that multiple Show[] should be separated by ";" but doing so suppresses output. * * * PS There is an incredibly minor-but-irritating-to-the-beginner "quirk" of commenting: semi-colon before comment at the end of code before a closing "]" is marked as a syntax error - is it really? If so, what is the nature of the _error_ (it might just be redundant)?               Block[{a},       Print[a];(*the ; preceding is magenta, but is it really a syntax error?*)]      One is tempted to say the ";" is superflous because the expression is terminated by "]", in which case why is it not still an error when extra line breaks are inserted?               Block[{a}, Print[a];      (*the ; preceding is not magenta, so why is this not a syntax error?*)      ]


How Simplify and Assume can be combined on matrix products?

What I am trying to do is to simplify some expressions involving matrices! The problem is that Simplify[] considers the simplifications based on alphabetical order and everything is Commutative. For instance, let               f[e_] := df*(e^1 + Subscript[C, 2]*e^2 + Subscript[C, 3]*e^3 +       Subscript[C, 4]*e^4 + Subscript[C, 5]*e^5 + Subscript[C, 6]*e^6);      and               fe = f[e]; f1e = f'[e];     u = Simplify[e - (2/3) Series[fe/f1e, {e, 0, 4}]];     f1u = f'[u]; J = (3 f1u + f1e)/(6 f1u - 2 f1e);     v = Simplify[e - J*(f[e]/f'[e])]      In fact, when I call Simplify[] in the above piece of code, Subscript[C, 2], ..., Subscript[C, 6] must be considered as matrices. I mean, Simplify[], assume that all muliplications are Commutative, while there is no such thing for matrices. To tackle this, I also added NonCommutativeMultiply[Subscript[C, 2], Subscript[C, 3], Subscript[C, 4], Subscript[C, 5], Subscript[C, 6]] at the beggining of my code, but once again I could not obtain reliable outputs! For example, we must have $C_2C_3\neq C_3C_2$, or the code must not simplify $C_2C_3C_2$ to $C_2^2C_3$. I also used the way described by Mr.Wizard in http://mathematica.stackexchange.com/questions/17926/why-does-simplify- ignore-an-assumption?newsletter=1&nlcode=83941%7cfd18, but once again the matrix products are commutative? So, is there any way to use Simplify or FullSimplify on matrix expressions involving matrix products to have reliable output simplified expression? Any tips or help will be fully appreciated.


Controlling page breaks

I'm writing a bunch of cells to a new notebook nb and am trying to control the pagebreaks. That is, I want a pagebreak after each `Length[listOef]` number of cells. But sometimes, I get two pagebreaks, depending on which random permutatation of `listOef`.               listOef      contains `"aantalVragen"` number of cells given by the user. Then I use the following code:               nb = CreateDocument[Null, Magnification -> 1.5, ShowCellTags -> False,                                PageHeaders -> {{None, None, None}, {None, None, None}},                               ShowCellLabel -> True];          (*Initialize exported notebook*)     SelectionMove[nb, Next, Cell];     NotebookDelete[nb];          allPermutations = Table[RandomPermutation[aantalVragen], {aantalToetsen}];          Do[      NotebookWrite[nb, Cell["Toets 1." <> ToString[toetsNummer], "Title",                              PageBreakAbove -> True]];      NotebookWrite[nb, Cell[datumToets, "Text"]];      NotebookWrite[nb, Cell["Wiskunde", "Text", TextAlignment -> Right]];      NotebookWrite[nb, Cell["G. Hollander", "Text", TextAlignment -> Right]];           (* Test toetsNummer *)        Do[         NotebookWrite[nb, Permute[listOef, allPermutations[[toetsNummer]]][[vraagNummer]]];         SelectionMove[nb, Previous, Cell];         SetOptions[NotebookSelection[nb],                     CellLabel -> "Vraag " <> ToString[vraagNummer] <> "."];         SelectionMove[nb, After, Notebook])         ,         {vraagNummer, aantalVragen}];           **SelectionMove[nb, Previous, Cell];      SetOptions[NotebookSelection[nb], PageBreakBelow -> False];      SelectionMove[nb, Next, Cell];**      ,      {toetsNummer, aantalToetsen}]          Export[exportAddress, nb];      Why does I sometimes get two pagebreaks? I then check if the last cell of the page has a pagebreak with the code               SelectionMove[nb,Previous,Cell];     Options[NotebookSelection[nb]]      at the end of every inner `Do[]` (which is for every page), but I get an empy list of options, so I don't know if there is a pagebreak or not. Also, I'm not quite sure of the part of the code in ** Bold **: I'm trying to suppress pagebreaks at the end of a page, as I'm doing that with                NotebookWrite[nb,        Cell["Toets 1." <> ToString[toetsNummer], "Title", PageBreakAbove -> True]];      at the beginning of the code. But that doesn't seem to prevent double page breaks, sometimes. Any help/advice on this? Thanks!


How to plot planar graphs as such?

A planar graph is a graph that can be drawn in the plane such that no two edges cross. For example, the graph `Graph[{{1, 2}, {2, 3}, {3, 1}, {1, 4}, {3, 4}, {2, 4}}]` is planar, and can be shown in both of these ways: ![enter image description here](http://i.stack.imgur.com/wQa6X.gif) The layout in the left doesn't have crossing edges and it's immediately obvious that the graph is planar. The layout on the right is what Mathematica gives me by default. **Question:** How can a planar graph be shown without any crossing edges in Mathematica? * * * I expect `Combinatorica`` might have this feature as it has a `PlanarQ` function, but unfortunately the documentation is not included with Mathematica and I have not been able to find out how to do this. Testing whether a `Graph` is planar is possible like this:               << GraphUtilities`     PlanarQ@ToCombinatoricaGraph[someGraph]      Note: The above way of testing planarity is for version 8 or earlier. The `PlanarGraphQ` built-in function was introduced in version 9. * * * Here's a random set of planar graph of different sizes to test on:               << ComputationalGeometry`     graphs = DeleteDuplicates[        Flatten@Table[          Graph@           Union[Sort /@              Join @@ (Thread /@                 DelaunayTriangulation@RandomReal[1, {j, 2}])],          {10}, {j, 4, 10}          ], IsomorphicGraphQ];      * * * To avoid confusion, I'd like to note that the `ComputationalGeometry`PlanarGraphPlot[]` function does not do what I need. It does not lay out a graph. One needs to provide an explicit list of vertex coordinates to it. I have a graph as the input, I know that it's planar, and need a layout algorithm that will draw the graph without intersecting edges.


How to force Compile to return multiple results?

I would like to return two separate values from a compiled function, but _Mathematica_ refuses to use the compiled version. Here is a narrowed-down example:                   cFunc = Compile[{{a, _Integer, 1}}, {a, a.a}];          (*        ==> CompiledFunction::cfex: Could not complete external evaluation at instruction 3; proceeding with uncompiled evaluation. >>            ==> {{1, 1, 1}, 3}     *)      Here `a` and `a.a` are hypothetic intermediate results of some long computation, that must be externalized in order for computation to go on outside the compiled function. I assume it is not possible to return lists that are not uniform (data type and dimensions). Is there any way to return more than one results from a compiled computation?


Setting up TextStyle with initialization cells in Mathematica 6+

It used to be quite straightforward to change the default settings of a notebook in terms of inputs, outputs, text styles and font sizes in previous versions of _Mathematica_ using initialization cells with commands such as `$TextStyle` and `$FormatType`. However, as of _Mathematica_ version 6, functions have been superseded by `BaseStyle`. May I know how to use this new function to accomplish the same?


Workbench Profile[] question

I previously posted this question on Mathgroup but received no response I am using Workbench to profile my code. Suppose I have 2 modules, let's call them A, B (they are too long to replicate here). While running my code, Module B is called repeatedly from A, say in a `Do` loop. Module A is called once. I would like to profile total usage of B (not just one instance), which rules out embedding each call to B in a `Profile[]` statement (as this generates a Profile output for each call). I could, of course, profile A, but the information produced on B would be buried in between timing data pertaining to other parts of A (which for my long module A makes it virtually impossible to understand what's happening in B). Is there a way to accomplish this?


Deploying Mathematica Content Online

I have the following program at home, which draws on a batch of pre-processed files (that are word frequency text files, compiled using `ToLowerCase`, `Tally` and `Sort`. Here is an example of the file that it draws on: `{{"i", 3073}, {"you", 2860}, {"the", 1741}, {"and", 1518}, {"a", 1218}, {"me", 1209}, {"to", 1153}, {"my", 913}, {"t", 855}, {"that", 843}...` and so on. Each file is about ~ 50KB, and it's been generated using `Put` and is thus grabbed using `Get`. I use them for the following program, which essentially plots word frequency for a given year (each year has its own file). It's along a similar lines as the Google ngram viewer, but on a very specific historical dataset.               Manipulate[viewerCount1 = {};      viewerCount2 = {};      SetDirectory["/users/myNAME/desktop/DB/Put/"];      filenames = FileNames["*.txt"];      Do[       input = Get[file];       yearLength = Length[input];       AppendTo[viewerCount1,         If[Length[Flatten[Cases[input, {word1, _}]]] == 0, 0,           Flatten[Cases[input, {word1, _}]][[2]]]/yearLength];       AppendTo[viewerCount2,         If[Length[Flatten[Cases[input, {word2, _}]]] == 0, 0,           Flatten[Cases[input, {word2, _}]][[2]]]/yearLength];       , {file, filenames}];      DateListPlot[{Tooltip[viewerCount1, word1],         Tooltip[viewerCount2, word2]}, {1964}, Joined -> True,        PlotLabel -> "Number of Total Word Appearances by % of All Words",        PlotStyle -> {{Red}, {Blue}}], {{word1, "war",         "First Word (Red)"}}, {{word2, "peace", "Second Word (Blue)"}}]      ![enter image description here](http://i.stack.imgur.com/LDvKW.png) Here's the crux of the question, however. **Is there a good way to deploy this online so other people can access it?** I assume this is too big for the CDF format? Alternatively, _WebMathematica_ sounds promising, but before I upgrade my _Mathematica_ purchase I would love to hear if the community thinks that would be useful. I know that there have been discussions elsewhere about sharing dynamic content with non-Mathematica users, but these seem to not rely on specific external files. Or, am I using the wrong language to deploy the final version of this?


Solving differential equation - initial condition

I want to solve the differential equation:               DSolve[{R''[ρ] + 2 /ρ R'[ρ] + (1 - (l (l + 1))/ρ^2) R[ρ] == 0}, R[ρ], ρ]      This works fine and outputs:               {{R[ρ] -> C[1] SphericalBesselJ[l, ρ] + C[2] SphericalBesselY[l, ρ]}}       But when I add the condition:               R[0] ==0      i.e.               DSolve[{R''[ρ] + 2 /ρ R'[ρ]] + (1 - (l (l + 1))/ρ^2) R[ρ] == 0,     R[0] == SphericalBesselJ[1, 0]}, R[ρ], ρ]      The output is:               { }      Why is this the case?


I constantly find myself with multiple Windows Explorer windows open and it would be wonderful to be able to close them all at once using a Mathematica command. Is it possible to close Windows Explorer from within Mathematica ? The post here makes me think it must be possible: http://stackoverflow.com/questions/7644881/calling-a-command-line-program


HOG descriptor for image processing

I did not find in _Mathematica_ a function for Histogram of Oriented Gradients (HOG) descriptors. Is there any similar function? Do you have an implementation you are willing to share?


How to express Polynomial in a certain format with Mathematica?

**Equations**               A = {{-0.03333, 0, 0}, {0.0667, -0.6799, 0.6667}, {0,     0.3399, -0.3467}};     B = {0.0333, 0, 0};     CC = {1, 1, 1};     myInverse = Inverse[s*IdentityMatrix[3] - A];     P = CC*myInverse*B;     P = P[[1,1]];      **Goal** > Express the polynomial $P$ in the format $\frac{1}{1+\text{something}}$. **Trials** > **1\. Trial:** tried to play with denominator and numerator, FAIL, here. > > **2\. Trial:** tried Solve command but errs, the code here fires the error > with a transfer function $G(s)$ and the picture here. I try to express the > line 146 i.e. the equation $G(s)$ in the form $\frac{1}{1+C}$. How can I > simplify this? Why do I get the error? How can I get the equation for the > $G(s)$ in the requested form? Err report "Solve::ivar: ... is not a valid > variable". > > **3\. Trial:** fixing the preserved-variable problem revealed by Artes's > answer, I get very peculiar answer -- I get empty set!? Why? I should get > some non-empty equation. Notice the line 336 in the picture here.


Calling external commands without showing command prompt on windows

I'm playing around with some code that's calling external command-line commands on a windows platform, and when doing this, the command prompt will pop up quickly and then disappear. This is not a huge bother, if you are calling something once, however if you have a loop running and each call takes some time, it becomes a major annoyance. Consider the following code:                Table[Pause[1/2]; Run[ "dir" ];, {3}];      Is there any way to avoid this behavior, or calling an external program though other methods then by `Run[]`.


Plot A Function Of A Stochastic Process

I am trying to do something very simple in Mathematica 9. I want to play around with option pricing and for that I thought it best to use the new stochastic process functionality. So, first of all I simulate one instance of a geometric brownian motion: $$ \frac{dX_t}{X_t} = \mu dt + \sigma dW_t\\\ dW_t \sim N(0, 1) $$ Which in Mathematica is:               proc = ItoProcess[        \[DifferentialD]x[t]/         x[t] == \[Sigma] \[DifferentialD]w[t] + \[Mu] \[DifferentialD]t,         x[t],         {x, x0},        t,        w \[Distributed] WienerProcess[]];      And here's an example of what I get, when I plot it, assuming $X_0 = 100$. ![Example of a GBM](http://i.stack.imgur.com/UFebR.png) So, okay, when I create a plot of a `RandomFunction` of the process, then I actually plot the `TemporalData` for $X_t$ and not $dX_t$. Cool, whatever. But now I want to plot, say $f(dX_t)$ or $f(X_t)$, where I would like to define $f$ as I see fit. And this is where I hit a brick wall. I have tried looking for hints in the docs or for answers here, but there are no definitive ones or the ones that seem to work. I also feel, that I'm missing something fundamental here. Could somebody kindly suggest an answer or the venue of inquiry?


TreePlot with centered vertexes

I want to draw a tree plot for Euler totient function for this question like the following: ![enter image description here](http://i.stack.imgur.com/N64Zx.jpg) I generate the EulerPhi for first 20 numbers into a list:               list = Map[# -> EulerPhi[#] &, Range[2, 20]]      Then I plot it using this:               TreePlot[list, Bottom, 1, VertexLabeling -> True,  DirectedEdges -> True ]      And the output: ![enter image description here](http://i.stack.imgur.com/bsM9R.jpg) But I want the layout of tree become like the above one so that numbers of form $2^n$ are centered and branches to the left or right. How can I do this? By manually editing the graph the output looks like the following ![enter image description here](http://i.stack.imgur.com/zpmip.jpg) **Updated** I've managed to centralize the powers of $2$ but now the branches aren't placed well.               y = 0; coordinates =       Map[First[#] -> {0, y++} &,       Select[Prepend[list, 1 -> {0, 0}], IntegerQ[Log[2, First[#]]] &]]          {1 -> {0, 0}, 2 -> {0, 1}, 4 -> {0, 2}, 8 -> {0, 3}, 16 -> {0, 4}}      and using `GraphPlot`:               GraphPlot[list, VertexLabeling -> True, DirectedEdges -> True,         VertexCoordinateRules -> coordinates]      ![enter image description here](http://i.stack.imgur.com/3vEvt.jpg) Now, If the branches are placed upper than the root, then the result would be OK.


Home edition: Updates and installing it on a new computer

I cannot find any info concerning the Home Edition on the eligibility   * to receive updates (so e.g. from 9.0.0 to 9.0.1)   * to install it on a more than one computer or on a new computer (I am planning to buy a new one in due time). Could you give me some references or user experience?


TextCell going awry due to ImageResolution (in Mathematica 7)

Can anyone see how to fix this text display? The example is from a larger project. I need to export the graphic at high resolution, but the text is going wrong.               text = StringTake[        ExampleData[{"Text", "DonQuixoteIEnglish"}], {110600, 110914}];          a = Graphics[{{LightBlue, Rectangle[{0, -0.21}, {1, -0.04}]},        Inset[Graphics[{{LightYellow, Rectangle[{0, 0}, {450, 40}]},           Inset[            TextCell[text, LineSpacing -> {0, 16}, TextJustification -> 1],            Center, Center, {450, 40}]},          BaseStyle -> {FontSize -> 12}, PlotRange -> {{0, 450}, {0, 40}}],         {0.5, -0.155}, Center, {0.9, Automatic}]},       PlotRange -> {{0, 1}, {-0.21, -0.04}}, ImageSize -> 600]      ![enter image description here](http://i.stack.imgur.com/Is0fv.png)               Rasterize[a, ImageResolution -> 300]      ![enter image description here](http://i.stack.imgur.com/gZioC.png) N.B. This problem is happening on Mathematica 7. I just checked on Mathematica 9 and it works ok, but I need to run it on version 7.


How to keep PlotLegend expressions on top of each others even when placed at Bottom?

Version 9. When writing               Plot[{Sin[x], Cos[x]}, {x, -2 Pi, 2 Pi},       PlotLegends -> Placed[TraditionalForm /@ {Sin[x], Cos[x]}, Right]]      The result is ![enter image description here](http://i.stack.imgur.com/WBBuW.png) Now I'd like to put the legend below the plot, but at the same time keep them looking the same way. i.e. `sin(x)` on top and `cos(x)` below. I do not want them to flatten. But when I do               Plot[{Sin[x], Cos[x]}, {x, -2 Pi, 2 Pi},       PlotLegends -> Placed[TraditionalForm /@ {Sin[x], Cos[x]}, Bottom]]      The result is ![enter image description here](http://i.stack.imgur.com/Wd2Jb.png) I can't use Grid or such to format these myself in the way I like them, since if I do, then `PlotLegend` will not see them any more. i.e. I can't just write something like               Plot[{Sin[x], Cos[x]}, {x, -2 Pi, 2 Pi},       PlotLegends -> Placed[ Column[{Sin[x], Cos[x]}], Bottom]]      ![enter image description here](http://i.stack.imgur.com/ilC2T.png) Any one knows of a trick to do this? I looked at options for PlotLegend but do not see anything right away.


What is the most elegant way to specifiy a start case for recursion?

When writing recursive code that computes the least value at which a condition is true and various other scenarios it is often necessary to specify a base case. What I have done to supply this is create a function parameter that must always have the specified base case passed into it: `least2nbigger[x_, n_] := If[2^n >= x, 2^n, least2nbigger[x, 1 + n]]` This is used with a structure like `least2nbigger[4097, 1]` Where the 1 is the start value for the recursion. x is the only parameter of interest to someone using the function; n is always to be passed as 1. In SML I would do something like this:               fun least2nbigger x = least2nbigger (x, 1)     |   least2nbigger (x, n) =     let         p = pow (2, n)     in         if p > x then p          else least2nbigger (x, n+1)         end;      (My SML is a bit rusty, that might not be entirely valid but the idea is clear). There is an alternative definition provided for the recursive case; the function can be called without the tuple. The only way I see to do this in Mathematica would be to make two functions, the recursive case and a dummy function that calls the recursive case with is base parameter. Is there a better way to accomplish this?


ParametricNDSolve: Parameter inside UnitStep leads to longer integration times

I have found one of the most annoying issues in ParametricNDSolve. When a parameters occurs inside UnitStep (and Piecewise and If) the integration takes much longer time. I illustrate this by an easy example First, create two identical systems with an infusion running for 100 time units. In the first system we set the value of the infusion time and in the second system this parameter value will be set later on to the same value.               sys1 = {x'[t] == RATE*UnitStep[100 - t], x[0] == 0};     sys2 = {x'[t] == RATE*UnitStep[tInf - t], x[0] == 0};     vars = {x};      Create two ParametricNDSolve objects:               p1 = First@     ParametricNDSolve[sys1, vars, {t, 0, 200}, {RATE},      Method -> {"ParametricSensitivity" -> None,        "ParametricCaching" -> None}];     p2 = First@     ParametricNDSolve[sys2, vars, {t, 0, 200}, {RATE, tInf},      Method -> {"ParametricSensitivity" -> None,        "ParametricCaching" -> None}];      Now we crete a large set of of random parameter values for the parameter RATE.               runs = 10000;     rvs = RandomReal[{0, 1}, runs];      Solve the first system (with only one parameter) a large number of times and take the time.               AbsoluteTiming[Do[x[rvs[[i]]] /. p1, {i, runs}]]          {1.546088, Null}      Solve the second system, with parameters RATE and tInf where tInf=100, a large number of times and take the time.               AbsoluteTiming[Do[x[rvs[[i]], 100] /. p2, {i, runs}]]          {9.052518, Null}       The second systems take approximately 6x longer to solve. What is going on here? There might be a large issue here with the ParametricNDSolve environment.


NotebookWrite undo

Is there way to make `NotebookWrite`s undooable? For example let's say I open a new notebook and then run.               NotebookWrite[EvaluationNotebook[], Cell["New content", "Subsection"]]      Is there way to make the text above then dissapear when I hit `Ctrl`+`z`.


neighbor swapping distance between two strings

**Updated Problem Description** I have a collection of strings $S$ that only contain two (or $m$ in general) kinds of elements: in this case C and D. For all $s\in S$, the length is the same, the number of C is the same (and so does the number of D). For instance consider the following two strings: CCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDD and CDCDCCDCDCDCDDCDCDCDCDCDCDCDCDCD. They have the same number of characters, the same number of C and D. Could anyone suggest how can I count the minimum number of neighbor swappings needed to transform from the 1st string to the 2nd string in Mathematica? **Information that is irrelevant to the problem itself** : I am doing this to compare how close the best candidate solution obtained by a problem-specific genetic algorithm to the real optimal solution. You are welcome to suggest other measures of "closeness". **Update 1** : There is not periodic boundary condition in my problem. I do not treat the string as necklace. **Update 2** : In the comments, @Stephen mentioned Kendall tau distance, but I'm not sure whether it applies to my problem considering that there is no order relation between C and D and so many characters in the string are the same one, i.e. there are so many C in one string.


Generating an "average curve" from a dense set of "semicontinuous curves" which clear trends

This question is related to a previous one of mine: Partitioning a superset of coordinates into subsets that generate continuous curves, where the challenge was to partition a data set into two clusters representing distinct "semicontinuous curves" (we mean this in the loose sense that a ListPlot generated two curves that by eye appeared to be continuous). The user rm -rf illustrated and demonstrated that FindClusters could very nice solve the problem using a Euclidean distance metric (a hat tip also to g3kk0 who elaborated on this approach). My question here is how one would approach a much more pathological case, where we have multiple closely spaced curves, displaced some amount vertically, and we would like to generate an "average" curve that represents a sort of average for the shape of all the semicontinuous curves. Take a look at the following plots (data uploaded to: https://www.dropbox.com/sh/751invayqe3ip9b/r6raIrdvLF): Plot A: ![enter image description here](http://i.stack.imgur.com/RvgFN.png) Plot B: ![enter image description here](http://i.stack.imgur.com/9zilo.png) In both cases, we can more or less clearly make out by eye what the shape of each semicontinuous curve looks like. For example, take the following "hand drawn" traces of two semicontinuous curves in Plot B: ![enter image description here](http://i.stack.imgur.com/Heggt.png) While it may not be possible to separate the data sets for Plot A and Plot B into clusters that represent each of these semicontinuous curves (I'd love to be corrected on this point), how can we automatically generate a sort of "average curve" that follows the trend for each of the semicontinuous curves? Update: In reponse to rm -rf's comment, if we take a similar data set to Plot B and bin along the X-axis and then compute a mean for each bin (computing the median generates a similar result), the resulting plot looks like this: ![enter image description here](http://i.stack.imgur.com/btBP5.png) My explanation for this is that we cannot "see" (i.e. we do not have access to) all of the semicontinuous curves in the plot. A peak in the set of curves may cause additional curves to appear near the bottom of the plot (see the $X \approx 5000$ to $8000$ region in Plot B), and vice versa. * * * Update 2: If we connect all points within some small cutoff distance $T$ (perhaps $T = 1$ here), generating a random geometric graph, perhaps we could look at the angle of the edges connecting the points / vertices? This shouldn't be affected very much by the presence of peaks or troughs of curves at the bottom and top of the plot, respectively. * * * Update 3: Provided that the data here is generally periodic along the $y$-axis, it might be reasonable to treat the surface as if it it curves around on itself like a tube (where the x-axis is the long-axis of the tube, and the curvature occurs along the y-axis).


HornerForm of polynomials in terms of E^(i x)

I want to know how to get the `HornerForm` of the following expression in terms of `E^(I x)`:                E^(I x) + 2 E^(2 I x) + 3 E^(3 I x) + 4 E^(4 I x) + 5 E^(5 I x) +           6 E^(6 I x) + 7 E^(7 I x) + 8 E^(8 I x) + 9 E^(9 I x) + 10 E^(10 I x)      `HornerForm[ expr, E^(I x)]` doesn't work as well as something like `Collect[ expr, E^(I x]]`.   How can I get the desired form?


InverseFunction oddity

InverseFunction[ConditionalExpression[#, 0 <= # <= 1] &]     InverseFunction[ConditionalExpression[#, -1 <= # <= 1] &]      The first line produces what I would expect:               ConditionalExpression[#1, 0 <= #1 <= 1] &      But when I make the lower limit in `ConditionalExpression` negative, the inequalities become strict:               ConditionalExpression[#1, -1 < #1 < 1] &      Why is this happening?


Torus triangulation

I'd like to plot something similar to this but with a triangle instead of a pentagon. Also, I'd like to triangulate the faces, that is, to insert the diagonals for each face of the 3 prisms used. In fact, I'd like to plot the minimal simplicial complex for the torus. I tried to compute the vertices to use some polygon plot3d function but no progress. Sorry. ![enter image description here](http://i.stack.imgur.com/87swL.gif) **Edit:** Here is the code I have. I'm trying to see the 3 cycles to determine the faces. The problem is that they are not equilateral triangle.               pic3 = Graphics3D[{Green,         Polygon[{{0, -1, Sqrt[3] - 1}, {1, -1 - Sqrt[3],            Sqrt[3] - 2}, {-1, -1 - Sqrt[3], Sqrt[3] - 2}}]}];      pic2 = Graphics3D[{Pink,         Polygon[{{0, 0, 1}, {1, 0, Sqrt[3]}, {-1, 0, Sqrt[3]}}]}];     pic1 = Graphics3D[{Blue,          Polygon[{{0, 1, Sqrt[3] - 1}, {1, 1 + Sqrt[3], Sqrt[3] - 2},                   {-1, 1 + Sqrt[3], Sqrt[3] - 2}}]}];      ![enter image description here](http://i.stack.imgur.com/GDKeU.gif) **Edit 2:** Using some rotation transformation, I defined some points and rotated them to produce another triangles. The code below produces a better result. Now I'd like to make it fancier, maybe with transparent or glass style.               triang1 = {{0, 0, 1}, {1, 0, 1 + Sqrt[3]}, {-1, 0, 1 + Sqrt[3]}};     triang2 = RotationTransform[2 Pi/3, {1, 0, 0}, {0, 0, 0}][triang1];     triang3 = RotationTransform[4 Pi/3, {1, 0, 0}, {0, 0, 0}][triang1];          pic1 = Graphics3D[{Blue, Polygon[triang1]}];     pic2 = Graphics3D[{Red, Polygon[triang2]}];     pic3 = Graphics3D[{Green, Polygon[triang3]}];          trapez1 = {triang1[[1]], triang2[[1]], triang2[[2]], triang1[[2]]};     Gtrapez1 = Graphics3D[{Yellow, Polygon[trapez1]}];     trapez2 = {triang1[[1]], triang3[[1]], triang3[[2]], triang1[[2]]};     Gtrapez2 = Graphics3D[{Yellow, Polygon[trapez2]}];     trapez3 = {triang3[[1]], triang2[[1]], triang2[[2]], triang3[[2]]};     Gtrapez3 = Graphics3D[{Yellow, Polygon[trapez3]}];     trapez4 = {triang1[[1]], triang2[[1]], triang2[[3]], triang1[[3]]};     Gtrapez4 = Graphics3D[{Yellow, Polygon[trapez4]}];     trapez5 = {triang1[[1]], triang3[[1]], triang3[[3]], triang1[[3]]};     Gtrapez5 = Graphics3D[{Yellow, Polygon[trapez5]}];     trapez6 = {triang3[[1]], triang2[[1]], triang2[[3]], triang3[[3]]};     Gtrapez6 = Graphics3D[{Yellow, Polygon[trapez6]}];          Show[Gtrapez6, Gtrapez5, Gtrapez4, Gtrapez3, Gtrapez2, Gtrapez1,          pic1, pic2, pic3, Boxed -> False, AspectRatio -> Automatic]      ![enter image description here](http://i.stack.imgur.com/LAN3s.gif)


To inscribe a circle in a given triangle

I am trying to to inscribe a circle in a given triangle but it isn't working. I've used GeoGebra with this construction and worked but as I'm new to Mathematica I am missing something. It can't be so complex to do. Here is my code:               pA = {0, 0}; pB = {1.1, 1}; pC = {1.5, 0};          midAB = (pA + pB)/2; midBC = (pB + pC)/2; midAC = (pA + pC)/2;          myT = Triangle[{pA, pB, pC}];          centerC = (midAB + midBC + midAC)/3          raioC = Last[centerC]          Graphics[{EdgeForm[Directive[Thick, Blue]], White,        myT, {PointSize[Large], Red, Point[midBC]}, {PointSize[Large], Red,         Point[pA]},       {Orange, Line[{pA, midBC}]},       {Orange, Line[{pB, midAC}]},       {Orange, Line[{pC, midAB}]},       {Red, Circle[centerC, Last[centerC]]},       }, AspectRatio -> Automatic, PlotRange -> All]           I understand that I'm not doing right the radius of the circle but I've tried more than one way to do that. Here is the original (book) construction: To construct: The circle inscribed in ^ABC Construction: Construct the bisectors of two of the angles of ^ABC. Their intersection is the center of the required circle, and the distance (perpendicular) to any side is the radius. (Any point on the bisector of an angle is equidistant from the sides of the angle.) As I said, it worked in GeoGebra and it is almost working with my code. Thank you for any help.


How to create a large sparse block matrix

I need to generate a very large sparse block matrix, with blocks consisting only of ones along the diagonal. I have tried several ways of doing this, but I seem to always run out of memory. The fastest way of doing this that I've come up with so far is as follows: (typically, I will need `n` to be at least 2500 and m of the order 50).               tmp= SparseArray[{}, {n,n}, 1];          SparseArray@      ArrayFlatten@       Table[If[i == j, tmp, 0], {i, m}, {j, m}]      Example when n=2, m=4: ![Matrix](http://i.stack.imgur.com/PIpvo.png) The problem with this construction is that `ArrayFlatten` for some reason converts the result to a normal matrix, and I run out of memory. That is, when it works, this code computes the end result very quickly and the result does not take up much memory. At some specific number however, it suddenly crashes as the intermediate `ArrayFlatten` step clogs up the memory. Any help will be greatly appreciated!


How to obtain a complete list of WordData's "Properties"?

Command `WordData["Word", "Properties"]` seems have an endless list of properties, such as : `"Definitions"`, `"PartsOfSpeech"`, `"Definitions"`, `"Examples"`, `"Synonyms"`, `"Antonyms"`, `"BroaderTerms"`, `"NarrowerTerms"`, `"ConceptWeight"`, `"BritishSpelling"`, `"AmericanSpelling"`... Is it possible obtain a complete list of it?


How can estimate the PSF function to deblur an image of plate licence of a car

I want to deblur a blurred image of a plate licence of a car. I need to deblured it. I have used the ImageDeconvolve[] function and Sharpen but the problem is still difficult because I need to estimate the kernel or the PSF function. A lot of techniques have been used to estimate the PSF. I wondered How the Fourier transform of the blurred image can gives us an idea about the PSF function. Any help?               psfMotion[dim_?NumberQ, theta_?NumberQ] :=       Module[{PSF},         PSF = ConstantArray[0.0, {dim, dim}];         PSF[[Ceiling[dim / 2.0], All]] = 1.0 / dim;         Return[ImageRotate[Image[PSF], theta  Degree]];        ];     psf = psfMotion[14, 0];     Table[ImageDeconvolve[licence, psfMotion[2, \[Theta]],        Method -> "RichardsonLucy", MaxIterations -> 15], {\[Theta], 0,        180}]      Image: ![enter image description here](http://i.stack.imgur.com/2HYeW.png) licence ![enter image description here](http://i.stack.imgur.com/qkXP2.png)


Stochastic Simulation using the Gillespie algorithm

I'm trying to reproduce the simulation with demographic stochasticity in Figure 1 from the paper entitled "Dynamical Resonance Can Account For Seasonality of Influenza Epidemics" (http://www.pnas.org/content/101/48/16915.full). My code works just fine when $t$ is small $(0<t<0.02)$, but when I increase the value of $t$ (as below), the simulation doesn't finish compiling. Thus, I'm wondering if there's an issue with my code. Ideally, I would like my code to function when $(10<t<20)$ so I can compare my results to the paper. Any input would be greatly appreciated.               Clear[S, Infe, R, No, b0, b1, b, t, Ro, d, L, event, fun, main, list1, list2, data]      No = 500000;      b0 = 500;      b1 = 0.04;      d = 0.02;      L = 4;      list1 = {};      list2 = {};      b[t_] := b0 *(1 + b1* Cos[2 Pi t]);      main[] := Module[{S = 499999, Infe = 1, R = 0, t = 0},      While[t < .03 && Infe > 0, {S, Infe, R, t} = fun[S, Infe, R, t];     AppendTo[list1, Infe]; AppendTo[list2, t] ]];          fun[S0_, Infe0_, R0_, t0_] :=      Module[ {S = S0, Infe = Infe0, R = R0, t = t0},      TransRate = (b[t]*S*Infe)/No;      RecoveryRate = Infe/d;      ImmunityLoss = (No - S - Infe)/L;      TotalRate = TransRate + RecoveryRate + ImmunityLoss;           t = t + RandomReal[ExponentialDistribution[TotalRate]];      event = RandomReal[UniformDistribution[]];           If[event < TransRate/TotalRate,      S = S - 1 ; Infe = Infe + 1,      If[event < (TransRate + RecoveryRate)/TotalRate,      Infe = Infe - 1 ; R = R + 1, R = R - 1 ; S = S + 1]];      {S, Infe, R, t}         ]          main[]      data = Transpose@{list2, list1};     ListPlot[data]


Plotting partial sums of Fourier sine series

How do I plot this on Mathematica version 5.2? $\frac{4}{\pi} \sin{x} + \frac{4}{3 \pi} \sin{3 x} + \cdots + \frac{4}{(2 N+1) \pi} \sin{(2 N+1) x}$ over $x \in [-\pi,\pi]$ for $N= 3, 6, 12, 24$. I tried and got this error: ![enter image description here](http://i.stack.imgur.com/ju3UT.jpg)


Check if a scalar falls within the range given by sub-arrays of a matrix

I have a rank 3 matrix:               r = {{{1, 10}, {19, 71}, {111, 159}}, {{1, 5}, {25, 63}, {118, 132}, {164, 185}}, {{1, 19}, {28, 49}, {157, 203}}};      and each of the sub-arrays above represents a range. No two sub-arrays in a given row has any overlap. I want to check if given `i` of `r[[i]]` and a scalar `x`, I want to check if any of the sub-arrays have `x` within their range. e.g. if `i =2` and `x=175` is TRUE because `{164,185}` has it, but `x=75` is FALSE since none of the `{1, 5}, {25, 63}, {118, 132}, {164, 185}` has it. I do not want to use `MapThread` and use compilable functions, `UnitStep` if possible.


Avoid trigonometric simplifications?

When evaluating the expression               Sinh[x]^2 + Cosh[x]^2 // FullSimplify      I get               Cosh[2 x]      That is indeed a simplification, but there are cases when I would not want that to happen. What if I have a much more complicated expression that I want to simplify generally, but still wish to stay in `Sinh[x]^2` and `Cosh[x]^2`. So under no circumstances do I wish to change to `Cosh[2 x]` or similar expressions. Is there a way to explicitly tell Mathematica **not** to use trigonometric relations? Or to use the trivial `Cosh[x]^2 - Sinh[x]^2 = 1` but none of the composed ones? Preferably, maybe there is a switch that disables the sensitivity of _Mathematica_ to trigonometric relations in an entire notebook?


Third syntax version of LogitModelFit: unexpected result of "BestFit"

The third listed syntax version of `LogitModelFit` allows one to specify input in a simple way: Only a design matrix (with a row of values of the explanatory input variables for each of the output values) and a response vector are needed. The following example is straight from the `LogitModelFit` help page:               dm = {{1, 1}, {1, 2}, {1, 3}, {1, 4}};     resp = {0, 1, 0, 1};     model = LogitModelFit[{dm, resp}]      ![Mathematica graphics](http://i.stack.imgur.com/ygo8s.png) As usual in these types of fits, Mathematica returns an object that can be interrogated with various methods. In this case, I just want to have the best fit:               model["BestFit"]      ![Mathematica graphics](http://i.stack.imgur.com/JXCUt.png) I noted something here that I feel is strange. Although this looks like a pure function (which is what I expected, given no formal variable names are specified in this syntax), it really isn't, since the required `&` at the end is missing. Hence, a construction like `model["BestFit"][1,2]` doesn't work. Is this a bug, or is this useful in some way and am I missing something? I note that neither the `"Function"` method of `LogitModelFit` nor something like `model//Normal` yields anything useful. The former generates an error which suggests to me that there is indeed a bug in this syntax variant. The latter returns the same as `"BestFit"`. My workaround for now is to use:               mod = model["BestFit"] // Evaluate // Function;      (`Evaluate` because of the `HoldAll` attribute of function)               mod[1, 2]      > 0.3883882668


Exp is slower for some number ranges

I get a hit on performance with the `Exp` function depending on the range of my inputs. for example, with:               w1 = RandomComplex[-20000 I, {10000000}];     Exp[w1]; // Timing          w2 = RandomComplex[-20 I, {10000000}];     Exp[w2]; // Timing      Results in 2.4 and 0.4 sec respectively. What mystifies me is that the involved numbers are not in a numerically "interesting" range. The transition to slower times starts gradually at about `-500 I` and asymptotically stabilizes by about `-10000 I`. Past these ranges the timings are stable:               w = RandomComplex[-I, {1000000}];     t = Table[{10^n, Timing[Exp[10^n w]][[1]]}, {n, 1.5, 5, .01}];     ListLogLinearPlot[t, AxesLabel -> {"Scaling", "Time"}]      ![](http://i.stack.imgur.com/fYrA4.png) Any ideas what might be happening here? Any simple fixes to get faster performance with high scaling factors?


Using NETLink.MathKernel.Compute() for graphics results fails with GraphPlot[]

I'm using MMA 8.0 to provide backend on a .NET application I'm writing. I am trying to use the high-level `Wolfram.NETLink.MathKernel` interface to export an image created with GraphPlot[]. Although the Result comes back as '-Graphics-', I find that Graphics[] is empty. Changing the Compute() to another graphic generating command returns an image in the Graphic[] as expected. Here's my example code:               Wolfram.NETLink.IKernelLink _iKernelLink;          string cmdLine = "-linkmode launch -linkname \"C:/Program Files/Wolfram Research/Mathematica/8.0/MathKernel.exe\"";     _iKernelLink = Wolfram.NETLink.MathLinkFactory.CreateKernelLink(cmdLine);     _iKernelLink.WaitAndDiscardAnswer();          var k = new Wolfram.NETLink.MathKernel(_iKernelLink); // new MathKernel          k.AutoCloseLink = true; // close link when object is disposed     k.CaptureGraphics = true; // capture graphics output     k.CapturePrint = true; // capture print output     k.CaptureMessages = true; // capture messages     k.HandleEvents = true; // lets Compute thread handle application events     k.UseFrontEnd = false; // don't use Mathematica Notebook front-end          // this produces empty Graphic[] result     string command = @"GraphPlot[{1 -> 2, 2 -> 1, 3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4}]";          // this command produces the expected Graphic[] result     //string command = @"BarChart@Range[5]";          k.Compute(command);          if (k.Graphics.Length > 0) // <-- should be an image for both commands         return k.Graphics[0];     else         return null;


Why modules with no variables?

I was reading some code, in particular, recipe 4.13 on unification pattern- matching in Sal Mangano's Mathematica Cookbook, and there were many instances of Modules with no variables in them, such as               Lookup[x_] := Module[{}, x /. $bindings]      i didn't understand the point. Why not just write               Lookup[x_] := x /. $bindings      ? Sal uses such modules frequently, so I'm supposing there is some deep reason I'm missing, hence the question here.


Detecting and correcting gradational brightness variations in a grayscale image

I am trying to quantify the proportions of various components in a greyscale image (backscattered electron image of a polished rock sample). Here is the original image:               bse = Import@"http://i.stack.imgur.com/eQece.png";      ![enter image description here](http://i.stack.imgur.com/eQece.png) The image is comprised of components (minerals) that should have the same intensity response. For example, the abundant 'mid-grey' component (plagioclase) should have a fixed grey-level across the entire image. It doesn't. By masking the other components of the image and adjusting the contrast, the gradations in brightness become more obvious:               bsek = ImageSubtract[bse, ColorNegate@Binarize[bse, {0.16, 0.24}]];     ImageAdjust[bsek, {3, 1.1}]      ![enter image description here](http://i.stack.imgur.com/Xo6C5.png) There seems to be two effects: a first order decrease in brightness towards the bottom corners and a second-order periodic vertical striping (comprised of short wavelength gradients). _Why bother? - Correcting for variations in brightness is an important step prior to segmentation analysis of the image_ By approximating the variation in grey-values for the plagioclase, the difference in birghtness between the top and bottom of the image can be modelled (albeit crudely).               ksim[im_] := Module[{kdf, kdl},       kdf = SmoothKernelDistribution[First@im];       kdl = SmoothKernelDistribution[Last@im];       Plot[{PDF[kdf, x], PDF[kdl, x]}, {x, 0, 0.3}, Filling -> Axis,         Exclusions -> None]]     ksim[ImageData[bsek]]      ![enter image description here](http://i.stack.imgur.com/i8hOp.png) The following creates a gradational filter that causes the grey-level peaks to overlap (by adjusting the value of `shift`).               bsedim = ImageDimensions[bse]     shift = 0.2;     grad = 1 +         Transpose@         Array[Table[x, {x, -shift, 0., shift/bsedim[[1]]}] &, bsedim[[1]]];     gradi = Image[grad];          bsekm = ImageMultiply[bsek, gradi];     ksim[ImageData[bsekm]]      ![enter image description here](http://i.stack.imgur.com/paB4h.png) This filter can then be applied to the original image:               bsem = ImageMultiply[bse, gradi]      ![enter image description here](http://i.stack.imgur.com/CWRuh.png) This clumsy method does an _OK_ job of levelling the first-order brightness defect. However, this effect looks to have a spherical gradient (dimmer in the bottom corners than the middle) which is not accounted for. As yet, I have not found a way to correct the second order periodic effect. Can anyone suggest a more straightforward way to detect and correct these kinds of brightness variation defects? Extra bonus gratitude to anyone who can help to correct the second-order periodic aberration. * * * **Update** Here is a contrast stretched image showing the vertical aberrations:                ImageAdjust[bse, {4.5, 3.85}]      ![enter image description here](http://i.stack.imgur.com/orqOk.png)


What are the algorithm details of FindRoot?

The Help page of `FindRoot` says: "by default, `FindRoot` uses Newton's method (Newton-Raphson) to solve a nonlinear system".   But I still have the following puzzles:   1. How will the Jacobian be calculated in each iteration : symbolically or using finite difference approximation only?   2. Is there any dumping method of the step being used when the Jacobian at any step is invertible?


Inequality of reciprocal functions

Simplify[1/(1/a + 1/b)]      { (a b)/(a + b) } That doesn't look right. The given function has an infinite term for `a = 0` and one for `b = 0`, while the result has one for `(a + b) = 0`. So that's probably the reason why:               a b/(a + b) === 1/(1/a + 1/b)      { False } though only a minute ago it Simplified it that way! Also               Simplify[1/(1/x)]        { x } seems to disregard the `1/0` case. Can anybody get me out of my confusion?


Code Golf: Least Common Multiple

"CodeGolf" challenge: write the shortest practical Least Common Multiple function that:   1. Does not use built in `GCD`, `LCM` or any related fuctions   2. Accepts multiple arguments in any order, e.g. `LCM[3, 20, 6]`   3. In the spirit of the original, obfuscated is better


Copy a variable to a specific kernel in Mathematica

I would like to copy some parameter from the main Kernel of Mathematica to the parallel kernels available. So I'm running now a command like:               LaunchKernels[]     ParallelEvaluate[var = 10, #] & /@ Kernels[]      Now running this is not a problem. But say I have another variable `var2` and I want to copy its content to all other kernels or a specific kernel. How can I do this?


Creating partly filled disks based on percentage

I'm trying to create a function that returns a partly filled `Disk`, based on a percentage. So inputting `1` would give a fully filled disk, while inputting `0.5` would return a `Disk` with half of if it filled (from 12 'o clock to 6 'o clock). Etc. So far I've written this:               Graphics[{{EdgeForm[Thick], White, Disk[{0, 0}, 1]},                {Blue, Disk[{0, 0}, 1, {4 Pi/3, Pi/2}]}}]      ![enter image description here](http://i.stack.imgur.com/uCZI7.png) The function part is not difficult but I can't get the coordinates to work properly. How do I transform a percentage like 0.1 to the correct segment of the `Disk`? (The `{4 Pi/3, Pi/2}` of the function).


Specifying the ports used by LinkCreate or LinkLaunch

Whenever a `Link` is created using `LinkCreate` or `LinkLaunch` with `LinkProtocol -> "TCPIP"`, Mathematica opens up two ports for communicating with the attached process. Can these be specified by the user of these functions? I ask because it would allow me to route all communication over ssh via port- forwarding.


How to remap a fisheye image?

I want to flatten a series of fisheye images by remapping them to a rectinlinear projection. To achieve this, I need to be able to remap the pixels of the image using fisheye correction formulas for the x-, and y-coordinates. How can I achieve this? I have found this question and this question but I wonder how to use this for fisheye correction. So far I've tried to use ImageTransformation for this, but I can't get the function to work properly.                 f[pt_] := With[{s = {.5, .5}},       Module[{rd, polarcoor, ru, newcoor},        rd = Norm[pt - s]^2/Norm[s];        polarcoor =          CoordinateTransform[{"Cartesian" -> "Polar", 2}, (pt - s)];        ru = 1*Tan[2*ArcSin[((polarcoor[[1]])/(2*1))]];        CoordinateTransform["Polar" -> "Cartesian", {ru, polarcoor[[2]]}]        ]       ]     ImageTransformation[image,f]      This should first translate the image coordinates to polar coordinates, then calculate the new r (ru=r undistorted), and than translate these back to cartesian coordinates. The `ru = 1*Tan[2*ArcSin[((polarcoor[[1]])/(2*1))]]` is based on the above links, with a random value chosen as f. It fi I get an error message, saying the function doesn't map. Anyone have an idea how to fix this and any further suggestions on how to improve the code? ![Example fisheye image](http://i.stack.imgur.com/JDX9f.jpg) **Update 2 22-10-2013** Changed the code to:               image = Import["http://i.stack.imgur.com/JDX9f.jpg"];     r[pt_] := Module[{rd, ru, polarcoor, a},       rd = Norm[pt];       ru = *Transformation formula*        a = ArcTan @@ (pt);       ru {Cos[a], Sin[a]}       ]      Using `ru = Sqrt[rd];` `ImageTransformation[image, r, DataRange -> {{-1, 1}, {-1, 1}}]` gives ![enter image description here](http://i.stack.imgur.com/cdvgw.jpg) Using `ru = ArcTan[rd];` `ImageTransformation[image, r, DataRange -> {{-2, 2}, {-2, 2}}]` gives ![enter image description here](http://i.stack.imgur.com/9JQVP.jpg) Both look like a step in the right direction, with straightened lines, but I got them by trial-and-error so I don't know the correctness.


Does Share have any side effect?

According to the documentation, > `Share[expr]` changes the way `expr` is stored internally, to try and > minimize the amount of memory used. How should I then interpret the fact that `x1 != x2 + x3` after running the following code?               e = Table[j (x + i), {i, 5}, {j, i}];     x1 = ByteCount@e     x2 = Share[e]     x3 = ByteCount@e


Simplifying expressions using rules that span nonconsecutive terms

Suppose there is some function with the property               f[x,y] f[y,x^2] / f[x^3,y] == f[2x,y]      How can I simplify an arbitrary expression that contains the lhs of the above equation in a somewhat obscured way? Say as in               a f[x^3,y] b / (c f[y,x^2] d f[x,y] e)      I tried Simplify with TransformationFunctions but I only seem to be able to replace the three f when they're literally next to each other in the syntax tree. Any ideas on how to proceed?


Mathematica Workbench - when to expect an update?

I'm considering getting Mathematica Workbench 2. Looking at the videos on Workbench 2 and on "Profiling Mathematica code" @ 01:09 I see the current version nr 2 dates back to at least oktober 3 2007 i.e soon to be 7 years old. This seems a bit outdated to be software. I don't seem to find any revision history. Are there any alternatives on the market, that have similar capabilities and are more up to date ?


Declaration of variables in large Linear Programming model with NMaximize

I want to solve a large LP problem using `NMaximize`. This is a small instance of my bigger problem: $$max \sum^{4}_{t=1}(\sum^{4}_{c=1} V_{c}*f_{c,t})\\\ s.t\quad \sum^{5}_{t=1} f_{c,t} \leq 100,\forall t$$ where $ f_{c,t} \geq 0$ and $c=1...5$ and $t=1...5$ I wrote the following:               NMaximize[{Sum[f[c, t]*V, {c, 1, 4}, {t, 1, 4}],        Sum[f[c, t], {c, 1, 5}] <= 100}, {f[c, t]}]      How can I declare `f[c,t]` as a variable?