SQL-Server-R-Services-Samples/RetailForecasting/SQLR/train_regression_rf.sql at master · Roboticmechart22/SQL-Server-R-Services-Samples · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
SET ANSI_NULLS ON
GO

/****** Create the Stored Procedure for Retail Forecasting Template ******/

SET QUOTED_IDENTIFIER ON
GO

DROP PROCEDURE IF EXISTS train_regression_rf
GO

TRUNCATE TABLE RetailForecasting_models_rf
GO
-- =============================================
-- Author:		<Author,,Name>
-- Create date: <Create Date,,>
-- Description:	<Description,,>
-- =============================================
CREATE PROCEDURE [train_regression_rf] @connectionString varchar(300),
                                       @num_folds int
AS
BEGIN
  DECLARE @inquery NVARCHAR(max) = N'SELECT * from train'
  INSERT INTO RetailForecasting_models_rf
  EXEC sp_execute_external_script @language = N'R',
                                  @script = N'
sql_share_directory <- paste("c:\\AllShare\\", Sys.getenv("USERNAME"), sep = "")
dir.create(sql_share_directory, recursive = TRUE)
sql <- RxInSqlServer(connectionString = connection_string,
                     shareDir = sql_share_directory)
local <- RxLocalSeq()

train <- InputDataSet
####################################################################################################
## Regression formula
####################################################################################################
train_vars <- rxGetVarNames(train)
train_vars <- train_vars[train_vars != "time"]
formula <- as.formula(paste("value~", paste(train_vars, collapse = "+")))
####################################################################################################
## Regression model evaluation metrics
####################################################################################################
evaluate_model <- function(data, observed, predicted) {
  data <- data[, c(observed, predicted)]
  data <- data[complete.cases(data), ]
  mean_observed <- mean(data[[observed]])
  data$se <- (data[[observed]] - data[[predicted]])^2
  data$ae <- abs(data[[observed]] - data[[predicted]])
  data$sem <- (data[[observed]] - mean(data[[observed]]))^2
  data$aem <- abs(data[[observed]] - mean(data[[observed]]))
  mae <- mean(data$ae)
  rmse <- sqrt(mean(data$se))
  rae <- sum(data$ae) / sum(data$aem)
  rse <- sum(data$se) / sum(data$sem)
  rsq <- 1 - rse
  metrics <- c("Mean Absolute Error" = mae,
               "Root Mean Squared Error" = rmse,
               "Relative Absolute Error" = rae,
               "Relative Squared Error" = rse,
               "Coefficient of Determination" = rsq)
  return(metrics)
}
####################################################################################################
## Decision forest modeling
####################################################################################################
set.seed(0)
nTree <- vector("list", num_folds)
maxDepth <- vector("list", num_folds)
mTry <- vector("list", num_folds)
forest_model <- vector("list", num_folds)
forest_metrics <- vector("list", num_folds)
for (i in 1:num_folds) {
  nTree[[i]] <- sample(1:100, 1)
  maxDepth[[i]] <- sample(1:50, 1)
  mTry[[i]] <- sample(1:50, 1)
  # TODO: There is a bug in colClasses for sql compute context
  # As the work around, setting it as local
  # should change it back to sql compute context after it is fixed in RTM
  rxSetComputeContext(local)
  fold_table <- RxSqlServerData(table = paste0("train_fold", i),
                                connectionString = connection_string,
                                colClasses = c(horizon = "integer"))
  forest_model[[i]] <- rxDForest(formula = formula,
                                 data = fold_table,
                                 nTree = nTree[[i]],
                                 maxDepth = maxDepth[[i]],
                                 mTry = mTry[[i]],
                                 seed = 0)
  rxSetComputeContext(local)
  fold_df <- rxImport(fold_table)
  predictions <- rxPredict(modelObject = forest_model[[i]],
                           data = fold_df,
                           predVarNames = "Forest_Prediction",
                           overwrite = TRUE)
  fold_df <- cbind(fold_df, predictions)
  forest_metrics[[i]] <- evaluate_model(data = fold_df,
                                        observed = "value",
                                        predicted = "Forest_Prediction")
  forest_metrics[[i]] <- c("Number of Trees" = nTree[[i]],
                           "Max Depth" = maxDepth[[i]],
                           "Number of Variables" = mTry[[i]],
                           forest_metrics[[i]])
}

forest_metrics <- as.data.frame(do.call(rbind, forest_metrics))

forest_sweep_table <- RxSqlServerData(table = "forest_sweep",
                                       connectionString = connection_string)
rxDataStep(inData = forest_metrics,
           outFile = forest_sweep_table,
           overwrite = TRUE)

index <- which(forest_metrics$`Root Mean Squared Error` ==
                 min(forest_metrics$`Root Mean Squared Error`))

trained_model <- data.frame(model = as.raw(serialize(forest_model[[index]], connection = NULL)));'
, @input_data_1 = @inquery
, @output_data_1_name = N'trained_model'
, @params = N'@connection_string varchar(300), @num_folds int'
, @connection_string = @connectionString
, @num_folds = @num_folds
END
GO