Recent Questions - Mathematica Stack Exchange most recent 30 from mathematica.stackexchange.com 2019-10-18T20:05:16Z https://mathematica.stackexchange.com/feeds https://creativecommons.org/licenses/by-sa/4.0/rdf https://mathematica.stackexchange.com/q/208154 0 Catastrophic loss of precision in numerical integration George Giannoulis https://mathematica.stackexchange.com/users/43644 2019-10-18T19:12:47Z 2019-10-18T19:12:47Z <p>I am trying to get the following code running:</p> <pre><code>t1 = 15.1/15; ξ1 = (t1)/Sqrt[(t1)^2 - 1] t2 = 1.25; ξ2 = (t2)/Sqrt[(t2)^2 - 1] ε0 = 8.854*10^(-12); μ0 = 4*Pi*10^(-7); d = (t2)^(-1/3)*Sqrt[(t2)^2 - 1]; c = 3*10^8; AnalyticalEigenfrequencies = 10^9*{0.461, 0.949, 1.071, 2.403}; εr = {42.4, 41.2, 41.1, 39}; kd = 2 Pi*d/c*AnalyticalEigenfrequencies Hφ[ξ_] := SpheroidalPS[1, 1, kd, ξ]*SpheroidalS1[1, 1, kd, ξ]; Eξ[ξ_, η_] := 2/(d (ξ^2 - 1) (1 - η^2) (I*2*Pi* AnalyticalEigenfrequencies*εr*ε0* Sqrt[1 - η^2]))* SpheroidalS1[1, 1, kd, ξ] ** (Sqrt[1 - η^2] SpheroidalPSPrime[1, 1, kd, ξ] + SpheroidalPS[1, 1, kd, ξ] d/2); Eη[ξ_, η_] := 2/(d (ξ^2 - 1) (1 - η^2))/(I*2*Pi* AnalyticalEigenfrequencies*\[εr*ε0)*(\ SpheroidalS1Prime[1, 1, -kd, ξ]*Sqrt[ξ^2 - 1] + SpheroidalS1[1, 1, kd, ξ] D[Sqrt[ξ^2 - 1], ξ]); We1 = 2 Pi* NIntegrate[ Abs[Eξ[ξ, η]]^2 + Abs[Eη[ξ, η]]^2, {ξ, 0, ξ1}, {η, -1, 1}, WorkingPrecision -&gt; 5, MaxRecursion -&gt; 5]; We2 = 2 Pi* NIntegrate[ Abs[Eξ[ξ, η]]^2 + Abs[Eη[ξ, η]]^2, {ξ, 0, ξ2}, {η, -1, 1}, WorkingPrecision -&gt; 5, MaxRecursion -&gt; 5]; Wh = 2*2 Pi* NIntegrate[Abs[Hφ[ξ]]^2, {ξ, 0, ξ2}, WorkingPrecision -&gt; 5, MaxRecursion -&gt; 5]; PerturbationFactor = ε0*(εr - 1)*(We1)/(μ0*Wh + ε0*(We2)) PerturbationFrequecnies = AnalyticalEigenfrequencies (1 + PerturbationFactor) </code></pre> <p>but Mathematica keeps showing the message: "NIntegrate::errprec: Catastrophic loss of precision in the global error estimate due to insufficient WorkingPrecision or divergent integral."</p> <p>What does this message mean and how can I avoid it?</p> https://mathematica.stackexchange.com/q/208152 0 Importing a csv file yields weird first character Indeterminate https://mathematica.stackexchange.com/users/54821 2019-10-18T18:50:05Z 2019-10-18T19:48:43Z <p>Whenever I import a CSV file, I get this weird character at the beginning of the file ,I am not sure why. How can I avoid this? <a href="https://i.stack.imgur.com/uFG0z.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/uFG0z.png" alt="enter image description here"></a></p> https://mathematica.stackexchange.com/q/208149 2 Interpolating and subtracting two sets of data Indeterminate https://mathematica.stackexchange.com/users/54821 2019-10-18T17:49:59Z 2019-10-18T19:59:14Z <p>I have a data set "data9k" with x varying from 0 to 365, and another data "data0" set with x varying from 0 to 365. But the x values for both data sets are not same but similar. I want to subtract the y values of "data0" from "data9k". I am assuming I should first interpolate both data9k and data0 from 0 to 360 [I only want the 0 to 360 range] and then subtract them? How should I interpolate? Is there a better way to do this?</p> <p>Here are my data sets</p> <pre><code>data9k = {{1.1172, 4.62*10^-8}, {12.619, 4.47*10^-8}, {24.638, 4.44*10^-8}, {35.7164, 4.34*10^-8}, {47.7885, 4.14*10^-8}, {59.3201, 4.14*10^-8}, {71.6327, 3.83*10^-8}, {83.2878, 3.44*10^-8}, {94.4534, 3.39*10^-8}, {106.053, 3.06*10^-8}, {118.451, 3.16*10^-8}, {130.402, 3.32*10^-8}, {142.897, 3.59*10^-8}, {155.719, 4.02*10^-8}, {167.718, 4.35*10^-8}, {179.867, 4.85*10^-8}, {191.746, 4.8*10^-8}, {203.29, 4.99*10^-8}, {215.511, 5.43*10^-8}, {227.228, 5.56*10^-8}, {238.653, 6.02*10^-8}, {251.438, 5.83*10^-8}, {263.693, 5.85*10^-8}, {275.223, 5.27*10^-8}, {287.595, 5.01*10^-8}, {299.263, 5.01*10^-8}, {310.811, 4.85*10^-8}, {322.76, 4.94*10^-8}, {334.224, 4.99*10^-8}, {346.385, 4.84*10^-8}, {358.353, 4.84*10^-8}, {365.005, 4.39*10^-8}, {365.005, 4.68*10^-8}}; data0 = {{1.72155, 6.26*10^-8}, {13.866, 6.02*10^-8}, {25.3934, 5.76*10^-8}, {36.5356, 5.38*10^-8}, {48.7993, 5.24*10^-8}, {60.9991, 5.12*10^-8}, {72.9415, 5.*10^-8}, {84.1156, 4.91*10^-8}, {95.8728, 5.01*10^-8}, {108.136, 5.08*10^-8}, {119.668, 5.06*10^-8}, {131.259, 5.25*10^-8}, {142.742, 5.31*10^-8}, {154.806, 5.62*10^-8}, {166.376, 5.82*10^-8}, {177.496, 5.89*10^-8}, {189.637, 6.1*10^-8}, {202.158, 6.35*10^-8}, {214.349, 6.57*10^-8}, {226.658, 6.74*10^-8}, {238.496, 6.77*10^-8}, {250.744, 6.87*10^-8}, {262.746, 6.91*10^-8}, {274.316, 6.94*10^-8}, {286.446, 6.92*10^-8}, {298.52, 6.95*10^-8}, {310.33, 6.76*10^-8}, {322.292, 6.57*10^-8}, {334.268, 6.45*10^-8}, {345.836, 6.16*10^-8}, {357.444, 5.97*10^-8}, {364.946, 5.85*10^-8}, {365.005, 5.92*10^-8}}; </code></pre> https://mathematica.stackexchange.com/q/208148 -2 need code for this coupled system to solve for different parameters Shahid Ali https://mathematica.stackexchange.com/users/67929 2019-10-18T17:42:55Z 2019-10-18T17:42:55Z <p><span class="math-container">\begin{equation}\label{velocity} (1+\lambda{f^2}){f^{\prime\prime\prime}}+ff^{\prime\prime}+2\lambda{f^{\prime}}f^{\prime\prime}- ({f^{\prime}}+\frac{\eta}{2}f^{\prime\prime})-(f^{\prime})^2+M(f^{\prime}-\lambda{f}f^{\prime\prime})=0. \end{equation}</span> <span class="math-container">\begin{equation} \frac{(1+R)\theta^{\prime\prime}}{P_{r}}+2{\theta}+\frac{1}{2}\eta{\theta^{\prime}}-f^{\prime}\theta+ f\theta^{\prime}=0. \end{equation}</span> where <span class="math-container">$P_{r}=\frac{\rho C_{p}}{k}$</span> is the prandtal number. The transformed boundary conditions are: <span class="math-container">\begin{equation} f(0)=0,\quad f^{\prime}(0)=1+N_{1}f^{\prime\prime}(0),\quad \theta^{\prime}(0)=B_{i}(\theta(0)-1),\quad f^{\prime}(\infty)=0,\quad\theta(\infty)=0. \end{equation}</span></p> https://mathematica.stackexchange.com/q/208143 2 SetDelayed error for Derivative rule Mathtrix https://mathematica.stackexchange.com/users/67993 2019-10-18T13:58:57Z 2019-10-18T14:46:07Z <p>Having a delayed assignment of the form</p> <pre><code>Derivative[f][x_] := HoldForm[f[x]] </code></pre> <p>works. But if there is a delayed assignment for f as in</p> <pre><code>f[x_] := g[x] Derivative[f][x_] := HoldForm[f[x]] </code></pre> <p>the error</p> <pre><code>SetDelayed::write: Tag Function in ((g^\[Prime])[#1]&amp;)[x_] is Protected. </code></pre> <p>occurs. Why is <code>f[x]</code> evaluated despite <code>HoldForm</code> and how can I write a delayed assignment of this form?</p> https://mathematica.stackexchange.com/q/208141 4 How can I filter an EntityClass by _not_ having a property? Stephan https://mathematica.stackexchange.com/users/67992 2019-10-18T13:48:50Z 2019-10-18T19:47:45Z <p>With Mathematica 12, I can create implicit Entity Classes like:</p> <p><a href="https://i.stack.imgur.com/iSsOo.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/iSsOo.png" alt="enter image description here"></a></p> <p>I can also filter for having exactly a specific property, like so <a href="https://i.stack.imgur.com/vIMlP.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/vIMlP.png" alt="enter image description here"></a></p> <p>It seems quite trivial, but I can't seem to filter by a property <em>not</em> having some value. For example, I'd like to be able to say</p> <pre><code>EntityClass["Country", "Continent" -&gt; Not["Europe"]] </code></pre> <p>or something like that.</p> <p>The documentation for <code>EntityClass</code> lists the following operators to be working with this syntax:</p> <blockquote> <p>Property values in implicitly defined entity classes may make use of Quantity (and intervals of Quantity) for dimensional values, Between for numeric values, DateObject for dates, TakeLargest and TakeSmallest for ordinal selections, and ContainsAll, ContainsExactly, ContainsAny, ContainsOnly, ContainsNone for entities. Lists of entities are interpreted as ContainsAll, while a single entity is interpreted as ContainsAny[{entity}].</p> </blockquote> <p>But first, non of the listed properties looks like it does what I want, i.e. querying for <em>not</em>.</p> https://mathematica.stackexchange.com/q/208137 2 How can a set of rules be applied to edit strings within a list of lists while maintaining list structure? Stuart Poss https://mathematica.stackexchange.com/users/35282 2019-10-18T12:55:35Z 2019-10-18T17:14:16Z <p>In attempting to read a webpage ("<a href="https://www.house.gov/representatives#by-name" rel="nofollow noreferrer">https://www.house.gov/representatives#by-name</a>") I have managed to import a table using </p> <pre><code>tableText1 = WebExecute[browser, "JavascriptExecute" -&gt; "return document.getElementById('by-name').innerText;"]; </code></pre> <p>I've eventually been able to massage the text, which contains a number of line feeds and blanks and comas at different levels within the table as well as a variable number of columns in each row, into a single table of Dimensions[n,6] of which [11,3] are shown here. However, note that the now third column contains a rather inconsistent series of strings, which I would like to edit following each committee name by a linefeed ("\n") using a list of rules.</p> <pre><code>The subset of data for illustrative purposes is here: table21 = {"Arrington, Jodey", "Texas 19th", "Ways and Means"}, {"Axne, Cynthia", "Iowa 3rd","AgricultureFinancial Services"}, {"Babin, Brian", "Texas 36th", "Transportation and InfrastructureScience, Space, and Technology"}, \ {"Bacon, Don", "Nebraska 2nd", "AgricultureArmed Services"}, {"Baird, James", "Indiana 4th","AgricultureScience, Space, and Technology"}, {"Balderson, Troy", "Ohio 12th","Transportation and InfrastructureSmall BusinessScience, Space, and Technology"}, {"Banks, Jim", "Indiana 3rd", "Armed ServicesEducation and LaborVeterans' Affairs"}, {"Barr, Andy", "Kentucky 6th","Financial ServicesVeterans' Affairs"}, {"Barragán, Nanette", "California 44th","Homeland SecurityEnergy and Commerce"}, {"Bass, Karen","California 37th", "Foreign AffairsJudiciary"}, {"Beatty, Joyce", "Ohio 3rd", "Financial Services"}} </code></pre> <p>As one can see the committee names in the 3rd column are not in a columnar form for each representative and the names run together. Because in the larger list there are many combinations of committees that can not be easily replaced by a single StringReplace[table21,{"a"->"a\n, "b->b\n"...}] expression, I have created a list of rules using Thread as follows:</p> <pre><code>committees = {"Agriculture", "Appropriations", "Armed Services", "Budget", "Climate Change", "Education and Labor", "Ethics", "Energy and Commerce", "Financial Services", "Foreign Affairs", "Homeland Security", "Intelligence", "Judiciary", "Modernization of Congress", "Natural Resources", "Oversight and Reform", "Science, Space and Technology", "Small Business", "Transportation and Infrastrure", "Veterans' Affairs", "Ways and Means"} addlinefeed[x_] := x ~~ "\n"; editedcommittees = addlinefeed /@ committees; rules = Thread[committees -&gt; editedcommittees]; </code></pre> <p>Although I can convert the entire table to a String by doing a StringReplace to effect these edits, in doing so I lose the desirable list structure and getting it back is complicated by the presence of comas used differently in different elements within the list of lists.</p> <p>How can I replace one column of this list of lists suitably edited using StringReplace in combination with my set of rules so that only this single suitably edited column appears as a column of columns within the list of lists, while leaving other columns within the list of lists unchanged? </p> <p>I've tried various combinations of Replace, StringReplace, Map, and MapAt trying to take into account the suitable levels and parts to edit this one column leaving all others the same. However, I have not met with success. A few other questions give hints but I am stumped. How can this be done?</p> https://mathematica.stackexchange.com/q/208136 2 Prevent argument substitution in held expression when injecting into unevaluated code István Zachar https://mathematica.stackexchange.com/users/89 2019-10-18T12:42:59Z 2019-10-18T19:31:36Z <p>I want to write a custom <code>sow/reap</code> pair to wrap any piece of code in <code>sow[code]</code> and call <code>reap</code> to collect the timing of <code>code</code> with a tag that is the <em>completely</em> unevaluated version of <code>code</code>. My proble is that I cannot effectively withhold argument value substitution. I expect to use this pair only on my own functions <code>fun</code> so I can freely get and set <code>DownValues</code> as I like. Of course I expect to put many <code>sow</code> in my definition of <code>fun</code>. See example:</p> <pre><code>ClearAll[sow, reap, fun]; Attributes[reap] = {HoldAllComplete}; reap[x_] := Module[{h = (Hold@x)[[1, 0]], old, new, res}, old = DownValues[Evaluate@h]; (* store old DownValues *) new = old /. {sow[y_] :&gt; Block[{time, out}, {time, out} = AbsoluteTiming@y; Sow[ToString@Unevaluated@y -&gt; time]; out]}; DownValues[Evaluate@h] = new;(* install new DownValues *) res = Reap@x; DownValues[Evaluate@h] = old;(* restore old DownValues *) res]; fun[i_Integer] := sow@(Print["CALLED"]; Table[None, {i}]); </code></pre> <p>Now call <code>reap</code> on <code>fun</code>:</p> <pre><code>In:= reap[fun] During evaluation of In:= CALLED Out= {{None, None}, {{"Print[CALLED]; Table[None, {2}]" -&gt; 0.0000418147}}} </code></pre> <p>This is almost what I want, but not exactly. <strong>How can I keep <code>i</code> from evaluating to the argument value <code>2</code>?</strong> That is, I want to have <code>"Print[CALLED]; Table[None, {i}]"</code> instead of <code>"Print[CALLED]; Table[None, {2}]"</code> in the resulting tag. I guess this cannot be solved locally within any definition of <code>sow</code>, hence the <code>DownValue</code>-manipulation within <code>reap</code>. Can it be solved with the <a href="http://mathematica.stackexchange.com/a/1937/89">injector pattern</a> or the <a href="https://mathematica.stackexchange.com/a/29318/89">Trott-Strzebonski</a> in-place evaluation?</p> <p>I know that I can specify tags manually in <code>Sow</code> but I specifically want to avoid this and simply use <code>sow</code> as a one-argument function. </p> https://mathematica.stackexchange.com/q/208134 2 How to Mathematica applied discrete Fourier transform to matrix? PavelDev https://mathematica.stackexchange.com/users/67991 2019-10-18T12:16:37Z 2019-10-18T13:09:13Z <p>I am new user of Mathematica, sorry if my question odd.</p> <p>I not understanding, how to Mathematica apply the discrete Fourier transform for matrix:</p> <pre><code>Print[Fourier[{{-50, 50}, {50, 50}, {50, -50}}]]; (*Result is: {{40.8248 +0. I,0. +0. I}, {-20.4124+35.3553 I,-61.2372-35.3553 I}, {-20.4124-35.3553 I,-61.2372+35.3553 I}} *) </code></pre> <p>Can you explain the step-by-step execution of this program using only <code>Fourier</code> for 1-d lists?</p> https://mathematica.stackexchange.com/q/208133 1 Finding solutions of a complicated equation Vaggelis_Z https://mathematica.stackexchange.com/users/5052 2019-10-18T11:55:12Z 2019-10-18T13:52:37Z <p>Consider the following setup</p> <pre><code>Clear["Global*"]; r1 = Sqrt[(x + m)^2 + y^2]; r2 = Sqrt[(x + m - 1)^2 + y^2]; w = Sqrt[1 - e]/(1 + e); V = ((1 - a)*(1 - m))/r1 + (m*r2)/(r2^2 + e) + w^2/2*(x^2 + y^2); Vx = D[V, x]; Vx0 = Vx /. {y -&gt; 0}; </code></pre> <p>Now, the equation <code>Vx0 == 0</code> has either 1, 3 or 5 solutions, depending on the particular values of the free parameters <span class="math-container">$m$</span>, <span class="math-container">$a$</span> and <span class="math-container">$e$</span>. Note that <span class="math-container">$m \in (0,0.5]$</span>, <span class="math-container">$a \in [0,0.1]$</span> and <span class="math-container">$e \in [0, 0.1]$</span>.</p> <p>My question is the following: for a given value of <span class="math-container">$m$</span>, let's say <span class="math-container">$m = 0.3$</span>, is there an elegant way to find for which values of <span class="math-container">$a$</span> and <span class="math-container">$e$</span> we have 1, 3 or 5 solutions? Moreover, can we obtain analytical equations giving the <span class="math-container">$x$</span> coordinates of the solutions?</p> <p>Note: I have already found the above using numerical methods (e.g., <code>FindRoot</code> etc). My aim now is to seek whether Mathematica can provide analtical equations regarding the solutions of <code>Vx0</code>. </p> https://mathematica.stackexchange.com/q/208132 2 Speeding up the process of NDSolve[] when a user-defined function is involved? Fazlollah https://mathematica.stackexchange.com/users/1485 2019-10-18T11:10:11Z 2019-10-18T11:10:11Z <p>I am trying to tackle a (1+4 dimensional PDE) model at which the solution of the first PDE (with some interpolations and changing the domain) would be used in the second PDE.</p> <p>In fact, I must choose around <span class="math-container">$m_1=m_2=m_3=m_4=20$</span> nodes along each dimension while solving the second PDE is challenging and time intensive due to calling a user-defined function named as <code>And2[]</code>. </p> <p>My try for a very few nodes is still time consuming when I solve the second PDE with <code>NDSolve[]</code>. See below:</p> <pre><code>ClearAll["Global*"]; (***************PARAMETER SETTINGS***************) TT = 5.; m1 = 6; m2 = 6; m3 = 6; m4 = 6; k1 = .05; size = m1*m2*m3*m4; roRr = 0; roRz = 0; roRy = 0; royz = 0; sigmaR = 0; gammar = 1.; \ gammaz = -0.2; a = 0; sigmay = 0.4; sigmar = 0.08; sigmaz = 0.1; rorz = 0; rory = 0; \[Kappa] = 0.0001; r = 0.02; \[Theta] = -210.; b = 0.1; a1 = 0.08; b1 \ = 0.1; e = 1.15; e1 = 0.45; (***************DOMAIN DISCRETIZATION***************) Rmin = 0.; Rmax = 1.; rmin = 0.; rmax = 1.; ymin = -6.; ymax = 0.; zmin = 0.; zmax = 4.; pt = DeveloperToPackedArray[{0.45, 0.03, -4.089, 1.15}]; xs = Table[(i - 1.)/(m1 - 1), {i, 1, m1}]; nx = xgrid1 = Range[Rmin, Rmax, (Rmax - Rmin)/(m1 - 1)]; ny = ygrid1 = Range[rmin, rmax, (rmax - rmin)/(m2 - 1)]; nz = zgrid1 = Range[ymin, ymax, (ymax - ymin)/(m3 - 1)]; nw = wgrid1 = Range[zmin, zmax, (zmax - zmin)/(m4 - 1)]; dims = {m1, m2, m3, m4}; grids = {nx, ny, nz, nw}; leng = Length[origrid]; origrid = Flatten[Outer[List, nx, ny, nz, nw], 3]; origrid1 = Flatten[Outer[List, nx, ny (1 + gammar), nz, nw (1 + gammaz)], 3]; (***************FILLING SOME MATRICES***************) Idx = SparseArray[{{i_, i_} -&gt; 1.}, {m1, m1}, 0]; Idy = SparseArray[{{i_, i_} -&gt; 1.}, {m2, m2}, 0]; Idz = SparseArray[{{i_, i_} -&gt; 1.}, {m3, m3}, 0]; Idw = SparseArray[{{i_, i_} -&gt; 1.}, {m4, m4}, 0]; DR = KroneckerProduct[(SparseArray@DiagonalMatrix@nx), Idy, Idz, Idw]; Dr = KroneckerProduct[Idx, (SparseArray@DiagonalMatrix@ny), Idz, Idw]; Dy = KroneckerProduct[Idx, Idy, (SparseArray@DiagonalMatrix@nz), Idw]; Dz = KroneckerProduct[Idx, Idy, Idz, (SparseArray@DiagonalMatrix@nw)]; Id = KroneckerProduct[Idx, Idy, Idz, Idw]; Dy2 = KroneckerProduct[Idx, Idy, (SparseArray@DiagonalMatrix@Exp[nz]), Idw]; opt = "DifferenceOrder" -&gt; 2; (***************FOR FIRST SPATIAL VARIABLE***************) dudx = NDSolveFiniteDifferenceDerivative[1, nx, opt][ "DifferentiationMatrix"]; d2udx2 = NDSolveFiniteDifferenceDerivative[2, nx, opt][ "DifferentiationMatrix"]; (***************FOR SECOND SPATIAL VARIABLE***************) dudy = NDSolveFiniteDifferenceDerivative[1, ny, opt][ "DifferentiationMatrix"]; d2udy2 = NDSolveFiniteDifferenceDerivative[2, ny, opt][ "DifferentiationMatrix"]; (***************FOR THIRD SPATIAL VARIABLE***************) dudz = NDSolveFiniteDifferenceDerivative[1, nz, opt][ "DifferentiationMatrix"]; d2udz2 = NDSolveFiniteDifferenceDerivative[2, nz, opt][ "DifferentiationMatrix"]; (***************FOR FOURTH SPATIAL VARIABLE***************) dudw = NDSolveFiniteDifferenceDerivative[1, nw, opt][ "DifferentiationMatrix"]; d2udw2 = NDSolveFiniteDifferenceDerivative[2, nw, opt][ "DifferentiationMatrix"]; (****************BUILDING THE FIRST SYSTEM MATRIX********************) B = SparseArray[ +(1/2 sigmaR^2 DR.(Id - DR)).KroneckerProduct[d2udx2, Idy, Idz, Idw] + (1/2 sigmar^2 Dr).KroneckerProduct[Idx, d2udy2, Idz, Idw] + (1/2 sigmay^2)*KroneckerProduct[Idx, Idy, d2udz2, Idw] + (1/2 sigmaz^2 Dz^2)*KroneckerProduct[Idx, Idy, Idz, d2udw2] + ((roRr*sigmaR*sigmar)*Sqrt[(DR.(Id - DR)).Dr]).KroneckerProduct[ dudx, dudy, Idz, Idw] + ((roRz*sigmaR*sigmaz)*(Dz.Sqrt[DR.(Id - DR)])).KroneckerProduct[ dudx, Idy, Idz, dudw] + ((rorz*sigmar*sigmaz)*(Dz.Sqrt[Dr])).KroneckerProduct[Idx, dudy, Idz, dudw] + ((roRy*sigmaR*sigmay)*(Sqrt[DR.(Id - DR)])).KroneckerProduct[ dudx, Idy, dudz, Idw] + ((rory*sigmar*sigmay)*(Sqrt[Dr])).KroneckerProduct[Idx, dudy, dudz, Idw] + ((royz*sigmay*sigmaz)*Dz).KroneckerProduct[Idx, Idy, dudz, dudw] + (a*(b*Id - DR)).KroneckerProduct[dudx, Idy, Idz, Idw] + (a1 (b1*Id - Dr)).KroneckerProduct[Idx, dudy, Idz, Idw] + ((r*Id - Dr).Dz).KroneckerProduct[Idx, Idy, Idz, dudw] + (\[Kappa] (\[Theta]*Id - Dy)).KroneckerProduct[Idx, Idy, dudz, Idw] - (r*Id) ]; B0 = B; payoff = Flatten@ Table[(1 - nx[[i]]) nw[[l]] (1 + gammaz), {i, 1, m1}, {j, 1, m2}, {k, 1, m3}, {l, 1, m4}]; initc = Thread[v == payoff]; s = NDSolveValue[{D[v[t], t] == B.v[t], v == initc[[All, 2]]}, v, {t, 0, TT}, Method -&gt; {"FixedStep", "StepSize" -&gt; k1, Method -&gt; {"ExplicitRungeKutta", "DifferenceOrder" -&gt; 4, "StiffnessTest" -&gt; False}}, PrecisionGoal -&gt; 5, AccuracyGoal -&gt; 5]; And1[time_Real] := Block[{sol2 = s[time]}, Interpolation@Join[origrid1, Partition[sol2, 1], 2] ] And2[t2_Real] := Quiet@(And1[t2] @@@ origrid) (****************BUILDING THE SECOND SYSTEM MATRIX********************) B = SparseArray[ +(1/2 sigmaR^2 DR.(Id - DR)).KroneckerProduct[d2udx2, Idy, Idz, Idw] + (1/2 sigmar^2 Dr).KroneckerProduct[Idx, d2udy2, Idz, Idw] + (1/2 sigmay^2)*KroneckerProduct[Idx, Idy, d2udz2, Idw] + (1/2 sigmaz^2 Dz^2)*KroneckerProduct[Idx, Idy, Idz, d2udw2] + ((roRr*sigmaR*sigmar)*Sqrt[(DR.(Id - DR)).Dr]).KroneckerProduct[ dudx, dudy, Idz, Idw] + ((roRz*sigmaR*sigmaz)*(Dz.Sqrt[DR.(Id - DR)])).KroneckerProduct[ dudx, Idy, Idz, dudw] + ((rorz*sigmar*sigmaz)*(Dz.Sqrt[Dr])).KroneckerProduct[Idx, dudy, Idz, dudw] + ((roRy*sigmaR*sigmay)*(Sqrt[DR.(Id - DR)])).KroneckerProduct[ dudx, Idy, dudz, Idw] + ((rory*sigmar*sigmay)*(Sqrt[Dr])).KroneckerProduct[Idx, dudy, dudz, Idw] + ((royz*sigmay*sigmaz)*Dz).KroneckerProduct[Idx, Idy, dudz, dudw] + (a*(b*Id - DR)).KroneckerProduct[dudx, Idy, Idz, Idw] + (a1 (b1*Id - Dr)).KroneckerProduct[Idx, dudy, Idz, Idw] + ((r*Id - Dr).Dz).KroneckerProduct[Idx, Idy, Idz, dudw] + (\[Kappa] (\[Theta]*Id - Dy)).KroneckerProduct[Idx, Idy, dudz, Idw] - (r*Id) ]; B0 = B; B = SparseArray[ B0 - Dy2 - gammaz*(Dy2.(Dz.KroneckerProduct[Idx, Idy, Idz, dudw]))]; payoff1 = Flatten@Table[0., {i, 1, m1}, {j, 1, m2}, {k, 1, m3}, {l, 1, m4}]; initc = Thread[v2 == payoff1]; k2 = 4 k1; fu = ParallelTable[Dy2.And2[t2], {t2, 0, TT, k2}]; // AbsoluteTiming ss = NDSolveValue[{D[v2[t2], t2] == B.v2[t2] + Dy2.And2[t2], v2 == initc[[All, 2]]}, v2, {t2, 0, TT}, Method -&gt; {"FixedStep", "StepSize" -&gt; k2, Method -&gt; {"ExplicitRungeKutta", "DifferenceOrder" -&gt; 4, "StiffnessTest" -&gt; False}}, PrecisionGoal -&gt; 5, AccuracyGoal -&gt; 5]; // AbsoluteTiming </code></pre> <p>This code takes around 12 second in my system to solve the last <code>NDSolveValue[]</code>. </p> <p>Can anyone suggest how we can speed up the process of <code>NDSolve[]</code> as a time-stepping method, when we call a user-defined function inside it?</p> <p>I checked for any CUDA applicability or something like that, but I failed. Maybe a compilation of the function <code>And2[]</code> into <code>C</code> or another idea could help.</p> <p>Thank you. </p> https://mathematica.stackexchange.com/q/208131 0 Set Theory Question Jic https://mathematica.stackexchange.com/users/67987 2019-10-18T10:01:19Z 2019-10-18T12:19:19Z <p>Q: Sum 40 balls in a box, 8= Blue, 13= Black, remaining= grey, I pick 5 balls randomly, pick another then put 1 back, pick another then put 1 back, </p> <p>i. Then return a ball &amp; pick another different color, chance Blue &amp; Black </p> <p>I. ≥ 2?</p> <p>II. ≥ whatever # within draw #?</p> <p>ii. After i. pick 1x randomly, then i. . This step's repeated an arbitrary # of times, </p> <p>I. ≥ 2?</p> <p>II. ≥ whatever # within draw #?</p> <p>I'm new to mathematica, so <code>Union[{8}]</code> ...? If anyone knows how to do this q pls point me in the right direction?</p> https://mathematica.stackexchange.com/q/208129 0 Define a function including two solve solutions Riccardo https://mathematica.stackexchange.com/users/67804 2019-10-18T09:15:09Z 2019-10-18T17:54:24Z <p>I'm trying to combine the solutions coming from two <a href="https://reference.wolfram.com/language/ref/NSolve.html" rel="nofollow noreferrer"><code>NSolve</code></a>s and define a new function that I've to integrate.</p> <p>Basically I've defined two <code>NSolve</code> solutions with the names <code>eqpart</code> and <code>usol</code>. I've assigned their solutions to three functions, <code>xtot[Tx]</code>, <code>ne[y]</code> and <code>T[y]</code>.</p> <pre><code>eq = ξ^-1*D[ξ*D[u[ξ], ξ], ξ] + u[ξ]^(3/7); usol = NDSolve[{eq == 0, u[ξmax] == 1*^-10, u'[ξmin] == 0}, u, {ξ, ξmin, ξmax}]; ne[ξ_] := (ne0/(2*m0*a0^(2/7)))*(a0/(u[ξ] /. usol))^(2/7); T[ξ_] := At*(u[ξ] /. usol)^(2/7); eqpart[Tx_?NumericQ] := NSolve[ {xs == 2*ys^2/RxB[Tx] + ys, 16*ys^4/(RxA[Tx]*RxB[Tx]) + 2*ys^2 + RxB[Tx]*ys - RxB[Tx] == 0, 0 &lt;= xs &lt;= 1, 0 &lt;= ys &lt;= 1, 0 &lt;= xs - ys &lt;= 1}, {xs, ys} ]; npe[Tx_] := 2*ngas*(ys /. eqpart[Tx]); xtot[Tx_] := npe[Tx]/(2*ngas); </code></pre> <p>The problem is when I try to do this</p> <pre><code>neff[ξ_] := ne[ξ]*xtot[T[ξ]]; neff0 = NIntegrate[neff[ξ]*Lc*2*Pi*Rc^2*ξ, {ξ, ξmin, ξmax}]/(Pi*Rc^2*Lc); </code></pre> <p>As an output I have several errors saying that </p> <blockquote> <p>eqpart... is neither a list of replacement rules nor a valid dispatch table, and so cannot be used for replacing</p> </blockquote> <p>What I'm doing wrong?</p> https://mathematica.stackexchange.com/q/208127 1 why some parts of my curve are removed or wiped Ragab Zidan https://mathematica.stackexchange.com/users/67253 2019-10-18T08:18:05Z 2019-10-18T16:45:44Z <p>When I try to draw the next code I get a curve with missing parts, as shown in the picture. I do not know if it is an precision <a href="https://i.stack.imgur.com/YqCcV.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/YqCcV.jpg" alt="enter image description here"></a>problem in the Mathematica program or is some data not calculated. Or is it a problem in the way of writing code ?. I'm sure that oriented should be connected.</p> <pre><code>r=2.0; T=0.05; β=1/T; J=1.0; Clear@UL;UL[B_]:=( η =Sqrt[J^2+B^2 r^4]; Z=2( Cosh[(2 J β)/r^2]+Cosh[(2 β η)/r^2]); Subscript[μ, +]=1/(2Z) ( E^(-((2 J β)/r^2))+Cosh[(2 β η)/r^2]-J/η Sinh[(2 β η)/r^2]); Subscript[ϵ, -]=1/(2Z) (- E^(-((2 J β)/r^2))+Cosh[(2 β η)/r^2]-J/η Sinh[(2 β η)/r^2]); Subscript[ϵ, +]=1/(2Z) ( E^((2 J β)/r^2)+Cosh[(2 β η)/r^2]+J/η Sinh[(2 β η)/r^2]); Subscript[μ, -]=1/(2Z) (-E^(((2 J β)/r^2))+ Cosh[(2 β η)/r^2]+J/ η Sinh[(2 β η)/r^2]); \[ScriptK]=-((B r^2 Sinh[(2 β η)/r^2])/(2 η Z)); X1=Cosh[(2 J β)/r^2]/Z; X2=Cosh[(2 J β)/r^2]/Z; X3=1/Z (Cosh[(2 β η)/r^2]+(B (r^2) )/ η Sinh[(2 β η)/r^2]); X4=1/Z (Cosh[(2 β η)/r^2]-(B (r^2) )/ η Sinh[(2 β η)/r^2]); ϖ=Sqrt[(Sinh[(2 J β)/r^2]+J/η Sinh[(2 β η)/r^2])^2+(B^2 r^4 Sinh[(2 β η)/r^2]^2)/ (η^2) ]; Z1=1/4 -ϖ/(2Z); Z2=1/4 -ϖ/(2Z); Z3=1/4 +ϖ/(2Z); Z4=1/4 +ϖ/(2Z); B1=1/2 (1-4 \[ScriptK]); B2=1/2 (1+4 \[ScriptK]); SρσxB=-X1*Log[2,X1]-X2*Log[2,X2]-X3*Log[2,X3]-X4*Log[2,X4]; SρσzB=-Z1*Log[2,Z1]-Z2*Log[2,Z2]-Z3*Log[2,Z3]-Z4*Log[2,Z4]; SρB=-B1*Log[2,B1]-B2*Log[2,B2]; SρσxB+SρσzB-2*SρB) ULPlot=Plot[UL[B],{B,0.02,10},PlotRange-&gt;All] </code></pre> https://mathematica.stackexchange.com/q/208124 3 wolframscript command line output from ParallelDo kernels contains lots of gibberish Mattia Landoni https://mathematica.stackexchange.com/users/60413 2019-10-18T02:12:08Z 2019-10-18T15:28:45Z <p>I run this code:</p> <pre><code>ParallelDo[ Print["Hi"];, {i,Range} ] </code></pre> <p>And I get this:</p> <pre><code>Launching kernels... StringForm[From 1:, ParallelKernelskernel[ParallelKernelsPrivatebk[SubKernelsLocalKernelslocalKernel[SubKernelsLocalKernelsPrivatelk[LinkObject["C:\Program Files\Wolfram Research\Mathematica\12.0\WolframKernel" -noicon -subkernel -noinit -nopaclet -wstp, 93, 4], {"C:\Program Files\Wolfram Research\Mathematica\12.0\WolframKernel" -noicon -subkernel -noinit -nopaclet -wstp, SubKernelsLocalKernelsLowerPriority -&gt; False}, SubKernelsLocalKernelsPrivatespeed$1005, SubKernelsLocalKernelsPrivatepreemptive<span class="math-container">$1005]], ParallelKernelsPrivateid$</span>1021, ParallelKernelsPrivatename$1021], ParallelKernelsPrivateek[ParallelKernelsPrivatenev$1022, ParallelKernelsPrivatepb<span class="math-container">$1022, ParallelKernelsPrivaterd$</span>1022], ParallelKernelsPrivatesk[ParallelKernelsPrivateq<span class="math-container">$1023, ParallelKernelsPrivaten0$</span>1023, ParallelKernelsPrivaten1$1023]]] Hi StringForm[From 1:, ParallelKernelskernel[ParallelKernelsPrivatebk[SubKernelsLocalKernelslocalKernel[SubKernelsLocalKernelsPrivatelk[LinkObject["C:\Program Files\Wolfram Research\Mathematica\12.0\WolframKernel" -noicon -subkernel -noinit -nopaclet -wstp, 92, 3], {"C:\Program Files\Wolfram Research\Mathematica\12.0\WolframKernel" -noicon -subkernel -noinit -nopaclet -wstp, SubKernelsLocalKernelsLowerPriority -&gt; False}, SubKernelsLocalKernelsPrivatespeed$1004, SubKernelsLocalKernelsPrivatepreemptive<span class="math-container">$1004]], ParallelKernelsPrivateid$</span>1017, ParallelKernelsPrivatename$1017], ParallelKernelsPrivateek[ParallelKernelsPrivatenev$1018, ParallelKernelsPrivatepb<span class="math-container">$1018, ParallelKernelsPrivaterd$</span>1018], ParallelKernelsPrivatesk[ParallelKernelsPrivateq<span class="math-container">$1019, ParallelKernelsPrivaten0$</span>1019, ParallelKernelsPrivaten1$1019]]] Hi </code></pre> <p>This is especially disruptive because the middle line ("StringForm[...") wraps across and takes over most of my screen space. Reading the output becomes very difficult. Is there a way to hide the gibberish?</p> https://mathematica.stackexchange.com/q/208086 0 Plotting a ListLinePlot and NonLinearModelFit on the same graph Epideme https://mathematica.stackexchange.com/users/49550 2019-10-17T16:01:21Z 2019-10-18T13:14:18Z <pre><code>data := Import[ "C:\\Users\\ControlRoom6\\Documents\\Wolfram \ Mathematica\\testdata.csv"] model = a x + b x^2 + c x^3 + d nlm = NonlinearModelFit[data, model, {a, b, c, d}, x] ListLinePlot[{data, nlm[x]}, PlotRange -&gt; {{0, 30}, {0, 35}}, PlotStyle -&gt; {Directive[RGBColor[1, 0.5, 0], AbsoluteThickness]}, PlotTheme -&gt; "Detailed", PlotLabel -&gt; "A ListLinePlot of Test CSV Data", LabelStyle -&gt; {Black, Bold}, Frame -&gt; {{True, False}, {True, False}}, FrameLabel -&gt; {"Quantity 1 (Units)", "Quantity 2 (Units)"}, ImageSize -&gt; {800, 600}, Epilog -&gt; {RGBColor[0.01, 0.65, 0], AbsolutePointSize, Point[data]}] </code></pre> <p>I would like to plot my NonLinearModel on the same plot as the actual line joining the points here, but when I run the code, I only get the line joining the points. Can anyone help me with getting the graph to show both lines? It worked when it was separated as 2 graphs</p> https://mathematica.stackexchange.com/q/208085 0 Non-linear differential equation with tricky variable dependence Lele https://mathematica.stackexchange.com/users/64007 2019-10-17T15:54:09Z 2019-10-18T14:11:21Z <p>My problem regards solving a differential equation and can be reduced to the problem of finding <span class="math-container">$f(x)$</span> such that <span class="math-container">$\frac{df}{dx}=\frac{dh}{df}$</span>, with <span class="math-container">$h(f)$</span> a known function.</p> <p>I have this list of data, from which I define a function <code>myfun</code> via <code>Interpolation</code> and enlarge its domain with <code>Piecewise</code> in the following way:</p> <pre><code>mydata={{0.0000255111, 3.48715}, {0.0000497289, 3.48715}, {0.0000760032, 3.68666}, {0.000101685, 4.13102}, {0.000127819, 4.8565}, {0.000160668, 5.89031}, {0.000199871, 7.03839}, {0.000251762, 8.11573}, {0.000510537, 10.1906}, {0.000759276, 10.6694}, {0.00131224, 10.8689}, {0.00205196, 10.8689}, {0.0039503, 10.8689}, {0.00586421, 10.8939}, {0.00936259, 10.9687}, {0.0121416, 11.0684}, {0.0157784, 11.1682}, {0.0214132, 11.7097}, {0.0269805, 12.465}, {0.0329414, 13.1633}, {0.0438442, 14.3354}, {0.0542594, 15.1783}, {0.0848459, 16.9373}, {0.105548, 18.4687}, {0.12379, 20.6365}, {0.132191, 22.4652}, {0.142875, 25.3083}, {0.15004, 27.8604}, {0.159849, 31.6752}, {0.167637, 34.0867}, {0.174909, 36.6097}, {0.180292, 39.116}, {0.187948, 41.5931}, {0.199271, 43.9}, {0.209739, 46.4811}, {0.225458, 48.9749}, {0.249185, 51.8844}, {0.270797, 54.2419}, {0.294283, 56.4441}, {0.320717, 58.4715}, {0.355922, 60.696}, {0.399908, 62.9903}, {0.468012, 65.264}, {0.537837, 67.6701}, {0.651061, 70.2674}, {0.770893, 72.5252}, {0.936818, 74.8075}, {1.12961, 76.9189}, {1.39071, 79.1248}, {1.74812, 80.9415}, {2.24823, 82.6618}, {2.80845, 83.7092}, {3.61942, 84.6744}, {4.4099, 85.2231}, {5.69251, 85.5709}, {7.33036, 85.8964}, {10.4519, 86.1783}, {13.1381, 86.691}, {16.5145, 87.616}, {20.7588, 88.7737}, {26.0938, 90.4665}, {31.4639, 92.2634}, {37.1584, 94.0748}, {44.8055, 96.3118}, {54.0264, 98.3997}, {66.5137, 100.666}, {83.6078, 102.479}, {105.095, 103.924}, {140.871, 105.274}, {176.744, 105.871}, {222.168, 106.231}, {279.265, 106.498}, {351.037, 106.642}, {441.253, 106.639}, {554.656, 106.842}, {697.203, 106.887}, {870.332, 106.902}, {1101.62, 106.932}, {1384.73, 106.932}, {1740.61, 106.932}, {2187.95, 106.932}, {2750.26, 106.932}, {3457.08, 106.932}, {4345.55, 106.932}, {5462.36, 106.932}, {6866.2, 106.932}, {8630.82, 106.932}, {10393.3, 106.932}, {12043.3, 106.932}}; myfun=Interpolation[mydata]; f[x_]:=Piecewise[{{myfun[x], x &lt;= 1000}, {myfun, x &gt; 1000}}]; </code></pre> <p>Now, I want to find a new function <code>T[t]</code> that satisfies this differential equation, where <span class="math-container">$f(T)$</span> is the function <code>f</code> defined with the list of data.</p> <p><span class="math-container">$$\dfrac{1}{T}\dfrac{dT}{dt}=-\dfrac{1}{1+\frac{1}{3}\frac{T}{f(T)}\frac{df(T)}{dT}}$$</span></p> <p>This is what I've done (the initial conditions should be reasonable for the problem I am tackling):</p> <pre><code>diffeq={T[t]'/T[t]==-1/(1+0.3*T[t]/f[T[t]]*f[T[t]]')}; NDSolve=[diffeq,T[-40]==10^10,T,{t,-40,0}]; </code></pre> <p>My code fails at finding the solution and I suspect that the problem resides in how I write the differential equation. I think that nesting the function <code>T[t]</code> that I want to find inside another function <code>f[T]</code> (and also making a derivative of <code>f</code>) drives Mathematica crazy.</p> <p>How can I manage this task?</p> <p>Thank you for your help!</p> <hr> <p><strong>Update, after the answer of Petrini</strong></p> <p>His method seems to work, but the error one receives is of the type</p> <blockquote> <p>Power::infy: Infinite expression 1/0 encountered.</p> </blockquote> <p>I have noticed that the function <code>f</code> has some serious smoothness problems, a glitch of <code>Interpolation</code>. Its shape is like this:</p> <p><a href="https://i.stack.imgur.com/JqyDG.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/JqyDG.png" alt="Graph of the function"></a></p> <p>but when you zoom in several intervals, like <code>10^-3,10^-2</code> you get this wiggling behaviour, whereas the data show a decreasing one, without oscillating.</p> <p><a href="https://i.stack.imgur.com/QAaNa.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/QAaNa.png" alt="function zoomed"></a></p> <p>The real problem (linked to the previous one I suppose) regards the derivative function, because if I plot <code>f'[x]</code> I get something that is a complete mess:</p> <p><a href="https://i.stack.imgur.com/IOTUX.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/IOTUX.png" alt="derivative of function"></a></p> <p>Hence, the 1/0 error should rise from here.</p> <p>So maybe the problem now is more like</p> <p><strong>How do you get rid of that problematic behaviour of the function and its derivative?</strong></p> https://mathematica.stackexchange.com/q/208045 27 Is there any algorithm that runs faster in Mathematica than in C or Fortran? [on hold] Gummala Navneeth https://mathematica.stackexchange.com/users/66938 2019-10-17T05:35:48Z 2019-10-18T15:50:34Z <p>I'm just curious. My friend just told me that Mathematica is mostly for symbolic calculation and not efficient for Numerical computations. He told me that's the reason most of the people don't use Mathematica for CFD and other numerical intensive code.</p> <p>I've just started with Mathematica (I don't know C and Fortran). I was assuming that since Mathematica is new when compared to C and Fortran it should have included all the problems that C and Fortran might have, and since Mathematica has many inbuilt functions it should run faster than C and Fortran.</p> <p>Why is this not the case?</p> <p>Is there any case where Mathematica's code runs faster than C and Fortran?</p> https://mathematica.stackexchange.com/q/208040 2 How to track a moving blob in video? M.R. https://mathematica.stackexchange.com/users/403 2019-10-17T03:02:39Z 2019-10-18T19:14:55Z <p>I have a video of nanotubes in solution taken with a confocal laser microscope. I typically track these nanotubes with Fiesta or Fiji, but in this case, there is variation in brightness that is confounding my tracking programs.</p> <p><a href="https://i.stack.imgur.com/s5SK9.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/s5SK9.png" alt="enter image description here"></a></p> <p>Here’s a link to <a href="https://www.dropbox.com/s/6cry46t43uxynlp/0apyraselong%202019%20January%2030%2018_59_36.tif?dl=0" rel="nofollow noreferrer">the full video (.tif file)</a></p> <p><strong>What I tried</strong> </p> <p>If you can't download the above link, here are 2001 frames in TIF file, it might take a few minutes to download:</p> <pre><code>frames = CloudGet @ CloudObject @ "https://www.wolframcloud.com/obj/b4056a15-97e5-464a-879e-89852b85ebfd"; </code></pre> <p><a href="https://i.stack.imgur.com/TmWle.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/TmWle.png" alt="enter image description here"></a></p> <p>Using the image tool-ribbon to get points in the target blob:</p> <p><a href="https://i.stack.imgur.com/OWyx0.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/OWyx0.png" alt="enter image description here"></a></p> <p>So then extract the region of the nanotube as a mask:</p> <pre><code>pts = {{104.125, 63.28125}, {89.1328125, 66.29296875`}}; RegionBinarize[frames[], pts, .6] </code></pre> <p><a href="https://i.stack.imgur.com/K6bMq.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/K6bMq.png" alt="enter image description here"></a></p> <p>But then using <code>ImageCorrespondingPoints</code> and <code>ImageFeatureTrack</code> the results were pretty bad:</p> <pre><code>pos = ImageValuePositions[RegionBinarize[frames[], c, .6], 1]; res = ImageFeatureTrack[frames, pos] Graphics[{If[FreeQ[#, _Missing], {RandomColor[], Line[{#}]}] &amp; /@ Transpose[res]}] </code></pre> <p><a href="https://i.stack.imgur.com/ip8LV.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/ip8LV.png" alt="enter image description here"></a></p> <pre><code>g = If[FreeQ[#, _Missing], Graphics@Point@#, Nothing] &amp; /@ res; ListAnimate@g </code></pre> <p>Treating everything as points doesn't really help in recovering the perimeter:</p> <p><a href="https://i.stack.imgur.com/tXl3W.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/tXl3W.png" alt="enter image description here"></a></p> <p>I was hoping some cv experts could help out with tracking the deforming shape of the nanotube over all the frames. </p> https://mathematica.stackexchange.com/q/208030 2 Where is the numerical solving breaking down? Aaron Stevens https://mathematica.stackexchange.com/users/42243 2019-10-16T23:28:56Z 2019-10-18T18:53:18Z <p>I am working with a set of three coupled reaction-diffusion PDEs, and for some parameter values I am getting some not so great solutions. I have been searching documentation and tutorials, and I have been trying to implement various methods and change various settings, but I feel like I am just blindly trying things without fully understanding what is going on. The equations might look intimidating, but I have supplied my code as well to help make everything reproducible.</p> <p>As a summary, I was asking about why a bad solution is obtained for a certain parameter set. As I went through testing my problem to make this post I came across a second issue where the solution behavior also depended on the end time of integration, which seems odd to me. Why am I running into these issues?</p> <hr> <h1>Equations</h1> <p>The set of equations I am working with is as follows: <span class="math-container">$$\frac{\partial x}{\partial t}=\left(1+\frac{\gamma_{pL}\cdot y_T}{(1+\gamma_P\cdot x)^2}\right)^{-1}\cdot\left[\gamma_{D_P}\cdot\nabla^2x+\gamma_a\cdot x_I+\gamma_c\cdot\frac{\gamma_{pL}}{\gamma_P}\cdot\left(\frac{\gamma_P\cdot x}{1+\gamma_P\cdot x}\right)^2\cdot y_T\right]$$</span></p> <p><span class="math-container">$$\frac{\partial y_T}{\partial t}=-\gamma_c\cdot\frac{\gamma_P\cdot x}{1+\gamma_P\cdot x}\cdot y_T$$</span></p> <p><span class="math-container">$$\frac{\partial z}{\partial t}=\left(1+\frac{\gamma_R}{(1+\gamma_L\cdot z)^2}\right)^{-1}\cdot\left[\gamma_{D_L}\cdot\nabla^2z+\gamma_c\cdot\frac{\gamma_P\cdot x}{1+\gamma_P\cdot x}\cdot y_T\right]$$</span></p> <p>where <span class="math-container">$x$</span>, <span class="math-container">$y_T$</span>, and <span class="math-container">$z$</span> are functions of <span class="math-container">$r$</span> (polar coordinate) and <span class="math-container">$t$</span> (time), <span class="math-container">$x_I$</span> is a source term given by <span class="math-container">$$x_I=\frac{1}{2\cdot\gamma_{D_P}\cdot t+1}\cdot\exp\left(-\frac{r^2}{2\cdot(2\cdot\gamma_{D_P}\cdot t+1)}-\gamma_a\cdot t\right)$$</span> and all <span class="math-container">$\gamma_i$</span> terms are parameters.</p> <p>Initial conditions and boundary conditions are as follows: <span class="math-container">$$x(r,0)=z(r,0)=0,\ y_T(r,0)=1$$</span> <span class="math-container">$$\left.\frac{\partial x}{\partial t}\right|_{r=0}=\left.\frac{\partial z}{\partial t}\right|_{r=0}=0$$</span> <span class="math-container">$$x(\infty,0)=z(\infty,0)=0$$</span></p> <p>In words, we start off with no <span class="math-container">$x$</span> and <span class="math-container">$z$</span>, and <span class="math-container">$y_T$</span> starts at a maximum value of <span class="math-container">$1$</span> across all space. The no-flux boundary condition at the origin is because the system has radial symmetry, and we want <span class="math-container">$x$</span> and <span class="math-container">$z$</span> to go to <span class="math-container">$0$</span> at <span class="math-container">$\infty$</span>.</p> <hr> <h1>Code</h1> <p>To tweak the above equations to work nicely in Mathematica (I think?), we need to use a "large" value of <span class="math-container">$r$</span> in place of <span class="math-container">$\infty$</span> and we need to use a point close to <span class="math-container">$r=0$</span> rather than <span class="math-container">$r=0$</span> itself (due to the <span class="math-container">$1/r$</span> term in the Laplacian in polar coordinates).</p> <pre><code>dr = .001; (*"small" r since we cannot use the origin in polar coordinates*) \[Rho]Far = 100.; (*r that is "infinity"*) \[Tau]max = 6.38;(*time to solve out to*) </code></pre> <p>The equations above:</p> <pre><code>xI = 1/(2*\[Gamma]DP*t + 1)*Exp[-(r-dr)^2/(2*(2*\[Gamma]DP*t + 1)) - \[Gamma]a*t]; dx = D[x[r, t],t] == (1 + (\[Gamma]pL*yT[r, t])/(1 + \[Gamma]P*x[r,t])^2)^-1*(\[Gamma]DP*Laplacian[x[r, t], {r, \[Theta]}, "Polar"] + \[Gamma]a*xI + \[Gamma]c*\[Gamma]pL/\[Gamma]P*((\[Gamma]P*x[r, t])/(1 + \[Gamma]P*x[r, t]))^2*yT[r, t]); dyT = D[yT[r, t], t] == (-\[Gamma]c*\[Gamma]P*x[r, t]*yT[r, t])/(1 + \[Gamma]P*x[r, t]); dz = D[z[r, t],t] == (1 + \[Gamma]R/(1 + \[Gamma]L*z[r, t])^2)^-1*(\[Gamma]DL*Laplacian[z[r, t], {r, \[Theta]},"Polar"] + (\[Gamma]c*\[Gamma]P*x[r, t]*yT[r, t])/(1 + \[Gamma]P*x[r, t])); </code></pre> <p>Intial/Boundary Conditions:</p> <pre><code>initx = x[r, 0] == 0.; bc1x = (D[x[r, t], r] == 0) /. r -&gt; dr; bc2x = x[\[Rho]Far, t] == 0.; inityT = yT[r, 0] == 1.; initz = z[r, 0] == 0; bc1z = (D[z[r, t], r] == 0) /. r -&gt; dr; bc2z = z[\[Rho]Far, t] == 0.; </code></pre> <p>Putting it all together:</p> <pre><code>deqns = {dx, dyT, dz, initx, bc1x, bc2x, inityT, initz, bc1z, bc2z}; </code></pre> <h3>Problem</h3> <p>My problem arises for certain parameter values (not all). I have also found that using </p> <pre><code>MaxStepSize -&gt; .1 </code></pre> <p>for NDSolveValue seems to help with some instances of my problem, but not all. An example of a "good solution" can be obtained with the following parameters</p> <pre><code>paramsGood = {\[Gamma]DP -&gt; 0.001222, \[Gamma]DL -&gt; 122.2, \[Gamma]a -&gt; 1., \[Gamma]c -&gt; 100., \[Gamma]P -&gt; 0.01, \[Gamma]pL -&gt; 0.01, \[Gamma]L -&gt; 100., \[Gamma]R -&gt; 0.01}; zSoln = NDSolveValue[deqns /. paramsGood, z, {r, dr, \[Rho]Far}, {t,0., \[Tau]max}, MaxStepSize -&gt; .1]; Plot[zSoln[r, 2.6], {r, dr, 15}, PlotRange -&gt; {-.002, .002}] </code></pre> <p><a href="https://i.stack.imgur.com/Mm0vT.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/Mm0vT.png" alt="enter image description here"></a></p> <p>However, the following bad parameter set</p> <pre><code>paramsBad = {\[Gamma]DP -&gt; 0.1222, \[Gamma]DL -&gt; 122.2, \[Gamma]a -&gt; 100., \[Gamma]c -&gt; 1., \[Gamma]P -&gt; 0.01, \[Gamma]pL -&gt; 100., \[Gamma]L -&gt; 1000., \[Gamma]R -&gt; 100.}; </code></pre> <p>gives an issue in the solution for <span class="math-container">$z$</span> (I have picked the time <span class="math-container">$t=2.6$</span> to show the bad solution, but the solution doesn't seem good from the start).</p> <pre><code>zSoln = NDSolveValue[deqns /. paramsBad, z, {r, dr, \[Rho]Far}, {t,0., \[Tau]max}, MaxStepSize -&gt; .1]; Plot[zSoln[r, 2.6], {r, dr, 15}, PlotRange -&gt; {-.002, .002}] </code></pre> <p><a href="https://i.stack.imgur.com/0LQbz.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/0LQbz.png" alt="badSolution"></a></p> <p>None of the dependent variables should be negative. </p> <p>I have tried modifying the MaxStepSize, StartingStepSize, and specifying a spatial discretization as suggested in the documentation: </p> <pre><code>Method -&gt; {"PDEDiscretization" -&gt; {"MethodOfLines", "SpatialDiscretization" -&gt; {"TensorProductGrid", "MinPoints" -&gt; 1000}}} </code></pre> <p>but I cannot seem to fix this issue. Sometimes these things fix the problem, but then for other parameter values the issues come right back (for example, I think making the MinPoints option above larger fixes for this parameter set, but not for all of the. Additionally the solution ends up taking a long time). Why is this happening for the numerical solver, and what is the most efficient way to determine a well-behaved solution Note that I need to be able to solve these equations fairly quickly.</p> <h3>Second Problem</h3> <p>If I just change the end time to <span class="math-container">$t=6.5$</span> the solution ends up behaving differently. There is a very small response in <span class="math-container">$z$</span>, but it at least looks well-behaved?</p> <pre><code>zSoln = NDSolveValue[deqns /. paramsBad, z, {r, dr, \[Rho]Far}, {t,0., 6.5}, MaxStepSize -&gt; .1]; Plot[zSoln[r, 2.6], {r, dr, 15}, PlotRange -&gt; {-.002, .002}] </code></pre> <p><a href="https://i.stack.imgur.com/hdEf3.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/hdEf3.png" alt="enter image description here"></a></p> <p>Also, this issue does not occur for the "good parameter set"; the solution does not show any notable difference in choice of the final integration time.</p> <p>So this really makes me question how do I make sure I am getting a legitimate solution here? Which settings should I employ to be confident in my solutions for a wide range of parameters?</p> https://mathematica.stackexchange.com/q/208014 2 BarChart and ColorFunction Igor Rivin https://mathematica.stackexchange.com/users/11539 2019-10-16T18:25:20Z 2019-10-18T17:45:39Z <p>There are really two questions. The first is: how does one get BarChart to generate x coordinates. That is, <code>ListPlot</code> takes a list of pairs, but <code>BarChart</code> takes a list of y-values only. Is there any way to impart x values to it?</p> <p>Second question (which is related, because I am using <code>BarChart</code> so I can use <code>ColorFunction</code>) is: how do I invert <code>ColorFunction</code>. That is, "DarkRainbow" makes high values red, low values green. I want it exactly the other way around. What's the trick?</p> https://mathematica.stackexchange.com/q/207830 2 Error using MaTeX, MaTeX::texerr : LaTeX Error: Missing \begin{document} Krishna Phanindra https://mathematica.stackexchange.com/users/67892 2019-10-14T06:58:06Z 2019-10-18T15:24:24Z <p>I've managed to install MateX with all prerequisites. pdflatex and GhostScript paths are correctly specified. I am able to load it into Mathematica. However, a simple command such as MaTeX[x^2] gives me a MaTeX::texerr : LaTeX Error titled "Missing \begin{document}". </p> <p>Has anyone faced a similar issue? Any help would be much appreciated..!</p> <p>Thanks,</p> https://mathematica.stackexchange.com/q/206431 0 Solving a simple differential equation and trying to plot the trace of the solutions freebird https://mathematica.stackexchange.com/users/67470 2019-09-18T15:23:26Z 2019-10-18T18:51:56Z <p>I am trying to run a simple code on Mathematica. However, it is not running for some reason. What mistake am I making?</p> <pre><code>ClearAll {x, y, z, t, X, Y, a, b, c}; Manipulate[ X[t_] := a Cos[t]; Y[t_] := Sin[t]; sols = {NDSolve[ {D[{u[t], v[t]}, t] == D[{{X[t], Y[t]}, {Y[t], -X[t]}}, t].{u[t], v[t]}, {u, v} == {1, 0}}, {u[t], v[t]}, {t, 0, 10}], NDSolve[ {D[{u[t], v[t]}, t] == D[{{X[t], Y[t]}, {Y[t], -X[t]}}, t].{u[t], v[t]}, {u, v} == {0, 1}}, {u[t], v[t]}, {t, 0, 10}][]}; GraphicsRow[{ ParametricPlot[Evaluate[{u[t], v[t]} /. sols], {t, 0, 10}], Plot[Tr[{u[t], v[t]} /. sols], {t, 0, 10}]}] {{a, 2}, 1, 5}] </code></pre> <p>What am I doing wrong?</p> https://mathematica.stackexchange.com/q/206422 0 An empty list is generating when I tried to find the roots of transcendental equation using NSOLVE function acoustics https://mathematica.stackexchange.com/users/53981 2019-09-18T13:07:29Z 2019-10-18T16:02:20Z <pre><code>I have an equation P which is dependent on ω and γ, and I am trying to find the roots of ω for different value of γ. I have written a small module to carry out this task, but the output of the module is showing empty. Y = 2*^11; ρ = 7850; aa = 0.1*0.1; Iyy = 0.1^4/12; sd1 = Subdivide[0.001, 0.5, 300]; sd2 = Subdivide[0.55, 2, 300]; sd3 = Subdivide[2.2, 5, 50]; sd = Flatten[{sd1, sd2}]; L1=4; lbar = L1*sd; P = 1/γ^4 aa^2 (Iyy^2 Y^6 (17.033 aa^2 + 121.171 aa Iyy γ + 56.7964 Iyy^2 γ^2) + Iyy Y^5 (-1.01106 aa^3 + aa^2 Iyy (-46.8109 - 15.3405 γ) γ + aa Iyy^2 (-160.727 - 64.3873 γ) γ^2 - 9.20748 Iyy^3 γ^4) ρ ω^2 + Y^4 (0.0117278 aa^4 + aa^3 Iyy (2.06068 + 0.910598 γ) γ + 0.373165 Iyy^4 γ^6 + aa Iyy^3 γ^4 (26.0561 + 6.63437 γ) + aa^2 Iyy^2 γ^2 (30.4847 + γ (24.8741 + 4.07576 γ))) ρ^2 ω^4 + aa Y^3 γ (aa^3 (-0.0154297 - 0.0105624 γ) + Iyy^3 (-1.05601 - 0.179254 γ) γ^5 + aa Iyy^2 γ^3 (-4.942 + (-2.56299 - 0.279973 γ) γ) + aa^2 Iyy γ (-0.960215 + (-1.09499 - 0.241934 γ) γ)) ρ^3 ω^6 + aa^2 Y^2 γ^2 (aa^2 (0.00488883 + (0.00819891 + 0.0028063 γ) γ) + Iyy^2 γ^4 (0.200292 + (0.0692493 + 0.00567345 γ) γ) + aa Iyy γ^2 (0.155664 + (0.112826 + 0.016619 γ) γ)) ρ^4 ω^8 + aa^3 Y γ^4 (Iyy γ^2 (-0.00630883 + (-0.00304845 - 0.000336771 γ) γ) + aa (-0.000792547 + (-0.000844803 - 0.000192771 γ) γ)) ρ^5 ω^10 + aa^4 γ^6 (0.0000321207 + (0.0000228257 + 3.90636*10^-6 γ) γ) ρ^6 ω^12); sd1 = Subdivide[0.001, 0.5, 300]; sd2 = Subdivide[0.55, 2, 300]; sd3 = Subdivide[2.2, 5, 50]; sd = Flatten[{sd1, sd2, sd3}]; lbar = L1*sd; sol[i_] := Module[{root}, P = P /. γ -&gt; lbar[[i]]; s1=NSolve[P == 0 &amp;&amp; 0 &lt; ω &lt; 2000]; s2 = Flatten[ω /. s1]; s3 = Surd[(ρ*aa*s2^2*L1^4)/(Y*Iyy), 4]; s4 = s3/(2 π); root = s4; Return[root]]; nonbeta = Table[sol[i], {i, 1, Length[lbar]}]; nonbeta1 = nonbeta[[All, 1]] </code></pre> https://mathematica.stackexchange.com/q/206418 0 Identifying the three frequencies using fourier transform Patrick https://mathematica.stackexchange.com/users/66809 2019-09-18T09:23:07Z 2019-10-18T12:01:20Z <p>The following simple function has clearly three frequency components:</p> <pre><code> fun[x_] = Cos[ x] + Cos[2 x] + Cos[3 x]; data = Table[fun[x], {x, 0, 2 \[Pi], 0.1}]; ListPlot[data, ImageSize -&gt; 200] </code></pre> <p>How can one show these frequencies using the Fourier transform? I tried the following</p> <pre><code>ListLinePlot[Abs[Fourier[data]], PlotRange -&gt; All, ImageSize -&gt; 200] </code></pre> <p>But it doesn't seem to lead to the proper answer.</p> <p>Edit: I would expect the Fourier plot to show three peaks corresponding to three frequencies in the ratio 1:2:3.</p> https://mathematica.stackexchange.com/q/206102 1 How to download user faves on Flickr? M.R. https://mathematica.stackexchange.com/users/403 2019-09-11T18:07:36Z 2019-10-18T19:49:01Z <p>The Flickr service API doesn’t seem to have the <a href="https://www.flickr.com/services/api/flickr.photos.getFavorites.html" rel="nofollow noreferrer">getfavorites()</a> request implemented. Is there an good way to do this with <code>WebExecute</code>?</p> <p><strong>Code to get started with:</strong></p> <p>For a given user, say <em>7944912@N05</em>, there are <em>n</em> pages for which one can manually extract images:</p> <pre><code>s = StartWebSession[]; WebExecute[s, "OpenPage" -&gt; "https://www.flickr.com/photos/7944912@N05/favorites/page1/"] possibleimageurls = WebExecute[s, "PageHyperlinks"]; Length@possibleimageurls i = Import@ "https://live.staticflickr.com/4278/34611590423_5f44dc95d2_k.jpg"; {Thumbnail@i, ImageDimensions[i]} </code></pre> <p><a href="https://i.stack.imgur.com/Vdrkt.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/Vdrkt.png" alt="enter image description here"></a></p> <p>But I don't know how to enumerate the highest resolution ones.</p> https://mathematica.stackexchange.com/q/204736 13 Tracking cells as they move under a microscope M.R. https://mathematica.stackexchange.com/users/403 2019-09-03T18:06:08Z 2019-10-18T12:26:26Z <p>I have a video (tiff file) of cells under a microscope and I'd like to segment and track the location and sizes of them across time:</p> <p><a href="https://i.stack.imgur.com/gIkyO.gif" rel="noreferrer"><img src="https://i.stack.imgur.com/gIkyO.gif" alt="enter image description here"></a></p> <p>It has a hundred frames:</p> <p><a href="https://i.stack.imgur.com/OwgqR.png" rel="noreferrer"><img src="https://i.stack.imgur.com/OwgqR.png" alt="enter image description here"></a></p> <p>I've uploaded it here (now it is public):</p> <pre><code>frames = CloudGet @ "https://www.wolframcloud.com/obj/3b3ecc16-c9e8-4b2d-a824-35e8ea1307a7" </code></pre> <p>There are many great answers on how to segment cells and objects, but not to track them (probably because mma doesn't fully support videos yet).</p> <p>There are three steps and I've stuck on all of them:</p> <ol> <li>Experiment for hyperparameters (AdaptiveBinarize, RingeFilter...)</li> <li>Find center-points / segmentations (MaxDetect, SelectComponents...)</li> <li>Track into next frame while adding/removing in-out of frame cells (ImageCorrepondingPoint, ImageFeatureTrack...)</li> </ol> <p><strong>How far I've gotten:</strong> </p> <p>The first step is to find thresholding parameters for preprocessing and finding the cell loci (bright points). I always forget which is the best preprocessing combo to use...</p> <pre><code>frames = ImageAdjust /@ frames; i1 = frames[]; i2 = frames[]; Manipulate[ HighlightImage[i1, MaxDetect@ImageAdjust@RidgeFilter[i1, o]] , {o, .1, 10, 1}] </code></pre> <p><a href="https://i.stack.imgur.com/QacMB.png" rel="noreferrer"><img src="https://i.stack.imgur.com/QacMB.png" alt="enter image description here"></a></p> <p>Then the segmentation</p> <pre><code>Manipulate[ segments = SelectComponents[WatershedComponents[GradientFilter[i2, gf], pts], "Area", a1 &lt; # &lt; a2 &amp;]; Colorize[segments] , {gf, 0.1, 2}, {a1, 1, 1000}, {a2, 1, 1000}] </code></pre> <p><a href="https://i.stack.imgur.com/NtO9S.png" rel="noreferrer"><img src="https://i.stack.imgur.com/NtO9S.png" alt="enter image description here"></a></p> <p>But I get into cases like this:</p> <pre><code>Manipulate[ b = Binarize[i, {0.7, 1}]; markers = MaxDetect@ImageAdjust@RidgeFilter[i1, w]; segments = SelectComponents[ b, (0 &lt; #Area &lt; 1000 &amp;&amp; #Count &gt; c(*&amp;&amp; #AdjacentBorderCount\[Equal]0*)) &amp;]; circles = ComponentMeasurements[ segments, {"Centroid", "EquivalentDiskRadius"}]; Show[HighlightImage[i, {Blue, markers}], Graphics[{Red, Thick, Circle @@ # &amp; /@ circles[[All, 2]]}]], {w, 1, 5}, {c, 0, 100}, SynchronousUpdating -&gt; False ] </code></pre> <p><a href="https://i.stack.imgur.com/Z1QIU.png" rel="noreferrer"><img src="https://i.stack.imgur.com/Z1QIU.png" alt="enter image description here"></a></p> <p>Help on canonicalizing this answer would cure many headaches :)</p> <p><strong>References:</strong></p> <ul> <li><a href="https://mathematica.stackexchange.com/questions/62976/segmentation-of-a-microscopy-image-with-uneven-illumination">Segmentation of a microscopy image with uneven illumination</a></li> <li><a href="https://mathematica.stackexchange.com/questions/138846/what-scheme-to-use-to-segment-this-aggregate-of-cells-in-such-a-poor-illuminatio">what scheme to use to segment this aggregate of cells in such a poor illumination</a> <ul> <li><a href="https://mathematica.stackexchange.com/questions/201974/segmenting-cells-from-a-stained-image-of-cells-from-microscope">Segmenting cells from a stained image of cells from microscope</a></li> <li><a href="https://reference.wolfram.com/language/example/AnalyzeSegmentedCellsInAnImage.html" rel="noreferrer">https://reference.wolfram.com/language/example/AnalyzeSegmentedCellsInAnImage.html</a></li> </ul></li> </ul> <p>This was the only post I've found that addressed moving cells:</p> <ul> <li><a href="https://mathematica.stackexchange.com/questions/109705/using-mask-to-segment-growing-cells-over-multiple-timepoints">Using mask to segment growing cells over multiple timepoints</a></li> </ul> https://mathematica.stackexchange.com/q/198738 2 Typesetting environment for CloudDeploy JEM https://mathematica.stackexchange.com/users/6404 2019-05-20T19:41:51Z 2019-10-18T15:02:00Z <p>I am currently starting to develop a Web API for our schools mathematics placement examination for new students. We have the questions and we have what potential scores will mean for us. After tinkering around with this for a while I have developed several questions: </p> <ol> <li><p>I currently use a personally defined stylesheet for most things and want this stylesheet to be the basis for all aesthetics associated to our cloud objects. Even if I deploy the entire notebook using <code>CloudDeploy[EvaluationNotebook[]]</code>, everything is automatically set to default values. </p></li> <li><p>Using ALT-7 I can create a text cell with mathematical typesetting easily embedded with proper centering, spacing, etc by just visually placing things where I want them in the notebook. In an attempt to reproduce this on the web I tried:</p> <p><code>CloudDeploy[CellPrint[Cell[BoxData[ToBoxes[Column[{Text[Style["Find the solution to the following system of linear equations:", FontFamily -&gt; Times, FontSize -&gt; Large]],TraditionalForm[Style[x + 3 y == 7, FontSize -&gt; Large, FontFamily -&gt; Times]],TraditionalForm[Style[2 x - y == 4, FontSize -&gt; Large, FontFamily -&gt; Times]]},Alignment -&gt; Center]]]]]]</code> </p></li> <li><p>I would appreciate any pointers on how we might proceed to create the interactivity with each question. Wrapping all of this up into a collection of <code>Manipulate[]</code> functions with <code>RadioButton</code> controls and embedded typesetting is going to be my initial effort. </p></li> </ol> <p>Any guidance would be much appreciated. </p> <p><strong>EDIT</strong></p> <p>I've got something that is starting to look reasonable. The code is a column with two elements. The first element is a column itself with the question and equations center aligned. Element two is the multiple choice <code>RadioButtonBar</code>. The typesetting choices I have made are completely lost when it is deployed. </p> <p>I'm actually picking the option to use <code>FontFamily-&gt;Times</code>. I think this should not be lost with <code>CloudDeploy</code>. </p> <pre><code>opt = Sequence[FontSize -&gt; Large, FontFamily -&gt; Times]; CloudDeploy[Column[{Column[ {Text[ Style["Find the solution to the following system of linear \ equations:", opt]], Spacer, TraditionalForm[Style[x + 3 y == 7, opt]], TraditionalForm[Style[2 x - y == 4, opt]], Spacer}, Alignment -&gt; Center], RadioButtonBar[ z, {1 -&gt; TraditionalForm[ Style[Row[{x == 19/7, Spacer, y == 10/7}], opt]], 2 -&gt; TraditionalForm[ Style[Row[{x == 20/7, Spacer, y == 11/7}], opt]], 3 -&gt; TraditionalForm[ Style[Row[{x == 0, Spacer, y == 7/3}], opt]], 4 -&gt; TraditionalForm[ Style[Row[{x == 2, Spacer, y == 0}], opt]]}, Appearance -&gt; "Vertical", ImageMargins -&gt; 10, BaselinePosition -&gt; Center]}], Permissions -&gt; "Public"] </code></pre> https://mathematica.stackexchange.com/q/193121 12 Solving "Resistance between two nodes on a grid" problem in Mathematica user929304 https://mathematica.stackexchange.com/users/52181 2019-03-12T18:28:52Z 2019-10-18T11:47:13Z <p>In the context of <a href="http://www.resistorguide.com/kirchhoff-law/" rel="noreferrer">resistor networks</a> and finding the (equivalent) resistance between two arbitrary nodes, I am trying to learn how to write a generic approach in Mathematica, generic as in an approach that also lends itself to large spatially randomly distributed graphs as well (not just lattices), where then one has to deal with sparse matrices. Before getting there, I've tried simply recreating a piece of algorithm written in <a href="https://en.wikipedia.org/wiki/Julia_(programming_language)" rel="noreferrer">Julia</a> for solving an example on a square grid, with all resistances set to 1.</p> <p>Here's the grid where each edge depicts a resistor between its incident nodes (all resistance values are assumed to be <span class="math-container">$1 \Omega$</span>) and two arbitrary nodes (<span class="math-container">$A$</span> at <code>{2,2}</code> and <span class="math-container">$B$</span> at <code>{7,8}</code>) are highlighted, question is to find the resistance between them.</p> <p><a href="https://i.stack.imgur.com/lPuflb.png" rel="noreferrer"><img src="https://i.stack.imgur.com/lPuflb.png" alt="enter image description here"></a></p> <p>In the Julia's code snippet, <a href="https://www.physics.utoronto.ca/~wei/lecture2.pdf" rel="noreferrer">the approach of injecting a current and measuring the voltages at the two nodes is adopted</a>, as shown below: (<a href="https://rosettacode.org/wiki/Resistor_mesh#Julia" rel="noreferrer">source</a>)</p> <pre><code>N = 10 D1 = speye(N-1,N) - spdiagm(ones(N-1),1,N-1,N) D = [ kron(D1, speye(N)); kron(speye(N), D1) ] i, j = N*1 + 2, N*7+7 b = zeros(N^2); b[i], b[j] = 1, -1 v = (D' * D) \ b v[i] - v[j] </code></pre> <p><code>Output: 1.6089912417307288</code></p> <p>I've tried to recreate exactly the same approach in Mathematica, here's what I have done:</p> <pre><code>n = 10; grid = GridGraph[{n, n}]; i = n*1 + 2; j = n*7 + 7; b = ConstantArray[0, {n*n, 1}]; b[[i]] = {1}; b[[j]] = {-1}; incidenceMat = IncidenceMatrix[grid]; matrixA = incidenceMat.Transpose[incidenceMat]; v = LinearSolve[matrixA, b] </code></pre> <p>I feel very silly, but I must be missing something probably very obvious as LinearSolve does not manage to find a solution (for the chosen nodes the answer is know to be <span class="math-container">$1.608991...$</span>, which is obtained by taking the potential difference between A and B since the current is set to 1). </p> <p><strong>Questions</strong></p> <ul> <li><p>Have I mis-interpreted something in my replication of the algorithm sample written in Julia? </p></li> <li><p>It would be very interesting and useful if someone could comment on how extensible these approaches are to more general systems (2d, 3d and not only for lattices). For instance, which approaches would be more suitable to adopt in Mathematica for larger resistor networks (in terms of efficiency, as one would have to deal with very sparse matrices probably). </p></li> </ul> <hr> <p>As a side-note, on the same Rosetta article, there are two alternative code snippets provided for Mathematica (which follows <a href="https://rosettacode.org/wiki/Resistor_mesh#Maxima" rel="noreferrer">Maxima's approach</a>, essentially similar to the one written Julia). In case someone is interested I include them here: (<a href="https://rosettacode.org/wiki/Resistor_mesh#Mathematica" rel="noreferrer">source for both</a>)</p> <pre><code>gridresistor[p_, q_, ai_, aj_, bi_, bj_] := Block[{A, B, k, c, V}, A = ConstantArray[0, {p*q, p*q}]; Do[k = (i - 1) q + j; If[{i, j} == {ai, aj}, A[[k, k]] = 1, c = 0; If[1 &lt;= i + 1 &lt;= p &amp;&amp; 1 &lt;= j &lt;= q, c++; A[[k, k + q]] = -1]; If[1 &lt;= i - 1 &lt;= p &amp;&amp; 1 &lt;= j &lt;= q, c++; A[[k, k - q]] = -1]; If[1 &lt;= i &lt;= p &amp;&amp; 1 &lt;= j + 1 &lt;= q, c++; A[[k, k + 1]] = -1]; If[1 &lt;= i &lt;= p &amp;&amp; 1 &lt;= j - 1 &lt;= q, c++; A[[k, k - 1]] = -1]; A[[k, k]] = c], {i, p}, {j, q}]; B = SparseArray[(k = (bi - 1) q + bj) -&gt; 1, p*q]; LinearSolve[A, B][[k]]]; N[gridresistor[10, 10, 2, 2, 8, 7], 40] </code></pre> <p>Alternatively:</p> <pre><code>graphresistor[g_, a_, b_] := LinearSolve[ SparseArray[{{a, a} -&gt; 1, {i_, i_} :&gt; Length@AdjacencyList[g, i], Alternatives @@ Join[#, Reverse /@ #] &amp;[ List @@@ EdgeList[VertexDelete[g, a]]] -&gt; -1}, {VertexCount[ g], VertexCount[g]}], SparseArray[b -&gt; 1, VertexCount[g]]][[b]]; N[graphresistor[GridGraph[{10, 10}], 12, 77], 40] </code></pre> https://mathematica.stackexchange.com/q/4129 20 Is it possible to Print expressions in reverse order? faysou https://mathematica.stackexchange.com/users/66 2012-04-11T09:46:18Z 2019-10-18T19:48:16Z <p>Let's say I'm debugging a program step by step and want to <code>Print</code> some expressions (<a href="https://stackoverflow.com/a/8270643/884752">using ShowIt</a>, for example).</p> <p>Is there a way to output the result of <code>Print</code> on top of already printed expressions instead of at the bottom?</p>