Chris Lee https://github.com/clfee/home/gallery.html Data science applications brought to you by Chris Lee https://github.com/clfee/home/assets/img/cmm1.PNG Chris Lee https://github.com/clfee/home/gallery.html quarto-1.4.554 Tue, 25 Feb 2025 06:00:00 GMT Demand Forecasting: Building a Base Model & Sharing through a Shiny App Chris Lee https://github.com/clfee/home/posts/2025-02-25-demand-forecasting/

Overview

Forecasting has always been at the forefront of decision making and planning.

The uncertainty that surrounds the future is both exciting and challenging, with individuals and organizations seeking to minimize risks and maximize utilities. In the last article we completed an EDA of the sales data and discovered that promotions boosted sales in some but not all stores.Here we will forecast at the order_id crossed with center_id level.

We want to try a couple different models, including exponential smoothing(ets) and tbats from the forecast package and compare them against baseline models including naive, seasonal naive, and mean based forecasts. Ideally we will find a model type that performs best across all levels and can serve as our base model in production. Once we compare these models and find a base model, we can also look deeper into the results to try to build ideas for further improvement upon our base model.

The paper provides a detailed discussion of various forecasting methods, comparing them across different dimensions such as accuracy, complexity, and adaptability.

Classical statistical methods are based on time series modeling and statistical inference. Exponential Smoothing (ETS) and Autoregressive Integrated Moving Average (ARIMA) are commonly used as baselines in forecastingcompetitions.

Kaggle - Food Demand Forecasting.

Back to top ]]> Shiny Forecasting https://github.com/clfee/home/posts/2025-02-25-demand-forecasting/ Tue, 25 Feb 2025 06:00:00 GMT Forecasting: Exploratory Data Analaysis Chris Lee https://github.com/clfee/home/posts/2025-01-15-forecasting-for-data-analysis/

Overview

Why Forecasting Matters for Our Business

Predicting customer demand is crucial for growing business. Without reliable forecasts, we risk stockouts or excess inventory, leading to wasted resources. This is especially important for our wedding and event catering service, where we work with perishable ingredients. By precisely estimating daily and weekly demand, we can optimize inventory, reduce waste, control costs, and consistently meet customer expectations.

Before diving into forecasting, we’ll start with data exploration. This includes analyzing variable distributions, handling missing values, and uncovering key insights. For this analysis, we’ll use a dataset from Kaggle. You can explore it here: Kaggle - Food Demand Forecasting.

The data contains information from 77 stores over a period of 145 weeks.
Two types of promotions (web, email) were shown in the data as below:
- 10.61% stores ran one type of promotion.
- 4.21% stores ran both types at the same time.
- 85.18% stores didn’t run any promotions.

Our initial analysis is aim to discover:
(1) Did revenue or profit increase?
(2) Which promotion worked best?
(3) To predict future demand for our menu items.

Data Summary

The data contains no missing values.

Code 
```{r}
#| label: Overview data
#| fig-cap: "Indentify missing values"
#| code-fold: true
#| fig-width: 8
#| fig-height: 6

# Check for missing values
kable(colSums(is.na(train)))
```
x
id 0
week 0
center_id 0
meal_id 0
checkout_price 0
base_price 0
emailer_for_promotion 0
homepage_featured 0
num_orders 0
city_code 0
region_code 0
center_type 0
op_area 0
category 0
cuisine 0
promotions 0
profit 0
promotion_flag 0

Indentify missing values

Categorical Variables

Center Type: Three types, with ‘TYPE_A’ being the most frequent.
Meal Category: Fourteen categories, ‘Beverages’ being the most frequent.
Cuisine: Four types, with ‘Italian’ being the most common.

Code 
```{r}
#| label: Overview categorical data
#| fig-cap: " Distribution of the categorical variables"
#| warning: false
#| code-fold: true
#| fig-width: 8
#| fig-height: 6

freq_data <- function(df){

  df <- as.data.frame(df)
  results_list <- vector("list", ncol(df) - 1)
  
  # Loop through the columns starting from the 2nd column
  for (i in 2:ncol(df)) {
       # Store the result of cal_freq(i) in the list
       results_list[[i - 1]] <- cal_freqx(i, df)
      }
  df <- do.call(rbind, results_list)

  # label bar graph
  df$vars <- ifelse(df$Freqx > 0.08, as.character(df$Var1), "")
  return(df)
}
 p <-  freq_data(train |> select(-promotion_flag) |> mutate(store_id = as.factor(center_id)))

 p |>
       ggplot(aes(x = round(Freqx,2), y = fct_rev(namex), fill = Var1)) + 
       geom_col(position = "fill", color = "white") +
       scale_x_continuous(labels = label_percent()) +
       labs(title = "Distribution of Categorical Variables:",
       subtitle = paste("Top to down :" , unique(p$namex)[2],"," ,unique(p$namex)[1],"," , unique(p$namex)[3],"," , unique(p$namex)[4],"," , unique(p$namex)[5]),y = NULL, x = NULL, fill = "var1")+
       guides(fill="none") +
       geom_text(aes(label = vars), position = position_stack(vjust = 0.5),
                 color = "white")+
      theme_void()
```

Distribution of the categorical variables

Numerical Variables

ID Variables: id, week, center_id, meal_id
Pricing Variables: checkout_price, base_price
Demand Variable (Target): num_orders
Location and Size Variables: city_code, region_code, op_area

Code 
```{r}
#| label: data distribution
#| fig-cap: ""
#| code-fold: true
#| fig-width: 8
#| fig-height: 4

# Plot the original distribution of num_orders
s1 <- 
  train|>
  ggplot(aes(x = (num_orders))) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7) +
  geom_density(alpha = 0.5, color = "#d88bb4") +
  ggtitle("Distribution of num_orders") +
  xlab("num_orders") +
  ylab("Frequency")+
  theme_minimal()

s2 <- 
  train|>
  ggplot(aes(x = (checkout_price))) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7) +
  geom_density(alpha = 0.3, color = "#d88bb4", outline.type = "upper") +
  ggtitle("Distribution of checkout_price") +
  xlab("checkout_price") +
  ylab("Frequency")+
  theme_minimal()

s3 <- 
  train|>
  ggplot(aes(x = (base_price))) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7) +
  geom_density(alpha = 0.5, color = "#d88bb4") +
  ggtitle("Distribution of base_price") +
  xlab("base_price") +
  ylab("Frequency")+
  theme_minimal()

s4 <- 
  train|>
  ggplot(aes(x = (op_area ))) +
  geom_histogram(bins = 50, fill = "steelblue", alpha = 0.7) +
  geom_density(alpha = 0.5, color = "#d88bb4") +
  ggtitle("Distribution of base_price") +
  xlab("operation area") +
  ylab("Frequency")+
  theme_minimal()



#kable(summary(train))
#grid.arrange(s1, s2, s3, ncol = 3)
plot_grid(s1, s2, s3, s4, labels="AUTO")
```

Time series engineering 

Computes correlations to identify feature importance.

Code 
```{r}
#| label: time series engineering
#| fig-cap: ""
#| code-fold: true
#| fig-width: 8
#| fig-height: 6

df_filtered <- train |>
  #filter(center_id %in% c(24:26))|>
  group_by(week,center_id,meal_id, promotion_flag) |>
  summarise(avg_order = mean(num_orders), .groups = 'drop')|>
  arrange(week) |>
  mutate(
    num_orders_lag_1 = lag(avg_order, 1, default = 0),
    num_orders_lag_2 = lag(avg_order, 2, default = 0),
    num_orders_lag_4 = lag(avg_order, 4, default = 0),
    num_orders_ma_2 = rollapply(avg_order, width = 2, FUN = mean, fill = NA, align = "right"),
    num_orders_ma_4 = rollapply(avg_order, width = 4, FUN = mean, fill = NA, align = "right"),
    week_sin = sin(2 * pi * week / 52),
    week_cos = cos(2 * pi * week / 52)
  )

# ---------- Compute Correlation and Feature Importance -----
 cor_matrix_menu <- cor(df_filtered |> select( -promotion_flag), use = "complete.obs")
corrplot(cor_matrix_menu,  method = "color",col = COL2('PiYG', 100), addCoef.col = "black", tl.col = "black", type = 'lower', tl.srt = 45)
```

Results

Since we are trying to forecast future demand, we can plot sales and profit of different promotions over time. To do this, we average the data across stores, as this can allow smoothing of the noise to see more of the signal.

Visulization: Effect of Promotion types on Weekly Profit in each store

