Theoretical model, version 02

Setting up a function to generate ideas

phase00 <- function(target, totAgents,totIdeas,clusters){
  
  set.seed(1) #Setting a seed to a fix number to allow comparable results
    agentsId <- as.integer(rnorm(totIdeas, totAgents/2, totAgents/10)) # Assigning an owner to each idea (this allows multiple ideas to one owner)
    
  set.seed(1) #Setting a seed again
    idea <- as.integer(runif(totIdeas, min = 0, max = target)) # Generating random numbers in a uniform distribution
  
  ideaClusters <- 1+as.integer(idea/(target/clusters)) #Extracting the cluster by dividing each number to the number of clusters
  agentsReward_01 <- rep(0,totIdeas) # A variable associated to phase 01
  agentsReward_02 <- rep(0,totIdeas) # A variable associated to phase 02
  ideas <- data.frame(agentsId, idea, ideaClusters,agentsReward_01,agentsReward_02) #Creating a dataframe with ID, value and cluster

  return(ideas)
}

Setting up a function to select ideas

phase01 <- function(clusters, ideas){

  #Creating a dataframe with Cluster ID, Winner ID and value
  idClusters <- seq(1:clusters)
  idWinners <- rep(NA, clusters)
  valueWinners <- rep(NA, clusters)
  listWinners <-  data.frame(idClusters, idWinners, valueWinners) 
  
  #Reward the owners of the selected ideas
  lenIdeas <- dim(ideas)[1]
  for (i in 1:lenIdeas) {
    j <- ideas[i, 3] # Check the cluster of the idea
    if (is.na(listWinners[j, 2])) {
    # If the cluster of the agent does not have a winner (it's value is NA) ...
    listWinners[j, 2] <- ideas[i, 1] # ... use the agent's ID
    listWinners[j, 3] <- ideas[i, 2] # ... use the idea's value
    ideas[i, 4] <- 1 +ideas[i, 4] # rewarding the selected agent by increasing the reward to 1 (taking into account multiple challenges)
    }
  }
  return(ideas)
}

Setting up a function to pool ideas

phase02 <- function (selectedIdeas, target) {

  library(lpSolve)
  ideas <- selectedIdeas
  listWinners <- filter(ideas, agentsReward_01 >0) #Filtering the list of winners before performing a left join with the pooled ideas

  #Linear programming
  objective.in <- listWinners[, 2] # Trying to pool the retained ideas by looking for the best combination of coefficients
  mat <-  matrix(listWinners[, 2], nrow = 1, byrow = TRUE) # The sum of the pooled ideas ...
  dir <- "<=" # ... should be below ...
  rhs <- target # ... the target
  optimum <-  lp(direction = "max", objective.in,  mat,  dir,  rhs,  all.bin = TRUE) # Which is the best combination of pooled ideas?
  optimum$solution # The selected ideas
  
  listWinners[,5] <- optimum$solution #Assign prizes
  polledIdeas <- ideas %>%
  left_join(listWinners, by = c("agentsId","idea","ideaClusters","agentsReward_01")) #Left join
  agentsReward_02 <- polledIdeas$agentsReward_02.x+ polledIdeas$agentsReward_02.y # Taking into account previous idea challenges
  polledIdeas <- data.frame(polledIdeas,agentsReward_02) #add the new column

  polledIdeas[5] <- NULL # Removing the redundant columns
  polledIdeas[5] <- NULL # Removing the redundant columns

  return(polledIdeas)
}

Setting up a function to summarize the rewards

