# San Francisco Crime Classification competition

This article is originally published at

In this blog post, I’ll explain my approach for the San Francisco Crime Classification competition, in which I participated for the past two months. This competition was hosted by kaggle, a free online platform for predictive modelling and analytics. I ended up in the first 60 places out of 2335 participants and so far is my best personal result. This competition belongs to the knowledge competitions, meaning that the submissions of the participants are evaluated on the whole test data, so there wasn’t any danger of overfitting the leaderboard, as after every submission the true (end) leaderboard score was calculated (no secrets). Furthermore, there weren’t any ranking points, so no particular gain except for learning new methods on how to tackle machine learning problems.

### the data set

The competition started one year ago, so there were some hints in the forum on how to exclude outliers or on how to approach this particular problem.

The dataset contained incidents derived from SFPD Crime Incident Reporting system and was collected from 1/1/2003 to 5/13/2015. The training set and test set rotated every week, meaning that week 1,3,5,7… belonged to test set whereas week 2,4,6,8 belonged to the training set. The following table shows the *Category*, which was the target of the competition,

```
train <- read.csv("train.csv", stringsAsFactors = F)
sort(table(train$Category), decreasing = T)
LARCENY/THEFT OTHER OFFENSES NON-CRIMINAL ASSAULT
174900 126182 92304 76876
DRUG/NARCOTIC VEHICLE THEFT VANDALISM WARRANTS
53971 53781 44725 42214
BURGLARY SUSPICIOUS OCC MISSING PERSON ROBBERY
36755 31414 25989 23000
FRAUD FORGERY/COUNTERFEITING SECONDARY CODES WEAPON LAWS
16679 10609 9985 8555
PROSTITUTION TRESPASS STOLEN PROPERTY SEX OFFENSES FORCIBLE
7484 7326 4540 4388
DISORDERLY CONDUCT DRUNKENNESS RECOVERED VEHICLE KIDNAPPING
4320 4280 3138 2341
DRIVING UNDER THE INFLUENCE RUNAWAY LIQUOR LAWS ARSON
2268 1946 1903 1513
LOITERING EMBEZZLEMENT SUICIDE FAMILY OFFENSES
1225 1166 508 491
BAD CHECKS BRIBERY EXTORTION SEX OFFENSES NON FORCIBLE
406 289 256 148
GAMBLING PORNOGRAPHY/OBSCENE MAT TREA
146 22 6
```

The data can be downloaded directly from kaggle.

```
head(train)
Dates Category Descript DayOfWeek PdDistrict Resolution
1 2015-05-13 23:53:00 WARRANTS WARRANT ARREST Wednesday NORTHERN ARREST, BOOKED
2 2015-05-13 23:53:00 OTHER OFFENSES TRAFFIC VIOLATION ARREST Wednesday NORTHERN ARREST, BOOKED
3 2015-05-13 23:33:00 OTHER OFFENSES TRAFFIC VIOLATION ARREST Wednesday NORTHERN ARREST, BOOKED
4 2015-05-13 23:30:00 LARCENY/THEFT GRAND THEFT FROM LOCKED AUTO Wednesday NORTHERN NONE
5 2015-05-13 23:30:00 LARCENY/THEFT GRAND THEFT FROM LOCKED AUTO Wednesday PARK NONE
6 2015-05-13 23:30:00 LARCENY/THEFT GRAND THEFT FROM UNLOCKED AUTO Wednesday INGLESIDE NONE
Address X Y
OAK ST / LAGUNA ST -122.4259 37.77460
OAK ST / LAGUNA ST -122.4259 37.77460
VANNESS AV / GREENWICH ST -122.4244 37.80041
1500 Block of LOMBARD ST -122.4270 37.80087
100 Block of BRODERICK ST -122.4387 37.77154
0 Block of TEDDY AV -122.4033 37.71343
test <- read.csv("test.csv", stringsAsFactors = F)
head(test)
Id Dates DayOfWeek PdDistrict Address X Y
1 0 2015-05-10 23:59:00 Sunday BAYVIEW 2000 Block of THOMAS AV -122.3996 37.73505
2 1 2015-05-10 23:51:00 Sunday BAYVIEW 3RD ST / REVERE AV -122.3915 37.73243
3 2 2015-05-10 23:50:00 Sunday NORTHERN 2000 Block of GOUGH ST -122.4260 37.79221
4 3 2015-05-10 23:45:00 Sunday INGLESIDE 4700 Block of MISSION ST -122.4374 37.72141
5 4 2015-05-10 23:45:00 Sunday INGLESIDE 4700 Block of MISSION ST -122.4374 37.72141
6 5 2015-05-10 23:40:00 Sunday TARAVAL BROAD ST / CAPITOL AV -122.4590 37.71317
```

