R语言侦测欺诈交易(共8页).doc

精选优质文档-倾情为你奉上R语言侦测欺诈交易背景考虑到在经济和社会领域中经常存在欺诈交易等非法活动，因此欺诈检验是数据挖掘技术的一个重要应用领域。从数据分析的角度，欺诈行为通常和异常的观测值相关联，因为这些欺诈行为是偏离常规的。在多个数据分析领域，这些偏离常规的行为经常成为离群值。数据挖掘的结果有助于公司的事后检查活动，能够提供某种欺诈概率排序作为输出结果，可以使公司以最佳方式来利用其事后检查资源。目的侦测欺诈交易的目的是找到“奇怪的”交易记录报告，它可能指出某些销售员涉嫌欺诈。这里用的数据是一个较短时期内的销售数据，销售员可按照自己的策略和公司情况来自由设置销售价格。我们的目的是根据公司过去发现的交易报告中的错误和欺诈企图，帮助公司完成核实这些销售报告真实性的工作。1.加载数据：共401 146行数据，每一行包括来自销售员报告的信息。ID：说明销售员ID的一个因子变量。Prod：说明销售产品ID号的一个因子变量。Quant:报告该产品销售的数量。Val：报告销售记录的总价值。Insp:有3个可能值的因子变量ok表示公司检查了该交易并认为该交易有效；fraud表示发现该交易为欺诈；unkn表示该交易未经过公司审核。2.数据集探索：> sum(is.na(sales$Quant) & is.na(sales$Val)1 888从数据的统计特征初步可以看出v431号雇员录入的数据最多，p1125号产品卖出最多，可以看到产品销售的数量和总价值的四分位数据，公司已检查承认有效的数据有14462，已发现欺诈的数据有1270，未经过审查的有，说明大量数据还未经过审核，需要接下来的数据分析来检查其中的欺诈数据。数据中有大量缺失值，当重要产品销售数和销售总价值同时缺失时，就无法进行分析，这样的数据有888条，在40万组数据中可以忽略不计。判断数据框中每个变量的属性：str(sales)'data.frame': obs. of 5 variables: $ ID : Factor w/ 6016 levels "v1","v2","v3",.: 1 2 3 4 3 5 6 7 8 9 . $ Prod : Factor w/ 4548 levels "p1","p2","p3",.: 1 1 1 1 1 2 2 2 2 2 . $ Quant: int 182 3072 20393 112 6164 104 350 200 233 118 . $ Val : num 1665 8780 76990 1100 20260 . $ Insp : Factor w/ 3 levels "ok","unkn","fraud": 2 2 2 2 2 2 2 2 2 2 .可以看到ID，Prod,Insp是因子型变量， Quant整数型，Val数值型。table(sales$Insp)/nrow(sales)*100 ok unkn fraud 3. 96. 0.在只考虑已检查过的销售记录，看到欺诈比例较小。绘制每个交易人员的交易数量和每个产品的交易数量图形totS <- table(sales$ID)totP <- table(sales$Prod)barplot(totS,main='Transactions per salespeople',names.arg='',xlab='Salespeople', ylab='Amount')barplot(totP,main='Transactions per product',names.arg='',xlab='Products', ylab='Amount')看到所有销售人员的数据相当不同，对于每个产品，波动性较大。sales$Uprice <- sales$Val/sales$Quantsummary(sales$Uprice) Min. 1st Qu. Median Mean 3rd Qu. Max. NA's 0.00 8.46 11.89 20.30 19.11 26460.00 13248检查产品单位价格的分布，看到有明显的变动性。out <- tapply(Uprice,list(Prod=Prod),function(x) length(boxplot.stats(x)$out)outorder(out,decreasing=T)1:10sum(out)129446sum(out)/nrow(sales)*10017.34047初步找到29446个被认为是离群值的交易，相当于交易的7.3%3.缺失值处理：找出变量Quant和变量Val同时有缺失值的交易占很大比例的销售人员> totS<-table(sales$ID)> totP<-table(sales$Prod)> nas<-saleswhich(is.na(sales$Quant)&is.na(sales$Val),c("ID","Prod")> propS<-100*table(nas$ID)/totS> propSorder(propS,decreasing=T)1:10 v1237 v4254 v4038 v5248 v3666 v4433 v4170 13. 9. 8. 8. 6. 6. 5. v4926 v4664 v4642 5. 5. 4.可以考虑直接剔除同时在两个变量有缺失值的交易sales<-sales-which(is.na(sales$Quant) & is.na(sales$Val),分析剩余的在数量或者价格变量上有缺失值的交易。计算每一种产品在数量上有缺失值的交易，显示前10个：> nnasQp<-tapply(sales$Quant,list(sales$Prod),function(x) sum(is.na(x)> propNAsQp<-nnasQp/table(sales$Prod)> propNAsQporder(propNAsQp,decreasing=T)1:10 p2442 p2443 p1653 p4101 p4243 p903 p3678 1. 1. 0. 0. 0. 0. 0. p4061 p3955 p4313 0. 0. 0.P2442和p2443两个产品所有的交易数量是缺失的，因此我们无法计算其标准价格，所以这些产品的交易信息不可能进行任何分析。一共54份报告，标记为ok的报告，意味着检查员掌握了比这个数据集更多的信息，或者我们得到的数据有输入错误，因为从这些交易中似乎不可能得到任何结论，基于此，将删除这些交易报告：> sales <- sales!sales$Prod %in% c('p2442','p2443'),更新删除两种产品后的Prod:> nlevels(sales$Prod)1 4548> sales$Prod <- factor(sales$Prod)> nlevels(sales$Prod)1 4546观察是否有销售人员的所有交易数量为缺失值：> nnasQs<-tapply(sales$Quant,list(sales$ID),function(x) sum(is.na(x)> propNAsQs<-nnasQs/table(sales$ID)> propNAsQsorder(propNAsQs,decreasing=T)1:10 v2925 v5537 v5836 v6058 v6065 v4368 v2923 1. 1. 1. 1. 1. 0. 0. v2970 v4910 v4542 0. 0. 0.从结果上看，有几个销售人员没有在报告中填写交易的数量信息。我们只要有其他销售人员报告的相同产品的交易，就可以尝试使用此信息来填补那些缺失值，所以不删除这些交易。对剩余的交易，用每个产品单位价格的中位数作为产品的标准价格：tPrice<-tapply(salessales$Insp!='fraud','Uprice',list(salessales$Insp!='fraud','Prod'),median,na.rm=T)用标准单价计算缺失值Quant和Val，填补所有缺失值noQuant<-which(is.na(sales$Quant)salesnoQuant,'Quant'<-ceiling(salesnoQuant,'Val'/tPricesalesnoQuant,'Prod')noVal<-which(is.na(sales$Val)salesnoVal,'Val'<-salesnoVal,'Quant'*tPricesalesnoVal,'Prod'重新计算Uprice列的值来填充先前未知的单位价格sales$Uprice<-sales$Val/sales$Quant填补缺失值之后保存为sales，后面分析的数据就用这个数据。有些产品只有极少的交易，因为太少的交易，在要求的统计学显著性下很难做出决定。这种情况下，可以和一些产品的交易一起分析来避免这个问题。尽管缺失产品之间关系的信息，但可以尝试通过观察产品单价分部之间的相似性来推断其中的一些关系，如果可以发现具有类似价格的产品，我们可以考虑合并它们相应的交易并对它们一起进行分析，从而找到异常值。比较两个分布的方法是比较总结分布的一些统计特性。连续变量分布的两个重要属性是集中趋势和离散趋势，这里使用中位数作为衡量中心的统计量，应用四分位距（IQR）作为离散指标的统计量。 > notF<-which(Insp!="fraud")> ms<-tapply(UpricenotF,list(Prod=ProdnotF),function(x)+ bp<-boxplot.stats(x)$stats+ c(median=bp3,iqr=bp4-bp2)+ )> ms<-matrix(unlist(ms),length(ms),2,byrow=T,dimnames=list(names(ms),c('median','iqr')> head(ms) median iqrp1 11. 8.p2 10. 5.p3 10. 4.p4 9. 5.p5 10. 7.p6 13. 6.上面的代码使用函数boxplot()获得中位数、第一个四分位数和第三个四分位数。对每个产品的所有交易，计算这些统计量，从分析中剔除有欺诈的交易。有了这些统计量以后，得到含有每个产品的中位数和四分位距的一个矩阵。par(mfrow=c(1,2)plot(ms,1,ms,2,xlab='Median',ylab='IQR',main='')plot(ms,1,ms,2,xlab='Median',ylab='IQR',main='',col='grey',log="xy")smalls <- which(table(Prod) < 20)points(log(mssmalls,1),log(mssmalls,2),pch='+')许多产品的中位数和IQR大致相同，我们可以看到，那些有少数交易的产品中有很多和其他产品很相似。但是难以判断这些产品是否为欺诈交易。对于交易数量少于20的产品，我们将寻找与它的单位价格分布最相似的产品，然后用Kolmogorow-Smirnov检验来检查两个产品是否在统计意义上相似。下面的代码用来获得一个矩阵（similar）。矩阵中存储的事这种少于20个交易的每个产品的检查信息，用对象ms来保存前面获得的每个产品的单位价格的中位数和IQR。dms <- scale(ms)smalls <- which(table(Prod) < 20)prods <- tapply(sales$Uprice,sales$Prod,list)similar <- matrix(NA,length(smalls),7,dimnames=list(names(smalls), c('Simil','ks.stat','ks.p','medP','iqrP','medS','iqrS') for(i in seq(along=smalls) d <- scale(dms,dmssmallsi,FALSE) d <- sqrt(drop(d2 %*% rep(1,ncol(d) stat <- ks.test(prodssmallsi,prodsorder(d)2) similari, <- c(order(d)2,stat$statistic,stat$p.value,mssmallsi, msorder(d)2,)head(similar) Simil ks.stat ks.p medP iqrP medS iqrSp8 2827 0. 0. 3. 0. 3. 0.p18 213 0. 0. 5. 8. 5. 7.p38 1044 0. 0. 5. 6. 5. 6.p39 1540 0. 0. 7. 1. 8. 1.p40 3971 0. 0. 9. 1. 9. 1.p47 1387 0. 0. 2. 2. 2. 2.得到矩阵similar前几行相应产品的ID：levels(Prod)similar1,11 "p2829"在90%的显著水平下，我们可以检查单位价格分布有相似性的产品的数量：sum(similar,'ks.p' >= 0.9)1 117对于这117个产品，我们可以把更多的交易纳入决策，提高检验的统计显著水平。4.用无监督技术进行数据挖掘：我们面临的不是预测任务，而是一个描述性的数据挖掘任务。对于未被检验的报告，Insp列没有任何信息，所以它对分析没有影响。对于这些观测值，我们只有对交易的描述。这意味着这些销售报告仅仅有描述他的自变量，这种类型的数据适用于非监督学习技术。聚类方法师徒对一组观测值形成多个聚类，一个聚类内的个案相似，从而找到这些观测值的“自然”组别。相似性概念通常要求由描述观测值的变量所定义的空间给出一个距离定义，这个距离定义是衡量一个观测值和其他观测值之间距离的函数，距离靠近的个案通常认为属于同一个自然组。有些异常值检验方法假定数据的预期分布，把背离这一分布的任何标记值记为异常值。另一个常见的异常值检验策略是假定一个变量空间的距离度量，然后把距离其他观测值“太远”的观测值标记为异常观测值，我们的目标是得到一组观测值的异常值排序，这个排序作为公司内检验决策的基础。5.评价准则library(ROCR)data(ROCR.simple)pred<-prediction(ROCR.simple$predictions,ROCR.simple$labels)perf<-performance(pred,'prec','rec')plot(perf)PRcurve <- function(preds,trues,.) require(ROCR,quietly=T) pd <- prediction(preds,trues) pf <- performance(pd,'prec','rec') pfy.values <- lapply(pfy.values,function(x) rev(cummax(rev(x) plot(pf,.)PRcurve(ROCR.simple$predictions,ROCR.simple$labels)标准价格的标准化距离：为了避免不同价格对异常值排名的影响，对单位价格和标准价格之间的距离进行标准化。 是产品p的标准单位价格，是该产品交易的单位价格的中位数，是该产品单位价格的四分位距avgNDTP <- function(toInsp,train,stats) if (missing(train) && missing(stats) stop('Provide either the training data or the product stats') if (missing(stats) notF <- which(train$Insp != 'fraud') stats <- tapply(train$UpricenotF, list(Prod=train$ProdnotF), function(x) bp <- boxplot.stats(x)$stats c(median=bp3,iqr=bp4-bp2) ) stats <- matrix(unlist(stats), length(stats),2,byrow=T, dimnames=list(names(stats),c('median','iqr') statswhich(stats,'iqr'=0),'iqr' <- statswhich(stats,'iqr'=0),'median'   mdtp <- mean(abs(toInsp$Uprice-statstoInsp$Prod,'median')/ statstoInsp$Prod,'iqr') return(mdtp)6.计算离群值排序：这里用局部离群值因子系统。ho.LOF<-function(form,train,test,k,.)ntr<-nrow(train)all<-rbind(train,test)N<-nrow(all)ups<-split(all$Uprice,all$Prod)r<-list(length=ups)for(u in seq(along=ups)ru<-if(NROW(upsu)>3)lofactor(upsu,min(k,NROW(upsu)%2)else if (NROW(upsu) rep(0,NROW(upsu)else NULLall$lof<-vector(length=N)split(all$lof,all$Prod)<-rall$lofwhich(!(is.infinite(all$lof)|is.nan(all$lof)<-SoftMax(all$lofwhich!(is.infinite(all$lof)|is.nan(all$lof)structure(evalOutlierRanking(test,order(all(ntr+1):N,'lof',decreasing=T,.),itInfo=list(preds=all(ntr+1):N,'lof',trues=ifelse(test$Insp='fraud',1,0)通过合并训练集和测试集，用LOF方法对合并后的所有报告排序，选择属于测试集个案的排列分数。lof.res<-holdOut(learner('ho.LOF',pars=list(k=7,Threshold=0.1,statsProds=globalStats),dataset(Insp.,sales),hldSettings(3,0.3,1234,T),itsInfo=TRUE)对于10%的检验限制，回溯精确值有69%，NDTP平均值有2.46专心-专注-专业