mirror of
https://github.com/Microsoft/sql-server-samples.git
synced 2025-12-08 14:58:54 +00:00
Merge pull request #259 from ZhouFang928/master
Upload retail precision marketing sqlr demo
This commit is contained in:
Umachandar Jayachandran
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,11 @@
|
||||
**List of data sets**
|
||||
|
||||
| Data Set Name | Link to the Full Data Set | Full Data Set Size (MB) | Link to Report |
|
||||
| ---:| ---: | ---: | ---: |
|
||||
| CDNOW_master.csv | [link](https://github.com/ZhouFang928/sql-server-samples/blob/master/samples/features/r-services/Retail%20Precision%20Marketing/Data/CDNOW_master.csv) | 1.55MB | N/A|
|
||||
|
||||
**Description of data sets**
|
||||
|
||||
* The CDNOW data contains the entire purchase history up to the end of June 1998 of the cohort of 23,570 individuals who made their first-ever purchase at CDNOW in the first quarter of 1997. This CDNOW dataset was first used by Fader and Hardie (2001). Each record in this file, 69,659 in total, comprises four fields: the customer's ID, the date of the transaction, the number of CDs purchased, and the dollar value of the transaction.
|
||||
|
||||
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 276 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 678 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 122 KiB |
BIN
Binary file not shown.
@@ -0,0 +1,237 @@
|
||||
#############################################################
|
||||
# Title : CRM Demo in-memory
|
||||
# Author: Microsoft
|
||||
# Date: Dec, 2015
|
||||
#############################################################
|
||||
|
||||
# Install package
|
||||
|
||||
install.packages("rmarkdown")
|
||||
install.packages("fpc")
|
||||
|
||||
# Set directory
|
||||
|
||||
wd <- getwd()
|
||||
data.path <- file.path(wd, "Data", "CDNOW_master.csv")
|
||||
|
||||
# Connect to SQL database using ODBC and read data from SQL via Open Source R
|
||||
|
||||
library(RODBC)
|
||||
getSqlTypeInfo()
|
||||
|
||||
# Connect from local PC
|
||||
|
||||
channel <- odbcDriverConnect("driver={SQL Server Native Client 11.0};
|
||||
server=tcp:sqlserver2012-81yms1ai.cloudapp.net,57500;
|
||||
database=RREDemoSql;
|
||||
uid=******;
|
||||
pwd=******;")
|
||||
|
||||
df <- sqlFetch(channel, 'CDNOW')
|
||||
df <- sqlQuery(channel, paste("select * from dbo.CDNOW"))
|
||||
|
||||
df$Date<-as.Date(df$Date)
|
||||
|
||||
str(df)
|
||||
head(df)
|
||||
|
||||
# Remove the rows with the duplicated IDs to see how many customers in total
|
||||
|
||||
uid <- df[!duplicated(df[,"ID"]), ]
|
||||
|
||||
dim(uid)
|
||||
|
||||
# Step 1: RFM analysis
|
||||
|
||||
# Call RFM source code
|
||||
|
||||
source(wd, "R", "RFM_Analysis_R_Source_Codes_V1.3.R")
|
||||
|
||||
# Set the startDate and endDate, we will only analysis the records in this date range
|
||||
|
||||
startDate <- as.Date("19970101","%Y%m%d")
|
||||
endDate <- as.Date("19980701","%Y%m%d")
|
||||
|
||||
# Calculate RFM value
|
||||
|
||||
df <- getDataFrame(df, startDate, endDate, tIDColName="ID", tDateColName="Date", tAmountColName="Amount")
|
||||
|
||||
head(df)
|
||||
|
||||
# Obtain independent RFM score
|
||||
|
||||
df1 <-getIndependentScore(df)
|
||||
|
||||
head(df1)
|
||||
|
||||
# Draw the histograms in the R, F, and M dimensions
|
||||
|
||||
drawHistograms(df1)
|
||||
|
||||
S500 <- df1[df1$Total_Score > 500, ]
|
||||
dim(S500)
|
||||
|
||||
S400 <- df1[df1$Total_Score > 400, ]
|
||||
dim(S400)
|
||||
|
||||
# Obtain RFM score with breaks
|
||||
# Take a look at the distribution of R, F, M
|
||||
|
||||
par(mfrow = c(1,3))
|
||||
hist(df$Recency)
|
||||
hist(df$Frequency)
|
||||
hist(df$Monetary)
|
||||
|
||||
# Set the Recency ranges as 0-120 days, 120-240 days, 240-450 days, 450-500 days, and more than 500 days.
|
||||
|
||||
r <- c(120, 240, 450, 500)
|
||||
|
||||
# Set the Frequency ranges as 0-2 times, 2-5 times, 5-8 times, 8-10 times, and more than 10 times.
|
||||
|
||||
f <- c(2, 5, 8, 10)
|
||||
|
||||
# Set the Monetary ranges as 0-10 dollars, 10-20 dollars, and so on.
|
||||
|
||||
m <-c(10,20,30,100)
|
||||
|
||||
# Calculate RFM score with breaks
|
||||
|
||||
df2 <- getScoreWithBreaks(df, r, f, m)
|
||||
drawHistograms(df2)
|
||||
|
||||
S500 <- df2[df2$Total_Score > 500, ]
|
||||
dim(S500)
|
||||
|
||||
S400 <- df2[df2$Total_Score > 400, ]
|
||||
dim(S400)
|
||||
|
||||
target <- df2[df2$Total_Score >= 441,]
|
||||
dim(target)
|
||||
|
||||
# Obtain RFM scores with quantiles as breaks
|
||||
|
||||
r <-c(cutpoint(df$Recency))
|
||||
f <-c(cutpoint(df$Frequency))
|
||||
m <-c(cutpoint(df$Monetary))
|
||||
|
||||
df3 <- getScoreWithBreaks(df, r, f, m)
|
||||
|
||||
str(df3)
|
||||
head(df3)
|
||||
tail(df3)
|
||||
|
||||
RFM_Result <- subset(df3,
|
||||
select=c("ID", "Recency", "Frequency", "Monetary",
|
||||
"R_Score", "F_Score", "M_Score", "Total_Score"))
|
||||
|
||||
colnames(RFM_Result) <- c("ID", "R", "F", "M", "R_Score", "F_Score", "M_Score", "Total_Score")
|
||||
|
||||
head(RFM_Result)
|
||||
|
||||
time <- system.time({
|
||||
|
||||
sqlSave(channel,
|
||||
RFM_Result,
|
||||
rownames=FALSE,
|
||||
append=FALSE,
|
||||
varTypes=list(numeric="float",
|
||||
integer="int"))
|
||||
})
|
||||
|
||||
sqlUpdate(channel, df)
|
||||
odbcClose(channel)
|
||||
|
||||
# Clustering using RFM
|
||||
|
||||
library(fpc)
|
||||
library(cluster)
|
||||
|
||||
# Kmeans clustering with number of cluster equal to 8
|
||||
|
||||
cl.fit1 <- kmeans(RFM_Result[, 2:8],
|
||||
centers=8,
|
||||
iter.max=10,
|
||||
nstart=1)
|
||||
|
||||
cl.fit2 <- kmeans(RFM_Result[, 2:8],
|
||||
centers=8,
|
||||
iter.max=20,
|
||||
nstart=200)
|
||||
|
||||
summary(cl.fit1)
|
||||
|
||||
cluster<-cl.fit1$cluster
|
||||
centers<-cl.fit1$centers
|
||||
size<-cl.fit1$size
|
||||
|
||||
plot(RFM_Result[, 2:4], col=cl.fit1$cluster)
|
||||
title(main="K-means",line=3)
|
||||
|
||||
# Classification using RFM
|
||||
|
||||
# Create IsVIP variable
|
||||
|
||||
IsVIP <- ifelse(RFM_Result[,'Total_Score'] >= 441, 1, 0)
|
||||
Cluster <- cl.fit1$cluster
|
||||
RFMVIPCluster <- cbind(RFM_Result, IsVIP, Cluster)
|
||||
|
||||
# Create training/testing data set
|
||||
|
||||
RD <- sample(1:10, dim(RFMVIPCluster)[1], replace=TRUE)
|
||||
|
||||
str(RD)
|
||||
table(RD)
|
||||
|
||||
RFMVIPCluster$RD <- RD;
|
||||
|
||||
urv <- factor(ifelse(RD <= 8,'TRAIN','TEST'))
|
||||
TrainTest <- cbind(RFMVIPCluster, urv)
|
||||
Train <- TrainTest[which(TrainTest$urv == "TRAIN"), ]
|
||||
Test <- TrainTest[which(TrainTest$urv == "TEST"), ]
|
||||
|
||||
# Logistic model
|
||||
# Build our Logistic Regression Model with IsVIP as response
|
||||
|
||||
r1 <- glm(IsVIP~R+F+M, data=Train, family = binomial)
|
||||
summary(r1)
|
||||
|
||||
p1 <- predict.glm(r1, data=Test, type="response")
|
||||
head(p1)
|
||||
tail(p1)
|
||||
|
||||
# Decision tree
|
||||
# Grow tree
|
||||
|
||||
fit <- rpart(Cluster~R+F+M,
|
||||
method="class",
|
||||
data=Train)
|
||||
|
||||
# Display the results
|
||||
|
||||
printcp(fit)
|
||||
|
||||
# Visualize cross-validation results
|
||||
|
||||
plotcp(fit)
|
||||
|
||||
# Detailed summary of splits
|
||||
|
||||
summary(fit)
|
||||
|
||||
# Plot tree
|
||||
|
||||
library(rpart)
|
||||
|
||||
plot(fit, uniform=TRUE, main="Classification Tree for CDNOW")
|
||||
text(fit, use.n=TRUE, all=TRUE, cex=.8)
|
||||
|
||||
# Prune the tree
|
||||
|
||||
pfit <- prune(fit, cp=fit$cptable[which.min(fit$cptable[,"xerror"]), "CP"])
|
||||
|
||||
# Plot the pruned tree
|
||||
|
||||
plot(pfit, uniform=TRUE,
|
||||
main="Pruned Classification Tree for CDNOW")
|
||||
text(pfit, use.n=TRUE, all=TRUE, cex=.8)
|
||||
|
||||
@@ -0,0 +1,208 @@
|
||||
################################################################
|
||||
# Title: CRM Demo in-SQL
|
||||
# Author: Microsoft
|
||||
# Date: Dec, 2015
|
||||
#################################################################
|
||||
|
||||
# Specify connection string and compute context
|
||||
|
||||
connectionString <- "Driver=SQL Server;
|
||||
Server=tcp:192.168.176.130,1433;
|
||||
Database=sqlr;
|
||||
Uid=******;
|
||||
Pwd=******"
|
||||
|
||||
RFMData <- RxSqlServerData(connectionString=connectionString,
|
||||
table="RFM_Result")
|
||||
|
||||
cc <- RxInSqlServer(connectionString=connectionString,
|
||||
autoCleanup=FALSE,
|
||||
consoleOutput=TRUE)
|
||||
|
||||
rxSetComputeContext(cc)
|
||||
|
||||
rxGetInfo(RFMData, getVarInfo=T, numRows=3)
|
||||
|
||||
# Step 1: RFM analysis
|
||||
|
||||
# Visualize the RFM values
|
||||
|
||||
rxHistogram(~R, data=RFMData, xNumTicks=20)
|
||||
rxHistogram(~F, data=RFMData, rowSelection=F < 30, xNumTicks=20)
|
||||
rxHistogram(~M, data=RFMData, rowSelection=M < 200, xNumTicks=20)
|
||||
|
||||
# Count frequency of each RFMscore Level
|
||||
|
||||
tmp <- rxCube(~F(Toltal_Score), data=RFMData)
|
||||
results <- rxResultsDF(tmp)
|
||||
results <- results[results$Counts != 0, ]
|
||||
results[order(results$Counts, decreasing=TRUE), ]
|
||||
|
||||
# Step 2: K-means Clustering
|
||||
|
||||
KmeansData <- RxSqlServerData(connectionString=connectionString,
|
||||
table = "Kmeans_Result")
|
||||
|
||||
md.km <- rxKmeans(formula=~R+F+M+R_Score+F_Score+M_Score,
|
||||
data=RFMData,
|
||||
outFile=KmeansData,
|
||||
numClusters=8,
|
||||
algorithm="lloyd",
|
||||
writeModelVars=TRUE,
|
||||
overwrite=TRUE)
|
||||
|
||||
rxGetInfo(KmeansData, getVarInfo=TRUE, numRows=10)
|
||||
|
||||
centers <- round(md.km$centers, digits=2)
|
||||
size <- md.km$size
|
||||
centers.txt <- file.path(output.path, "centers.txt")
|
||||
write.table(centers, file=centers.txt, sep=" ")
|
||||
size.txt <- file.path(output.path, "size.txt")
|
||||
write.table(size, file=size.txt, sep=" ")
|
||||
|
||||
# Connect to SQL database via odbcConnect
|
||||
|
||||
library(RODBC)
|
||||
|
||||
channel<-odbcDriverConnect(connection=connectionString)
|
||||
|
||||
# Read Kmeans_Result from SQL via OSR
|
||||
|
||||
Kmeans.df <- sqlQuery(channel, paste("select * from dbo.Kmeans_Result"))
|
||||
|
||||
head(Kmeans.df)
|
||||
plot(Kmeans.df[, 2:4], col=Kmeans.df$X_rxCluster)
|
||||
title(main="RFM-based K-means on CDNOW Data", line=3)
|
||||
|
||||
# Step 3: Prediction-logistic and decision tree
|
||||
|
||||
# Create IsVIP variable
|
||||
|
||||
RFMVIPData <- RxSqlServerData(connectionString=connectionString,
|
||||
table="RFMVIP")
|
||||
|
||||
rxDataStep(inData=RFMData,
|
||||
outFile=RFMVIPData,
|
||||
transforms=list(IsVIP=ifelse(Toltal_Score >= 441, 1, 0)),
|
||||
overwrite=TRUE,
|
||||
reportProgress=1)
|
||||
|
||||
rxGetInfo(RFMVIPData, getVarInfo=T, numRows=3)
|
||||
rxGetInfo(RFMVIPRDData, getVarInfo=T, numRows=3)
|
||||
|
||||
RFMVIPRDData <- RxSqlServerData(connectionString=connectionString,
|
||||
table="RFMVIPRD")
|
||||
|
||||
RFMVIPTrainTestData <- RxSqlServerData(connectionString = connectionString,
|
||||
table="RFMVIPTrainTest")
|
||||
|
||||
rxDataStep(inData=RFMVIPRDData,
|
||||
outFile=RFMVIPTrainTestData,
|
||||
transforms=list(urv=factor(ifelse(RD <= 8,'TRAIN','TEST'))),
|
||||
overwrite=T)
|
||||
|
||||
rxGetInfo(RFMVIPTrainTestData, T, numRows=3)
|
||||
|
||||
## Split data into training/testing data set
|
||||
|
||||
TrainData <- RxSqlServerData(connectionString=connectionString,
|
||||
table = "RFMVIPTrainTest.urv.TRAIN")
|
||||
|
||||
TestData <- RxSqlServerData(connectionString=connectionString,
|
||||
table="RFMVIPTrainTest.urv.TEST")
|
||||
|
||||
rxSplit(RFMVIPTrainTestData, outFilesBase=RFMVIPTrainTestData,
|
||||
splitByFactor='urv', overwrite=T, reportProgress=1)
|
||||
|
||||
## Built our Logistic Regression Model with IsVIP as response
|
||||
|
||||
r1<- rxLogit(IsVIP~R+F+M,
|
||||
data =RFMVIPData,
|
||||
variableSelection = rxStepControl(method="stepwise",
|
||||
scope = ~ R+F+M))
|
||||
summary(r1)
|
||||
|
||||
## r1:stepwise selection shows that Monetary, Recency are significant.
|
||||
## Build our Logistic Regression Model
|
||||
|
||||
r2 <- rxLogit(IsVIP~R+F,
|
||||
data=RFMVIPData, covCoef=TRUE)
|
||||
summary(r2)
|
||||
|
||||
## Predict our Logistic Model on our test Dataset
|
||||
|
||||
LogisticPred.xdf <- file.path(output.path,"LogisticPred.xdf")
|
||||
p2 <- rxPredict(r2, data=test.xdf, outData=LogisticPred.xdf,
|
||||
writeModelVars=TRUE, extraVarsToWrite="ID",
|
||||
computeResiduals=TRUE, computeStdErr=TRUE,
|
||||
interval="confidence", predVarNames='LogitPredict',
|
||||
overwrite=TRUE)
|
||||
|
||||
rxGetInfo(LogisticPred.xdf, getVarInfo=T, numRows=10)
|
||||
LogisticPredInfoTop10 <- rxGetInfo(LogisticPred.xdf, getVarInfo=T, numRows=10)
|
||||
LogisticPredInfoTop10.txt <- file.path(output.path, "LogisticPredInfoTop10.txt")
|
||||
write.table(LogisticPredInfoTop10$data, file=LogisticPredInfoTop10.txt, sep=" ")
|
||||
|
||||
## Draw a ROC curve
|
||||
|
||||
rxRocCurve(actualVarName='IsVIP',predVarNames='LogitPredict',data=LogisticPred.xdf)
|
||||
|
||||
## Build a Decision Tree with Cluster as response
|
||||
|
||||
d1 <- rxDTree(Cluster~R+F+M, data=TrainData, blocksPerRead=5)
|
||||
d1 <- rxDTree(Cluster~R_Score+F_Score+M_Score, data=TrainData, blocksPerRead=5)
|
||||
d1
|
||||
d1Cp<- rxDTreeBestCp(d1)
|
||||
d1 <- prune.rxDTree(d1, cp=d1Cp)
|
||||
d2 <- rxDTree(Cluster~R+F+M, data=TrainData, pruneCp="auto")
|
||||
d2 <- rxDTree(Cluster~R_Score+F_Score+M_Score, data=TrainData, pruneCp="auto")
|
||||
d2
|
||||
|
||||
# View Decision Tree
|
||||
|
||||
# View 1
|
||||
|
||||
library(RevoTreeView)
|
||||
|
||||
plot(createTreeView(d1))
|
||||
plot(createTreeView(d2))
|
||||
|
||||
# View 2
|
||||
|
||||
library(rpart)
|
||||
|
||||
plot(rxAddInheritance(d1))
|
||||
text(rxAddInheritance(d1))
|
||||
title(main="RFM-based Decision Tree on CDNOW Data",line=3)
|
||||
|
||||
plot(rxAddInheritance(d2))
|
||||
text(rxAddInheritance(d2))
|
||||
title(main="RFM-based Decision Tree on CDNOW Data",line=3)
|
||||
|
||||
# Prediction
|
||||
|
||||
DTreePred.xdf<-file.path(output.path,"DTreePred.xdf")
|
||||
rxPredict(d1, data=test.xdf, outData=DTreePred.xdf,
|
||||
writeModelVars=TRUE, extraVarsToWrite="ID",
|
||||
computeResiduals=T, overwrite=TRUE)
|
||||
|
||||
rxGetInfo(DTreePred.xdf, getVarInfo=T, numRows=3)
|
||||
|
||||
DTreePredInfoTop10 <- rxGetInfo(DTreePred.xdf, getVarInfo=T, numRows=10)
|
||||
DTreePredInfoTop10.txt <- file.path(output.path, "DTreePredInfoTop10.txt")
|
||||
write.table(DTreePredInfoTop10$data, file=DTreePredInfoTop10.txt, sep=" ")
|
||||
|
||||
DTreePred <- rxXdfToDataFrame(file=DTreePred.xdf)
|
||||
|
||||
sqlSave(channel, DTreePred, rownames=FALSE, append=FALSE,
|
||||
varTypes=list(numeric="float",
|
||||
integer="int",
|
||||
Date="date"))
|
||||
odbcClose(channel)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
+307
@@ -0,0 +1,307 @@
|
||||
###############################################################################
|
||||
#Description: A set of R functions to implement the Independent RFM scoring and the RFM scoring with input breaks.
|
||||
#Author: Jack Han http://www.DataApple.net email: jackhan2008 # qq.com
|
||||
#Version: 1.3
|
||||
#Date: 23 Dec 2013
|
||||
#Usage: Read the article "RFM Customer Analysis with R Language" http://www.dataapple.net/?p=84
|
||||
################################################################################
|
||||
|
||||
|
||||
################################################################################
|
||||
# Function
|
||||
# getDataFrame(df,startDate,endDate,tIDColName="ID",tDateColName="Date",tAmountColName="Amount")
|
||||
#
|
||||
# Description
|
||||
# Process the input data frame of transcation records so that the data frame can be ready for RFM scoring.
|
||||
# A.Remove the duplicate records with the same customer ID
|
||||
# B.Find the most recent date for each ID and calculate the days to the endDate, to get the Recency data
|
||||
# C.Calculate the quantity of translations of a customer, to get the Frequency data
|
||||
# D.Sum the amount of money a customer spent and divide it by Frequency, to get the average amount per transaction, that is the Monetary data.
|
||||
#
|
||||
# Arguments
|
||||
# df - A data frame of transcation records with customer ID, dates, and the amount of money of each transation
|
||||
# startDate - the start date of transcation, the records that happened after the start date will be kepted
|
||||
# endDate - the end date of transcation, the records that happed after the end date will be removed. It works with the start date to set a time scope
|
||||
# tIDColName - the column name which contains customer IDs in the input data frame
|
||||
# tDateColName - the column name which contains transcation dates in the input data frame
|
||||
# tAmountColName - the column name which contains the amount of money of each transcation in the input data frame
|
||||
#
|
||||
# Return Value
|
||||
# Returns a new data frame with three new columns of "Recency","Frequency", and "Monetary". The number in "Recency" is the quantity of days from the # #most recent transcation of a customer to the endDate; The number in the "Frequency" is the quantity of transcations of a customer during the period from # #startDate to endDate; the number in the "Monetary" is the average amount of money per transcation of a customer during that period.
|
||||
#
|
||||
#################################################################################
|
||||
getDataFrame <- function(df,startDate,endDate,tIDColName="ID",tDateColName="Date",tAmountColName="Amount"){
|
||||
|
||||
#order the dataframe by date descendingly
|
||||
df <- df[order(df[,tDateColName],decreasing = TRUE),]
|
||||
|
||||
#remove the record before the start data and after the end Date
|
||||
df <- df[df[,tDateColName]>= startDate,]
|
||||
df <- df[df[,tDateColName]<= endDate,]
|
||||
|
||||
#remove the rows with the duplicated IDs, and assign the df to a new df.
|
||||
newdf <- df[!duplicated(df[,tIDColName]),]
|
||||
|
||||
# caculate the Recency(days) to the endDate, the smaller days value means more recent
|
||||
Recency<-as.numeric(difftime(endDate,newdf[,tDateColName],units="days"))
|
||||
|
||||
# add the Days column to the newdf data frame
|
||||
newdf <-cbind(newdf,Recency)
|
||||
|
||||
#order the dataframe by ID to fit the return order of table() and tapply()
|
||||
newdf <- newdf[order(newdf[,tIDColName]),]
|
||||
|
||||
# caculate the frequency
|
||||
fre <- as.data.frame(table(df[,tIDColName]))
|
||||
Frequency <- fre[,2]
|
||||
newdf <- cbind(newdf,Frequency)
|
||||
|
||||
#caculate the Money per deal
|
||||
m <- as.data.frame(tapply(df[,tAmountColName],df[,tIDColName],sum))
|
||||
Monetary <- m[,1]/Frequency
|
||||
newdf <- cbind(newdf,Monetary)
|
||||
|
||||
return(newdf)
|
||||
|
||||
} # end of function getDataFrame
|
||||
|
||||
|
||||
################################################################################
|
||||
# Function
|
||||
# getIndependentScore(df,r=5,f=5,m=5)
|
||||
#
|
||||
# Description
|
||||
# Scoring the Recency, Frequency, and Monetary in r, f, and m in aliquots independently
|
||||
#
|
||||
# Arguments
|
||||
# df - A data frame returned by the function of getDataFrame
|
||||
# r - The highest point of Recency
|
||||
# f - The highest point of Frequency
|
||||
# m - The highest point of Monetary
|
||||
#
|
||||
# Return Value
|
||||
# Returns a new data frame with four new columns of "R_Score","F_Score","M_Score", and "Total_Score".
|
||||
#################################################################################
|
||||
|
||||
getIndependentScore <- function(df,r=5,f=5,m=5) {
|
||||
|
||||
if (r<=0 || f<=0 || m<=0) return
|
||||
|
||||
#order and the score
|
||||
df <- df[order(df$Recency,-df$Frequency,-df$Monetary),]
|
||||
R_Score <- scoring(df,"Recency",r)
|
||||
df <- cbind(df, R_Score)
|
||||
|
||||
df <- df[order(-df$Frequency,df$Recency,-df$Monetary),]
|
||||
F_Score <- scoring(df,"Frequency",f)
|
||||
df <- cbind(df, F_Score)
|
||||
|
||||
df <- df[order(-df$Monetary,df$Recency,-df$Frequency),]
|
||||
M_Score <- scoring(df,"Monetary",m)
|
||||
df <- cbind(df, M_Score)
|
||||
|
||||
#order the dataframe by R_Score, F_Score, and M_Score desc
|
||||
df <- df[order(-df$R_Score,-df$F_Score,-df$M_Score),]
|
||||
|
||||
# caculate the total score
|
||||
Total_Score <- c(100*df$R_Score + 10*df$F_Score+df$M_Score)
|
||||
|
||||
df <- cbind(df,Total_Score)
|
||||
|
||||
return (df)
|
||||
|
||||
} # end of function getIndependentScore
|
||||
|
||||
################################################################################
|
||||
# Function
|
||||
# scoring(df,column,r=5)
|
||||
#
|
||||
# Description
|
||||
# A function to be invoked by the getIndepandentScore function
|
||||
#######################################
|
||||
scoring <- function (df,column,r=5){
|
||||
|
||||
#get the length of rows of df
|
||||
len <- dim(df)[1]
|
||||
|
||||
score <- rep(0,times=len)
|
||||
|
||||
# get the quantity of rows per 1/r e.g. 1/5
|
||||
nr <- round(len / r)
|
||||
if (nr > 0){
|
||||
|
||||
# seperate the rows by r aliquots
|
||||
rStart <-0
|
||||
rEnd <- 0
|
||||
for (i in 1:r){
|
||||
|
||||
#set the start row number and end row number
|
||||
rStart = rEnd+1
|
||||
|
||||
#skip one "i" if the rStart is already in the i+1 or i+2 or ...scope.
|
||||
if (rStart> i*nr) next
|
||||
|
||||
if (i == r){
|
||||
if(rStart<=len ) rEnd <- len else next
|
||||
}else{
|
||||
rEnd <- i*nr
|
||||
}
|
||||
|
||||
# set the Recency score
|
||||
score[rStart:rEnd]<- r-i+1
|
||||
|
||||
# make sure the customer who have the same recency have the same score
|
||||
s <- rEnd+1
|
||||
if(i<r & s <= len){
|
||||
for(u in s: len){
|
||||
if(df[rEnd,column]==df[u,column]){
|
||||
score[u]<- r-i+1
|
||||
rEnd <- u
|
||||
}else{
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
return(score)
|
||||
|
||||
} #end of function Scoring
|
||||
|
||||
|
||||
|
||||
################################################################################
|
||||
# Function
|
||||
# getScoreWithBreaks(df,r,f,m)
|
||||
#
|
||||
# Description
|
||||
# Scoring the Recency, Frequency, and Monetary in r, f, and m which are vector object containing a series of breaks
|
||||
#
|
||||
# Arguments
|
||||
# df - A data frame returned by the function of getDataFrame
|
||||
# r - A vector of Recency breaks
|
||||
# f - A vector of Frequency breaks
|
||||
# m - A vector of Monetary breaks
|
||||
#
|
||||
# Return Value
|
||||
# Returns a new data frame with four new columns of "R_Score","F_Score","M_Score", and "Total_Score".
|
||||
#
|
||||
#################################################################################
|
||||
cutpoint <- function(vec){
|
||||
temp <- as.vector(quantile(vec,probs = c(0,0.2,0.4,0.6,0.8,1.0)))
|
||||
temp[2:5]
|
||||
}
|
||||
|
||||
getScoreWithBreaks <- function(df,r,f,m) {
|
||||
|
||||
## scoring the Recency
|
||||
len = length(r)
|
||||
R_Score <- c(rep(1,length(df[,1])))
|
||||
df <- cbind(df,R_Score)
|
||||
for(i in 1:len){
|
||||
if(i == 1){
|
||||
p1=0
|
||||
}else{
|
||||
p1=r[i-1]
|
||||
}
|
||||
p2=r[i]
|
||||
|
||||
if(dim(df[p1<df$Recency & df$Recency<=p2,])[1]>0) df[p1<df$Recency & df$Recency<=p2,]$R_Score = len - i+ 2
|
||||
}
|
||||
|
||||
## scoring the Frequency
|
||||
len = length(f)
|
||||
F_Score <- c(rep(1,length(df[,1])))
|
||||
df <- cbind(df,F_Score)
|
||||
for(i in 1:len){
|
||||
if(i == 1){
|
||||
p1=0
|
||||
}else{
|
||||
p1=f[i-1]
|
||||
}
|
||||
p2=f[i]
|
||||
|
||||
if(dim(df[p1<df$Frequency & df$Frequency<=p2,])[1]>0) df[p1<df$Frequency & df$Frequency<=p2,]$F_Score = i
|
||||
}
|
||||
if(dim(df[f[len]<df$Frequency,])[1]>0) df[f[len]<df$Frequency,]$F_Score = len+1
|
||||
|
||||
## scoring the Monetary
|
||||
len = length(m)
|
||||
M_Score <- c(rep(1,length(df[,1])))
|
||||
df <- cbind(df,M_Score)
|
||||
for(i in 1:len){
|
||||
if(i == 1){
|
||||
p1=0
|
||||
}else{
|
||||
p1=m[i-1]
|
||||
}
|
||||
p2=m[i]
|
||||
|
||||
if(dim(df[p1<df$Monetary & df$Monetary<=p2,])[1]>0) df[p1<df$Monetary & df$Monetary<=p2,]$M_Score = i
|
||||
}
|
||||
if(dim(df[m[len]<df$Monetary,])[1]>0) df[m[len]<df$Monetary,]$M_Score = len+1
|
||||
|
||||
#order the dataframe by R_Score, F_Score, and M_Score desc
|
||||
df <- df[order(-df$R_Score,-df$F_Score,-df$M_Score),]
|
||||
|
||||
# caculate the total score
|
||||
Total_Score <- c(100*df$R_Score + 10*df$F_Score+df$M_Score)
|
||||
|
||||
df <- cbind(df,Total_Score)
|
||||
|
||||
return(df)
|
||||
|
||||
} # end of function of getScoreWithBreaks
|
||||
|
||||
|
||||
################################################################################
|
||||
# Function
|
||||
# drawHistograms(df,r,f,m)
|
||||
#
|
||||
# Description
|
||||
# Draw the histograms in the R, F, and M dimensions so that we can see the quantity of customers in each RFM block.
|
||||
#
|
||||
# Arguments
|
||||
# df - A data frame returned by the function of getIndependent or getScoreWithBreaks
|
||||
# r - The highest point of Recency
|
||||
# f - The highest point of Frequency
|
||||
# m - The highest point of Monetary
|
||||
#
|
||||
# Return Value
|
||||
# No return value.
|
||||
#
|
||||
#################################################################################
|
||||
drawHistograms <- function(df,r=5,f=5,m=5){
|
||||
|
||||
#set the layout plot window
|
||||
par(mfrow = c(f,r))
|
||||
|
||||
names <-rep("",times=m)
|
||||
for(i in 1:m) names[i]<-paste("M",i)
|
||||
|
||||
|
||||
for (i in 1:f){
|
||||
for (j in 1:r){
|
||||
c <- rep(0,times=m)
|
||||
for(k in 1:m){
|
||||
tmpdf <-df[df$R_Score==j & df$F_Score==i & df$M_Score==k,]
|
||||
c[k]<- dim(tmpdf)[1]
|
||||
|
||||
}
|
||||
if (i==1 & j==1)
|
||||
barplot(c,col="lightblue",names.arg=names)
|
||||
else
|
||||
barplot(c,col="lightblue")
|
||||
if (j==1) title(ylab=paste("F",i))
|
||||
if (i==1) title(main=paste("R",j))
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
par(mfrow = c(1,1))
|
||||
|
||||
} # end of drawHistograms function
|
||||
@@ -0,0 +1,54 @@
|
||||
Data Driven Precision Marketing with SQL Server R Service
|
||||
|
||||
As a data professional, do you wonder how you can leverage data science for creating new value in your organization? In this sample, learn how you can leverage your familiar knowledge on working with databases, and learn how you can get started with doing data science with databases.
|
||||
|
||||
----------
|
||||
|
||||
**Example**
|
||||
|
||||
In retail, tons of data are generated every data, which imply rich information about the whole market.
|
||||
|
||||
To provide market intelligence, the CRM analysis is commonly used to understand customer segmentation, predict customer behavior and better target potential buyers via right recommendation. With growing size of data and higher request on timeliness, it becomes a bit more challenging to do precision marketing on big data in a much more time-efficient way.
|
||||
|
||||
In this demo, we address the issue with Microsoft R Server's parallel computing algorithms and build an end-to-end operationalized analytical system using SQL Server R and Power BI.
|
||||
|
||||
Using a concrete example of customer relationship management for retail, we’ll share how you can jumpstart by
|
||||
|
||||
- Running R scripts using SQL Server as the compute context
|
||||
- Operationalize your R scripts using stored procedures.
|
||||
|
||||
The insights delivered by these models are visualized using a Power BI dashboard.
|
||||
|
||||
----------
|
||||
|
||||
**Pre-requirements**
|
||||
|
||||
You have to do the following set-up before playing with this demo.
|
||||
|
||||
- Install SQL Server 2016 or create a SQL Server 2016 Enterprise VM on Azure with Standalone R Server and R Services installed/configured.
|
||||
- Install R IDE: R Tools for Visual Studio or R Studio.
|
||||
- Install PowerBI Desktop.
|
||||
- Validate the successful installation.
|
||||
|
||||
----------
|
||||
|
||||
**Files**
|
||||
|
||||
This sample consists of the following directory structure.
|
||||
|
||||
- **Data** - This folder contains the CD sales data CDNOW.
|
||||
- **R** - This folder contains the R code that you can run in any R IDE.
|
||||
- **SQL Server** - This folder contains the sql files that you can run to create T-SQL stored procedures (with R code embeded) and try out this precision marketing example.
|
||||
- **PowerBI** - This folder contains a sample PowerBI report.
|
||||
|
||||
To jumpstart, run the T-SQL files (crm_demo.sql)
|
||||
|
||||
**Note**
|
||||
|
||||
This is a demo built on SQL 2016 RC1 in Dec 2015. To try out it, please modify it to fit the new version of SQL Server R Services.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,429 @@
|
||||
--use the database RREDemoSql
|
||||
|
||||
use sqlr;
|
||||
go
|
||||
|
||||
drop procedure if exists get_CDNOW_RFM
|
||||
go
|
||||
|
||||
--create stored procedure to get RFM
|
||||
|
||||
create proc get_CDNOW_RFM (@start datetime = '1900-1-1', @end datetime = '3000-1-1', @now datetime = null)
|
||||
as
|
||||
begin
|
||||
if @now is null
|
||||
set @now = getdate()
|
||||
|
||||
select
|
||||
ID, DATEDIFF(d,R,@now) as R ,F,M
|
||||
from
|
||||
(select
|
||||
ID, MAX([Date]) as R, COUNT(Volume) as F, round(avg(Amount),2) as M
|
||||
from
|
||||
[dbo].[CDNOW]
|
||||
where
|
||||
[Date] BETWEEN @start AND @end
|
||||
group by ID ) as rfm_tmp
|
||||
order by cast (ID as int)
|
||||
end
|
||||
go
|
||||
|
||||
--execute the stored procedure to obtain CDNOWRFM table
|
||||
|
||||
exec dbo.get_CDNOW_RFM @start='1997-1-1',@end='1998-7-1',@now='1998-7-1'
|
||||
go
|
||||
|
||||
drop procedure if exists BreakScoreRFM
|
||||
go
|
||||
|
||||
--create stored procedure to break RFM score
|
||||
|
||||
create proc BreakScoreRFM (@start datetime = '1900-1-1', @end datetime = '3000-1-1', @now datetime = null,
|
||||
@r_cut varchar(254) = null, @f_cut varchar(254) = null, @m_cut varchar(254) = null)
|
||||
as
|
||||
begin
|
||||
if @now is null
|
||||
set @now = getdate()
|
||||
|
||||
declare @r_cut1 float = 100, @r_cut2 float = 200, @r_cut3 float = 300, @r_cut4 float = 400
|
||||
declare @f_cut1 float = 100, @f_cut2 float = 200, @f_cut3 float = 300, @f_cut4 float = 400
|
||||
declare @m_cut1 float = 100, @m_cut2 float = 200, @m_cut3 float = 300, @m_cut4 float = 400
|
||||
declare @idx int = 0, @len int = 0
|
||||
--get cut parameter, should add more code to check cut parameter.
|
||||
if(@r_cut is not null) -- and @r_cut follow the syntax
|
||||
begin
|
||||
set @idx = CHARINDEX('-',@r_cut)
|
||||
set @len = len(@r_cut)
|
||||
set @r_cut1 = substring(@r_cut,1,@idx-1)
|
||||
set @r_cut=substring(@r_cut,@idx+1,@len-@idx)
|
||||
|
||||
set @idx = CHARINDEX('-',@r_cut)
|
||||
set @len = len(@r_cut)
|
||||
set @r_cut2 = substring(@r_cut,1,@idx-1)
|
||||
set @r_cut=substring(@r_cut,@idx+1,@len-@idx)
|
||||
|
||||
set @idx = CHARINDEX('-',@r_cut)
|
||||
set @len = len(@r_cut)
|
||||
set @r_cut3 = substring(@r_cut,1,@idx-1)
|
||||
set @r_cut4=substring(@r_cut,@idx+1,@len-@idx)
|
||||
end
|
||||
|
||||
if(@f_cut is not null) -- and @f_cut follow the syntax
|
||||
begin
|
||||
set @idx = CHARINDEX('-',@f_cut)
|
||||
set @len = len(@f_cut)
|
||||
set @f_cut1 = substring(@f_cut,1,@idx-1)
|
||||
set @f_cut=substring(@f_cut,@idx+1,@len-@idx)
|
||||
|
||||
set @idx = CHARINDEX('-',@f_cut)
|
||||
set @len = len(@f_cut)
|
||||
set @f_cut2 = substring(@f_cut,1,@idx-1)
|
||||
set @f_cut=substring(@f_cut,@idx+1,@len-@idx)
|
||||
|
||||
set @idx = CHARINDEX('-',@f_cut)
|
||||
set @len = len(@f_cut)
|
||||
set @f_cut3 = substring(@f_cut,1,@idx-1)
|
||||
set @f_cut4=substring(@f_cut,@idx+1,@len-@idx)
|
||||
end
|
||||
|
||||
if(@m_cut is not null) -- and @m_cut follow the syntax
|
||||
begin
|
||||
set @idx = CHARINDEX('-',@m_cut)
|
||||
set @len = len(@m_cut)
|
||||
set @m_cut1 = substring(@m_cut,1,@idx-1)
|
||||
set @m_cut=substring(@m_cut,@idx+1,@len-@idx)
|
||||
|
||||
set @idx = CHARINDEX('-',@m_cut)
|
||||
set @len = len(@m_cut)
|
||||
set @m_cut2 = substring(@m_cut,1,@idx-1)
|
||||
set @m_cut=substring(@m_cut,@idx+1,@len-@idx)
|
||||
|
||||
set @idx = CHARINDEX('-',@m_cut)
|
||||
set @len = len(@m_cut)
|
||||
set @m_cut3 = substring(@m_cut,1,@idx-1)
|
||||
set @m_cut4=substring(@m_cut,@idx+1,@len-@idx)
|
||||
end
|
||||
|
||||
--drop exists tmp tables.
|
||||
if exists (select 1 from sys.tables where [object_id] =object_id('RFM_Score') and type= 'U')
|
||||
begin
|
||||
truncate table RFM_Score
|
||||
drop table RFM_Score
|
||||
end
|
||||
|
||||
if exists (select 1 from sys.tables where [object_id] =object_id('RFM') and type= 'U')
|
||||
begin
|
||||
truncate table RFM
|
||||
drop table RFM
|
||||
end
|
||||
-- get RFM table from initial data.
|
||||
select
|
||||
ID, DATEDIFF(d,R,@now) as R, F, M into RFM
|
||||
from
|
||||
(select
|
||||
ID, max([Date]) as R, count(Volume) as F, round(avg(Amount),2) as M
|
||||
from
|
||||
CDNOW
|
||||
where
|
||||
[Date] between @start and @end
|
||||
group by ID ) as rfm_tmp
|
||||
order by cast (ID as int)
|
||||
|
||||
-- record R_Score at temp table '#R'
|
||||
select
|
||||
ID,
|
||||
case when R <= @r_cut1 then 5
|
||||
when R > @r_cut1 and R <= @r_cut2 then 4
|
||||
when R > @r_cut2 and R <= @r_cut3 then 3
|
||||
when R > @r_cut3 and R <= @r_cut4 then 2
|
||||
when R > @r_cut4 then 1
|
||||
else 0
|
||||
end as R_Score
|
||||
into #R
|
||||
from RFM
|
||||
|
||||
-- score F
|
||||
select
|
||||
ID,
|
||||
case when F >= @f_cut4 then 5
|
||||
when F > @f_cut3 and F <= @f_cut4 then 4
|
||||
when F > @f_cut2 and F <= @f_cut3 then 3
|
||||
when F > @f_cut3 and F <= @f_cut4 then 2
|
||||
when F < @f_cut4 then 1
|
||||
else 0
|
||||
end as F_Score
|
||||
into #F
|
||||
from RFM
|
||||
|
||||
-- score M
|
||||
select
|
||||
ID,
|
||||
case when M >= @m_cut4 then 5
|
||||
when M > @m_cut3 and M <= @m_cut4 then 4
|
||||
when M > @m_cut2 and M <= @m_cut3 then 3
|
||||
when M > @m_cut3 and M <= @m_cut4 then 2
|
||||
when M < @m_cut4 then 1
|
||||
else 0
|
||||
end as M_Score
|
||||
into #M
|
||||
from RFM
|
||||
|
||||
--union all
|
||||
select #R.ID, R_Score, F_Score, M_Score, R_Score*100 + F_Score*10 + M_Score as Toltal_Score
|
||||
into RFM_Score
|
||||
from #R, #F, #M
|
||||
where #R.ID = #F.ID and #R.ID = #M.ID
|
||||
|
||||
select * from RFM_Score order by Toltal_Score desc,ID
|
||||
end
|
||||
|
||||
go
|
||||
|
||||
--execute the stored procedure to obtain RFM_Score table
|
||||
|
||||
exec dbo.BreakScoreRFM @start ='1997-1-1', @end = '1998-7-1' ,@now = '1998-7-1', @r_cut ='142-433-486-513', @f_cut = '1-1-2-4', @m_cut ='14.37-20.25-29.37-44.29'
|
||||
go
|
||||
|
||||
--combine RFM and RFM_Score
|
||||
|
||||
drop table RFM_Result;
|
||||
select a.*, b.R_Score, b.F_Score, b.M_Score, b.Toltal_Score
|
||||
into RFM_Result
|
||||
from
|
||||
[dbo].[RFM] a left outer join
|
||||
[dbo].[RFM_Score] b on
|
||||
a.[ID] = b.[ID];
|
||||
select top 10 * from RFM_Result;
|
||||
|
||||
--create stored procedure to visualize RFM
|
||||
|
||||
drop procedure if exists visualizeRFM;
|
||||
go
|
||||
create procedure visualizeRFM
|
||||
as
|
||||
begin
|
||||
execute sp_execute_external_script
|
||||
@language = N'R'
|
||||
, @script = N'
|
||||
drawHistograms <- function(df,r=5,f=5,m=5){
|
||||
#set the layout plot window
|
||||
par(mfrow = c(f,r))
|
||||
names <-rep("",times=m)
|
||||
for(i in 1:m) names[i]<-paste("M",i)
|
||||
for (i in 1:f){
|
||||
for (j in 1:r){
|
||||
c <- rep(0,times=m)
|
||||
for(k in 1:m){
|
||||
tmpdf <-df[df$R_Score==j & df$F_Score==i & df$M_Score==k,]
|
||||
c[k]<- dim(tmpdf)[1]
|
||||
}
|
||||
if (i==1 & j==1)
|
||||
barplot(c,col="lightblue",names.arg=names)
|
||||
else
|
||||
barplot(c,col="lightblue")
|
||||
if (j==1) title(ylab=paste("F",i))
|
||||
if (i==1) title(main=paste("R",j))
|
||||
}
|
||||
}
|
||||
par(mfrow = c(1,1))
|
||||
}
|
||||
RFMhist<-drawHistograms(RFM_Result[,1:4])
|
||||
ff= tempfile()
|
||||
png(filename=ff, width=620, height=240)
|
||||
print(RFMhist)
|
||||
dev.off()
|
||||
OutputDataSet <- data.frame(data=readBin(file(ff, "rb"), what=raw(), n=1e6));
|
||||
'
|
||||
, @input_data_1 = N'select "R", "F", "M" from RFM_Result'
|
||||
, @input_data_1_name = N'RFM_Result'
|
||||
with result sets ((plot varbinary(max)));
|
||||
end;
|
||||
go
|
||||
grant execute on visualizeRFM to rdemo;
|
||||
go
|
||||
|
||||
--clustering based on RFM
|
||||
|
||||
drop table if exists Kmeans_Result;
|
||||
drop table if exists CDNOW_rx_models;
|
||||
go
|
||||
create table CDNOW_rx_models(
|
||||
model_name varchar(30) not null default('default model') primary key,
|
||||
model varbinary(max) not null
|
||||
);
|
||||
go
|
||||
|
||||
create table Kmeans_Result (
|
||||
"X_rxCluster" int null
|
||||
, "R" int null, "F" int null, "M" float null
|
||||
, "R_Score" int null, "F_Score" int null, "M_Score" int null
|
||||
);
|
||||
go
|
||||
|
||||
--create stored procedure to do clustering
|
||||
|
||||
drop procedure if exists generate_CDNOW_rx_Kmeans;
|
||||
go
|
||||
create procedure generate_CDNOW_rx_Kmeans
|
||||
as
|
||||
begin
|
||||
execute sp_execute_external_script
|
||||
@language = N'R'
|
||||
, @script = N'
|
||||
require("RevoScaleR");
|
||||
CDNOWKmeans <- rxKmeans(formula=~R+F+M+R_Score+F_Score+M_Score,
|
||||
data=RFM_Result,
|
||||
#outFile=Kmeans_Result,
|
||||
numClusters=8,
|
||||
algorithm="lloyd",
|
||||
writeModelVars=TRUE,
|
||||
overwrite=TRUE)
|
||||
rxKmeans_model <- data.frame(payload=as.raw(serialize(CDNOWKmeans, connection=NULL)));
|
||||
'
|
||||
, @input_data_1 = N'select * from RFM_Result'
|
||||
, @input_data_1_name = N'RFM_Result'
|
||||
, @output_data_1_name = N'rxKmeans_model'
|
||||
with result sets ((model varbinary(max)));
|
||||
end;
|
||||
go
|
||||
|
||||
--how to write Kmeans_Result back to database?[To Be Modified]
|
||||
|
||||
insert into CDNOW_rx_models (model)
|
||||
exec generate_CDNOW_rx_Kmeans;
|
||||
update CDNOW_rx_models set model_name = 'rxKmeans' where model_name = 'default model';
|
||||
select * from CDNOW_rx_models;
|
||||
go
|
||||
|
||||
--create stored procedure to build logistic regression model
|
||||
|
||||
drop procedure if exists generate_CDNOW_rx_Logit;
|
||||
go
|
||||
create procedure generate_CDNOW_rx_Logit
|
||||
as
|
||||
begin
|
||||
execute sp_execute_external_script
|
||||
@language = N'R'
|
||||
, @script = N'
|
||||
require("RevoScaleR");
|
||||
CDNOWLogit <- rxLogit(IsVIP~R+F+M,
|
||||
data=RFMVIPCluster,
|
||||
variableSelection=rxStepControl(method="stepwise",
|
||||
scope=~R+F+M))
|
||||
summary(CDNOWLogit)
|
||||
rxLogit_model <- data.frame(payload = as.raw(serialize(CDNOWLogit, connection=NULL)));
|
||||
'
|
||||
, @input_data_1 = N'select * from RFMVIPCluster'
|
||||
, @input_data_1_name = N'RFMVIPCluster'
|
||||
, @output_data_1_name = N'rxLogit_model'
|
||||
with result sets ((model varbinary(max)));
|
||||
end;
|
||||
go
|
||||
|
||||
insert into CDNOW_rx_models (model)
|
||||
exec generate_CDNOW_rx_Logit;
|
||||
update CDNOW_rx_models set model_name = 'rxLogit' where model_name = 'default model';
|
||||
select * from CDNOW_rx_models;
|
||||
go
|
||||
|
||||
--create stored procedure to build decision tree model
|
||||
|
||||
drop procedure if exists generate_CDNOW_rx_Dtree;
|
||||
go
|
||||
create procedure generate_CDNOW_rx_Dtree
|
||||
as
|
||||
begin
|
||||
execute sp_execute_external_script
|
||||
@language = N'R'
|
||||
, @script = N'
|
||||
require("RevoScaleR");
|
||||
CDNOWDtree <- rxDTree(Cluster~R+F+M, data=RFMVIPCluster, pruneCp="auto")
|
||||
rxDtree_model <- data.frame(payload=as.raw(serialize(CDNOWDtree, connection=NULL)));
|
||||
'
|
||||
, @input_data_1 = N'select * from RFMVIPCluster'
|
||||
, @input_data_1_name = N'RFMVIPCluster'
|
||||
, @output_data_1_name = N'rxDtree_model'
|
||||
with result sets ((model varbinary(max)));
|
||||
end;
|
||||
go
|
||||
|
||||
insert into CDNOW_rx_models (model)
|
||||
exec generate_CDNOW_rx_Dtree;
|
||||
update CDNOW_rx_models set model_name = 'rxDtree' where model_name = 'default model';
|
||||
select * from CDNOW_rx_models;
|
||||
go
|
||||
|
||||
--create stored procedure to predict whether the customer is VIP or not
|
||||
|
||||
drop procedure if exists predict_CDNOW_IsVIP;
|
||||
go
|
||||
create procedure predict_CDNOW_IsVIP (@model varchar(100))
|
||||
as
|
||||
begin
|
||||
declare @rx_model varbinary(max) = (select model from CDNOW_rx_models where model_name = @model);
|
||||
-- Predict based on the specified model:
|
||||
exec sp_execute_external_script
|
||||
@language = N'R'
|
||||
, @script = N'
|
||||
require("RevoScaleR");
|
||||
CDNOWmodel <- unserialize(rx_model);
|
||||
CDNOWpred <- rxPredict(CDNOWmodel, data=RFMVIPCluster, writeModelVars = TRUE);
|
||||
OutputDataSet <- cbind(RFMVIPCluster[,1], CDNOWpred$IsVIP, round(CDNOWpred$IsVIP_Pred,2));
|
||||
colnames(OutputDataSet) <- c("ID", "IsVIP.Actual", "IsVIP.Expected");
|
||||
OutputDataSet <- as.data.frame(OutputDataSet);
|
||||
'
|
||||
, @input_data_1 = N'
|
||||
select * from RFMVIPCluster'
|
||||
, @input_data_1_name = N'RFMVIPCluster'
|
||||
, @params = N'@rx_model varbinary(max)'
|
||||
, @rx_model = @rx_model
|
||||
with result sets ( ("ID" int, "IsVIP.Actual" int, "IsVIP.Expected" float)
|
||||
);
|
||||
end;
|
||||
go
|
||||
|
||||
--execute the stored procedure to obtain the prediction on IsVIP
|
||||
|
||||
exec predict_CDNOW_IsVIP 'rxLogit';
|
||||
go
|
||||
|
||||
--create stored procedure to predict which cluster the customer belongs to
|
||||
|
||||
drop procedure if exists predict_CDNOW_Cluster;
|
||||
go
|
||||
create procedure predict_CDNOW_Cluster (@model varchar(100))
|
||||
as
|
||||
begin
|
||||
declare @rx_model varbinary(max) = (select model from CDNOW_rx_models where model_name = @model);
|
||||
-- Predict based on the specified model:
|
||||
exec sp_execute_external_script
|
||||
@language = N'R'
|
||||
, @script = N'
|
||||
require("RevoScaleR");
|
||||
CDNOWmodel <- unserialize(rx_model);
|
||||
CDNOWpred <- rxPredict(CDNOWmodel,
|
||||
data=RFMVIPCluster,
|
||||
predVarNames=c("prob1", "prob2", "prob3", "prob4", "prob5", "prob6", "prob7", "prob8"),
|
||||
writeModelVars=TRUE, extraVarsToWrite="ID",
|
||||
computeResiduals=T, overwrite=TRUE);
|
||||
OutputDataSet <- round(cbind(RFMVIPCluster[,1], RFMVIPCluster[,10],
|
||||
CDNOWpred$prob1,CDNOWpred$prob2,CDNOWpred$prob3,CDNOWpred$prob4,
|
||||
CDNOWpred$prob5,CDNOWpred$prob6,CDNOWpred$prob7,CDNOWpred$prob8),2);
|
||||
|
||||
colnames(OutputDataSet) <- c("ID", "Cluster.Actual", "Cluster1.Prob","Cluster2.Prob","Cluster3.Prob","Cluster4.Prob","Cluster5.Prob","Cluster6.Prob","Cluster7.Prob","Cluster8.Prob");
|
||||
OutputDataSet<-as.data.frame(OutputDataSet);
|
||||
'
|
||||
, @input_data_1 = N'
|
||||
select * from RFMVIPCluster'
|
||||
, @input_data_1_name = N'RFMVIPCluster'
|
||||
, @params = N'@rx_model varbinary(max)'
|
||||
, @rx_model = @rx_model
|
||||
with result sets ( ("ID" int, "Cluster.Actual" int, "Cluster1.Prob" float,"Cluster2.Prob" float,"Cluster3.Prob" float,"Cluster4.Prob" float,"Cluster5.Prob" float,"Cluster6.Prob" float,"Cluster7.Prob" float,"Cluster8.Prob" float)
|
||||
);
|
||||
end;
|
||||
go
|
||||
|
||||
--execute the stored procedure to obtain the prediction on Cluster
|
||||
|
||||
exec predict_CDNOW_Cluster 'rxDtree';
|
||||
go
|
||||
@@ -0,0 +1,28 @@
|
||||
use sqlr;
|
||||
go
|
||||
drop table if exists CDNOW;
|
||||
go
|
||||
|
||||
-- create the fraud table to hold invoice data:
|
||||
|
||||
create table CDNOW(
|
||||
[ID] int not null,
|
||||
[Date] date not null,
|
||||
[Volume] int not null,
|
||||
[Amount] float not null);
|
||||
go
|
||||
|
||||
-- Modify path to the data file: "CDNOW_master.csv"
|
||||
|
||||
bulk insert CDNOW
|
||||
from 'C:\sqlr\mydemos\CRM\CDNOW_master.csv'
|
||||
with(
|
||||
fieldterminator = ',',
|
||||
firstrow = 2);
|
||||
go
|
||||
|
||||
--create clustered columnstore index cs_CDNOW on CDNOW;
|
||||
--go
|
||||
|
||||
grant select on CDNOW to rdemo;
|
||||
go
|
||||
Reference in New Issue
Block a user