New answers tagged

4

Select[Transpose[{l1,l2}],#[[2]] =!= False &] (* {{a > b, c > d}, {m > n, j > k}} *) Select[Transpose[{l3,l4}],#[[2]] =!= False &] (* {{j > k, m > n}} *) where l1={a>b,x>y,m>n} l2={c>d,False,j>k} l3={a>b,c>d,x>y,j>k} l4={False,False,False,m>n} (Original Answer) Select[Transpose[{l1,l2}],FreeQ[#[[2]...


4

Does this do what you want? array = Riffle[{list1, list2, list3}, {{{Null, Null}}}]; array = Flatten[Transpose /@ array, 1]; array = PadRight[#, Max[Length /@ array], Null] & /@ array; Export["data.xls", Transpose[array]] Riffle puts the two empty columns between each of the lists. Flatten produces a list of the spreadsheet columns. ...


4

l1 = {a > b, x > y, m > n}; l2 = {c > d, False, j > k}; MapThread[ If[#1 =!= False && #2 =!= False, List[#1, #2], Nothing] &, {l1, l2}] {{a > b, c > d}, {m > n, j > k}}


3

One way of going about it is with a, in some sense, fundamental part of MMA called pattern matching via DeleteCases. l1 = {a > b, x > y, m > n}; l2 = {c > d, False, j > k}; Transpose@{l1, l2} (*Gets corresponding pairs of elements*) DeleteCases[ % (*This is the shorthand to refer to the previous output and is technically Out[-1]*), {_, ...


3

Adding InterpolationOrder -> 0 prevents this issue. Voltage[x_] := ListLinePlot[ v, PlotStyle -> {Red, AbsoluteThickness[x]}, PlotRange -> Automatic, ImageSize -> 600, LabelStyle -> {FontSize -> 20, FontFamily -> "Helvetica", Black, Bold}, Frame -> {True, True, False, False}, FrameLabel -> {{"...


2

One big speed-up you can get is realizing a $k$-regular graph has $kn/2$ edges so you don't have to generate all subsets of the edges. This goes from considering $2^{n(n-1)/2}$ subsets to $\binom{n (n-1) /2}{kn/2}$ which is a large savings. I am still thinking if there's a way to get more savings by constraints involving spanning sets or regular sets. Either ...


1

list = Range[5]; StringRiffle[list, " "]


1

Edit 2: list1 = {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}, {-1, 1, 0}, {1, -1, 0}, {-1, -1, 0}, {-1, 0, 1}, {1, 0, -1}, {-1, 0, -1}, {0, -1, 1}, {0, 1, -1}, {0, -1, -1}}; list2 = {{2, 0, 0}, {0, 2, 0}, {0, 0, 2}, {-2, 0, 0}, {0, -2, 0}, {0, 0, -2}}; a[n_] := {"a" <> "[" <> ToString@n <> "]", list1[[n]]} ...


1

input = a1 a2 b1 b2 c2 c3 + 100 a1 b2 + a1 c2 b2 d3 + a1 a2 + a3 c1 c2 + a3 c1; 1. ReplaceAll + Alternatives + Complement + Variables: ClearAll[f1] f1 = # /. Alternatives @@ Complement[Variables @ #, {##2}] -> 0 &; Examples: f1[input, a1, a2] a1 a2 f1[input, a1, b2] 100 a1 b2 f1[input, a3, c1, c2] a3 c1 + a3 c1 c2 2. ReplaceAll + Alternatives +...


1

You may use Variables with DeleteCases. With input = a1 a2 b1 b2 c2 c3 + 100 a1 b2 + a1 c2 b2 d3 + a1 a2 + a3 c1 c2 + a3 c1; Then f[expr_, vars__] := expr /. DeleteCases[Thread[Variables[expr] -> 0], Alternatives @@ {vars} -> 0] and f[input, a1, a2] a1 a2 f[input, a1, b2] 100 a1 b2 f[input, a3, c1, c2] a3 c1 + a3 c1 c2 Hope this helps.


2

<...> when the current context is dumped, all one may have is the printout of the table left of the original calculation, and if that takes 24 h to calculate, one would have the problem of translating a table into a vector whose origin is difficult to resurrect, in order to use it for further processing. That is the context I am most interested in. If ...


5

Clear["Global`*"] TableForm should only be used for display. Assign a name to the input to TableForm and take the column that you want from the input. SeedRandom[1234]; (mat = RandomReal[1, {9, 3}]) // TableForm For the second column mat[[All, 2]] {* {0.521964, 0.0116446, 0.479332, 0.984993, 0.884729, 0.91956, 0.587943, \ 0.696159, 0.632741} *} ...


4

Using sample data TableForm[RandomReal[{0, 1}, {5, 3}]] Select middle column, Copy & Paste. Add ; (optional), and evaluate, followed by a = Flatten@% This should set the middle column to a with the original precision.


0

You could take the column with arrayName[[3]] or arrayName[[;;,3]] (if it is column three; the ;; is Span and captures all of that dimension) and export it to a file with Export[pathAndName.xlsx,arrayname[[appropriate designation]] to open it in Excel and copy from there.


5

lists = {{a, b, c, d}, {i, j, k}, {v, w, x, y, z}}; pairs = Join @@ Tuples /@ Subsets[lists, {2}] (* {{a, i}, {a, j}, {a, k}, {b, i}, {b, j}, {b, k}, {c, i}, {c, j}, {c, k}, {d, i}, {d, j}, {d, k}, {a, v}, {a, w}, {a, x}, {a, y}, {a, z}, {b, v}, {b, w}, {b, x}, {b, y}, {b, z}, {c, v}, {c, w}, {c, x}, {c, y}, {c, z}, {d, v}, {d,...


3

Try A={a,b,c,d}; B={i,j,k}; cC={v,w,x,y,z};(*C is a predefined Mathematica name*) Join[Tuples[{A,B}],Tuples[{A,cC}], Tuples[{B,A}],Tuples[{B,cC}], Tuples[{cC,A}],Tuples[{cC,B}]]


1

I more or less follow your code. fn is the list of files of type tsv. fn = FileNames["*.tsv"]; sidata = Import[fn[[1]], {"Data", All, {1, 2}}]; ListPlot[sidata[[All, {1, 2}]], PlotRange -> {{2.5*10^-11, 4*10^-11}, {-5000, 10000}}, AxesOrigin -> {2.5*10^-11, -2000}] This is how I would find the peaks and get the intervals around ...


5

Using Format, Interpretation, and Orderless: Attributes[S] = {Orderless}; Format[e : S[args___]] := Interpretation[Subscript[s, Row@{args}], e] S[1, 2, 4, 3] S[1, 2, 4, 3] // InputForm (* S[1, 2, 4, 3] *) The use of Interpretation ensures that you can still use the expression when copy-pasting it (see the last example). The Orderless attribute does the ...


2

This can be done with a pure function, like this: ClearAll[S] S = Subscript[s, Row[{##} // Flatten // Sort, " "]] &; S[{1, 2, 3, 4}] S[1, 3, 2] Notice the use of ## in the above to refer to the function arguments. If you don't like so much space between the subscripts, use ClearAll[S] S = Subscript[s, Row[{##} // Flatten // Sort]] &;


0

First, look at https://mathematica.stackexchange.com/questions/187654/how-to-build-a-templatebox-with-dynamic-length-gridbox[templatebox-with-dynamic-length-gridbox][1] since similar questions already have answers My solution (adopted from more general context) is below. With little more adaptation the output even can be copied, edited and reused, assuming ...


0

If you want an input to be a List then e.g.: S[list_] := Subscript[S, StringDelete[ToString[Sort[list]], {",", " ","{", "}"}]] If a Sequence then e.g.: R[seq__] := Subscript[R, StringDelete[ToString[{seq}], {",", " ", "{", "}"}]] I'm sure there are other (better) ways, but ...


2

The following takes around 10 seconds for n=8 on my laptop: (* the input list of lists *) n = 8; lists = Select[DuplicateFreeQ@*Catenate]@Subsets[Subsets[Range@n, {2}], {n/2}]; (* return the elements of list that are "compatible" with l*) comp[l_, list_] := Select[DisjointQ[#, l] &]@list[[FirstPosition[list, l][[1]] + 1 ;;]] (* recursively ...


1

Use integer constraints, restrict the integers to [1,length] of arr, and use IntegerQ to prevent symbolic evaluation of the objective. This will perform well up to a certain point beyond which you'll need to look at other techniques like integer programming, or other kinds of optimization like ResourceFunction["AntColonyOptimization"] Remove["...


2

So you want c1,c2,c3 to be elements of arr. And they don't have to be distinct elements. That makes me think Tuples. And you want to find the smallest value of someFunc given those three elements. That makes me think SortBy. And you want to know what c1,c2,c3 are and the value of someFunc given those three values. arr = {5, 10, 7, 101}; someFunc[c1_,c2_,c3_]:...


2

If neither the order of the classes nor the elements within each class matters: classes = Reap[NestWhile[Complement[#, Sow[MatrixPermutations[First[#]] ⋂ #]] &, t, # =!= {} &]][[2, 1]]; The order of GatherBy[t, MatrixPermutations] can still be restored: With[{order = Sort /@ SortBy[Replace[classes, PositionIndex[t][[All, 1]], {2}], Min]}, ...


7

Here's an approach that I believe is equivalent to NonDairyNeutrino's answer, but repackaged to use SatisfiabilityInstances instead: listPartitions[l_, len_] := Module[{z = Table[Unique["z"], Length[l]], intersecting, instances}, intersecting = Pick[Subsets[z,{2}], IntersectingQ@@@Subsets[l, {2}]]; instances = SatisfiabilityInstances[ ...


8

TL;DR We can think of each set as a vertex in a graph and the edges as showing whether or not the sets are disjoint, then finding all the maximum cliques. lists = {{1, 2}, {1, 6}, {2, 3}, {2, 5}, {3, 4}, {3, 6}, {4, 5}, {5, 6}}; maximumDisjointSubcollections[collection_] := With[ {graph = UndirectedEdge @@@ Select[Subsets[collection, {2}], Apply@DisjointQ] ...


7

lists = {{1, 2}, {1, 6}, {2, 3}, {2, 5}, {3, 4}, {3, 6}, {4, 5}, {5, 6}}; Select[DuplicateFreeQ@*Catenate]@Subsets@lists (* {{}, {{1, 2}}, {{1, 6}}, {{2, 3}}, {{2, 5}}, {{3, 4}}, {{3, 6}}, {{4, 5}}, {{5, 6}}, {{1, 2}, {3, 4}}, {{1, 2}, {3, 6}}, {{1, 2}, {4, 5}}, {{1, 2}, {5, 6}}, {{1, 6}, {2, 3}}, {{1, 6}, {2, 5}}, {{1, 6}, {3, 4}}, {{1, 6}, {4, 5}}, {{2, 3}...


3

twRule=Thread[TwoWayRule @@ Partition[#, 2]]&; Splice @* twRule /@ a {1 <-> 7, 2 <-> 8, 3 <-> 6, 4 <-> 7}


7

Similar to @BobHanlon's suggestion in the comments: a = {{1, 2, 7, 8}, {3, 4, 6, 7}}; Splice@{# <-> #3, #2 <-> #4} & @@@ a (* {1 <-> 7, 2 <-> 8, 3 <-> 6, 4 <-> 7} *) The difference is the use of Splice instead of Flatten, and the use of Apply at level 1 (@@@) to be able to write #2 instead of #[[2]].


5

Map[Splice@*Thread] @ a {{1, 3}, {1, 5}, {1, 8}, {1, 9}, {2, 4}, {2, 6}, {6, 1}, {10, 1}, {10, 3}, {10, 5}, {10, 6}, {10, 7}, {10, 8}} Also Splice @* Thread /@ a (* thanks: LukasLang *) {{1, 3}, {1, 5}, {1, 8}, {1, 9}, {2, 4}, {2, 6}, {6, 1}, {10, 1}, {10, 3}, {10, 5}, {10, 6}, {10, 7}, {10, 8}} For versions older than 12.0 replace Splice with Apply[...


3

a//Table[Splice@Distribute[#[[i]],List], {i,1,Length@#}]& (* {{1, 3}, {1, 5}, {1, 8}, {1, 9}, {2, 4}, {2, 6}, {6, 1}, {10, 1}, {10, 3}, {10, 5}, {10, 6}, {10, 7}, {10, 8}} *)


8

Using Join and Thread: Join @@ Thread /@ a (* {{1, 3}, {1, 5}, {1, 8}, {1, 9}, {2, 4}, {2, 6}, {6, 1}, {10, 1}, {10, 3}, {10, 5}, {10, 6}, {10, 7}, {10, 8}} *)


4

I am sure there are at least 10 ways to do this in Mathematica. One that comes to mind now is a={{1, {3, 5, 8, 9}}, {2, {4, 6}}, {6, {1}}, {10, {1, 3, 5, 6, 7, 8}}}; Flatten[Cases[a, {x_, {y___}} :> ({x, #} & /@ {y})], 1] gives {{1, 3}, {1, 5}, {1, 8}, {1, 9}, {2, 4}, {2, 6}, {6, 1}, {10, 1}, {10, 3}, {10, 5}, {10, 6}, {10, 7}, {10, 8}}


4

The solution depends on how the empty value are represented. Furthermore, you can use any of the many Mathematica functions, such as DeleteCases, Select, Cases, Replace ... (* Empty values represented with Null *) arr = {, , , , , , , , , 2, , , , , , 1, , , , , 2, , , , , , , , , , , , , , , , , , , , , , 9, , , , , , 1}; DeleteCases[arr, Null] Select[arr, ...


0

Another solution using Replace and Condition (/;) Replace[{a_,b_,c_}/;b>c:>{a,c,b}] /@ T1 Or, using the level specification of Replace: Replace[T1, {a_,b_,c_}/;b>c:>{a,c,b}, 1]


3

This can be achieved using a convolution layer with fixed weights data = List@ ArrayFlatten[ Partition[Partition[#, 2] & /@ Partition[Range[16], 4], 2]]; MatrixForm@First@data conv = ConvolutionLayer[4, {2, 2}, "Input" -> {1, 4, 4}, "Stride" -> 2, "Weights" -> {{{{1, 0}, {0, 0}}}, {{{0, 1}, {0, 0}}}, {{...


1

Update: An alternative version which may be easier to generalize: ClearAll[delete1b, delete2b] delete1b = MapAt[DeleteCases[Alternatives @@ ({OrderlessPatternSequence @ ##} & @@@ #2)], #, {All, 2}] &; delete2b = DeleteCases[{Alternatives @@ ({OrderlessPatternSequence @ ##} & @@@ #2), {__}}] @ # &; Examples: delete1b[sol[2, 2],{{a[1], ...


2

You can do this with Ifand Map (although there might also be some other more elegant ways): If[#[[2]] > #[[3]], {#[[1]], #[[3]], #[[2]]}, #] & /@ T1 (* {{-1., 0.880673, 0.880673}, {-0.9, 0.870404, 0.870404}, {-0.8, 0.839598, 0.839598}, {-0.7, 0.788252, 0.788252}, {-0.6, 0.716371, 0.716371}, {-0.5, 0.62399, 0.62399}, {-0.4, -0.066081, 1.08857}...


4

You want to do the same thing to every item in T1, each of those items happens to be a list of 3 numbers. Wanting to do the same thing to every item in a list often suggests using Map. Map[If[#[[2]]>#[[3]],{#[[1]],#[[3]],#[[2]]},#]&,T1] accomplishes what you want. If all those # and & seem confusing then you can do the same thing another way. ...


2

I recommend that you use indexed variables Clear["Global`*"] Format[a[n_]] := Subscript[a, n]; Format[b[n_]] := Subscript[b, n]; list[1] = {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}, {-1, 1, 0}, {1, -1, 0}, {-1, -1, 0}, {-1, 0, 1}, {1, 0, -1}, {-1, 0, -1}, {0, -1, 1}, {0, 1, -1}, {0, -1, -1}}; list[2] = {{2, 0, 0}, {0, 2, 0}, {0, 0, 2}, {-2, 0, ...


5

As suggested in the comment, you should use Part and ArrayReshape: (* Create random 3D matrix with dimensions 11 x 1000 x 3 *) mat = RandomReal[1, {11, 1000, 3}]; Dimensions[mat] (* {11, 1000, 3} *) mat2 = mat[[All, 11 ;;, All]]; Dimensions[mat2] (* {11, 990, 3} *) mat3 = ArrayFlatten[mat2, 1]; Dimensions[mat3] (* {10890, 3} *)


0

Copying over your code data = {{1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, ...


2

KeyValueMap[{colnames[[#]], ## & @@ #2} &] @ GroupBy[Thread[rownames -> (PositionIndex[#][1] & /@ data)], Last -> First] {{{c1}, S0}, {{c6}, S1, S8}, {{c12}, S2, S3, S4}, {{c5, c9, c10, c11, c12}, S5, S6, S7}} You can also do: Values @ GroupBy[Thread[rownames -> (PositionIndex[#][1] & /@ data)], Last, {colnames[[...


2

Clear["Global`*"] ψ = Sqrt[2] - 1; ϵ = 0.001; I have used a smaller value of w to reduce the time required to evaluate. After you have finalized the code, increase w to whatever required value. w = 4000; To improve efficiency, use memorization for f and g2 f[ω_] := f[ω] = N[Mean[ Select[ Flatten[ Table[(Ceiling[n (ψ - ϵ)] + ...


2

Wasteful but general code that uses the numbers $1\ldots n$ instead of variables $\{a,b,c,\ldots\}$: f[n_ /; n >= 2 && EvenQ[n]] := Select[Subsets[Subsets[Range[n], {2}], {n/2}], DuplicateFreeQ@*Flatten] f[2] (* {{{1, 2}}} *) f[4] (* {{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}} *) f[6] (* {{{1,...


3

As I have mentioned already in the comment, the main problem lies in the fact that there is no unique way to define a concave region only by providing the interior points. That is why ListDensityPlot automatically creates a convex hull of your points and uses this as a plotting region. You can, however, create a concave hull. We can use code from this answer ...


1

There are already several nice solutions published here. Let me put also my five cents. Let expr = (-I x + a + b*I)*(I x + a - b*I) be our expression. I often use the function to take the desired factor out of the parentheses: factor[expr_, fact_, funExpr_ : Expand, funFact_ : Identity] := Module[{a = fact, b = expr/fact}, funFact[Evaluate[a]]*funExpr[...


1

substituting and inverse-substituting ((I*x + a) (I*x + b) /. {a -> I ai, b -> I bi} // Factor) /. {ai -> -I a, bi -> I b} (*-((-I a + x) (I b + x))*) works too


3

sol = SolveAlways[(I*x + a) (I*x + b) == e (x + I*c) (x + I*d), x] (* {{a -> -c, b -> -d, e -> -1}, {a -> -d, b -> -c, e -> -1}} *) e (x + I*c) (x + I*d) /. sol (* {-(I c + x) (I d + x), -(I c + x) (I d + x)} *)


Top 50 recent answers are included