.g() .us() setScienceIfNot("Acc_vs_Anal_2015", load=FALSE) setSubProj("iTunesForecast") lib(ggplot) library(h2o) ## Recalculate if missing if (!exists("DT.iTunes.acc_v_anal")) DT.iTunes.acc_v_anal <- create_DT.iTunes.acc_v_anal(confirm=FALSE) ## TODO: Add in Mike B's numbers! # initial H2O locl instance localh2o = h2o.init(nthreads=30, min_mem_size="18g", max_mem_size="40g") ## reload data if necessary loadIfNotExists("DT.iTunes.acc_v_anal") ## Folder for plot outputs folder.plots <- plots.p(today.string()) dir.create(folder.plots, recursive=TRUE, showWarnings=FALSE) ## Folder for model outputs folder.h2o_models <- out.p(timeStamp("h2o_models")) dir.create(folder.h2o_models, recursive=TRUE, showWarnings=FALSE) ## Should have been brought over from previous file, but just in case, create again if (!exists("kCols")) kCols <- c("date", "storeid", "transid") ## POTENTIAL VARIABLE LIST (Explanitory is based on j) TargetVar.list = list(log="log.revenue.acc", unlog="revenue.acc") Explanitory.list = rev(list( c("transac_type_abbr", "is_DTorDA", "months_back_TRANSFORMED", "more_than_six_months_ago", "music_vs_video_by_transac", "revenue.anal", "paidunits.anal", "paidunits.acc") , c("transac_type_abbr", "is_DTorDA", "more_than_six_months_ago", "music_vs_video_by_transac", "revenue.anal", "paidunits.anal", "paidunits.acc") , c("transac_type_abbr", "is_DTorDA", "months_back_from_max_date", "music_vs_video_by_transac", "revenue.anal", "paidunits.anal", "paidunits.acc") , c("transac_type_abbr", "is_DTorDA", "months_back_from_max_date", "revenue.anal", "paidunits.anal", "paidunits.acc") , c( "is_DTorDA", "months_back_from_max_date", "revenue.anal", "paidunits.anal", "paidunits.acc") , c("transac_type_abbr", "is_DTorDA", "revenue.anal", "paidunits.anal", "paidunits.acc") , c("transac_type_abbr", "revenue.anal", "paidunits.anal", "paidunits.acc") )) ## Create Legend Plot P.legend <- gg_extract_legend(ggplot(data=DT.iTunes.acc_v_anal[, list(unique(transac_type_abbr))][, .N, by=list(transac_type_abbr=V1)], aes_string(x="transac_type_abbr", color="transac_type_abbr", fill="transac_type_abbr", y="N")) + geom_density(stat="identity") + legendbottom() + color_by_dict("colors.trans_abbr") + fill_by_dict("colors.trans_abbr")) # if (!exists("epochs")) # { # .g() # ## PARAMETERS FOR SETUP # i <- 7 # j <- 2 # transform_to <- "unlog" ## one of c("unlog", log") # # ## PAREMETERS FOR MODEL # epochs <- 10000 # # H <- 220 # # hidden <- c(H, 1.5*H, 1.5*H, H) # l1 = 1e-5 # l2 = 1 # # idr = 0 # hdr = 0 # } verbose <- TRUE epoch.optons <- c(30, 50, 200, 500, 1000, 10000) hidden.options <- list(c(200, 400, 400, 200), c(500, 500, 500), c(200, 50, 200), c(500, 500, 500, 500), c(800, 800, 800, 800, 800)) d_ratio.options <- c(0.01, 0.05, 0.1, 0.15, 0.2, 0.3, 0.5) # removed 0 to not re run regu.options <- c(0, 1e-10, 1e-7, 1e-5, 1e-2, 1e-1, 0.2, 0.5, 0.8, 1) j.options <- seq(Explanitory.list) i.opt <- 1:3 { if (!exists("model.iTunes.rev")) model.iTunes.rev <- list() } { if (!exists("DT.model_scores" )) DT.model_scores <- data.table(model_name=character(), train_MSE=numeric(), validation_MSE=numeric(), hidden=list(), epochs=numeric(), l1=numeric(), l2=numeric(), hdr=numeric(), idr=numeric(), j=numeric(), i=numeric(), transform_to=character(), plot_file=character(), Explanitory=character(), TargetVar=character(), predCol=character(), TotalTestRev=numeric(), TotalPredRev=numeric(), short_abs=numeric(), short_perc=numeric()) } counter <- 0 for (epochs in epoch.optons) { for (hidden in hidden.options) { for (idr in d_ratio.options) { for (hdr in d_ratio.options) { for (j in j.options) { for (l1 in regu.options) { for (l2 in regu.options) { for (transform_to in c("log")) try({ cat("----------------------------------------------------------------------------------------\n\n\n") TargetVar <- TargetVar.list[[transform_to]] Explanitory <- log_unlog_swap(Explanitory.list[[j]], transform_to) colsForModeling <- c(Explanitory, TargetVar) colsForModeling.test <- unique(c(colsForModeling, log_unlog_swap(TargetVar), "transac_type_abbr", "is_DTorDA")) ## < see > DT.iTunes.acc_v_anal[, c(Explanitory, TargetVar), with=FALSE] ## Indecis for sub sampling inds.list <- getIndsList_AND_add_rowindexCol_to_DT(DT.iTunes.acc_v_anal, byCols=c("transac_type_abbr")) # { # k = 12 ## number of subsamples # train_test_split = 3/4 ## percent of training set. Usually about 0.80 # replace = FALSE # byCols = setdiff(kCols, "date") # byCols = c("transac_type_abbr") # # cat("byCols for subsetting indecis is " , pasteQand(byCols, q=" "), "\n ", fill=TRUE) # ## add a row index to ensure consistency # DT.iTunes.acc_v_anal[, rowindex := seq(.N)] # ## Create subsamples indices # inds.list <- {set.seed(7); lapply(seq(k), function(i) DT.iTunes.acc_v_anal[, .inds := seq(.N) %in% sample(.N, floor(.N*(train_test_split)), replace=replace), by=byCols][, rowindex[.inds]] )} # DT.iTunes.acc_v_anal[, .inds := NULL] ## cleanup # setattr(inds.list, "names", sprintf("fold_%02i", seq(inds.list))) # } for (i in 1:3) { ## Create Training and Testing DTs { ## Model for current index training <- inds.list[[i]] test <- setdiff(seq(nrow(DT.iTunes.acc_v_anal)), training) ## confirm we have all of the rows and no duplicates stopifnot(!duplicated(c(test, training))) # no duplicates stopifnot(sort(DT.iTunes.acc_v_anal$rowindex) == sort(c(test, training))) ## identical ## Confirm that they each have all of the trans types stopifnot(all(DT.iTunes.acc_v_anal[, unique(transac_type_abbr)] %in% DT.iTunes.acc_v_anal[training, unique(transac_type_abbr)])) stopifnot(all(DT.iTunes.acc_v_anal[, unique(transac_type_abbr)] %in% DT.iTunes.acc_v_anal[test, unique(transac_type_abbr)])) DT.iTunes.training <- DT.iTunes.acc_v_anal[ training , colsForModeling, with=FALSE] DT.iTunes.test <- DT.iTunes.acc_v_anal[ test , colsForModeling.test, with=FALSE] cat("\t\t --={ L O A D I N G I N T O D A T A H 2 O }=--\n") h2o.iTunes.training <- as.h2o(localh2o, DT.iTunes.training, key="iTunes.training" ) h2o.iTunes.test <- as.h2o(localh2o, DT.iTunes.test, key="iTunes.test" ) cat("\t\tTargetVar is : ", extract(TargetVar, DT.iTunes.training), fill=TRUE, sep=" ") cat("\t\tExplanitory vars are : ", sapply(Explanitory, extract, DT.iTunes.training), fill=TRUE, sep=" ") cat("\n") } # TRAIN THE MODEL { # ## Pull a random seed, then save it # seed_for_h2o <- runif(1, 0, 1e7) ## from documentation: "only reproducible when running single threaded" M <- length(model.iTunes.rev) + 1 ## The next element in the list j.i.l.l. <- sprintf("j_%02i.i_%02i.l1_%s.l2_%s.idr_%s.hdr_%s.epochs_%s.hidden_%s.transform_%s", j, i, as.character(l1), as.character(l2), idr, hdr, epochs, pasteC(hidden, C="x"), transform_to) model_name <- sprintf("%smodel__%s", ifelse(transform_to=="unlog", "", "log-log."), j.i.l.l.) predCol <- sprintf("%spred__j_%02i.i_%02i", ifelse(transform_to=="unlog", "", "log."), j, i) ## column name cannot be too long for ggplot2 file.out <- model_name model.iTunes.rev[[M]] <- list(model_name=model_name, model=NULL, info=NULL, prediction=NULL) cat("\t\t --={ C R E A T I N G M O D E L '", model_name, "'' }=--\n", sep="") model.iTunes.rev[[M]][["model"]] <- h2o.deeplearning(x = seq(length(colsForModeling)-1), y = length(colsForModeling) , classification = FALSE , data = h2o.iTunes.training , validation = h2o.iTunes.test , activation = "RectifierWithDropout" , hidden = hidden , input_dropout_ratio = idr , hidden_dropout_ratios = rep(hdr, length(hidden)) , l1 = l1 , l2 = l2 , epochs = epochs) # print(model.iTunes.rev[[M]][["model"]]); cat("\n"); Sys.sleep(2) #Perform classification on the test set prediction <- unlist(as.data.frame(h2o.predict(model.iTunes.rev[[M]][["model"]], newdata=h2o.iTunes.test)), use.names=FALSE) #Copy predictions from H2O to R DT.iTunes.test[, (predCol) := prediction] DT.iTunes.test[, log_unlog_swap(predCol) := log_unlog_swap(get(predCol), inverse_transform=transform_to)] ## Calculate how much is off by TotalTestRev <- sumn(DT.iTunes.test[["revenue.acc"]]) TotalPredRev <- sumn(DT.iTunes.test[[log_unlog_swap(predCol, transform_to="unlog")]]) short_abs <- TotalTestRev - TotalPredRev short_perc <- TotalPredRev / TotalTestRev ## Compile the relevant information next_row <- data.table(model_name=model_name, train_MSE=model.iTunes.rev[[M]][["model"]]@model$train_sqr_err, validation_MSE=model.iTunes.rev[[M]][["model"]]@model$valid_sqr_err, hidden=list(hidden), epochs=epochs, l1=l1, l2=l2, hdr=hdr, idr=idr, j=j, i=i, transform_to=transform_to, plot_file=paste0(folder.plots, "/", file.out), Explanitory=pasteC(Explanitory, C=", "), TargetVar=TargetVar, predCol=predCol, TotalTestRev=TotalTestRev, TotalPredRev=TotalPredRev, short_abs=short_abs, short_perc=short_perc) DT.model_scores <- rbind(DT.model_scores, next_row, use.names=TRUE, fill=TRUE) ## Add the info to model list as well model.iTunes.rev[[M]][["info"]] <- next_row model.iTunes.rev[[M]][["prediction"]] <- prediction } ## Save it # jesusForData(DT.iTunes.test, info=model_name) ## CREATE THE PLOTS OBJECT AND SAVE TO FILE { YN <- c("Y", "N") # t_to <- c("log", "unlog") using_color <- ("transac_type_abbr" %in% names(DT.iTunes.test)) color <- if (using_color) "transac_type_abbr" else NULL PLOTS <- emptylist(apply(expand.grid(c("log", "unlog"), "__DTDA_", YN), 1, pasteC)) for (t_to in c("log", "unlog")) { TV <- log_unlog_swap(TargetVar, transform_to=t_to) PC <- log_unlog_swap(predCol, transform_to=t_to) cat("Using TV =", TV, " and PC =", PC, fill=TRUE) for (yn in YN) { ## set Limits based on range of both actual and predicted. Plot will be squared lims <- DT.iTunes.test[is_DTorDA==yn, range(c(get(TV), get(PC)), na.rm=TRUE)] if (t_to == "log") lims <- roundOutToX(lims + c(-.1, +.1), X=.05) else lims <- roundOutToX(lims + c(-1200, +1200), X=250) if (any(is.na(lims) | !is.finite(lims))) lims <- NULL PLOTS[[paste0(t_to, "__DTDA_", yn)]] <- ggplot(data=DT.iTunes.test[is_DTorDA==yn], aes_string(x=TV, y=PC, color=color)) + geom_point() + gg_xyline() + {if (using_color) color_by_dict("colors.trans_abbr")} + {if (t_to == "unlog") dollar.x(limits=lims) else xlim(lim=lims)} + {if (t_to == "unlog") dollar.y(limits=lims) else ylim(lim=lims)} + labs(x="actual", y="predicted", title=t_to) ## Print it to force DT and any issues with by-reference stemming from data.table print(PLOTS[[paste0(t_to, "__DTDA_", yn)]]) } } V.MSE <- model.iTunes.rev[[M]][["model"]]@model$valid_sqr_err main_title <- sprintf("Model %s V.MSE: %.04f \nTest-data represents $ %sK in revenue and prediction is short by $ %sK or %s of actual ", gsub("\\.", " ", gsub("_", " = ", j.i.l.l.)), V.MSE, formnumb(TotalTestRev/1000, round=-2), formnumb(short_abs/1000, round=-2), fwp(short_perc, dec=0, sep="")) cat(main_title, "\n", fill=TRUE) stopifnot(sapply(PLOTS, is.gg)) full.file.out <- printToPDF(PLOTS, f.name=file.out, f.dir=folder.plots, nrow=2, ncol=2, open.when.done=(.Pfm=="Darwin"), math_fonts=FALSE, main=main_title) # full.file.out <- printToPDF(c(PLOTS, list(legend=P.legend)), f.name=file.out, f.dir=folder.plots, nrow=c(3), ncol=c(2, 2, 1), open.when.done=(.Pfm=="Darwin"), math_fonts=FALSE, main=main_title) } } ## // end of for i ### I HAD FORGOTTEN TO ADD hidden and epochs TO DT.model_scores ### This code took it from the model_name # DT.model_scores[, # c("hidden", "epochs") := # rbindlist(lapply(strsplit(model_name, "\\."), function(x) { # h <- grep("^hidden", x, value=TRUE) # data.table( # hidden = list(as.numeric(unlist(strsplit(gsub("hidden_", "", h), "x"), use.names=FALSE))) # , epochs = as.numeric(gsub("^epochs_", "", grep("^epoch", x, value=TRUE))) # ) # })) # ] }) # // transform_to ## MID-ITERATION SAVE ## Set the names of of model.iTunes.rev nms.models <- unname(sapply(model.iTunes.rev, "[[", "model_name")) nms.models <- unlist(ifelse(sapply(nms.models, is.null), sprintf("NO_NAME_%04i", seq(nms.models)), nms.models)) setattr(model.iTunes.rev, "names", value=nms.models) jfile.model_list <- jesusForData(model.iTunes.rev) jfile.model_Scores <- jesusForData(DT.model_scores) if (.Pfm != "Darwin") cat(sprintf("\n\nbringme('%s'); \nbringmeFolder('%s'); \n.o('%2$s');\n.g();\n\n", jfile.model_Scores, folder.plots), fill=TRUE ) } # // l2 } # // l1 } # // j try(h2o.saveAll(localh2o, dir=folder.h2o_models, force=TRUE), silent=TRUE) } # // hdr } # // idr } # // hidden } # // epochs