Bounded rationality

Author

Hubert Baechli

Simulation of selected Meetings (by Knowledge and bounded rationality)

The time has come for the next big step! So far, the encounters have been purely random, but this is about to change. A first assumption is that the agents are pure utility maximisers of their preferred knowledge.

It seems utopian to believe that each agent knows exactly how much knowledge all other agents have, even if they work at different universities. For this reason, an ingroup and an outgroup are defined for the utility calculation, so that outside the university only the average knowledge of the university is known.

Definitions

Loading some Packages for easier Data management and Presentation of Results

Code

library(tidyverse)

── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.1     ✔ tibble    3.2.1
✔ lubridate 1.9.3     ✔ tidyr     1.3.1
✔ purrr     1.0.2     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

Code

# set.seed(1)

Generic Functions

update_Pop

Code

update_Pop <- function(Pop = Pop,
                       name = Parametername,
                       add = 0,
                       fac = 1,
                       set = FALSE) {

  if (set == FALSE & name %in% colnames(Pop)) {
    Pop <- Pop %>%
      mutate( !!name := ( .data[[name]] + add ) * fac )
  } else {
    Pop <- Pop %>%
      mutate( !!name := add * fac )
  }
  return(Pop)
}

sort_Pop

Code

sort_Colnames <- function(Pop = Pop,
                          name = name) {
    cols <- Pop %>%
      select(starts_with(name)) %>%
      colnames()
  
  if (length(cols) == 0) { return(character(0)) }
  return(sort(cols)) 
  }

Code

sort_Pop <- function(Pop = Pop,
                     sort_Par = TRUE,
                     clean_Par = FALSE,
                     sort_Agents = NA){
  if (sort_Par == TRUE) {
    Pop <- Pop %>%
      select(tidyselect::all_of(sort_Colnames(Pop = Pop, name = "ID")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Preference")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Agents")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "University")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Knowledge")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Counter")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Resources")),
             everything())
    }
  if (clean_Par == TRUE) {
    Pop <- Pop %>%
      select(tidyselect::all_of(sort_Colnames(Pop = Pop, name = "ID")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Preference")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Agents")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "University")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Knowledge")),
             tidyselect::all_of(sort_Colnames(Pop = Pop, name = "Counter")))
    }
  if (!is.na(sort_Agents)) {
    Pop <- Pop %>%
      arrange(across(all_of(sort_Agents)))
    }
  return(Pop)
}

update_Typ

Code

get_Typ <- function(Pop = Pop,
                    name = name){
  del_name <- paste0("^", name, "_")
  Typ <- Pop %>%
    select(starts_with(name)) %>%
    colnames() %>%
    str_remove(del_name) 
  return(Typ)
}

Code

update_Typ <- function(Pop = Pop,
                       name = Parametername,
                       Typ = Typ,
                       add = 0,
                       fac = 1,
                       set = FALSE) {
  sep <- "_"
  if (name == "") {sep <- ""}
  
  if (length(Typ) != length(add)) {
    add <- rep(add, length(Typ))
  }
  if (length(Typ) != length(fac)) {
    fac <- rep(fac, length(Typ))
  }
  if (length(Typ) != length(set)) {
    set <- rep(set, length(Typ))
  }
  for (i in seq_along(Typ)) {
    name_i <- paste(name, Typ[[i]], sep = sep)
    Pop <- update_Pop(Pop = Pop, 
                      name = name_i, 
                      add = add[[i]],
                      fac = fac[[i]],
                      set = set[[i]])
    }
  Pop <- sort_Pop(Pop = Pop)
  return(Pop)
}

Transform Population-Matrix

Code

del_tmp <- function(Pop = Pop,
                    name = "tmp_"){
  Pop <- Pop %>%
    select(-starts_with(name))
  return(Pop)
}

Code

longer_Pop <- function(Pop = Pop,
                       name = name){
  syntax_remove <- paste0(name, "_")
  Pop_long <- Pop %>%
  pivot_longer(cols = starts_with(name),
               names_to = "Typ",
               names_prefix = syntax_remove,  
               values_to = name )
  return(Pop_long)
}

Code

wider_Pop <- function(Pop_long = Pop_long,
                      name = name){
  syntax_add <- paste0(name, "_")
  Pop <- Pop_long %>%
    pivot_wider(names_from = Typ,
                values_from = starts_with(name),
                names_prefix = syntax_add)
  return(Pop)
}

Calculated Agents Information

update_Agents_Learnrate

Code

update_Agents_Learnrate <- function(Pop = Pop,
                                    sort_Par = TRUE,
                                    clean_Par = FALSE,
                                    sort_Agents = NA){
  Pop_long <- longer_Pop(Pop = Pop, name = "Knowledge")
  Pop_long <- Pop_long %>%
    group_by(ID) %>%
    mutate(tmp_Rank = rank(Knowledge, ties.method = "random"),
           tmp_Rank = max(tmp_Rank) - tmp_Rank + 1,
           tmp_Rank = 0.5 ^ tmp_Rank,
           tmp_LR = Knowledge * tmp_Rank,
           tmp_LR = max(sum(tmp_LR),1E-3),
           tmp_KxR = max(Knowledge) * sum(tmp_Rank),
           tmp_Profile = (min(tmp_LR / tmp_KxR, 1) - 0.25),
           tmp_Profile = (min(tmp_LR / tmp_KxR, 1) - 0.5) * 2,
           Agents_Learnrate_Topic = tmp_LR,
           Agents_Learnrate_Others = tmp_LR * tmp_Profile) %>%
    ungroup() 
  Pop_long <- del_tmp(Pop = Pop_long)
  Pop <- wider_Pop(Pop_long = Pop_long, name = "Knowledge")
  Pop <- sort_Pop(Pop = Pop,
                  sort_Par = sort_Par,
                  clean_Par = clean_Par,
                  sort_Agents = sort_Agents)
  return(Pop)
}

update_Agents_Topic

Code

update_Agents_Topic <- function(Pop = Pop,
                                sort_Par = TRUE,
                                clean_Par = FALSE,
                                sort_Agents = NA){
  Typs <- get_Typ(Pop = Pop, name = "Knowledge")
  Pop_long <- longer_Pop(Pop = Pop, name = "Knowledge")
  Pop_long <- Pop_long %>%
    group_by(ID) %>%
    mutate(tmp_Rank = rank(Knowledge, ties.method = "random"),
           tmp_Rank = max(tmp_Rank) - tmp_Rank + 1,
           tmp_Rank = 0.5 ^ tmp_Rank,
           Agents_Topic = case_when(
             Preference %in% Typs ~ Preference,
             Preference == "All" ~ Typ[which.min(tmp_Rank)],
             TRUE ~ Typ[which.max(tmp_Rank)])) %>%
    ungroup() 
  Pop_long <- del_tmp(Pop = Pop_long)
  Pop <- wider_Pop(Pop_long = Pop_long, name = "Knowledge")
  Pop <- sort_Pop(Pop = Pop,
                  sort_Par = sort_Par,
                  clean_Par = clean_Par,
                  sort_Agents = sort_Agents)
  return(Pop)
}

