New answers tagged

0

How about this? As an example, let lst = {1, 2, 0, 0, 0, 0, 0}; perm1 = {{3, 4}, {5}, {6}, {7}}; perm2 = {{3, 4, 5}, {6}, {7}}; Then, define f = ReplacePart[#1, Thread[Position[#1, 0] -> Flatten@Position[#, 0]]][[PermutationList[Cycles@#2, Length@#1]]] & and f[lst, perm1] (* {1, 2, 4, 3, 5, 6, 7} *) f[lst, perm2] (* {1, 2, 4, 5, 3, 6, 7} *) ...


1

Example Code List /@ {3,5,4,2} Output {{3}, {5}, {4}, {2}} Reference Map


1

Since your Data are already a List you can use Part to access Values: {3, 5, 4, 2}[[1]] 3 myList = {3, 5, 4, 2}; myList[[1]]*myList[[3]] 12 Nota Bene, everything in the comments seem right, however, you can also work with Subsets: lst = {3, 5, 4, 2}; s1 = Subsets[lst, {1}] {{3}, {5}, {4}, {2}} m = s1[[1]] {3} n = s1[[3]] {...


0

Well, I thought this would be quite easy with tables, but the code turned into arguably a bit of a whale, still posting it in case you find it useful, after all it does work. sc12 = {{{1, 2, 0, 0, 0, 0, 0}}, {{3, 2, 1, 0, 0, 0, 0}}}; pnscc2 = {{{3}, {4}, {5}, {6}, {7}}, {{3, 4}, {5}, {6}, {7}}, {{3, 4}, {5, 6}, {7}}, {{3, 4, 5}, {6}, {7}}, {{3, 4, 5}, ...


1

fun:=(1-Unitize[#])*Range[Length@#]+#& Usage fun/@CombiningCyclesCase2 {{1,2,3,4,5},{1,2,4,3,5},{1,2,4,5,3},{3,2,1,4,5},{3,2,1,5,4},{3,2,4,1,5},{3,4,1,2,5},{3,2,4,5,1},{3,5,4,1,2}}


4

If your lists are large (and rectangular as your example), this s/b considerably faster than existing answers: fix=With[{d=Dimensions@#},#+BitXor[1,Unitize@#]*ConstantArray[Range@d[[2]],d[[1]]]]&; or simpler and similar speed: fix2=With[{rx = Range@Length@#[[1]]}, (# + BitXor[1, Unitize[#]]*rx) & /@ #] &;


0

You could do this: Function[{a, b, c, d, e}, Graphics[{{PointSize@Medium, Point[{a, b, c, d, e}]}, Line[{{a,b}, {a,c}, {a,d}, {a,e}, {b,c}, {b,d}, {c, e}}]}]]@@CirclePoints[5] I used a Function to localize the variables and then applied it to the desired points with @@.


2

The answer is no. The 1st argument of With does not allow destructuring. It only accepts a list of simple assignments. I would rewrite the example you give as Module[{a, b, c, d, e}, {a, b, c, d, e} = CirclePoints[5]; Graphics[ {{PointSize @ Medium, Point[{a, b, c, d, e}]}, Line[{{a, b}, {a, c}, {a, d}, {a, e}, {b, c}, {b, d}, {c, e}}]}]]


4

ClearAll[f] f = ReplacePart[#, # -> Last @# & /@ Position[#, 0]]&; f @ CombiningCyclesCase2


5

One solution: MapIndexed[If[# == 0, Last[#2], #] &, CombiningCyclesCase2, {2}]


6

Update Modified to address ciao's comment. I think this is good implementation because it's simple, robust, and avoids all those calls to Position. complement[set1_List, set2_List] /; ContainsAll[set1, set2] := Module[{k, s1, s2}, k = Union[set1]; s1 = Split[Sort[set1~Join~k]]; s2 = Split[Sort[set2~Join~k]]; MapThread[Drop[#1, UpTo[...


9

cd= Module[{t1 = 2 Tally[#1], t2 = Tally[Join[#1, #2]], t3}, Sort[Join @@ ConstantArray @@@ Pick[t3 = Transpose[{t2[[;; Length@t1, 1]], Subtract[t1[[All, 2]], t2[[;; Length@t1, 2]]]}], Sign@t3[[All, 2]], 1]]] &; Using test = RandomInteger[1*^6, 1*^5]; del = RandomSample[test, 1*^3]; result= cd[test,...


2

Just something silly(and ugly): cf[a_, b_] := Module[{as = Association[Rule @@@ Tally[a]], bs = Association[Rule @@@ Tally[b]]}, Catenate@ KeyValueMap[ With[{s = #2[[1]] - #2[[2]]}, If[s < 0, {}, Table[#1, {s}]]] &, Merge[KeyUnion[{as, bs}], (# /. _Missing :> 0 &)]]] It is less inefficient than I thought it would be:


7

I can't say if it's more elegant, but this will also do what you seek myComplement[full_, todel_] := Fold[DeleteCases[#1, #2, 1, 1] &, full, todel] myComplement[{1, 2, 3, 3, 4, 4}, {1, 3, 4}] (* {2, 3, 4} *) This seems to be about twice as fast as OP's function (which I call myComplementOP below) list0 = Range[10000]; list1 = Flatten[{#, #, #} &...


4

Well, as @WReach has already explained the process of Thread clearly, I think I'll simply give a new function to solve this problem and make both examples work. After knowing the behaviour of Pick, a simple change can solve this problem------Whenever the two parts are not of the same shape, simply pass it and go to the next. The code is shown below: ...


7

What I think you are asking for can be achieved by 1) pairing up the values in the two rows (using Transpose) 2) Sorting by the First value in each pair using SortBy 3) Unpairing, again using Transpose. Specifically lists = {{2, 1, 0, 2}, {2, 1, 2, 0}} SortBy[Transpose[lists], First] // Transpose


4

list={{{1,2},{1}},{{2,2},{3,3}},{{5,{3,4}},{6,{4,5}}}}; Transpose[If[Quiet[Check[Transpose[#],True]]===True,#,Transpose[#]]&/@list] {{{1, 2}, {2, 3}, {5, 6}}, {{1}, {2, 3}, {{3, 4}, {4, 5}}}}


0

As mentioned in the comments: A hacky solution: Extra hacky because this should work for any list. data = {{{1, 2}, False}, {{2, False}, {3, False}}, {{5, False}, {6, True}}}; err = {}; Table[Table[ If[Length[data[[i, j]]] == 0, data[[i, j]] = ConstantArray[data[[i, j]], 2]; data[[1]] = Transpose[data[[1]]]; err = Append[err, i]], {i, ...


24

This is not a bug. It is a consequence of the manner in which Pick scans its arguments. The Pick Process The documentation for Pick calls its arguments list, sel and patt. Pick scans the list and sel expressions lock-step in a top-down, left-to-right fashion. It proceeds roughly as follows: The entire sel expression is checked to see if it matches ...


1

Although syntactically correct, your Manipulate expression is somewhat strange. Normally, one does not initialize a control in the first argument of a Manipulate expression, but I know of nothing in the literature of dynamic constructs that forbids it. On the other hand, because the order in which control variables are initialized is not clearly documented ...


0

For our unanswered rate, I decide to post this as an answer and hope this can solve your problem: ListAnimate[ Table[Plot[Sin[t y], {y, 0, 50}, PlotRange -> {-3, 3}, PlotLabel ->Style[t,30,Bold]], {t, .1, 5, .1}]] This will generate a Animated plot while a number shown above the graph indicate time:


0

This doesn't answer the question of "why does this bug out" but this answer is a DynamicModule that is equivalent to your Manipulate that you could add your Initialization function to. DynamicModule[ {a = 2, b = 1}, Panel[ Column[{ Manipulator[Dynamic[b], {1, a, 1}, Appearance -> "Open"], Framed[Dynamic[a], Background -> White, ...


7

Three possibilities: With[{n = 4}, ArrayFlatten[{{NestList[RotateRight, Array[B, n], n - 1], 1}, {{Array[A, n]}, 1}}]] With[{n = 4}, ArrayFlatten[{{ToeplitzMatrix[RotateRight[Reverse[Array[B, n]]], Array[B, n]], 1}, {{Array[A, n]}, 1}}]] With[{n = 4}, PadRight[Append[NestList[RotateRight, Array[B, n], ...


2

I would do something like the following: ListDensityPlot[list, PlotLegends->True, ColorFunction->"Rainbow"]


3

A couple of points: You have some duplicate coordinates in your data, these need to be removed before you can interpolate A couple of the points in your list are outside the range you've specified. Therefore you need to extrapolate, not interpolate, and the results at these points can't be trusted. data0 = DeleteDuplicatesBy[data0, #[[;; 2]] &]; ...


3

This is not a full answer, but it seems to me that you may have a use for code that allows you to group the points by the orbit they belong to, as Jason also mentioned. It seems to me that, with this in hand, the problem may be reduced to the one @JasonB solved in your previous question. Here's a start in that direction: paths = FindClusters[data0, 15, ...


3

You can make an interpolating function for both px and py from the data you have: data = Import["Downloads/lyap_4d.dat", "Table"]; d00 = data[[All, {1, 2}]]; pyfunc = Interpolation[{{#1, #2}, #4} & @@@ data, InterpolationOrder -> 1]; pxfunc = Interpolation[{{#1, #2}, #3} & @@@ data, InterpolationOrder -> 1]; That answers the question ...


2

Some alternatives for thought food... slist /. x_Integer:>g[x] ...or... Last@Last@Reap[Scan[Sow[g[#]]&,slist]]


2

g[w_] := w^2 + 1 slist = Range[0, 100, 1]; g[slist] {1,2,5,10,17,26,37,50,65,82,101,122,145,170,197,226,257,290,325,362,401,442,485,530,577,626,677,730,785,842,901,962,1025,1090,1157,1226,1297,1370,1445,1522,1601,1682,1765,1850,1937,2026,2117,2210,2305,2402,2501,2602,2705,2810,2917,3026,3137,3250,3365,3482,3601,3722,3845,3970,4097,4226,4357,4490,4625,...


1

Just some variants. If only want first element: Reap[Sow @@@ data, 1, #2 &][[2, 1]] 1 /. GroupBy[data, Last -> First] both yield: {{0, 0, 0}, {2, 0, 0}} If whole element: 1 /. GroupBy[data, Last] yields: {{{0, 0, 0}, 1}, {{2, 0, 0}, 1}}


5

I had the same idea as Jim Baldwin, as constraints are often implemented as penalty functions. Here is one that severely penalized any negative residual. The parameter scale might need to be adjusted to be a significant fraction of the range of the data values. ClearAll[penalty]; penalty[residuals_?VectorQ, scale_: 10] := scale*Length@residuals*(1 - ...


5

Never forget Pick for problems involving picking elements from a list. data = {{1, 2, 3, 4, 5, 6}, {2, 3, 4, 5, 6}, {1, 3, 4, 5, 6}, {1, 2, 4, 5, 6}, {1, 2, 3, 5, 6}, {1, 2, 3, 4, 6}, {1, 2, 3, 4, 5}, {1, 2, 5, 6}, {1, 2, 4, 6}, {1, 2, 4, 5}, {1, 2, 3, 6}, {1, 2, 3, 5}, {1, 2, 3, 4}, {5, 6}, {4, 6}, {4, 5}, {3, 6}, {3, 5}, {3, 4}, {2, 6}, {2, ...


6

Never forget Pick for problems involving picking elements from a list. data = {{{0, 0, 0}, 1}, {{2, 2, 2}, 0}, {{2, 2, 0}, 0}, {{2, 2, -2}, 0}, {{2, 0, 2}, 0}, {{2, 0, 0}, 1}, {{2, 0, -2}, 0}, {{2, -2, 2}, 0}, {{2, -2, 0}, 0}, {{2, -2, -2}, 0}}; Pick[data, Last /@ data, 1] {{{0, 0, 0}, 1}, {{2, 0, 0}, 1}}


3

You can also use replacement rules. FYI, this method is usually slow on very large lists. list/. { {{_, _, _}, 0} -> Sequence[], {x : {_, _, _}, 1} :> x } Which gives: {{0, 0, 0}, {2, 0, 0}}


5

Cases[{{{0, 0, 0}, 1}, {{2, 2, 2}, 0}, {{2, 2, 0}, 0}, {{2, 2, -2}, 0}, {{2, 0, 2}, 0}, {{2, 0, 0}, 1}, {{2, 0, -2}, 0}, {{2, -2, 2}, 0}, {{2, -2, 0}, 0}, {{2, -2, -2}, 0}}, {list_, 1} :> list] (*{{0, 0, 0}, {2, 0, 0}}*)


4

Example Data list = {{{0, 0, 0}, 1}, {{2, 2, 2}, 0}, {{2, 2, 0}, 0}, {{2, 2, -2}, 0}, {{2, 0, 2}, 0}, {{2, 0, 0}, 1}, {{2, 0, -2}, 0}, {{2, -2, 2}, 0}, {{2, -2, 0}, 0}, {{2, -2, -2}, 0}} Code Select[list, #[[2]] == 1 &][[All, 1]] (*For cases 1*) Select[list, #[[2]] == 2 &][[All, 1]] (*For cases 2*) Output {{0, 0, 0}, {2, 0, 0}} Reference ...


4

Just for our unanswered rate: With[{n = 6}, Select[List1, Length[#] == 2 || Length[#] == n-2 &]] With[{n = 6}, Pick[List1, Length/@List1, 2 | n-2]] Try With: it will always help if you want to plug something in an expression fast.


4

Example Code Select[list, Length @ # == 2 || Length @ # == 4 &] or with n n = 6; Select[list, Length @ # == 2 || Length @ # == n - 2 &] Output {{1, 2, 5, 6}, {1, 2, 4, 6}, {1, 2, 4, 5}, {1, 2, 3, 6}, {1, 2, 3, 5}, {1, 2, 3, 4}, {5, 6}, {4, 6}, {4, 5}, {3, 6}, {3, 5}, {3, 4}, {2, 6}, {2, 5}, {2, 4}, {3, 4, 5, 6}, {2, 4, 5, 6}, ...


4

So, I think this is what you actually wanted: d2 = {{{0.5, 0.0142}, {2.5, 0.00223}, {7., 0.00158}, {12., 0.00151}, {17., 0.0035}, {22., 0.0054}, {27., 0.00751}, {32., 0.01028}, {37., 0.01604}, {42., 0.02347}, {47., 0.03576}, {52., 0.05677}, {57., 0.07494}, {62., 0.11366}, {67., 0.16382}, {72., 0.23114}, {77., 0.32861}, {82., 0.44569},...


2

There are many answers, but I want to give another one that could be not so elegant, but is very suitable for easy modification. It's quite often that you have a list of "objects", where object can be a weirdly nested list, and you need to extract some subset of components possible in different order. l = {{{x1, y1}, z1}, {{x2, y2}, z2}}; {#[[1, 1]], #[[1, ...


4

♭ = ## & @@@ {##} & @@@ # &; ♭ @ {{{x1, y1}, z1}, {{x2, y2}, z2}} {{x1, y1, z1}, {x2, y2, z2}}


2

Example Code Partition[Flatten @ data , 3] Output {{x1, y1, z1}, {x2, y2, z2}} Note: data is your original list Reference Flatten Partition


5

Let's have an answer. data = {{{x1, y1}, z1}, {{x2, y2}, z2}, {{x3, y3}, z3}, {{x4, y4}, z4}}; J.M. Flatten /@ data Append @@@ data m_goldberg ArrayReshape[data, {Length[data], 3}] Block[{h}, h[{{a_, b_}, c_}] := {a, b, c}; h /@ data] All of the above return {{x1, y1, z1}, {x2, y2, z2}, {x3, y3, z3}, {x4, y4, z4}}


2

another option is Cases lst = {{{x1, y1}, z1}, {{x2, y2}, z2}} Cases[lst, {{x__}, y__} :> {x, y}]


1

I haven't seen this yet, but it may be degenerate with someone else's answer. Append @@@ Partition[Riffle[list, x], 2]


2

For your specific example, why not: FoldList[# + #2^2 + #2^3 &, 1, someList]


4

Using MapIndexed... MapIndexed[Join[#1, x[[#2]]] &, list]


4

Yet another possibility, using Flatten[] as a "generalized Transpose[]": Append @@@ DeleteCases[Flatten[{list, x}, {{2}, {1}}], {_}] {{1, 2, x1}, {5, 2, x2}, {9, 3, x3}, {6, 5, x4}}


1

list = {{1, 2}, {5, 2}, {9, 3}, {6, 5}}; x = {x1, x2, x3, x4, x5, x6, x7}; ArrayFlatten[{{list, {#} & /@ x[[1 ;; 4]]}}] {{1, 2, x1}, {5, 2, x2}, {9, 3, x3}, {6, 5, x4}}


1

It's not quite clear what is the role of someList in what you're trying to implement, but if I understand you correctly you can do it with Table: c=a; d=b; Table[{c,d,e}=someFunction[c,d,x];e , {x,someList}]



Top 50 recent answers are included