phase03 <- function(ideas, target){
  library(tidyverse)
  agentsRewards <- ideas %>% 
    gather('agentsReward_01', 'agentsReward_02', key = "Phase", value = "Rewards")

  winners <- summarise(group_by(agentsRewards, agentsId, idea), Rewards = sum(Rewards, na.rm = TRUE))
    winners <- arrange(winners, idea) #Sorting ideas
    problemSolved <- sum(filter(winners, Rewards > 1)[, 2])
    
    #Print results for comparison
    print("filter(winners, Rewards >0)")
      print(filter(winners, Rewards > 0)) # Test: selected ideas
    print("Mean(winners$Rewards)")
      print(mean(winners$Rewards))
    print("Problem Solved")
      print(problemSolved)
    print("Remainder")
      print(target-problemSolved)
    
    return(agentsRewards)
}

Setting up a function to run an idea Challenge

ideaChallenge <- function(target, totAgents, totIdeas, clusters, sortedIdea) {
  
  generatedIdeas <- as.data.frame(seq(1:totIdeas))
  generatedIdeas <- phase00(target, totAgents, totIdeas, clusters) # Generating ideas

  if(sortedIdea) generatedIdeas <-arrange(generatedIdeas,desc(idea)) # Sorting ideas by experts

  selectedIdeas <- phase01(clusters, generatedIdeas) # Selecting ideas
  polledIdeas <- phase02(selectedIdeas, target) # Polling ideas 
  agentsRewards <- phase03(polledIdeas, target)
  return(agentsRewards)
}

Standard idea challenge Benchmark

target <- 1e9 # we set the target at 1'000'000'000
totAgents <- 1e3
totIdeas <- 1e4
clusters <- 1

generatedIdeas0 <- as.data.frame(seq(1:totIdeas))
generatedIdeas0 <- phase00(target, totAgents, totIdeas, clusters) # Generating ideas

generatedIdeas0 <-arrange(generatedIdeas0,desc(idea)) #Sorting ideas by experts

selectedIdeas0 <- phase01(clusters, generatedIdeas0) # Selecting ideas

agentsRewards0 <- selectedIdeas0 %>% 
    gather('agentsReward_01', 'agentsReward_02', key = "Phase", value = "Rewards")

winners <- dim(filter(agentsRewards0, Rewards>0))[1]
quality <-filter(agentsRewards0, Rewards==1)[,2]
prize <- mean(agentsRewards0$Rewards) * totAgents
challengeID <- "Single Winner"

performance <- data.frame(challengeID, winners, quality, prize)

performance$winners # Winners

## [1] 1

performance$quality # Sum of the pooled ideas

## [1] 999930593

performance$prize # Cost of prizes 

## [1] 0.05

First idea challenge

MODEL A: Selecting the first idea for each cluster

target <- 1e9 # we set the target at 1'000'000'000
totAgents <- 1e3
totIdeas <- 1e4
clusters <- 10

agentsRewards1_1 <- ideaChallenge(target, totAgents, totIdeas, clusters, FALSE)

## [1] "filter(winners, Rewards >0)"
## # A tibble: 10 x 3
## # Groups:   agentsId [10]
##    agentsId      idea Rewards
##       <int>     <int>   <dbl>
##  1      469  61786270       1
##  2      538 176556752       2
##  3      437 265508663       1
##  4      518 372123899       1
##  5      495 497699242       1
##  6      416 572853363       1
##  7      573 660797792       1
##  8      612 769841419       2
##  9      417 898389684       1
## 10      659 908207789       1
## [1] "Mean(winners$Rewards)"
## [1] 0.0012
## [1] "Problem Solved"
## [1] 946398171
## [1] "Remainder"
## [1] 53601829

Model B: Selecting the idea for each cluster with the highest score

agentsRewards2 <- ideaChallenge(target, totAgents, totIdeas, clusters, TRUE) #using sorted ideas

## [1] "filter(winners, Rewards >0)"
## # A tibble: 10 x 3
## # Groups:   agentsId [10]
##    agentsId      idea Rewards
##       <int>     <int>   <dbl>
##  1      359  99989993       2
##  2      508 199977182       1
##  3      486 299951496       1
##  4      617 399994368       2
##  5      474 499982866       2
##  6      552 599919136       1
##  7      469 699974252       1
##  8      468 799901459       1
##  9      544 899746668       1
## 10      578 999930593       1
## [1] "Mean(winners$Rewards)"
## [1] 0.0013
## [1] "Problem Solved"
## [1] 999967227
## [1] "Remainder"
## [1] 32773

