The Simplest Topic Allocation Algorithm in R

user_8833311 0
Viewed 132

I would like to allocate topics starting from their lowest popularity to highest. My data looks like this:

library(tidyverse)
data <- data.frame(topic = c("A", "B", "C", "D", "E"),
           id1 = c(1,2,3,1,2),
           id2 = c(3,3,2,1,3),
           id3 = c(1,1,3,3,2),
           id4 = c(3,1,2,2,1),
           id5 = c(2,2,1,3,1),
           id6 = c(3,1,1,1,3)) %>%
  mutate(popularity = rowSums(. == 3),) %>%
  arrange(popularity) 

  topic id1 id2 id3 id4 id5 id6 popularity
1     B   2   3   1   1   2   1          1
2     C   3   2   3   2   1   1          2
3     D   1   1   3   2   3   1          2
4     E   2   3   2   1   1   3          2
5     A   1   3   1   3   2   3          3

With help of SO I am able to allocate the topic in each row to the first maximum value in that row. So what we did here is move the topic title from each row to the first occurence of value 3 (which is maximum is this case).

# create empty matrox of size of the data
my_matrix <- matrix(NA, nrow(data), ncol(data)-1)
# fill matrix with topic at first occurence of maximum value per row
my_matrix[cbind(seq_len(nrow(my_matrix)), max.col(data[,-1], 'first'))] <- data$topic

     [,1] [,2] [,3] [,4] [,5] [,6]
[1,] NA   "B"  NA   NA   NA   NA  
[2,] "C"  NA   NA   NA   NA   NA  
[3,] NA   NA   "D"  NA   NA   NA  
[4,] NA   "E"  NA   NA   NA   NA  
[5,] NA   "A"  NA   NA   NA   NA

That's almost perfect despite the fact that multiple topics have been assigned to one id (person). I am looking for a loop or a sopihsticated ifelse that does the max.col(data[,-1], 'first')) <- data$topic substitution and remembers that column 2 (id2) is already served. The expected outcome should be:

     [,1] [,2] [,3] [,4] [,5] [,6]
[1,] NA   "B"  NA   NA   NA   NA  
[2,] "C"  NA   NA   NA   NA   NA  
[3,] NA   NA   "D"  NA   NA   NA  
[4,] NA   NA   NA   NA   NA   "E"  
[5,] NA   NA   NA   NA   "A"   NA

In the end, every topic is allocated only once, to someone who had a maximum preference for this topic.

r algorithm loops
4 Answers

I think this is a classical assignment problem in graph theory, and you can use max_bipartite_match from igraph to solve it

library(igraph)
library(dplyr)

mat <- data %>%
  select(-topic) %>%
  `row.names<-`(seq(nrow(.))) %>%
  `==`(3)

res <- mat %>%
  graph_from_incidence_matrix() %>%
  set_vertex_attr(name = "type", value = startsWith(names(V(.)), "id")) %>%
  max_bipartite_match() %>%
  pluck("matching") %>%
  subset(startsWith(names(.), "id")) %>%
  stack() %>%
  arrange(as.numeric(values)) %>%
  na.omit() %>%
  as.matrix() %>%
  replace(x = NA * mat, values = data$topic)

such that

> res
  id1 id2 id3 id4 id5 id6
1 NA  "B" NA  NA  NA  NA
2 "C" NA  NA  NA  NA  NA
3 NA  NA  "D" NA  NA  NA
4 NA  NA  NA  NA  NA  "E"
5 NA  NA  NA  "A" NA  NA
user_121587570

I suspect there's a better way to do this with the purrr package, but this for loop will work well enough for small data:

#gather the data into a long format and store it in a temporary data frame
temp <- data %>% 
  gather(-topic, key = id, value = preference) %>% 
  #sort so that the higher rows are most desired
  arrange(desc(preference), id, topic)

#create an empty tibble to store results
results <- tibble()

#loop through every id
for(i in unique(temp$id)){
  #capture the highest preference topic for that id
  one_result <- temp %>% 
    filter(id == i) %>% 
    slice(1)
  
  #remove that id and topic from the temp data frame,
  #this way neither can be chosen again
  temp <- temp %>% 
    filter(topic != one_result$topic,
           id != one_result$id)
  
  #Store the results
  results <- results %>% 
    bind_rows(one_result)
}

results
# A tibble: 5 x 3
topic id    preference
<fct> <chr>      <dbl>
1 C     id1            3
2 A     id2            3
3 D     id3            3
4 B     id4            1
5 E     id5            1
user_86776010

The below is a tidyverse option that does not work as specified. But the result is seemingly compatible with what you are after in the sense that "In the end, every topic is allocated only once, to someone who had a maximum preference for this topic".

library(tidyverse)

data %>%
  pivot_longer(-topic) %>%
  group_by(topic) %>%
  mutate(grpMax = value == max(value),
         id = str_c(name, value)) %>%
  ungroup() %>%
  mutate(rowNumber = row_number(),
         X = pmap_lgl(list(id, rowNumber, grpMax), 
                      ~ ! ..1 %in% id[1: ..2 - 1] & ..3 == T)) %>%
  group_by(topic) %>%
  filter(X == T) %>%
  slice_head() %>%
  select(topic, name)
           
# # A tibble: 5 x 2
# # Groups:   topic [5]
#   topic name 
#   <chr> <chr>
# 1 A     id4  
# 2 B     id2  
# 3 C     id1  
# 4 D     id5  
# 5 E     id6
user_128202050

Here is a base R approach.

Using apply get all positions (ids) where the value is equal to the maximum value. A vector cols will contain possible positions available for assignment of a topic.

Looping by rows, get the minimum position for a given row, assign the topic to the corresponding position, and then remove from available positions.

my_matrix <- matrix(NA, nrow(data), ncol(data) - 1)
my_max <- apply(data[-1], 1, function(x) which(x == max(x)))

cols <- seq_len(ncol(data) - 1)

for (i in seq_len(nrow(data))) {
  pos_min <- min(intersect(my_max[[i]], cols))
  my_matrix[i, pos_min] <- data$topic[i]
  cols <- setdiff(cols, pos_min)
}

Output

     [,1] [,2] [,3] [,4] [,5] [,6]
[1,] NA   "B"  NA   NA   NA   NA  
[2,] "C"  NA   NA   NA   NA   NA  
[3,] NA   NA   "D"  NA   NA   NA  
[4,] NA   NA   NA   NA   NA   "E" 
[5,] NA   NA   NA   "A"  NA   NA
user_34606700
Related