Tag Info

New answers tagged

0

In 10.1.0 we have the new function KeyValueMap. You can use these functions, although they are not perfect heldNormal[assoc_] := Apply[Rule, Hold@Evaluate@KeyValueMap[Hold, assoc], {2}] map[f_, assoc_] := Association @@ Unevaluated @@@ List@MapAt[f, heldNormal@assoc, {All, All, 2}] associationMap[f_, assoc_] := Association[ReleaseHold@Map[f, ...


2

Using the undocumented "Periodic" padding as the third argument of PadRight: ClearAll[fpF, fpF2] fpF = Block[{i = 1}, While[i < Length@# && PadRight[#[[;; i]], Length@#, "Periodic"] != #, i++]; i] &; fpF2 = Block[{i = 1}, While[i < Length@# && PadRight[#[[;; i]], Length@#, "Periodic"] != #, i++]; {i, #[[;; i]]}] ...


1

Late to party, and liking all answers but esp Chris Degnen: per[u_] := Module[{j = 1, lg = Length@u}, While[Total[ Abs[Take[Join @@ ConstantArray[u[[;; j]], Ceiling[lg/j]], lg] - u]] != 0, j++]; {j, u[[;; j]]}] Some test cases: tc={{19, 6, 19, 6, 19, 6, 19, 6, 19, 6, 19, 6}, {73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7}, {73, 7, 4, 7, ...


3

This answer only returns the period. If you want to extract the repeating substring, just use Take[list, period]. sequencePeriod = Compile[{{l, _Integer, 1}}, With[{n = Length[l]}, Catch[ Do[ If[ Catch[ Do[ Do[ If[l[[j]] != l[[k]], Throw[False]];, {k, i + j, n, i} ];, {j, i} ...


6

This uses partitioning, with padding if required, to make sublists. f = Module[{b, c = 1}, While[Length[b = Union@Partition[#, c, c, {1, 1}, Take[#, c]]] > 1, c++]; {Length@First@b, First@b}] &; Example f@{73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7} {3, {73, 7, 4}}


10

ClearAll[len] len[{p__, p__ .., e___}] /; MatchQ[{p}, {e, __}] := Length[{p}] len[p_] := Length[p] len /@ lists (* {2, 3, 14} *)


7

I won't bet my hand for this but seems to be ok: ClearAll[return]; return[x : {0 ..., 1}, list_] := {#, list[[;; #]]} &[Length@x]; return[x_, y_] := {Length@y, y}; sqPeriod[list_] := return[FindLinearRecurrence[list], list] sqPeriod /@ { {19, 6, 19, 6, 19, 6, 19, 6, 19, 6, 19, 6}, {73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7, 4, 73, 7}, {73, 7, 4, ...


0

I wouldn't say all functions. For example, consider f = Compile[{{x, _Real}}, x*x] There aren't any replacement rules for f in this case. DownValues[f] (* {} *)


1

This is essentially 2012rcampion's answer using Association for Basis. The definitions are: commutator[A_, B_] := A.B - B.A; multiplicationTable[basis_] := Outer[LinearSolve[Transpose[Flatten /@ Values[basis]], Flatten[commutator[#1, #2]]] &, Values@basis, Values@basis, 1].Keys[Basis] and the basis: Basis = Association["H" -> H, "E1" ...


2

(Note, it's best practice to use lowercase symbols to avoid conflicts with builtins.) multiplicationTable[basis_] := Outer[LinearSolve[Transpose[Flatten /@ basis], Flatten[commutator[##]]] &, basis, basis, 1] If we turn each matrix in the basis and the commutator into a vector, we can find a linear combination of basis elements that equal the ...


1

There may be a more efficient way to compute your MultiplicationTable itself but as a post-processing measure you could use something like this: rules = Join[ Thread[Basis -> {"H", "E1", "E2"}], Thread[-Basis -> {"-H", "-E1", "-E2"}], {m_ /; MatrixQ[m, # == 0 &] :> 0} ]; Replace[MultiplicationTable[Basis], rules, {2}] {{0, "-E2", ...


2

Patterned assumptions seem to need to match the ConditionalExpression's condition exactly to work out for some cases. The ∈ Reals-assumptions do work as you gave them, while the inequality Subscript[s,_]>0 does not, but observe the different behavior of Subscript[s,_]>=0: Evaluating without any assumptions first: f = 1/\[Sqrt](2 \[Pi] Subscript[s, ...


1

The document never promises that pattern-matching is supported inside Assumptions. (Though in some cases it does seem to be!) So the only stable way I can think of is as following: Subscript[g, i_][x_] := ($Assumptions = Union[$Assumptions~Join~ {{Subscript[m, i], Subscript[s, i]} ∈ Reals, Subscript[s, i] > 0}]; Exp[-((x - Subscript[m, ...


1

Something different (but ugly): fun[u_] := Module[{p = Flatten@Position[Partition[u, 3, 1], {1, _, 3}], rules, res}, rules = {x_, #} :> {Style[x, Red, Bold], #} & /@ Flatten[{#, # + 2} & /@ p]; res = MapIndexed[{#1, First@#2} &, u] /. rules; res[[;; , 1]] ] So, test = {{1, 2, 3}, {1, 2, 3, 1, 2, 3, 4, 5}} fun/@test


1

lst//.{a___,1,s_,3,b___}:>{a,Style[1, Red],s,Style[3, Red],b}


1

I'm lazy so this is short but not efficient in general case: lst //. {x___, 1, y_, 3, z___} :> {x, Style[1, Red], y, Style[3, Red], z}


0

lst = {{1, 2, 3}, {1, 2, 3, 1, 2, 3, 4, 5}}; lst /. a_Integer /; MemberQ[{1, 3}, a] :> Style[a, Red]


0

This will kludge it up: c = Cases[{#, Chop@FindFit[#, a x + b, {a, b}, x]} & /@ Subsets[data, {4, Length@data}], {_, {a -> aa_, b -> bb_}} /; FractionalPart[Round[aa, .0001]] == 0 && FractionalPart[Round[bb, .0001]] == 0]; Last@SortBy[c, Length] (* {{2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24}, {a -> 2., b -> 0}} *) ...


0

Finding Subsequences First off, here's the code I used to verify my solutions: Sort@DeleteDuplicates[ Select[Select[Reverse@Subsets[data, {3, ∞}], Equal @@ Differences[#] &], Unequal @@ # &], SubsetQ[##] && Equal @@ Sign@*First@*Differences /@ {##} &] First, we get all Subsets of data that are no shorter than three elements ...


1

Here's a generalized function: delDupeOnZeroes[list_, zerpos_, distpos_, any_: False] := Module[{up = Union@Flatten@{distpos}, r = Range@Length@list, zp = zerpos, p, gb, jgb, patt}, If[any, p = Cases[Tally[list[[All, #]]], {val_, num_ /; num > 1} :> val] & /@ up; If[Flatten@p === {}, Return[list, Module]]; patt = ...


13

lst = {{2, -2}, {1, 5}, {1, -3}, {-3, 3}}; Pick[lst, Total[lst, {2}], 0] (* {{2,-2},{-3,3}} *) First@Timing[res0 = Pick[Ta, Total[Ta, {2}], 0];] (* 0.093750 *) First@Timing[res0a = Pick[Ta, Total /@ Ta, 0];] (* 0.187500 *) First@Timing[res0b = Pick[Ta, Plus @@ Transpose[Ta], 0];] (*thanks: 2012rcampion *) (* 0.062500 *) First@Timing[res1 = DeleteCases[Ta, ...


1

Cases[{{2, -2}, {1, 5}, {1, -3}, {-3, 3}}, {a_, b_} /; a + b == 0] produces the same result and is modestly faster. Ta = Flatten[Table[{i, j}, {i, -1000, 1000}, {j, -1000, 1000}], 1]; Timing[DeleteCases[Ta, {a_, b_} /; a != -b];] (* {4.34375, Null} *) Timing[Cases[Ta, {a_, b_} /; a + b == 0];] (* {3.92188, Null} *) An irreducible amount of time goes to ...


1

From the details section of the documentation page, it says that DeleteDuplicates[list] deletes all but the first occurrence of each distinct element that appears in list. So, to make sure that the tuples with 0-s are deleted, we have to sort the list first. Also, Second is not a built-in function so using Last here instead: ...


2

list = {{-2053.5150, 0}, {-2053.5150, -2053.46}, {-2012.7445, 0}, {-1297.0270, 0}, {-1297.0270, -1297.09}, {-1296.0551, 0}, {-1296.0551, -1296.08}, {-802.7016, 0}, {-760.9591, 0}, {-757.1460, 0}, {-715.4035, 0}, {-44.5266, 0}, {-44.5266, -44.498}, {-41.8274, 0}, {-41.8274, -41.456}, {-41.4285, 0}, {-41.4285, -41.456}, {-1.0569, 0}, ...


0

"Xabcde" /. a_ :> StringCases[a, _] /. {"X", b__} :> StringJoin[b] (*"abcde"*)


4

Use StringReplace["Xabcde", "X" ~~ e__ -> e]. Replace, et al are for lists/expressions... Notice that AtomQ@"Xabcde" is True, so regular (non-string) replace operations only "see" it as a singular entity: "Xabcde" /. "Xabcde" -> 1 (* 1 *) From the docs for ReplaceAll: "... to transform each subpart..." - but there is no "subpart" for atoms, so ...


4

Fixed in 10.1 (windows) code MatchQ[{1, 2}, {a_, b_}] MatchQ[{1, 2}, {a_, b_: 0}] MatchQ[{1, 2}, {PatternSequence[a_, b_]}] MatchQ[{1, 2}, {PatternSequence[a_, b_: 0]}]


1

This has been fixed in 10.1 code Exp[2 I u x] /. Exp[Complex[0, a_] u x] :> a Exp[2 I u Sin[x]] /. Exp[Complex[0, a_] u Sin[x]] :> a foo[2 I u Sin[x]] /. foo[Complex[0, _] u Sin[x]] :> bar foo[2 I u Sin[x]] /. foo[Complex[0, _] (p : u) Sin[x]] :> bar foo[2 I u Sin[x]] /. foo[Complex[0, _] HoldPattern[u] Sin[x]] :> bar


2

The misunderstanding as far as I can tell lies in the order in which missing patterns are filled when using Optional (pattern : value). Why does Mathematica fill the missing items from left to right rather than right to left? It becomes quite clear if you think about how Optional is meant to be used. In Mathematica Optional is used to provide default values ...


1

data = Table[{x, Exp[.2 + .3 x + .1 Sin[x] + RandomReal[{-.2, .2}]]}, {x, RandomReal[5, 100]}]; nlm = NonlinearModelFit[data, Exp[a + b Sin[x] + c Cos[x]], {a, b, c}, x]; pt = nlm["ParameterTable"]; You can also use Part as follows to access the row labels, column labels and the content of pt: rowlabels = Sequence[1, 1, 2 ;;, 1]; collabels ...


0

Drop[(%["ParameterTable"] // First // First)[[All, 1]], 1]


3

Assuming you have typed fit = NonlinearModelFit[{{0, 1}, {1, 2}, {3, 3}}, a + b*x, {a, b}, x] Using this great answer you can type StringProperties[NonlinearModelFit] ...


7

General Dataset has been internally overloaded on many system functions via UpValues. This is necessary to make sure that those functions work on Dataset properly, and this behavior may not be the same as would've been by default (without such redefinitions). However, in some cases, this might not be desirable. Below is the code that I suggest to use to ...


11

The behaviour we are seeing is due to an up-value on Dataset. Many operators have special meaning when applied to Dataset. They are typically changed so that they operate upon the content of the dataset and then wrap the result back into a dataset. ReplaceAll is one of those operators. We can see that this special behaviour is implemented as an up-value ...


2

It does what it is designt to, so either put there a stronger pattern: Flatten @ StringCases[list, StartOfString ~~ "H" ~~ __ ~~ EndOfString] or use more suited functions: Select[list, StringMatchQ[#, "H" ~~ __] &]



Top 50 recent answers are included