Calculated University Information

update_University_Learnrate

Code

update_University_Learnrate <- function(Pop = Pop,
                                        sort_Par = TRUE,
                                        clean_Par = FALSE,
                                        sort_Agents = NA){
  Pop_long <- longer_Pop(Pop = Pop, name = "Knowledge")
  Pop_long <- Pop_long %>%
    group_by(Typ, ID_University) %>%
    mutate(tmp_Knowledge = mean(Knowledge)) %>%
    group_by(ID_University) %>%
    mutate(tmp_Rank = rank(tmp_Knowledge, ties.method = "random"),
           tmp_Rank = max(tmp_Rank) - tmp_Rank + 1,
           tmp_Rank = 0.5 ^ tmp_Rank,
           tmp_LR = tmp_Knowledge * tmp_Rank,
           tmp_LR = max(sum(tmp_LR),1E-3),
           tmp_KxR = max(tmp_Knowledge) * sum(tmp_Rank),
           tmp_Profile = (min(tmp_LR / tmp_KxR, 1) - 0.25),
           tmp_Profile = (min(tmp_LR / tmp_KxR, 1) - 0.5) * 2,
           University_Learnrate_Topic = tmp_LR,
           University_Learnrate_Others = tmp_LR * tmp_Profile) %>%
    ungroup() 
  Pop_long <- del_tmp(Pop = Pop_long)
  Pop <- wider_Pop(Pop_long = Pop_long, name = "Knowledge")
  Pop <- sort_Pop(Pop = Pop,
                  sort_Par = sort_Par,
                  clean_Par = clean_Par,
                  sort_Agents = sort_Agents)
  return(Pop)
}

update_University_Topic

Code

update_University_Topic <- function(Pop = Pop,
                                    sort_Par = TRUE,
                                    clean_Par = FALSE,
                                    sort_Agents = NA){
  Typs <- get_Typ(Pop = Pop, name = "Knowledge")
  Pop_long <- longer_Pop(Pop = Pop, name = "Knowledge")
  Pop_long <- Pop_long %>%
    group_by(Typ, ID_University) %>%
    mutate(tmp_Knowledge = mean(Knowledge)) %>%
    group_by(ID_University) %>%
    mutate(tmp_Rank = rank(tmp_Knowledge, ties.method = "random"),
           tmp_Rank = max(tmp_Rank) - tmp_Rank + 1,
           tmp_Rank = 0.5 ^ tmp_Rank,
           University_Topic = Typ[which.max(tmp_Rank)]) %>%
    ungroup() 
  Pop_long <- del_tmp(Pop = Pop_long)
  Pop <- wider_Pop(Pop_long = Pop_long, name = "Knowledge")
  Pop <- sort_Pop(Pop = Pop,
                  sort_Par = sort_Par,
                  clean_Par = clean_Par,
                  sort_Agents = sort_Agents)
  return(Pop)
}

Generate grouped Population

Code

gen_Pop <- function(addToPop = NULL,
                    nA = NumberOfAgents,
                    Preference = "Max",
                    ID_University = ID_University,
                    K = Knowledge,
                    Typ = SpezKnowledge,
                    pWD = percentsWorkingaDay,
                    pMD = percentsMeetingsaDay){
  ID <- seq_len(nA)
  Pop <- tibble(ID = ID,
                ID_University = ID_University,
                Preference = Preference)
  Pop <- update_Typ(Pop = Pop, 
                    name = "Agents", 
                    Typ = list("p_WorkDay", "p_MeetDay"),
                    add = list(pWD, pMD),
                    set = TRUE)
  Pop <- update_Typ(Pop = Pop, 
                    name = "Knowledge", 
                    Typ = Typ, 
                    add = K,
                    set = TRUE)

  if (!is.null(addToPop)) {
    Pop <- Pop %>%
      mutate(ID = ID + max(addToPop$ID))
    Typ_add <- get_Typ(Pop = addToPop, name = "Knowledge")
    Pop <- update_Typ(Pop = Pop, 
                      name = "Knowledge", 
                      Typ = Typ_add, 
                      add = 0)
    addToPop <- update_Typ(Pop = addToPop, 
                           name = "Knowledge", 
                           Typ = Typ, 
                           add = 0)
    Pop <- bind_rows(addToPop,Pop)
    }
  Pop <- update_Agents_Learnrate(Pop = Pop)
  Pop <- update_Agents_Topic(Pop = Pop)
  Pop <- update_University_Learnrate(Pop = Pop)
  Pop <- update_University_Topic(Pop = Pop)
  Pop <- sort_Pop(Pop = Pop)
  return(Pop)
  }

Code

Pop <- gen_Pop( nA = 3, 
                Preference = "Max",
                ID_University = "Zürich",
                K = list(0.01, 0.2), 
                Typ = list("M1", "M2"), 
                pWD = 0.5,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 2, 
                Preference = "All",
                ID_University = "Bern",
                K = list(0.01, 0.2), 
                Typ = list("M3", "M2"), 
                pWD = 0.2,
                pMD = 0.5)
Pop <- gen_Pop( addToPop = Pop,
                nA = 1, 
                Preference = "M3",
                ID_University = "Bern",
                K = list(0.8), 
                Typ = list("M3"), 
                pWD = 0.2,
                pMD = 0.5)
Pop <- gen_Pop( addToPop = Pop,
                nA = 1, 
                Preference = "M1",
                ID_University = "Bern",
                K = list(0.3, 0.3, 0.3), 
                Typ = list("M1", "M2", "M3"), 
                pWD = 0.2,
                pMD = 0.5)
Pop <- gen_Pop( addToPop = Pop,
                nA = 1,
                ID_University = "Bern",
                K = list(0.0, 0.0, 0.0), 
                Typ = list("M1", "M2", "M3"), 
                pWD = 0.2,
                pMD = 0.5)
Pop

# A tibble: 8 × 14
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                         0.0176                  0.103
2     2 Zürich        Max                         0.0176                  0.103
3     3 Zürich        Max                         0.0176                  0.103
4     4 Bern          All                         0.0176                  0.103
5     5 Bern          All                         0.0176                  0.103
6     6 Bern          M3                          0.0571                  0.4  
7     7 Bern          M1                          0.262                   0.262
8     8 Bern          Max                         0.001                   0.001
# ℹ 9 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>

Simulation parameter

reset_Counter

Code

