Descripcion

Calcular la probabilidad de que n personas de un grupo de N tengan celebren su cumpleaños el mismo dia.

Supuestos

library(dplyr)

Calculo para \(N=15\) y \(n \geq 2\)

#set.seed(124)
grupo<-sample(1:364,replace = TRUE,size=15)
grupo_df <- tibble(index=1:15,grupo)
grupo_df
grupo_df %>%
  group_by(grupo) %>% 
  summarise(n=n()) %>% 
  arrange(desc(n)) %>% 
  filter(n>1) %>% 
  nrow()
[1] 0

funcion generadora de grupos

bday_group <- function(x,N=15){
  grupo<-sample(1:364,replace = TRUE,size=N)
  grupo_df <- tibble(index=1:N,grupo)
  grupo_df %>%
  group_by(grupo) %>% 
  summarise(n=n()) %>% 
  arrange(desc(n)) %>% 
  filter(n>1) %>% 
  nrow() %>% return()
}
bday_group()
[1] 0

Calculo de la probabilidad

sim<-
sapply(1:5000,bday_group,N=15)
sum(sim>0)/5000
[1] 0.2588

funcion que genera la probabilidad para un groupo variable

prob_bday <- function(Ngroup,sim=100){
  out<-
sapply(1:sim,bday_group,N=Ngroup)
  out<- sum(out>0)/sim
  return(out)
} 
prob_bday(15,1000)
[1] 0.25
prob_vec<-
sapply(2:100, prob_bday,sim=1000)
plot(2:100,prob_vec, type='l',col='red')

tibble(gsize=2:100,prob_vec)
LS0tDQp0aXRsZTogIkJpcnRoZGF5IFBhcmFkb3giDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KDQojIyBEZXNjcmlwY2lvbg0KDQpDYWxjdWxhciBsYSBwcm9iYWJpbGlkYWQgZGUgcXVlICoqbioqIHBlcnNvbmFzIGRlIHVuIGdydXBvIA0KZGUgKipOKiogdGVuZ2FuIGNlbGVicmVuIHN1IGN1bXBsZWHDsW9zIGVsIG1pc21vIGRpYS4NCg0KIyMgU3VwdWVzdG9zDQoNCiogRWwgYcOxbyB0aWVuZSAzNjQgZGlhcy4NCiogTm8gdG9tYW1vcyBlbiBjdWVudGEgYcOxbyBiaXNpZXN0by4NCiogRWwgMSBkZSBlbmVybyBlcXVpdmFsZSBhIDEuDQoqIEVsIDMxIGRlIGRpY2llbWJyZSBlcXVpdmFsZSBhIDM2NC4NCiogTGEgcHJvYmFiaWxpZGFkIGRlIHF1ZSB1bmEgcGVyc29uYSBuYXpjYSBjdWFscXVpZXIgZGlhIGRlbCBhw7FvIGVzIHVuaWZvcm1lLg0KDQpgYGB7ciBsaWJyYXJpZXN9DQpsaWJyYXJ5KGRwbHlyKQ0KYGBgDQoNCiMjIENhbGN1bG8gcGFyYSAkTj0xNSQgeSAkbiBcZ2VxIDIkDQoNCmBgYHtyfQ0KI3NldC5zZWVkKDEyNCkNCmdydXBvPC1zYW1wbGUoMTozNjQscmVwbGFjZSA9IFRSVUUsc2l6ZT0xNSkNCmdydXBvX2RmIDwtIHRpYmJsZShpbmRleD0xOjE1LGdydXBvKQ0KZ3J1cG9fZGYNCmBgYA0KDQoNCmBgYHtyfQ0KZ3J1cG9fZGYgJT4lDQogIGdyb3VwX2J5KGdydXBvKSAlPiUgDQogIHN1bW1hcmlzZShuPW4oKSkgJT4lIA0KICBhcnJhbmdlKGRlc2MobikpICU+JSANCiAgZmlsdGVyKG4+MSkgJT4lIA0KICBucm93KCkNCiAgDQpgYGANCg0KDQojIyMgZnVuY2lvbiBnZW5lcmFkb3JhIGRlIGdydXBvcw0KDQpgYGB7cn0NCmJkYXlfZ3JvdXAgPC0gZnVuY3Rpb24oeCxOPTE1KXsNCiAgZ3J1cG88LXNhbXBsZSgxOjM2NCxyZXBsYWNlID0gVFJVRSxzaXplPU4pDQogIGdydXBvX2RmIDwtIHRpYmJsZShpbmRleD0xOk4sZ3J1cG8pDQogIGdydXBvX2RmICU+JQ0KICBncm91cF9ieShncnVwbykgJT4lIA0KICBzdW1tYXJpc2Uobj1uKCkpICU+JSANCiAgYXJyYW5nZShkZXNjKG4pKSAlPiUgDQogIGZpbHRlcihuPjEpICU+JSANCiAgbnJvdygpICU+JSByZXR1cm4oKQ0KfQ0KYmRheV9ncm91cCgpDQpgYGANCg0KIyMjIENhbGN1bG8gZGUgbGEgcHJvYmFiaWxpZGFkDQoNCmBgYHtyfQ0Kc2ltPC0NCnNhcHBseSgxOjUwMDAsYmRheV9ncm91cCxOPTE1KQ0KYGBgDQoNCg0KDQpgYGB7cn0NCnN1bShzaW0+MCkvNTAwMA0KYGBgDQoNCg0KIyMjIGZ1bmNpb24gcXVlIGdlbmVyYSBsYSBwcm9iYWJpbGlkYWQgcGFyYSB1biBncm91cG8gdmFyaWFibGUNCg0KYGBge3J9DQpwcm9iX2JkYXkgPC0gZnVuY3Rpb24oTmdyb3VwLHNpbT0xMDApew0KICBvdXQ8LQ0Kc2FwcGx5KDE6c2ltLGJkYXlfZ3JvdXAsTj1OZ3JvdXApDQogIG91dDwtIHN1bShvdXQ+MCkvc2ltDQogIHJldHVybihvdXQpDQp9IA0KcHJvYl9iZGF5KDE1LDEwMDApDQpgYGANCg0KYGBge3J9DQpwcm9iX3ZlYzwtDQpzYXBwbHkoMjoxMDAsIHByb2JfYmRheSxzaW09NTAwKQ0KYGBgDQoNCmBgYHtyfQ0KcGxvdCgyOjEwMCxwcm9iX3ZlYywgdHlwZT0nbCcsY29sPSdyZWQnKQ0KYGBgDQoNCg0KDQpgYGB7cn0NCnRpYmJsZShnc2l6ZT0yOjEwMCxwcm9iX3ZlYykNCmBgYA0KDQoNCg0K