Tag Info

Hot answers tagged

21

I've decided to expand on my comment. Before I delve into the solution, let's all pause for a moment and marvel at the stereographic parametrization of a unit circle: $$\begin{pmatrix}\frac{1-t^2}{1+t^2}\\\frac{2t}{1+t^2}\end{pmatrix}$$ Sometimes also referred to as the Weierstrass substitution, it has often been used as a tool in the solution of algebraic ...


15

You can speed it up by only invoking the NearestFunction once: KPosition3[x_, y_] := Module[{step0, step1, nf}, step0 = Thread[x -> Range[1, Length@x, 1]]; nf = Nearest[step0]; step1 = nf[#, y] & /@ x]; Running your three timing tests gives: {0.003057, 0.004344, 0.051009}


15

We can take advantage of the fact that IntegerDigits is very fast when the base is large. But not too large: no bigger than $2^{63}-1$ on a 64-bit system or $2^{31}-1$ on a 32-bit one, because Mathematica's machine integers are signed. Additionally, non-power-of-two bases require more work to get the result than just partitioning a bit-string, and are ...


13

This is because of the compilation that kicks in automatically if the list in Map exceeds a certain number of elements. "MapCompileLength" /. ("CompileOptions" /. SystemOptions["CompileOptions"]) (* Out: 100 *) shows that the default setting is that if the list contains more than 100 elements then Map will be compiled. MapThread on the other hand does not ...


11

Map is automatically compiled. Yes, even with RandomChoice. Try it: f = Compile[{{p, _Real, 0}, {t, _Integer, 1}}, Map[# RandomChoice[{p, 1 - p} -> {1, 0}] &, t] ]; f // InputForm (* -> clean bytecode *) Check its performance: p = 0.1; t = Table[1, {10^6}]; SeedRandom[1000]; AbsoluteTiming[a = Map[# RandomChoice[{p, 1 - p} -> {1, 0}] ...


10

I present in this answer a compiled implementation of one of the simpler algorithms for numerically evaluating a Bessel function of (modestly-sized) integer order and (small to medium-sized) real argument. This uses Miller's algorithm: bessj = With[{bjl = N[Log[1*^16]]}, Compile[{{n, _Integer}, {x, _Real}}, Module[{h, hb, ...


10

The problem is that Mathematica has no concept of using any datatype more specific than Integer or Real, and I think these are (on a 64bit computer) always 64bit long. So I can't think of a way to import that data into Mathematica in a way that would need less memory in the final state. If there is a limit of slightly more than 2GB in the size mma can import ...


8

Here's a way using Nearest a little differently, remembering Nearest's second argument can be a list... KPosition[x_, y_] := With[{p = PositionIndex[x]}, Map[p[#][[1]] &, Nearest[x, x, y][[All, 2 ;;]], {2}]] And my timings: KPosition[Tst1, 8]; // AbsoluteTiming KPosition[Tst2, 8]; // AbsoluteTiming KPosition[Tst3, 8]; // AbsoluteTiming ...


8

ImageLevels[ ColorConvert[img, "Grayscale"] ][[1, 2]] // RepeatedTiming (* Out: {0.0029, 144316} *) Generally, for speed, you want to avoid pattern matching altogether.


7

Preferential growth with an increasing number of vertices means that older vertices will have far more connections than the newer ones. So we know which vertices will probably be chosen, and we should try to use that in our algorithm. One way to do it is roulette wheel selection: randomChoice = Compile[{{list, _Real, 1}}, Module[{acc, i = 1, r1 = 0., r2 ...


6

Here is a version that should be superior to your attempt. I'm using ImagePartition (as already suggested by m_goldberg) to rip your original image apart at 1/3 of the image width. After that you use a negative ImagePad to remove 20 pixel and again a positive ImagePad to add a 20 pixel white border. For processing a large number of images, it definitely ...


6

You can do this much faster and more easily on the image level using: ImageMeasurements[ColorNegate@Binarize[img, 0], "Total"] // RepeatedTiming {0.0039, 144316.} Another way: Length@ImageValuePositions[img, 0] // RepeatedTiming {0.013, 144316}


6

Update Based on Guesswhoitis. answer I have improved my ugly code and use his approach. Otherwise the format is as outlined in original answer. Manipulate[p = {-a, 0}; q = {0, b}; r = {c, 0}; s = mp[a, b, c]; nfb = RegionNearest[Circle[{0, 0}, b]]; nfc = RegionNearest[Circle[{0, 0}, c]]; res = VectorAngle @@@ Partition[Join[{{-a, 0}}, sc[#] & /@ ...


6

The definition a = 0 is not being distributed among the subkernels, therefore in f2 the Sum is evaluated symbolically. After the results are returned to the master kernel a is substituted in. It happens that in this case a symbolic sum is much faster: ClearAll[a] Sum[N@Gamma[i + 1], {i, 10000}] // AbsoluteTiming Sum[N@Gamma[a + i + 1], {i, 10000}] /. a ...


5

There are two parts that are immediately suspicious to me: your phase calculation and finalState. Your calculation of phase is rather inefficient. Table is a good construct, but it is often slow. The form you have is not even allowing it to speed things up: you are nesting them instead of using both iterators with one call. Honestly, I would not even ...


5

Since "Visualizing the resulting triangle is left as an exercise for the interested reader" and I am interested here is a visualization of J.M.'s numeric solution. DynamicModule[{corners, perimeter, sol, u, v, pts}, Manipulate[ corners = {{-c, 0}, b {(1 - u^2)/(1 + u^2), 2 u/(1 + u^2)}, a {(1 - v^2)/(1 + v^2), 2 v/(1 + v^2)}}; perimeter[u_, v_] = ...


5

Just for fun: data = {{1, 2}, {3, 1}, {1, 5}, {6, 2}, {7, 3}, {4, 4}, {5, 4}, {0, 0}, {2, 3}, {6, 7}}; g = Cases[ Subsets[data, {2}] /. {{{x_, a_}, {x_, b_}} :> UndirectedEdge[{x, a}, {x, b}], {{a_, y_}, {b_, y_}} :> UndirectedEdge[{a, y}, {b, y}]}, UndirectedEdge[_, _]]; gr = Graph[data, g, VertexLabels -> "Name"] ...


5

There is a bug in your code which causes one of the factors in the Dot product to have excessively large imaginary parts (of the form 0. +1.32133*10^246 I). This means the multiplication can't be done in machine precision arithmetic, and as a result the calculation slows down considerably. The mistake is that the exponentiation of the eigenvalues must ...


4

Perhaps not the fastest, but reasonably fast (requires V10+): Select[Association[Thread[list2[[All, 2]] -> True]] @* First][list1] A slightly slower version of this to use for earlier versions: With[{rules = Dispatch[Thread[list2[[All, 2]] -> True]]}, Select[list1, Replace[First[#], rules] &] ]


4

Edit: now including Michael E2's improvement. Building on your own code and the existing answers this seems both cleaner and faster: wizKP[x_List, n_] := Nearest[x -> Automatic, x, n]


4

In short: there's no reliable way, so don't bother. Leave it to the users of your function to pass correct arguments to it which are actually functions. I think there was a question about this before, but I can't find it. Why is this not possible? There are many, many very different types of expressions in Mathematica that can act as functions, and ...


4

All times decrease as you proceed through this answer. The final version takes about 70% of the time of Pickett's solution on this sample problem on my hardware. For comparison, mrz's initial solution: mrz := Length[Position[ImageData[img], {0., 0., 0.}]] mrz // RepeatedTiming (* Out: {0.208, 144316} *) I found a number of much slower ways to do this. ...


3

You can apply your transformation to a black image of the same dimension to create a mask. When you add this mask to one of your images the black areas of the mask will not affect them, and the white areas will make the color channel values in those areas of the images one or larger. However, those values will then be truncated back to 1, giving you the ...


3

This should be pretty snappy: With[{t = First@Transpose@#1, t2 = Transpose[#2][[2]]}, Pick[#1, Replace[t, Dispatch[Thread[Rule[Intersection[t, t2], True]]], {1}]]] &[list1, list2]


3

You can use Count to achieve the same thing. It is slighlty faster on your image, but same order of magnitude execution time: Clear[data] data = ImageData[img]; Length@Position[data, {0., 0., 0.}] // RepeatedTiming Count[data, {0., 0., 0.}, Infinity] // RepeatedTiming (* Out: {0.16, 144316} {0.10, 144316} *)


3

Update On reflection I think using ConnectedComponents as referenced in the accepted answer to (4843) and used by ubpdqn in his answer is probably the best approach. Here is my implementation of that idea. fn2[data_] := UndirectedEdge @@@ Partition[#, 2, 1, 1] & /@ GatherBy[data, #] & /@ {First, Last} // Flatten // Graph // ...


2

The following function will calculate the eigensystem numerically when provided with numerical values of $j$ and $q$. This is, I believe, what @Szabolcs was referring to in his comment. I wonder if this is what you mean when you ask for a "numerical solution". Clear[eigen] eigen[jj_?NumericQ, qq_?NumericQ] := Chop@Eigensystem[N[f /. {j -> jj, q -> ...


2

One way to think about it that explains why it isn't a problem is to consider how setting a variable works in Mathematica. var = value is a shorthand syntax for Set[var, value]. Set has the attribute HoldFirst. This means that if var = 10 and value = 5 then the first thing that will happen as you write Set[var,value] is that it will be rewritten as Set[var, ...


2

Here is another version of the C code. As I have supposed this should be done much more efficient by avoiding a complete copy of the data I have implemented that to proof my point. The code below can only handle lists of integers (rank 1 arrays), but it reads those with an adjustable buffer size. With this version I could successfully read an integer ...


2

The performance can be further increased by just calculating and memoizing the sequence length and using ParallelMap instead of Map. seqLength[1] = 1 seqLength[n_?EvenQ] := seqLength[n] = 1 + seqLength[n/2] seqLength[n_?OddQ] := seqLength[n] = 1 + seqLength[3 n + 1] lengthList = Flatten@ParallelMap[seqLength, Range[10^6], Method -> Automatic]; ...



Only top voted, non community-wiki answers of a minimum length are eligible