Using a recursive function to conditionally aggregate a contingency table

In this post, we will show on a simple example the application of a recursive function. The problem that we want to solve is the following. We have a matrix of dimensions N x M. This can be, for example, a two-dimensional contingency table. Columns that have a mean value less than the set value must be added to the adjacent column. In the case where there are two adjacent columns the lower one is selected. This kind of problem can be resolved elegantly with the use of recursive functions.
In the example we will use the matrix 5 x 8. We will generate 40 integers in the interval from 1 to 9.

# Define a seed for the random number generator
set.seed(155)

# Create a matrix 5 x 8
mat <- matrix(ceiling(runif(40, 0, 9)), 5, 8)

# Name columns and rows of a newly created matrix
colnames(mat) <- LETTERS[1:8]
rownames(mat) <- letters[1:5] 

# Print the matrix 
print(mat)

  A B C D E F G H
a 8 3 9 8 6 5 5 3
b 4 7 2 5 5 1 4 6
c 7 6 2 5 3 2 7 8
d 7 5 5 8 2 5 8 8
e 5 5 2 2 2 8 3 5

We want to merge other columns with all columns with a mean value of less than 5. In this example, columns with mean values less than 5 are C, E and F. Column C must be added to column B (mean B < mean D) and column E must be added to column F (mean F < mean D). Since column F is added to column E, it is not necessary to merge it with other columns.

# Calculating columns mean values 
col_means <- round(colMeans(mat), 1) 

# Print the columns mean values 
print(t(as.matrix(col_means)))

       A   B C   D   E   F   G H
[1,] 6.2 5.2 4 5.6 3.6 4.2 5.4 6

First we will create an auxiliary merge_columns function that merges two columns according to the above described algorithm. Implementation of the function is in the appendix at the end of the post.
The recursive function will call itself as long as there is a column with a mean value less than 5.

collapsing_matrix <- function(mat, threshold) {
  col_means <- colMeans(mat)
  ind <- which(col_means < threshold)[1]
  
  if (!is.na(ind)) {
    mat <- merge_columns(mat, ind)
    
    # the function calls itself if there is a column 
    # with a mean value less than threshold
    collapsing_matrix(mat, threshold)
  } else {
    return(mat)
  }
}

By applying the function to the matrix defined above, we are getting the expected result.

# Generating a matrix according to a specified condition
new_mat <- collapsing_matrix(mat, threshold = 5) 

# Print the matrix 
print(new_mat)

  A B,C D E,F G H
a 8  12 8  11 5 3
b 4   9 5   6 4 6
c 7   8 5   5 7 8
d 7  10 8   7 8 8
e 5   7 2  10 3 5

The function can be applied to a matrix of any dimension. For instance, we have a matrix 5 x 20.

  A B C D E F G H I J K L M N O P Q R S T
a 8 3 9 8 6 5 5 3 8 3 9 8 6 5 5 3 8 3 9 8
b 4 7 2 5 5 1 4 6 4 7 2 5 5 1 4 6 4 7 2 5
c 7 6 2 5 3 2 7 8 7 6 2 5 3 2 7 8 7 6 2 5
d 7 5 5 8 2 5 8 8 7 5 5 8 2 5 8 8 7 5 5 8
e 5 5 2 2 2 8 3 5 5 5 2 2 2 8 3 5 5 5 2 2

The mean values of the columns of the matrix.

       A   B C   D   E   F   G H   I   J K   L   M   N   O P   Q   R S   T
[1,] 6.2 5.2 4 5.6 3.6 4.2 5.4 6 6.2 5.2 4 5.6 3.6 4.2 5.4 6 6.2 5.2 4 5.6

Result after calling the function collapsing_matrix() for threshold value 5.

  A B,C D E,F G H I J,K L M,N O P Q R,S T
a 8  12 8  11 5 3 8  12 8  11 5 3 8  12 8
b 4   9 5   6 4 6 4   9 5   6 4 6 4   9 5
c 7   8 5   5 7 8 7   8 5   5 7 8 7   8 5
d 7  10 8   7 8 8 7  10 8   7 8 8 7  10 8
e 5   7 2  10 3 5 5   7 2  10 3 5 5   7 2

With fewer changes in the R code, the recursive function in the appendix can be written so that instead of the mean value, different criterion could be used, for example, the minimum value.

Appendix

merge_columns <- function(mat, ind) {
  n_cols <- ncol(mat)
  col_ind <- 1:n_cols
  col_names <- colnames(mat)
  col_means <- colMeans(mat)
  
  if (ind == 1) {
    start <- NULL 
    i <- 0
    j <- 1
    end <- setdiff(col_ind, c(1,2))
  } else {
    if (ind == ncol(mat)) {
      start <- setdiff(col_ind, c(n_cols-1, n_cols))
      i <- -1
      j <- 0
      end <- NULL
    } else {
      mean_before <- col_means[ind-1]
      mean_after <- col_means[ind+1]
      if (mean_before <= mean_after) {
        start <- col_ind[col_ind < ind-1]
        i <- -1
        j <- 0
        end <- col_ind[col_ind > ind] 
      } else {
        start <- col_ind[col_ind < ind]
        i <- 0
        j <- 1
        end <- col_ind[col_ind > ind+1]
      }
    }
  }

  mat <- cbind(mat[,start], c(mat[,ind+i] + mat[,ind+j]), mat[,end])
  new_col_names <- c(col_names[start], paste(col_names[ind+i], col_names[ind+j], sep = ","), col_names[end])
  colnames(mat) <- new_col_names
  return(mat)
}