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.

[code lang=”r” firstline=”1″]
# 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)
[/code]

  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.

[code lang=”r” firstline=”13″]
# Calculating columns mean values
col_means <- round(colMeans(mat), 1)

# Print the columns mean values
print(t(as.matrix(col_means)))
[/code]

       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 [su_label]merge_columns[/su_label] 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.

[code lang=”r” firstline=”18″]
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)
}
}
[/code]

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

[code lang=”r” firstline=”32″]
# Generating a matrix according to a specified condition
new_mat <- collapsing_matrix(mat, threshold = 5)

# Print the matrix
print(new_mat)
[/code]

  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 [su_label]collapsing_matrix()[/su_label] 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

[code lang=”r”]
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)
}
[/code]