I have this system of equations: $- \ddot{z} + \frac{1}{g} \frac{\partial g}{\partial z} \dot{z}^2 + \frac{1}{g} \frac{\partial g}{\partial z^*} \dot{z} \dot{z}^*$ =0 , $- \ddot{z}^*+ \frac{1}{g^*} \frac{\partial g^*}{\partial z^*} \dot{z}^{*2} + \frac{1}{g^*} \frac{\partial g}{\partial z} \dot{z} \dot{z}^*$ =0 . I have written them as: eq1 := - D[z[t],t,t] + (1/g[t]) * (D[ g[t],t]/ D[ z[t],t] ) * D[z[t],t]^2 + (1/g[t]) * (D[ g[t],t]/ D[ Conjugate [z[t]],t] ) * \dot{z} \dot{z}^* eq2 := - D[Conjugate[z[t]], t,t] + (1/Conjugate [g[t]] ) * (D[ Conjugate [g[t]], t]/ D[ Conjugate[z[t]], t] ) * D[Conjugate[z[t]],t]^2 + (1/Conjugate [g[t]] ) * (D[g[t], t]/ D[ z[t], t] ) * \dot{z} \dot{z}^* (* With initial conditions ) ( Note that these are arbitrary values, could be changed so that NDSolve give the most suitable solutions *) ic= { g[0]==1, z[0]==1, Derivative[1][z][0]==0} (* Numerically solved in z and g *) solz := NDSolveValue[ {eq1==0, eq2==0, ic},z , {t,0,50} ] solg := NDSolveValue[ {eq...

As Mathematica gets slow for large symbolic calculations, the cost of putting terms over a common denominator ( Together ), in particular, gets too high. It occurred to me that, if one has a small number of variables, it should be much faster if we represent our expressions by arrays of their coefficients. I have implemented a small package that does this with an improvement of a factor of 10 in both speed and memory (in putting Together a sum of rational terms, more or less independent of the size of the sum), but it seems to me that I should be able to do better. I post my package here with the hope that someone might point out glaring performance bottlenecks. First, the public initializations, with their usability comments. AA::usage = "DATA STRUCTURE AA[num,den] that stores polynomials as their tensor coefficients of a basis, multiplication is the tensor product" PolytoAA::usage = "PolytoAA[poly_,vars_List] returns an AA[num_SparseArray,1]" AAtoPoly::usage = ...

I just Ctrl-Alt-Deleted out of Mathematica after I crashed it while running. I had not saved it all day and had done quite a lot of work on it. When I reopen the file, it shows a version with none of the changes I made today -- I guess I never saved it. I don't think I've actually lost work through not saving in fifteen years. Have I managed to do it today, or is there some way to view scripts that ran in the past but weren't saved? Moderator's note: I am leaving this question open rather than closing it as a duplicate of one of several linked in the comments because it specifically asks about the possibility of recovering data from a Notebook that was not saved. Please do not post answers explaining how to set up an auto-save system. Such methods should instead be posted in answer to other questions. – Mr.Wizard

I can edit a notebook within the mathematica front end and then Save As a .m file, which produces output like this: (* ::Package:: *) (* ::Section::Closed:: *) (*Preliminaries*) (* ::Input:: *) (*ClearAll["Global`*"]*) (* ::Text:: *) (*Some text here.*) (* ::Input:: *) (*u[d_,v_]:=v-t d;*) (*Solve[u[x,v1]==u[1-x,v2],x][[1]];*) (*x/.%;*) (*x[v1_,v2_]=%;*) The same thing is a .nb file looks like this: (* Content-type: application/vnd.wolfram.mathematica *) (*** Wolfram Notebook File ***) (* http://www.wolfram.com/nb *) (* CreatedBy='Mathematica 9.0' *) (*CacheID: 234*) (* Internal cache information: NotebookFileLineBreakTest NotebookFileLineBreakTest NotebookDataPosition[ 157, 7] NotebookDataLength[ 1786, 74] NotebookOptionsPosition[ 1395, 55] NotebookOutlinePosition[ 1750, 71] CellTagsIndexPosition[ 1707, 68] WindowFrame->Normal*) (* Beginning of Notebook Content *) Notebook[{ Cell[CellGroupData[{...

The default keyboard shortcut (on Windows at least) for switching focus to the next window is Ctrl+F6, and for switching to the previous windows it's Shift+Ctrl+F6. How can I change this to Ctrl+Tab and Shift+Ctrl+Tab respectively (or some other pair of combinations which is not used by default)? Answer You need to add the following to KeyEventTranslations.tr : Item[KeyEvent["Tab", Modifiers -> {Control}], FrontEndExecute[FrontEndToken["CycleNotebooksForward"]]], Item[KeyEvent["Tab", Modifiers -> {Shift, Control}], FrontEndExecute[FrontEndToken["CycleNotebooksBackward"]]], This will map Control - Tab and Control - Shift - Tab to cycling between notebooks. For some reason, using the Tab key sometimes fails, but any alternative shortcut could be used (for example Ctrl - ` ). On Windows KeyEventTranslation.tr is located in $InstallationDirectory\SystemFiles\FrontEnd\TextResources\Windows

I have a function of two variables, e.g.: f[a_, b_] := f[a, b] = something f[a - 1, b - 1] etc With the above code I used the concept of memoization to speed up the computation. However, I have the problem that I run out of memory for large values of a and b . Since my recursion is not very deep, I would like to clear the memory from time to time; for example, I calculate f[1000, 1000] and then remove all values of f[a, b] for a , b between 1 and something close to 1000. However, I only found the Clear / ClearAll functions, which (unless I am missing something) clear everything indiscriminately. This is not what I want. Is there a built-in function that does not clear all values of f[a, b] , but just a specific range?

I have the following data consisting of x, y pairs and errors of y: dataWithError = {{0.0333333, 0.0000122672, 0.00000173485}, {0.05, 0.0000371462, 0.00000448037}, {0.0666667, 0.0000697768, 0.00000748151}, {0.0833333, 0.000108625, 0.000010837}, {0.1, 0.000147595, 0.0000136051}, {0.116667, 0.000186599, 0.0000161483}, {0.133333, 0.000221451, 0.0000179078}, {0.15, 0.000253062, 0.0000192494}}; I can plot the data with error bars with: ErrorListPlot[dataWithError, Joined -> True, PlotRange -> Full] The result is: I need a ListLogLogPlot with error bars (both axes have to be logarithmic). How can that be done? Answer You can always perform coordinate transformation yourself. There is nothing so special about LogLogPlot . You have to apply Log to your points and plot it with regular ErrorListPlot . Keep in mind that your error bar won't be symmetric in log-log coordinates. After that you have to draw ticks acc...

I have a very basic question. I am trying to code the LHS of the differential equation: $$\Big[\frac{1}{\sin\theta}\frac{d}{d\theta}\big(\sin\theta\frac{d}{d\theta}\big)-\frac{m^2}{\sin^2\theta}+n(n+1)\Big]f(\theta)=0$$ into Mathematica . As you can see, in the first term, the differential operator is nested and is to properly act on the function $f(\theta)$. I tried to use #1 , but (lol) I don't know how to use it! This is what I have: Sin[θ]^(-1) D[Sin[θ] D[#1, θ], θ] - m^2*#1/Sin[θ]^2 + n (n + 1) #1 What next?! Also : I don't want to just stick in f[θ] into where I have #1 , because eventually I would like to be able to make change of variables! Answer Why not just define a Function ? ClearAll[m, n, x, foo] oper = Function[{f, \[Theta]}, (1/ Sin[\[Theta]] D[Sin[\[Theta]] D[f[\[Theta]], \[Theta]]] - m^2/Sin[\[Theta]]^2 f[\[Theta]] + n (n + 1) f[\[Theta]])]; oper[foo, x] foo[x_] := Sin[x]*Cos[x]*x^4 oper[foo, x]

I have merged cells in a Notebook file. Is there a way to split such a merged cell group back to single cells, in each of them being one command? Answer Put this code after your merged cell and evaluate, it should print below all expressions separately. I don't know how solid it is but worth a try: Composition[ Scan[NotebookWrite[EvaluationNotebook[], Cell[#, "Input"]] &, #] &, Thread, DeleteCases[#, "\[IndentingNewLine]" | "\n", {2}] &, First, NotebookRead ] @ PreviousCell[]

This is an N-Body simulation for the Sun and the following planetary bodies: Mercury, Venus,Earth,Mars,Jupiter,Saturn,Uranus,Neptune and Pluto. Initial Parameters Ecc = {0.20563069, 0.00677323, 0.01671022, 0.09341233,0.04839266, 0.05415060, 0.04716771, 0.00858587, 0.24880766};(*eccentricity of bodies*) a = {0.38709893, 0.7233319899999999, 1.00000011, 1.52366231, 5.2033630099999995, 9.537070319999998, 19.191263929999998, 30.06896348, 39.48168677}; (*semi major axis of bodies*) r = a (1 - Ecc^2)/(1 + Ecc Cos[\[Psi]]); (*orbital position*) rx={0, 0.3075, 0.718433, 0.98329, 1.38133, 4.95156, 9.02063, 18.2861, 29.8108, 29.6583} (*x component of position*) ry={0, 0., 0., 0., 0., 0., 0., 0., 0., 0.} v = {0, 0.03406085426835039`, 0.020363076269733636`, 0.017491554631468408`, 0.015304294697344465`, 0.007915195286690359`, 0.005880353628887382`, 0.004116410730170449`, 0.0031640275881454545`, 0.0035297581940090896`};(*initial velocity*) T = {0, 88.0, 224.7, 365.2, 687.0, 4331, 10747, 30589, 59800,...

I want to apply Length in each element from a list. For example: My list is: {1,{2,3},{4,5,6}} How to apply Length in each element of this list? Length[{1}] Length[{2,3}] Length[{4,5,6}] I have tried to use Thread , but doesn't works: In[235]:= Thread[Length[{1, {2, 3}, {4, 5, 6}}]] Out[235]= 3 The result that I want is some like: 1 2 3 Which is the number of elements in each element. Answer If[AtomQ @ #, 1, Length @ #] & /@ {1, {2, 3}, {4, 5, 6}} {1, 2, 3} If the input list does not contain {} (thanks: @corey979), you can also use: Length /@ {1, {2, 3}, {4, 5, 6}} /. 0 -> 1 (* or Map[Length]@{1, {2, 3}, {4, 5, 6}} /. 0 -> 1 *) {1, 2, 3}

How can I extract the colors used by default in the BulletGauge? Answer Trace A programmatic approach using Trace : Trace[ BulletGauge[{1, 1.8, 3, 3.4, 4, 5}, {2.4, 2.9}, {0, 3.5, 4.8}], _ColorData ] // Flatten // First ColorData[63, 1] Check: ColorData[63, "ColorList"] Related examples: Spelunking This can also be found by spelunking the definition of BulletGauge itself using tools from: One find that the inner definition is Charting`iLinearGauge Needs["GeneralUtilities`"] PrintDefinitions @ Charting`iLinearGauge Within that one finds a hard-coded color source: Charting`padList[{{ColorData[63][#1] &, None}}, numvals]

I am trying to get the eigenvalues of the following differential operator $$L\psi(r) = -f \partial_r (f \partial_r \psi(r)) + V \psi(r)$$ which must satisfy (obviously) $$L \psi(r) = \omega^2 \psi(r)$$ where I want to acquire both the real and imaginary part of $\omega$ . To my problem, we have $$ f = 1 - \frac{2M}{r}$$ and $$ V = f \left( \frac{l (l-1)}{r^2} + \frac{2 (1-S^2) M}{r^3} \right) $$ with $ M = 1, l = 2, S=2$ . The boundary conditions are $\psi(2M) = 0, \psi(\inf) = 0$ . (To whomever may care, I am getting the real and imaginary oscillations of a Schwarzschild black hole. It is well studied in the literature, but I need to recover the result). I tried three different ways to do it: 1) Using NDEigensystem: f = 1 - 2*(M/r); V = f*(l*((l - 1)/r^2) + (2*(1 - S^2)*M)/r^3); M = 1; l = 2; S = 2; \[ScriptCapitalL] = f*D[f*D[\[Chi][r], r], r] + V*\[Chi][r]; \[ScriptCapitalB] = DirichletCo - ndition[\[Chi][r] == 0, True]; boundarydistance = 10; {ev, ef} = NDEigensystem[{\[ScriptC...

For example, say I wanted to plot Sin(x) like this: Plot[Sin[x],{x,0,2 Pi}] But instead of plotting to a graph, I want to now tabulate the values of Sin[x] to a data file. How do I achieve this? EDIT: Sorry I wasn't clear enough, I mean plot the x values in one column and the y values in the second column Answer First create your points, running from 0 to 2 Pi at intervals of 0.01. points = Table[{x,Sin[x]}, {x, Range[0, 2 \[Pi], .01]}]; You can plot them with: ListLinePlot[points] And export them to a csv file with: Export["points.csv", points]

I am working with polynomials in several variables with the obvious action of $S_n$. That is, given a polynomial $f$ in the variables $x_1, \dots, x_n$, a permutation $\sigma \in S_n$ acts on $f$ by sending $x_i$ to $x_{\sigma(i)}$. What I would like to do is to give Mathematica a polynomial, for example $x_1^2x_2 + x_3$ and have it compute the image of this under the action of a particular element. For example, if I gave it $(123)$ it would output $x_2^2x_3 + x_1$. Thanks! Answer This should be a start. groupElementAction[expr_, vars_, perm_] /; Length[perm] == Length[vars] && PermutationListQ[perm] := expr /. Thread[vars -> Permute[vars, perm]] That example: groupElementAction[x1^2*x2 + x3, {x1, x2, x3}, {2, 3, 1}] (* Out[131]= x2 + x1 x3^2 *) With some tweaking it can be made to handle the explicit cycle form of permutation group elements.

I have a stack of timelapse microscopy images that I am trying to segment frame-by-frame using some of Mathematica's image processing functions. I have created a little interactive DynamicModule with a LocatorPane where the user can try out different image processing operations/parameters on a particular frame until an acceptable segmentation is arrived at for that frame. Once the segmentation for that frame is acceptable I would like the user to be able to store the generated segmentation image (aka save the "mask") and then move on to the next frame of the timelapse. The problem I am encountering is that when I use Append or AppendTo to store each segmentation image the time to Append gets very slow as the user goes through more and more frames (I have timelapse stacks of ~100 to 200 images to go through). Is there some way to generate a list of segmented masks frame-by-frame without using Append? I have used Reap and Sow in the past when a list is generated in one fell...

I came across some unexpected behaviour today when using the Longest function when trying to do some pattern matching. StringCases[#, a___ ~~ b_ ~~ Longest[c___] ~~ b_ ~~ d___ -> {a, b, c, d}] &@"abcbba" The intent is to find the two identical characters which are the furthest apart in the string. I would expect this to return {a,b,cb,a} , since that would be the longest possible distance between two identical characters. However, it instead returns {abc,b, ,a} . I don't understand why it's not finding the longer possibility, especially when default behaviour when matching patterns seems to be that earlier patterns try to match the shortest possible sequences. Using c__ instead of c___ makes the behaviour more like the expected behaviour for this case, but I do want the pattern to work when the only sets of identical characters are adjacent to each other. What am I missing? Answer There are a number of subtle details at work here. Perhaps the prominent one...

Are there any new tools in v10 that might be applicable to this problem? Recent versions of Mathematica provide the option of having a unique $Context for each cell group, via: Evaluation > Notebook's Default Context > Unique to Each Cell Group This is an appealing concept, but I find it unusable, as my code spans multiple cell groups. I would like a way to specify a unique context for cell groups of a certain level such as every Section , but not a separate context for every Subsection or Subsubsection . A solution will need to affect new cell groups as they are created.

I want to edit my menus and know I can do this via MenuSetup.tr but can I do this in real time? Can I do it temporarily? Moreover can I change whether the changes are permanent or not / how can I make edits with minimal amounts of syntax and manual editing? Answer I do this differently to @MB1965. SetOptions[$FrontEndSession, MenuConfigurationFile -> "path/to/alternative/MenuSetup.tr" ]; and then to restore the menus: SetOptions[$FrontEndSession, MenuConfigurationFile -> Inherited ]; I find this easy and can be done readily on the fly, switched on and off with buttons etc.

I am 100% new to mathematica and I don't really understand if I am doing this correctly. I have some most code except the calculation of the color. I will do that once I know I am doing this correctly. I am trying to make sure it is correct and if am not I need some direction as to what I am doing wrong. I added comments if that helps. Anything helps! (* Triangle vertices *) v1 = {-2.0, -2.0}; v2 = {2.0, -2.0}; v3 = {0.0, 2.0}; (* xy-space to plot *) c1 = {1, 0, 0}; c2 = {0, 1, 0}; c3 = {0, 0, 1}; I am trying to Compute the barycentric coordiantes of a 2D point xy based on triangle vertices v1 , v2 , v3 and that is what I need help on because I'm not sure that I got it right. (* Input: xy = {x, y} and global v1, v2, v2 each as {x,y} *) (* Output: uvw = {u, v, w}, the barycentric coordinates *) (* The entries in the linear system set-up below need set. I Determine what values in function *) computeBaryCoords[xy_] := ( mat = {{v1[[1]], v2[[1]], v3[[1]]}, {v1[[2]], v2[[2...

Since ColorData["VisibleSpectrum"] is wrong , I would like to have a more accurate function to use. Can this information be extracted from Mathematica itself? Answer Notice: Simon Woods did just this months ago for an answer I missed: It seems that it can. By spelunking ChromaticityPlot I found: Image`ColorOperationsDump`$wavelengths Image`ColorOperationsDump`tris These are a list of wavelengths and their corresponding XYZ color values used by this plot command: ChromaticityPlot["sRGB", Appearance -> {"VisibleSpectrum", "Wavelengths" -> True}] We can therefore use them to generate a new color function: ChromaticityPlot; (* pre-load internals *) newVisibleSpectrum = With[ {colors = {Image`ColorOperationsDump`$wavelengths, XYZColor @@@ Image`ColorOperationsDump`tris}\[Transpose]}, Blend[colors, #] & ]; A comparison with the old function: ArrayPlot[ {Range[385, 745]}, ImageSize -> 400, AspectRatio ->...

When defining some functions which depend on many arguments, sometimes we need to include predicate constraints (?xxxQ) to reduce processing time. My question is simple: is there a way to shorten a long function definition like this: f[x_?NumericQ,y_?NumericQ,z_?NumericQ,k_?IntegerQ,l_?IntegerQ]:=Stuff[x,y,z,k,l] to produce cleaner code?

My question is strongly related to this question , nevertheless I would like to bring it to everyone's attention. Let's say I want to create a new graphics primitive Boing which should look like this Boing[] := Polygon[Join[#1, Reverse[#2]] & @@@ Partition[ Table[{2 x/Pi, y/2*Cos[x]}, {x, -Pi/2, Pi/2, Pi/10}, {y, {-1, 1}}], 2, 1]] Graphics[{Opacity[0.3, Blue], Boing[]}, AspectRatio -> Automatic] As a new primitive, it should clearly work like other primitives like Disk , Rectangle , etc. When I define a FaceForm and EdgeForm one sees that this does not work because the settings are applied to the underlying Polygons Graphics[{EdgeForm[Black], FaceForm[Opacity[0.3, Blue]], Boing[]}, AspectRatio -> Automatic] In this case one could slightly re-arrange the points and create one overall polygon to circumvent the issue Boing[] := Polygon[Join[#1, Reverse[#2]] & @@ Transpose[ Table[{2 x/Pi, y/2*Cos[x]}, {x, -Pi/2, Pi/2, Pi/10}, {y, {-1,...

Is this graph in the list among the so-called "standard" structures used in GraphData ? However, I have not found yet anything like "Carpet" or "Sponge" in the list of the objects that can be built. Maybe, this graph has a different name? For me, using GraphData helps to save time for constructing adjacency matrix; therefore, I would rather prefer using this function than drawing the graph... Thank you very much in advance!

I have the following image: img1 I'm trying to count al these colored cells and draw a circle around them. I really don't now how I can use SelectComponents for this image. And EdgeDetect has the following result: img2 Maybe some tips or examples. Greetings

How might I implement a local HTTP server using either Java, C#, C or purely Mathematica? It should be able to respond with Mathematica input to GET and POST requests ideally on W7. This is related although doesn't really work. If you would like you can read the license here Answer The following guide shows how to conduct communication between nanohttpd , an http server for Java, and Mathematica . The result is a server that, if you go to its address in a web browser, displays the result of SessionTime[] , i.e. the time since the Mathematica kernel associated to the server started. I'm going to write as if the reader was using OS X with Maven installed because that is the operating system I am using, but this solution works on all operating systems with the proper, obvious, modifications. Directories and so on. On OS X Maven can be installed with Brew using brew -install maven Getting up and running with nanohttpd: Download the latest version of nanohttpd from Github . Fol...

Normally, I used ViewPoint in the code in Plot3D. Most of the time, I will use mouse to rotate the 3D object to get a better view point. The problem is, when I find the best view point for me, is there any way to get the ViewPoint parameters for the rotated scene, such as {-1.25, 2.31, 1.8}, so I can repeat the plot or use it in the future? Answer One way is to set a symbol equal to the initial default viewpoint. v = Options[Plot3D, ViewPoint][[1, 2]] (* {1.3, -2.4, 2.} *) Use that symbol dynamically in the plot. Monitor the dynamic value of v and note the value when the rotated plot is pleasing to you: Plot3D[ Sin[x + y^2], {x, -3, 3}, {y, -2, 2}, ViewPoint -> Dynamic[v] ] Dynamic[v] (* {2, -0.9, 2.5} *)

Bug introduced in 9.0 and fixed in 11.3.0 Consider the following symbolic expression (all the c 's are undefined) exp = (-4*I)*(-1 + c22)*Pi*c1[c7[c12], c7[Glu5], c7[c9[c1312][0]]]* c13[{c7[Glu5], c7[c9[c1312][0]]}, c10[c25], c10[c24]]* c8[c11[c15, c6], c5[l, c6]]* c4[c5[p2, c6], c6].c4[c5[l, c6], c6].c4[c5[p1, c6], c6]*c40[c15]* c40[c20] - (4*I)*(-1 + c22)*Pi* c1[c7[c12], c7[Glu5], c7[c9[c1312][0]]]* c13[{c7[Glu5], c7[c9[c1312][0]]}, c10[c25], c10[c24]]* c8[c11[c15, c6], c5[p2, c6]]* c4[c5[p1, c6], c6].c4[c5[p2, c6], c6]*c40[c14]*c40[c15]* c40[c20] - (4*I)*(-1 + c22)*Pi* c1[c7[c12], c7[Glu5], c7[c9[c1312][0]]]* c13[{c7[Glu5], c7[c9[c1312][0]]}, c10[c25], c10[c24]]*(c8[c5[p1, c6], c5[p1, c6]] - 2*c8[c5[p1, c6], c5[p2, c6]] + c8[c5[p2, c6], c5[p2, c6]])*(c4[c5[p1, c6], c6].c4[c5[p1, c6], c6].c4[ c11[c15, c6], c6] - c4[c5[p2, c6], c6].c4[c5[p1, c6], c6].c4[c11[c15, c6], c6] + c4[c5[p1, c6], c6].c4[c11[c15, c6], c6]*c40[c14] - c4[c5[p2, c6], c6].c4[c11[c15, c6], c6]*...

Observe: rand = RandomReal[1, {4, 3, 2}]; Graphics @ Polygon @ rand Graphics[Polygon /@ rand] I am losing anti-aliasing when I use the multiple-polygon syntax form of Polygon . Yet it is possible for Mathematica to apply AA as can be shown with: Style[ Graphics @ Polygon @ rand, Antialiasing -> True ] (Incidentally this Style -applied AA does not copy with Szabolcs's Image Uploader but the in-Notebook appearance is identical to the second output above.) Why am I losing anti-aliasing here? Is there a system option to turn it on, and with what caveat? Answer It seems with antialiasing on, you get seams between adjacent polygons. It's at the end of the possible issues section in the Polygon documentation page. So probably it assumes that by default, with the all-in-one-polygon syntax form (one Polygon head for multiple polygon representations) it's more important to avoid seams for adjacent polygons, and with the multiple- Polygon -syntax, antialiasing is more impor...

I tried ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}, ContourLabels->automatic] , but it messes up the contourplot. How can I just add values to the contours for ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}] ? Answer Looking at the rather dismal automatic placement of contour labels in the example Sin[x y] , I thought it may be worth pointing out that you can often get better results with customized placement. For this, I devised a function burnTooltip in this answer . Here is how to use it for this question: Options[burnTooltips] = {ImageSize -> 360, "LabelFunction" -> (Framed[#, FrameStyle -> None, RoundingRadius -> 8, Background -> RGBColor[1, .8, .4]] &)}; burnTooltips[plot_, opt : OptionsPattern[]] := DynamicModule[{ins = {}, wrapper = OptionValue["LabelFunction"], toolRule = Function[{arg}, Tooltip[t__] :> Button[Tooltip[t], AppendTo[arg, Inset[wrapper[Last[{t}]], MousePosition["Graphic...

Having looked around the intergoogles and Mathematica.SE, I thought I'd pose a question with a minimum working example. Here is the situation I am trying to improve: I am solving a 4th order non linear PDE with NDSolve. It is stiff and I use a stiff solver such as BDF or LSODA. On occassion, I have no choice but to increase the MaxStepFraction to uncomfortable levels. As a result, the code runs longer than usual (made worse by the fact that it is a stiff equation to begin with) Is there any way I could improve NDSolve performance/speed? Here is my minimum example: $HistoryLength = 0; Needs["VectorAnalysis`"] Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"]; Clear[Eq0, EvapThickFilm, h, Bo, \[Epsilon], K1, \[Delta], Bi, m, r] Eq0[h_, {Bo_, \[Epsilon]_, K1_, \[Delta]_, Bi_, m_, r_}] := \!\( \*SubscriptBox[\(\[PartialD]\), \(t\)]h\) + Div[-h^3 Bo Grad[h] + h^3 Grad[Laplacian[h]] + (\[Delta] h^3)/(Bi h + K1)^3 Grad[h] + m (h/(K1 + Bi h)...

This might seem like an overly simple question, but I need to specify custom plot tick marks as integers (no trailing decimal point) if they are approximately integers, but not if they are not. Using Rationalize on all the tick values won't work because I don't want ticks in the form of $\frac{3}{2}$. Consider: roundif = If[Chop[# - Floor[#]] == 0, Rationalize[#], #] & Some tests to show it works as intended: roundif /@ {-1., -1, 0, 0.5, 1500, 1501., 1501.2} (* {-1, -1, 0, 0.5, 1500, 1501, 1501.2} *) roundif /@ Range[-3, 3, 0.5] (* {-3, -2.5, -2, -1.5, -1, -0.5, 0, 0.5, 1, 1.5, 2, 2.5, 3} *) (Of course, I could make it a normal SetDelayed function and make its Attributes include Listable .) Timing seems to be linear in the length of the list and the number of times it is performed. testdata = Range[-30, 30, 0.5]; Do[roundif /@ testdata, {10000}]; // AbsoluteTiming {5.8656000, Null} Is this the most efficient way to do this? Have I missed some subtlety? Answer St...

I would like to efficiently find the maximum $(\sigma,\lambda)$ for the log-likelihood of the derived distribution below. I only need $\sigma$ and $\lambda$ to one decimal place - so not very precise. I have tried lowering both the AccuracyGoal and PrecisionGoal to as low as 1, or 2, but this doesn't appear to affect the rate at which the solution is obtained. The below code creates the function, the some test data, then attempts its maximisation: aDist[σ_, λ_] := TruncatedDistribution[{0, ∞}, MixtureDistribution[{1, 1}, {NormalDistribution[0, σ], ExponentialDistribution[λ]}]]; data = If[# > 0, #, 0] & /@ RandomVariate[aDist[4, 1/3], {20}]; NMaximize[{LogLikelihood[aDist[σ, λ], data], 10 > σ > 0, 1 > λ > 0}, {σ, λ}] Whilst for 20 data points this method returns a solution in a short time, for my actual dataset I need to find a solution for a dataset of size 1000+. As it currently stands, this would be untenable for the above method. I have tried some of the d...

I have a deformed 2D region of triangular Elements specified by their Nodes in $x$ and $y$ coordinate system. In addition, I have a list of Displacements in $y$ direction for each node. I want to ContourPlot the displacements over my deformed region of elements. So far my reasoning was to make a list Nodes2 where each sublist has in the first two places the node position and the third is displacement. Then I use ListContourPlot . Nodes = {{0., 0.}, {10., 0.}, {20., 0.}, {30., 0.}, {-0.101573, 9.81671}, {9.92361, 10.0459}, {19.8914, 10.2668}, {29.7869, 10.5013}, {-0.453558, 19.6276}, {9.57795, 20.086}, {19.5471, 20.5443}, {29.4276, 21.0344}, {-1.06222, 29.4477}, {8.97881, 30.1177}, {18.9679, 30.8116}, {28.8439, 31.5901}, {-1.90436, 39.3141}, {8.12513, 40.1282}, {18.1438, 41.0447}, {28.0142, 42.1991}, {-2.88222, 49.2855}, {7.0891, 50.1568}, {16.9537, 51.1588}, {26.904, 52.9408}}; Elements = {{1, 2, 6}, {6, 5, 1}, {2, 3, 7}, {7, 6, 2}, {3, 4, 8}, {8, 7, 3}, {5, 6, 10}, {10, 9, 5}, {6...

I am trying to compute the shortest distance between a point and a triangle in 3D distance[point_, {p1_, p2_, p3_}] := Module[{p, s, t, sol}, p = s*p1 + (1 - s)*(t*p2 + (1 - t)*p3); MinValue[{(point - p).(point - p), 0 but it seems to be quite slow, is there any way to make it faster? Answer Well, you can use the undocumented RegionDistance which does exactly this as follows: ( This answer, as written, only works for V9 as noted by Oska, for V10 see update below ) here is a triangle in 3D region = Polygon[{{0, 0, 0}, {1, 0, 0}, {0, 1, 1}}]; Graphics3D[region] Now suppose you want to find the shortest distance from the point {1, 1, 1} in 3D to this triangle just do the following: Load the Region context Graphics`Region`RegionInit[]; Then RegionDistance[region, {1, 1, 1}] As a bonus, you can get the exact point on the triangle that is closest to the given point as follows: RegionNearest[region, {1, 1, 1}] Visualize it Graphics3D[{region, Darker@Green, PointSize[0.03], Point[...

I need to plot a graph (to be specific: Fortune Algorithm output) with given vertex coordinates and a few unconnected vertices. I am thinking of using Mathematica for that. GraphPlot does much of the task with VertexCordinateRules option but does not plot unconnected points. So is there any way to do this? And it would be even nicer if that graph comes with 2-D Axes. I was thinking to use ListLinePlot and Point commands but they give two different graphs as output. Is there any option for combining output from two graphs? (The Show command didn't help.) Answer I didn't quite follow the description of your graph, but are you aware of this functionality?: data = MapIndexed[Flatten[{##}] &, RandomReal[1, {100, 2}]]; ListDensityPlot[ data, InterpolationOrder -> 0, ColorFunction -> Hue, Mesh -> All, Epilog -> Point@data[[All, {1, 2}]] ] Specifically note InterpolationOrder -> 0 .