# Ordering and summing elements of a list based on their indexes

Suppose I have a vector.

I assign to every vector index a four-element array, in such a way that index i corresponds to {x1,p1,x2,p2}, where x1,x2 range from a $[-n,n]$ interval ($n$ is a constant defined elsewhere, used to define the dimension of my system) while p1,p2 are either $0$ or $1$. So, if the vector is {a,b,c,d,...,z}, for example, for $n=1$, I have

1 ------> {-1,0,-1,0}------> a
2 ------> {-1,0,-1,1}------> b
3 ------> {-1,0,0,0} ------> c
...
36------> {1,1,1,1}  ------> z


What I want to do now is rearranging the vector in such a way that the indexes are ordered like {x1,x2,p1,p2}:

1 ------> {-1,0,-1,0}------> a
2 ------> {-1,0,-1,1}------> b
7 ------> {-1,1,-1,0}------> g
8 ------> {-1,1,-1,1}------> h
...
36 -----> {1,1,1,1}  ------> z


Then, I'll have to generate another vector summing a+b+g+h as the first element, and so on, summing 4 elements at a time. At the end, I'll have a 9-element vector:

1 -----> {-1,-1} -----> a+b+g+h
...
9 -----> {1,1}   -----> j+k+y+z


Where j,k are the appropriate elements, chosen by the above rule.

What I do is writing a function that gives me all the 4-elements arrays with x1,p1,x2,p2s, then riffling this with my original vector, then ordering by x1 and x2, and finally summing the elements.

Is there a faster way to do this?

Here's my solution:

I start defining a positionFinder function:

positionFinder[index_Integer,n_]:=


Then I define indexes as Length[vector[n]], and

poleposition[n_]:= Table[positionFinder[i-1,n],{i,1,indexes}];
positions[n_]:=
Partition[Riffle[Part[poleposition[n],All,1],
Part[poleposition[n],All,3]],2];


So I have the positions list, i.e. an array {{-n(* ,0 *),-n(* ,0 *))},{-n (* ,0 *),-n (* ,1 *)},{-n(* ,1 *),-n+1(* ,0 *)}, ... , {-n(* ,1 *),-n(* ,0 *)},{-n(* ,1 *),-n(* ,1 *)},{-n(* ,1 *),-n+1(* ,0 *)} ... ,{n(* ,1 *),n(* ,1 *)}} (I commented the p1,p2 which make my array disordered). Now, I do

probGet[n_]:=Partition[Flatten[Riffle[positions[n],vector[n]]],3];


to join the positions and their correspondent vector element and