reset_Counter <- function(Pop = Pop){
  Pop <- update_Typ(Pop = Pop,
                    name = "Counter",
                    Typ = list("Day", 
                               "Time_total",
                               "Time_meet",
                               "Time_learnd",
                               "Number_meet"),
                    add = 0,
                    set = TRUE)
  return(Pop)
}

update_Resources

Code

update_Resources <- function(Pop = Pop,
                             time_day = hoursDay,
                             set = TRUE){
  tmp_Time <- time_day * Pop[["Agents_p_WorkDay"]]
  tmp_p <- Pop[["Agents_p_MeetDay"]]
  Pop <- update_Typ(Pop = Pop,
                  name = "Resources",
                  Typ = list("Time_total",
                             "Time_meet",
                             "Time_learnd"),
                  add = list(tmp_Time,
                             tmp_Time * tmp_p,
                             tmp_Time * (1-tmp_p)),
                  set = set)
  return(Pop)
}

Code

Pop <- reset_Counter(Pop = Pop)
Pop <- update_Resources(Pop = Pop, time_day = 8)
Pop

# A tibble: 8 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                         0.0176                  0.103
2     2 Zürich        Max                         0.0176                  0.103
3     3 Zürich        Max                         0.0176                  0.103
4     4 Bern          All                         0.0176                  0.103
5     5 Bern          All                         0.0176                  0.103
6     6 Bern          M3                          0.0571                  0.4  
7     7 Bern          M1                          0.262                   0.262
8     8 Bern          Max                         0.001                   0.001
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Meetings

Functions to select and reintegrate a Sub Populations

Select a Sub Population (random)

Code

sel_SubPop <- function(Pop = Pop,
                       IDs = NULL,
                       n = 2) {
  if (is.null(IDs)) {
    IDs <- sample( Pop[["ID"]], size=n )
    }
  SubPop <- list()
  SubPop$sel <- Pop %>%
    filter(ID %in% IDs) %>%
    arrange(match(ID, IDs))
  SubPop$rest <- Pop %>%
    filter(!ID %in% IDs)
  return(SubPop)
}

Code

SubPop <- sel_SubPop( Pop = Pop , IDs = c(2, 1))
SubPop$sel

# A tibble: 2 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     2 Zürich        Max                         0.0176                  0.103
2     1 Zürich        Max                         0.0176                  0.103
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Code

SubPop$rest

# A tibble: 6 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     3 Zürich        Max                         0.0176                  0.103
2     4 Bern          All                         0.0176                  0.103
3     5 Bern          All                         0.0176                  0.103
4     6 Bern          M3                          0.0571                  0.4  
5     7 Bern          M1                          0.262                   0.262
6     8 Bern          Max                         0.001                   0.001
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Integrate Sub Population

Code

int_SubPop <- function(SubPop = SubPop,
                       Pop = Pop) {
  col_sort <- colnames(Pop)
  SubPop <- SubPop[, col_sort]
  IDs <- SubPop[["ID"]]
  Pop[Pop$ID %in% IDs,] <- SubPop
  Pop <- Pop %>%
    arrange(ID)
  return(Pop)
}

Code

Pop

# A tibble: 8 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                         0.0176                  0.103
2     2 Zürich        Max                         0.0176                  0.103
3     3 Zürich        Max                         0.0176                  0.103
4     4 Bern          All                         0.0176                  0.103
5     5 Bern          All                         0.0176                  0.103
6     6 Bern          M3                          0.0571                  0.4  
7     7 Bern          M1                          0.262                   0.262
8     8 Bern          Max                         0.001                   0.001
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Code

SubPop <- sel_SubPop(Pop = Pop, IDs = c(2, 1) )$sel
SubPop <- update_Pop(Pop = SubPop,
                     name = "Knowledge_M2",
                     add = 0,
                     set = TRUE)
Pop <- int_SubPop(SubPop = SubPop, Pop = Pop)
Pop <- update_Agents_Learnrate(Pop = Pop)
Pop <- update_Agents_Topic(Pop = Pop)
Pop

# A tibble: 8 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                       0.000714                  0.005
2     2 Zürich        Max                       0.000714                  0.005
3     3 Zürich        Max                       0.0176                    0.103
4     4 Bern          All                       0.0176                    0.103
5     5 Bern          All                       0.0176                    0.103
6     6 Bern          M3                        0.0571                    0.4  
7     7 Bern          M1                        0.262                     0.262
8     8 Bern          Max                       0.001                     0.001
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Select a random Slot of pairs

Code

sel_Pairs_rnd <- function(Pop = Pop,
                          psize = percentsOfPop) {      
  psize <- min(psize, 1)   
  nR <- nrow(Pop)   
  n <- round(nR * psize * 0.4999, 0)   
  n <- max(n, 1)      
  SubPop <- sel_SubPop( Pop = Pop, n = n)      
  Slot1 <- SubPop$sel %>%          
    mutate(tmp_ID = seq_len(n))   
  if (nrow(SubPop$rest) == n) {     
    Slot2 <- SubPop$rest   
  } else {     
      SubPop <- sel_SubPop( Pop = SubPop$rest, n = n)      
      Slot2 <- SubPop$sel   
  }   
  Slot2 <- Slot2 %>%          
    mutate(tmp_ID = seq_len(n))   
  Pairs <- bind_rows(Slot1, Slot2)   
  return(Pairs)     
  }

Code

Pairs <- sel_Pairs_rnd(Pop = Pop, psize = 0.5) 
Pairs

# A tibble: 4 × 23
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     4 Bern          All                       0.0176                    0.103
2     3 Zürich        Max                       0.0176                    0.103
3     6 Bern          M3                        0.0571                    0.4  
4     1 Zürich        Max                       0.000714                  0.005
# ℹ 18 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Select a Slot of pairs by utility

Code

calc_Utility <- function(Pop = Pop) { 
  #Typs <- get_Typ(Pop = Pop, name = "Knowledge")
  Utility <- Pop %>%
    select(starts_with("ID"),
           starts_with("Agents"),
           starts_with("University"),
           starts_with("Knowledge"))
  Utility1 <- longer_Pop(Pop =  Utility, name = "Knowledge") %>%
    mutate(Side = "Inside",
           Utility = ifelse(
             Typ == Agents_Topic, 
             Agents_Learnrate_Topic, 
             0.5 * Agents_Learnrate_Others))
  Utility2 <- longer_Pop(Pop =  Utility, name = "Knowledge") %>%
    mutate(Side = "Outside",
           Utility = ifelse(
             Typ == University_Topic, 
             University_Learnrate_Topic, 
             0.5 * University_Learnrate_Others))
  Utility <- bind_rows(Utility1, Utility2) %>%
    pivot_wider(names_from = Side,
                values_from = Utility,
                names_prefix = "Utility_") %>%
    mutate(Typ_Inside = Typ, Typ_Outside = Typ) %>%
    pivot_wider(names_from = Typ_Inside,
                values_from = Utility_Inside,
                names_prefix = "Utility_Inside_") %>%
    pivot_wider(names_from = Typ_Outside,
                values_from = Utility_Outside,
                names_prefix = "Utility_Outside_") %>%
    group_by(ID) %>%
    mutate(across(starts_with("Utility"), ~ max(., na.rm = TRUE))) %>%
    ungroup()
  Utility <- wider_Pop(Pop =  Utility, name = "Knowledge") %>%
    select(starts_with("ID"), starts_with("Utility"))
  
  return(Utility)     
}