As one of our goals is to identify patterns and correlations between promotion types, individual store performance, and weekly profit trends. We first used a heatmap to help us visualize how well our stores are performing over time and how different promotions impact our profits. Each cell in the heatmap represents the average profit for a specific store (rows) during a specific week (columns). The color intensity (ranging from light to dark green) indicates the magnitude of average profit, with darker greens representing higher profits. The Color bar represents a profit from 10.0 to 20.0. The border of the cell represents the promotion type being carried out in the store for the corresponding week. Namely Promotion, Double promotion, Email promotion, No promotion, and Homepage promotion.

  1. While some stores (e.g., Store IDs around 40-50) consistently show higher profits (darker green), other stores (e.g., Store IDs around 140-150) show consistently lower profits (lighter green). This indicates that the strategies for these stores need a revisit.
  2. Weeks with promotions (identified by the border type) often correlate with higher profits (darker green cells). However, the effectiveness varies.
  3. Patterns in the heatmap suggest potential seasonal cycles, with profit fluctuations happening in waves.
Code 
```{r}
#| label: Heatmaps
#| fig-cap: " How Promotions Impact overall Profit?"
#| warning: false
#| code-fold: true
#| fig-width: 8
#| fig-height: 6

#library(pheatmap) ## for heatmap generation
#library(ggplotify) ## to convert pheatmap to ggplot2
#library(heatmaply) ## for constructing interactive heatmap

tstx <- train |>
    group_by(promotion_flag, center_id) |>
      dplyr::summarise(`Average Profit (log2)` = log(mean(profit),2))

testx <- tstx |>
  tidyr::pivot_wider(names_from = center_id, values_from = `Average Profit (log2)`)|>
  mutate(across(everything(), ~replace_na(.x, 0)))

testx <- data.frame(testx)
rownames(testx) <- testx$promotion_flag

flag <- data.frame(testx$promotion_flag)
rownames(flag) <- testx$promotion_flag
colnames(flag) <- "promotions"
cols <- colorRampPalette(c( "white", "lightgreen", "darkgreen"))(100)  
pheatmap(testx[,-c(1)],cutree_cols=2, cutree_rows=2, color = cols)
```

How Promotions Impact overall Profit?
Code 
```{r}
#| label: Overview profit with heatmap 
#| fig-cap: "Overview profit with heatmap "
#| warning: false
#| code-fold: true
#| fig-width: 10
#| fig-height: 10

#--------------- Heatmap overall------
train |>
    group_by(week, promotion_flag, center_id) |>
    dplyr::summarise(`Average Profit (log2)` = log(mean(profit),2))|>
  ggplot(aes(x = as.factor(week), y = as.factor(center_id), fill = `Average Profit (log2)`)) +
  geom_tile(aes(color = promotion_flag), linewidth = 0.5) + # Color outline for promotion
  scale_fill_gradient(low = "ivory", high = "darkgreen", name = "Average profit") +
scale_color_manual(values = c("Double promotion" = "red", "Email promotion" =
            "yellow", "Homepage promotion" = "orange","No promotion" = "white"),
                    name = "Promotion") +
  
  labs(title = " ", #Heatmap of Weekly Profit and Promotions per Store
       x = "Week", y = "Store ID") +
  theme_minimal() +
    theme(legend.position="bottom",
          axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
```

Overview profit with heatmap

Since we are trying to forecast future demand, we can plot sales and profit of different promotions over time. To do this, we average the data across stores, as this can allow smoothing of the noise to see more of the signal.

Visulization: Average Sales and Revenue Over Time

The blue line (No Promotions) is consistently lower and less volatile compared to other lines (Homepage promotion, Email promotion, Double promotion) in figure 1A. This suggests that promotions drive short-term spikes in sales, but the effect is not stable over time. There are frequent peaks and drops, indicating that sales surge when promotions are active but return to normal levels afterward. The profit trend (Figure 1B) mirrors the sales trend, confirming that higher sales during promotions contribute to revenue increases.However, the fluctuations in revenue suggest that while sales increase, revenue might not be growing at the same rate, possibly due to discounting.

Note: The non-promoted sales and revenue (blue line) remain relatively stable over time. The promoted periods exhibit more volatility, meaning promotions may be shifting demand rather than creating long-term sales growth.

Code 
```{r}
#| label: Time series plots of sales volume and revenue
#| fig-cap: " "
#| warning: false
#| code-fold: true
#| fig-width: 8
#| fig-height: 6

# ---------------------------
# 1. Time Series Plot of Sales Volume & Revenue
# ---------------------------
sales_trend <- train |>
  group_by(week, promotion_flag) |>
  dplyr::summarise(average_sales = log(mean(num_orders),2), 
            average_profit = log(mean(profit),2),
            .groups = 'drop')

# Plot Sales Volume Over Time

 a1 <-
   ggplot(sales_trend, aes(x = week, y = average_sales, color = as.factor(promotion_flag))) +
  geom_line(size = 1) +
  labs(title = "1A) Average Sales Volume Over Time", x = "", y = "Average Sales (log2)", color = "Promotion") +
  theme_minimal()+
   theme(legend.title=element_blank(),
         legend.position="bottom",
    panel.background = element_blank())+
    theme(axis.line = element_line(color = 'black'))+
    guides(color="none")

# Plot Revenue Over Time
 a2 <-
  ggplot(sales_trend, aes(x = week, y = average_profit, color = as.factor(promotion_flag))) +
  geom_line(size = 0.8) +
  labs(title = "1B) Profit Over Time", x = "Week", y = "Average Profit (log2)", color = "Promotion") +
  theme_minimal()+
   theme(legend.title=element_blank(),
         legend.position="bottom",
    panel.background = element_blank())+
    theme(axis.line = element_line(color = 'black'))
 
 grid.arrange(a1, a2, nrow = 2)
```

Promotion Effectiveness: Average Weekly Sales & Revenue by Promotion Type

Sales Volume
Figure 2A shows how many orders were placed under different types of promotions.The y-axis is in a log scale (log2), meaning the values grow exponentially. The median order volume is highest for double promotions (both email and homepage), followed by homepage promotions, no promotions, and email promotions. The spread (height of the box) indicates variability, with double promotions showing more fluctuation in sales. The presence of numerous outliers at the upper end indicates that some stores experience exceptionally high sales under promotional influence.

Checkout Price
Figure 2B shows the range of prices customers paid at checkout under different promotions. Unlike the sales volume, there is no major difference in checkout price across promotions. There is some right-skewness with outliers, suggesting a small number of high-value purchases, but the overall trend remains stable. This suggests that promotions influence the number of items bought, but not the price per visit.

Profit
Revenue is also log-transformed for better visualization as shown in figure 2C. Similar to the sales volume trend, double promotions generate the highest median revenue, followed by homepage promotions, no promotions, and email promotions. The spread of revenue is wider, meaning revenue varies significantly under all conditions. The presence of high-value outliers suggests that under certain conditions, promotions can lead to exceptionally high revenue generation.

Code 
```{r}
#| label: Boxplot of sales volume, checkout price and revenue
#| fig-cap: " "
#| warning: false
#| code-fold: true
#| fig-width: 8
#| fig-height: 4

# ---------------------------
# Boxplots of Sales with vs. without Promotion
# ---------------------------
a <- ggplot(train, aes(x = promotion_flag, y = log(num_orders,2), fill = promotion_flag)) +
  geom_boxplot() +
  labs(title = "2A) Sales Distribution", x = "", y = "Order Volume (log2)") +
  theme_minimal()+
    theme(
      legend.position="bottom",
      plot.title = element_text(size=11),
      axis.text.x = element_text(angle = 45, vjust = 0.5, hjust=0.2))+
  guides(fill="none")

b<- ggplot(train, aes(x = promotion_flag, y = checkout_price,  fill = promotion_flag)) +
  geom_boxplot() +
  labs(title = "2B) Checkout Price Distribution", x = "Promotion", y = "Checkout Price") +
  theme_minimal()+
    theme(
      legend.position="bottom",
      plot.title = element_text(size=11),
      axis.text.x = element_text(angle = 45, vjust = 0.5, hjust=0.2))+
  guides(fill="none")

c<- ggplot(train, aes(x = promotion_flag, y = log((profit),2), fill = promotion_flag)) +
  geom_boxplot() +
  labs(title = "2C) Profit Distribution", x = "", y = "Revenue (log2)") +
  theme_minimal()+
    theme(
      legend.position="bottom",
      plot.title = element_text(size=11),
      axis.text.x = element_text(angle = 45, vjust = 0.5, hjust=0.2))+
  guides(fill="none")

grid.arrange(a,b,c, ncol = 3)
```

Analysis of Meal Popularity During Promotions and No-Promotions

In figure 3A, the Meal IDs are arranged from left to right in descending order based on their overall popularity (total percentage of orders). This visualization helps identify which meals are popular and how promotions influence demand.

Impact of Promotions:
Several meals (especially on the left side of the plot) show a significant increase in order percentage when a promotion is applied. This indicates that promotions can be effective in boosting the popularity of certain meals.For some meals, the Double promotion (email+homepage) or Email promotion seems to have a noticeable impact compared to “No promotion”.

Homepage Promotion Baseline:
Homepage promotion seems to be always present at some level for all meals, which suggests that homepage promotion might be a baseline strategy applied to all meals.

