customer_churn.Rmd

---
title: "Customer Churn Analytics"
output:
  flexdashboard::flex_dashboard: 
    source_code: https://github.com/rstudio/keras-customer-churn
    social: ["twitter", "linkedin"]
runtime: shiny_prerendered
---

```{r setup}
library(keras)
library(flexdashboard)
library(billboarder)
library(tidyverse)
library(tidyquant)
library(corrr)
library(scales)
library(lime)
library(glue)

# load data and model
load('data/customer_churn.RData')
model_keras <- load_model_hdf5('model/customer_churn.hdf5', compile = FALSE)

# customer scorecard inputs
main_vars <- c('tenure', 'Contract', 'InternetService', 'MonthlyCharges', 
               'OnlineBackup', 'OnlineSecurity', 'DeviceProtection', 
               'TechSupport', 'StreamingMovies', 'PhoneService')
commercial_vars <- c('InternetService', 'OnlineBackup', 'OnlineSecurity', 
                     'DeviceProtection', 'TechSupport', 'StreamingMovies', 
                     'PhoneService')
financial_vars <- c('PaymentMethod')
customer_feature_vars <- c(main_vars, commercial_vars, financial_vars) %>% unique

# transform original datasset
churn_data_raw <- read_csv("data/WA_Fn-UseC_-Telco-Customer-Churn.csv") %>% 
  mutate(
    tenure_range = case_when(
      tenure < 12 ~ '< 1 Yr',
      tenure < 24 ~ '1-2 Yrs',
      tenure < 36 ~ '2-3 Yrs',
      tenure >= 36 ~ 'Over 3 Yrs',
      TRUE ~ 'NA'
    ),
    monthly_charge_range = case_when(
      MonthlyCharges < 20 ~ '< 20 per Month',
      MonthlyCharges < 50 ~ '20-50 per Month',
      MonthlyCharges < 100 ~ '50-100 per Month',
      MonthlyCharges >= 100 ~ 'Over 100 per Month',
      TRUE ~ 'NA'
    )
  )

churn_data_tbl <- churn_data_raw %>%
  drop_na() %>%
  select(Churn, everything())

# setup lime::model_type() function for keras
assign("model_type.keras.models.Sequential", envir = globalenv(), function(x, ...) {
  "classification"
})

# setup lime::predict_model() function for keras
assign("predict_model.keras.models.Sequential", envir = globalenv(), function(x, newdata, type, ...) {
  pred <- predict_proba(object = x, x = as.matrix(newdata))
  data.frame(Yes = pred, No = 1 - pred)
})
```


Customer Scorecard {data-orientation=rows}
=============================================================================

Sidebar {.sidebar}
-----------------------------------------------------------------------------

#### Customer ID

```{r}
selectInput('customer_id', NULL, unique(test_tbl_with_ids$customerID))
```

#### Churn Risk

```{r}
gaugeOutput("churn_risk", width = "220px", height = "130px")
```

```{r, context="server"}
output$churn_risk <- renderGauge({
  
  req(input$customer_id)
        
  selected_customer_id <- test_tbl_with_ids$customerID[1]
  selected_customer_id <- input$customer_id
  
  test_tbl_with_ids_predictions <- test_tbl_with_ids %>% 
    mutate(churn_prob = predictions$Yes)
  
  customer_tbl <- test_tbl_with_ids_predictions %>% 
    filter(customerID == selected_customer_id)
        
  gauge(
    round(customer_tbl$churn_prob * 100, digits = 1), 
    min = 0, 
    max = 100,
    gaugeSectors(
      success = c(0,33),
      warning = c(33, 66),
      danger = c(67,100)
    ),
    symbol = "%"
  )
})
```

***

