# Computing the average over the values of the boxes surrounding a box in a grid

Recenty,I encounter a problem described as below:

I have a table that owns many boxes,and each box has a sequence like 1,2,3,4,etc.In addition,every box has a value.

Now I want to make the value of a box become the average of the values of boxes that arounding it.

For example,

the value of box 1 become the average ofthe values of box 2,11,12,

the value of box 11 become the average ofthe values of box 1,2,12,22,21

the value of box 14 become the average ofthe values of box 3,4,5,13,15,23,24,25

Grid[Reverse@Partition[Range[80], 10], Frame -> All]


sequenceValue = Thread@List[Range[80], RandomInteger[{0, 1}, 80]];
Reverse@Partition[sequenceValue, 10] // Grid[#, Frame -> All] &


### My trial

Extract the sequence of the boundary of table

ExtractBoundarySequence[length_, width_] := Block[
{bottomData, topData, leftData, rightData, cornerData},
bottomData = Range[2, length - 1];
topData = Range[2 + (width - 1) length, width*length - 1];
leftData = Range[1 + length, 1 + (width - 2) length, length];
rightData = Range[2 length, (width - 1) length, length];
cornerData = {1, length, 1 + (width - 1) length, width*length};
List[cornerData, bottomData, topData, leftData, rightData]
]


Extract the sequence of the innerior of table