New idea challenge starting from the remainder of the previous idea challenge

# Setting up the remainder as new target
  winners1_1 <-  summarise(group_by(agentsRewards1_1, agentsId, idea), Rewards = sum(Rewards, na.rm = TRUE))
  problemSolved1_1 <- sum(filter(winners1_1, Rewards > 1)[, 2]) 
  remainder1_1 <- target - problemSolved1_1

agentsRewards1_2 <- ideaChallenge(remainder1_1, totAgents, totIdeas, clusters, FALSE)

## [1] "filter(winners, Rewards >0)"
## # A tibble: 10 x 3
## # Groups:   agentsId [10]
##    agentsId     idea Rewards
##       <int>    <int>   <dbl>
##  1      469  3311857       1
##  2      538  9463764       2
##  3      437 14231749       1
##  4      518 19946521       1
##  5      495 26677589       1
##  6      416 30705988       1
##  7      573 35419970       1
##  8      612 41264908       2
##  9      417 48155330       1
## 10      659 48681598       1
## [1] "Mean(winners$Rewards)"
## [1] 0.0012
## [1] "Problem Solved"
## [1] 50728672
## [1] "Remainder"
## [1] 2873157

New idea challenge: Cheatstorming with the remainder

# agentsRewards1_3 <- ideaChallenge_Cheatstorming(remainder1_1, totAgents, totIdeas, clusters, agentsRewards1_1)  # Using old ideas

  target <- remainder1_1 # New target

  generatedIdeas<- agentsRewards1_1 %>%
    spread(key = Phase, value = Rewards)  # Putting the table back in shape
  
  generatedIdeas<-filter(generatedIdeas,idea<target) #Removing the ideas that are above the target  
  generatedIdeas$ideaClusters <- 1+as.integer(generatedIdeas$idea/(target/clusters))# New clusters

  generatedIdeas$agentsReward_01 <- 1/dim(generatedIdeas)[1] +generatedIdeas$agentsReward_01 # Reward all contributions in phase 01
  if(is.na(generatedIdeas$agentsReward_02)) {
    generatedIdeas$agentsReward_02 <- 0 # Remove NA from column 2
    }

  selectedIdeas <- generatedIdeas
  pooledIdeas <- phase02(selectedIdeas, target) # Pooling ideas
  agentsRewards <- phase03(pooledIdeas, target)

## [1] "filter(winners, Rewards >0)"
## # A tibble: 564 x 3
## # Groups:   agentsId [301]
##    agentsId    idea Rewards
##       <int>   <int>   <dbl>
##  1      465  106433 0.00177
##  2      546  120655 0.00177
##  3      342  200380 1.00   
##  4      569  570522 0.00177
##  5      405  605266 1.00   
##  6      573  656347 0.00177
##  7      510  668174 0.00177
##  8      585  682127 0.00177
##  9      320  918506 1.00   
## 10      309 1026818 0.00177
## # ... with 554 more rows
## [1] "Mean(winners$Rewards)"
## [1] 0.0141844
## [1] "Problem Solved"
## [1] 53601829
## [1] "Remainder"
## [1] 0

  filter(agentsRewards, Rewards>=1)

##   agentsId     idea ideaClusters           Phase Rewards
## 1      260  6082597            2 agentsReward_02       1
## 2      320   918506            1 agentsReward_02       1
## 3      342   200380            1 agentsReward_02       1
## 4      395  1836858            1 agentsReward_02       1
## 5      405   605266            1 agentsReward_02       1
## 6      545  1363479            1 agentsReward_02       1
## 7      776 42594743            8 agentsReward_02       1