Meal-Specific Promotion Effectiveness:
Some meals respond well to specific types of promotions. For example, Meal ID 1962 sees a significant portion of its orders come from “promotion_flag”. Other meals, like Meal ID 1558, benefits more from “Email promotion”.

Meals with Low Promotion Impact:
On the right side of the plot, the meals have low percentages overall, and the impact of promotions appears to be less significant. This could mean these meals are less popular regardless of promotions, or that the current promotions are not effective for these meals.

Code 
```{r}
#| label: del Promotions Impact popular items
#| fig-cap: " How Promotions Impact checkout price?"
#| warning: false
#| code-fold: true
#| fig-width: 8
#| fig-height: 8

c1 <- 
train |>
  group_by(promotion_flag)|>
  dplyr::count(meal_id) |>
  mutate(p = round(100*(n / sum(n)),2))|>
  select(-n)|>
  ggplot(aes(x = reorder(factor(meal_id),p,, decreasing = TRUE),  fill = promotion_flag)) +
  geom_bar(aes(y = p), stat='identity', alpha=0.7) +
  scale_color_manual(values=c('Order Percent'="#d88bb4")) +
  labs(x = '', y = 'Percentage', 
       title = '3A) Popular Meals During Promotions and No Promotions') +
  theme_minimal()+
  theme(legend.position="bottom",
        axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=0.5))+
  guides(fill="none")
c2 <- 
train|>
  #filter(meal_id %in% radom_meal)|>
  group_by(meal_id, promotion_flag) |>
  summarise(avg_profit = mean(profit), .groups = 'drop')|>
  ggplot(aes(x = as.factor(meal_id), y = log(avg_profit,2), fill = as.factor(promotion_flag))) +
  geom_bar(stat = "identity", position = "dodge") +
  labs(title = "3B) Average Profit per Menu Item (With & Without Promotion)", x = "Menu ID", y = "Avg Profit (log2)", fill = "Promotion") +
  theme_minimal()+
  #guides(fill="none") +
    theme(legend.position="bottom",
        axis.text.x = element_text(angle = 90, vjust = 0.2, hjust=0.1))

grid.arrange(c1, c2, nrow = 2)
```

How Promotions Impact checkout price?

Analysis of Meal Popularity During Promotions and No-Promotions

The average profit per menu item (on the log2 scale) generally falls between approximately 12 and 16 in figure 3B. There’s noticeable variation in average profit across different menu items (identified by their Menu ID). Indeed, we compare the mean profits for No promotion vs. promotins (homepage, email, and homepage+email), the p-value is less than 0.05 from ANOVA test results show promotions substantially impact profits across menu items.

We also see some items are inherently more profitable than others, regardless of the promotion strategy. Certain menu items (e.g., 1248, 1445, 1558) show higher profits under double (homepage and email) promotion, suggesting targeted discounts may work well for these meals. This may indicate that these meals experience higher order volume during promotions, making up for the reduced margin. Since, this isn’t universally true for all menu items. Promotions should be customized per meal item—apply them only where they result in a net positive profit effect.

Code 
```{r}
#| label: Promotions Impact checkout price
#| fig-cap: " How Promotions Impact checkout price?"
#| warning: false
#| code-fold: true
#| fig-width: 8
#| fig-height: 6

# Compute average checkout_price and number of orders before and during promotions for each meal

checkout_price_comparison <- train|>
  group_by(meal_id, promotions) |>
  summarise(avg_checkout_price = mean(checkout_price, na.rm = TRUE)) |>
  spread(promotions, avg_checkout_price)|>
  mutate(Price_Change_Percent = 100*(Yes - No)/No)

comparison_df_order <- train |>
  group_by(meal_id, promotions) |>
  summarise(avg_num_orders = mean(num_orders, na.rm = TRUE))|>
  spread(key = promotions, value = avg_num_orders)|>
  mutate(Order_Change_Percent = 100*(Yes - No)/No)

comparison_df <- left_join(comparison_df_order|> select(meal_id, Order_Change_Percent),
                           checkout_price_comparison|> select(meal_id, Price_Change_Percent),
                           by = "meal_id") 
# Check correlation between Price_Change_Percent vs Order_Change_Percent
correlation_po <- round(cor(comparison_df$Order_Change_Percent , 
                            comparison_df$Price_Change_Percent , use = "complete.obs"),2)


# Plot the results
ggplot(comparison_df, aes(x = reorder(factor(meal_id),round(Price_Change_Percent,2)))) +
  geom_bar(aes(y = Price_Change_Percent), stat='identity', fill='steelblue', alpha=0.7) +
  geom_line(aes(y = 0.1*(Order_Change_Percent+4), group=1, color='Order Change Percent'), size=0.8) +
  geom_point(aes(y = 0.1*(Order_Change_Percent+4), color='darkgray'),shape=21, size=2) +
  scale_color_manual(values=c('Order Change Percent'="#d88bb4")) +
  labs(x = 'Meal ID', y = 'Percentage Change', 
       title = '4) Checkout Price Change & Order Volume Change During Promotions',
       subtitle = paste("Correlation : Price Change vs. Order Volumne :" , correlation_po )) +
  theme_minimal()+
  theme(legend.position="bottom",
        axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
```

How Promotions Impact checkout price?

Keytakeaways

As shown in the heatmap, we know not all stores respond promotions, and some can maintain high profitability without them. We should consider store-specific promotion strategies instead of universal discounting. While double promotions drive the highest sales and revenue, homepage and email promotions individually are not as effective as using both together.

The data shows checkout price per transaction remains stable regardless of the promotion type, meaning the increase in revenue comes from selling more, not from charging more. We can identify stores where promotions significantly boost profits and focus campaigns on those locations. For low-response stores, explore alternative marketing (e.g., bundling, loyalty programs).

Back to top ]]> Data Visualization https://github.com/clfee/home/posts/2025-01-15-forecasting-for-data-analysis/ Sat, 01 Feb 2025 06:00:00 GMT Graphs for Communication - Creating Animated Maps Chris Lee https://github.com/clfee/home/posts/2025-02-01-Graphs-for-Communication/ Making the data easier to understand!

Goal : To demonstrate how to create animated maps with ggplot2 and gganimate in R to track MRSA BSI incidence in the State of California.

Graphs for Communication

Earlier this year, I prepared a presentation for our stakeholders to showcase our business performance, particularly after the lifting of restrictions on large events and gatherings. While we saw overall growth, the performance varied across different locations. One of the key focuses of the presentation was to illustrate how sales at wedding venues and restaurants evolved over time.

To make the data not only accurate but also engaging, I used the ggplot2 and gganimate packages in R. These tools allowed me to transform raw numbers into visually compelling animations, making the data more understandable and impactful for the audience.

This same storytelling approach can be applied to datasets tracking Methicillin-resistant Staphylococcus aureus (MRSA) bloodstream infections (BSI) (BSI) in California Hospitals.

These datasets include 95% confidence intervals for the Standardized Infection Ratio (SIR) and statistical interpretations to compare MRSA BSI incidence against the national baseline. Additionally, the data tracks hospital progress towards national Healthcare-Associated Infection (HAI) reduction goals. Hospitals need to meet or exceed incremental SIR targets each year to stay on track.

In this exercise, we will create an animated map to show whether MRSA BSI incidence in California was the same, better, or worse than the national baseline from 2019 to 2023. The map will use a color scale ranging from purple (-1, indicating worse than the national average) to yellow (1, indicating better than the national average) to depict these comparisons.

Steps

The first section simply loads the libraries and data that will be used.

Code 
```{r}
#| context: setup
#| code-fold: true
#| warning: false

# Load required packages
library(gganimate)
library(gifski)
library(dplyr)
library(tidyverse)
library(dplyr)
library(ggplot2)


# Load data
url_2022 <- "https://data.chhs.ca.gov/dataset/a345bba7-25ed-4019-b6e3-0b597bea7368/resource/3ff809c6-c1e2-4107-be0c-f976521aadb2/download/mrsa_bsi_odp_2022.csv"
url_2021 <- "https://data.chhs.ca.gov/dataset/a345bba7-25ed-4019-b6e3-0b597bea7368/resource/23bef156-ae4d-4800-8512-d29660b2269f/download/cdph_mrsa_bsi_odp_2021.csv"
url_2019 <- "https://data.chhs.ca.gov/dataset/a345bba7-25ed-4019-b6e3-0b597bea7368/resource/62aead61-e320-4a74-b64c-1f65efa72b35/download/cdph_mrsa_bsi_odp_2019.csv"
url_2023 <-"https://data.chhs.ca.gov/dataset/a345bba7-25ed-4019-b6e3-0b597bea7368/resource/15c4962f-e357-4b03-9d24-655a2bc8030c/download/mrsa_bsi_odp_2023.csv"

data_2023 <- read_csv(url_2023)
data_2022 <- read_csv(url_2022)
data_2021 <- read_csv(url_2021)
data_2019 <- read_csv(url_2019)

# Combine data
mrsa_combine <- bind_rows(data_2023,data_2022, data_2021, data_2019)

# Remove redundant data
mrsa_combine <- unique(mrsa_combine)
# Lon and lat info
us_counties <- map_data("county")|> filter(region =="california")|> mutate( subregion = toupper( subregion))|> dplyr::select(-c( order,  region)) 

# Data transformation
mrsa_combine <- mrsa_combine |>
  dplyr::select(-State, -HAI, -Met_2020_Goal, -SIR_CI_95_Lower_Limit,-SIR_CI_95_Upper_Limit, -On_Track, -Notes) |>
  mutate(Months = as.numeric(ifelse(is.na(Months), 13, Months)),
         Year = as.integer(ifelse(is.na(Year), 2021, Year)),
         Comparison = case_when(
      Comparison == "Worse" ~ -1,
      Comparison == "Better" ~ 1,
      Comparison == "Same" ~ 0,
      .default = 0),
         Patient_Stay = cut(      
           Patient_Days,
           breaks = quantile(Patient_Days, probs = seq(0, 1, by = 0.1), na.rm = TRUE),
           labels = 1:10),
         Months = as.character(Months),
         Year = as.character(Year),
         Infections_Reported = as.numeric(Infections_Reported))|>
  filter(!grepl("Pooled", Facility_Name, ignore.case = TRUE),
         !grepl("Pooled", Facility_Type, ignore.case = TRUE))|> 
  mutate( subregion = toupper(County))
```