I’ve red the data with *stringsAsFactors = F*, because I wanted the categorical columns to be in character and not in factor form, as I had to do some string preprocessing,

```
train = train[, -c(3,6)]
```

Furthermore, I removed the 3rd and 6th columns for two reasons: firstly they do appear only in the train data and secondly, I couldn’t find a way to take advantage of the *Descript* and *Resolution*.

```
train$Id = sort(seq(-nrow(train), -1, 1), decreasing = T)
test$Category = rep('none', nrow(test))
train = train[, c(8, 1:7)]
test = test[, c(1:2,8,3:7)]
train = rbind(train, test)
```

In order to horizontally join the train with the test data ( so that string preprocessing is feasible), I had to add an *Id* column to the train and a *Category* column to the test data. Then I shifted the order of columns so that the column names of the train data match the column names of the test data.

```
addr = train$Address
library(parallel)
rem_sl = unlist(mclapply(addr, function(x) stringr::str_replace(x, "/", ""), mc.cores = 4))
rem_sl1 = unlist(mclapply(rem_sl, function(x) stringr::str_replace_all(x, pattern=" ", repl=""), mc.cores = 4))
rem_sl2 = as.vector(sapply(rem_sl1, tolower))
train$Address = rem_sl2
```

To continue, I did some preprocessing of the **Address** column, as it appeared that some of these were in lower case, whereas others in upper case. First, I replaced c(‘/’, “ “) with an empty string “” and then I converted all addresses to lower case.

```
date = train$Dates
library(lubridate)
date1 = ymd_hms(date)
Year = year(date1)
Month = month(date1)
YDay = yday(date1)
WDay = wday(date1)
char_wdays = weekdays(date1)
Day = day(date1)
Hour = hour(date1)
Minute = minute(date1)
```

The **Dates** column was from a classification point of view important too, so I used the *lubridate* package to extract the *year*, *month*, *yearsday*, *weekday* (in numeric form), *weekday* (in character form),*day*, *hour* and *minutes*.

```
remov = data.frame(date_tmp = date1, order_dat = 1:length(date1))
remov1 = remov[order(remov$date_tmp, decreasing = F), ]
remov2 = cbind(remov1, order_out = 1:nrow(remov1))
remov3 = remov2[order(remov2$order_dat, decreasing = F), ]
ORD_rows = remov3$order_out
```

The training set and test set rotated every week, as I mentioned in the beginning, so I thought that a feature that tracks the order of the weeks could add some predictive power to the model,

```
library(zoo)
yq <- as.yearqtr(as.yearmon(as.Date(train$Dates), "%m/%d/%Y") + 1/12)
Season <- factor(format(yq, "%q"), levels = 1:4, labels = c("winter", "spring", "summer", "fall"))
Season = as.numeric(Season)
newy = which(Month == 1 & Day == 1)
newy1 = which(Month == 12 & Day == 31)
newal = rep(0, length(Month))
newal[newy] = 1
newal[newy1] = 1
train1 = data.frame(year = Year, month = Month, yday = YDay, weekday = WDay, day = Day, hour = Hour, minutes = Minute, season = Season, newy = newal, ORD_date = ORD_rows)
train1 = cbind(train, train1)
```

Furthermore, I utilized the *zoo* library to mark some periods of the year (seasons, new-year-event),

```
library(dplyr)
DISTRICTS = lapply(unique(train1$PdDistrict), function(x) filter(train1, PdDistrict == x))
median_outliers = function(sublist) {
if (max(sublist$X) == -120.5 || max(sublist$Y) == 90.00) {
sublist$X[which(sublist$X == -120.5)] = median(sublist$X)
sublist$Y[which(sublist$Y == 90.00)] = median(sublist$Y)
}
sublist
}
distr = lapply(DISTRICTS, function(x) median_outliers(x))
distr1 = do.call(rbind, distr)
```

There were some potential outliers in the *latitude* and *longitude* data (X,Y columns), which should be replaced with the corresponding median of each district’s X and Y. Here, I used the *filter* function of the dplyr package as it was faster than the *subset* function of the base R.

