library(tidyverse)
library(kableExtra)

set.seed(123) #Specify seed value to keep results reproducible
ratings <-
  read_csv("ratings.csv") %>% #Import raw data from CSV file
  gather(item, rating, -user) %>% # Convert layout from wide to tall
  filter(!is.na(rating)) %>% #Remove missing values
  sample_frac(1, replace = FALSE) %>% #Randomize row order
  mutate(data_cat = if_else(row_number() < n() * 0.8, "Training", "Test", missing = NULL)) #Label 60% of the data for training.

training_avg <- ratings %>% 
  filter(data_cat == 'Training') %>% 
  summarise(tmean = mean(rating, na.rm = TRUE)) %>% 
  pull %>% 
  print()

[1] 3.113208

## Using your training data, calculate the raw average (mean) rating for every user-item combination.

user_avgs <- ratings %>% 
  filter(data_cat == 'Training') %>% # Select the training data
  group_by(user) %>% #Group by user so R knows what elements to enter into the mean calculation
  summarise(user_avg = mean(rating, na.rm = TRUE)) %>% #calculate the mean by user, ignoring missing values
  mutate(user_bias = user_avg - training_avg) #calculate the bias

user_avgs %>% 
  kable(digits = 2) %>%
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = F)

item_avgs <- ratings %>% 
  filter(data_cat == 'Training') %>% 
  group_by(item) %>% 
  summarise(item_avg = mean(rating, na.rm = TRUE)) %>% 
  mutate(item_bias = item_avg - training_avg)

item_avgs %>% 
  kable(digits = 2) %>%
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = F)

## From the raw average, and the appropriate user and item biases, calculate the baseline predictors for every user-item combination.
bl_pred_df <- crossing(item_avgs, user_avgs) %>% # Ggenerate a dataframe with all user/item combinations
  mutate(bl_predictor = item_bias + user_bias + training_avg) %>% # Create baseline predictor column
  mutate(bl_predictor = pmax(pmin(bl_predictor, 5), 1)) %>% # Clip values to between 1 and 5.
  select(item, user, bl_predictor) # Remove unnecesary columns

bl_pred_df %>% 
  spread(item, bl_predictor) %>% #rearange dataframe into a standar user/item matrix
  kable(digits = 2) %>% # limit decimals places
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = F) #formatting

rmse_calcs <- ratings %>% 
  left_join(bl_pred_df, by = c('user','item')) %>% # Add bias values to our initial data
  mutate(sq_err_bl_pred = (rating - bl_predictor)**2) %>% # Calculate the squared error for our baseline predictor
  mutate(sq_err_avg_pred = (rating - training_avg)**2) # Calculate the squared error for our average predictor

rmse_calcs %>% 
  kable(col.names = c("User","Item","Rating","Category","Baseline","Baseline sq. error","Avg. sq. error")) %>% # Rename columns
  kable_styling(bootstrap_options = c("striped", "hover"),fixed_thead = T, full_width = F) # Formatting

## Calculate the RMSE for raw average for both your training data and your test data.
rmse_df <- rmse_calcs %>% 
  gather(error_type,error_val, sq_err_bl_pred:sq_err_avg_pred) %>% # Convert from wide to tall
  group_by(error_type, data_cat) %>% # Group by error type so R calculates the means correctly
  summarise(rmse = sqrt(mean(error_val, na.rm = TRUE))) %>% # Calculate the square root of the mean.
  type.convert() # Convert users and items to factors (for barplot below)

rmse_df %>% 
  kable(digits = 4) %>% # Limit to 4 decimal places
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = F) #formatting

1-(rmse_df$rmse[3] / rmse_df$rmse[1]) #RMSE improvement Test set

[1] 0.1787335

1-(rmse_df$rmse[4] / rmse_df$rmse[2]) #RMSE improvement training set

[1] 0.2471183

