Tag Info

New answers tagged

2

This answer is effectively a generalization of the approach by halirutan and Pickett. Here, I present a function that when given a list of colors, a list of positions and colors, or a color gradient known to ColorData[], it yields a listable compiled function effectively equivalent to Blend[]: makeCompiledBlend[colors : (_String | _List), opts___] := ...


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 ...


2

Update It might be worthwhile just specifying PlotPoints. For instance, if we use Energies[_, _, x_, y_] := SparseArray[ {Band[{1, 2}] -> Cos[x] Sin[y], Band[{2, 1}] -> Cos[x] Sin[y]} , {3, 3}] as our set of test-matrices, then Plot3D[Evaluate @ Sort @ Eigenvalues @ Energies[W, q, x, y] , {x, 0, 1}, {y, 0, 1} , PlotPoints -> 10] ...


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]; ...


1

I figured, that the performance increase of memoizing the result of a_?OddQ -> 3 a + 1 or a_?EvenQ -> a / 2 would hardly help. However, it would be very helpful to memoize the sequence from applying the rule all the way until the result goes down to 1. Like so: ClearAll[f] f[1] = {1}; f[a_?EvenQ] := f[a] = Join[{a}, f[a/2]] f[a_?OddQ] := f[a] = ...


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. ...


8

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


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}


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} *)


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_] = ...


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[#] & /@ ...


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"] ...


1

I'm going with this, which tranposes the data, finds the unique values for X/Y using union and then selects X, and then Y, points which match each value: With[{tr = Union /@ (data\[Transpose])}, {Cases[data, {#, _}] & /@ First@tr, Cases[data, {_, #}] & /@ Last@tr}] {{{{0, 0}}, {{1, 2}, {1, 5}}, {{2, 3}}, {{3, 1}}, {{4, 4}}, {{5, 4}}, ...


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 // ...


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 ...


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 ...


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 ...


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 ...


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 ...


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 ...


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 ...


1

This is likely primarily due to array unpacking. See here: What is a Mathematica packed array? list1 takes only ByteCount[list1] (* 200000144 *) space when packed, but this increases to ByteCount@Developer`FromPackedArray[list1] (* 600000080 *) when unpacking. It's the same for list2, so the total rises to 1.2 GB. Make a rule list out of these ...


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]


1

Here are the list of all "record setters", perimeters which achieve higher values than any previous perimeter, for n ≤ 10^32: {12 60 120 240 420 720 840 1680 2520 4620 5040 9240 18480 27720 55440 110880 120120 166320 180180 240240 360360 720720 1081080 1441440 2042040 2162160 2882880 3603600 4084080 6126120 12252240 18378360 24504480 36756720 49008960 ...


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 -> ...


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 ...


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}


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}] ...


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 ...


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 ...


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 ...


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 ...


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, ...


1

This should do for part 1 ( so in this example, returns list 1 where cols. 1&2 match cols 2&3 in list 2): With[{s1 = #1[[All, #3]], s2 = #2[[All, #4]]}, Pick[#1, Replace[s1, Dispatch[ Append[Thread[Rule[Intersection[s1, s2], True]], _ -> False]], {1}], True]] &[list1, list2, {1,2}, {2,3}] Should be comparable in ...


0

These are just some tweaks of LLlAMnYP's approach, which I didn't read carefully enough at first to realize that the fundamental improvement, speeding up the integral, was similar in both cases; then I got curious because my locator-plot reacted faster even though my integral code evaluated slightly slower. The significant improvement is evaluating 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]


1

Using Complement on two lists could be used as follows: Complement[l1, l2] == {} True If you have more than one list, for example, l1 = {a, b, c}; l2 = {b, c, a}; l3 = {c, b, z}; you could also implement it with Tuples and compare the lists pairwise: ((Complement @@ #) == {}) & /@ Tuples[{l1, l2, l3}, 2] {True, True, False, True, True, ...


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] &] ]



Top 50 recent answers are included