```
address_frequency = function(sublist) {
tmp_df = data.frame(table(sublist$Address))
tmp_df = tmp_df[order(tmp_df$Freq, decreasing = T), ]
tmp_df[1, ]$Var1
}
gcd.hf <- function(long1, lat1, long2, lat2) { # http://www.r-bloggers.com/great-circle-distance-calculations-in-r/
R <- 6371 # Earth mean radius [km]
delta.long <- (long2 - long1)
delta.lat <- (lat2 - lat1)
a <- sin(delta.lat/2) ^ 2 + cos(lat1) * cos(lat2) * sin(delta.long/2) ^ 2
c <- 2 * asin(min(1,sqrt(a)))
d = R * c
return(d) # Distance in km
}
get_reference_address = function(initial_data, split_column) { # function to calculate km-distances
s_col = lapply(unique(initial_data[, split_column]), function(x) initial_data[initial_data[, split_column] == x, ])
reference_address = lapply(s_col, function(x) as.character(address_frequency(x)))
reference_lon_lat = lapply(1:length(s_col), function(x) filter(s_col[[x]], Address == reference_address[[x]])[1, c('X','Y')])
Distance = lapply(1:length(s_col), function(f) sapply(1:nrow(s_col[[f]]), function(x) gcd.hf(s_col[[f]][x, 7], s_col[[f]][x, 8],
reference_lon_lat[[f]]$X, reference_lon_lat[[f]]$Y)))
tmp_id = do.call(rbind, s_col)$Id
tmp_df = data.frame(id = tmp_id, unlist(Distance))
colnames(tmp_df) = c('Id', paste('dist_', stringr::str_trim(split_column, side = 'both' )))
return(tmp_df)
}
lst_out = list()
for (i in c('PdDistrict', 'weekday', 'day', 'hour', 'season')) {
cat(i, '\n')
lst_out[[i]] = get_reference_address(distr1, i)
}
merg = merge(lst_out[[1]], lst_out[[2]], by.x = 'Id', by.y = 'Id')
merg = merge(merg, lst_out[[3]], by.x = 'Id', by.y = 'Id')
merg = merge(merg, lst_out[[4]], by.x = 'Id', by.y = 'Id')
merg = merge(merg, lst_out[[5]], by.x = 'Id', by.y = 'Id')
```

The previous long code chunk takes advantage of the *latitude* and *longitude* data to calculate **distance** features. The idea behind the script was to spot, first, for each district (*‘PdDistrict’*) the locations with high crime frequency. Then, I extended the features by doing the same for *‘weekday’*, *‘day’*, *‘hour’* and *‘season’*.

```
ndf = merge(distr1, merg, by.x = 'Id', by.y = 'Id')
ndf$`dist_ weekday` = log(ndf$`dist_ weekday` + 1)
ndf$`dist_ day` = sqrt(ndf$`dist_ day` + 1)
ndf$`dist_ hour` = 2 * sqrt(ndf$`dist_ hour` + 3/8)
ndf = ndf[, -c(2, 4)]
```

Then, I merged the distance-features (merg) with the initial data (distr1) and I took the *log* of the *‘dist_ weekday’*, the *sqrt* of the *‘dist_ day’* and the *Anscombe transform* of the *‘dist_ hour’*, as I observed some correlation of those transforms with the response variable. Additionally, I removed the 2nd (Dates) and 4th (DayOfWeek) columns, because *Dates* have been already preprocessed and the *DayOfWeek* appeared in numeric form already (*weekday*).

```
table(ndf$PdDistrict)
BAYVIEW CENTRAL INGLESIDE MISSION NORTHERN PARK RICHMOND SOUTHERN TARAVAL TENDERLOIN
179022 171590 158929 240357 212313 99512 90181 314638 132213 163556
pdD = as.factor(ndf$PdDistrict)
mdM = model.matrix(~.-1, data.frame(pdD))
ndf$PdDistrict = NULL
ndf = cbind(ndf, mdM)
```

I converted the *PdDistrict* predictor to dummy variables, as it didn’t have many Levels (like the Address column) and, in binarized form, it could add more predictive power to the model.

```
ndf$Address = as.numeric(as.factor(ndf$Address))
ntrain = filter(ndf, Id < 0)
ntrain$Id = NULL
response = ntrain$Category
y = c(0:38)[ match(response, sort(unique(response))) ]
ntrain$Category = NULL
ntest = filter(ndf, Id >= 0)
ID_TEST = as.integer(ntest$Id)
ntest$Id = NULL
ntest$Category = NULL
```

Finally, I split the end-data (ndf2) to train and test, I converted the response variable (y) to numeric (0:38) (so that it is compatible with the xgboost algorithm) and I removed redundant columns from both train (the *Id*) and test (the *Category*).

