New answers tagged

1

Following @eyorble's suggestion to look at DivideSides, I found that a method the does the trick is ApplySides[#/eps&, eqsOfMotion] (and I think another valid solution replaces ApplySides with Map). DivideSides does not work for me because it is too intelligent for its own good, and creates a proliferation of cases in which I have no interest.


3

Here is a way using SplitBy: split[l:{__}, m_] := Module[{e = l[[1, 1]] + m} , SplitBy[l, If[#[[1]] < e, e, e = #[[1]] + m]&] ] split[list, 3] (* {{{1,x},{2,x},{3,x}},{{4,x},{5,x}},{{8,x}},{{13,x}},{{16,x},{17,x}}} *)


0

Table[2 Table[i, {i, 0, k}], {k, 0, 4}] (* {{0}, {0, 2}, {0, 2, 4}, {0, 2, 4, 6}, {0, 2, 4, 6, 8}} *)


1

You are probably expected to use Table like this: A = {0, 2, 4, 6, 8}; Table[A[[;; i]], {i, Length[A]}] {{0}, {0, 2}, {0, 2, 4}, {0, 2, 4, 6}, {0, 2, 4, 6, 8}} Or in some equivalent way such as: Table[i, {k, A}, {i, 0, k, 2}]


7

The main question here is, there are too many approaches to perform the same operation. And normally, I didn't know which approach is the most optimal way in terms of efficiency. Mathematica's performance is hard to predict, even more so than that of other high-level languages. There is no simple guideline you can follow. There will always be surprises and ...


3

The double semicolon syntax list[[i ;; j]] gives you a span of elements, not different levels. So, with l = {a,b,c}, l[[2 ;; 3]] gives {b,c}. You'll want to use commas instead! Note also that Mathematica lists start at 1, not 0. So you'll want b[[1, 2]]. This is equivalent to b[[1]][[2]], giving the first part of {{10,11}}, which is {10,11}, and then the ...


4

1. TopologicalSort path1 = Partition[TopologicalSort[DirectedEdge @@@ li], 2, 1] 2. FindHamiltonianPath path2 = Partition[Reverse @ FindHamiltonianPath[li], 2, 1]; Alternatively, path3 = Partition[FindHamiltonianPath[DirectedEdge @@@ li], 2, 1]; 3. RelationGraph rg = RelationGraph[#[[2]] == #2[[1]] &, li] path4 = FindHamiltonianPath @ rg ; We can ...


0

rule = {x1___, y1 : {_, x3_}, x4__, y2 : {x3_, _}, x5___} :> {x1, y1, y2, x4, x5}; Sort[li] //. rule


5

Import the molecule In[14]:= m = Import["https://pastebin.com/raw/d5UcNr2h", "XYZ"]; In[15]:= OutputForm[m] Out[15]//OutputForm= Molecule[<Cu513H210S672>] Get a list of copper atom indices In[16]:= copperSites = AtomList[m, "Cu", "AtomIndex"] Out[16]= {483,484,485,486,487,488,489,490,491,492,<<493>&...


0

If you want the position specification required to Extract a particular element, use Position. pos = Position[list, 1] (* {{1, 1, 1, 1}} *) Extract[list, pos] (* {1} *}


0

Try also this: f[x_, a_] := x[[a]]; Fold[f, list, Table[1, Depth[list] - 1]] (* 1 *) Have fun!


0

First: You can put a list of indices into a single pair of [[...]] to access elements of nested lists (which already improves readability a lot): list = {{{{1, 2}}}} (* {{{{1, 2}}}} *) list[[1]][[1]][[1]][[1]] (* 1 *) list[[1, 1, 1, 1]] (* 1 *) Going from the bottom up is generally more difficult: For the case of a (nested) list of integers (or other ...


4

If you need to compute all 16 (4×4) integrals and then extract the diagonal elements, use Diagonal: Diagonal[angdist3[#, 0.3] & /@ a] {100707., 71762., 25625.6, 13508.} You could instead compute only those 4 results. MapThread will map over both a and b simultaneously: MapThread[angdist[#1, #2, 0.3] &, {a, b}] {100707., 71762., 25625.6, 13508.} ...


2

RandomInteger[{1, 4}, {5, 5}] this generates a 5 by 5 array of random integers in the range {1,4} Table[RandomInteger[{1, 4}, {5, 5}], {3}] this generates 3 arrays Table[RandomInteger[{1, 4}, {m, m}], {m, 4, 6}, {3}] this generates 3 of each size starting at the 4 by 4 ending on the 6 by 6 Table[RandomInteger[{1, 4}, {m, m}], {m, 4, 6}] this generates 1 ...


2

Clear[h, y] a = {1, 2}; b = Accumulate[a] - a/2; Transpose[{Thread[h -> a], Thread[y -> b]}] {{h -> 1, y -> 1/2}, {h -> 2, y -> 2}}


4

L = {{h -> 1}, {h -> 2}}; Y = Thread[y -> Flatten[Accumulate[Values@L ] - Values@L/2]]; Join[L, List /@ Y, 2] {{h -> 1, y -> 1/2}, {h -> 2, y -> 2}} Or MapThread[Append] @ {L, Y} {{h -> 1, y -> 1/2}, {h -> 2, y -> 2}} Or Flatten /@ Thread @ {L, Y} {{h -> 1, y -> 1/2}, {h -> 2, y -> 2}}


2

f[x_, y_, z_] := x + y + z; Try @@@ (Apply at Level 1): f[#,#2, 1] & @@@ {{1, 2}, {3, 4}} {4, 8}


2

tuples = {{24, 29}, {155, 161}, {185, 193}, {220, 224}, {229, 234}, {251, 256}, {290, 297}, {394, 406}, {568, 586}, {648, 654}, {691, 696}, {760, 772}, {852, 856}, {860, 864}, {923, 929}, {954, 958}, {984, 992}, {1099, 1108}, {1138, 1144}, {1179, 1185}}; sa = SparseArray[Thread[Join @@ Range @@@ tuples -> 1], {1199}] Normal @ sa You ...


4

Two additional methods (both faster than Select[strings, StringContainsQ["101"]]): strings = Map[StringJoin, Tuples[{"0", "1"}, 6]]; Pick[strings, StringContainsQ["101"] @ strings] {"000101", "001010", "001011", "001101", "010100", "010101", "010110&...


3

Two different methods: strings = Map[StringJoin, Tuples[{"0", "1"}, 6]]; Flatten @ StringCases[ strings, StartOfString ~~ ___ ~~ "101" ~~ ___ ~~ EndOfString ] Select[strings, StringContainsQ["101"]] The Select variant is slightly faster for large datasets.


0

I face a similar problem in my calculation and I want to share my answer here. The following argument is related to two-dimension, but it can also generalize to other dimensions, lets first make random points SeedRandom[253] pts = RandomReal[{-1, 1}, {1000, 2}]; Then, using NearestNeighborGraph and ConnectedComponents, we can find nearby points with some ...


4

Here is an example that uses Table (well, ParallelTable) instead of For. I've also used ParametricNDSolveValue instead of With, mostly to simplify the Table. phifunc = ParametricNDSolveValue[ {\[Phi]''[x] + 2 \[Phi]'[x]/x + (2 (zg + zh Exp[-zh x/dh])/x + 1) \[Phi][x] == 0 , \[Phi][$MachineEpsilon] == 1 , \[Phi]'[$MachineEpsilon] == -(zg + zh) } ,...


1

x = {{1, 2}, {2, 3}, {3, 4}, {4, 5}, {5, 6}} x // Select[Between[First@#, {2, 4}] &] (* {{2, 3}, {3, 4}, {4, 5}} *)


2

You can Sow and Reap different tags like this: v1 = Reap[ Do[ MapIndexed[ Sow[#1, First @ #2] &, {{i, i}, {i^2, i^3}} // Transpose ];, {i, 3} ], Range[2] ][[2, All, 1]] {{{1, 1}, {2, 4}, {3, 9}}, {{1, 1}, {2, 8}, {3, 27}}} Of course, you do need to know the number of tags to collect (2, in this case).


6

You were really close. You just need to add another underscore to y_ as list = { {Position, {Code}}, {1, {0000, 0001}}, {2, {0100, 0011}}, {3, {0110, 0111}}, {4, {1000, 1001}}, {5, {1100,1011}}, {6, {1110, 1111}} }; list /. {x_, {y__}} :> {x, y} {{Position, Code}, {1, 0000, 0001}, {2, 0100, 0011}, {3, 0110, 0111}, {4, 1000, 1001}, {5, 1100,...


5

ReplacePart can do it. data = {{Position, {Code}}, {1, {0000, 0001}}, {2, {0100, 0011}}, {3, {0110, 0111}}, {4, {1000, 1001}}, {5, {1100, 1011}}, {6, {1110, 1111}}}; ReplacePart[data, {i_, 2} :> Sequence @@ data[[i, 2]]] {{Position, Code}, {1, 0, 1}, {2, 100, 11}, {3, 110, 111}, {4, 1000, 1001}, {5, 1100, 1011}, {6, 1110, 1111}}


1

How about ClearAll@f f[a_, b_] := {a, RandomInteger[{1, 100}, 10]} ListLinePlot[Table[f[a, b][[2]], 10]]


6

A few additional methods: Level[#, {-1}] & /@ list Apply[Sequence, list, {-2}] Map[Splice, list, {-2}] Join[{#}, #2] & @@@ list Prepend[#2, #]& @@@ list MapAt[Splice, {All, 2}] @ list ReplacePart[{_, 2, 0} -> Sequence] @ list Map[Map @ Apply @ Sequence] @ list Delete[{2, 0}] /@ list FlattenAt[#, 2] & /@ list ... and for the ...


10

list // Map[Flatten] {{Position, Code}, {1, 0, 1}, {2, 100, 11}, {3, 110, 111}, {4, 1000, 1001}, {5, 1100, 1011}, {6, 1110, 1111}}


0

@DanielHuber's comment turned out to be the most general and fast for nested lists, with some modifications: (* helper to join singletons/nonlists to nearest list *) join[a_List, b_List] := Join[a, b]; join[a_List, b_] := Join[a, {b}]; join[a_, b_List] := Join[{a}, b]; list = {{0, {1, 2}, {3}, 4, {5, 6}, {7}}, {8}, {{1}, {2}}, 3, {{4, 5, 6}}, {{7}}}; ...


6

Try list={{Position,{Code}},{1,{0000,0001}},{2,{0100,0011}},{3,{0110,0111}},{4,{1000,1001}},{5,{1100,1011}},{6,{1110,1111}}} list /. {a_ , b_List } -> Join[{a}, b]


2

Sort[#, Greater] & /@ {{1, 2}, {3, 3}, {5, 6}, {3.14, π}} Or {{1, 2}, {3, 3}, {5, 6}, {3.14, π}} /. {x_?NumberQ, y_?NumberQ} :> {Max[x, y], Min[x, y]} {{2, 1}, {3, 3}, {6, 5}, {π, 3.14}}


3

lists = {{0.959531`,1.72455`},{1.39025`,1.70444`},{1.53595`,0.207495`}, {0.117589`,0.270531`},{0.815728`,1.53551`},{1.43189`,0.0795958`}, {0.959939`,0.742054`},{1.92875`,1.77258`},{0.494335`,0.588112`}, {1.22158`,1.08751`},{0.8228`,0.309531`},{1.41939`,0.833903`}} MatrixForm[lists] sorted = Map[ReverseSort] @ lists; MatrixForm[sorted]


1

Setting the attribute Orderless to a function F with two arguments could be one option. This attribute orders the the arguments of F on input: The problem/caveat of this approach is that Orderless functions appear only with their arguments canonically ordered (e.g.: F[b,a] returns F[a,b]) which can only be prevented by using Hold: Hold[F[b, a]] returns Hold[...


2

lst = {{}, {1, 2, 3}, {4}, {5, 6}, {7}, {}}; We can use SequenceReplace: ClearAll[appendLeft1, appendRight1] appendLeft1[l_, n_: 1] := SequenceReplace[{a_, b__} /; (And @@ Thread[Length /@ {b} <= n]) :> Join[a, b]] @ l appendLeft1 @ lst {{}, {1, 2, 3, 4}, {5, 6, 7}} appendRight1[l_, n_: 1] := SequenceReplace[{a__, b_} /; (And @@ Thread[...


0

I would pack the data into associations like: manualPlacement = Association[ "PP" -> Association[week1 -> metrics, week2 -> metrics, ..], "Ros" -> Association[week1 -> metrics, ..], "Top" -> Association[week1 -> metrics, ..]]; autoPlacement = Association["PP" -> .., "Ros" ...


0

{{x1, y1}, {x2, y2}, {x3, y3}} /. {x_, y_} :> {x, Log[y]} Or {#1, Log[#2]} & @@@ {{x1, y1}, {x2, y2}, {x3, y3}} Or the method which provided by @wuyudi


7

SequenceReplace SequenceReplace[{f1, _, _} | {f2, _} -> Nothing] @ lis {c, d, g, h, i, l, m, o} Split+ ReplaceAll ReplaceAll[{{f1, _, _, a___} | {f2, _, a___} :> a}] @ Split[lis, #2 =!= f1 && #2 =!= f2 &] {c, d, g, h, i, l, m, o}


1

Answer was provided in the comments to the question - by kglr: Table[X[i], {i,layernumber}] * Table[Y[j], {j,interfacenumber}] Which seems a little obvious in hindsight to just use two Table functions instead of one. Extrapolating this to the problem I'm working on (which has some unruly matricies) also required use of the Map function, again thanks to kglr....


2

Change the outer for loop to a table: d = 1000; sol = Table[alpha = 0.1*k; fd = 3*d^2/(Pi^2); fs = fd*FareySequence[d]; count = 0; For[i = 1, i < fd, i++, For[j = (i - 1), j > 0, j--, If[(fs[[i]] - fs[[j]]) < alpha, count++, Break[]]];]; {k, count/d^2}, {k, 1, 40}]; ListPlot[sol] gives the plot you're looking for!


1

Maybe this? layernumber = Accumulate[Mod[Range[1, 2 Nlayer], 2]]; interfacenumber = 1 + Accumulate[Mod[Range[0, 2 Nlayer - 1], 2]]; MapThread[Times, {layernumber, interfacenumber}] Inner[X[#1]*Y[#2] &, layernumber, interfacenumber, List]


4

Or using CartesianProduct from Combinatorica package t1 = {{1,2},{3,4}}; t2 = {{a,b,c},{e,f}}; Needs["Combinatorica`"] Flatten /@ Catenate @ MapThread[CartesianProduct,{List[#]& /@ t1,t2}]


3

Here's what you can do: you can interpolate the derivative of fx and then integrate it. The derivative of fx is well-behaved outside of the function range: Plot[fx'[x], {x, -3, 3}] So instead of interpolating the function and differentiating it, you can interpolate the derivative and integrate it: fx2 = Derivative[-1] @ Interpolation[ Transpose[{Range[-3,...


6

Given: t1 = {{1, 2}, {3, 4}}; t2 = {{a, b, c}, {e, f}}; ReplacePart can express the transformation reasonably directly: ReplacePart[t2, {i_,j_} :> Append[t1[[i]], t2[[i,j]]]] // Catenate (* {{1,2,a},{1,2,b},{1,2,c},{3,4,e},{3,4,f}} *) The same technique is textually shorter using MapIndexed, but perhaps a little less readable: MapIndexed[Append[t1[[#2[[...


4

Here's solution that works quickly: FareySequence[1000] is only 304193 elements long, plenty short enough to store in memory, so just calculate the sequence once then access the elements for a speed up. fs = 304193*FareySequence[1000]; Then notice that the elements of FareySequence are monotonically increasing, so if you take element fs[[i]] and the ...


2

More an extended comment than an answer... If you reduce the limit of your i iterator to something small, e.g., 10 rather than 304193, the corrected code ("IF" rather than "if") seems to work fine. Try the following: count = 0; For[i = 1, i < 10, i++, For[j = 1, j < i, j++, If[ (304193 *FareySequence[1000, i]) - (304193 * ...


5

I also use Outer to construct the list. t1 = {{1, 2}, {3, 4}}; t2 = {{a, b, c}, {e, f}}; MapThread[ Outer[Flatten@*List, {#1}, #2, 1]~Flatten~1 &, {t1, t2}]~Flatten~1 Flatten /@ MapThread[Outer[List, {#1}, #2, 1] &, {t1, t2}]~Flatten~2


9

Your method is quite concise. You can also do: MapThread[## & @@ Thread[{## & @@ #, #2}] &]@{t1, t2} Join @@ MapThread[Thread[{## & @@ #, #2}] &] @ {t1, t2} Join @@ MapThread[Flatten /@ Thread[{##}, List, {2}] &] @ {t1, t2} Join @@ MapThread[Function[{a, b}, Append[a, #] & /@ b]] @ {t1, t2} Join @@ Map[Flatten]@*Tuples /@ ...


1

I never played roulette, so check my assumptions: There are 37 wholes, 18 red 18 black, 1 green. If I set on red and the ball stop on red, I get twice my money back, otherwise I lose all. With this assumptions: We mark "win" by 1 and loose by "0". Then playing n times the numbers of "wins" is: Count[RandomChoice[{18, 19} -> {...


4

You can use the options MeshFunctions, Mesh and MeshStyle as follows: Manipulate[Plot[x^2 - 2*(a - 2)*x + a - 2, {x, -20, 20}, ClippingStyle -> False, MeshFunctions -> {# &}, Mesh -> {{a - 2}}, MeshStyle -> Directive[PointSize[Large], Red], PlotRange -> {-200, 200}], {a, -10, 10}] Alternatively, you can use Epilog Manipulate[...


Top 50 recent answers are included