Tag Info

New answers tagged

4

Using the new Interpreter in ver10+ listhex = {"56", "7f", "ff"}; Interpreter["HexInteger"]@listhex (* Out {86, 127, 255} *) and this can be coupled with ToString a la Nasser The Interpreter function seems to have the undocumented(?) ability to act directly on "Ox.." format e.g. fromHexString[value_] := Interpreter["HexInteger"][value]; fromHexString ...


4

The ^^ syntax is only used for inputting literals. You want to use FromDigits, e.g. FromDigits[#, 16] & /@ {"56", "57", "58"} Note that the input numbers must be strings. 56 is a decimal number only. In order to input numbers with higher or lower bases you must use a string (i.e. "56").


0

result = ReplacePart[first, Thread[Rule[Position[first, a], t]]] ListPlot[Transpose[{t, result}]]


3

first = {1 + a, 2 + a, 3 + a, 4 + a}; t = {0, 1, 2, 3}; MapThread[#1 /. a -> #2 &, {first, t}] (* {1, 3, 5, 7}*) or #[[1]] /. a -> #[[2]] & /@ Transpose@{first, t} (* {1, 3, 5, 7}*)


2

Just a quick-and-dirty idea: pruner2b[lst_] := Module[{f}, f[_] = True; Map[If[f[#[[1]]] && f[#[[2]]], (f[#] = False)&/@#; #,Unevaluated@Sequence[]] &, lst]] This returns precisely the same results as Kguler's DeleteDuplicates solution (I've not proofed that this is "optimal", in the sense of maximizing ...


5

Maybe lst = {{20, 11}, {17, 20}, {26, 5}, {14, 9}, {18, 13}, {19, 11}}; DeleteDuplicates[lst, Intersection[##] != {} &] (* {{20, 11}, {26, 5}, {14, 9}, {18, 13}} *) lst2 = {{20, 11}, {17, 20}, {26, 13}, {14, 26}, {11, 20}, {18, 13}, {19, 11}}; DeleteDuplicates[lst2, Intersection[##] != {} &] (* {{20, 11}, {26, 13}} *)


2

Using the compressed list you supplied: list=Uncompress@"<...>"; Length@list (* 432 *) Length@(dedup = DeleteDuplicatesBy[list, First]) (* 54 *) Here is the result: dedup=Uncompress@"1:eJytmEFuwzAMBGXZ6D/6ib6ipz6hBwM59ZB+\ 324dHUTY3qWsNQPEaBQoI66WpNT375+v+SOl9Jy2x+fj+Tvnq58ew/bHY3unw/hrqHw5T+\ ...


0

This should be comparable on tiny lists and 20-50+X faster than the current posted solution on large lists, depending on number of replacements needed (at least when I compared to pre-V10 solution - I no longer have 10 installed, so did not bmark that 10-specific solution, perhaps Mr.W could bmark the two): pairReplace[list_, pairsub_, subs_] := Module[{f ...


2

Here is just one of many ways to do what you are asking. It uses an association, so it only works in V10. data = {{1, 2, a}, {2, 3, a}, {4, 3, a}, {5, 4, b}, {8, 9, b}, {3, 8, b}, {1, 9, b}, {3, 5, c}, {2, 2, c}}; assoc = GroupBy[data, #[[3]] &] <|a -> {{1, 2, a}, {2, 3, a}, {4, 3, a}}, b -> {{5, 4, b}, {8, 9, b}, {3, ...


4

Revised question My proposal for your revised question: Needs["GeneralUtilities`"] trim[pos__][a_] := Join @@ TrimRight @ GatherBy[a, #[[pos]] &] If you are not using Mathematica 10 then also define(1): TrimRight[lists_] := Take[lists, All, Min[Length /@ lists]] Now using -1 as the Part index of your identifier: trim[-1] @ lis {{1, 2, a}, {2, ...


1

I think this does what you're after (to be honest, I had some trouble deciphering the question). patchedData = Module[{gb = GatherBy[SortBy[#, First], First], lens, tot = 0, cnt = 1, mems = {}, sets}, lens = Length /@ gb; sets = Append[Reap[ Scan[(tot += #; mems = {mems, cnt++}; If[tot >= 12, Sow[Flatten@mems]; ...


2

Just because I wanted to join the party and with no redeeming features (...just like playing with Reap and Sow): f[str_] := Module[{ss = StringSplit[str, ""], a, b, rul}, {a, b} = Reap[MapIndexed[Sow[w[First@#2, #1], DigitQ[#1]] &, ss]]; rul = Join[Thread[b[[1]] -> Sort[b[[1, All, 2]]]], Thread[b[[2]] -> b[[2, All, 2]]]]; StringJoin[a ...


3

strng = "95uge678r3gi89hgfe30kgh063d51"; Block[{c = Sort@StringCases[#, DigitCharacter], j = 0}, StringReplace[#, DigitCharacter :> c[[++j]]]] &@strng (* "00uge133r3gi55hgfe66kgh788d99" *)


8

I think you'll find this much faster than answers so far... strnumsrt = Module[{tc = ToCharacterCode[#], tcc, tcr}, tcc = Unitize@Clip[tc, {48, 57}, {0, 0}]; tcr = Pick[Range@Length@tcc, tcc, 1]; tc[[tcr]] = Sort[tc[[tcr]]]; FromCharacterCode[tc]] &;


8

StringReplacePart gets very slow when there are many replacements. A more direct approach proves to have far better complexity. My proposal: subSort[s_String] := Module[{p, ch}, p = StringPosition[s, DigitCharacter]; If[p === {}, Return[s], p = p[[All, 1]]]; ch = Characters[s]; ch[[p]] = Sort @ ch[[p]]; StringJoin[ch] ] rasher took this idea ...


4

This is known to be inefficient because using patterns like this gives a poor complexity, but it works: str = "95uge678r3gi89hgfe30kgh063d51"; FixedPoint[StringReplace[ #, a___ ~~ b : DigitCharacter ~~ c___ ~~ d : DigitCharacter ~~ e___ /; !OrderedQ[{b, d}] :> StringJoin[{a, d, c, b, e}] ] &, str] (Thanks to Simon Woods for ...


6

This is a slight rewrite of the code in the question, rather than anything elegant or clever. You can use the DigitCharacter pattern in StringPosition instead of ToString /@ Range[0, 9], and having found the positions you can use them in StringTake instead of searching the string again with StringCases: With[{p = StringPosition[#, DigitCharacter]}, ...


3

Perhaps: test = {57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0, 30, 3}; Position[Partition[Sign[test - 80], 2, 1], {-1, 1}] + 1 The +1, to get when crossed, would have to modify for equality cases, eg using Alternatives`


2

lst = {57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0, 30, 3} Select[Range[2, Length@lst], lst[[# - 1]] < 80 < lst[[#]] &] (* {4, 6, 16} *) Pick[Range[2, Length@lst], lst[[# - 1]] < 80 < lst[[#]] & /@ Range[2, Length@lst]] (* {4, 6, 16} *)


2

Just using a chisel to drive a screw: l = {57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0, 30, 3}; f = Interpolation[l, InterpolationOrder -> 1] NDSolve[{k'[x] == f'@x, k[1] == f[1], WhenEvent[k[x] == 80, If[f'[x] >= 0, Print[Ceiling@x]]]}, k[x], {x, 1, Length@l}] (* 4,6,16 *)


5

There is no way to do this with Position without breaking the list up using Partition[list, 2, 1] first. Position looks at elements one by one, and tests each for a match against the pattern. While we can use a pattern such as __ (BlankSequence[]), it won't behave any differently from _ (Blank[]) in Position because it will never be tested against the full ...


4

No need folding 1D graph to get a 2D Random walk in Mathematica. and the CCW easy in Mathematica. Here we go: Generate data set for the random sequence with 2000 steps. Alternatively, you may use your "own generated" data set. rdata = Accumulate[RandomChoice[{-1, 1}, {2000, 2}]] Now plot it with similar layout as your example ListLinePlot[rdata, ...


8

Just a quick-n-dirty, for huge lists there's faster ways, will update when time permits. f = With[{s = Split[#, #1 < 80 && #2 >= 80 &]}, Pick[Accumulate@(Length /@ s), Length /@ s, 2]] &; f@{57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0, 30, 3} (* {4, 6, 16} *) For large lists, this should be quite snappy: ...


4

rw = Accumulate@RandomChoice[{-1, 1}, 400]; ListLinePlot[rw, AspectRatio -> 1] rw2 = Transpose[{rw[[ ;; 200]], rw[[201 ;; ]]}]; llp2 = ListLinePlot[rw2, AspectRatio -> 1] To rotate llp2: Show[MapAt[GeometricTransformation[#, RotationTransform[-45 Degree]] &, llp2, {1}], PlotRange -> All] Aside: Using InterpolationOrder->0 ...


4

ListLinePlot[Accumulate @ Prepend[RandomChoice[{{-1, 0}, {1, 0}, {0, -1}, {0, 1}}, 1000], {1, 1}], AspectRatio -> Automatic] Starting with some random data rd = RandomChoice[{1, -1}, 2000]; ListLinePlot[Accumulate@rd] Creating a random walk similar to the one shown in your question rw = Accumulate@Transpose[{rd[[;; 1000]], rd[[1001 ...


2

@Wizard, @Kuba, Sorry I do not have sufficient reputation for adding comments, therefore I take the liberty to post it as an Answer. Your solution result not only contains (A1,A2) but also contains (A2,A1), therefore // Take[#, Length @ #/2] & needs to be added in order to take only (A1,A2). :)


0

If order does not matter, Clear[splitList] splitList[ list_?(VectorQ[#] && EvenQ[Length[list]] &)] := Module[{a1, a2, a3, len = Length[list]}, a1 = Subsets[list, {len/2}]; a2 = Complement[list, #] & /@ a1; a3 = Transpose[{a1, a2}]; Union[a3, SameTest -> (Sort[Sort /@ #1] === Sort[Sort /@ #2] &)]] splitList[{e1, e2, ...


1

I would suggest using a combination of Subsets and Complement, two basic set operations in Mathematica. Here is an example code, you should be able to transfer that to any sort of list on your own: (*create list*) list = {1, 2, 3, 4, 5, 6, 7, 8}; (*create all subsets of length n/2*) subsets = Subsets[list, {Length[list]/2}]; (*create the corresponding ...


0

I'm assuming in A_1 A_2 pair, order matters: set = Range[6]; Transpose[{#, Reverse@#}] & @ Subsets[#, {Length[#]/2}] & @ set {{{1, 2, 3}, {4, 5, 6}}, {{1, 2, 4}, {3, 5, 6}}, {{1, 2, 5}, {3, 4, 6}}, {{1, 2, 6}, {3, 4, 5}}, {{1, 3, 4}, {2, 5, 6}}, {{1, 3, 5}, {2, 4, 6}}, {{1, 3, 6}, {2, 4, 5}}, {{1, 4, 5}, {2, 3, 6}}, {{1, 4, 6}, {2, 3, 5}}, ...


0

Try also this: as = <|"Aa" -> "1/2", "Av" -> "2/5", "Ca" -> "3/4", "Bx" -> "3/7", "Ce" -> "4/9"|>; ks = KeySelect[as, Characters[#][[1]] == "A" || Characters[#][[2]] == "a" &]; op = Map[ToExpression, ks, 2]; Merge[{Association[Complement[Normal[as], Normal[ks]]], op}, Total] yielding (* <|"Bx" -> "3/7", ...


3

A variation on the theme: test = {Aa -> "1/2", Av -> "2/5", Bx -> "3/7", Ce -> "4/9"}; test /. (key_ /; StringMatchQ[ToString[key], ___ ~~ "a" | "A" ~~ ___] -> val_) :> (key -> ToExpression[val]) (*{Aa -> 1/2, Av -> 2/5, Bx -> "3/7", Ce -> "4/9"}*)


6

I would use something like this: Clear[f]; f[key_ -> val_] := key -> If[ StringMatchQ[ToString@key, ___ ~~ "A" | "a" ~~ ___], q@val, val] then f /@ {Aa->1/2, Av->2/5, Bx->3/7, Ce->4/9} (* {Aa -> q[1/2], Av -> q[2/5], Bx -> 3/7, Ce -> 4/9} *) If you have v10, and your data is in an Association, you use AssociationMap, ...


3

I found a clever way to make MaxFilter work with even windows, and used conditionals to combine the odd- and even- cases. This solution is, surprisingly, more efficient than even @MrWizard's compiled function, and increasingly so as the window size increases. tl;dr MovingMax[list_, w_] := If[w > Length@list, {}, Module[{r, tmp}, r = Floor[w/2]; ...


4

Riffle is surely the canonical method since version 6 but there are other approaches: fn1[lst_, ele_, n_, m_: 1] := Take[ Join @@ ArrayPad[Partition[lst, n, n, 1], {0, {0, m}}, ele], QuotientRemainder[Length @ lst, n].{n + m, 1} ] Test: fn1[Range@10, "x", 3] fn1[Range@10, "x", 4, 2] fn1[Range@10, "x", 5, 3] {1, 2, 3, "x", 4, 5, 6, "x", ...


7

I'm answering my own question because I found it curious that neither Google nor Mathematica's documentation located my solution when I searched by, what were to me, the most obvious combinations of keyphrases, e.g. mathematica insert every list. Riffle is probably an obvious thought for anyone familiar with Mathematica, but not a common term that ...


1

Why not just do it on-the-fly: MapThread[ Replace[FinancialData[#2, "OHLC", {{2015, 1, 1}, {2015, 1, 5}}], {d : {__}, p : {__}} :> {d, Append[p, #1]}, {1}] &, Transpose@lis]


0

This variant works. But it will of necessity do some evaluation outside of Compile so it may not offer much in the way of a speed gain (I do not have time to check right now). Another drawback is I have not succeeded in getting it to cooperate with compiling to C. SetAttributes[myreap, HoldFirst]; myreap[a__] := Reap[a][[2, 1]] func = Compile[{}, ...


1

This pre-pends to each result set retrieved by Financial Data (data=Map[Financial......) the db ids. For appending swap the arguments in Transpose Transpose[{lis[[All, 1]], data}] // ((f \[Function] Flatten[f, 2]) /@ # & ) Thread works as well, here with the arguments swopped for appending Thread[{data, lis[[All, 1]]}] // ((f \[Function] Flatten[f, ...


1

One way: MapAt[Append[4470], data, {All, All, 2}] By the way updating all of the rows and columns with a known value is likely to be redundant. If you could put that number into the code that inserts the data into the database somehow it would likely be faster, because you will be able to skip this step completely.


2

Use With to replace only explicit appearances of k in the right-hand-side, preventing the changing values of k from contaminating the stack. f[{_}] = 2.; f[n_] := f[n] = With[ {k = Union[Select[n, # > 1 &]]}, f[Drop[n, 1]] + If[k == {}, 0., Sum[Count[n, i]*f[Join[DeleteCases[n, i, 1, 1], i - 1]], {i, k}]] ] f[{1, 2, 2, 3, 3, 3}] ...


0

In version 10 the package GeneralUtilites contains the functions TrimLeft and TrimRight: x = {{1, 2, 3}, {1, 2, 3, 4}, {1, 2}}; Needs["GeneralUtilities`"] TrimLeft[x] TrimRight[x] {{2, 3}, {3, 4}, {1, 2}} {{1, 2}, {1, 2}, {1, 2}} Burdened with the additional argument testing overhead of a packaged function these are not quite as fast as the raw ...


4

Compilation is useful here (with a method from Efficient circular buffer?): cf = Compile[{{x, _Integer, 1}, {n, _Integer}}, Module[{i = n, a = Take[x, n]}, (a[[ Mod[i, n, 1] ]] = #; i++; Max[a]) & /@ Drop[x, n - 1] ] ]; Test: x = RandomInteger[{-1*^6, 1*^6}, 200000]; (r1 = AnotherMaxFilter[x, 200]); // AbsoluteTiming // First (r2 = cf[x, ...


2

Too late for the party so fun solution: ToString @ Row @ list ~ StringTrim ~ ("0" ..) // ToExpression // IntegerDigits {1, 2, 3, 0, 0, 4, 5} I feel like it is a duplicate but I can't find it...


9

Unless both lists given to Equal are packed arrays Equal will first unpack. Unfortunately for this case {} is not a packable expression, therefore list == {} will always unpack list, assuming it starts packed. That unpacking takes time: test = RandomInteger[100000000, 10000000]; Developer`FromPackedArray[test]; // AbsoluteTiming {0.207012, Null} ...


1

d = {1, 0, 2, 1, 3, 0, 2, 4, 1, 3, 0, 5, 2, 4, 1, 6, 3, 0, 5, 2, 7, 4, 1, 6, 3}; t = {0, 1, 0, 1, 0, 2, 1, 0, 2, 1, 3, 0, 2, 1, 3, 0, 2, 4, 1, 3, 0, 2, 4, 1, 3}; po[d_, t_] := Binomial[14, d] Binomial[14 - d, t]; Grid[{First[#], po @@ Rest[#]} & /@ Transpose[{Range[Length[d]], d, t}]] Alternatively, make the function po Listable ...


5

The TakeWhile and replacement based answers will be very slow with large lists and/or large lists with many trailing zeroes. Something like dropper=With[{s = Split[#]}, If[s[[-1, 1]] == 0, Join @@ (Most@s), #]] &; will be ~2000X faster on a list of 50K length vs a replacement solution, advantage growing with size. There are other even faster methods ...


3

a = {1, 2, 3, 0, 0, 4, 5, 0, 0, 0}; f = Drop[#, -Length[TakeWhile[Reverse[#], Function[b, b == 0]]]] &; f[a] {1, 2, 3, 0, 0, 4, 5}


3

Technically, @Bill's and @Pickett's clean answers do not quite delete the 0s after "the last positive integer." A teeny alteration fixes Bill's answer: {1, 2, 3, 0, 0, 4, 4.2, 0, 0, 0} /. {a___, b_Integer /; b > 0, 0 ..} -> {a, b}


8

The easiest way would be to use {1, 2, 3, 0, 0, 4, 5, 0, 0, 0} /. {a___, 0 ...} :> {a} /. is synonymous with ReplaceAll. It tries to replace values on the left hand side with the rules on the right hand side. In this case {a___, 0...} is the pattern; a___ matches zero or more elements, and 0... matches zero or more zeroes. :> {a} takes the a that ...


3

I'm not sure I really understand how the example is to be generalised, but this removes all List heads at level 2 and 4: ReplacePart[lis, Position[lis, List, {#}] & /@ Join[2, 4] -> Sequence] (* {a, {b, c, d, e}, {f, g, h, i}} *)



Top 50 recent answers are included