```
library(Matrix)
ntrain = Matrix(as.matrix(ntrain), sparse = T)
ntest = Matrix(as.matrix(ntest), sparse = T)
```

Some of the columns are highly sparse, thus converting the data to a sparse matrix could speed up the training. For this purpose, I used the Matrix library.

### xgboost algorithm

The purpose of the competition was to decrease the *Multi-class log loss* thus, I used a corresponding function (*MultiLogLoss*) and additionally I built a validation function, which I used internally to evaluate the folds in xgboost (*VALID_FUNC*).

```
VALID_FUNC = function(EVAL_METRIC, arg_actual, arg_predicted, inverse_order = FALSE) {
if (inverse_order == TRUE) {
args_list = list(arg_predicted, arg_actual)
}
else {
args_list = list(arg_actual, arg_predicted)
}
result = do.call(EVAL_METRIC, args_list)
result
}
MultiLogLoss = function (y_true, y_pred) {
if (is.factor(y_true)) {
y_true_mat <- matrix(0, nrow = length(y_true), ncol = length(levels(y_true)))
sample_levels <- as.integer(y_true)
for (i in 1:length(y_true)) y_true_mat[i, sample_levels[i]] <- 1
y_true <- y_true_mat
}
eps <- 1e-15
N <- dim(y_pred)[1]
y_pred <- pmax(pmin(y_pred, 1 - eps), eps)
MultiLogLoss <- (-1/N) * sum(y_true * log(y_pred))
return(MultiLogLoss)
}
```

I used the xgboost algorithm because it works pretty well with big data and gives good results as well. I performed a 4-fold cross-validation and at each fold, I also predicted the test data. The following function was used to evaluate each fold and to get the predictions from the unknown test data,

```
xgboost_cv = function(RESP, data, TEST, repeats, Folds, idx_train = NULL, param, num_rounds, print_every_n = 10,
early_stop = 10, maximize = FALSE, verbose = 1, EVAL_METRIC, set_seed = 2) {
start = Sys.time()
library(caret)
library(xgboost)
library(Metrics)
out_ALL = list()
for (j in 1:repeats) {
cat('REPEAT', j, '\n')
TEST_lst = PARAMS = PREDS_tr = PREDS_te = list()
if (is.numeric(Folds)) {
if (is.null(set_seed)) {
sample_seed = sample(seq(1, 1000000, 1), 1)}
else {
sample_seed = set_seed
}
set.seed(sample_seed)
folds = createFolds(RESP, k = Folds, list = TRUE)}
else {
if (is.null(idx_train)) stop(simpleError('give index of train data in form of a vector'))
out_idx = 1:dim(data)[1]
folds = lapply(1:length(Folds), function(x) out_idx[which(idx_train %in% Folds[[x]])])
}
tr_er <- tes_er <- rep(NA, length(folds))
for (i in 1:length(folds)) {
cat('fold', i, '\n')
dtrain <- xgb.DMatrix(data = data[unlist(folds[-i]), ], label = RESP[unlist(folds[-i])])
dtest <- xgb.DMatrix(data = data[unlist(folds[i]), ], label = RESP[unlist(folds[i])])
watchlist <- list(train = dtrain, test = dtest)
fit = xgb.train(param, dtrain, nround = num_rounds, print.every.n = print_every_n, watchlist = watchlist,
early.stop.round = early_stop, maximize = maximize, verbose = verbose)
PARAMS[[i]] = list(param = param, bst_round = fit$bestInd)
pred_tr = predict(fit, data[unlist(folds[-i]), ], ntreelimit = fit$bestInd)
pred_tr = matrix(pred_tr, nrow = dim(data[unlist(folds[-i]), ])[1], ncol = length(unique(y)), byrow = TRUE)
pred_te = predict(fit, data[unlist(folds[i]), ], ntreelimit = fit$bestInd)
pred_te = matrix(pred_te, nrow = dim(data[unlist(folds[i]), ])[1], ncol = length(unique(y)), byrow = TRUE)
tr_er[i] = VALID_FUNC(EVAL_METRIC, as.factor(RESP[unlist(folds[-i])]), pred_tr)
tes_er[i] = VALID_FUNC(EVAL_METRIC, as.factor(RESP[unlist(folds[i])]), pred_te)
tmp_TEST = matrix(predict(fit, TEST, ntreelimit = fit$bestInd), nrow = dim(TEST)[1], ncol = length(unique(y)), byrow = TRUE)
TEST_lst[[paste0('preds_', i)]] = tmp_TEST
cat('---------------------------------------------------------------------------', '\n')
save(tmp_TEST, file = paste('sfcc_', paste(sample(1:1000000000, 1), '_REPEAT_save.RDATA', sep = ""), sep = ""))
gc()
}
out_ALL[[j]] = list(TEST_lst = TEST_lst, PARAMS = PARAMS, sample_seed = sample_seed, tr_er = tr_er,PREDS_tr = PREDS_tr,
PREDS_te = PREDS_te, tes_er = tes_er)
cat('================================================================================================================', '\n')
gc()
}
end = Sys.time()
return(list(res = out_ALL, time = end - start))
}
```

