Tag Info

Hot answers tagged

18

I think the built-in function ArrayComponents is what you need: vec = {1, 4, 4, 8, 7, 7, 4}; ArrayComponents[vec] (* {1,2,2,3,4,4,2} *) mat = {{1, 4}, {2, 7}, {7, 2}, {9, 4}}; ArrayComponents[mat] (* {{1,2},{3,4},{4,3},{5,2}} *) raggedarray = RandomSample /@ (CharacterRange["a", "z"][[#]] & /@ Range[RandomSample[Range[5]]]) (* ...


11

The old-school way to do this: index[a_] := Module[{i = 1, f}, f[x_] := f[x] = i++; f /@ a] index @ vec {1, 2, 2, 3, 4, 4, 2} A method using Assocation, introduced long after ArrayComponents. index2[a_List] := AssociationThread[#, Range@Length@#] ~Lookup~ a & @ DeleteDuplicates @ a Edit #2: extended to matrices using eldo's own method: ...


7

Your code is like a Rube Goldberg machine! Try this instead: fn[state_] := Outer[Coefficient[state, #*#2] &, ##] & @@ (Union @ Cases[state, #, -2] & /@ {_FF, _GG}) Test: test = 7 FF[1, 1] GG[1, 1] + 2 FF[1, 1] GG[2, 2] + 4 FF[2, 2] GG[2, 2] + 11 FF[2, 1] GG[2, 4]; fn[test] // MatrixForm $\left( \begin{array}{ccc} 7 & 2 & 0 ...


6

Join @@ Flatten[{M1, M2}, {{2}, {1}}] (* {{1, 2, 3}, {10, 11, 12}, {4, 5, 6}, {13, 14, 15}, {7, 8, 9}, {16, 17, 18}, {19, 20, 21}, {22, 23, 24}} *) Reference for using the second argument of Flatten to transpose a ragged array. Update: even shorter (big praise to Flatten): Flatten[{M1, M2}, {2, 1}]


6

I'll use this example matrix: matrix = Table[i + j, {i, 20}, {j, 0, 19}] Please take a look at it. You'll notice that the top row has the elements 1-20 and that the leftmost column as has those as well. Now let's create a list of the columns/rows that you want to keep: keep = Join[Range[5], Range[6, 10, 2], Range[11, 20, 3]] (* Out: {1, 2, 3, 4, 5, 6, 8, ...


6

I know I'm a little bit late to the party but here's a way to generate the ragged diamond using DiamondMatrix directly: (* Generate double diamond surrounded by zeros using DiamondMatrix*) diamondWithin = DiamondMatrix[{4, 5}, {9, 10}]; (* Trim the zeros and resulting empty lists (if any) *) trimZero = diamondWithin //. {0 :> Sequence[], {} :> ...


6

I am not getting the same results in version 10. Also I see no problem with the results already indicated, and I'll say a bit about that as we proceed. Here is what I obtain in version 10. smatrix = {{1 - 2.96392/u2, 0.0000196744/u2}, {1. - 2.96392/u2, -2.11737*10^-10 + 0.0000196746/u2}}; det = Det[smatrix]; sols = Solve[det == 0, u2] During ...


6

At least internally, the following is a nice recursive way of thinking about the chess board: MatrixPlot[CellularAutomaton[250, {0, 1}, {7, 7}]] Not sure if this is what was meant by functional style. It's hard to make a one-liner functional. To address extensibility: the dimensions of the board are directly dictated by the argument {7,7}, and the ...


5

Using ArrayPad to reflect a pyramid matrix: diamond[n_] := ArrayPad[ConstantArray[1, #] & /@ Range[n], {{0, n - 1}}, "Reflected"] diamond[5] // MatrixForm


5

Defining a helper function for tidiness: diamondcounts[n_] := Range[n] ~Join~ Range[n - 1, 1, -1] You could use ConstantArray and Map ConstantArray[1, #] & /@ diamondcounts[n] But personally I think Table is a rather nice choice here: Table[1, {i, diamondcounts[n]}, {i}]


5

Here are two different methods based on Array: diamond[n_] := With[{a = ConstantArray[1, #] &}, Array[a, n]~ Join ~Reverse@Array[a, n - 1]] OR diamond[n_]:= Array[Array[1 &, #] &, {n}] ~ Join ~ Reverse[Array[Array[1 &, #] &, {n-1}]] diamond[5] // MatrixForm


5

For a worst case scenario when your graphics broke down, and you are forced to work only with numbers f[x_, y_, a_, b_] := (x + y)^2/a^2 + (x - y)^2/b^2 R = 10; mat=Table[If[f[m, n, 2, 3] < R^2, Style[X, Red], O], {m, -2 R,2 R}, {n, -2 R, 2 R}]; Grid[mat, Spacings -> {0, 0}] Change R, a, b to change the shape. Its probably not very practical way, ...


5

One way, probably not the cleanest: gr = Graphics[Rotate[Disk[{0, 0}, {4, 2}], Pi/6], ImageSize -> 250]; a = Image[gr, "Bit", ColorSpace -> "Grayscale"] // ImageData; a // Colorize You can control the border size using PlotRangePadding or ArrayPad, for Graphics or absolute scaling. This is not slow: gr = Graphics[Rotate[Disk[{0, 0}, {4, 2}], ...


5

Judging from the paper you linked to and your own comments, I think what you really want is a directed Barabasi‚ÄďAlbert graph whose opposite edges have different weight. (Thus e.g. edge 1 -> 2 should have a different weight than 2 -> 1). The code you posted generates an undirected BA graph, so allow me to suggest an alternative generating function ...


5

I'm not quite sure if I understand your problem correctly. Anyway, use Eigensystem to find Eigenvalues and Eigenvectors at the same time. Here we go A = {{5, 4, 2}, {4, 5, 2}, {2, 2, 2}}; Eigensystem[A] (* {{10, 1, 1}, {{2, 2, 1}, {-1, 0, 2}, {-1, 1, 0}}} *) Hence the Eigenvalues are {10,1,1} and the respective Eigenvectors appear ordered ...


4

You were almost there but you need to read up on SortBy: Do[ matfinal[i] = SortBy[matinitial, Total[#[[i ;; i + 4]]] &], {i, 6} ]


4

diamond[n_] := 1 & /@ Range[#] & /@ (Range[n]~Join~Reverse@Range[n - 1]); or diamond[n_] := Array[1 &, n - Abs[#]] & /@ Range[1 - n, n - 1]; diamond[10]//MatrixForm


4

Here is a FoldList approach: diamond[n_] := Rest@FoldList[ConstantArray[1, #2] &, 0, Range[n]~Join~Range[n - 1, 1, -1]] Then: diamond[6] // MatrixForm


4

Not much to add to the existing answers except that my favorite method to convert lists of natural numbers to all ones is x^0 therefore: f[n_] := Range[n - Abs @ Range[1-n, n-1]]^0 Also I don't believe anyone has yet used Diagonal: f2[n_] := With[{m = BoxMatrix[(n - 1)/2]}, Array[m ~Diagonal~ # &, 2 n - 1, 1 - n]]


4

I'm surprised MMA doesn't have something like StringSplit for list, but maybe I haven't looked hard enough. I added the .. to delete multiple all-zero columns after seeing @Kuba's comment. Please upvote his comment instead of my answer since his was the more succinct. mat = {{0, 0, 0, 0, 0, 1}, {1, 0, 0, 1, 0, 1}, {0, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, ...


4

This seems much simpler than other answers presented: Array[Plus, {8, 8}] ~Mod~ 2 // MatrixPlot Attempting to comply with the requirements of the addendum here is a recursive solution: board[n_] := board[n - 1, {{0}}] board[n_, a_] := board[n - 1, ArrayFlatten[{{a, #\[Transpose]}, {#, 0}}] &[{1 - Last[a]}]] board[0, a_] := a Example: ...


3

Investigating your answers I found some more possibilities: A helper function PeekRange[n_] := With[{r = Range @ n}, r ~ Join ~ Reverse @ Most @ r] Partition: diamond1[n_] := Partition[ConstantArray[1, n], n, 1, {-1, 1}, {}] ListConvolve: diamond2[n_] := ConstantArray @@@ ListConvolve[{1}, PeekRange @ n, 1, 0, List] ArrayReshape: diamond3[n_] := ...


3

func = Function[{mat, matfin, n, m}, Table[ With[{ord = Ordering[mat, All, Total[#[[i ;; i + m]]] < Total[#2[[i ;; i + m]]] &]}, matfin[i] = matinit[[ord]]], {i, n}]]; OP's example: func[matinitial, matfinal, 6, 4]; matfinal[1] (* {{11, 12, 13, 14, 15, 16, 17, 18, 19, 10}, {21, 22, 23, 24, 25, 26, 27, 28, 29, 210}, {31, 32, ...


3

You are completely right: using Map is much nicer than an iterative approach. Here's one way you might do it: ReplacePart[M, # -> s]& /@ L Here /@ is a short-hand input form of Map, and the #& combination is what's known as a pure function. Welcome to Mathematica :).


3

A variation on @MrW's answer using a combination of Outer, Coefficient, Variables and GatherBy: func = Function[{state}, Coefficient[state, #] &@ Outer[Times, ## & @@ (Sort /@ GatherBy[Variables[state], Head])]]; Test: xx1 = FF[1, 1] GG[1, 1] + FF[1, 1] GG[2, 2] + FF[2, 2] GG[2, 2]; xx2 = 2*FF[1, 2] GG[1, 1] + FF[1, 1] GG[1, 2] + FF[2, 2] ...


3

you can also use ClusteringComponents function inex[m_] := ClusteringComponents[m, Length@m + 1]; vec = {1, 4, 4, 8, 7, 7, 4}; inex[vec] (*{1, 2, 2, 3, 4, 4, 2}*) mat = {{1, 4}, {2, 7}, {7, 2}, {9, 4}}; inex[mat] (*{{1, 2}, {3, 4}, {4, 3}, {5, 2}}*)


3

Basically, the same idea as seismatica's answer, but with different details. m = {{0, 0, 0, 0, 0, 1}, {1, 0, 0, 1, 0, 1}, {0, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 1}, {1, 1, 0, 1, 0, 0}, {0, 0, 0, 1, 0, 1}}; split = Transpose /@ DeleteCases[ SplitBy[If[Plus @@ # > 0, #] & /@ Transpose[m], # === Null &], {Null}]; ...


3

In the spirit of Mathematica 10 I would have written it like this: Composition[ DeleteCases[{{0} ..}], Map[Transpose], SplitBy[#, Unitize@*Total] &, Transpose ]@mat {{{0, 0}, {1, 0}, {0, 1}, {0, 0}, {1, 1}, {0, 0}}, {{0}, {1}, {0}, {0}, {1}, {1}}, {{1}, {1}, {0}, {1}, {0}, {1}}} With rules I would write: Transpose /@ {Transpose[mat] ...


3

This is a functional version of board: ones = {{1, 1}, {1, 1}}; zeros = {{0, 0}, {0, 0}}; board[n_] := Partition[Riffle[ConstantArray[ones, (n)^2/2], {zeros}], n, n - 1] // ArrayFlatten // Image[#, ImageSize -> 400] & board[8] (Defining ones and zeros is optional, so this side effect can be avoided. You will notice also that it only works for even ...


3

Pattern-based functional approach: pat1 := n_Integer /; n > 1 :> Sequence[n, n - 1 /. pat1]; pat2 := v : List[__Integer] /; Max[v] > 1 :> Sequence[v, v - 1 /. pat2]; cb[n_] := MatrixPlot[ {{n}} /. pat1 /. pat2, ColorFunction -> (GrayLevel@Mod[1 + #, 2] &), ColorFunctionScaling -> False, PlotRangePadding -> None, ...



Only top voted, non community-wiki answers of a minimum length are eligible