Tag Info

New answers tagged

2

Mathematica 10 introduced GroupBy which does exactly what you want: a = GroupBy[Range@10, Mod[#, 3] &] <|1 -> {1, 4, 7, 10}, 2 -> {2, 5, 8}, 0 -> {3, 6, 9}|> The result is an Association which among other things can be used for replacement: foo[2, bar[0, 1]] /. a foo[{2, 5, 8}, bar[{3, 6, 9}, {1, 4, 7, 10}]] Also: a[2] ...


2

For data that is not already grouped by the first element: dat2 = {{baz, 16}, {foo, 65}, {baz, 41}, {bar, 88}, {foo, 2}, {bar, 96}, {foo, 20}, {bar, 19}, {foo, 36}, {baz, 90}}; GroupBy (introduced in version 10) offers a concise syntax: GroupBy[dat2, First -> Last, Total] <|baz -> 147, foo -> 123, bar -> 203|> The result ...


0

Thanks for updating your Question. With the new, clearer example I believe I can see the issue. Analysis The first method uses evenper on Symbolic values that are in canonical order: r1 = evenper[{a, b, c, d}] {{a, b, c, d}, {a, c, d, b}, {a, d, b, c}, {b, a, d, c}, {b, c, a, d}, {b, d, c, a}, {c, a, b, d}, {c, b, d, a}, {c, d, a, b}, {d, a, c, b}, ...


1

I am not familiar with the specific output format you need but I think I can show you how to proceed. dat = Import["ExampleData/caffeine.xyz", {{"VertexTypes", "VertexCoordinates"}}]; dat2 = {#[[1, 1]], #[[All, 2]]} & /@ GatherBy[dat\[Transpose], First]; dat3 = {#, Length@#2, #2} & @@@ dat2; dat3 has this format: dat3 // TableForm $\left( ...


0

Perhaps stream = {1, 2, 3, 4, 5, 6, 7, 8, 9, 8, 7, 6, 5, 4, 3, 2, 1}; Now I'm trying to make selections and calculations "that depend on the previous value": Cases[Partition[stream, 2, 1], {a_, b_} /; b < a && a >= 5 :> a b] {72, 56, 42, 30, 20}


2

Many ways (for example MapIndexed[]) but you may have some fun using for example @Leonid's implementation of FoldWhile[] here stream = {0, 0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 8, 7, 6, 5, 4, 3, 2, 1}; FoldWhile[#2 &, ! (#1 <= 5 && #2 > 5) &, 0, stream] (* 5 *) Here is how it works: Grid @@@ Reap@ FoldWhile[(Sow[{"Current", #2, " ", ...


2

Perhaps stream = {1, 2, 3, 4, 5, 6, 7, 8, 9, 8, 7, 6, 5, 4, 3, 2, 1}; LengthWhile[stream, # <= 5 &] (* 5 *) TakeWhile[stream, # <= 5 &] (* {1,2,3,4,5} *) or First[Split[stream , #1 < 5 &]] (* {1,2,3,4,5} *) Length@First@Split[stream , #1 < 5 &] (* 5 *) or i = 1; While[stream[[i]] < 5, i++]; i (* 5 *) i = 1; ...


0

I am not sure what it is you are trying to do, but presumably list = foo /@ RotateRight[list] is something like what you want?! The most general solution involves the function ListConvolve[] which you should look up (the documentation gives you better examples than the ones I can come up with without knowing what it is you want to do). You want the ...


5

The sorting (ordering) done by Union is different for different forms of expressions, e.g., analytic versus numeric expressions for a number. Union[{2., (Sqrt[5] + 1)/2}] {2., 1/2 (1 + Sqrt[5])} % // N {2., 1.61803} Union[{2., (Sqrt[5] + 1.0)/2}] {1.61803, 2.} SortBy[{2., (Sqrt[5] + 1)/2}, N] {1/2 (1 + Sqrt[5]), 2.}


1

The new JoinAcross essentially gives you a SQL join if you convert the lists to Key-> Value pairs. lists = {list1, list2, list3}; kys = Map[StringReplace[#, {__ ~~ "Col1" -> "KeyCol"}] &, Table[StringJoin["Lst", ToString@iLst, "Col", ToString@kCol], {iLst, Length@lists}, {jRow, Length@lists[[iLst]]}, {kCol, Length@lists[[iLst, ...


3

Approach using v10 functions: CustomMerge1[lists__] := Module[{assocList, keys, vals, res}, assocList = GroupBy[#, First -> Rest] & /@ {lists}; keys = Sort@DeleteDuplicates[Flatten[Keys /@ assocList]]; res = Table[ vals = #[k] /. Missing[___] -> {{Missing[], Missing[]}} & /@ assocList; Flatten /@ Tuples[{{k}, ...


3

First augment each list to fill in any Missing items. Then work through fulllist2 to insert matching items from fulllist1. To complete the extra credit part of your question you could use a similar method to join corresponding elements of your list1 and list3 before before or after doing the augmentation and use this result in the join process with ...


0

(* combine[expr_, l_] := With[{matches = Select[l, First[#] == First[expr] &]}, If[Length[matches] == 0, {Append[expr, Missing[]]}, Map[Join[expr, Rest[#]] &, matches]]] *) combine[expr_, l_] := With[{matches = Select[l, First[#] == First[expr] &], len = Length[l[[1]]] - 1}, If[Length[matches] == ...


2

You can use Intersection or Union with the option SameTest. For example, solutions for all 3 equations: Intersection[sol1, sol2, sol3, SameTest -> (Abs[#[[1]] - #2[[1]]] < 0.01 && Abs[#[[2]] - #2[[2]]] < 0.0001 &)] (* {{1.13627*10^-10, 0.517141}, {1822.16, 0.130514}} *) Or if you want to gather almost equal solutions: ...


0

Using the data in your comment: list = {{1, 190}, {2, 80}, {3, 50}, {1, 19}, {3, 60}, {2, 85}, {4, 33}} I'd use: With[{gb = GatherBy[list, First]}, Transpose[{gb[[All, 1, 1]], Plus @@@ (gb[[All, All, 2]])}] ] {{1, 209}, {2, 165}, {3, 110}, {4, 33}} Expanding to your data list, since it has 3 levels, we can use Join to get what we want. With[{gb ...


3

You can use ImplicitRegion to define this type of set. Define your set. \[ScriptCapitalR] = ImplicitRegion[r \[Element] Rationals && r^2 < 2, {r}]; Check that this works correctly on some rational and some irrational points. Element[#, \[ScriptCapitalR]] & /@ {{1}, {4/3}, {3/2}, {\[Pi]}, {E}} (* {True, True, False, False, False} *) ...


3

You can also use Dot: sundat.{{2., 0}, {0, .5}} (* {{560., 0.041}, {561., 0.0495}, {7990., 0.00435}, {8000., 0.00434}} *)


1

Although I prefer kguler's double Transpose you could also use Inner: sundat = {{280., 0.082}, {280.5, 0.099}, {3995., 0.0087}, {4000., 0.00868}}; Inner[Times, sundat, {2., .5}, List] {{560., 0.041}, {561., 0.0495}, {7990., 0.00435}, {8000., 0.00434}} Or leveraging Simon's solution from: How can I make threading more flexible? smartThread[sundat ...


4

sundat = {{280., 0.082}, {280.5, 0.099}, {3995., 0.0087}, {4000., 0.00868}}; conversionfactors = {2., .5}; data2 = Transpose[conversionfactors Transpose[sundat]] or data2 = conversionfactors # & /@ sundat both give (* {{560.,0.041},{561.,0.0495},{7990.,0.00435},{8000.,0.00434}} *)


3

Here is a rough stab at it that should help you get started: f[x_List] := Module[{n, lis = Range @ Length @ x, len = Length @ x, d = x}, Do[(n = RandomChoice[lis, 2]; If[d[[First @ n]] > 0, d[[First @ n]] -= 1; d[[Last @ n]] += 1]), {len}]; d] Now we generate our list of ones: list = ConstantArray[1, 400]; Then: res = f @ list {0, 2, 2, ...


0

This is certainly not as elegant as others and also I have used subsets twice which seems redundant. partyResult[list_] := Module[{}, allParties = DeleteCases[Subsets[Cases[list, {a_, b_} -> a]], {}]; allvotes = DeleteCases[Subsets[Cases[list, {a_, b_} -> b]], {}]; allparSum = Cases[Total[allvotes, {2}], _?(# >= 141 &)]; allsumpos = ...


4

result = {{"a", 120}, {"b", 80}, {"c", 50}, {"d", 30}}; {players, worths} = Transpose[result]; indices = Subsets[Range@Length@players, {1, Infinity}]; majoritycoalitions = Pick[indices, Total[worths[[#]]] >= 141 & /@ indices]; table = SortBy[{Row@players[[#]], Total[worths[[#]]], Total[worths[[#]]] - 141} & /@ majoritycoalitions, -Last[#] ...


5

Here is a variation of Mr.Wizard's answer using Pick and making it into a function. Here, nP is the number of parties involved. coalitionGames[result_, nP_Integer] := With[{n = Last @ Total[result] / 2 + 1, lis = Subsets[result, {1, nP - 1}] ~Total~ {2}, Pick[lis, UnitStep @ (n - lis[[All, 2]]), 0]] Then: SortBy[coalitionGames[result, 4], -#[[2]] ...


7

My straightforward solution: TakeWhile[Rest@Reverse@SortBy[{{} <> #, Total@#2} & @@@ Transpose /@ Subsets[result, {1, ∞}], Last], #[[2]] > n &] // Grid Let me do it as fast as possible. I know that you ask an elegant solution but tuning the efficiency is also interesting. One can note that Total and StringJoin works slow on ...


5

Perhaps I am overlooking something but this seems like a straightforward subset sum problem, and since you appear to accept the computational and memory complexity of generating a power set it can be implemented simply: Select[ Subsets[result][[2 ;; -2]] ~Total~ {2}, #[[2]] >= n & ] {{"a" + "b", 200}, {"a" + "c", 170}, {"a" + "d", 150}, {"a" + ...


1

str={"1,2,3,5,10,12,13,17,26,30,32,41,42,43,113,115,121,125"} ToExpression[StringCases[str[[1]], DigitCharacter ..]] ToExpression[StringSplit[str[[1]], ","]] ToExpression["{" ~~ str[[1]] ~~ "}"]


0

Let me join this old thread. One can set the default element to 1. and inverse the array as you want HoldPattern@setDef[SparseArray@s___, x_] := SparseArray[#, #2, x, #4] &@s; V == DiagonalMatrix[1/setDef[Diagonal[A], 1.]] (* True *) Timings: Do[DiagonalMatrix@SparseArray[1/Normal[Diagonal[A]]], {1000}] // AbsoluteTiming (* {12.273275, Null} *) ...


3

ClearAll[randomSymMat]; randomSymMat = Module[{mat = RandomVariate[#, {#2, #2}], upper, diag}, upper = UpperTriangularize[mat, 1]; diag = DiagonalMatrix[Diagonal@mat]; diag + upper + Transpose[upper]] &; dist = NormalDistribution[3, 5]; First[AbsoluteTiming[res = randomSymMat[dist, 1000]]] (* 0.065046 *) res == Transpose[res] (* True *)


4

For the test case in @rhermans' answer, an approach based on Gather is more than twice as fast as Tally: ClearAll[tllyF]; tllyF = {#[[1]], Length@#} & /@ Gather[#[[All, 1]]] &; data1 = Table[{RandomChoice[{AA, BB, CC, DD}], RandomInteger[10], RandomInteger[10]}, {1000000}]; First[Timing[res0 = Tally[data1[[All, 1]]]]] (* 0.234375 *) ...


4

This should be faster than mapping First: Tally[ First @ Transpose[data]] {{AA, 2}, {CC, 5}, {DD, 3}} One can use also new functions (in version 10) like Count, CountsBy and GroupBy to get similar results, e.g. : CountsBy[ data, First] <|AA -> 2, CC -> 5, DD -> 3|> If the format is crucial we can do this List @@@ Normal @ ...


8

Without a Do loop Tally[First /@ data] {{AA, 2}, {CC, 5}, {DD, 3}} or for speed Tally[data[[All, 1]]] {{AA, 2}, {CC, 5}, {DD, 3}} EDIT: Testing for a bigger set of data: data2 = Table[{RandomChoice[{AA, BB, CC, DD}], RandomInteger[10],RandomInteger[10]}, {10000000}]; We get: First@Timing@Tally[data2[[All, 1]]] 2.683217 ...


1

ClearAll[f1]; f1 = RotateLeft[PadLeft[Internal`PartitionRagged[Range[# (#-1)/2],Range[#-1, 1, -1]], {#, #}]] &; Row[MatrixForm /@ {m1 = f1[4], Transpose[m1], m1 + Transpose[m1]}] ClearAll[f2]; f2 = With[{m = Solve[{a (a - 1)/2 == Length@#, a > 0}, a, Integers][[1, 1, 2]]}, RotateLeft[PadLeft[Internal`PartitionRagged[#, Reverse@Range[m - 1]], ...


2

My trial: Define the function: upperTriangular[expr_?VectorQ, n_Integer] /; Length@expr == (n (n - 1))/2 := Join[Table[0, {n - Length@#}], #] & /@ (Append[ Complement[#2, #1] & @@@ Partition[ Prepend[Take[expr, #] & /@ Accumulate@Reverse@Range[n - 1], {}],2, 1], {}]) Test expr1=CharacterRange["a", "u"]; upperTriangular[expr, ...


2

keys = Alternatives @@ Intersection @@ Map[First, {list1, list2, list3}, {2}] res = Flatten /@ Transpose[{ Cases[list1, {keys, __}], Last /@ Cases[list2, {keys, __}], Rest /@ Cases[list3, {keys, __}]}] {{2, b, bb, 0.2, 20, 200, 2000}, {5, e, ee, 0.5, 50, 500, 5000}, {6, f, ff, 0.6, 60, 600, 6000}, {10, j, jj, 0.1, 100, 1000, 10000}} ...


2

Version 10 offers some nice notation to perform the essential work: {list1, list2, list3} // Map@GroupBy[First->Rest] // KeyIntersection // Merge@Flatten (* <| 2 -> {b,bb,0.2,20,200,2000} , 5 -> {e,ee,0.5,50,500,5000} , 6 -> {f,ff,0.6,60,600,6000} , 10-> {j,jj,0.1,100,1000,10000} |> *) The result is an association, ...


4

Flatten[{#, Rest/@{##2}}]&@@@(Pick[#, Length@# > 2]&/@ GatherBy[Join[list1, list2, list3], First]) (* {{2, b, bb, 0.2, 20, 200, 2000}, {5, e, ee, 0.5, 50, 500, 5000}, {6, f, ff, 0.6, 60, 600, 6000}, {10, j, jj, 0.1, 100, 1000, 10000}} *)


2

Consider: a = {{x0, y0, z0}, {x1, y1, z1}, {xn, yn, zn}}; b = {{x0, y0, Z0}, {x1, y1, Z1}, {xn, yn, Zn}}; (* note capital Z *) c = a; c[[All, 3]] -= b[[All, 3]]; c {{x0, y0, z0 - Z0}, {x1, y1, z1 - Z1}, {xn, yn, zn - Zn}} See: Elegant operations on matrix rows and columns You can use a Module if you wish to make this a self-contained function. ...


4

lis1 = {{x0, y0, z01}, {x1, y1, z11}, {xn, yn, zn1}}; lis2 = {{x0, y0, z02}, {x1, y1, z12}, {xn, yn, zn2}}; If you first define this function: f[{x_, y_, z_}, {x_, y_, u_}] := {x, y, z - u} You can then easily do: f @@@ Transpose[{lis1, lis2}] {{x0, y0, z01 - z02}, {x1, y1, z11 - z12}, {xn, yn, zn1 - zn2}}


5

As far as I can tell from the problem description you can simply shuffle the list as many times as needed, since duplicate permutations are allowed: (* thanks ybeltukov for tweaks *) f[n_, m_] := Table[RandomSample @ #, {m}] & @ Range @ n Example: f[5, 3] {{5, 3, 1, 4, 2}, {3, 4, 2, 5, 1}, {2, 1, 5, 3, 4}}


4

mrandomperms[n_, m_]:= Table[PermutationList[RandomPermutation[n]], {m}] Was my initial answer, but, as pointed out by Mr. Wizard, PermutationList should be given $n$ as a second argument, since otherwise it will give the wrong answer if $n$ is a fixed point. Also, Table can be eliminated for elegance and efficiency, leaving one with: mrandomperms[n_, ...


3

{a, ##} & @@@ {{b, c}, {d, e, f}} (* {{a, b, c}, {a, d, e, f}} *)


1

Could be done with: l = {{b, c}, {d, e, f}}; Join[{a}, #] & /@ l {{a, b, c}, {a, d, e, f}}


2

This will do what you asked for, but -- as you can see from the plot -- your three experiments don't plot well together because the hex experiment values are incommensurable with the oct and butane experiment values. myNIR = {{ {, 2, 4, 6, 8, 9}, {hex, 342432, 435345, 564564, 56756, 9945}, {oct, 23, 356, 565, 304, 564}, {butane, 55, 67, 76, 44, 7} }} ...


0

You want to solve once and then replace the a, b, c variables in the general solution with each triple of values. The import of a .txt file as a "Table" should end up with a table like (could be integers, reals, or a combination) SeedRandom[8]; data = RandomInteger[{-5, 5}, {10, 3}]; Convert each triple to substitution rules: substitutionRules = ...


0

... so, here is why I disagree with you, Mr. Wizard. If you use an indexed object, which is actually a function definition (like varFunc[ii] instead of ToExpression["var" <> ToString[ii]]) then there is no value associated with varFunc[ii]. Yes, it is true that a long list can then be accessed fast. Unfortunately in that form it is practically useless ...


8

Update This should have been obvious to me from the start but of course Part does not hold its first argument. This means that the entire list of Symbols must be checked against the changing value of the Do iterator, which I think easily explains the slow-down observed. Consider: x = Table[Unique["var"], {100000}]; Do[x, {i, 10000}] // AbsoluteTiming // ...


2

I would use a slightly different derivation but the concept is basically the same. Here $I_q:=4\pi \int_0^{\infty}P(r)\frac{\sin qr}{qr}dr$. Hence $qI_q=4\pi \int_0^{\infty}P(r)\frac{\sin qr}{r}dr$. The derivative of $qI_q$ with respect to $q$ is \begin{equation} \frac{d}{dq}(qI_q)=4\pi\int_{0}^{\infty}P(r)\cos(qr)\,dr. \end{equation} This relation can be ...


0

This looks like a bug, but presumably a workaround is to use a hash table. That is, in @Szabolcs's code, change the first line to: Table[arr[i] = RandomInteger[10, 5].x^Range[5], {i, 1, 1000000}]; The second line seems to work reasonably quickly.


3

I don't know if it is possible to do much to improve this for an Association object. If the conversion to a list of keys and values can be externalized this numeric selection can be performed quite quickly by using UnitStep, and SparseArray Properties: (* hash randomized to demonstrate order independence *) hash = Association[RandomSample @ Table[i -> ...


2

You can create a table of the individual solutions like this: solutions = Table[ X /. Solve[(MM[[K + 2]])*X + (MM[[K + 2]]*R[[K + 2]]) == 0, X][[1]], {K, 9}] Then use Accumulate to give the final desired result Accumulate[solutions]



Top 50 recent answers are included