To learn more about the model used by this application, see the blog post [Using Deep Learning With Keras To Predict Customer Churn](https://tensorflow.rstudio.com/blog/keras-customer-churn.html).

***

*Created by:*

![](images/business-science-logo.png){width=24} [Business Science](https://www.business-science.io/)

![](images/rstudio-logo.png){width=24} [RStudio](https://www.rstudio.com)


Strategies
-----------------------------------------------------------------------------

```{css}
.value-box .value-output,
.value-box .caption {
  font-size: 24px;
}
```

### Main Strategy

```{r}
valueBoxOutput("main")
```

```{r, context="server"}
output$main <- renderValueBox({
  
   req(input$customer_id)
        
  selected_customer_id <- test_tbl_with_ids$customerID[1]
  selected_customer_id <- input$customer_id
  
  customer_tbl <- test_tbl_with_ids %>% 
      filter(customerID == selected_customer_id)
  
  if (customer_tbl$tenure <= 9) {
      main_strategy <- 'Retain until one year'
  } else if (customer_tbl$tenure > 9 | customer_tbl$Contract == 'Month-to-month') {
      main_strategy <- 'Upsell to annual contract'
  } else if (customer_tbl$tenure > 12 & customer_tbl$InternetService == 'No') {
      main_strategy <- 'Offer internet service'
  } else if (customer_tbl$tenure > 18 & customer_tbl$MonthlyCharges > 50) {
      main_strategy <- 'Offer discount in monthly rate'
  } else if (customer_tbl$tenure > 12 & 
             customer_tbl$Contract != 'Month-to-month' & 
             ((customer_tbl$OnlineBackup == 'No' & 
               customer_tbl$OnlineSecurity == 'No' & 
               customer_tbl$DeviceProtection == 'No' & 
               customer_tbl$TechSupport == 'No' & 
               customer_tbl$StreamingMovies == 'No') 
              | customer_tbl$PhoneService == 'No')) {
      main_strategy <- 'Offer additional services'
  } else {
      main_strategy <- 'Retain and maintain'
  }
  valueBox("Main Strategy", caption = main_strategy, color = "info")
})
```

### Commercial Strategy

```{r}
valueBoxOutput("commercial")
```

```{r, context="server"}
output$commercial <- renderValueBox({
  
  req(input$customer_id)
        
  selected_customer_id <- test_tbl_with_ids$customerID[1]
  selected_customer_id <- input$customer_id
  
  customer_tbl <- test_tbl_with_ids %>% 
      filter(customerID == selected_customer_id)
  
  if ((customer_tbl$InternetService == 'DSL' & 
       customer_tbl$OnlineBackup == 'No' & 
       customer_tbl$OnlineSecurity == 'No' & 
       customer_tbl$DeviceProtection == 'No' & 
       customer_tbl$TechSupport == 'No' & 
       customer_tbl$StreamingMovies == 'No') 
      | customer_tbl$PhoneService == 'No') {
      commercial_strategy <- 'Offer additional services'
  } else if (customer_tbl$InternetService == 'Fiber optic') {
      commercial_strategy <- 'Offer tech support and services'
  } else if (customer_tbl$InternetService == 'No') {
      commercial_strategy <- 'Upsell to internet service'
  } else {
      commercial_strategy <- 'Retain and maintain'
  }
  
  valueBox("Commercial Strategy", caption = commercial_strategy, color = "primary")
})
```

### Financial Strategy

```{r}
valueBoxOutput("financial")
```

```{r, context="server"}
output$financial <- renderValueBox({
  
  req(input$customer_id)
        
  selected_customer_id <- test_tbl_with_ids$customerID[1]
  selected_customer_id <- input$customer_id
  
  customer_tbl <- test_tbl_with_ids %>% 
      filter(customerID == selected_customer_id)
  
  if (customer_tbl$PaymentMethod %in% c('Mailed Check', 'Electronic Check')) {
    financial_strategy <- 'Move to credit card or bank transfer'
  } else {
    financial_strategy <- 'Retain and maintain'
  }
  
  valueBox("Financial Strategy", caption = financial_strategy, color = "warning")
})
```

```{js}
$(document).on("shiny:sessioninitialized", function() {
  $("#section-strategies .value-box").hover( 
    function(e) {
      var id = $(this).find(".shiny-valuebox-output").attr('id');
      Shiny.onInputChange("strategy_box_hover", id); 
    },
    function(e) {
      Shiny.onInputChange("strategy_box_hover", 'none'); 
    }
  );
});

```

Customer Analysis
-----------------------------------------------------------------------------

### Customer Details {data-width=33}

```{css}
table.dataTable thead {
  display:none;
}
table.dataTable tr.selected td, 
table.dataTable td.selected {
  background-color: #c3dbf7 !important;
  border-color: #c3dbf7 !important;
}
```

```{r}
DT::dataTableOutput('customer_info_tbl')
```

```{r, context="server"}
output$customer_info_tbl <- DT::renderDataTable({
        
  req(input$customer_id)
  
  selected_customer_id <- test_tbl_with_ids$customerID[1]
  selected_customer_id <- input$customer_id
  
  customer_info <- test_tbl_with_ids %>% 
      filter(customerID == selected_customer_id) %>% 
      mutate(tenure = paste0(tenure, ifelse(tenure == 1, ' Month', ' Months'))) %>% 
      select(customer_feature_vars) %>% 
      gather(metric, value)
  
  DT::datatable(
    customer_info, 
    rownames = NULL, 
    options = list(
        dom = 't', 
        bSort = FALSE, 
        paging = FALSE
    )
  )
})

observeEvent(input$strategy_box_hover, {
    
  strategy_hover <- input$strategy_box_hover
        
  if (strategy_hover == 'none') {
    row_indices <- 0
  } else {
    strategy_features <- get(paste0(strategy_hover, '_vars'))
    row_indices <- match(strategy_features, customer_feature_vars)
  }
  
  DT::dataTableProxy('customer_info_tbl') %>% 
    DT::selectRows(row_indices)
})
```


### Contributions to Churn (LIME) {data-width=67}

```{r}
billboarderOutput('customer_explanation')
```

```{r, context="server"}
output$customer_explanation <- renderBillboarder({
     
  req(input$customer_id)
  
  selected_customer_id <- test_tbl_with_ids$customerID[1]
  selected_customer_id <- input$customer_id
  
  # Run lime() on training set
  explainer <- lime(
    x = x_train_tbl,
    model = model_keras,
    bin_continuous = FALSE
  )
  
  customer_index <- test_tbl_with_ids %>% 
    mutate(rownum = row_number()) %>% 
    filter(customerID == selected_customer_id) %>%
    select(rownum)
  
  # Run explain() on explainer
  set.seed(42)
  explanation <- explain(
    x_test_tbl[customer_index$rownum,], 
    explainer = explainer, 
    n_labels = 1, 
    n_features = length(x_test_tbl),
    kernel_width = 0.5
  )
  
  type_pal <- c('Supports', 'Contradicts')
  explanation$type <- factor(ifelse(sign(explanation$feature_weight) == 
                                        1, type_pal[1], type_pal[2]), levels = type_pal)
  description <- paste0(explanation$case, "_", explanation$label)
  desc_width <- max(nchar(description)) + 1
  description <- paste0(format(description, width = desc_width), 
                        explanation$feature_desc)
  explanation$description <- factor(description, levels = description[order(abs(explanation$feature_weight))])
  explanation$case <- factor(explanation$case, unique(explanation$case))
  
  explanation_plot_df <- explanation %>%
    mutate(churn_predictor = case_when(
        (label == 'Yes' & type == 'Supports') | (label == 'No' & type == 'Contradicts') ~ 'More likely to churn',
        (label == 'Yes' & type == 'Contradicts') | (label == 'No' & type == 'Supports') ~ 'Less likely to churn'
    )) %>%
    arrange(-abs(feature_weight)) %>% 
    head(20)
  
  billboarder() %>%
    bb_barchart(
        data = explanation_plot_df,
        mapping = bbaes(x = feature_desc, y = feature_weight, group = churn_predictor),
        rotated = TRUE,
        stacked = TRUE
    ) %>%
    bb_colors_manual('Less likely to churn' = 'rgba(63, 182, 24, 0.7)', 'More likely to churn' = 'rgba(255, 0, 57, 0.7)')
})
```

Churn Facets {data-orientation=rows}
============================================================================

Sidebar {.sidebar}
----------------------------------------------------------------------------

```{r}
selectInput('payment_methods', 'Payment Method', 
            c('All', unique(churn_data_raw$PaymentMethod)))

selectInput('tech_support', 'Tech Support', 
            c('All', unique(churn_data_raw$TechSupport)))

selectInput('monthly_charge_range', 'Monthly Charge Range', 
            c('All', unique(churn_data_raw$monthly_charge_range)))

selectInput('tenure_range', 'Tenure Range', 
            c('All', unique(churn_data_raw$tenure_range)))
```

```{r, context="server"}
churn_analysis_data <- reactive({
  
  churn_data_filtered <- churn_data_raw
  
  if (input$payment_methods != 'All') {
    churn_data_filtered <- filter(churn_data_filtered, PaymentMethod == input$payment_methods)
  }
  
  if (input$tech_support != 'All') {
    churn_data_filtered <- filter(churn_data_filtered, TechSupport == input$tech_support)
  }
  
  if (input$monthly_charge_range != 'All') {
    churn_data_filtered <- filter(churn_data_filtered, monthly_charge_range == input$monthly_charge_range)
  }
  
  if (input$tenure_range != 'All') {
    churn_data_filtered <- filter(churn_data_filtered, tenure_range == input$tenure_range)
  }
  
  churn_data_filtered
})

bb_colors <- function(bb) {
  bb %>% bb_colors_manual('Yes' = 'rgba(255, 0, 57, 0.7)', 'No' = 'rgba(63, 182, 24, 0.7)')
}
```

Row 
----------------------------------------------------------------------------

### Monthly revenue by type of contract

```{r}
billboarderOutput('monthly_revenue')
```

```{r, context="server"}
output$monthly_revenue <- renderBillboarder({
   
  plot_df <- churn_analysis_data() %>% 
    group_by(Churn, Contract) %>% 
    summarise(monthly_revenue = sum(MonthlyCharges))
    
    billboarder() %>% 
      bb_barchart(
        data = plot_df,
        mapping = bbaes(x = Contract, y = monthly_revenue / 10000, group = Churn),
        stacked = TRUE,
        rotated = TRUE
      ) %>% 
      bb_y_axis(label = list(text = "Revenue (USD, in thousands)",
                             position = "outer-top")) %>% 
      bb_colors()
})
```

### Number of customers by type of contract
  
```{r}
billboarderOutput('number_of_customers')
```  
  
```{r, context="server"}
output$number_of_customers <- renderBillboarder({
    
  plot_df <- churn_analysis_data() %>% 
    group_by(Churn, Contract) %>% 
    summarise(number_of_customers = n())
    
    billboarder() %>% 
      bb_barchart(
        data = plot_df,
        mapping = bbaes(x = Contract, y = number_of_customers, group = Churn),
        stacked = TRUE,
        rotated = TRUE
      ) %>% 
      bb_y_axis(label = list(text = "Customer Count",
                             position = "outer-top")) %>%
      bb_colors()
})
```  
    
Row 
----------------------------------------------------------------------------
    
### Monthly revenue churn
    
```{r}
billboarderOutput('pct_monthly_revenue')
```  

```{r, context="server"}
output$pct_monthly_revenue <- renderBillboarder({
        
  plot_df <- isolate(churn_analysis_data()) %>% 
    group_by(Churn) %>% 
    summarise(monthly_revenue = sum(MonthlyCharges)) %>% 
    ungroup %>% 
    mutate(pct = round(monthly_revenue / sum(monthly_revenue), 2)) %>% 
    select(-monthly_revenue) %>% 
    mutate(x = 'Churn') %>% 
    spread(Churn, pct)
      
  billboarder() %>% 
    bb_barchart(
      data = plot_df,
      stacked = TRUE,
      rotated = TRUE
    ) %>% 
    bb_y_axis(label = list(text = "Percentage, Monthly Revenue",
                             position = "outer-top")) %>%
    bb_colors()
})
```

### Customer churn
    
```{r}
billboarderOutput('pct_customers')
```  

```{r, context="server"}
output$pct_customers <- renderBillboarder({
        
  plot_df <- churn_analysis_data() %>% 
    group_by(Churn) %>% 
    summarise(num_customers = n()) %>% 
    ungroup %>% 
    mutate(pct = round(num_customers / sum(num_customers), 2)) %>% 
    select(-num_customers) %>% 
    mutate(x = 'Churn') %>% 
    spread(Churn, pct)
        
  billboarder() %>% 
    bb_barchart(
      data = plot_df,
      stacked = TRUE,
      rotated = TRUE
    ) %>% 
    bb_y_axis(label = list(text = "Percentage, Customers",
                             position = "outer-top")) %>%
    bb_colors()
})
```

Row 
----------------------------------------------------------------------------

### Churn rate by tenure range    
    
```{r}
billboarderOutput('churn_rate_tenure')
```  

```{r, context="server"}
output$churn_rate_tenure <- renderBillboarder({
    
  plot_df <- churn_analysis_data() %>% 
    count(tenure_range, Churn) %>% 
    group_by(tenure_range) %>% 
    mutate(pct = round(n / sum(n), 2)) %>% 
    ungroup
  
  plot <- billboarder() %>% 
    bb_y_grid(
        lines = list(
          list(value = mean(churn_analysis_data()$Churn == 'Yes'), text = "Average Churn Rate")
        )
    ) %>% 
    bb_y_axis(label = list(text = "Percentage, Customers",
                             position = "outer-top")) %>%
    bb_colors()
    
  if (nrow(plot_df) == 2) {
    plot_df <- plot_df %>% 
      select(-n) %>% 
      spread(Churn, pct)
    
    plot <- plot %>% 
      bb_barchart(
        data = plot_df,
        stacked = TRUE,
        rotated = TRUE
    )
  } else {
    plot <- plot %>% 
      bb_barchart(
        data = plot_df,
        mapping = bbaes(x = tenure_range, y = pct, group = Churn),
        stacked = TRUE,
        rotated = TRUE
      ) 
  }
  
  plot
})
```

### Churn rate by internet service    
    
```{r}
billboarderOutput('churn_rate_internet_service')
```  

```{r, context="server"}
output$churn_rate_internet_service <- renderBillboarder({
  plot_df <- churn_analysis_data() %>% 
    count(InternetService, Churn) %>% 
    group_by(InternetService) %>% 
    mutate(pct = round(n / sum(n), 2))
  
  billboarder() %>% 
    bb_barchart(
      data = plot_df,
      mapping = bbaes(x = InternetService, y = pct, group = Churn),
      stacked = TRUE,
      rotated = TRUE
    ) %>% 
    bb_y_grid(
      lines = list(
        list(value = mean(churn_analysis_data()$Churn == 'Yes'), text = "Average Churn Rate")
      )
    ) %>% 
    bb_y_axis(label = list(max = 1, 
                           text = "Percentage, Customers",
                           position = "outer-top")) %>%
    bb_colors()
})
```

Correlation Analysis
=============================================================================

```{r}
plotOutput('corr_analysis')
```

```{r, context="server"}
output$corr_analysis <- renderPlot({
        
  withProgress(message = 'Generating correlations plot', value = 0.6, {
    
    # Feature correlations to Churn
    corrr_analysis <- x_train_tbl %>%
      mutate(Churn = y_train_vec) %>%
      correlate() %>%
      focus(Churn) %>%
      rename(feature = rowname) %>%
      arrange(abs(Churn)) %>%
      mutate(feature = as_factor(feature))
         
    # Correlation visualization
    corrr_analysis %>%
      ggplot(aes(x = Churn, y = fct_reorder(feature, desc(Churn)))) +
      geom_point() +
      # Positive Correlations - Contribute to churn
      geom_segment(aes(xend = 0, yend = feature),
                   color = palette_light()[[2]],
                   data = corrr_analysis %>% filter(Churn > 0)) +
      geom_point(color = palette_light()[[2]],
                 data = corrr_analysis %>% filter(Churn > 0)) +
      # Negative Correlations - Prevent churn
      geom_segment(aes(xend = 0, yend = feature),
                   color = palette_light()[[1]],
                   data = corrr_analysis %>% filter(Churn < 0)) +
      geom_point(color = palette_light()[[1]],
                 data = corrr_analysis %>% filter(Churn < 0)) +
      # Vertical lines
      geom_vline(xintercept = 0, color = palette_light()[[5]], size = 1, linetype = 2) +
      geom_vline(xintercept = -0.25, color = palette_light()[[5]], size = 1, linetype = 2) +
      geom_vline(xintercept = 0.25, color = palette_light()[[5]], size = 1, linetype = 2) +
      # Aesthetics
      theme_tq() +
      labs(title = "Churn Correlation Analysis",
           subtitle = "Positive Correlations (contribute to churn), Negative Correlations (prevent churn)",
           y = "Feature Importance")
    })
})
```