New answers tagged

4

FindRepeat meets your need perfectly. FindRepeat[{19, 6, 19, 6, 19, 6, 19, 6, 19, 6, 19, 6}] {19, 6} FindRepeat[{73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7}] {73, 7, 4} FindRepeat[{73, 7, 4, 7, 2, 6, 7, 2, 7, 73, 9, 17, 7, 7}] {73, 7, 4, 7, 2, 6, 7, 2, 7, 73, 9, 17, 7, 7}


5

For this use case, I would encourage you to use Map and Replace rather than Cases, since you can use multiple rules for the extraction: Map[Replace[{{___, {}} :> Null, {___, {x_}} :> x}], dat1] (* {Null, 1, 2} *) As an alternative, you can use Replace with a level spec: Replace[dat1, {{___, {}} :> Null, {___, {x_}} :> x}, 1] (* {Null, 1, 2} *)


6

Here I treat the contents of the empty element as Null and I assume either 1 element in the nested list or no element: Cases[dat1, {x_ : Null} :> x, 2] (* returns: {Null, 1, 2} *)


4

n = 4; p = 2; m = 3; aa = Array[Subscript[a, ##] &, {n, m}]; bb = Array[Subscript[b, ##] &, {p, m}]; Join cc = Join[aa, bb]; TeXForm @ MatrixForm @ aa $$\left( \begin{array}{ccc} a_{1,1} & a_{1,2} & a_{1,3} \\ a_{2,1} & a_{2,2} & a_{2,3} \\ a_{3,1} & a_{3,2} & a_{3,3} \\ a_{4,1} & a_{4,2} & a_{4,3} \\ \end{...


2

appending the ith column of A and ith column of B A = {{1, 2, 3}, {4, 5, 6}, {7, 8, 9}}; B = {{10, 11, 12}, {14, 15, 16}}; ArrayFlatten[{{A}, {B}}]


7

Q1. Use the option Joined -> False: DateListPlot[data, Joined -> False] Q2. Use the option DateTicksFormat "to put the AM or PM values of the times in the x-axis": DateListPlot[data, Joined -> False, DateTicksFormat -> {"Hour", ":", "Minute", "AMPM"}] Q3. Specify the date ticks using DateRange ...


4

This method is a modified version of the Game of Life example from the Neat Examples section of SparseArray. I changed the cellupdate function so that a cell is born if it has 1 or 2 neighbors, and stays alive if it has 3 neighbors. The modified update function tests only the cells with common edges. ClearAll[cellupdate,update] SetAttributes[cellupdate,...


2

Select[Select[c=Sort[lis],#!=Last[c] &],#==Last[Select[c,#!=Last[c] &]]&]


1

Description Program : The code is using 3 modules after the Intialisation: 1- Torus module 2- Rules module: 3- Excution Module: n generation module using Torus and Rules modules. Initialisations : n = 16; Init = {{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0,...


0

Representing n generations: n=16, and the workspace imposed in the puzzle as a (11 $\times$ 11) matrix such that all the live cells are represented by 1 and the dead ones by 0. Also in this particular case for the example we have: "the rules 01100;00010 mean that a cell is born if it has one or two neighbors, and stays alive if it has three. If we ...


3

This is a little involved but I hope you can follow this step-by-step: (* load the data *) Evaluate[ToExpression@Import["data3d.txt"]]; (* get the centroid and the KLDecomposition *) kld = KarhunenLoeveDecomposition[Transpose[Data3D]]; (* get the transformed points, new basis, and new centroid *) transformed = Transpose[kld[[1]]]; basis = kld[[2]]...


4

# & @@@ Cases[t1, _Power, All] {2, 3, 5, 6, 7, 31, 10, 11, 17}


4

Another way Cases[t1, Sqrt[x_] :> x, Infinity] (* {2, 3, 5, 6, 7, 31, 10, 11, 17} *)


3

Assuming all expressions are either product of a square root or square root on its own: First /@ Cases[t1, Sqrt[_], Infinity] (* result: {2, 3, 5, 6, 7, 31, 10, 11, 17} *)


1

First set up your a1...a6 however you want them in a Manipulate as below. Note how output is set to the result of the ContourPlot3D: Manipulate[ With[{ε=10^-6, c1=Tan[a1], c2=Tan[a2], c3=Tan[a3], c4=Tan[a4], c5=Tan[a5], c6=Tan[a6]}, output = ContourPlot3D[ Evaluate[((c6 Sin[3 x]) Sin[2 y]) Sin[z] + ((c4 Sin[2 x]) Sin[3 y]) Sin[z] + ((c5 ...


1

Edit To answer your question I will use the following test data because the my answer doesn't have any dependency of the variable names or the data values that appear in your code. It only depends of the structure of the data. data = {#1, {#2, #3}} & @@ MapThread[Rule, {{a, b, c}, Range[3]}] {a -> 1, {b -> 2, c -> 3}} All you need to do is map ...


0

Let: list = {a, {b,c}}; This will give you element "a": list[[1]] This will give you elements {b,c}: list[[2]] This will give you "b" straight away: list[[2, 1]]


4

I think I've found a method that could work. The idea is to make a MeshRegion out of your points and then find all of the polygons with similar face normal vectors. The normal vectors can be computed with MeshCellNormals as described in this answer: mesh = ConvexHullMesh[Data3D]; poly = MeshPrimitives[ConvexHullMesh[Data3D], 2]; clusters = ...


1

Clear["Global`*"] y[x_, r_] := -Tan[r]*x; {rmin, rmax} = {1.4, 1.57}; ymax = 60; Using graphics primitives with Graphics3D gr = Graphics3D[{Thick, {ColorData["Rainbow"][(#[[1, 2]] - rmin)/(rmax - rmin)], Line[#]} & /@ Table[{x, r, y[x, r]}, {r, rmin, rmax, 0.01}, {x, -2, 0, 0.05}]}, BoxRatios -> {1, 1, 1/2}, Axes -&...


3

This is straight-forward to do with assignment: m = {{1, 2, 3}, {4, 5, 6}, {7, 8, 9}}; m[[1 ;; 2, 1 ;; 2]] = {{3, 2}, {1, 2}}; m // MatrixForm We can get the list of all matrices like this: newMatrices = ConstantArray[m, Length[helios]]; newMatrices[[All, 1 ;; 2, 1 ;; 2]] = helios;


3

Edit Acting on the advice given here: Pick[#1,Replace[#1[[All,#2]],Unitize[Counts[#1[[All,#2]]]-1],{1}],1]&@@{t1,-1} Original Answer Pick[#1,#1[[All,#2]]/.Unitize[Counts[#1[[All,#2]]]-1],1]&@@{t1,-1} {{5, 5, 50}, {7, 4, 65}, {8, 1, 65}, {7, 1, 50}} For identities at position 2 (if desired): Pick[#1,#1[[All,#2]]/.Unitize[Counts[#1[[All,#2]]]-1],1]&...


6

I agree that this belongs on CrossValidated because it is about algorithms and not about Mathematica, but nevertheless I'll provide a simple, illustrative example of RANSAC: computeInliers[{pt1_, pt2_}, pts_, k_ : 1] := Module[{a, b, dist}, {a, b} = Values@FindFit[{pt1, pt2}, a + b x, {a, b}, x]; dist = RegionDistance[InfiniteLine[{pt1, pt2}]] /@ pts; ...


1

Take a smaller example with the same structure as the one in OP: k = 4; cc = Array[Subscript[c, #] &, k]; pp = Array[Subscript[p, #] &, k]; tt = Array[Subscript[t, #] &, k]; You can get your table using: tbl = (1/Most[cc - (1 - θ) tt]) Rest[pp].Rest[cc - (1 - θ) tt]; TeXForm @ tbl $\left\{\frac{p_2 \left(c_2-(1-\theta ) t_2\right)+p_3 \left(...


-2

From your code, it seems that $c=t=$cases, $p=$Prob. If so, $\theta$ is useless, since $$ \frac{c_i-(1-\theta)t_i}{c_j-(1-\theta)t_j}=\frac{c_i-(1-\theta)c_i}{c_j-(1-\theta)c_j}=\frac{\theta c_i}{\theta c_j}=\frac{c_i}{c_j} $$ Then the code for your table is simply n = Length[cases]; (* 141 *) Rest[Inner[Times, Prob, cases, List]].ConstantArray[1/Most[cases]...


6

Try Dot: Dot[as, bs - as] 270 aa = Array[Subscript[a, #] &, 4]; bb = Array[Subscript[b, #] &, 4]; Dot[aa, bb - aa] // TeXForm $a_1 \left(b_1-a_1\right)+a_2 \left(b_2-a_2\right)+a_3 \left(b_3-a_3\right)+a_4 \left(b_4-a_4\right)$


9

You asked for advice and the best advice is: Consult a statistician. If you can't afford a statistician, ask at CrossValidated. In any event you should have some reason for tossing out data. That it doesn't look like it fits isn't a good enough reason. If you have known kinds of errors in the data such as electronic glitches or the coordinates get ...


5

Using GatherBy similarly to Rohit's GroupBy solution (I even emulate his style because I find it really nice): GatherBy[t1, Last] // Select[Length[#] > 1 &] // Flatten[#, 1] & {{5, 5, 50}, {7, 1, 50}, {7, 4, 65}, {8, 1, 65}} To add a bit more novelty to the answer, I also submit these rule based solutions: ReplaceList[ SortBy[t1, Last], {___, ...


5

GroupBy[Counts[t1[[All, -1]]]@#[[-1]] > 1 &][t1]@True {{5, 5, 50}, {7, 4, 65}, {8, 1, 65}, {7, 1, 50}}


11

Preserving the order: With[{c = CountsBy[t1, Last]}, Select[t1, c[Last@#] > 1 &]]


7

If order is not important t1 // GroupBy[Last] // Select[Length[#] > 1 &] // Values (* {{{5, 5, 50}, {7, 1, 50}}, {{7, 4, 65}, {8, 1, 65}}} *)


5

Update I realized that different sets of parameters can be used: corQuartiles[d_?ListQ] := Quantile[d, {1/4, 1/2, 3/4}, {If[EvenQ[Length[d]], {1/2, 0}, {0, 1}], {0, 1}}] Test: # -> corQuartiles[#] & /@ Range /@ Range[2, 7] {{1, 2} -> {1, 3/2, 2}, {1, 2, 3} -> {1, 2, 3}, {1, 2, 3, 4} -> {3/2, 5/2, 7/2}, {1, 2, 3, 4, 5} -> {3/2, 3, 9/...


1

By the links provided by @Flinty, it seems the answer to my question should be cantor = {a_, b_} :> {{a, a + (b - a)*1/7}, {a + (b - a)*2/7, a + (b - a)*3/7}, {a + (b - a)*4/7, a + (b - a)*5/7}, {a + (b - a)*6/7, b}}; CantorRegion[n_Integer?NonNegative] := Module[{ints}, ints = Flatten[ Nest[Flatten[Map[Function[s, s /. cantor], #...


2

Sheer brute force is also an option if you need to generate lots of solutions and it's very fast. Here we randomly permute the range [1,10], saving permutations when the totals are equal: results = DeleteDuplicates@Reap[Do[ s = RandomSample[Range[10]]; If[Total[s[[1 ;; 4]]] == Total[s[[5 ;; 8]]] == s[[2]] + s[[6]] + Total[s[[9 ;; 10]]], ...


4

Map[Sort /* RotateLeft, d, {-2}] % === newd {{{"A5", "I4", "A2"}, {"A5", "I5", "A4"}}, {{"A5", "I4", "A2"}, {"A5", "I5", "A4"}}, {{"A5", "I4", "A2"}, {"A5", "I4", "A4"}}, {{&...


2

Map[ReverseSortBy[#, {StringCases["A5"], StringCases[RegularExpression["[I\d]"]]}]&,d,{2}] {{{A5, I4, A2}, {A5, I5, A4}}, {{A5, I4, A2}, {A5, I5, A4}}, {{A5, I4, A2}, {A5, I4, A4}}, {{A5, I4, A2}}, {{A5, I4, A2}}} %==newd True


6

Thread[Unevaluated@f[{1, 2, 3}, 4]] {1.946182809, 2.842898138, 3.571798651} Explanation Documentation of Thread: Thread evaluates the whole expression before threading. f[x_, y_] := x + y Thread[f[{1, 2, 3}, 4]] => Thread[{1, 2, 3} + 4] (* Evaluates *) => Thread[{5, 6, 7}] => {5, 6, 7} (* Threads... trivially *) Since + is Listable, nothing ...


4

k=2; Map[#[[k]] &, dd, {2}] {{3, 10}, {76}} Also Flatten[dd, {3}][[k]] {{3, 10}, {76}}


5

One way: d /. x : {__String} :> SortBy[x, StringReplace[#, {"A5" -> 1, "I" ~~ _ -> 2, "A" ~~ _ -> 3}] &]; % === newd True If you look at the output of StringReplace you will see remaining StringExpression heads, which is less than clean, but because they are all the same they do not affect the sort order. A ...


2

The function Numberform will do it. Try: Numberform[list,2] you should get the result you wanted. The second argument of the function is the number of digits you want.


3

Just a quick benchmark of kglr's methods in version 10.1. f1[data_] := GatherBy[data, Quotient[#, 10] &]; f2[data_] := Split[data, SameQ @@ Quotient[{##}, 10] &]; f3[data_] := Values@GroupBy[Quotient[#, 10] &]@data; f4[data_] := DeleteCases[{}]@BinLists[data, 10]; f5[data_] := SplitBy[data, Quotient[#, 10] &]; Needs["GeneralUtilities`&...


8

data = {0, 5, 5, 10, 19, 22, 23, 24, 25, 33, 34, 40, 40, 42, 53, 62, 69, 74, 91, 91}; GatherBy GatherBy[data, Quotient[#, 10] &] {{0, 5, 5}, {10, 19}, {22, 23, 24, 25}, {33, 34}, {40, 40, 42}, {53}, {62, 69}, {74}, {91, 91}} Split Split[data, SameQ @@ Quotient[{##}, 10] &] {{0, 5, 5}, {10, 19}, {22, 23, 24, 25}, {33, 34}, {40, 40, 42}, {53}, {62, ...


6

# always binds itself to the most direct &, and is equivalent to #1, so #[[1]] <= # <= #[[2]] is erroneous. TakeWhile scans from the first element of the list. You're giving every class the same list. As a result, e.g., for{10, 19}, since the first element 0 is not within this range, it immediately halts and returns {}. As an alternative, you ...


5

Index the cells: 1 * * 2 3 4 5 6 7 * * 8 9 * * 10 Define a $10\times 10$ zero-one matrix $M$, where $M_{i,j}=1$ iff number $i$ is in $j^\text{th}$ cell, and $0$ otherwise. Constraints: Every number in unique cell: $\sum_j M_{I,j}=1 \quad \forall_I$ Every cell has unique number: $\sum_i M_{i,J}=1 \quad \forall_J$ $n_j=$ (Number in $j^\text{th}$ cell) $=\...


4

This should be fast for large lists: Transpose[{Log @ #, #2} & @@ Transpose[#]] & @ list {{-4.60517, 0.037348}, {-3.50656, 0.165434}, {-2.30259, 0.263921}, {-1.20397, 0.560191}, {0., 0.968857}, {1.09861, 1.50965}, {2.30259, 2.36502}, {3.4012, 3.07659}, {4.60517, 3.73412}, {5.70378, 4.4931}, {6.90776, 5.06818}, {8.00637, 5.65423}, {9.21034, 6.00944}...


4

In addition, in v 12.0 and greater, you may use SubsetMap SubsetMap[Log, list, {All,1}] {{-4.60517, 0.037348}, {-3.50656, 0.165434}, {-2.30259, 0.263921}, {-1.20397, 0.560191}, {0., 0.968857}, {1.09861, 1.50965}, {2.30259, 2.36502}, {3.4012, 3.07659}, {4.60517, 3.73412}, {5.70378, 4.4931}, {6.90776, 5.06818}, {8.00637, 5.65423}, {9.21034, 6.00944}}


8

You may use MapAt. MapAt[Log, {All, 1}]@list {{-4.60517, 0.037348}, {-3.50656, 0.165434}, {-2.30259, 0.263921}, {-1.20397, 0.560191}, {0., 0.968857}, {1.09861, 1.50965}, {2.30259, 2.36502}, {3.4012, 3.07659}, {4.60517, 3.73412}, {5.70378, 4.4931}, {6.90776, 5.06818}, {8.00637, 5.65423}, {9.21034, 6.00944}} Hope this helps.


2

newlist=Table[{Log[list[[k]]],list[[k]]},{k,1,Length[list]}] is inelegant but will work.


3

As the list is in ascending order, maybe: 1+LengthWhile[{1, 4, 10,12,20}, # <11 &] 4 A slight variation on the FirstPosition answer of MarcoB (originally posted as a comment): FirstPosition[UnitStep[{1,4,10,12,20}-11],1] {4}


4

This question is closely related to the question Best way to insert element into an ordered list at the correct position? , where it was noted that Leonid Shifrin's bsearchMax from this answer is a fast way to solve the problem. Like flinty's answer it uses a binary search but it appears to be faster. bsearchMax[{1, 4, 10, 12, 20}, 11] 4 For a list of ...


3

A couple of slower alternatives to FirstPosition: data = {1, 4, 10, 12, 20}; Position[data, SelectFirst[data, # >= 11 &]][[1, 1]] Needs["Combinatorica`"]; Ceiling@BinarySearch[data, 11]


Top 50 recent answers are included