New answers tagged

1

Follows a script which determines with assigned accuracy the furthers parallel and perpendicular set of points. distmin = 0; distminp = 0; e1 = 0.01; e2 = 0.01; e3 = 0.01; For[i = 1, i <= n, i++, For[j = i + 1, j <= n, j++, {dx, dy, dz} = spheres[[i]] - spheres[[j]]; If[Abs[dx/dz] < e1 && Abs[dy/dz] < e2, dist = dx^2 + dy^2 + dz^...


6

I'll go ahead and post this quick speed improvement pending your reply to my question. Replace references to ThreeJSymbol in your code with j3s, and add ClearAll[j3s]; j3s[a_, b_, c_] := j3s[a, b, c] = ThreeJSymbol[a, b, c]; to the top of your code. This will redefine j3s for known values as they are computed (a kind of memoization), and results in a ...


1

A possible solution for this particular case of gathering index of points which are near to other points: PointGatherBy[pts_, tol_] := Values@PositionIndex@ Merge[Flatten[ MapIndexed[Function[s, s -> {Length@#1, #2[[1]]}] /@ #1 &, Flatten[Values[ PositionIndex[ Round[Transpose[Transpose[pts] + #], tol]]] & /@ ...


0

The problem here is that the exhibited Outer expression generates a 24-dimensional tensor that contains nearly 4 x 10^12 elements at the deepest level. There is no practical way to operate upon a structure of this size. Even simply iterating over the deepest elements will require a significant amount of time. For discussion purposes, let us consider a ...


9

ClusteringComponents does what you want; maybe play with the DistanceFunction and other options: ClusteringComponents[pts, Length[pts], 1] (* {1, 2, 3, 3, 4, 4} *)


5

Here's a refactoring of the OP's code & Rolf's compile idea. Basically I tried to implement the idea in my comment: Also, BesselJ is not compilable, so it slows down the compiled function with call-backs to the main kernel. You could pass a list of Bessel function values as an argument to Compile. This would reduce the number of Bessel function calls ...


8

Coding the square root in polynomial terms yields the result in 0.06 sec. on my laptop: Minimize[{u + v, u^2 == 3 + x && v^2 == 3 - x*y && x^2 + y^2 == 9 && u >= 0 && v >= 0}, {x, y, u, v}] (* {Root[9 - 54 #1^2 + 45 #1^4 - 12 #1^6 + #1^8 &, 5], {x -> -3 + Root[9 - 54 #1^2 + 45 #1^4 - 12 #1^6 + #1^8 &...


3

expr = Sqrt[3 + x] + Sqrt[3 - x*y]; fd = FunctionDomain[{expr, x^2 + y^2 == 9}, {x, y}] // FullSimplify (* x y <= 3 && x^2 + y^2 == 9 *) Plot the function to find additional constraints on x and y to use in the Minimize Plot3D[expr, {x, -3, 3}, {y, -3, 3}, RegionFunction -> (#1^2 + #2^2 <= 9 &), AxesLabel -> Automatic] ...


3

It can do it if you give additional constraints and break the problem into 3 cases. ClearAll[x, y]; Minimize[{Sqrt[3 + x] + Sqrt[3 - x*y], x^2 + y^2 == 9 && x > 0}, {x, y}]//N (* {2.01754, {x -> 1.07047, y -> 2.80252}} *) So by giving different combinations, it can give all answers Minimize[{Sqrt[3 + x] + Sqrt[3 - x*y], x^2 + y^2 == 9 &...


5

Using Compile speeds things up: λ = 0.500; k = (2 π)/λ; ρ[x_, y_] := Sqrt[x^2 + y^2]; ϕ[x_, y_] := ArcTan[x, y]; Ε2[n_, x_, y_, z_] := Exp[I k z + I n ϕ[x, y] + (I k ρ[x, y]^2)/(4 z)]* Sqrt[π/2]*(-I)^(Abs[n]/2)*Sqrt[(k*ρ[x, y]^2)/(4 z)]*(BesselJ[(Abs[n] - 1)/2, (k ρ[x, y]^2)/(4 z)] - I*BesselJ[(Abs[n] + 1)/2, (k ρ[x, y]^2)/(4 z)]); U = With[{expr = ((Exp[I*...


1

It's been a while since this question was asked but perhaps a sketch of an answer is useful for future reference. In version 12.0 FindRoot got a new method option for an Affine Corvariant Newton solver that is fairly efficient for large scale sets of equations. It achieves this performance by making use of a few tricks. It's optimized to use minimal ...


0

EDIT This approach doesn't work, as the method of choosing points to include in the polygon (counting crossings of rays extending from point) results in points sometimes in, sometimes out. With enough points, you are guaranteed for it to fail. Keeping this answer as it has useful info, and to head off any future ventures down this path. This is easy to ...


2

One could also go with a fully analytical approach: l1 = {1, 2, 4, 3, 1}; l2 = {3, 6, 5, 1, 0}; s1 = Subsequences[l1, {2}]; s2 = Subsequences[l2, {2}]; s = Transpose[{s1, s2}]; Edit: to avoid the code breaking when a polygon has area = 0, one can replace s with: s = Select[Transpose[{s1, s2}], #[[1]] != #[[2]] &] To speed up computation, one might ...


6

First of all, I observed that your matrix can be represented as KroneckerProduct of smaller matrixes which are themselfes KroneckerProduct (or TensorProducts) of vectors: Ux = Table[m^2 Sin[m x], {m, 1, k}]; Vx = Table[p^2 Sin[p x], {p, 1, k}]; Uy = Table[Sin[n y], {n, 1, k}]; Vy = Table[Sin[q y], {q, 1, k}]; Ax = KroneckerProduct[Ux, Vx]; Ay = ...


1

In fact, you can compute the exact answer for this case if you explicitly assemble the piecewise linear function representing the two "connect-the-dots" plots in the OP, and then feed the integrand to Integrate[]. Here's one way to derive the required piecewise linear interpolant: makePW[ya_?VectorQ, t_] := Piecewise[MapIndexed[{InterpolatingPolynomial[...


9

You can extract the polygons in llp using Cases: llp = ListLinePlot[{{1, 2, 4, 3, 1}, {3, 6, 5, 1, 0}}, Filling -> {1 -> {2}}]; polygons = Cases[Normal@llp, _Polygon, All] {Polygon[{{1.,1.},{2.,2.},{3.,4.},{3.33333,3.66667},{3.33333,3.66667},{3.,5.},{2.,6.},{1.,3.}}], Polygon[{{3.33333,3.66667},{4.,1.},{5.,0.},{5.,1.},{4.,3.},{3.33333,3.66667}...


2

Applying SparseArray`SparseArraySort to jSparse3 will make it the same as jSparse1 and jSparse2. Also notice that jSparse1 == jSparse3 returns True. SameQ (===) compares the internal structure of the SparseArrays, which are the "ColumnIndices", "RowPointers", "NonzeroValues", and "Background" properties. At least, that's the defining properties for vectors ...


3

lst1 = {{1, 4}, {2, 7}, {4, 6}, {5, 2}, {6, 5}, {7, 1}}; lst2 = {{1, 2}, {2, 5}, {3, 1}, {5, 7}, {6, 3}, {7, 6}}; 1. An alternative method using FindCycle and RelationGraph: ClearAll[findCycl1] findCycl1 = FindCycle[RelationGraph[#[[2]] == #2[[1]] &, # ]][[1, ;; , 1]] &; findCycl1 /@ {lst1, lst2} {{{1, 4}, {4, 6}, {6, 5}, {5, 2}, {2, 7}, {7, 1}...


1

Using march's general idea to treat the pairs as a list of graph edges: List @@@ First[FindCycle[Rule @@@ {{1, 4}, {2, 7}, {4, 6}, {5, 2}, {6, 5}, {7, 1}}]] {{1, 4}, {4, 6}, {6, 5}, {5, 2}, {2, 7}, {7, 1}} List @@@ First[FindCycle[Rule @@@ {{1, 2}, {2, 5}, {3, 1}, {5, 7}, {6, 3}, {7, 6}}]] {{1, 2}, {2, 5}, {5, 7}, {7, 6}, {6, 3}, {3, 1}}


Top 50 recent answers are included