Step 1

As gganimate extends the grammar of graphics as implemented by ggplot2 to include the description of animation. Therefore, we will need to generate a base map using ggplot2. Then, add a function of facet_wrap(Hospital_Category_RiskAdjustment) to track the average performance of each hospital category in each county across California.

Step 2

Then, the gganimate library is used to animate the display of color by year (2019 – 2023). Here we define the transition time (in years), add a title and subtitle.

Note: 1. transition_*() defines how the data should be spread out and how it relates to itself across time.
2. The comparison is depicted values and colors range from -1 (purple, worse than the national average) to 1 (yellow, better than the national average).

Code 
```{r}
#| title: Bloodstream infections (BSI) compare to national overtime
#| code-fold: true
#| warning: false
#| fig-width: 8
#| fig-height: 8

st <- mrsa_combine|>
    dplyr::select(subregion, Year, Comparison,Hospital_Category_RiskAdjustment)|>
  mutate(Year = as.integer(Year))|>
  group_by(subregion, Year,Hospital_Category_RiskAdjustment)|> 
  summarise(`national baseline` = round(mean(na.omit(as.numeric(Comparison))),2)) 

st <- left_join(st, unique(us_counties), by= "subregion", relationship = "many-to-many") 

a <-
st|> 

  ggplot(mapping = aes(x = long, y = lat, group = group, fill = `national baseline` ))+
              geom_polygon(color = "gray90", linewidth = 0.3) +
  coord_map(projection = "albers", lat0 = 39, lat1 = 45) +
  scale_fill_continuous(type = "viridis")+
  theme(axis.line=element_blank(),
        axis.text=element_blank(),
        axis.ticks=element_blank(),
        axis.title=element_blank(),
        panel.background=element_blank(),
        panel.border=element_blank(),
        panel.grid=element_blank())+
        scale_color_gradient(low = "green", high = "red")+ 
   facet_wrap(~Hospital_Category_RiskAdjustment)
            
            
a + transition_time(Year) +labs(title = "MRSA BSI incidence compares to the national baseline, Year: {frame_time}")
```

Bonus

Also compatible with other ggplot graphs!

In this example we see trend plots of continuous variables infections cases and days of patient hospital stays between 2019 and 2023.

Did you notice the length of patient stay in a hospital is not necessarily positive correlated with numbers of reported cases (except for the acute care hospital category)?

Code 
```{r}
#| title: Patients Days vs Reported infection cases 
#| code-fold: true
#| warning: false
#| fig-width: 8
#| fig-height: 8

st <- left_join(mrsa_combine, unique(us_counties), by= "subregion", relationship = "many-to-many") 

p <-     
  st|> 
  ggplot(aes(x= Patient_Days, y= Infections_Reported))+
    geom_point(alpha = 0.5, show.legend = FALSE, color = "#167bb2") +
    scale_size(range = c(2, 12)) +
    theme_bw()+
    ggtitle(paste0("Length of Patients stay vs Reported infection cases")) +
    theme(#axis.text.x=element_blank(),
          axis.text=element_text(size=12),
          legend.position = "bottom",
          axis.line = element_line(colour = "black"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_blank(),
          panel.background = element_blank())+
          facet_wrap(~Hospital_Category_RiskAdjustment)+
    xlab("Days")+ylab("Cases")+labs(caption="Produced by CF Lee")


p + transition_time(as.integer(Year))+  
  enter_fade() +
  exit_fade()+labs(title = "Year: {frame_time}")
```

Resources

  1. gganimate link
  2. California Hospitals data.
Back to top ]]> R Data organization https://github.com/clfee/home/posts/2025-02-01-Graphs-for-Communication/ Sun, 01 Sep 2024 05:00:00 GMT Automated Reporting: A Game-Changer for Data Analysis Chris Lee https://github.com/clfee/home/posts/2024-08-16-automated-custom-reports/ In the fast-paced world of data analysis, efficiency is key. Automated reporting is revolutionizing how we handle recurring data-rich reports, offering on-demand production and enhanced data exploration capabilities. This innovative approach not only saves time but also allows for deeper, more strategic insights. Parameterized reporting is a cutting-edge technique that enables simultaneous generation of multiple reports. This method not only boosts productivity but also significantly reduces errors associated with manual data handling.

Goal : The objective of this report is to demonstrate how to create automated custom reports with Quarto and Purrr in R to track patient days from public data.

Real-World Application: California MRSA Data Analysis

To illustrate the power of automated reporting, let’s consider a case study using data from the California California Health and Human Services Open Data Portal. The demo uses the data from All California general acute care hospitals are required to report Methicillin-resistant Staphylococcus aureus (MRSA) bloodstream infection (BSI) cases that occur following hospitalization. MRSA is a serious, contagious bacterial infection that starts on your skin. It’s a type of staph infection that resists most common antibiotics, making it especially dangerous. Without treatment, MRSA can be deadly.

Step-by-Step Guide

Step 1: Create a Single Report Template

We began by preparing a single report template using data from 2022. This template serves as the foundation for all subsequent reports. Let’s prepare a single report as a template from the data in 2022.

Healthcare Associated Infection Report, 2022

Results

Figure 1: Box plots of Standardized Infection Ratio (SIR) in 2022.

Code 
```{r}
#| label: Boxplots
#| code-fold: true
#| warning: false

color_palette <- c("#167bb2","#2e3b4f","#7A6C5D","#2e4f42","#A54657","#624151","#16b29b","#002c47","#9d72d0"
)

 mrsa_combine|>
    filter(Year == params$year) |>
    filter(County %in% c("San Diego" ,"San Francisco", "Los Angeles", "Sacramento", "Orange","Yolo" ))|>
    ggplot(aes(x= Hospital_Type, y= SIR, fill=Hospital_Type))+
     geom_boxplot()+
    scale_fill_manual(values=color_palette)+
       theme(
      legend.position="none",
      plot.title = element_text(size=11),
      axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)
    ) +
    ggtitle(paste0("Standardized Infection Ratio (SIR) in ",params$year)) +
    xlab("")+ylab("")+labs(caption="Produced by CF Lee")+
   facet_wrap(~County)
```

Figure 2: Patients Days vs Reported infection cases in 2022

Code 
```{r}
#| code-fold: true
#| warning: false

 mrsa_combine$Months <- as.numeric(mrsa_combine$Months)

 mrsa_combine |> 
    filter(Year == params$year) |>
    mutate(Quarters = case_when(
                         Months > 0 & Months < 4 ~ 1,
                         Months > 3 & Months < 7 ~ 2,
                         Months > 6 & Months < 10 ~ 3 , 
                         Months > 9 & Months < 13 ~ 4 , 
                                .default = 4))|>
  # group_by(Quarters,Hospital_Category_RiskAdjustment, Year)|>
  #  summarise(mean = mean(na.omit(Infections_Reported)))|> 
    
    ggplot(aes(x= Patient_Days, y= Infections_Reported, 
               colour = as.integer(Quarters)))+
     geom_point(alpha = 0.7, show.legend = FALSE) +

    theme_bw()+
    ggtitle(paste0("Patients Days vs Reported infection cases in ",params$year)) +
    theme(#axis.text.x=element_blank(),
          axis.text=element_text(size=12),
          legend.position = "bottom",
          axis.line = element_line(colour = "black"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_blank(),
          panel.background = element_blank())+
          facet_wrap(~Hospital_Category_RiskAdjustment)+
    xlab("Days")+ylab("Cases")+labs(caption="Produced by CF Lee")
```