ExtractInteriorSequence[length_, width_] := Block[
{},
DeleteCases[
Flatten@Table[{# - 1, #, # + 1} + i *length, {i, -1, 1}], #] & /@
Flatten@Table[Range[2 + length, 2 length - 1]+(i - 1)length , {i, 1, width - 2}]
]


Caculate the value of the boundary of table

 CalculateBoundaryValue[SequenceValue_, length_, width_] := Block[
{corner, bottom, top, left, right,
cornerSequence, bottomSequence, topSequence, leftSequence, rightSequence,
value1, value2},
{corner, bottom, top, left, right} =ExtractBoundarySequence[length, width];
bottomSequence = DeleteCases[
Flatten@Table[{# - 1, #, # + 1} + i *length, {i, 0, 1}], #] & /@bottom;
topSequence = DeleteCases[
Flatten@Table[{# - 1, #, # + 1} + i *length, {i, -1, 0}], #] & /@top;
leftSequence = DeleteCases[
Flatten@Table[{#, # + 1} + i *length, {i, -1, 1}], #] & /@ left;
rightSequence = DeleteCases[
Flatten@Table[{# - 1, #} + i *length, {i, -1, 1}], #] & /@ right;

value1 =
Mean /@ (Flatten[
Map[Part[SequenceValue[[All, 2]], #] &,
{bottomSequence, topSequence, leftSequence,
rightSequence}, {2}], 1]);

cornerSequence =
{
DeleteCases[
Flatten@Table[{#, # + 1} + i*length, {i, 0, 1}], #] &[corner[[1]]],
DeleteCases[
Flatten@Table[{# - 1, #} + i *length, {i, 0, 1}], #] &[corner[[2]]],
DeleteCases[
Flatten@Table[{#, # + 1} + i *length, {i, -1, 0}], #] &[corner[[3]]],
DeleteCases[
Flatten@Table[{# - 1, #} + i *length, {i, -1, 0}], #] &[corner[[4]]]
};

value2 =
Mean /@ (Part[SequenceValue[[All, 2]], #] & /@ cornerSequence);

Thread@List[Flatten@{corner, bottom, top, left, right}, Join[value2, value1]]
]


Caculate the value of the innerior of table

 CalculateInteriorValue[SequenceValue_, length_, width_] := Block[
{interiorSequence, interiorNumber, value},
interiorSequence =
ExtractInteriorSequence[length, width];
interiorNumber =
Flatten@Table[Range[2 + length, 2 length - 1]+(i - 1)length, {i, 1, width - 2}];
value =
Mean /@ ((Part[SequenceValue[[All, 2]], #] &) /@ interiorSequence);
]


Final sequence-v-alue

NewSequenceValue[SequenceValue_, length_, width_] := Block[
{NewBoundaryData, NewInteriorData},
NewBoundaryData =
CalculateBoundaryValue[SequenceValue, length, width];
NewInteriorData =
CalculateInteriorValue[SequenceValue, length, width];
SortBy[Join[NewBoundaryData, NewInteriorData], First]
]


Using my function:

Reverse@Partition[NewSequenceValue[sequenceValue, 10, 8], 10] //Grid[#, Frame -> All] &


and it can achieve the result.

However, I think my method is a little tedious, so my question: is there a better algorithm (method) to solve my problem?

-
Prescribe just a value (e.g. 0 or 1) to all boxes and you are done. –  Artes Jul 18 '14 at 8:12
@Artes,OK,I have edided my question,Thanks for your suggestion! –  Shutao Tang Jul 18 '14 at 8:37
Closely related question without the complication of not counting the central value: (28240) –  Mr.Wizard Jul 18 '14 at 9:03

A bit blunt but I believe it works, it is flexible, and it should be pretty fast:

averages[m_?MatrixQ] :=
With[{ker = 1 - BoxMatrix[0, 3]},
Divide @@ (ListCorrelate[ker, #, {2, -2}, 0] & /@ {m, ConstantArray[1, Dimensions@m]})
]


ker is the kernel of the convolution (or correlation), in this case:

1 - BoxMatrix[0, 3]

{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}


Which represents every element in a 3x3 neighborhood except the central one.

This works on any regtangular array; applying it to a matrix of strings for illustration:

data = Partition[CharacterRange["a", "o"], 3];
data // MatrixForm


$\left( \begin{array}{ccc} \text{a} & \text{b} & \text{c} \\ \text{d} & \text{e} & \text{f} \\ \text{g} & \text{h} & \text{i} \\ \text{j} & \text{k} & \text{l} \\ \text{m} & \text{n} & \text{o} \\ \end{array} \right)$

averages[data] // MatrixForm


$\left( \begin{array}{ccc} \frac{1}{3} (\text{b}+\text{d}+\text{e}) & \frac{1}{5} (\text{a}+\text{c}+\text{d}+\text{e}+\text{f}) & \frac{1}{3} (\text{b}+\text{e}+\text{f}) \\ \frac{1}{5} (\text{a}+\text{b}+\text{e}+\text{g}+\text{h}) & \frac{1}{8} (\text{a}+\text{b}+\text{c}+\text{d}+\text{f}+\text{g}+\text{h}+\text{i}) & \frac{1}{5} (\text{b}+\text{c}+\text{e}+\text{h}+\text{i}) \\ \frac{1}{5} (\text{d}+\text{e}+\text{h}+\text{j}+\text{k}) & \frac{1}{8} (\text{d}+\text{e}+\text{f}+\text{g}+\text{i}+\text{j}+\text{k}+\text{l}) & \frac{1}{5} (\text{e}+\text{f}+\text{h}+\text{k}+\text{l}) \\ \frac{1}{5} (\text{g}+\text{h}+\text{k}+\text{m}+\text{n}) & \frac{1}{8} (\text{g}+\text{h}+\text{i}+\text{j}+\text{l}+\text{m}+\text{n}+\text{o}) & \frac{1}{5} (\text{h}+\text{i}+\text{k}+\text{n}+\text{o}) \\ \frac{1}{3} (\text{j}+\text{k}+\text{n}) & \frac{1}{5} (\text{j}+\text{k}+\text{l}+\text{m}+\text{o}) & \frac{1}{3} (\text{k}+\text{l}+\text{n}) \\ \end{array} \right)$

-
♦,Wow,perfect!Thanks for replacing my many lines code with your two line code.It's amazed to me. –  Shutao Tang Jul 18 '14 at 8:50
@Tangshutao Glad I could help. :-) Be sure to read the documentation for ListCorrelate so that you understand how this works. Pay careful attention to the alignment argument (here {2, -2}) as it's a bit confusing at least to me, and you will need to change it if you use a kernel of a different size. –  Mr.Wizard Jul 18 '14 at 8:54
@ Mr.Wizard: very elegant. How do you copy the result of MatrixForm into the answer? –  Dr. Wolfgang Hintze Jul 18 '14 at 9:40
@Dr.WolfgangHintze Thanks! Select the output, right-click, and choose Copy As... > LaTeX. Then paste between $ signs in the editor, e.g. $\{1,2\}$. – Mr.Wizard Jul 18 '14 at 9:50 @Mr.Wizard,I thought your advanced method was only suitable for 3$\times$3 matrix when you gived the answer right now. However,toady I want to understand your program and try to extend to m$\times$n matrix, I discover that it also suitable to m \times n matrix. Although I cannot understand the two dimensions correlate(I have master the usage of ListCorrelate in one dimension now).Thanks!! – Shutao Tang Sep 5 '14 at 8:28 This answer is slightly shorter but still not very elegant. Let m(i,j), i,j, = 1 ... n be your matrix and let us first define the number nc[] (not elegant) of cells to added in each case nc[i_, j_, n_] := 3 /; (i == 1 && j == 1) || (i == 1 && j == n) || (i == n && j == 1) || (i == n && j == n) nc[i_, j_, n_] := 5 /; (i == 1 && 1 < j < n) || (i == n && 1 < j < n) || (1 < i < n && j == 1) || (1 < i < n && j == n) nc[i_, j_, n_] := 8 /; (1 < i < n && 1 < j < n)  Check Table[nc[i, j, 3], {i, 1, 3}, {j, 1, 3}] {{3, 5, 3}, {5, 8, 5}, {3, 5, 3}}  Now, for a given cell {i,j} define the average of all apropriate neighbouring cells: s[i_, j_, n_] := 1/nc[i, j, n] (Sum[m[i + u, j + v], {u, -1, 1}, {v, -1, 1}] - m[i, j]) /. {m[ 0, _] -> 0, m[_, 0] -> 0, m[n + 1, _] -> 0, m[_, n + 1] -> 0}  Notice that (1) in order to keep the Sum simple we need to subtract the element m[i,j] (not elegant) (2) we have put all elements of m beyond the "border" equal to zero Check the result in symbolic form With[{n = 3}, Table[s[i, j, n], {i, 1, n}, {j, 1, n}]] {{(1/3)*(m[1, 2] + m[2, 1] + m[2, 2]), (1/5)*(m[1, 1] + m[1, 3] + m[2, 1] + m[2, 2] + m[2, 3]), (1/3)*(m[1, 2] + m[2, 2] + m[2, 3])}, {(1/5)*(m[1, 1] + m[1, 2] + m[2, 2] + m[3, 1] + m[3, 2]), (1/8)*(m[1, 1] + m[1, 2] + m[1, 3] + m[2, 1] + m[2, 3] + m[3, 1] + m[3, 2] + m[3, 3]), (1/5)*(m[1, 2] + m[1, 3] + m[2, 2] + m[3, 2] + m[3, 3])}, {(1/ 3)*(m[2, 1] + m[2, 2] + m[3, 2]), (1/5)*(m[2, 1] + m[2, 2] + m[2, 3] + m[3, 1] + m[3, 3]), (1/ 3)*(m[2, 2] + m[2, 3] + m[3, 2])}} % // MatrixForm (* not displayed here *)  Now with a numerical matrix m With[{n = 3}, Table[m[i, j] = Random[Integer, {1, 17}], {i, 1, n}, {j, 1, n}]] {{14, 10, 10}, {14, 2, 4}, {1, 1, 3}} With[{n = 3}, Table[s[i, j, n], {i, 1, n}, {j, 1, n}]] {{7, 6, 9}, {49/5, 81/8, 43/5}, {16/3, 44/5, 22/3}} % // MatrixForm (* not displayed here *)  Regards, Wolfgang # Edit,@Wolfgang 's method just for$m_{n \times n}$Here,editing the former method and make it applicable for$A_{m \times n}$nc1[i_, j_, m_,n_] := 3 /; (i == 1 && j == 1) || (i == 1 && j == n) || (i == m && j == 1) || (i == m && j == n) nc1[i_, j_,m_, n_] := 5 /; (i == 1 && 1 < j < n) || (i == m && 1 < j < n) || (1 < i < m && j == 1) || (1 < i < m && j == n) nc1[i_, j_,m_, n_] := 8 /; (1 < i < m && 1 < j < n) $\sum_{u=-1}^{1}\sum_{v=-1}^{1} A_{(i+u)(j+v)}-A_{ij}\$

 s[i_, j_,m_,n_] :=
1/nc[i, j,m, n] (Sum[A[i + u, j + v], {u, -1, 1}, {v, -1, 1}] - A[i, j]) /. {A[
0, _] -> 0, A[_, 0] -> 0, A[m + 1, _] -> 0, A[_, n + 1] -> 0}


Example

Array[A, {2, 3}] // MatrixForm


Table[s1[i, j, 2, 3], {i, 1, 2}, {j, 1, 3}] // MatrixForm


-

Update 2: For arbitrary matrices, one can use a relabeling function like numbering (from this answer by Yu-Sung) to produce a matrix with no duplicate elements, and proceed as in the original post:

 dataB = Partition[RandomChoice[CharacterRange["a", "z"], 20], 4];
numbering[x_] := Block[{n = 0}, Replace[x, y_ :> ++n, {-1}]];

dataB2 = numbering@dataB;
dataB2 = (dataB2 /.  MapAt[Mean[Flatten[dataB][[#]]] &,
ComponentMeasurements[dataB2, "Neighbors"], {All, -1}]);
Row[Grid[#, Frame -> All] & /@ {dataB, dataB2}, Spacer[5]]


Original post: If data does not have any duplicates:

data = Reverse@Partition[Range[80], 10];
data2 = (data /. MapAt[Mean, ComponentMeasurements[data, "Neighbors"], {All, -1}] // N);
Row[Grid[#, Frame -> All] & /@ {data, data2}, Spacer[5]]


Update: Working with symbolic matrices

dataA = Reverse@Partition[CharacterRange["a", "z"], 4];

dataA2 = (ArrayComponents@dataA /. MapAt[Mean[Flatten[dataA][[#]]] &,
ComponentMeasurements[ArrayComponents@dataA, "Neighbors"], {All, -1}]);

Row[Grid[#, Frame -> All] & /@ {dataA, dataA2}, Spacer[5]]


-
Interesting approach. It seems this only works on an integer matrix however. –  Mr.Wizard Jul 18 '14 at 8:46
I don't seem to get the same results from this method as I do from mine. I'm not sure which is correct (if either). The inability to apply this to a symbolic matrix makes it harder to see what's going on here. –  Mr.Wizard Jul 18 '14 at 8:51
@kguler,I think MapAt[Mean, ComponentMeasurements[data, "Neighbors"], {All, -1}] has a mistake. –  Shutao Tang Jul 18 '14 at 8:56
@Mr.W, right. I think it can be tweaked to work with symbolic matrices too. –  kglr Jul 18 '14 at 8:57
@Tangshutao, do you get an error message? (It works fine form me --Version 9.0.1.0 Windows 8.0 64 bit)) –  kglr Jul 18 '14 at 8:59

This idea comes from @Dr. Wolfgang Hintze

Solving the coefficient of mean

meanCoefficient[i_, j_, m_, n_] :=
8 /; (1 < i < m && 1 < j < n)

meanCoefficient[i_, j_, m_, n_] :=
3 /; (i == 1 && j == 1) || (i == 1 && j == n) || (i == m &&
j == 1) || (i == m && j == n);

meanCoefficient[i_, j_, m_, n_] :=
5 /; (i == 1 && 1 < j < n) || (i == m && 1 < j < n) || (1 < i < m &&
j == 1) || (1 < i < m && j == n);


Soling every average value of each grid

MyMean[matrix_, i_, j_, m_, n_] :=
1/meanCoefficient[i, j, m, n] (
Sum[matrix[[i + 1 + u, j + 1 + v]], {u, -1, 1}, {v, -1, 1}]
-matrix[[i + 1, j +1]])


Showing result

FinalResult[matrix_, m_, n_] :=
Grid[
Reverse@Array[MyMean[matrix, #1, #2, 8, 10] &, {m, n}],Frame -> All]


Constructing the matrix

finalMatrix[data_,m_, n_] := Join[
List@Table[0, {n + 2}], Prepend[#, 0] & /@
Join[Reverse@Partition[data, n], List /@ Table[0, {m}], 2],
List@Table[0, {n + 2}]]


## Example1

mat =finalMatrix[Range@80,8, 10];
mat//MatrixForm


N@FinalResult[Reverse@mat, 8, 10]


## Example2

data = CharacterRange["a", "i"];
finalMatrix[data, 3, 3] // MatrixForm


FinalResult[Reverse@finalMatrix[data, 3, 3], 3, 3]


-
@Dr. Wolfgang Hintze,Thanks for your idea!! –  auto Jul 18 '14 at 14:54
@Tangshutao, welcome. Nice exercise. What's behind it, i.e. to which problem do you apply it? Might be a diffusion-like process ... ? –  Dr. Wolfgang Hintze Jul 18 '14 at 16:12
@Dr. Wolfgang Hintze,I use this method to discover the differences between two sets of data. –  Shutao Tang Jul 19 '14 at 10:47

Recently,I know the innral function ArrayPad, and I feel it is convenient in this queastion.

meanCoefficient[i_, j_, row_, col_] :=
8 /; (1 < i < row && 1 < j < col)

meanCoefficient[i_, j_, row_, col_] :=
3 /; (i == 1 && j == 1) || (i == 1 && j == col) || (i == row &&
j == 1) || (i == row && j == col);

meanCoefficient[i_, j_, row_, col_] :=
5 /; (i == 1 && 1 < j < col) || (i == row &&
1 < j < col) || (1 < i < row && j == 1) || (1 < i < row &&
j == col);


Computute the single element in a grid

ElementMean[mat_, i_, j_, row_, col_] :=
1/meanCoefficient[i, j, row, col] *
(Total[mat[[i ;; i + 2, j ;; j + 2]], 2] - mat[[i + 1, j + 1]])


### Final function:

FinalResult[mat_?MatrixQ] :=
{row, col} = Dimensions@mat;
Array[ElementMean[padded, #1, #2, row, col] &, {row, col}]
]


### Test

caseSmaple = Partition[CharacterRange["a", "o"], 5];
caseSmaple // MatrixForm


FinalResult[caseSmaple] // Grid[#, Frame -> All] &


-
This does work but unfortunately it is very inefficient. It seems to have about the same complexity as my code but it is several orders of magnitude slower. For example with big = RandomReal[99, {70, 90}]; my code averages[big] takes on average 0.0005 second while FinalResult[big] takes almost exactly two seconds. –  Mr.Wizard Sep 12 '14 at 4:06
@Mr.Wizard,OK, your solution is advanced and most optimized. In additional, I think the main time taken is the function meanCoefficient.To improve the efficiency, I should try to optimize the function meanCoefficient –  Shutao Tang Sep 12 '14 at 6:38
I don't think meanCoefficient is a major problem. Instead: (1) You are doing ArrayPad[mat, 1] for every iteration of Array when this should be done only once; this is the largest performance problem. (2) There are many (uncompiled) loops which are slow, e.g. the Sum could be replaced with Total[mat[[i ;; i + 2, j ;; j + 2]], 2], and the entire ElementMean should be made compilable for Array. (3) This does not use incremental addition; that is to say that the sums performed for each element are independent rather that reusing the sums from the adjacent elements. (continued) –  Mr.Wizard Sep 12 '14 at 7:50
ListCorrelate includes this optimization. It will become increasingly important as the size of the neighborhood increases. I can edit your post to improve issues (1) and (2) if you will let me, but I don't feel like reimplementing ListCorrelate to solve (3). –  Mr.Wizard Sep 12 '14 at 7:52
@Mr.Wizard,wow, the efficiency has improved 20 times :-) –  Shutao Tang Sep 12 '14 at 8:20