Code

calc_spezific_Utility <- function(Utility = Utility,
                                  Topic = Topic,
                                  University = University) {
  spezific_Utility <- Utility %>%
    select(starts_with("ID"), contains(Topic)) %>%
    rename_with(~ "Inside", contains("Inside")) %>%
    rename_with(~ "Outside", contains("Outside")) %>%
    mutate(Utility = ifelse(ID_University == University,
                            Inside,
                            Outside)) %>%
    select("ID","Utility") 
  
  spezific_Utility <- spezific_Utility[sample(nrow(spezific_Utility)), ]
  
  return(spezific_Utility)
  
}

Code

Utility <- calc_Utility(Pop = Pop)
Utility

# A tibble: 8 × 8
     ID ID_University Utility_Inside_M1 Utility_Inside_M2 Utility_Inside_M3
  <int> <chr>                     <dbl>             <dbl>             <dbl>
1     1 Zürich                  0.005            0.000357          0.000357
2     2 Zürich                  0.005            0.000357          0.000357
3     3 Zürich                  0.00879          0.103             0.00879 
4     4 Bern                    0.103            0.00879           0.00879 
5     5 Bern                    0.103            0.00879           0.00879 
6     6 Bern                    0.0286           0.0286            0.4     
7     7 Bern                    0.262            0.131             0.131   
8     8 Bern                    0.0005           0.001             0.0005  
# ℹ 3 more variables: Utility_Outside_M1 <dbl>, Utility_Outside_M2 <dbl>,
#   Utility_Outside_M3 <dbl>

Code

spezific_Utility <- calc_spezific_Utility(Utility = Utility,
                                          Topic = "M1",
                                          University = "Zürich") 
spezific_Utility

# A tibble: 8 × 2
     ID Utility
  <int>   <dbl>
1     2 0.005  
2     5 0.108  
3     4 0.108  
4     7 0.108  
5     6 0.108  
6     8 0.108  
7     1 0.005  
8     3 0.00879

Code

sel_Pairs_utility <- function(Pop = Pop,
                              psize = percentsOfPop) {      
  psize <- min(psize, 1)   
  nR <- nrow(Pop)   
  n <- round(nR * psize * 0.4999, 0)   
  n <- max(n, 1)      
  SubPop <- sel_SubPop( Pop = Pop, n = n)      
  Slot1 <- SubPop$sel %>%          
    mutate(tmp_ID = seq_len(n)) 
  
  Utility <- calc_Utility(Pop = SubPop$rest)
  IDs <- as.vector(0)
  
  for (i in seq_len(nrow(Slot1))) {
    Topic <- Slot1$Agents_Topic[i]
    University <- Slot1$ID_University[i]
    spezific_Utility <- calc_spezific_Utility(Utility = Utility,
                                              Topic = Topic,
                                              University = University)
    max_row <- which.max(spezific_Utility[["Utility"]])
    ID_sel <- spezific_Utility$ID[max_row]
    Utility <- Utility %>% filter(ID != ID_sel)
    IDs[i] <- ID_sel
  }
  
  SubPop <- sel_SubPop( Pop = Pop, IDs = IDs)      
  Slot2 <- SubPop$sel %>% 
    mutate(tmp_ID = seq_len(n))   
  Pairs <- bind_rows(Slot1, Slot2)   
  return(Pairs)     
  }

Code

sel_Pairs_utility(Pop = Pop, psize = 1)

# A tibble: 8 × 23
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     6 Bern          M3                        0.0571                    0.4  
2     5 Bern          All                       0.0176                    0.103
3     8 Bern          Max                       0.001                     0.001
4     2 Zürich        Max                       0.000714                  0.005
5     7 Bern          M1                        0.262                     0.262
6     4 Bern          All                       0.0176                    0.103
7     1 Zürich        Max                       0.000714                  0.005
8     3 Zürich        Max                       0.0176                    0.103
# ℹ 18 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Learning

Learning with a exponential lernrate

… by Pairs

Code

learn_Pairs <- function(Pairs = Pairs,
                        time_meet = time_meet) {
  Pop_long <- longer_Pop(Pop = Pairs, name = "Knowledge")
  Pop_long <- Pop_long %>%
    mutate(tmp_Learnrate = ifelse(
      Typ == Agents_Topic, 
      Agents_Learnrate_Topic, 
      Agents_Learnrate_Others)) %>%
  group_by(tmp_ID) %>%
    mutate(tmp_facT = ifelse(
      Typ == Agents_Topic, 1, 0)) %>%
  group_by(tmp_ID, Typ) %>%
    mutate(tmp_facT = mean(tmp_facT ),
           tmp_Learnrate = mean(tmp_Learnrate)) %>%
  group_by(ID) %>%
    mutate(tmp_time_learn = tmp_facT * time_meet,
           tmp_Time0 = ( 1 - Knowledge )^( 1 / -tmp_Learnrate ),
           Knowledge = 1 - ( tmp_Time0 + tmp_time_learn)^( -tmp_Learnrate )) %>%
    ungroup()
  
  Pop_long <- del_tmp(Pop = Pop_long)
  Pairs <- wider_Pop(Pop_long = Pop_long, name = "Knowledge")
  Pairs <- sort_Pop(Pop = Pairs)
  
  Pairs <- update_Typ(Pop = Pairs,
                      name = "Counter",
                      Typ = list("Time_total",
                                 "Time_meet", 
                                 "Number_meet"),
                      add = list(time_meet,
                                 time_meet,
                                 1))
  Pairs <- update_Typ(Pop = Pairs,
                      name = "Resources",
                      Typ = list("Time_total","Time_meet"),
                      add = list(-time_meet))
  return(Pairs)
}

Code

Pairs <- learn_Pairs(Pairs = Pairs, time_meet = 0.75)
Pop <- int_SubPop(SubPop = Pairs, Pop = Pop)
Pop <- update_Agents_Learnrate(Pop = Pop)
Pop <- update_Agents_Topic(Pop = Pop)
Pop

# A tibble: 8 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                       0.00607                  0.0110
2     2 Zürich        Max                       0.000714                 0.005 
3     3 Zürich        Max                       0.0181                   0.103 
4     4 Bern          All                       0.0462                   0.121 
5     5 Bern          All                       0.0176                   0.103 
6     6 Bern          M3                        0.0653                   0.406 
7     7 Bern          M1                        0.262                    0.262 
8     8 Bern          Max                       0.001                    0.001 
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

