New answers tagged

1

You can multiply each subset by all combinations of signs: result = Flatten[ Transpose[#*Transpose@Tuples[{1, -1}, Length@#]] & /@ Subsets[list, {1, Length@list}] , 1] // DeleteDuplicates; result // Sort (* {{-2}, {-1}, {1}, {2}, {-2, -2}, {-2, 2}, {-1, -2}, {-1, 2}, {1, -2}, {1, 2}, {2, -2}, {2, 2}, {-1, -2, -2}, {-1, -2, 2}, {-1, 2, -2}...


2

Here is a way to construct the list directly: list = {1,2,2}; Splice[Curry[Times][#] /@ Tuples[{1, -1}, Length@#]]& /@ DeleteDuplicates@Subsets[list, {1,Length@list}] (* {{1},{-1},{2},{-2}, {1,2},{1,-2},{-1,2},{-1,-2},{2,2},{2,-2},{-2,2},{-2,-2}, {1,2,2},{1,2,-2},{1,-2,2},{1,-2,-2},{-1,2,2},{-1,2,-2},{-1,-2,2},{-1,-2,-2}} *) If the input list can ...


1

You may construct you answer by treating each case separately. The one element cases: t1 = Subsets[list, {1}] t2 = Subsets[-list, {1}] and the two element cases: t3 = Flatten[Outer[List, list, list], 1] t4 = Flatten[Outer[List, list, -list], 1] t5 = Flatten[Outer[List, -list, -list], 1] And then combine everything: Join[t1, t2, t3, t4, t5]


2

list = {1, 2, 2}; result = Subsets[{Splice[list], Splice[-list]}, {1, Length@list}] GroupBy[result, Length[Intersection[#, -#]] < 1 &] <|True -> {{1}, {2}, {2}, {-1}, {-2}, {-2}, {1, 2}, {1, 2}, {1, -2}, {1, -2}, {2, 2}, {2, -1}, {2, -1}, {-1, -2}, {-1, -2}, {-2, -2}, {1, 2, 2}, {1, -2, -2}, {2, 2, -1}, {-1, -2, -2}}, False -&...


1

First, join the two groups: Join[files1, files2] Then gather them by their last 3 numbers like: StringCases["DT120_blur7_Defoc=050um_AstigX=000um_AstigY=260um.png", DigitCharacter ..] (*Out: {"120", "7", "050", "000", "260"} *) StringCases["DT120_blur7_Defoc=050um_AstigX=000um_AstigY=260um....


1

Clear["Global`*"] f1[theta_, phi_] = Sin[3 theta] Cos[phi]; f2[theta_, phi_] = Cos[theta] Sin[phi]; List1 = Flatten[ Table[{{theta, phi}, f1[theta, phi]}, {theta, 0, Pi, Pi/10}, {phi, 0, 2 Pi, 2 Pi/10}], 1]; List2 = Flatten[ Table[{{theta, phi}, f2[theta, phi]}, {theta, 0, Pi, Pi/10}, {phi, 0, 2 Pi, 2 Pi/10}], 1]; funcs = ...


1

polygoncoords = (Join @@@ Partition[Transpose[{list1, list2}], 2, 1])[[All, {1, 2, 4, 3, 1}]]; polygons = Polygon /@ polygons; Graph the third polygon (polygons[[3]]); Graphics[{Blue, Line@list1, Red, Line@list2, EdgeForm[rc = RandomColor[]], rc, Opacity[.5], polygons[[3]]}] Graphs polygons 1, 3 and 6 (polygons[[{1, 3, 6}]]): Graphics[{Blue, Line @ ...


6

In Python To reproduce the same result, I use the following code in python: import numpy a = numpy.asarray([ [1j,2+0j], [3+0j,4+0j] ]) In python when you want to export the array in CSV file with Numpy, use fmt to change the default formatting (i stands for integer, see here for more information): numpy.savetxt("foo.csv", a, delimiter=",&...


5

We can select two points from the two list alternatively and use ConvexHullMesh to construct the convex polygon. BTW,Here we have Reverse the order of the second listlist2to keep the orientation of polygon,so we can also replace ConvexHullMesh by Polygonto make the same convex polygons. list1 = {{0, 0.}, {0, 1.18961}, {0, 2.37923}, {0, 3.56884}, {0, 4....


1

Position is actually a pretty useful function. Not only can it find specific values: Position[h, 3] (as suggested by kglr) but it can also be used to locate indices of ranges of values, for example: Position[a, _?((2 < # < 5) &)] or Position[a, x_ /; (2 < x < 5)] to locate all the indices with values between 2 and 5.


6

I would argue that it's not a fair comparison unless you consider the performance with NumericArray, as the default Mathematica list-of-lists has many other features regarding numeric stability, etc. that are not present in a merely list of Real32 numbers. Let me demonstrate: In your code you do something like: SeedRandom[1]; coordinates = RandomReal[10, {...


11

Another idea is to make use of the fact that Cycles canonicalizes. For example: Cycles[{{5,1,2,3,4}}] Cycles[{{1, 2, 3, 4, 5}}] So, DeleteDuplicatesBy[arr, Cycles @* List] {{1, 2, 3, 4, 5}, {4, 3, 2, 5, 1}}


6

If we consider the list elements as graph vertices with an edge between each consecutive pair (cyclically), then two lists are equivalent if they can be mapped to graphs with the same edges. In code: graphs[list_] := <| # -> Sort@Thread[# -> RotateLeft[#]] & /@ list |> So then: graphs[arr] (* <| {1,2,3,4,5} -> {1->2, 2->3, 3-&...


2

For data, Mathematica has ListZTransform, which was introduced in V9 in 2012. SeedRandom[0]; data = RandomReal[1, 5]; data . z^-Range[0, Length[data] - 1] (* = definition *) ListZTransform[data, z] (* 0.652468 + 0.935202/z^4 + 0.566352/z^3 + 0.682813/z^2 + 0.63307/z 0.652468 + 0.935202/z^4 + 0.566352/z^3 + 0.682813/z^2 + 0.63307/z *) [Note that the Dot ...


2

Define an orbit index using CyclicGroup: orbitIndex = Association[Join @@ MapIndexed[Thread[# -> #2[[1]]] &] @ GroupOrbits[CyclicGroup[Length @ First @ #], #, Permute]] &; DeleteDuplicatesBy[arr, orbitIndex[arr]] {{1, 2, 3, 4, 5}, {4, 3, 2, 5, 1}} DeleteDuplicates[arr, orbitIndex[arr][#] == orbitIndex[arr][#2] &] {{1, 2, 3, 4, 5}, {4,...


2

The simplest and the most solid solution is DeleteDuplicatesBy[arr, Sort[NestList[RotateLeft, #, Length[#] - 1]] &] If this solution is too slow for you, you might devise something like DeleteDuplicatesBy[arr, RotateLeft[#, Last[Ordering[#]]] &] But the latter works only if you know that there are no repetitions in each group. For example, it does ...


2

arr = {{1, 2, 3, 4, 5}, {2, 3, 4, 5, 1}, {5, 1, 2, 3, 4}, {4, 3, 2, 5,1}}; DeleteDuplicatesBy[list, Sort[Table[RotateLeft[#, i], {i, 1, 5}]] &] // Length 2


4

Maybe DeleteDuplicatesBy[arr, Mod[# - #[[1]], 5] &] does what you want. It replaces rotation operations by basuc integer arithmetic. However, this exploits that only the numbers 1--5 appear in the lists. I don't know whether that is your actual use case... The following would be a more general method: DeleteDuplicatesBy[arr, RotateLeft[#, Ordering[#, -1]...


4

I must admit, I haven't read much past the question description, but the following creates isotropic tensors in 3-dimensions for rank n. As you note, we're seeking for tensors which satisfy: $$ T'_{i_1' i_2'\dots i_n'}=R_{i_1'i_1}R_{i_2'i_2}\dots R_{i_n'i_n}T_{i_1i_2\dots i_n} $$ The important identity here, is that we can express infinitesimal rotations (to ...


4

KCoreComponents The function KCoreComponents with 1 as the second argument gives the desired result: ClearAll[f1] f1 = KCoreComponents[#, 1] &; Examples: f1 @ {{1, 4}, {1, 6}, {2, 3}} {{1, 4, 6}, {2, 3}} f1 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}} {{1, 4, 6}, {2, 3}} f1 @ {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}} {{2, 3, 5}, {1, 4, 6}} ...


5

f[sep: List[__List]]:= Union @@@ Gather[ sep, IntersectingQ ] f@{{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}} (* {{1, 4, 6}, {2, 3, 5}} *) f@{{1, 4},{1, 6}, {2, 3}, {4, 6}} (* {{1, 4, 6}, {2, 3}} *) Alternatively, use pattern: {{1,4},{1,6},{2,3},{4,6}} //. { {OrderlessPatternSequence[x1: {__}, x2: {__}, y___]} :> {Union[x1, x2], y}/;...


2

If I understand your question correctly, you would like to join all sub lists that have some elements in common und delete duplicates. This can be achieved by e.g.: {{1, 4}, {1, 6}, {2, 3}, {4, 6}, {3, 5}} //. {y1___, x1:{__}, y2___, x2:{__}, y3___} /; Intersection[x1, x2] != {} :> {y1, Union[x1, x2], y2, y3} (*{{1, 4, 6}, {2, 3, 5}}*)


2

Try this: lst = {a^(-1 - x1), b^(-x2), (a + b)^(-x3), (1 - a)^(-1 + x4), (1 - b)^(-1), (1 + a b)}; lst1 = lst /. Power[y_, x__] /; y == a || y == b || y == c -> Nothing lst2 = Complement[lst, lst1] (* {(a + b)^-x3, (1 - a)^(-1 + x4), 1/(1 - b), 1 + a b} {a^(-1 - x1), b^-x2} *) Have fun!


6

If you have to use SequenceCases and pattern: list1 = Flatten @ SequenceCases[list, {Alternatives @@ pattern}] {a^(-1 - x1), b^-x2, (1 - a)^(-1 + x4)} list2 = Flatten @ SequenceCases[list, {Except[Alternatives @@ pattern]}] {(a + b)^-x3, 1/(1 - b), 1 + a b} Otherwise, you can use Cases: list1b = Cases[list, Alternatives @@ pattern] {a^(-1 - x1), b^-x2, (...


3

If the numbers are machine floats (complex ones), this will be fast: data3 = Compile[ {{m1, _Complex, 2}, {m2, _Complex, 2}, {m3, _Complex, 2}}, m1 . m2 . m3, RuntimeAttributes -> {Listable}, Parallelization -> True][mat1, mat2, mat3]; (If d1 is changed to d1 =300, then the OP's Table[] runs in 0.34 sec. and the above in 0.012 sec.)


3

Clear["Global`*"] f1 = 2 x; f2 = x^2; f3 = x^3 - 2 x^2 + 5; functions = {f1, f2, f3}; ranges = {{2, 5}, {3, 8}, {1, 4}}; Show[Plot @@@ Transpose[ {functions, Insert[#, x, 1] & /@ ranges}], PlotRange -> All] To use different PlotStyles colors = {Red, Blue, Green}; Show[Plot[#[[1]], #[[2]], PlotStyle -> #[[3]]] & /@ Transpose[ ...


5

{xmin, xmax} = MinMax[ranges]; 1. ConditionalExpression conditionalfunctions = MapThread[ ConditionalExpression[#, Between[#2] @ x] &, {functions, ranges}]; Plot[conditionalfunctions, {x, xmin, xmax}] You can also define conditionalfunctions as follows: conditionalfunctions1 = MapThread[ConditionalExpression[#, #2 @ x] &] @ {functions, ...


1

Using random rho and sigma matrices, here's a proof of concept: SeedRandom[1]; rho = #\[Transpose] . # &@RandomReal[{-1, 1}, {8, 8}]; sX = {sA, sB, sC} = #\[Transpose] . # & /@ RandomReal[{-1, 1}, {3, 2, 2}]; sXY = {sBC, sAC, sAB} = #\[Transpose] . # & /@ RandomReal[{-1, 1}, {3, 4, 4}]; G = MapThread[KroneckerProduct, {sX, sXY}]; Min[...


6

a = mat[[All, {1}]] {{Subscript[m, 1, 1]}, {Subscript[m, 2, 1]}, {Subscript[m, 3, 1]}, {Subscript[m, 4, 1]}, {Subscript[m, 5, 1]}} MatrixForm @ a


3

SeedRandom[1] list = RandomChoice[Range@5, 50]; ClearAll[n, tb] tb = TogglerBar[Dynamic[n], {1, 2, 3, 4, 5}]; Use MemberQ[n, #]& as the criterion function and wrap Select with Dynamic: Column[{tb, Dynamic @ Select[list, MemberQ[n, #] &]}] We get the same result using Column[{tb, Dynamic @ Cases[list, Alternatives @@ n] Alternatively, use a ...


3

[Update: I rewrote most of the text in response to the OP's comments. I suspect what I wrote originally lacked clarity. I hope I have improved it.] The extra time observed in Total[aa // First, Infinity] comes from copying the data in aa[[1]]. It resembles unpacking in that it adds time to the computation that seems unnecessary. Indeed, in unpacked ...


2

Memory. Table[RotateLeft[a, {1, 1}];, {i, 1, 500}] requires to allocate and to write $1000 \times 1000 \times 500 \times 8$ bytes for storing the result, while Table[RotateLeft[a, {1, 1}][[1, 1]], {i, 1, 500}]; requires only $500 \times 8$ bytes. However, I cannot reproduce the timings with Mathematica 12 for macos. My timings are 0.413361 for the former and ...


2

tst = Block[{x = rlist[[1]], y = rlist[[1]]}, Module[{sol = (Last[#1] &) /@ First[NDSolve[{eqs, ic}, var, {t, -tmax, tmax}]], Bsol}, Bsol = Table[Map[#1[t1] &, sol, {1}], {t1, ttlist}]; Map[(#1 . G0 . ConjugateTranspose[#1] &)[ttmesh Partition[#1 . Bsol, 2]] &, smat, {2}]]]; // AbsoluteTiming (* {0.0249631, Null} *...


7

Included in your timing is the Part operation. Try: b = a[[1]]; Total[b, Infinity]; // RepeatedTiming


1

If you have the time of the events in a list "data" then clusters=Gather[data,Abs[#1-#2]<60&] Mean/@Select[clusters,Length[#]>counts&] will give you all occurrences where the rate exceeds counts/minute.


6

If phif and phit are not lists, then MassDefect's and ciao's suggestions in comments as well as variations of them work: ClearAll[v1, v2, a, b, phif, x] v1 = Array[a, 3]; v2 = Array[b, 3]; phif = x; result1 = Table[findcvec[phif, phit, v1[[i]], v2[[i]], +1], {i, Length[v1]}] {findcvec[phif, phit, a[1], b[1], 1], findcvec[phif, phit, a[2], b[2], 1], ...


8

I found your simulation idea interesting, so I decided to look into the problem. What I found was that your implementation of nextState is mostly where the fault lies. It simply does not do what it name advertises — it does not compute the next state of the simulated world. Here is the code I used to develop a working simulation. I use a more modular ...


4

SeedRandom[1] anArray = RandomInteger[10, {40, 2, 61, 3}]; meana = Transpose[Mean[Transpose[anArray, {3, 2, 1, 4}]], {2, 1, 3}]; Dimensions[meana] {40, 2, 3} axis = 3; 1. Map Mean at level axis - 1: meanb = Map[Mean, anArray, {axis - 1}] Dimensions[meanb] {40, 2, 3} 2. Flatten with {axis} as the second argument and take Mean: meanc = Mean @ Flatten[...


2

For the Mean example, you can use Total instead, which does support other dimensions: A = RandomInteger[10, {40, 2, 61, 3}]; r1 = Transpose[Mean[Transpose[A, {3, 2, 1, 4}]], {2, 1, 3}]; r2 = Total[A, {3}]/Dimensions[A][[3]]; r1 === r2 True


4

With any version we can use foo = Table[Table[RandomComplex[], {i, 1000}], {j, 8192}]; With[{s1 = {250}, s2 = {250}, q = Abs[foo[[1, 21]] - foo[[1, -20]]]}, Table[RandomComplex[]*Table[q, s1], s2]]; // AbsoluteTiming Out[]= {0.0010452, Null} In more general case it takes about {0.144313, Null} f[i_, j_] := Abs[foo[[i, 21]] - foo[[j, -20]]] ...


11

Perhaps this: WithCleanup[ SetSystemOptions[ "CompileOptions" -> "TableCompileLength" -> Infinity], Table[Abs[foo[[1, 21]] - foo[[1, -20]]], {2500}]; // AbsoluteTiming, SetSystemOptions["CompileOptions" -> "TableCompileLength" -> 250] ] (* {0.006308, Null} *) Pre V12.2, use WithCleanup = Internal`...


7

SeedRandom[1234]; (mat = Take[#, RandomInteger[{3, 5}]] & /@ Array[a, {10, 10}]) // Column nbrCol[mat_, row_Integer?Positive] := Length@mat[[row]] nbrCol[mat, #] & /@ Range[10] (* {5, 3, 3, 4, 5, 5, 4, 4, 5, 5} *) nbrRows[mat_, col_Integer?Positive] := Count[mat, _?(Length[#] >= col &)] nbrRows[mat, #] & /@ Range[10] (* {10, ...


2

In the Table, wrap your output in e.g. PutAppend so each time an output is generated it gets appended to a file. I recommend that you label the results with the value of the iterator as well. Here is a minimal example, where I use Pause to simulate a long computation, and Print just to provide visual feedback to you of the progress of the computation (...


2

This is not an answer, but a comment that is too long and messy to be a normal comment. I can't see better way to do it than ListConvolve[{1, 4, 1}, {a, b, c, d, e, f, g}][[;; ;; 2]] Note that the initial 1 can be eliminated from [[1;; ;; 2]] Another way to do it is to first partition the data and then map ListConvolve over it. p = Partition[{a, b, c, d, ...


6

First, Array takes a function, look it up in the manual, what you need is Table. However, it is not necessary to fill heads and tails with zero. In MMA you seldom use loops. Instead work with whole vectors or rows/columns of matrices. Here is an example for what I mean: Create a table of flips. Then add all rows to get the number of tails. To get the heads, ...


5

The documentation for Position clearly shows that it searches at every level and inside every subexpression. If you want it to only look at the topmost level then perhaps telling it to only look for this at the first level might be closer to what you are looking for. fixedφvalues = {0, π/2, π, (3 π)/2}; Position[fixedφvalues, π,{1}] (*{{3}}*)


3

If the plots are already created, you can combine them using Show and post-process to change line colors: tup = tup1; plots = Plot[f[##], {x, 0, 10}] & @@@ tup; Show[plots] colors = ColorData[97] /@ Range[Length @ tup]; Legended[Show[plots, ImageSize -> Large] /. _?ColorQ :> Last[colors = RotateLeft[colors]], LineLegend[colors, tup]]


21

Update 2: We can combine a toggler-bar legend and FlipView to control curve visibility by clicking on curves and/or legends. (Naturally this approach is less responsive than either method.) First we plot functionswithtooltips and extract the primitives: plot1 = Plot[Evaluate[functionswithtooltips], {x, 0, 5}, GridLines -> Automatic, ImageSize -> ...


2

Try Select[list, #[[2]] > 2 &] (*{{1, 11}, {2, 7}, {7, 9}}*)


Top 50 recent answers are included