# This R environment comes with all of CRAN preinstalled, as well as many other helpful packages # The environment is defined by the kaggle/rstats docker image: https://github.com/kaggle/docker-rstats # Required Libraries library(data.table) library(readr) library(caret) library(stringdist) library(digest) # Read in data 1 location <- fread("../input/Location.csv") 2 itemPairsTest <- fread("../input/ItemPairs_test.csv") 3 itemPairsTrain <- fread("../input/ItemPairs_train.csv") 4 #itemInfoTest <- read_csv("../input/ItemInfo_test.csv", nrows = 100) #itemInfoTrain <- read_csv("../input/ItemInfo_train.csv", nrows = 100) itemInfoTest <- read_csv( "../input/ItemInfo_test.csv") 5 itemInfoTrain <- read_csv("../input/ItemInfo_train.csv") 6 itemInfoTest <- data.table(itemInfoTest) 7 itemInfoTrain <- data.table(itemInfoTrain) 8 setkey(location, locationID) setkey(itemInfoTrain, itemID) setkey(itemInfoTest, itemID) # Split by generation method #itemPairsTrain1 <- itemPairsTrain[generationMethod == 1] #itemPairsTrain2 <- itemPairsTrain[generationMethod == 2] #itemPairsTrain3 <- itemPairsTrain[generationMethod == 3] # Create cross-folds for validation #set.seed(1984) #itemPairsTrain1$foldId <- createFolds(itemPairsTrain1$isDuplicate, k=5, list=FALSE) #itemPairsTrain2$foldId <- createFolds(1:nrow(itemPairsTrain2), k=5, list=FALSE) #itemPairsTrain3$foldId <- createFolds(itemPairsTrain3$isDuplicate, k=5, list=FALSE) #itemPairsTrain <- rbind(itemPairsTrain1, itemPairsTrain2, itemPairsTrain3) #rm(list=c("itemPairsTrain1", "itemPairsTrain2", "itemPairsTrain3")) 9 # Drop unused factors dropAndNumChar <- function(itemInfo){ itemInfo[, ':=' (ncharTitle = nchar(title), ncharDescription = nchar(description), # description = NULL, images_array = NULL, attrsJSON = NULL)] } dropAndNumChar(itemInfoTest) dropAndNumChar(itemInfoTrain) 1 # Merge mergeInfo <- function(itemPairs, itemInfo){ # merge on itemID_1 setkey(itemPairs, itemID_1) itemPairs <- itemInfo[itemPairs] setnames(itemPairs, names(itemInfo), paste0(names(itemInfo), "_1")) # merge on itemID_2 setkey(itemPairs, itemID_2) itemPairs <- itemInfo[itemPairs] setnames(itemPairs, names(itemInfo), paste0(names(itemInfo), "_2")) # merge on locationID_1 setkey(itemPairs, locationID_1) itemPairs <- location[itemPairs] setnames(itemPairs, names(location), paste0(names(location), "_1")) # merge on locationID_2 setkey(itemPairs, locationID_2) itemPairs <- location[itemPairs] setnames(itemPairs, names(location), paste0(names(location), "_2")) return(itemPairs) } 2 itemPairsTrain <- mergeInfo(itemPairsTrain, itemInfoTrain) itemPairsTest <- mergeInfo(itemPairsTest, itemInfoTest) #itemPairsTrainOut <- itemPairsTrain[sample(nrow(itemPairsTrain), 500), ] #write.csv(itemPairsTrainOut, file="smallTrainData500D.csv") #itemPairsTestOut <- itemPairsTest[sample(nrow(itemPairsTest), 500), ] #write.csv(itemPairsTestOut, file="smallTestData500D.csv") 3 #d1 <- itemPairsTrain$description_1 4 #d2 <- itemPairsTrain$description_2 5 #itemPairsTrain$isDuplicate #str(d1) #str(d2) 1111 #str(itemPairsTrain) #dim(itemPairsTrain) 3 #summary(itemPairsTrain) #head(itemPairsTrain) #datatable(itemPairsTrain) rm(list=c("itemInfoTest", "itemInfoTrain", "location")) # Create features matchPair <- function(x, y){ ifelse(is.na(x), ifelse(is.na(y), 3, 2), ifelse(is.na(y), 2, ifelse(x==y, 1, 4))) } calcHash <- function(s){ digest(object = s, algo = "md5", serialize = FALSE) } calcWordDistHash <- function(s1, s2){ ws1 = unlist(strsplit(as.character(s1)," ")) ws2 = unlist(strsplit(as.character(s2)," ")) hs <- numeric() # foreach(st1 in ws1, .combine='c') %do% { for(st1 in ws1) { v <- calcHash(st1) hs <- c(hs, v) } k <- 0 # foreach(st in ws2, .combine='c') %do% { for(st in ws2) { sh <- calcHash(st) if(is.na(match(sh, hs)) == FALSE){ k <- k + 1 } } # return(k) return(k / max(length(ws1),length(ws2)) ) } cwd <- function(s1, s2){ ws1 = unlist(strsplit(as.character(s1)," ")) ws2 = unlist(strsplit(as.character(s2)," ")) k <- 0 for(st1 in ws1){ if(is.na(match(st1, ws2)) == FALSE){ # if(length(match(st1, ws2)) > 0){ k <- k + 1 break } } return(k / pmin(length(ws1),length(ws2)) ) } createFeatures <- function(itemPairs){ itemPairs[, ':=' (locationMatch = matchPair(locationID_1, locationID_2), locationID_1 = NULL, locationID_2 = NULL, regionMatch = matchPair(regionID_1, regionID_2), regionID_1 = NULL, regionID_2 = NULL, metroMatch = matchPair(metroID_1, metroID_2), metroID_1 = NULL, metroID_2 = NULL, categoryMatch = matchPair(categoryID_1, categoryID_2), wd = 1, categoryID_1 = NULL, categoryID_2 = NULL, priceMatch = matchPair(price_1, price_2), priceDiff = pmax(price_1/price_2, price_2/price_1), # priceMin = pmin(price_1, price_2, na.rm=TRUE), # priceMax = pmax(price_1, price_2, na.rm=TRUE), price_1 = NULL, price_2 = NULL, titleStringDist = stringdist(title_1, title_2, method = "jw"), wordDist = stringdist(description_1, description_2, method = "jw"), title_1 = NULL, title_2 = NULL, titleCharDiff = pmax(ncharTitle_1/ncharTitle_2, ncharTitle_2/ncharTitle_1), #titleCharMin = pmin(ncharTitle_1, ncharTitle_2, na.rm=TRUE), # titleCharMax = pmax(ncharTitle_1, ncharTitle_2, na.rm=TRUE), ncharTitle_1 = NULL, ncharTitle_2 = NULL, descriptionCharDiff = pmax(ncharDescription_1/ncharDescription_2, ncharDescription_2/ncharDescription_1), # descriptionCharMin = pmin(ncharDescription_1, ncharDescription_2, na.rm=TRUE), # descriptionCharMax = pmax(ncharDescription_1, ncharDescription_2, na.rm=TRUE), ncharDescription_1 = NULL, ncharDescription_2 = NULL, distance = sqrt((lat_1-lat_2)^2+(lon_1-lon_2)^2), lat_1 = NULL, lat_2 = NULL, lon_1 = NULL, lon_2 = NULL, itemID_1 = NULL, itemID_2 = NULL)] itemPairs[, ':=' (priceDiff = ifelse(is.na(priceDiff), 0, priceDiff), # priceMin = ifelse(is.na(priceMin), 0, priceMin), # priceMax = ifelse(is.na(priceMax), 0, priceMax), titleStringDist = ifelse(is.na(titleStringDist), 0, titleStringDist))] } 4 itemPairsTrain <- itemPairsTrain[sample(nrow(itemPairsTrain), 50000), ] #itemPairsTest <- itemPairsTest[sample(nrow(itemPairsTest), 1000), ] createFeatures(itemPairsTrain) #summary(itemPairsTrain$wordDist) createFeatures(itemPairsTest) 5 itemIter <- function(itemPairs){ #itemPairs["description_1"] itemPairs["wd"] <- cwd(itemPairs["description_1"], itemPairs["description_2"]) } #lapply(itemPairsTrain, itemIter) #lapply(itemPairsTest, itemIter) #for(idx in 1:nrow(itemPairsTrain)){ # itemPairsTrain[idx,]$wd <- calcWordDistHash(itemPairsTrain[idx,]$description_1, itemPairsTrain[idx,]$description_2) #} #for(idx in 1:nrow(itemPairsTest)){ # itemPairsTest[idx,]$wd <- calcWordDistHash(itemPairsTest[idx,]$description_1, itemPairsTest[idx,]$description_2) #} 5 itemPairsTrain[, ':=' (description_1 = NULL, description_2 = NULL)] itemPairsTest[, ':=' (description_1 = NULL, description_2 = NULL)] 5 library(xgboost) 6 maxTrees <- 70 shrinkage <- 0.1 gamma <- 2 depth <- 8 minChildWeight <- 3 colSample <- 0.95 subSample <- 0.95 earlyStopRound <- 20 modelVars <- names(itemPairsTrain)[which(!(names(itemPairsTrain) %in% c("isDuplicate", "generationMethod", "foldId")))] itemPairsTest <- data.frame(itemPairsTest) itemPairsTrain <- data.frame(itemPairsTrain) set.seed(1984) #itemPairsTrain <- itemPairsTrain[sample(nrow(itemPairsTrain), 50000), ] 7 # Matrix dtrain <- xgb.DMatrix(as.matrix(itemPairsTrain[, modelVars]), label=itemPairsTrain$isDuplicate) dtest <- xgb.DMatrix(as.matrix(itemPairsTest[, modelVars])) 8 str(dtrain) 9 # xgboost cross-validated set.seed(1984) xgbCV <- xgb.cv(params=list(max_depth=depth, eta=shrinkage, gamma=gamma, colsample_bytree=colSample, min_child_weight=minChildWeight, subsample=subSample, objective="binary:logistic"), data=dtrain, nrounds=maxTrees, eval_metric ="auc", nfold=4, stratified=TRUE, early.stop.round=earlyStopRound) 11 numTrees <- min(which(xgbCV$test.auc.mean==max(xgbCV$test.auc.mean))) 11 xgbResult <- xgboost(params=list(max_depth=depth, eta=shrinkage, gamma=gamma, colsample_bytree=colSample, min_child_weight=minChildWeight), data=dtrain, nrounds=numTrees, objective="binary:logistic", eval_metric="error") 12 testPreds <- predict(xgbResult, dtest) 12 submission <- data.frame(id=itemPairsTest$id, probability=testPreds) write.csv(submission, file="submission.csv",row.names=FALSE)