… by it Own

Code

learn <- function(Pop = Pop,                   
                  con = TRUE) {   
  if (con == TRUE){     
    tmp_Learnrate <- Pop[["Agents_Learnrate_Topic"]]
    Pop <- update_Agents_Learnrate(Pop = Pop)     
    Pop <- update_Agents_Topic(Pop = Pop) 
    Pop <- update_Pop(Pop = Pop,
                      name = "Agents_Learnrate_Topic",
                      add = tmp_Learnrate, 
                      fac = 0.5)
    tmp_Time <- Pop[["Resources_Time_meet"]]
    Pop <- update_Typ(Pop = Pop, 
                      name = "Resources_Time",
                      Typ = list("meet", "learnd"),
                      add = list(-tmp_Time, tmp_Time))
  } 
  
  Pop_long <- longer_Pop(Pop = Pop, name = "Knowledge") 
  Pop_long <- Pop_long %>%     
    group_by(ID) %>%     
    mutate(tmp_Time_learnd = ifelse(
      Typ == Agents_Topic, 
      Resources_Time_learnd, 
      0)) %>%  
    mutate(tmp_Learnrate = Agents_Learnrate_Topic,            
           tmp_Time0 = ( 1 - Knowledge )^( 1 / -tmp_Learnrate ),
           tmp_Time1 = tmp_Time0 + tmp_Time_learnd,
           Knowledge = 1 - ( tmp_Time1 )^( -tmp_Learnrate )) %>%
    ungroup()   
  
  Pop_long <- del_tmp(Pop = Pop_long)
  Pop <- wider_Pop(Pop_long = Pop_long, name = "Knowledge") 
  Pop <- sort_Pop(Pop = Pop)
  
  tmp_Time <- Pop[["Resources_Time_learnd"]]
  Pop <- update_Typ(Pop = Pop,
                    name = "Counter",
                    Typ = list("Time_total", "Time_learnd"),
                    add = list(tmp_Time))
  Pop <- update_Typ(Pop = Pop,
                    name = "Resources",
                    Typ = list("Time_total", "Time_learnd"),
                    add = list(-tmp_Time))
  Pop <- update_Agents_Learnrate(Pop = Pop)     
  Pop <- update_Agents_Topic(Pop = Pop)
  
  return(Pop) 
  }

Code

Pop <- learn(Pop = Pop, con = TRUE) 
Pop

# A tibble: 8 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                       0.00618                 0.0140 
2     2 Zürich        Max                       0.000866                0.00606
3     3 Zürich        Max                       0.0199                  0.116  
4     4 Bern          All                       0.0634                  0.130  
5     5 Bern          All                       0.0528                  0.125  
6     6 Bern          M3                        0.0654                  0.407  
7     7 Bern          M1                        0.251                   0.293  
8     8 Bern          Max                       0.001                   0.001  
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

… by Days

Code

learn_Day <- function(Pop = Pop,
                      time_day = time_day,
                      time_meet = time_meet) { 
  if (!any(startsWith(names(Pop), "Counter_"))) {
    Pop <- reset_Counter(Pop = Pop)
  }
  Pop <- update_Resources(Pop = Pop, time_day = time_day)
  
  nR_Pop <- nrow(Pop)
  psize <- max(Pop[["Agents_p_MeetDay"]]) * 1.1
  iD <- round(time_day / time_meet, digits = 0)

  for(i in 1:iD) {
    Par <- Pop %>%
      select(Resources_Time_meet) %>%
      mutate(Break = ifelse(Resources_Time_meet >= time_meet, 1,0))
    ParBreak <- sum(Par$Break)
    if (ParBreak < 2) { break }
   
  Pop_Res <- Pop[Pop$Resources_Time_meet >= time_meet, ]
  
  nR_Pop_Res <- nrow(Pop_Res)
  psize_i <- psize / nR_Pop_Res * nR_Pop
  
  Pairs <- sel_Pairs_utility(Pop = Pop_Res, psize = psize_i)
  Pairs <- learn_Pairs(Pairs = Pairs, time_meet = time_meet)
  
  Pop <- int_SubPop(SubPop = Pairs, Pop = Pop)
  } 
  
  Pop <- learn(Pop = Pop, con = TRUE)
  
  return(Pop) 
}

Code

Pop <- reset_Counter(Pop = Pop)
Pop <- learn_Day(Pop = Pop, time_day = 8, time_meet = 0.75)
Pop

# A tibble: 8 × 22
     ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
  <int> <chr>         <chr>                        <dbl>                  <dbl>
1     1 Zürich        Max                        0.0287                  0.0467
2     2 Zürich        Max                        0.0174                  0.0305
3     3 Zürich        Max                        0.0226                  0.122 
4     4 Bern          All                        0.0869                  0.141 
5     5 Bern          All                        0.114                   0.153 
6     6 Bern          M3                         0.0655                  0.408 
7     7 Bern          M1                         0.248                   0.310 
8     8 Bern          Max                        0.00275                 0.0103
# ℹ 17 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Knowledge_M3 <dbl>,
#   Counter_Day <dbl>, Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>,
#   Resources_Time_learnd <dbl>, Resources_Time_meet <dbl>, …

Visualization

Get Agents-Timelines

Code

get_Timeline <- function(TL = Timeline,                          
                         Pop = Pop) {   
  TLadd <- sort_Pop(Pop = Pop, clean_Par = TRUE)
  Time <- unique(Pop[["Counter_Day"]])
  if (Time == 0) {
    TL <- TLadd 
  } else {
    TL <- bind_rows(TL, TLadd)   
  }
  return(TL)  
}

Timelineplots

plt_Learnrate

Code

