Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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]

enter image description here

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

enter image description here

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);
  Thread@List[interiorNumber, value]
 ]

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] &

enter image description here

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?

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

5 Answers 5

up vote 8 down vote accepted

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)$

share|improve this answer
    
♦,Wow,perfect!Thanks for replacing my many lines code with your two line code.It's amazed to me. –  ShutaoTang Jul 18 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 at 8:54
    
@ Mr.Wizard: very elegant. How do you copy the result of MatrixForm into the answer? –  Dr. Wolfgang Hintze Jul 18 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 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!! –  ShutaoTang Sep 5 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

enter image description here

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

enter image description here

share|improve this answer

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]]

enter image description here


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]]

enter image description here

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]]

enter image description here

share|improve this answer
    
Interesting approach. It seems this only works on an integer matrix however. –  Mr.Wizard Jul 18 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 at 8:51
    
@kguler,I think MapAt[Mean, ComponentMeasurements[data, "Neighbors"], {All, -1}] has a mistake. –  ShutaoTang Jul 18 at 8:56
    
@Mr.W, right. I think it can be tweaked to work with symbolic matrices too. –  kguler Jul 18 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)) –  kguler Jul 18 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

enter image description here

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

enter image description here

Example2

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

enter image description here

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

enter image description here

share|improve this answer
    
@Dr. Wolfgang Hintze,Thanks for your idea!! –  auto Jul 18 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 at 16:12
    
@Dr. Wolfgang Hintze,I use this method to discover the differences between two sets of data. –  ShutaoTang Jul 19 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] :=
 Module[{row, col, padded},
  {row, col} = Dimensions@mat;
  padded = ArrayPad[mat, 1];
  Array[ElementMean[padded, #1, #2, row, col] &, {row, col}]
 ]

Test

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

enter image description here

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

enter image description here

share|improve this answer
    
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 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 –  ShutaoTang Sep 12 at 6:38
1  
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 at 7:50
1  
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 at 7:52
1  
@Mr.Wizard,wow, the efficiency has improved 20 times :-) –  ShutaoTang Sep 12 at 8:20

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.