probCompute[n_]:=Sort[Sort[probGet[n],#1[[2]]>#2[[2]]&],#1[[1]]<#2[[1]]&];


to order my total array by the positions. Finally,

probExtract[n_]:= Part[probCompute[n],1;;-1;;4] + Part[probCompute[n],2;;-1;;4] +
Part[probCompute[n],3;;-1;;4] + Part[probCompute[n],4;;-1;;4];

• Post your solution! That way if we come up with different solutions, we can test speed against your solution (and we won't reproduce your solution). Also: how is n chosen? Is it related to the length of some list? Or is it a parameter in your problem? – march Oct 22 '15 at 15:36
• @march that's correct, letters don't matter, that's why I chose j and k at the end. I'll edit the question with my solution. – Enzo Oct 22 '15 at 15:47
• I was going to use your code to test my solution against yours, but MixedRadix is new in V10.2, which I don't have, so I have another question. How does "summing a+b+g+h" result in {-1, 1}? That part is unclear. However: your finding of positions and such is unnecessary, because of you just Sort your list of 4-tuples, it will bring it automatically into the form you want. You can then Partition[ ..., 4] and sum over those rows. I can show this if you can clear up the part about the final summation. – march Oct 22 '15 at 16:34
• Summing a+b+g+h means summing the elements which are indexed by the same position. In the end, I'll have a vector like {{-1,-1,a+b+g+h}, ... ,{1,1,j+k+y+z}}. So "summing" does not result in {-1,-1}, they simply become "associated". I'm sorry if I'm being unclear. – Enzo Oct 22 '15 at 16:40
• Ok, I edited again, I hope it's clearer now – Enzo Oct 22 '15 at 16:47

Since I cannot reproduce the ordering of your original list, I will make my own:

orderingList = RandomSample[
Flatten[
Outer[Riffle, Tuples[Range[-n, n], 2], Tuples[{0, 1}, 2], 1, 1]
, 1];


We then get the correct ordering of this list by using SortBy with a custom ordering function using SortBy:

ordering = Last /@ SortBy[MapIndexed[Flatten@{#1, #2} &, orderingList], {#[[1]] &, #[[3]] &, #[[2]] &, #[[4]] &}];


Finally, we apply this ordering to the original list, partition, and sum. As an example, let's suppose that the values {a, b, c, ...} are

vals = Array[v, 36];


Then:

summedVals = Total /@ Partition[vals[[ordering]], 4];


should do the trick. Finally, add back in the coordinates, which we didn't have to keep track of because Mathematica sorts things consistently:

MapThread[Append[#1, #2] &, {Tuples[Range[-1, 1], 2], summedVals}]

• Ok, it works perfectly. Thank you very much! – Enzo Oct 22 '15 at 21:22

Proposition

listForComponent[vec_, n_] := Flatten[
Table[{x1, p1, x2, p2,
vec[[4 (2 n + 1) (x1 + n) + 2 (2 n + 1) p1 + 2 (x2 + n) + p2 + 1]]},
{x1, -n, n}, {p1, 0, 1}, {x2, -n, n}, {p2, 0, 1}],
{1, 2, 3, 4}];

gatherComponents[vec_, n_] := GatherBy[listForComponent[vec, n],
{#[[1]], #[[3]]} &];

addComponents[{{x1_, _, x2_, _, c1_}, {x1_, _, x2_, _, c2_},
{x1_, _, x2_, _, c3_}, {x1_, _, x2_, _, c4_}}] :=
{x1, x2, c1 + c2 + c3 + c4};

toNewVector[vec_, n_] := addComponents /@ gatherComponents[vec, n];


Explanation

I explain the above code by means of the following test vector:

testvector = Join[CharacterRange["a", "z"], CharacterRange["A", "J"]];
testvector // Short

(* {"a", "b", "c", "d", "e", <<26>>, "F", "G", "H", "I", "J"} *)


listForComponent generates the indices {x1, p1, x2, p2} for each vector component. The assignment follows the structure you detailed in your example and is given in the form {x1, p1, x2, p2, *Component*}.

listForComponent[testvector, 1] // Short

(* {{-1, 0, -1, 0, "a"}, {-1, 0, -1, 1, "b"}, <<33>>, {1, 1, 1, 1, "J"}} *)


gatherComponents gathers the vector components with respect to their values {x1, x2}.

gatherComponents[testvector, 1] // Short

(* {{{-1, 0, -1, 0, "a"}, {-1, 0, -1, 1, "b"}, {-1, 1, -1, 0, "g"},
{-1, 1, -1, 1, "h"}}, <<8>>} *)


addComponents provides the sum of the vector components having the same {x1, x2}, and returns a list of the form {x1, x2, *SumOfComponents*}.

At last, toNewVector, the main function, uses addComponents on the output given by gatherComponents to return the result sought-after.

toNewVector[testvector, 1]

(* {{-1, -1, "a" + "b" + "g" + "h"}, {-1, 0, "c" + "d" + "i" + "j"},
{-1, 1, "e" + "f" + "k" + "l"}, {0, -1, "m" + "n" + "s" + "t"},
{0, 0, "o" + "p" + "u" + "v"}, {0, 1, "q" + "r" + "w" + "x"},
{1, -1, "E" + "F" + "y" + "z"}, {1, 0, "A" + "B" + "G" + "H"},
{1, 1, "C" + "D" + "I" + "J"}} *)


Given a vector and a specification n, the code will work only if the length of the vector is greater or equal to 4(2n+1)(2n+1). The "equal situation" has been shown above; for the "greater situation" the code will apply on the first 4(2n+1)(2n+1) components.

Timings

Here are some timings on my computer.

For n = 1 and an initial vector of length 36 ("equal situation")

Mean@Table[AbsoluteTiming[toNewVector[testvector, 1]][[1]], 1000]

(* 0.000367063 *)


For n = 2 and an initial vector of length 100 ("equal situation")

ltestvector = Array[v, 100];
Mean@Table[AbsoluteTiming[toNewVector[ltestvector, 2]][[1]], 1000]

(* 0.00105849 *)