plt_Learnrate <- function(TL = Timeline,
                          Group = NA) { 
  Grouping <- c("Counter_Day", "Typ")
  Data <- longer_Pop(Pop = TL, name = "Agents_Learnrate")
  
  if (Group %in% colnames(Data)) {
    Grouping <- c(Grouping, Group)
    Data <- Data %>%
      group_by(across(all_of(Grouping))) %>%
      summarise(
        Learnrate = mean(Agents_Learnrate, na.rm = TRUE), .groups = "drop") %>%
      mutate( plt_Typ = interaction(Typ, .data[[Group]], sep = "_"),
              !!Group := factor(.data[[Group]]))
  } else {
    Data <- Data %>%
      group_by(across(all_of(Grouping))) %>%
      summarise(
        Learnrate = mean(Agents_Learnrate, na.rm = TRUE), .groups = "drop") %>%
      mutate( plt_Typ = Typ)
  }
    
  Data$Typ <- factor(Data$Typ, levels = c("Topic", "Others"))
  
  plt <- ggplot(data = Data, 
                aes(x = Counter_Day, y = Learnrate, group = plt_Typ)) +
    geom_line(aes(linetype = Typ), linewidth = 1) +
    scale_linetype_manual(values = c("Topic" = "solid", 
                                     "Others" = "dashed")) +
    ggtitle("Mean Learnrate over Days") +     
    xlab("Number of Days") +     
    scale_x_continuous(
      limits = c(0, max(Data$Counter_Day, na.rm = TRUE))) +
    scale_y_continuous(
      limits = c(0, 1), 
      breaks = seq(0, 1, 0.2)) + 
    guides(linetype = guide_legend(title = ""))+
    theme_minimal() +
    theme(legend.position = "top",
          legend.justification = "left")
  
  if (Group %in% colnames(Data)) {
    del_prefix <- "^[^_]*_"
    plt <- plt +
      aes(color = .data[[Group]]) +
      guides(color = guide_legend(title = str_remove(Group,del_prefix), 
                                  position = "right" ),
             override.aes = list(linewidth = 1,
                                 alpha = 1))
    }
  
  return(plt)
}

plt_Knowledge

Code

plt_Knowledge <- function(TL = Timeline) {  
   
  TL <- longer_Pop(Pop = TL, name = "Knowledge") %>%     
    group_by(Counter_Day, Typ) %>%  
    summarise(Knowledge = mean(Knowledge, na.rm = TRUE), .groups = "drop") %>%
    mutate(TopicColor = case_when(
      grepl("M1", Typ) ~ "blue",  
      grepl("M2", Typ) ~ "green",  
      grepl("M3", Typ) ~ "red",  
      TRUE ~ "lightgray")
      )
  ggplot(TL, aes(x = Counter_Day, y = Knowledge, group = Typ, color = Typ)) +
    geom_line(linewidth = 1) +
    scale_color_manual(values = unique(TL$TopicColor)) + 
    ggtitle("Mean Knowledge over Days") +     
    xlab("Number of Days") +     
    scale_x_continuous(
      limits = c(0, max(TL$Counter_Day, na.rm = TRUE)), 
      expand = expansion(mult = c(0, 0)) ) +
    scale_y_continuous(
      limits = c(0, 1), 
      breaks = seq(0, 1, 0.2)) + 
    theme_minimal() +
    theme(
      legend.title = element_blank(),       
      legend.position = "top",       
      legend.justification = "left"
    )

}

plt_Topics

Code

plt_Topics <- function(TL = Timeline) {   
  TL <- TL %>%
    group_by(Counter_Day, Agents_Topic) %>%
    summarise(Frequency = n(), .groups = "drop") %>%
    mutate(TopicColor = case_when(
      grepl("M1", Agents_Topic) ~ "blue",  
      grepl("M2", Agents_Topic) ~ "green",  
      grepl("M3", Agents_Topic) ~ "red",  
      TRUE ~ "lightgray")
      )
  
  TL$Time <- factor(TL$Counter_Day, levels = unique(TL$Counter_Day))
  
  ggplot(TL, aes(x = Time, y = Frequency, fill = Agents_Topic)) +
    geom_bar(stat = "identity", 
             position = "stack",
             width = 0.8) +
    scale_fill_manual(values = unique(TL$TopicColor)) +
    ggtitle("Agent's Topic over Days") +     
    xlab("Number of Days") +
    scale_x_discrete(
      expand = expansion(mult = c(0, 0))) +
    theme_minimal() +
    theme(legend.title = element_blank(),       
          legend.position = "top",       
          legend.justification = "left")
}

Timepointplots

Number of Meetings

Code

plt_Number_meet <- function(TL = Timeline,
                            TP = NA,
                            Group = Group) {
  if (is.na(TP)) {
    TP <- unique(TL$Counter_Day)
  } 
  Titel <- paste("Number of Meetings until Day", TP)
  Data <- TL %>%
    filter(Counter_Day == TP)
  
  if (Group %in% colnames(Data)) {
    Data <- Data %>%
      mutate( !!Group := factor(.data[[Group]])) %>%
      group_by(.data[[Group]]) %>%
      mutate(plt_ID = seq_len(n())) %>% 
      ungroup()
    del_prefix <- "^[^_]*_"
    Titel <- paste(Titel,"- grouped by", str_remove(Group,del_prefix))
  } else {
    Data <- Data %>%
      mutate( plt_Typ = Typ,
              plt_ID = ID )
  }
  
  plt <- ggplot(Data, 
                aes(x = plt_ID, y = Counter_Number_meet)) +
    geom_step(direction = "mid",linewidth = 1) +
    scale_x_continuous( 
      breaks = function(limits) { scales::breaks_pretty()(limits)},
      labels = scales::number_format(accuracy = 1)) +
    scale_y_continuous(limits = c(0,max(Data$Counter_Number_meet))) +
    ggtitle(Titel) +     
    xlab("Agents") +     
    ylab("Frequency") +
    theme_minimal() +
    theme(
      legend.title = element_blank(),       
      legend.position = "top",       
      legend.justification = "left"
    )
  
  if (Group %in% colnames(Data)) {
    plt <- plt + facet_grid(. ~ .data[[Group]], scales = "free_x")
  }
  
  return(plt)
  }

Time invested

Code

plt_Time_invest <- function(TL = Timeline,
                            TP = NA,
                            Group = NA) {
  if (is.na(TP)) {
    TP <- unique(TL$Counter_Day)
  }
  Titel <- paste("Time invested until Day", TP)
  Data <- longer_Pop(Pop = TL, name = "Counter_Time") %>%
    filter(Counter_Day == TP)
  
  Grouping <- c("Typ")
  
  if (Group %in% colnames(Data)) {
    Grouping <- c(Grouping, Group)
    Data <- Data %>%
      mutate( plt_Typ = interaction(Typ, .data[[Group]], sep = "_"),
              !!Group := factor(.data[[Group]])) %>%
      group_by(plt_Typ) %>%
      mutate(plt_ID = seq_len(n())) %>% 
      ungroup()
    del_prefix <- "^[^_]*_"
    Titel <- paste(Titel,"- grouped by", str_remove(Group,del_prefix))
  } else {
    Data <- Data %>%
      mutate( plt_Typ = Typ,
              plt_ID = ID )
  }
    
  Data$Typ <- factor(Data$Typ, levels = c("meet", "learnd", "total"))

  plt <- ggplot(Data, 
                aes(x = plt_ID, y = Counter_Time, 
                    group = plt_Typ,
                    linewidth = Typ)) +
    
    geom_step(direction = "mid") +
    scale_linewidth_manual(values = c("total" = 1.5, 
                                      "learnd" = 0.5, 
                                      "meet" = 1.0)) +
    scale_x_continuous( 
      breaks = function(limits) { scales::breaks_pretty()(limits)},
      labels = scales::number_format(accuracy = 1)) +
    scale_y_continuous(limits = c(0,max(Data$Counter_Time))) +
    ggtitle(Titel) +     
    xlab("Agents") +     
    ylab("Hours") +
    guides(linewidth = guide_legend(title = ""))+
    theme_minimal() +
    theme(
      legend.title = element_blank(),       
      legend.position = "top",       
      legend.justification = "left"
    )
  
  if (Group %in% colnames(Data)) {
    plt <- plt + facet_grid(. ~ .data[[Group]], scales = "free_x")
  }
  
  return(plt)
  }