Note: Patient Days is define as below. A count of the number of patients in the hospital during a time period, excluding IRFs and IPFs with their own CCN numbers. A rehabilitation unit (IRF) with its own CCN number reports separately from the rest of the hospital. To calculate patient days, the number of patients is recorded at the same time each day for each day of the month. At the end of the month, the daily counts are summed. See the NHSN website: http://www.cdc.gov/nhsn.

Step 2: Generate All Report Variations

After creating the single report, we used an R script to render the parameterized Quarto template with each defined parameter. This step allows for the simultaneous generation of all report variations, ensuring consistency and accuracy.To do this, write an R script to render the parameterized Quarto template with each of the defined parameters.

In our example the code looks like this,

# 1. First create a dataframe 

data <- expand.grid(
  year = c(2019,2021:2023),
  record_date = Sys.Date(), 
  stringsAsFactors = FALSE)

df <- data |> 
  dplyr::mutate(
    output_format = "html",       # Output format (html, word, etc.)
    output_file = paste(          # Output file name
      year, "report.html",
      sep = "-"
    ),
    execute_params = purrr::map2( # Named list of parameters
      record_date, year, 
      \(record_date, year) list(record_date = record_date, year = year)
    )
  ) |> 
  dplyr::select(-c(record_date, year))

df

# 2. Use purrr::pwalk() to map over each row of the dataframe and render each report variation.

purrr::pwalk(
  .l = df,                      # Dataframe to map over
  .f = quarto::quarto_render,   # Quarto render function
  input = "demo_autoreport.qmd",       # Named arguments of .f
  .progress = TRUE              # Optionally, show a progress bar
)

By adopting this automated approach, analysts can shift their focus from report creation to data interpretation, leading to more impact decision-making and strategic planning.

Automatically generated reports, one after another!

Resources

  1. The raw data is obtained from California Health and Human Services Open Data Portal datasets

  2. Full code link

Back to top ]]> R Data organization https://github.com/clfee/home/posts/2024-08-16-automated-custom-reports/ Fri, 16 Aug 2024 05:00:00 GMT Tying the data together Chris Lee https://github.com/clfee/home/posts/2024-08-01-tying-the-data-together/

Have you ever get tired of typing functions into vlookup? In this post, we will use tidyverse in R to modify, combine, search, and merge several datasets. We will also create a shiny app allowing users to download the organized data.

Background & challenges

Recently, we reviewed our operational costs and found that a significant portion was allocated to credit card processing fees. After thorough research and negotiation, we secured a better deal with a new merchant service provider, saving about $1,500 USD per month and qualifying for next-day funding—a major win for our business.

However, our bookkeeper quickly identified an issue: the new provider’s reporting system is less straightforward. Unlike our previous provider, which offered a comprehensive master report with detailed order and funding information, the new service splits this data into three separate reports: Sales, Transaction, and Funded. To complicate matters, some data points, like order details, are labeled differently across the reports (e.g., order.ifo in Sales versus order_detail in Transaction). Additionally, a single order can have multiple funding references, making it challenging to track everything accurately.

Different column names and multiple funded entries for one order

Actions

To fully benefit from the cost savings and stick with the new provider, I decided to tackle this problem head-on using R and Shiny.

One of our goals was to create a master statement with all the action organized in one report as below. To do this, the steps are as below:

  1. We first re-organized the raw report by renaming the column names.
  2. Skipped the data where it is empty or contains not useful information.
  3. Data merge based on the same column names.

Desired master report
library(shiny)
Warning: package 'shiny' was built under R version 4.4.3
# identify columns appear in both data sets
renderUI({
    var_names <- intersect(names(data_a()), names(data_b()))
    selectInput("var_ab", "Select merge variable for Transaction and Sales", choices = var_names)
  })
# merge data 
  merged_data <- reactive({
    req(data_a(), data_b(), data_c(), input$var_ab, input$var_bc)
    temp_ab <- dplyr::full_join(data_a(), data_b(), by = input$var_ab)
    unique(dplyr::full_join(temp_ab, data_c(), by = input$var_bc))
  })

I also wanted to save time for our bookkeeper as they often need to cross-check the internal documents. This step takes time to find the correct range of the data, and input Vlookup functions before finding and labeling the matches in Excel. To streamline the process and to reduce the manual input errors, I replicated this function in the app (full code as below and on github).

The output result is shown below. This example shows that the order 891631 with two different retrieval references were received, the transactions were successful ,and the amount was deposited into the account. These records (114,115) also appeared in the uploaded internal file.

reactive({
    req(merged_data(),data_f())
    dt_org <- dplyr::full_join(merged_data(),data_f(), by = input$var_checklist)
    dt_org <- dt_org |>
        select(`Date and Time`,`Transaction Date`,`Transaction Count`,`Merchant Reference Number`,`Summary          Transaction Slip`,Retrieval_Ref,
              `Transaction Gross`,`Transaction Net`,`Gross Amount`,`Net Amount`,Currency,`Reversal Flag`,
               `Transaction Type`)
    counts <- dt_org |>
      filter(`Summary Transaction Slip` != "")|>
      group_by(`Summary Transaction Slip`) |>
      mutate(Check_merchantID = list(`Merchant Reference Number`), count = n())|>
      mutate(Check_Retrieval_Ref = list(Retrieval_Ref), countx = n())|>
      mutate(has_Summary_Transaction_Slip = "Yes")|>
      select(-count, -countx)

    not_in_counts <- dt_org |>
      filter(is.na(`Summary Transaction Slip`))|>
      mutate(Check_merchantID = list(0))|>
      mutate(Check_Retrieval_Ref = list(0))|>
      mutate(has_Summary_Transaction_Slip = "No")
     counts_summary <- apply(rbind(counts,not_in_counts),2,as.character)
     unique(counts_summary)
  })
















Results


After the data merge is done, the files are ready to download to the local drive by pressing the Download buttons. This customized shiny app allows our accounting staff to run and download the report anytime/anywhere.




By developing a custom solution, I was able to streamline the reporting process, merge the data consistently, and keep our operations running smoothly—all while cutting down on expenses.


Full code on Github











library(shiny)
library(dplyr)





Attaching package: 'dplyr'






The following objects are masked from 'package:stats':

    filter, lag






The following objects are masked from 'package:base':

    intersect, setdiff, setequal, union




library(tidyr)
library(readxl)




Warning: package 'readxl' was built under R version 4.4.3




library(readr)
library(DT)





Attaching package: 'DT'






The following objects are masked from 'package:shiny':

    dataTableOutput, renderDataTable




