# Tag Info

1

More of an extended comment, but I have found a single counterexample, where it's longer to pack, than to just do it. Edit: of course this needs <<Developer first. Do[Outer[Times, ToPackedArray[{3.}], ToPackedArray[{5.}]], {1000000}] // AbsoluteTiming (* {1.62244, Null} *) Do[Outer[Times, {3.}, {5.}], {1000000}] // AbsoluteTiming (* {0.929396, ...

6

Try calculating your own circles. (This puts the computation in the CPU with 64-bit floats instead of, I assume, in the GPU with 16/24/32-bit floats, depending on the processor and implementation.) The minimum number of circle points (12 below) might need adjusting to the clarity & resolution of the display device. circle[pt_, r_, scale_] := Line@ ...

1

I'm not sure what distribution is desired. Here is one that chooses uniformly among all distinction permutations of partitions of all integers m <= n into nonnegative parts no greater than k. This is done by transposing the Young tableaux for partitions of 2n into at most k + 1 parts, and subtracting 1 to get the parts to be between 0 and k. We then ...

1

One possibility is to add an equation that the sum of variables is some constant, say 1. You can actually enforce nonnegativity by augmenting the starting values, per refguide page for FindRoot. I won't repeat the lengthy setup code but just show the steps from there. k = 9; len = 2*k; vars = Array[s, len]; eqns = Join[eqs[vars], {Total[vars] - 1}]; start = ...

9

It seems like RandomReal[1., 2] is automatically a packed array, whereas {1., 2.} is not. Notice; (Outer[Times, list1, DeveloperToPackedArray@{1., 2.}];) // AbsoluteTiming // First (* 0.032425 *) whereas (Outer[Times, list1, {1., 2.}];) // AbsoluteTiming // First (* 0.542086 *) Also: list1 = DeveloperFromPackedArray@RandomReal[1., 1000000]; ...

0