Learnrate at Timepoint

Code

plt_Learnrate_Time <- function(TL = Timeline,
                                TP = NA,
                                Group = NA) {
  if (is.na(TP)) {
    TP <- unique(TL$Counter_Day)
  }
  Titel <- paste("Learnrate at Day", TP)
  Data <- longer_Pop(Pop = TL, name = "Agents_Learnrate") %>%
    filter(Counter_Day == TP)
  
  Grouping <- c("Typ")
  
  if (Group %in% colnames(Data)) {
    Grouping <- c(Grouping, Group)
    Data <- Data %>%
      mutate( plt_Typ = interaction(Typ, .data[[Group]], sep = "_"),
              !!Group := factor(.data[[Group]])) %>%
      group_by(plt_Typ) %>%
      mutate(plt_ID = seq_len(n())) %>% 
      ungroup()
    del_prefix <- "^[^_]*_"
    Titel <- paste(Titel,"- grouped by", str_remove(Group,del_prefix))
  } else {
    Data <- Data %>%
      mutate( plt_Typ = Typ,
              plt_ID = ID)
  }
  
  Data$Typ <- factor(Data$Typ, levels = c("Topic", "Others"))
  
  plt <- ggplot(data = Data, 
                aes(x = plt_ID, 
                    y = Agents_Learnrate, 
                    group = plt_Typ,
                    linewidth = Typ)) +
    geom_step(direction = "mid") +
    scale_linewidth_manual(values = c("Topic" = 1.0, 
                                      "Others" = 0.8)) +
    scale_x_continuous( 
      breaks = function(limits) { scales::breaks_pretty()(limits)},
      labels = scales::number_format(accuracy = 1)) +
    scale_y_continuous(limits = c(0, 1)) +
    ggtitle(Titel) +     
    xlab("Agents") +     
    ylab("Learnrate") +
    guides(linewidth = guide_legend(title = ""))+
    theme_minimal() +
    theme(
      legend.title = element_blank(),       
      legend.position = "top",       
      legend.justification = "left"
    )
  
  if (Group %in% colnames(Data)) {
    plt <- plt + facet_grid(. ~ .data[[Group]], scales = "free_x")
  }
  return(plt)
}

Knowledge at Timepoint

Code

plt_Knowledge_Time <- function(TL = Timeline, 
                               TP = NA,
                               Group = NA) {
  if (is.na(TP)) {
    TP <- unique(TL$Counter_Day)
  }
  Titel <- paste("Knowledge at Day", TP)
  Data <- longer_Pop(Pop = TL, name = "Knowledge") %>%
    filter(Counter_Day == TP)
  
  Grouping <- c("Typ")
  
  if (Group %in% colnames(Data)) {
    Grouping <- c(Grouping, Group)
    Data <- Data %>%
      mutate( plt_Typ = interaction(Typ, .data[[Group]], sep = "_"),
              !!Group := factor(.data[[Group]])) %>%
      group_by(plt_Typ) %>%
      mutate(plt_ID = seq_len(n())) %>% 
      ungroup()
    del_prefix <- "^[^_]*_"
    Titel <- paste(Titel,"- grouped by", str_remove(Group,del_prefix))
  } else {
    Data <- Data %>%
      mutate( plt_Typ = Typ,
              plt_ID = ID)
  }
  
  plt <- ggplot(Data, 
                aes(x = plt_ID, y = Knowledge, group = Typ, color = Typ)) +
    geom_step(direction = "mid", linewidth = 1) +
    scale_x_continuous( 
      breaks = function(limits) { scales::breaks_pretty()(limits)},
      labels = scales::number_format(accuracy = 1)) +
    scale_y_continuous(limits = c(0, 1)) +
    ggtitle(Titel) +     
    xlab("Agents") +     
    ylab("Knowledge") +
    theme_minimal() +
    theme(
      legend.title = element_blank(),       
      legend.position = "top",       
      legend.justification = "left"
    )
  
  if (Group %in% colnames(Data)) {
    plt <- plt + facet_grid(. ~ .data[[Group]], scales = "free_x")
  }
  return(plt)
}

Simulation

Simulating Days

A learning process with updated learn rate by current knowledge when Agents meet selective Agents with higher Knowledge

Code

sim_Days <- function(Pop = Pop,
                     nD = nubmberDay,
                     time_day = 8,
                     time_meet = 0.75) {
  Pop <- update_Agents_Learnrate(Pop = Pop)
  Pop <- update_Agents_Topic(Pop = Pop)
  Pop <- update_University_Learnrate(Pop = Pop)     
  Pop <- update_University_Topic(Pop = Pop)
  Pop <- reset_Counter( Pop = Pop)
  Pop <- update_Resources( Pop = Pop, time_day = time_day)
  TL <- get_Timeline(TL = TL, Pop = Pop)
  for(i in 1:nD) {
    Pop <- learn_Day(Pop = Pop,
                     time_day = time_day,
                     time_meet = time_meet)
    if (i %% 5 == 0) {
      Pop <- update_University_Learnrate(Pop = Pop)     
      Pop <- update_University_Topic(Pop = Pop)
    }
    Pop <- update_Typ(Pop = Pop,
                      name = "Counter",
                      Typ = list("Day"),
                      add = list(i),
                      set = TRUE)
    TL <- get_Timeline(TL = TL, Pop = Pop)
  }
    
  Output <- list( Pop = Pop,
                  TL = TL)
  return(Output)
}

Definition & Calculation

Code

