11
Speed tips:
Explicit is faster than implicit.
"DiscontinuityProcessing" is your friend.
Other tips:
WhenEvent is mysterious sometimes, but not here.
Functions should depend only on their arguments (best practice).
If 1/10^6 is to be a significant value to NDSolve, AccuracyGoal probably has be somewhat larger than 6.
Irrelevent, gratuitous tips:
...
11
Here is a semi-imperative way that gives the same result as tup2 from the original question, but much faster:
tup2b = Module[{keep}
, keep[t_] :=
( keep[t] = False
; keep[t[[{4,5,6,1,2,3,10,11,12,7,8,9}]]] = False
; True
)
; Select[tup1, keep]
];
tup2b === tup2
(* True *)
Length[tup2b] === Length[tup2] === 52650
(* True *)
On my machine, ...
11
Here's a refinement of @Henrik's approach. The key difference is that using Nearest[pts->"Distance"] is over an order of magnitude faster than using Nearest[pts->{"Index", "Distance"}]:
SeedRandom[1];
pts = RandomReal[1, {10000,2}];
AbsoluteTiming[
data=Nearest[pts->"Distance"][pts,2][[All,2]];
d=Min[...
9
Maybe this works for you:
AbsoluteTiming[
data = Nearest[pts -> {"Index", "Distance"}][pts, 2][[All, 2]];
i = OrderingBy[data, Last, 1][[1]];
j = data[[i, 1]];
dist = data[[i, 2]];
result = {dist, pts[[i]], pts[[j]]}
]
i and j are the indices of the pair of points that are closest to each other; dist is their distance.
Nearest[...
9
Straight-forward application of Compile to your code. No effort has been taken towards optimization. You'll need to evaluate this twice for Compile to pick up on the recursion. I flattened the return structure and made it explicitly 2D, but you can easily make it higher-dimensional if you want to by turning the 2;;5 into some calculated parameter.
simpleMin =...
9
You can also get tup2 from tup1 using:
1. Union
ClearAll[fA]
fA = Union[Sort[{#, #[[{4, 5, 6, 1, 2, 3, 10, 11, 12, 7, 8, 9}]]}] & /@ #][[All, 1]] &;
tup2A = fA @ tup1; // AbsoluteTiming // First
0.213222
Length @ tup2A
52650
2. DeleteDuplicates
ClearAll[fB]
fB = DeleteDuplicates[
Sort[{#, #[[{4, 5, 6, 1, 2, 3, 10, 11, 12, 7, 8, 9}]]}] & /@...
8
Certain functionality, most notably rasterizing graphics, is implemented by the front end. In your case it is the JPEG export that triggers this.
8
The issue here is that AdjacencyMatrix returns a non-real valued matrix
g = GridGraph[{20, 20}];
amg = AdjacencyMatrix[A1];
meaning the elements are all integers:
In[]:= Map[Head,Normal@amg,{2}]//Flatten//Union
Out[]= {Integer}
and the kernel is trying to find an answer in terms of integers, rational numbers, and roots. Numericizing before computation ...
7
A tuple is deleted if both its first two triples and its second two triples are identical when exchanged (but not when they're the same when not swapped). That we can construct the undeleted tuples directly like so:
tup2 =
Module[{
pair = Tuples[Tuples[{{0, 1}, {0, -1, 1}, {0, -1, 1}}], 2],
unique
},
unique = DeleteDuplicates[pair, #1 ===...
6
By default Mathematica uses $HistoryLength = Infinity, so it stores every output expression since you started Mathematica in the data associated with the System symbol Out. If a lot of your output takes a lot of memory, you can easily slow down your computer. Instead, you could use this
$HistoryLength = 2;
Then Mathematica will only remember the two most ...
6
If you just want the largest eigenvalue, the Arnoldi method is much faster than calculating all eigenvalues (and associated eigenvectors) and picking the largest:
Eigensystem[A // N, 1,
Method -> {"Arnoldi", "Criteria" -> "RealPart"}] // AbsoluteTiming
(* {0.007187, {{3.95532}, {{-0.00211558, -0.0041839, ......
4
Why not work with AdjacencyMatrix instead? For example:
KPaths[g_, k_] := Module[{a, m},
a = AdjacencyMatrix[g];
m = 1 - IdentityMatrix[Length[a]];
Nest[Unitize[(a . #) m]&, a, k-1]
]
Comparison:
SeedRandom[1];
gr=makegraph2[100,{0},10,0.01,0.5];
last = Length[FindPath[gr,#,Last@VertexList[gr],{6}]]&/@VertexList[gr]; //...
4
This is more of an extended comment. Here is a slight modification of your code:
parms = {m -> 1, ω -> 1, ℏ -> 1, α -> 1, n0 -> 8};
quadratures = ProbabilityDistribution[(1/Sum[1/k!, {k, 0, n0}]) *
Abs[Sum[(α E^(I ϕ))^n/√(n!) 1/Sqrt[2^n n!] ((m ω)/(π ℏ))^(1/4) *
Exp[-((m ω z^2)/(2 ℏ))] HermiteH[n, Sqrt[(m ω)/ℏ] z], {n, 0, n0}]]^2,
{z, -...
4
You can do it with FrobeniusSolve like so:
ClearAll[solutions]
byFrobenius[m_Integer?Positive, n_Integer?Positive] :=
FrobeniusSolve[ConstantArray[1, n], m];
This works like so:
byFrobenius[5, 3]
(* {{0, 0, 5}, {0, 1, 4}, {0, 2, 3},
{0, 3, 2}, {0, 4, 1}, {0, 5, 0},
{1, 0, 4}, {1, 1, 3}, {1, 2, 2},
{1, 3, 1}, {1, 4, 0}, {2, 0, 3},
{2, 1,...
4
Instead of filtering symbolically, we can filter numerically to remove a large number of undesired tuples. Since the numerators and denominators are quadratic polynomials, the rational functions are determined by their values at five distinct points. To keep things in machine integers, we write a rational function as an ordered pair and code some of the ...
3
f1[n_, m_] := IntegerPartitions[m, {n}, Range[m, 0, -1]]
f2[n_, m_] :=
FrobeniusSolve[ConstantArray[1, n], m] // DeleteDuplicatesBy[Sort]
(Please notice that $N$ is before $M$) :P
Validation
f1[6, 10] // RepeatedTiming
f2[6, 10] // RepeatedTiming
%[[2]] === %%[[2]]
{8.628*10^-6, {{0, 0, 0, 0, 0, 10}, {0, 0, 0, 0, 1, 9}, {0, 0, 0, 0,
2, 8}, {0, 0, 0, ...
3
I hope that your real data consists of more than 3 data points when fitting a function with 3 parameters (a, b, and an error variance).
While I don't know why the functions hang, for your function there is a simple fix. Because myfunc[x, 4] does not change with the scaling parameter, just replace the predictor with the values of the function. Then both ...
3
I think the answer is:
f[m_,n_]:=Flatten[Permutations /@ PadRight[IntegerPartitions[m], {Automatic, n}], 1]
e.g
f[2, 4]
(*=> {{2, 0, 0, 0}, {0, 2, 0, 0}, {0, 0, 2, 0}, {0, 0, 0, 2}, {1, 1, 0, 0},
{1, 0, 1, 0}, {1, 0, 0, 1}, {0, 1, 1, 0}, {0, 1, 0, 1}, {0, 0, 1, 1}} *)
An answer with FrobeniusSolve[] as suggested by @J.M.'s ennui, or any improvements in ...
2
A method using SparseArray`SparseArrayRemoveDiagonal to remove the diagonal:
ClearAll[urd, kPaths1, kPaths2]
urd = Unitize @* SparseArray`SparseArrayRemoveDiagonal;
kPaths1[g_, k_] := Module[{a = AdjacencyMatrix @ g}, Nest[urd[a.#] &, a, k - 1]]
Example:
SeedRandom[1];
gr = makegraph2[100, {0}, 10, 0.01, 0.5];
r1 = kPaths1[gr, 6]; // RepeatedTiming /...
1
Instead of evaluating a single sum, you could break up the sum into two or more sums.
L = 24;
sind = Range[-Pi, Pi, 2*Pi/L];
a[x_, y_] := x y
g[x_, y_] := x + y
f = Cos[x]*Sin[y]*Sin[x + x1]*Cos[y + y1]*a[x, y] + g[x, y]*Cos[x2 - y2]*Sin[x + x1 + x2];
AbsoluteTiming[sx = Sum[f, {x, sind}, {x1, sind}, {x2, sind}] // Simplify;
sxy = Sum[sx, {y, sind}, {y1, ...
Only top voted, non community-wiki answers of a minimum length are eligible