ggplot(rmse_df, aes(x = error_type, y = rmse, fill = error_type)) +
  geom_bar(stat = "identity") +
  facet_grid( ~ data_cat) +
  scale_fill_brewer(palette = "Paired") +
  labs(title = "RMSE by data group and predictor type",
       subtitle = "",
       caption = "The RMSE for both data groups is based on the avg. and bias values of the training data.") +
  ylab("RMSE") +
  theme_minimal() +
  theme(legend.position = "none", axis.title.x = element_blank()) +
  geom_text(aes(label = round(rmse, 2)),
            vjust = 1.6,
            color = "white",
            size = 5) +
  scale_x_discrete(labels = c("Avg. Rating \n (Training Data)", "Baseline Predictor"))

LS0tDQp0aXRsZTogIlByb2plY3QgMTogR2xvYmFsIEJhc2VsaW5lIFByZWRpY3RvcnMgYW5kIFJNU0UiDQpzdWJ0aXRsZTogIkRBVEEtNjEyLCBTdW1tZXIgMjAxOSINCmF1dGhvcjogIkZlcm5hbmRvIEZpZ3VlcmVzIFplbGVkw7NuIg0Kb3V0cHV0OiBodG1sX25vdGVib29rDQotLS0NCg0KIyBJbnRyb2R1Y3Rpb24NCg0KVGhlIGZvbGxvd2luZyBzeXN0ZW0gcmVjb21tZW5kcyBoeXBvdGhldGljYWwgbHVuY2ggbWVudSBpdGVtcyBmb3IgYSBncm91cCBvZiBzdHVkZW50cy4NCg0KIyBEYXRhIGFjcXVpc2l0aW9uICYgY2xlYW5pbmcNCg0KYGBge3IgTGlicmFyeSwgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0NCmxpYnJhcnkodGlkeXZlcnNlKQ0KbGlicmFyeShrYWJsZUV4dHJhKQ0KYGBgDQoNCmBgYHtyIGRhdGFfaW1wb3J0LCBtZXNzYWdlPUZBTFNFfQ0Kc2V0LnNlZWQoMTIzKSAjU3BlY2lmeSBzZWVkIHZhbHVlIHRvIGtlZXAgcmVzdWx0cyByZXByb2R1Y2libGUNCnJhdGluZ3MgPC0NCiAgcmVhZF9jc3YoInJhdGluZ3MuY3N2IikgJT4lICNJbXBvcnQgcmF3IGRhdGEgZnJvbSBDU1YgZmlsZQ0KICBnYXRoZXIoaXRlbSwgcmF0aW5nLCAtdXNlcikgJT4lICMgQ29udmVydCBsYXlvdXQgZnJvbSB3aWRlIHRvIHRhbGwNCiAgZmlsdGVyKCFpcy5uYShyYXRpbmcpKSAlPiUgI1JlbW92ZSByb3dzIHdpdGggbWlzc2luZyByYXRpbmcgdmFsdWUNCiAgc2FtcGxlX2ZyYWMoMSwgcmVwbGFjZSA9IEZBTFNFKSAlPiUgI1JhbmRvbWl6ZSByb3cgb3JkZXINCiAgbXV0YXRlKGRhdGFfY2F0ID0gaWZfZWxzZShyb3dfbnVtYmVyKCkgPCBuKCkgKiAwLjgsICJUcmFpbmluZyIsICJUZXN0IiwgbWlzc2luZyA9IE5VTEwpKSAjTGFiZWwgODAlIG9mIHRoZSBkYXRhIGZvciB0cmFpbmluZy4NCmBgYA0KDQojIyBDYWxjdWxhdGlvbiBvZiBtZWFucyBhbmQgYmlhc2VzDQoNCkZpcnN0LCB3ZSB1c2UgdGhlIHJhdGluZ3MgZnJvbSB0aGUgdHJhaW5pbmcgZGF0YSB0byBjYWxjdWxhdGUgdGhlIGdsb2JhbCBhdmVyYWdlIGZvciBhbGwgdXNlci9pdGVtIGNvbWJpbmF0aW9ucy4gSW4gdGhpcyBjYXNlLCBpdCdzIDMuMTEuDQoNCmBgYHtyIHRyYWluaW5nX2F2Z19jYWxjfQ0KdHJhaW5pbmdfYXZnIDwtIHJhdGluZ3MgJT4lIA0KICBmaWx0ZXIoZGF0YV9jYXQgPT0gJ1RyYWluaW5nJykgJT4lICMgU2VsZWN0IG9ubHkgdHJhaW5pbmcgZGF0YQ0KICBzdW1tYXJpc2UodG1lYW4gPSBtZWFuKHJhdGluZywgbmEucm0gPSBUUlVFKSkgJT4lICMgQ2FsY3VsYXRlIHRoZSBtZWFuDQogIHB1bGwgJT4lICMgRXh0cmFjdCBzaW5nbGUgdmFsdWUgZnJvbSBkYXRhIGZyYW1lDQogIHByaW50KCkNCmBgYA0KDQpXaXRoIHRoZSBtZWFuLCB3ZSBjYW4gYmVnaW4gdG8gY2FsY3VsYXRlIHRoZSB1c2VyIGFuZCBpdGVtIGJpYXNlcyBieSBzdWJ0cmFjdGluZyB0aGUgZ2xvYmFsIGF2ZXJhZ2UgZnJvbSBlYWNoIHVzZXIgYW5kIGl0ZW0gYXZlcmFnZS4NCg0KV2UgYmVnaW4gYnkgY2FsY3VsYXRpbmcgdGhlIGF2ZXJhZ2UgcmF0aW5nIGZvciBlYWNoIHVzZXIuIFdlIHRoZW4gc3VidHJhY3QgdGhlIGdsb2JhbCBhdmVyYWdlIGZyb20gZWFjaCB2YWx1ZSB0byBvYnRhaW4gdGhlIGJpYXMuIFRoaXMgdmFsdWUgZ2l2ZXMgdXMgYW4gaW5kaWNhdGlvbiBvZiBob3cgaGFyc2ggb3IgZ2VuZXJvdXMgZWFjaCB1c2VyIGlzIHdoZW4gcmF0aW5nIHRoZSBtZW51IGl0ZW1zIHJlbGF0aXZlIHRvIG90aGVyIHVzZXJzLg0KDQpgYGB7ciB1c2VyX2F2Z3N9DQp1c2VyX2F2Z3MgPC0gcmF0aW5ncyAlPiUgDQogIGZpbHRlcihkYXRhX2NhdCA9PSAnVHJhaW5pbmcnKSAlPiUgIyBTZWxlY3QgdGhlIHRyYWluaW5nIGRhdGENCiAgZ3JvdXBfYnkodXNlcikgJT4lICNHcm91cCBieSB1c2VyIHNvIFIga25vd3Mgd2hhdCBlbGVtZW50cyB0byBlbnRlciBpbnRvIHRoZSBtZWFuIGNhbGN1bGF0aW9uDQogIHN1bW1hcmlzZSh1c2VyX2F2ZyA9IG1lYW4ocmF0aW5nLCBuYS5ybSA9IFRSVUUpKSAlPiUgI2NhbGN1bGF0ZSB0aGUgbWVhbiBieSB1c2VyLCBpZ25vcmluZyBtaXNzaW5nIHZhbHVlcw0KICBtdXRhdGUodXNlcl9iaWFzID0gdXNlcl9hdmcgLSB0cmFpbmluZ19hdmcpICNjYWxjdWxhdGUgdGhlIGJpYXMNCg0KdXNlcl9hdmdzICU+JSANCiAga2FibGUoZGlnaXRzID0gMikgJT4lDQogIGthYmxlX3N0eWxpbmcoYm9vdHN0cmFwX29wdGlvbnMgPSBjKCJzdHJpcGVkIiwgImhvdmVyIiksIGZ1bGxfd2lkdGggPSBGKQ0KYGBgDQoNCldlIGNvbXBsZXRlIGEgc2ltaWxhciBvcGVyYXRpb24gYnV0IHRoaXMgdGltZSB3ZSBjYWxjdWxhdGUgdGhlIGF2ZXJhZ2UgcmF0aW5nIGFuZCBiaWFzIGJ5IG1lbnUgaXRlbS4gVGhpcyBnaXZlcyB1cyBhbiBpbmRpY2F0aW9uIG9mIHdoaWNoIGl0ZW1zIGFyZSBtb3JlIHBvcHVsYXIgcmVsYXRpdmUgdG8gdGhlIHJlc3QuDQoNCmBgYHtyIGl0ZW1fYXZnc30NCml0ZW1fYXZncyA8LSByYXRpbmdzICU+JSANCiAgZmlsdGVyKGRhdGFfY2F0ID09ICdUcmFpbmluZycpICU+JSANCiAgZ3JvdXBfYnkoaXRlbSkgJT4lIA0KICBzdW1tYXJpc2UoaXRlbV9hdmcgPSBtZWFuKHJhdGluZywgbmEucm0gPSBUUlVFKSkgJT4lIA0KICBtdXRhdGUoaXRlbV9iaWFzID0gaXRlbV9hdmcgLSB0cmFpbmluZ19hdmcpDQoNCml0ZW1fYXZncyAlPiUgDQogIGthYmxlKGRpZ2l0cyA9IDIpICU+JQ0KICBrYWJsZV9zdHlsaW5nKGJvb3RzdHJhcF9vcHRpb25zID0gYygic3RyaXBlZCIsICJob3ZlciIpLCBmdWxsX3dpZHRoID0gRikNCmBgYA0KDQojIFVzZXIvaXRlbSBtYXRyaXgNCg0KV2UndmUgbWFuYWdlZCB0byBjYWxjdWxhdGUgYW4gYXZlcmFnZSByYXRpbmcgZm9yIGFsbCB1c2VyL2l0ZW0gY29tYmluYXRpb25zIGFuZCBiaWFzIHZhbHVlcyBmb3IgZWFjaCB1c2VyIGFuZCBpdGVtLiBXaXRoIHRoZXNlIHZhbHVlIHdlIGNhbiBjYWxjdWxhdGUgdGhlIGJhc2VsaW5lIHByZWRpY3RvciBmb3IgYWxsIGNvbWJpbmF0aW9ucywgZXZlbiB0aG9zZSB0aGF0IGRpZG4ndCBoYXZlIGEgcmF0aW5nLg0KDQpgYGB7ciBiYXNlbGluZV9wcmVkaWN0b3JzfQ0KIyMgRnJvbSB0aGUgcmF3IGF2ZXJhZ2UsIGFuZCB0aGUgYXBwcm9wcmlhdGUgdXNlciBhbmQgaXRlbSBiaWFzZXMsIGNhbGN1bGF0ZSB0aGUgYmFzZWxpbmUgcHJlZGljdG9ycyBmb3IgZXZlcnkgdXNlci1pdGVtIGNvbWJpbmF0aW9uLg0KYmxfcHJlZF9kZiA8LSBjcm9zc2luZyhpdGVtX2F2Z3MsIHVzZXJfYXZncykgJT4lICMgR2dlbmVyYXRlIGEgZGF0YWZyYW1lIHdpdGggYWxsIHVzZXIvaXRlbSBjb21iaW5hdGlvbnMNCiAgbXV0YXRlKGJsX3ByZWRpY3RvciA9IGl0ZW1fYmlhcyArIHVzZXJfYmlhcyArIHRyYWluaW5nX2F2ZykgJT4lICMgQ3JlYXRlIGJhc2VsaW5lIHByZWRpY3RvciBjb2x1bW4NCiAgbXV0YXRlKGJsX3ByZWRpY3RvciA9IHBtYXgocG1pbihibF9wcmVkaWN0b3IsIDUpLCAxKSkgJT4lICMgQ2xpcCB2YWx1ZXMgdG8gYmV0d2VlbiAxIGFuZCA1Lg0KICBzZWxlY3QoaXRlbSwgdXNlciwgYmxfcHJlZGljdG9yKSAjIFJlbW92ZSB1bm5lY2VzYXJ5IGNvbHVtbnMNCg0KYmxfcHJlZF9kZiAlPiUgDQogIHNwcmVhZChpdGVtLCBibF9wcmVkaWN0b3IpICU+JSAjcmVhcmFuZ2UgZGF0YWZyYW1lIGludG8gYSBzdGFuZGFyIHVzZXIvaXRlbSBtYXRyaXgNCiAga2FibGUoZGlnaXRzID0gMikgJT4lICMgbGltaXQgZGVjaW1hbHMgcGxhY2VzDQogIGthYmxlX3N0eWxpbmcoYm9vdHN0cmFwX29wdGlvbnMgPSBjKCJzdHJpcGVkIiwgImhvdmVyIiksIGZ1bGxfd2lkdGggPSBGKSAjZm9ybWF0dGluZw0KYGBgDQoNCiMgUk1TRSBDYWxjdWxhdGlvbg0KDQpOb3cgdGhhdCB3ZSBoYXZlIGJvdGggYXZlcmFnZSBhbmQgYmFzZWxpbmUgcHJlZGljdGlvbnMsIHdlIGNhbiBjYWxjdWxhdGUgUk1TRSB2YWx1ZXMgdG8gY29tcGFyZSB0aGUgYWNjdXJhY3kgb2YgdGhlIHByZWRpY3Rpb25zIG9uIGJvdGggb3VyIHRyYWluaW5nIGFuZCB0ZXN0IHNldHMuDQoNCmBgYHtyIHJtc2VfY2Fsc30NCnJtc2VfY2FsY3MgPC0gcmF0aW5ncyAlPiUgDQogIGxlZnRfam9pbihibF9wcmVkX2RmLCBieSA9IGMoJ3VzZXInLCdpdGVtJykpICU+JSAjIEFkZCBiaWFzIHZhbHVlcyB0byBvdXIgaW5pdGlhbCBkYXRhDQogIG11dGF0ZShzcV9lcnJfYmxfcHJlZCA9IChyYXRpbmcgLSBibF9wcmVkaWN0b3IpKioyKSAlPiUgIyBDYWxjdWxhdGUgdGhlIHNxdWFyZWQgZXJyb3IgZm9yIG91ciBiYXNlbGluZSBwcmVkaWN0b3INCiAgbXV0YXRlKHNxX2Vycl9hdmdfcHJlZCA9IChyYXRpbmcgLSB0cmFpbmluZ19hdmcpKioyKSAjIENhbGN1bGF0ZSB0aGUgc3F1YXJlZCBlcnJvciBmb3Igb3VyIGF2ZXJhZ2UgcHJlZGljdG9yDQoNCnJtc2VfY2FsY3MgJT4lIA0KICBrYWJsZShjb2wubmFtZXMgPSBjKCJVc2VyIiwiSXRlbSIsIlJhdGluZyIsIkNhdGVnb3J5IiwiQmFzZWxpbmUiLCJCYXNlbGluZSBzcS4gZXJyb3IiLCJBdmcuIHNxLiBlcnJvciIpKSAlPiUgIyBSZW5hbWUgY29sdW1ucw0KICBrYWJsZV9zdHlsaW5nKGJvb3RzdHJhcF9vcHRpb25zID0gYygic3RyaXBlZCIsICJob3ZlciIpLGZpeGVkX3RoZWFkID0gVCwgZnVsbF93aWR0aCA9IEYpICMgRm9ybWF0dGluZw0KYGBgDQoNCmBgYHtyfQ0Kcm1zZV9kZiA8LSBybXNlX2NhbGNzICU+JSANCiAgZ2F0aGVyKGVycm9yX3R5cGUsZXJyb3JfdmFsLCBzcV9lcnJfYmxfcHJlZDpzcV9lcnJfYXZnX3ByZWQpICU+JSAjIENvbnZlcnQgZnJvbSB3aWRlIHRvIHRhbGwNCiAgZ3JvdXBfYnkoZXJyb3JfdHlwZSwgZGF0YV9jYXQpICU+JSAjIEdyb3VwIGJ5IGVycm9yIHR5cGUgc28gUiBjYWxjdWxhdGVzIHRoZSBtZWFucyBjb3JyZWN0bHkNCiAgc3VtbWFyaXNlKHJtc2UgPSBzcXJ0KG1lYW4oZXJyb3JfdmFsLCBuYS5ybSA9IFRSVUUpKSkgJT4lICMgQ2FsY3VsYXRlIHRoZSBzcXVhcmUgcm9vdCBvZiB0aGUgbWVhbi4NCiAgdHlwZS5jb252ZXJ0KCkgIyBDb252ZXJ0IHVzZXJzIGFuZCBpdGVtcyB0byBmYWN0b3JzIChmb3IgYmFycGxvdCBiZWxvdykNCg0Kcm1zZV9kZiAlPiUgDQogIGthYmxlKGRpZ2l0cyA9IDQpICU+JSAjIExpbWl0IHRvIDQgZGVjaW1hbCBwbGFjZXMNCiAga2FibGVfc3R5bGluZyhib290c3RyYXBfb3B0aW9ucyA9IGMoInN0cmlwZWQiLCAiaG92ZXIiKSwgZnVsbF93aWR0aCA9IEYpICNmb3JtYXR0aW5nDQpgYGANCg0KYGBge3J9DQoxLShybXNlX2RmJHJtc2VbM10gLyBybXNlX2RmJHJtc2VbMV0pICNSTVNFICUgaW1wcm92ZW1lbnQgVGVzdCBzZXQNCg0KMS0ocm1zZV9kZiRybXNlWzRdIC8gcm1zZV9kZiRybXNlWzJdKSAjUk1TRSAlIGltcHJvdmVtZW50IHRyYWluaW5nIHNldA0KYGBgDQoNCg0KYGBge3J9DQpnZ3Bsb3Qocm1zZV9kZiwgYWVzKHggPSBlcnJvcl90eXBlLCB5ID0gcm1zZSwgZmlsbCA9IGVycm9yX3R5cGUpKSArDQogIGdlb21fYmFyKHN0YXQgPSAiaWRlbnRpdHkiKSArDQogIGZhY2V0X2dyaWQoIH4gZGF0YV9jYXQpICsNCiAgc2NhbGVfZmlsbF9icmV3ZXIocGFsZXR0ZSA9ICJQYWlyZWQiKSArDQogIGxhYnModGl0bGUgPSAiUk1TRSBieSBkYXRhIGdyb3VwIGFuZCBwcmVkaWN0b3IgdHlwZSIsDQogICAgICAgc3VidGl0bGUgPSAiIiwNCiAgICAgICBjYXB0aW9uID0gIlRoZSBSTVNFIGZvciBib3RoIGRhdGEgZ3JvdXBzIGlzIGJhc2VkIG9uIHRoZSBhdmcuIGFuZCBiaWFzIHZhbHVlcyBvZiB0aGUgdHJhaW5pbmcgZGF0YS4iKSArDQogIHlsYWIoIlJNU0UiKSArDQogIHRoZW1lX21pbmltYWwoKSArDQogIHRoZW1lKGxlZ2VuZC5wb3NpdGlvbiA9ICJub25lIiwgYXhpcy50aXRsZS54ID0gZWxlbWVudF9ibGFuaygpKSArDQogIGdlb21fdGV4dChhZXMobGFiZWwgPSByb3VuZChybXNlLCAyKSksDQogICAgICAgICAgICB2anVzdCA9IDEuNiwNCiAgICAgICAgICAgIGNvbG9yID0gIndoaXRlIiwNCiAgICAgICAgICAgIHNpemUgPSA1KSArDQogIHNjYWxlX3hfZGlzY3JldGUobGFiZWxzID0gYygiQXZnLiBSYXRpbmcgXG4gKFRyYWluaW5nIERhdGEpIiwgIkJhc2VsaW5lIFByZWRpY3RvciIpKQ0KYGBgDQoNCg0KQXMgd2UgY2FuIHNlZSBmcm9tIHRoZSBjYWx1Y3VsYXRpb25zIGFib3ZlLCB1c2luZyB0aGUgYmFzZWxpbmUgcHJlZGljdG9yIHZzIHRoZSByYXcgYXZlcmFnZSByZXN1bHRzIGluIGEgMTcuOSUgaW1wcm92ZW1lbnQgaW4gdGhlIFJNU0UgZm9yIHRoZSB0ZXN0IGRhdGEgc2V0LiBGb3IgdGhlIHRyYWluaW5nIGRhdGEgc2V0LCB3ZSBvYnNlcnZlIGEgMjQuNyUgaW1wcm92ZW1lbnQu