Pop <- gen_Pop( nA = 30, 
                Preference = "M1",
                ID_University = "Zürich",
                K = list(0.01), 
                Typ = list("M1"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 30,
                Preference = "All",
                ID_University = "Bern",
                K = list(0.01), 
                Typ = list("M2"), 
                pWD = 0.8,
                pMD = 0.8)

Pop

# A tibble: 60 × 13
      ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
   <int> <chr>         <chr>                        <dbl>                  <dbl>
 1     1 Zürich        M1                         0.00167                  0.005
 2     2 Zürich        M1                         0.00167                  0.005
 3     3 Zürich        M1                         0.00167                  0.005
 4     4 Zürich        M1                         0.00167                  0.005
 5     5 Zürich        M1                         0.00167                  0.005
 6     6 Zürich        M1                         0.00167                  0.005
 7     7 Zürich        M1                         0.00167                  0.005
 8     8 Zürich        M1                         0.00167                  0.005
 9     9 Zürich        M1                         0.00167                  0.005
10    10 Zürich        M1                         0.00167                  0.005
# ℹ 50 more rows
# ℹ 8 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>

Code

res <- sim_Days(Pop = Pop, nD = 20)

res$Pop

# A tibble: 60 × 21
      ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
   <int> <chr>         <chr>                        <dbl>                  <dbl>
 1     1 Zürich        M1                           0.365                  0.518
 2     2 Zürich        M1                           0.340                  0.506
 3     3 Zürich        M1                           0.379                  0.521
 4     4 Zürich        M1                           0.348                  0.510
 5     5 Zürich        M1                           0.298                  0.485
 6     6 Zürich        M1                           0.333                  0.506
 7     7 Zürich        M1                           0.363                  0.512
 8     8 Zürich        M1                           0.394                  0.530
 9     9 Zürich        M1                           0.311                  0.492
10    10 Zürich        M1                           0.390                  0.528
# ℹ 50 more rows
# ℹ 16 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Counter_Day <dbl>,
#   Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>, …

Visualization Results

Code

plt_Topics(TL = res$TL)

Code

plt_Knowledge(TL = res$TL)

Code

plt_Learnrate(TL = res$TL)

Code

plt_Learnrate(TL = res$TL, Group = "ID_University")

Code

plt_Learnrate(TL = res$TL, Group = "Preference")

Code

plt_Number_meet(TL = res$TL, TP = 1, Group = "ID_University")

Code

plt_Number_meet(TL = res$TL, TP = 20, Group = "ID_University")

Code

plt_Time_invest(TL = res$TL, TP = 20, Group = "ID_University")

Code

plt_Learnrate_Time(TL = res$TL, TP = 20, Group = "ID_University")

Code

plt_Knowledge_Time(TL = res$TL, TP = 20, Group = "ID_University")

Special Cases

Only one Agent with Knowledge (0.8)

Code

Pop <- gen_Pop( nA = 10, 
                Preference = "M1",
                ID_University = "Zürich",
                K = list(0.01), 
                Typ = list("M1"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 10, 
                Preference = "All",
                ID_University = "Zürich",
                K = list(0.01), 
                Typ = list("M1"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 9, 
                ID_University = "Zürich",
                K = list(0.01), 
                Typ = list("M1"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 1, 
                ID_University = "Zürich",
                K = list(0.8), 
                Typ = list("M1"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 10, 
                Preference = "M2",
                ID_University = "Bern",
                K = list(0.01), 
                Typ = list("M2"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 10, 
                Preference = "All",
                ID_University = "Bern",
                K = list(0.01), 
                Typ = list("M2"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 9, 
                ID_University = "Bern",
                K = list(0.01), 
                Typ = list("M2"), 
                pWD = 0.8,
                pMD = 0.8)
Pop <- gen_Pop( addToPop = Pop,
                nA = 1, 
                ID_University = "Bern",
                K = list(0.4), 
                Typ = list("M2"), 
                pWD = 0.8,
                pMD = 0.8)

Pop

# A tibble: 60 × 13
      ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
   <int> <chr>         <chr>                        <dbl>                  <dbl>
 1     1 Zürich        M1                         0.00167                  0.005
 2     2 Zürich        M1                         0.00167                  0.005
 3     3 Zürich        M1                         0.00167                  0.005
 4     4 Zürich        M1                         0.00167                  0.005
 5     5 Zürich        M1                         0.00167                  0.005
 6     6 Zürich        M1                         0.00167                  0.005
 7     7 Zürich        M1                         0.00167                  0.005
 8     8 Zürich        M1                         0.00167                  0.005
 9     9 Zürich        M1                         0.00167                  0.005
10    10 Zürich        M1                         0.00167                  0.005
# ℹ 50 more rows
# ℹ 8 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>

Code

res1 <- sim_Days(Pop = Pop, nD = 20)

res1$Pop

# A tibble: 60 × 21
      ID ID_University Preference Agents_Learnrate_Others Agents_Learnrate_Topic
   <int> <chr>         <chr>                        <dbl>                  <dbl>
 1     1 Zürich        M1                           0.281                  0.491
 2     2 Zürich        M1                           0.295                  0.501
 3     3 Zürich        M1                           0.284                  0.495
 4     4 Zürich        M1                           0.297                  0.503
 5     5 Zürich        M1                           0.295                  0.501
 6     6 Zürich        M1                           0.302                  0.502
 7     7 Zürich        M1                           0.280                  0.494
 8     8 Zürich        M1                           0.271                  0.489
 9     9 Zürich        M1                           0.265                  0.490
10    10 Zürich        M1                           0.277                  0.492
# ℹ 50 more rows
# ℹ 16 more variables: Agents_p_MeetDay <dbl>, Agents_p_WorkDay <dbl>,
#   Agents_Topic <chr>, University_Learnrate_Others <dbl>,
#   University_Learnrate_Topic <dbl>, University_Topic <chr>,
#   Knowledge_M1 <dbl>, Knowledge_M2 <dbl>, Counter_Day <dbl>,
#   Counter_Number_meet <dbl>, Counter_Time_learnd <dbl>,
#   Counter_Time_meet <dbl>, Counter_Time_total <dbl>, …

Visualization Results

Code

plt_Topics(TL = res1$TL)

Code

plt_Knowledge(TL = res1$TL)

Code

plt_Learnrate(TL = res1$TL)

Code

plt_Learnrate(TL = res1$TL, Group = "ID_University")

Code

plt_Learnrate(TL = res1$TL, Group = "Preference")

Code

plt_Number_meet(TL = res1$TL, TP = 20, Group = "ID_University")

Code

plt_Time_invest(TL = res1$TL, TP = 20, Group = "ID_University")

Code

plt_Learnrate_Time(TL = res1$TL, TP = 20, Group = "ID_University")

Code

plt_Learnrate_Time(TL = res1$TL, TP = 6, Group = "Preference")

Code

plt_Learnrate_Time(TL = res1$TL, TP = 10, Group = "Preference")

Code

plt_Learnrate_Time(TL = res1$TL, TP = 20, Group = "Preference")

Code

plt_Knowledge_Time(TL = res1$TL, TP = 20, Group = "ID_University")

Code

plt_Knowledge_Time(TL = res1$TL, TP = 6, Group = "Preference")

Code

plt_Knowledge_Time(TL = res1$TL, TP = 10, Group = "Preference")

Code

plt_Knowledge_Time(TL = res1$TL, TP = 20, Group = "Preference")