ui <- fluidPage(
  titlePanel("File Merger"),
  sidebarLayout(
    sidebarPanel(
      p("1. Convert Retrieval Reference Number to General"),
      fileInput("file_a", "Transaction file (CSV or XLSX)",
                accept = c(".csv", ".xlsx")),
      p("2a. Convert Retrieval Ref to General"),
      p("2b. Remove all rows above Merchant ID "),
      fileInput("file_b", "Sales (CSV or XLSX)",
                accept = c(".csv", ".xlsx")),
      p("3. Remove all rows above Summary Transaction Slip"),
      p("   Output: Merged File; Auto-Checked File "),
      fileInput("file_c", "Funded Deposit (CSV or XLSX)",
                accept = c(".csv", ".xlsx")),
      p("------------------------------------------"),
      p("4. (Optional) Upload a payportal list. Output: Manual-Checked File"),
      p("Must contain a column called **Merchant Reference Number**!"),
      checkboxInput("checklist", "Manual Check", value = FALSE),
      fileInput("file", "Checklist (CSV or XLSX)", accept = c(".csv", ".xlsx")),
      
      uiOutput("merge_vars_a_b"),
      uiOutput("merge_vars_b_c"),
      uiOutput("merge_vars_checklist"),
      br(),
      #p("------------------------------------------"),
      p("A: Contains Summary Transaction Slip & Retrival Ref (matched & unmatched)"),
      downloadButton("downloadData", "Download Merged File"),
      #p("------------------------------------------"),
      p("B: Contains non-empty Summary Transaction Slip, count matched Retrival Ref & Merchant ref"),
      downloadButton("exportData",   "Download Auto-Checkeds File"),
      #p("------------------------------------------"),
      p("C: Using uploaded checklist to match and count non-empty Summary Transaction Slip, Retrival Ref & Merchant ref"),
      downloadButton("manual_input", "Download Manual-Checked File")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Transaction List", DT::dataTableOutput("table_a")),
        tabPanel("Sales List", DT::dataTableOutput("table_b")),
        tabPanel("Funded Deposit List", DT::dataTableOutput("table_c")),
        tabPanel("Merged File", DT::dataTableOutput("table_d")),
        tabPanel("Auto-Checked File", DT::dataTableOutput("table_e")),
        tabPanel("Checklist", DT::dataTableOutput("table_f")),
        tabPanel("Manual-Checked File", DT::dataTableOutput("table_g"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  read_data <- function(file) {
    if (is.null(file)) {
      return(NULL)
    }
    ext <- tools::file_ext(file$name)
    if (ext == "csv") {
      df <- read_csv(file$datapath)
    } else if (ext == "xlsx") {
      df <- read_excel(file$datapath)
    } else {
      return(NULL)
    }
    return(df)
  }
  
  data_a <- reactive({
    validate(
      need(input$file_a != "", label = "data set")
    )
    
    da <- read_data(input$file_a)%>%
      mutate(Retrieval_Ref = `Retrieval Reference Number`)%>% 
      select(`Date and Time`, Retrieval_Ref,`Merchant Reference Number`,Amount) 
    return(da)
    
  })
  
  # remove all rows above Merchant ID and change 
  data_b <- reactive({
    req(input$file_b)
    db <- read_data(input$file_b)%>% 
      mutate(Retrieval_Ref = `Retrieval Ref.`)%>% 
      select(`Transaction Date`, Retrieval_Ref, `Summary Transaction Slip`,
             `Payment Transaction Slip`, `Transaction Gross`,`Transaction Net`)
    db 
  })
  
  
  # remove all rows above Summary Transaction Slip
  data_c <- reactive({
    req(input$file_c)
    dc <- read_data(input$file_c)
    dc<- dc[!grepl('Payment', dc$`Summary Transaction Slip`)&
              !grepl('Sale', dc$`Summary Transaction Slip`)&
              !grepl('/', dc$`Summary Transaction Slip`)&
              !grepl('Summary', dc$`Summary Transaction Slip`),]
    dc$`Summary Transaction Slip` <-  as.numeric(dc$`Summary Transaction Slip`)
    
    #colnames(dc)[2:7] <-  c("Summary Transaction Slip","Transaction Type","Transaction Count", "Reversal Flag",
    #                   "Currency","Gross Amount", "Net Amount")
    return(dc) 
  })
  
  output$merge_vars_a_b <- renderUI({
    #req(data_a(), data_b())
    validate(
      need(input$file_a != "", label = "data set")
    )
    var_names <- intersect(names(data_a()), names(data_b()))
    selectInput("var_ab", "Select merge variable for Transaction and Sales", choices = var_names)
  })
  
  output$merge_vars_b_c <- renderUI({
    #req(data_b(), data_c())
    validate(
      need(input$file_a != "", label = "data set")
    )
    #get(input$file_a, 'package:datasets')
    var_names <- intersect(names(data_b()), names(data_c()))
    selectInput("var_bc", "Select merge variable for Sales and Funded Depos it", choices = var_names)
  })
  
  
  output$merge_vars_checklist <- renderUI({
    validate(
      need(input$checklist != FALSE, label = "data set")
    )
    #get(input$file_a, 'package:datasets')
    var_names <- intersect(names(merged_data()), names(data_f()))
    selectInput("var_checklist", "Select merge variable for Merge data and Checklist", choices = var_names)
  })
  data_f <- reactive({
    validate(
      need(input$file != "", label = "data set")
    )
    dt <- read_data(input$file)
    return(dt)
  })
  
  output$table_a <- DT::renderDataTable({
    #req(data_a())
    DT::datatable(data = unique(data_a()),
                  options = list(pageLength = 100, rownames = FALSE) 
    )  
  })
  
  output$table_b <- DT::renderDataTable({
    #req(data_b())
    DT::datatable(data = unique(data_b()),
                  options = list(pageLength = 100, rownames = FALSE) 
    )  
  })
  
  output$table_c <- DT::renderDataTable({
    #req(data_c())
    DT::datatable(data = unique(data_c()),
                  options = list(pageLength = 100, rownames = FALSE) 
    )  
  })
  
  merged_data <- reactive({
    req(data_a(), data_b(), data_c(), input$var_ab, input$var_bc)
    temp_ab <- dplyr::full_join(data_a(), data_b(), by = input$var_ab)
    unique(dplyr::full_join(temp_ab, data_c(), by = input$var_bc))
  })
  
  processed_data <- reactive({
    req(merged_data())
    df <-
      merged_data() %>%
      filter(`Summary Transaction Slip` != "")%>%
      group_by(`Summary Transaction Slip`) %>%
      mutate(Check_merchantID = list(`Merchant Reference Number`), count = n())%>%
      mutate(Check_Retrieval_Ref = list(Retrieval_Ref), countx = n())%>%
      select(`Date and Time`,`Transaction Date`,`Transaction Count`,`Merchant Reference Number`,`Summary Transaction Slip`,Retrieval_Ref,
             `Check_merchantID`,Check_Retrieval_Ref,`Transaction Gross`,`Transaction Net`,`Gross Amount`,`Net Amount`,Currency,`Reversal Flag`,
             `Transaction Type`)
    apply(df,2,as.character)
    
  })
  
  manual_check <-reactive({
    req(merged_data(),data_f())
    dt_org <- dplyr::full_join(merged_data(),data_f(), by = input$var_checklist)
    dt_org <- dt_org |>
        select(`Date and Time`,`Transaction Date`,`Transaction Count`,`Merchant Reference Number`,`Summary Transaction Slip`,Retrieval_Ref,
              `Transaction Gross`,`Transaction Net`,`Gross Amount`,`Net Amount`,Currency,`Reversal Flag`,
               `Transaction Type`)

    counts <- dt_org |>
      filter(`Summary Transaction Slip` != "")|>
      group_by(`Summary Transaction Slip`) |>
      mutate(Check_merchantID = list(`Merchant Reference Number`), count = n())|>
      mutate(Check_Retrieval_Ref = list(Retrieval_Ref), countx = n())|>
      mutate(has_Summary_Transaction_Slip = "Yes")|>
      select(-count, -countx)

    not_in_counts <- dt_org |>
      filter(is.na(`Summary Transaction Slip`))|>
      mutate(Check_merchantID = list(0))|>
      mutate(Check_Retrieval_Ref = list(0))|>
      mutate(has_Summary_Transaction_Slip = "No")

     #counts_summary <- rbind(counts,not_in_counts)
     counts_summary <- apply(rbind(counts,not_in_counts),2,as.character)#rbind(apply(counts,2,as.character),apply(not_in_counts,2,as.character))
    
    
     unique(counts_summary)
    
  })
  
  output$table_d <- DT::renderDataTable({
    req(merged_data())
    DT::datatable(data = unique(merged_data()),
                  options = list(pageLength = 100, rownames = FALSE) 
    )  
  })
  
  output$table_e <- DT::renderDataTable({
    req(merged_data())
    DT::datatable(data = unique(processed_data()),
                  options = list(pageLength = 100, rownames = FALSE) 
    )  
  })
  
  # Render the data table only if the checkbox is checked
  output$table_f <- renderDT({
    req(input$checklist)
    #manual_check()
    
    DT::datatable(data = unique(data_f()),
                  options = list(pageLength = 100, rownames = FALSE)
    )
  })
  
  output$table_g <- renderDT({
    req(input$checklist)
    
    DT::datatable(data = unique(manual_check()),
                  options = list(pageLength = 100, rownames = FALSE)
    )
  })
  
  ######### Download ############
  output$downloadData <- downloadHandler(
    filename = function() {
      paste0(Sys.Date(), "merged_data.csv")
    },
    content = function(file) {
      write.csv(unique(merged_data()), file, row.names = FALSE)
    }
  )
  
  
  output$exportData <- downloadHandler(
    filename = function() {
      paste0(Sys.Date(), "auto_checked.csv")
    },
    content = function(file) {
      write.csv(unique(processed_data()), file, row.names = FALSE)
    }
  )
  
  output$manual_input <- downloadHandler(
    filename = function() {
      paste0(Sys.Date(), "manual_checked.csv")
    },
    content = function(file) {
      write.csv(unique( manual_check()), file, row.names = FALSE)
    }
  ) 
  
}
shinyApp(ui, server)




PhantomJS not found. You can install it with webshot::install_phantomjs(). If it is installed, please make sure the phantomjs executable can be found via the PATH variable.






Shiny applications not supported in static R Markdown documents
















 Back to top ]]>
  R
  Shiny
  Data organization
  sql
  vlookup
  https://github.com/clfee/home/posts/2024-08-01-tying-the-data-together/
  Thu, 01 Aug 2024 05:00:00 GMT


  Creating a Serveless Dashboard
  Chris Lee
  https://github.com/clfee/home/posts/2024-06-25-create-a-Quarto-dashboard/
  


A while ago I wrote about creating a serverless dashboard (with no server dependencies) using Flexdashboard. As some of the functions now are no longer supported, I found a good alternative called “Quarto Dashboards”. Quarto Dashboards allow to create dashboards using Python, R, Julia, and Observable. More details are here.


Dashboards can be created either using Jupyter notebooks (.ipynb) or using plain text markdown (.qmd). I am showing how to create one using RStudio.


    

  1. Click File -> New File -> Quarto Document
    2. 





    

  1. A new .qmd file is created
    2. 



Here is the code for the visual version of the dashboard link


Here is the plain text .qmd version of the dashboard.


    

  1. The document options define the title and author for the navigation bar as well as specifying the use of the dashboard format.
    2. 

  2. By default, dashboard pages are laid out first by row, then by column. In this demo, I changed this by specifying the orientation: columns document option:
    3. 



title: "Marketing Campaign at a Glance"
author:
    name: Chris Lee
    url: https://clfee.github.io/
date: 2024-07-15
format: 
  dashboard:
    orientation: columns
    nav-buttons: [github]
    github: https://github.com/clfee
logo: "/assets/images/cmm1.PNG"
theme: custom.scss
editor_options: 
  chunk_output_type: console


    

  1. Each row in the dashboard that is not given an explicit height will determine its size by either filling available space or by flowing to its natural height.Here I changed the figure height by specifying the #| fig-height: 6 
    2. 



#| title: Correlations
#| fig-height: 6
#| padding: 0;
dt <- train


More details about full code.




 Back to top ]]>
  R
  Quarto
  Dashboard
  https://github.com/clfee/home/posts/2024-06-25-create-a-Quarto-dashboard/
  Tue, 25 Jun 2024 05:00:00 GMT


  Image Classification (Part1)
  Chris Lee
  https://github.com/clfee/home/posts/2021-08-31-malaria-cell-classification/
  I remember years ago seeing my colleague spent hours under a microscopes counting cells underwent of apoptosis or Dauer larva formation. I mean it is fun doing experiments in the lab but telling differences of these tiny worms would probably is the last thing I’d want to do. This task does take lots of valuable time from a researcher. Imagine, how many more novel anti-agents like this article Yongsoon could bring us if the deep learning techniques were ready to use back in 2011.