I experimented with different parameter settings, but the following one is a good trade-off between running time and performance, as it runs in 2.89 hours and gives a leaderboard score of 2.238 Multi-class log-loss. To improve the leaderboard score in this competition I averaged 6 models with different parameter settings. I observed that a learning rate (eta) of 0.145 and a number of rounds (num_rounds) 320 gave the best results,

```
params = list("objective" = "multi:softprob", "eval_metric" = "mlogloss", "num_class" = 39, "booster" = "gbtree", "bst:eta" = 0.245,
"subsample" = 0.7, "max_depth" = 7, "colsample_bytree" = 0.7, "nthread" = 6, "scale_pos_weight" = 0.0,
"min_child_weight" = 0.0, "max_delta_step" = 1.0)
fit = xgboost_cv(y, ntrain, ntest, repeats = 1, Folds = 4, idx_train = NULL, params, num_rounds = 145, print_every_n = 5,
early_stop = 10, maximize = FALSE, verbose = 1, MultiLogLoss)
```

Before, submitting the csv-predictions, I had to calculate the train and test error for each fold, then to average the predictions of the unknown test data and to add the column names of the sample submission (the column names had to be in the correct form, otherwise the submission wasn’t accepted, thus check.names = F when reading the data was necessary),

```
tr_er = unlist(lapply(fit$res, function(x) x$tr_er))
tes_er = unlist(lapply(fit$res, function(x) x$tes_er))
cat('log loss of train is :', mean(tr_er), '\n')
# log loss of train is : 1.952143
cat('log loss of test is :', mean(tes_er), '\n')
# log loss of test is : 2.232479
lap = unlist(lapply(fit$res, function(x) x$TEST_lst), recursive = FALSE)
avg_dfs = (lap[[1]] + lap[[2]] + lap[[3]] + lap[[4]])/4
subms = data.frame(ID_TEST, avg_dfs)
sampleSubmission <- read.csv("sampleSubmission.csv", check.names = F)
colnames(subms) = colnames(sampleSubmission)
subms = subms[order(subms$Id, decreasing = F), ]
write.csv(subms, "xgb_post_submission_train_error_1_95_test_error_2_2324.csv", row.names=FALSE, quote = FALSE)
```

Finally, I’ll utilize the *FeatureSelection* package and especially xgboost and ranger to plot the important variables,

```
ntr = as.matrix(ntrain)
colnames(ntr) = make.names(colnames(ntr))
library(FeatureSelection)
params_xgboost = list(params = list("objective" = "multi:softprob", "eval_metric" = "mlogloss", "num_class" = 39, "booster" = "gbtree",
"bst:eta" = 0.5, "subsample" = 0.65, "max_depth" = 5, "colsample_bytree" = 0.65, "nthread" = 6,
"scale_pos_weight" = 0.0, "min_child_weight" = 0.0, "max_delta_step" = 1.0),
nrounds = 50, print.every.n = 5, verbose = 1, maximize = F)
params_ranger = list(write.forest = TRUE, probability = TRUE, num.threads = 6, num.trees = 50, verbose = FALSE, classification = TRUE,
mtry = 4, min.node.size = 5, importance = 'impurity')
params_features = list(keep_number_feat = NULL, union = F)
feat = wrapper_feat_select(ntr, y, params_glmnet = NULL, params_xgboost = params_xgboost, params_ranger = params_ranger, xgb_sort = NULL,
CV_folds = 4, stratified_regr = FALSE, cores_glmnet = 2, params_features = params_features)
params_barplot = list(keep_features = 28, horiz = TRUE, cex.names = 0.8)
barplot_feat_select(feat, params_barplot, xgb_sort = 'Cover')
```

The complete script of this blog post can be found as a single file in my Github account.

Thanks for visiting r-craft.org

This article is originally published at

Please visit source website for post related comments.