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! –  Tangshutao 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

4 Answers 4

up vote 4 down vote accepted

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

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.

Applying this function to a matrix of strings for illustration:

data = Partition[CharacterRange["a", "i"], 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} \\ \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}{3} (\text{d}+\text{e}+\text{h}) & \frac{1}{5} (\text{d}+\text{e}+\text{f}+\text{g}+\text{i}) & \frac{1}{3} (\text{e}+\text{f}+\text{h}) \\ \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. –  Tangshutao 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

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. –  Tangshutao 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!! –  taotao 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. –  Tangshutao Jul 19 at 10:47

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.