Kim Y, Sun H (2012) PLOS ONE 7(9): e45890






Thanks to the advancement in deep learning field, neural network model architectures can be readily reused and, in most cases, are tested across multiple applications to establish robustness. Here, I’m going to show how easy it is to implement transfer learning using Keras in Python for Malaria cell classification. The basic concept of transfer learning is using the knowledge (architecture or weights) gained from a neural network model that was trained to recognize animals to recognize cats. The dataset used here came from NIH, along with recent publications1,2.




Workflow


    

  • Loading data and data pre-processing
    • 

  • Transfer learning and fine-tuning (DenseNet121)
    • 

  • Result evaluation
    • 









Data Overview


There are many ways to create train/valid/test data sets. Below is one of the methods using R to create csv files containing file paths and classifications from train and test folders.


# R code
library(fs)
dataset_dir <- "Data/cell_images/"
test_dir   <- paste0(dataset_dir, "/test/")
# stored image paths in the image column
test_parasite <- dir_ls(path=paste0(test_dir, "parasite"),glob = "*.png")
test_uninfected <- dir_ls(path=paste0(test_dir, "uninfected"),glob = "*.png")
test_par <- as.data.frame(matrix('parasite', length(test_parasite), 1))
test_unin <- as.data.frame(matrix('uninfected', length(test_parasite), 1))
test_par$image <- test_parasite 
test_unin$image <- test_uninfected

test <- rbind(test_par,test_unin)
colnames(test)[1] <- 'label'
test$normal  <- ifelse(test$label != 'parasite', 1,0)
test$parasite <- ifelse(test$label == 'parasite', 1,0)


And the csv file looks like this. csv


In reality, we don’t usually see many cells infected with parasites, therefore less than 1/3 of the infected samples were used in this exercise.


# Python
# get ids for each label
all_img_ids = list(new_df.uninfected.index.unique())
train_ids, test_ids = train_test_split(all_img_ids, test_size=0.01, random_state=21)
train_ids, valid_ids = train_test_split(train_ids, test_size=0.1, random_state=21)


Making sure, the proportion of the infected cell is as expected after data split. pct


Let’s also check few images. The images come with different sizes. They will need to reshape and normalize before xx.


# Extract numpy values from image column in data frame
train_df = new_df.iloc[train_ids,:]
images = train_df['image'].values
# Extract 9 random images 
random_images = [np.random.choice(images) for i in range(9)]
img_dir = 'C:/Users/your_image_folder'
print('Display Random Images')
# Adjust the size of your images
plt.figure(figsize=(20,10))
for i in range(9):
    plt.subplot(3, 3, i + 1)
    img = plt.imread(os.path.join(img_dir, random_images[i]))
    plt.imshow(img)
    plt.axis('off')








random_images










Loading data


Next is building generators from the Keras framework. The purpose of building generator is that it allows to generate batches of tensor image data with real-time data augmentation(ex: random horizontal flipping of images). We also use the generator to transform the values in each batch so that their mean is 0 and their standard deviation is 1.Here is the information of ImageDataGenerator and a short tutorial. We’ll also need to build a sereperate generator for valid and test sets. Since each image will be normailized using mean and standard deviation derived from its own batch. In a real life scenario, we process one image at a time. And the incoming image is normalized using the statistics computed from the training set.


# Train generator
def get_train_generator(df, image_dir, x_col, y_cols, shuffle=True, batch_size=8, seed=1, target_w = 224, target_h = 224):
    """

    Args:
      train_df (dataframe): dataframe specifying training data.
      image_dir (str): directory where image files are held.
      x_col (str): name of column in df that holds filenames.
      y_cols (list): list of strings that hold y labels for images.
      sample_size (int): size of sample to use for normalization statistics.
      batch_size (int): images per batch to be fed into model during training.
      seed (int): random seed.
      target_w (int): final width of input images.
      target_h (int): final height of input images.
    
    Returns:
        train_generator (DataFrameIterator): iterator over training set
    """        
    print("getting train generator...") 
    # normalize images
    image_generator = ImageDataGenerator(
        samplewise_center=True,
        samplewise_std_normalization= True)
    
    # flow from directory with specified batch size and target image size
    generator = image_generator.flow_from_dataframe(
            dataframe=df,
            directory=image_dir,
            x_col=x_col,
            y_col=y_cols,
            class_mode="raw",
            batch_size=batch_size,
            shuffle=shuffle,
            seed=seed,
            target_size=(target_w,target_h))
    
    return generator  


Before, model building we’ll need to define a loss function to address class imbalance. We can give more weight for the less frequent class and less weight for the other one, see here . We can write the overall average cross-entropy loss over the entire training set D of size N as follows:








loss






Next, we will use a pre-trained DenseNet121 model which we can load directly from Keras and then add two layers on top of it.


    

  • Set include_top=False, to remove the orginal fully connect dense layer (so you can adjust the ouptut prediction clsses or
    
activation function).
    • 

  • Use specific layer using get_layer(). For example: base_model.get_layer(‘conv5_block16_conv’)
    • 



A GlobalAveragePooling2D layer to get the average of the last convolution layers from DenseNet121. The pooling layer typically uses a filter to extract representative features (e.g., maximum, average, etc.) for different locations. The method of extracting features from the pooling filter is called a pooling function. The commonly used pooling functions include the maximum pooling function, average pooling function, L2 normalization, and weighted average pooling function based on the distance from the center pixel. In short, the pooling layer summarizes all the feature information centered on each position of the input feature map, which makes it reasonable that the output data of the pooling layer is less than the input data. This method reduces the input data to the next layer and improves the computational efficiency of the CNN.


The output of the pooling layer is flattening to convert the pooled features maps into a single dimensional array. This is done in order for the data to be fed into densely connected hidden layers.


A Dense layer with sigmoid activation to get the prediction logits for each of our classes. We can set our custom loss function for the model by specifying the loss parameter in the compile() function.


# Build model
def create_dense121_model():
    
    pretrained = 'fine_tuned.hdf5'
    train_df = pd.read_csv("train_df.csv")
    labels = ['uninfected', 'parasite']  
    
    class_pos = train_df.loc[:, labels].sum(axis=0)
    class_neg = len(train_df) - class_pos
    class_total = class_pos + class_neg

    pos_weights =  class_pos / class_total #[0.5,class_pos / class_total]
    neg_weights =  class_neg / class_total #[0.5,class_neg / class_total]
    print("Got loss weights")
    
    def create_model(input_shape=(224, 224,3)):
        base_model = DenseNet121(weights='imagenet', include_top=False, input_shape=input_shape)
       
        # add a global spatial average pooling layer
        x = GlobalAveragePooling2D()(base_model.output)
        x = Flatten()(x)
        x = Dense(1024, activation='relu', name='dense_post_pool')(x)
        x = Dropout(0.8)(x)
        # output has two neurons for the 2 classes (uninfected and parasite)
        predictions = Dense(len(labels), activation='sigmoid')(x)
        model = Model(inputs = base_model.input, outputs = predictions)

        # freeze the earlier layers
        for layer in base_model.layers[:-4]:
            layer.trainable=False
        
        return model
    
    def get_weighted_loss(neg_weights, pos_weights, epsilon=1e-7):
        def weighted_loss(y_true, y_pred):
            y_true = tf.cast(y_true, tf.float32)
            #print(f'neg_weights : {neg_weights}, pos_weights: {pos_weights}')
            #print(f'y_true : {y_true}, y_pred: {y_pred}')
            # L(X, y) = −w * y log p(Y = 1|X) − w *  (1 − y) log p(Y = 0|X)
            # from https://arxiv.org/pdf/1711.05225.pdf
            loss = 0
            
            for i in range(len(neg_weights)):
                loss -= (neg_weights[i] * y_true[:, i] * K.log(y_pred[:, i] + epsilon) + 
                         pos_weights[i] * (1 - y_true[:, i]) * K.log(1 - y_pred[:, i] + epsilon))
            
            loss = K.sum(loss)
            return loss
        return weighted_loss
    
   
    model = create_model()
    model.load_weights(pretrained)
    print("Loaded Model")
    
    model.compile(optimizer='adam', loss= get_weighted_loss(neg_weights, pos_weights)) 
    print("Compiled Model")   
          
    return model