A more classical approach ar1 = With[{len = 10, d = {2001, 1, 1}}, Transpose[{DateRange[d, DatePlus[d, len - 1]], Range@len}]]; ar2 = With[{len = 15, d = {2001, 1, 7}}, Transpose[{DateRange[d, DatePlus[d, len - 1]], Range@len + 5, CharacterRange["a", "z"][[;; len]]}]]; ar3 = With[{len = 15, d = {2001, 1, 8}}, Transpose[{DateRange[d, DatePlus[d, len - 1]], ...

4

Another way which I find is fractionally faster than @march's and I think scales better when combining information from more than 2 arrays (as you say you are interested in) is simply: GroupBy[Join[array1, array2, array3], First -> Rest, Join]; This produces a well formatted output straight away (imo), for the shorter length 10 and 15 arrays: ...

4

We will use Associations. There are many ways to form these Associations from your data. I will choose one and re-format it at the end. Using your provided data, we form Associations that use the date as the Key: assoc1 = Association[Rule @@@ array1]; assoc2 = Association[#1 -> {##2} & @@@ array2]; We then "intersect" these intersections, taking ...

6

Outer is highly optimized for several built-in functions (Plus, Times, List). Therefore Exp@-Abs@Outer[Plus, #, -#] &@Range[-10, 10, 0.02]; // RepeatedTiming (* {0.025, Null} *) gives ~50x speedup over Outer[#1 - #2&, #, #] and ~15x speedup over Outer[Subtract, #, #]. Also is a bit faster then Kuba's Exp[-Abs[x - # & /@ x]].

0

Replace Nest[]construction with Fold[] curveKnotInsertNew[ctrlpts_, {deg_, knots_}, {u0_, r_}] := Module[{n, s, k, coeff, left, right}, n = Length@ctrlpts - 1; s = Count[knots, u0]; k = searchSpan[knots, u0]; coeff = (u0 - knots[[#1 + 1]])/(knots[[#1 + deg - #2 + 2]] - knots[[#1 + 1]]) &; left = k - deg; right = k - s; Fold[ ...

10

More recent (10.1+) versions of Mathematica feature the SequencePosition function, which can be told to stop after the first match, like so: SeedRandom[1337]; a = RandomInteger[{1, 10}, 10000]; b = {1, 7, 1}; SequencePosition[a, b, 1] // AbsoluteTiming (* {0.000175, {{88, 90}}} *) This is quite a bit faster than the MemberQ/Partition-based approach: ...

14

Vectorization will help a lot: a[x_?NumericQ] := N[Exp[-Abs[x]]]; x = Table[-10 + 0.02 (j - 1), {j, 1, 1001}]; A = Outer[a[#1 - #2] &, x, x]; // AbsoluteTiming (* {2.11988, Null} *) B = Exp[-Abs[x - #]] & /@ x; // AbsoluteTiming (* {0.016182, Null} *) A == B (* True *) Notice that I am doing arithmetic on vectors the size of x instead of ...

3

Yes, two things help. The first is that Subtract is going to execute faster than #1 - #2 &, and the other is that all the operations involved in a are Listable, so getting rid of that _?NumericQ restriction speeds things up greatly. On my computer, this amounts to an order of magnitude speedup: With[{x = Table[-10 + 0.02 (j - 1), {j, 1, 1001}]}, ...

1

Exp@-Abs@Outer[#1 - #2 &, #, #] &[Range[-10, 10, 0.02]]; // AbsoluteTiming // First 0.950001

3

Opacity always gives a huge performance drop in interacting with Graphics3D. So let's skip it during interactions with Sliders using ControlActive. And of course the main thing, as noted in comments, do not calculate the same mesh each time: mesh = ConvexHullMesh[ RotationTransform[{{1, -1, 0}, {1, 0, 0}}, {0, 0, 0}]@ RotationTransform[{{1, 1, 1}, ...

4

In your present example the operation that is slow is the rasterization of the Graphics expression. This is implicitly performed by both ImageDifference[target,example1] and ColorConvert[example1, "RGB"]. By pre-rasterizing for example2 you remove this costly step and the ImageDifference is two orders of magnitude faster. If you include the rasterization ...

6

Indeed, the newt function as you wrote it freezes Mathematica at least for a minute or so (I aborted it afterwards without waiting to see if it would complete). Instead, you can prevent any attempts at symbolically evaluating the newt function by DensityPlot by restricting it to numerical arguments only: Clear[newt] newt[n_?NumericQ, z_?NumericQ] := ...

1

Say you have two vectors (I'll just make length-5 for demonstration) concatenated into a matrix a. a = RandomInteger[{0, 10}, {5, 2}]; m = NullSpace[Transpose[a]]; {MatrixForm[m], MatrixForm[a]} The Matrix m contains rows that are orthogonal to the two vectors, as you can see since m.a is the zero matrix. Hence m is a matrix whose null space is ...

1

After Reading anderstoods Comment on the Original Post I realized that I had actually constructed the projector on the space orthogonal to the span of the vectors. This led me to the simpler version. Again, if you know that your vectors are linearly independent, you don't have to kick out the vectors. But I like orthogonalizing first. v = ...

2

Not sure about what you want, but perhaps: f[v_] := v Sign[v[[-1]]]/GCD @@ v v0 = {-2, 2, 4, 6, 2, 2}; f@v0 (* {-1, 1, 2, 3, 1, 1} *)

3

There is an undocumented built in solution from the Developer context $ContextPath = Prepend[$ContextPath, "Developer"]; rules = {#, #} -> RandomReal[{}, {128, 128}] & /@ Range[48]; SparseArray`SparseBlockMatrix[rules]; // RepeatedTiming (*{0.042, Null}*)

3

Note your iteration rule can be reduced to an explicit formula: $$\boldsymbol{\mathrm{w}}_{n,m}=\boldsymbol{v}+\sum_{k=2}^m f(\boldsymbol{\mathrm{A}}\cdot \boldsymbol{\mathrm{w}}_{n-1,k},\boldsymbol{\mathrm{w}}_{n-1,k})\mathrm{,\;\;(for\;}n>1\mathrm{)}$$ So we can calculate the $n$-th row of $\boldsymbol{\mathrm{w}}$ in one time by performing ...

14

You are right, it can be done in a fraction of second. One can explicitly construct an array of indexes blockArray[mat_] := SparseArray[ Tuples[Range@# - {1, 0, 0}].{Rest@#, {1, 0}, {0, 1}} &@Dimensions@mat -> Flatten@mat] Timings: matrices = RandomReal[1, {48, 128, 128}]; s1 = SparseArray@ ...

4

You can use the CanonicalGraph function in concert with DeleteDuplicatesBy: DeleteIso[gs_List] := DeleteDuplicatesBy[gs, CanonicalGraph]

14

It definitely has something to do with the Interpolation function. Evaluating tempdata = Import["http://www.inrim.it/~magni/cm.dat.gz", "Table"]; cmfunc = Interpolation[tempdata] we get the warning Interpolation::udeg: Interpolation on unstructured grids is currently only supported for InterpolationOrder->1 or InterpolationOrder->All. Order will ...

5

Before using MatrixRank remove columns/rows consisting of zeros only. Also, when a row/column contains precisely 1 non-zero element, delete the corresponding column/row that contains the non-zero element and count one rank. mat = D[Union@Flatten@CoefficientList[f,{z0,z1,z2}], {coefficients}] rank[m_] := Module[{rank = 0, mat = m, c1, c2}, ...

7

Before going into the issues you mention I'd like to point out the following in your code: An expression of the form: nnff[#] & /@ test can be simplified to nnff /@ test here. The NearestFunction generated by Nearest is effectively Listable, as shown in its documentation: "Nearest[...][{x1, x2, ...}] gives a list of the elements closest to each of the ...

3

Let me first start with a cleaned up version of your evol2: Clear@evol3 evol3[mat_, initial_, ti_, tf_] := Module[{dt = (tf - ti)/10, res = col[initial]}, Do[res = MatrixExp[-I*mat, res], {t, ti, tf, dt}]; squ[res]]; Note that you don't need the complicated way to substitute numerical values for t, as Do uses Block internally which does this for ...

1

Let me at least show you how to avoid the Do loop while I think about other possible improvements. The idiomatic way is to use Fold. Here is my version: evol3[mat_, initial_, ti_, tf_] := Module[{dt = (tf - ti)/10, res = col[initial], ar = ArrayRules[mat]}, squ[Fold[ MatrixExp[-I*SparseArray[ar /. t -> #2, Dimensions[mat]], #1] &, ...

2

mind[l1_List, l2_List] := MinimalBy[Table[{k, First@Nearest[l1, k]}, {k, l2}], Norm] RepeatedTiming[mind[testlist1, testlist2]] (* {0.0061, {{0.0057, 0.}}} *) For huge lists you may change Table for ParallelTable

7

DistanceMatrix is fast. It evaluates multiple times in the SameTest. If you rewrite your code, you can see the difference: min=Min[DistanceMatrix[testlist1,testlist2]];//AbsoluteTiming {0.000501174,Null} Intersection[testlist1,testlist2,SameTest->(Abs[#1-#2]<=min&)]//AbsoluteTiming {0.0236643,{0.5}} VS original code ...

0

Just for something different: tab=Join @@ (Tuples[{{#}, Range[-#, #]}] & /@ Range[2]); g[a_, b_] := Times @@ (1 - Unitize[a - b]) Outer[g, tab, tab, 1] // MatrixForm

0

Because the indices i and j are computed similarly, one would expect ar to be a symmetric matrix, but on my four-processor PC it is not. \$Version (* "10.3.0 for Microsoft Windows (64-bit) (October 9, 2015)" *) (* {{0, 0, 0, 0, 0, 0, 0, 0}, {0, 1, 0, 0, 0, 0, 0, 0}, {0, 0, 1, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 1, 0}, {0, 0, 0, 0, 0, 0, ...

0

I keep improving my version **First version **, by separate Transpose[base] and Change the way Transpose act, time reduce from 4.52389 sec to 2.57898 sec Clear[lattice]; lattice[basisvec_List, numofcell_List, base_List] := (tmptmp = Transpose[base]; Flatten[ Transpose[(# + tmptmp) & /@ (Tuples[ Range /@ numofcell].basisvec), {1, 3, 2}], ...

0

This appears to be faster, dealing with the x and y coordinate lists separately: lattice2[basisvec_List, numofcell_List, base_List] := Module[{x, y, basex, basey}, {x, y} = Transpose[Tuples[Range /@ numofcell].basisvec]; {basex, basey} = Transpose[base]; Transpose[{Join @@ ((x + #) & /@ basex), Join @@ ((y + #) & /@ basey)}]]

4

This does not solve the problem, but provides some additional observations. As DiscretizeRegion[Interval[{0, 1}], MeshRefinementFunction -> (Echo@#2 > 0.01 &)] or DiscretizeRegion[Interval[{0, 1}], MeshRefinementFunction -> ((Print[#2]; #2 > 0.01) &)] work without any error messages I conclude that Reap is used somewhere within ...

2

For your first question a=1. tmptmp = Tuples[Range /@ {1000, 100}].{{3 a, 0}, {0, Sqrt[3] a}} The basic answer is that in your first case Transpose[# + Transpose[{{0, 0}, {a, 0}, {-a/2, Sqrt[3] a/2}, {3 a/2, Sqrt[3] a/2}}]] & /@ tmptmp the variable a gets evaluated many many times. I simplified the problem by defining a small ...

2

The problem resides in the fact that I was minimizing over a matrix not a number. This can be done, however, over the sum of the total matrix elements, by using the line: FinalFunct[a1_, a2_, a3_, b1_, b2_, b3_, c1_, c2_, c3_] := Sum[StateDifference[a1, a2, a3, b1, b2, b3, c1, c2,c3][[k]][[k]], {k, 1, Length[StateDifference[a1, a2, a3, b1, b2, b3, c1, c2, ...

8

There is another way that is on my machine almost 500x faster then your solution. The idea is to look how Mathematica represents colored strings and use this directly. When we colorize an input string by selecting text and using the Format menu, we can create something like this Now, press Ctrl+Shift+E to see the underlying expression. ...

4

For completeness, here is a way to extend the compiled or LibraryLink approaches to arbitrarily large integers. Since it comes so long after the original answer, I post it separately. As explained in this answer, we can bridge the gap between arbitrary and machine precision at least somewhat efficiently by using IntegerDigits to express a large integer as a ...

4

I really enjoy Mathematica when I can outsource tough algorithmic decisions to their source code- I believe this is the case here. It appears as if your code is doing something expensive (searching and replacing) many different times. I propose to do it all at once. Benchmark: txt = ExampleData[{"Text", "AeneidEnglish"}]; somewords = ...

2

I don't know if limiting yourself to a single traversal really helps that much. I would sort, split the list, and find the element with the smallest ByteCount in three separate passes, perhaps like this: SimplestEquivalents[exprs_, assumptions_, tol_: 10*^-8] := With[{nums = exprs /. assumptions}, Flatten[Map[ MinimalBy[exprs[[#]], ByteCount, 1] ...

Top 50 recent answers are included