Código Kmeans para Rejane

Athos 28/04/2019

library(tidyverse)
library(cluster)
library(flexclust)

Gera dados simulados

gera_valores_unitarios <- function(k, n = 300) {
  grupos = sample.int(k, n, replace = TRUE)
  medias = runif(k) * sample(c(1, 1, 5, 10, 100), k, replace = TRUE)
  valores_unitarios = medias[grupos] + rnorm(n, 0, 0.1)
} 

set.seed(42)
dados <- tibble(
  id_prestador = "hospital_x",
  id_cliente = "pessoa_y",
  id_produto = 1:3,
  grupos = c(2, 3, 4)
) %>%
  mutate(
    valor_unitario = map(grupos, gera_valores_unitarios)
  ) %>%
  unnest %>%
  mutate(treino_ou_teste = if_else(runif(n()) < 0.5, "treino", "teste"))

Encontra a quantidade ideal de grupos por produto

Método da silhueta

silhouette_score <- function(k, vu) {
  km <- kmeans(vu, centers = k, nstart=25)
  ss <- silhouette(km$cluster, dist(vu))
  mean(ss[, "sil_width"])
}

k_ideal <- function(vu, k_max = 8) {
  which.max(map_dbl(2:k_max, silhouette_score, vu = vu)) + 1
}

ks_ideais <- dados %>%
  filter(treino_ou_teste %in% "treino") %>%
  group_by(id_produto, id_prestador) %>%
  summarise(
    valor_unitario = list(valor_unitario),
    grupos_teoricos = first(grupos),
    grupos_inferidos = k_ideal(valor_unitario)
  )

ks_ideais %>% select(-valor_unitario)

## # A tibble: 3 x 4
## # Groups:   id_produto [3]
##   id_produto id_prestador grupos_teoricos grupos_inferidos
##        <int> <chr>                  <dbl>            <dbl>
## 1          1 hospital_x                 2                2
## 2          2 hospital_x                 3                3
## 3          3 hospital_x                 4                3

Cria o agrupamento com o k_ideal encontrato

agrupadores <- ks_ideais %>%
  mutate(agrupador = map2(valor_unitario, grupos_inferidos, kmeans))

agrupadores %>% select(id_prestador, id_produto, agrupador)

## # A tibble: 3 x 3
## # Groups:   id_produto [3]
##   id_prestador id_produto agrupador   
##   <chr>             <int> <list>      
## 1 hospital_x            1 <S3: kmeans>
## 2 hospital_x            2 <S3: kmeans>
## 3 hospital_x            3 <S3: kmeans>

Em produção

Aplica os agrupadores na base de teste

dados %>%
  group_by(id_prestador, id_produto) %>%
  mutate(
    grupo = pmap_dbl(list(id_prestador, id_produto, valor_unitario), function(id_prestador, id_produto, valor_unitario) {
      agrupador = agrupadores %>% 
        filter(id_produto %in% id_produto, id_prestador %in% id_prestador) %>% 
        pull(agrupador)
        
      predict(as.kcca(agrupador[[1]], valor_unitario))
    })
  )

## # A tibble: 900 x 7
## # Groups:   id_prestador, id_produto [3]
##    id_prestador id_cliente id_produto grupos valor_unitario treino_ou_teste
##    <chr>        <chr>           <int>  <dbl>          <dbl> <chr>          
##  1 hospital_x   pessoa_y            1      2          0.561 teste          
##  2 hospital_x   pessoa_y            1      2          0.417 treino         
##  3 hospital_x   pessoa_y            1      2          0.437 treino         
##  4 hospital_x   pessoa_y            1      2          0.321 treino         
##  5 hospital_x   pessoa_y            1      2          0.444 teste          
##  6 hospital_x   pessoa_y            1      2          0.365 teste          
##  7 hospital_x   pessoa_y            1      2          0.391 teste          
##  8 hospital_x   pessoa_y            1      2          0.613 treino         
##  9 hospital_x   pessoa_y            1      2          0.427 treino         
## 10 hospital_x   pessoa_y            1      2          0.337 teste          
## # ... with 890 more rows, and 1 more variable: grupo <dbl>