Model is fine tuned using ModelCheckpoint and only the model’s weights will be saved.


# CallBack 
# -------------------------------------------------------------------------------------------------
# Callback Function 1
fname = 'dense121(V)_Epoch[{epoch:02d}].ValLoss[{val_loss:.3f}].hdf5'
fullpath = fname
# https://keras.io/api/callbacks/model_checkpoint/
callback_func1 = ModelCheckpoint(filepath=fullpath,             
                                monitor='val_loss',             
                                verbose=1,                      
                                save_best_only=True,            
                                save_weights_only=True, # save weights       
                                mode='min',                     
                                period=1)                       

# Callback Function 2
# https://keras.io/callbacks/#tensorboard
callback_func2 = keras.callbacks.TensorBoard(log_dir='./logs/log2', histogram_freq=1)

# Callback Function
callbacks = []
callbacks.append(callback_func1)
callbacks.append(callback_func2)

# Training and Plotting
# -------------------------------------------------------------------------------------------------
history = model.fit(train_generator, 
                              validation_data=valid_generator,
                              steps_per_epoch=100, 
                              validation_steps=25, 
                              epochs = 15,
                              callbacks=callbacks)

plt.plot(history.history['loss'])
plt.plot(history.history['val_loss'])
plt.ylabel("loss")
plt.xlabel("epoch")
plt.title("Training Loss Curve")
plt.show()


Train versus validation loss for all epochs is shown here. The orange and blue lines indicate train loss and validation loss respectively. We can see the model may be under-fitted. One way to overcome this is simply increase the number of epochs. Also with the callback function, we can re-use the best weights saved at 12th epoch.








history










Evaluation


The ROC curve is created by plotting the true positive rate against the false positive rate. We can see the model performs reasonable well.








ROC






We can try different approaches to improve the model perfromance, such as train the model for a longer time or use all the training data (since only 1/3 of the parasite data was used). We can also try a different base model, the previous publication, shows 99.32% accuracy with VGG-19 alone.






Visualize class activation maps


Next, I will show how to produce visual explanation using Grad-CAM. The purpose of doing this is as following:


    

  • Debug your model and visually validate that it is “looking” and “activating” at the correct locations in an image.
    • 

  • Grad-CAM works by (1) finding the final convolutional layer in the network and then (2) examining the gradient information flowing into that layer.
    • 







Notes


Note 1: AUC is the area below these ROC curves. Therefore, in other words, AUC is a great indicator of how well a classifier functions. Note 2: A good tutorial for to learn neural network image classification from scratch and Andrew Ng’s deep learning course.


Note 3:


# packages used 
import os
import sklearn
import pandas as pd
import numpy as np
import seaborn as sns
import matplotlib.pyplot as plt

import keras
from keras.applications.densenet import DenseNet121
from keras.models import Model
from keras.layers import Dense, Activation, Flatten, Dropout, BatchNormalization, GlobalAveragePooling2D
from keras.callbacks import ModelCheckpoint, CSVLogger, LearningRateScheduler, ReduceLROnPlateau, EarlyStopping, TensorBoard
from keras import backend as K
from keras.preprocessing import image
from keras.preprocessing.image import ImageDataGenerator






 Back to top ]]>
  python
  Image Classification
  https://github.com/clfee/home/posts/2021-08-31-malaria-cell-classification/
  Tue, 31 Aug 2021 05:00:00 GMT


  Image Classification (Part2)
  Chris Lee
  https://github.com/clfee/home/posts/2021-08-31-malaria-cell-classification - p2/
  When building a predictive model, there are two important criteria: predictive accuracy and interpretability, which generally have a trade-off relationship. In the previous post, we have shown that the DenseNet121 model can achieve high accuracy in detecting cells infected with parasites.


Here, I am going to introduce a powerful technique GRAD-CAM (gradient-weighted class activation mapping) to visualize which parts of an image are most important to the predictions of an image regression network. GRAD-CAM is a generalization of the CAM technique which determines the importance of each neuron in a network prediction by considering the gradients of the target flowing through the deep network. Unlike CAM which requires a particular kind of CNN architecture to perform global average pooling prior to prediction and forces us to change the base model retrain the network. In contrast, GRAD-CAM is accessing intermediate activations in the deep learning model and computing gradients with respect to the class output. For more details, please see.


Workflow: - Obtain predicted class/index - Determine which intermediate layer(s) to use. Lower-level convolution layers capture low level features such as edges, and lines. Higher-level layers usually have more abstract information. - Calculate the gradients with respect to the outout of the class/index - Generate a heatmap by weighing the convolution outputs with the computed gradients - Super-impose the heatmap to the original image


Load base model


We first load the base model and will only train the last 4 layers.


def build_model(input_shape=(224, 224,3),pos_weights,neg_weights):
  # load the base DenseNet121 model
  base_model = DenseNet121(input_shape = input_shape, 
                      weights='imagenet', 
                      include_top=False)
  
  # add a GAP layer
  output = layers.GlobalAveragePooling2D()(base_model.output)

  # output has two neurons for the 2 classes (uninfected and parasite)
  output = layers.Dense(2, activation='softmax')(output)

  # set the inputs and outputs of the model
  model = Model(base_model.input, output)

  # freeze the earlier layers
  for layer in base_model.layers[:-4]:
      layer.trainable=False

  # configure the model for training
  model.compile(loss= get_weighted_loss(neg_weights, pos_weights), 
                optimizer=adam, 
                metrics=['accuracy'])
  
  return model
 


We then create a new model that has the original model’s inputs, but two different outputs. The first output contains the activation layers outputs that in this case is the final convolutional layer in the original model. And the second output is the model’s prediction for the image.


def get_CAM(model, processed_image, actual_label, layer_name): 
    """
    GradCAM method for visualizing input saliency.
    
    Args:
        model (Keras.model): model to compute cam for
        image (tensor): input to model, shape (1, H, W, 3)
        cls (int): class to compute cam with respect to
        layer_name (str): relevant layer in model
        H (int): input height
        W (int): input width
    Return:
        heatmap()
    """    

    model_grad = Model([model.inputs], 
                       [model.get_layer(layer_name).output, model.output])
    
    with tf.GradientTape() as tape:
        conv_output_values, predictions = model_grad(processed_image)

        # assign gradient tape to monitor the conv_output
        tape.watch(conv_output_values)
        
        # use binary cross entropy loss, actual_label = 0 if uninfected
        # get prediction probability of infected  
        pred_prob = predictions[:,1] 
        
        # make sure actual_label is a float, like the rest of the loss calculation
        actual_label = tf.cast(actual_label, dtype=tf.float32)
        
        # add a tiny value to avoid log of 0
        smoothing = 0.00001 
        
        # Calculate loss as binary cross entropy
        loss = -1 * (actual_label * tf.math.log(pred_prob + smoothing) + (1 - actual_label) * tf.math.log(1 - pred_prob + smoothing))
        print(f"binary loss: {loss}")
    
    # get the gradient of the loss with respect to the outputs of the last conv layer
    grads_values = tape.gradient(loss, conv_output_values)
    grads_values = K.mean(grads_values, axis=(0,1,2))
    
    conv_output_values = np.squeeze(conv_output_values.numpy())
    grads_values = grads_values.numpy()
    
    # weight the convolution outputs with the computed gradients
    for i in range(grads_values.shape[-1]): 
        conv_output_values[:,:,i] *= grads_values[i]
    heatmap = np.mean(conv_output_values, axis=-1)
    
    heatmap = np.maximum(heatmap, 0)
    heatmap /= heatmap.max()
    
    del model_grad, conv_output_values, grads_values, loss
   
    return heatmap








Result






Note: Instead of using max pooling that only keeps the highest valued ones. Average pooling allows some of the lesser intensity pixels to pass on in the pooling layer. It is important as we look at the small size of the image once it reaches this layer, max pooling could leave us with very little information.




 Back to top ]]>
  python
  Image Classification
  https://github.com/clfee/home/posts/2021-08-31-malaria-cell-classification - p2/
  Tue, 31 Aug 2021 05:00:00 GMT