x <- array(list(20465 ,158258 ,48 ,18 ,23975 ,0 ,33629 ,186930 ,53 ,20 ,85634 ,1 ,1423 ,7215 ,0 ,0 ,1929 ,0 ,25629 ,129098 ,51 ,27 ,36294 ,0 ,54002 ,230632 ,76 ,31 ,72255 ,0 ,151036 ,508313 ,128 ,36 ,189748 ,1 ,33287 ,180745 ,62 ,23 ,61834 ,1 ,31172 ,185559 ,83 ,30 ,68167 ,0 ,28113 ,154581 ,55 ,30 ,38462 ,0 ,57803 ,290658 ,67 ,26 ,101219 ,1 ,49830 ,121844 ,50 ,24 ,43270 ,2 ,52143 ,184039 ,77 ,30 ,76183 ,0 ,21055 ,100324 ,46 ,22 ,31476 ,0 ,47007 ,209427 ,79 ,25 ,62157 ,4 ,28735 ,168265 ,56 ,18 ,46261 ,4 ,59147 ,154593 ,54 ,22 ,50063 ,3 ,78950 ,142018 ,81 ,33 ,64483 ,0 ,13497 ,79030 ,6 ,15 ,2341 ,5 ,46154 ,167047 ,74 ,34 ,48149 ,0 ,53249 ,27997 ,13 ,18 ,12743 ,0 ,10726 ,73019 ,22 ,15 ,18743 ,0 ,83700 ,241082 ,99 ,30 ,97057 ,0 ,40400 ,195820 ,38 ,25 ,17675 ,0 ,33797 ,141899 ,59 ,34 ,33106 ,1 ,36205 ,145433 ,50 ,21 ,53311 ,1 ,30165 ,183744 ,50 ,21 ,42754 ,0 ,58534 ,202232 ,61 ,25 ,59056 ,0 ,44663 ,190230 ,81 ,31 ,101621 ,0 ,92556 ,354924 ,60 ,31 ,118120 ,0 ,40078 ,192399 ,52 ,20 ,79572 ,0 ,34711 ,182286 ,61 ,28 ,42744 ,0 ,31076 ,181590 ,60 ,22 ,65931 ,2 ,74608 ,133801 ,53 ,17 ,38575 ,4 ,58092 ,233686 ,76 ,25 ,28795 ,0 ,42009 ,219428 ,63 ,24 ,94440 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,36022 ,223044 ,54 ,28 ,38229 ,0 ,23333 ,100129 ,44 ,14 ,31972 ,3 ,53349 ,136733 ,36 ,35 ,40071 ,9 ,92596 ,249965 ,83 ,34 ,132480 ,0 ,49598 ,242379 ,105 ,22 ,62797 ,2 ,44093 ,145794 ,37 ,34 ,40429 ,0 ,84205 ,96404 ,25 ,23 ,45545 ,2 ,63369 ,195891 ,64 ,24 ,57568 ,1 ,60132 ,117156 ,55 ,26 ,39019 ,2 ,37403 ,157787 ,41 ,22 ,53866 ,2 ,24460 ,81293 ,23 ,35 ,38345 ,1 ,46456 ,224049 ,67 ,24 ,50210 ,0 ,66616 ,223789 ,54 ,31 ,80947 ,1 ,41554 ,160344 ,68 ,26 ,43461 ,8 ,22346 ,48188 ,12 ,22 ,14812 ,0 ,30874 ,152206 ,86 ,21 ,37819 ,0 ,68701 ,294283 ,74 ,27 ,102738 ,0 ,35728 ,235223 ,56 ,30 ,54509 ,0 ,29010 ,195583 ,67 ,33 ,62956 ,1 ,23110 ,145942 ,40 ,11 ,55411 ,8 ,38844 ,208834 ,53 ,26 ,50611 ,0 ,27084 ,93764 ,26 ,26 ,26692 ,1 ,35139 ,151985 ,67 ,23 ,60056 ,0 ,57476 ,190545 ,36 ,38 ,25155 ,10 ,33277 ,148922 ,50 ,31 ,42840 ,6 ,31141 ,132856 ,48 ,20 ,39358 ,0 ,61281 ,126107 ,46 ,19 ,47241 ,11 ,25820 ,112718 ,53 ,26 ,49611 ,3 ,23284 ,160930 ,27 ,26 ,41833 ,0 ,35378 ,99184 ,38 ,33 ,48930 ,0 ,74990 ,182022 ,69 ,36 ,110600 ,8 ,29653 ,138708 ,93 ,25 ,52235 ,2 ,64622 ,114408 ,59 ,24 ,53986 ,0 ,4157 ,31970 ,5 ,21 ,4105 ,0 ,29245 ,225558 ,53 ,19 ,59331 ,3 ,50008 ,137011 ,40 ,12 ,47796 ,1 ,52338 ,113612 ,72 ,30 ,38302 ,2 ,13310 ,108641 ,51 ,21 ,14063 ,1 ,92901 ,162203 ,81 ,34 ,54414 ,0 ,10956 ,100098 ,27 ,32 ,9903 ,2 ,34241 ,174768 ,94 ,28 ,53987 ,1 ,75043 ,158459 ,71 ,28 ,88937 ,0 ,21152 ,80934 ,20 ,21 ,21928 ,0 ,42249 ,84971 ,34 ,31 ,29487 ,0 ,42005 ,80545 ,54 ,26 ,35334 ,0 ,41152 ,287191 ,49 ,29 ,57596 ,0 ,14399 ,62974 ,26 ,23 ,29750 ,1 ,28263 ,134091 ,48 ,25 ,41029 ,0 ,17215 ,75555 ,35 ,22 ,12416 ,0 ,48140 ,162154 ,32 ,26 ,51158 ,0 ,62897 ,226638 ,55 ,33 ,79935 ,0 ,22883 ,115019 ,58 ,24 ,26552 ,0 ,41622 ,105038 ,44 ,24 ,25807 ,7 ,40715 ,155537 ,45 ,21 ,50620 ,0 ,65897 ,153133 ,49 ,28 ,61467 ,5 ,76542 ,165577 ,72 ,27 ,65292 ,1 ,37477 ,151517 ,39 ,25 ,55516 ,0 ,53216 ,133686 ,28 ,15 ,42006 ,0 ,40911 ,61342 ,24 ,13 ,26273 ,0 ,57021 ,245196 ,52 ,36 ,90248 ,0 ,73116 ,195576 ,96 ,24 ,61476 ,0 ,3895 ,19349 ,13 ,1 ,9604 ,0 ,46609 ,225371 ,38 ,24 ,45108 ,3 ,29351 ,152796 ,41 ,31 ,47232 ,0 ,2325 ,59117 ,24 ,4 ,3439 ,0 ,31747 ,91762 ,54 ,21 ,30553 ,0 ,32665 ,136769 ,68 ,23 ,24751 ,0 ,19249 ,113552 ,28 ,23 ,34458 ,1 ,15292 ,85338 ,36 ,12 ,24649 ,1 ,5842 ,27676 ,2 ,16 ,2342 ,0 ,33994 ,147984 ,83 ,29 ,52739 ,0 ,13018 ,122417 ,29 ,26 ,6245 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,98177 ,91529 ,46 ,25 ,35381 ,0 ,37941 ,107205 ,25 ,21 ,19595 ,0 ,31032 ,144664 ,51 ,23 ,50848 ,0 ,32683 ,136540 ,59 ,21 ,39443 ,0 ,34545 ,76656 ,36 ,21 ,27023 ,0 ,0 ,3616 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,27525 ,183065 ,40 ,23 ,61022 ,0 ,66856 ,144636 ,68 ,33 ,63528 ,0 ,28549 ,159104 ,28 ,30 ,34835 ,2 ,38610 ,113273 ,36 ,23 ,37172 ,0 ,2781 ,43410 ,7 ,1 ,13 ,0 ,41211 ,175774 ,70 ,29 ,62548 ,1 ,22698 ,95401 ,30 ,18 ,31334 ,0 ,41194 ,118893 ,59 ,32 ,20839 ,8 ,32689 ,60493 ,3 ,12 ,5084 ,3 ,5752 ,19764 ,10 ,2 ,9927 ,1 ,26757 ,164062 ,46 ,21 ,53229 ,3 ,22527 ,132696 ,34 ,28 ,29877 ,0 ,44810 ,155367 ,54 ,29 ,37310 ,0 ,0 ,11796 ,1 ,2 ,0 ,0 ,0 ,10674 ,0 ,0 ,0 ,0 ,100674 ,142261 ,39 ,18 ,50067 ,0 ,0 ,6836 ,0 ,1 ,0 ,0 ,57786 ,154206 ,48 ,21 ,47708 ,6 ,0 ,5118 ,5 ,0 ,0 ,0 ,5444 ,40248 ,8 ,4 ,6012 ,1 ,0 ,0 ,0 ,0 ,0 ,0 ,28470 ,122641 ,38 ,25 ,27749 ,0 ,61849 ,88837 ,21 ,26 ,47555 ,0 ,0 ,7131 ,0 ,0 ,0 ,1 ,2179 ,9056 ,0 ,4 ,1336 ,0 ,8019 ,76611 ,15 ,17 ,11017 ,1 ,39644 ,132697 ,50 ,21 ,55184 ,0 ,23494 ,100681 ,17 ,22 ,43485 ,1) ,dim=c(6 ,144) ,dimnames=list(c('CWCharacters' ,'Time' ,'Blogs' ,'Reviews' ,'CWseconds' ,'Shared') ,1:144)) y <- array(NA,dim=c(6,144),dimnames=list(c('CWCharacters','Time','Blogs','Reviews','CWseconds','Shared'),1:144)) for (i in 1:dim(x)[1]) { for (j in 1:dim(x)[2]) { y[i,j] <- as.numeric(x[i,j]) } } par4 = 'no' par3 = '3' par2 = 'none' par1 = '1' #'GNU S' R Code compiled by R2WASP v. 1.0.44 () #Author: Dr. Ian E. Holliday #To cite this work: Ian E. Holliday, 2009, YOUR SOFTWARE TITLE (vNUMBER) in Free Statistics Software (v$_version), Office for Research Development and Education, URL http://www.wessa.net/rwasp_YOURPAGE.wasp/ #Source of accompanying publication: #Technical description: library(party) library(Hmisc) par1 <- as.numeric(par1) par3 <- as.numeric(par3) x <- data.frame(t(y)) is.data.frame(x) x <- x[!is.na(x[,par1]),] k <- length(x[1,]) n <- length(x[,1]) colnames(x)[par1] x[,par1] if (par2 == 'kmeans') { cl <- kmeans(x[,par1], par3) print(cl) clm <- matrix(cbind(cl$centers,1:par3),ncol=2) clm <- clm[sort.list(clm[,1]),] for (i in 1:par3) { cl$cluster[cl$cluster==clm[i,2]] <- paste('C',i,sep='') } cl$cluster <- as.factor(cl$cluster) print(cl$cluster) x[,par1] <- cl$cluster } if (par2 == 'quantiles') { x[,par1] <- cut2(x[,par1],g=par3) } if (par2 == 'hclust') { hc <- hclust(dist(x[,par1])^2, 'cen') print(hc) memb <- cutree(hc, k = par3) dum <- c(mean(x[memb==1,par1])) for (i in 2:par3) { dum <- c(dum, mean(x[memb==i,par1])) } hcm <- matrix(cbind(dum,1:par3),ncol=2) hcm <- hcm[sort.list(hcm[,1]),] for (i in 1:par3) { memb[memb==hcm[i,2]] <- paste('C',i,sep='') } memb <- as.factor(memb) print(memb) x[,par1] <- memb } if (par2=='equal') { ed <- cut(as.numeric(x[,par1]),par3,labels=paste('C',1:par3,sep='')) x[,par1] <- as.factor(ed) } table(x[,par1]) colnames(x) colnames(x)[par1] x[,par1] if (par2 == 'none') { m <- ctree(as.formula(paste(colnames(x)[par1],' ~ .',sep='')),data = x) } #Note: the /var/wessaorg/rcomp/createtable file can be downloaded at http://www.wessa.net/cretab load(file="/var/wessaorg/rcomp/createtable") if (par2 != 'none') { m <- ctree(as.formula(paste('as.factor(',colnames(x)[par1],') ~ .',sep='')),data = x) if (par4=='yes') { a<-table.start() a<-table.row.start(a) a<-table.element(a,'10-Fold Cross Validation',3+2*par3,TRUE) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'',1,TRUE) a<-table.element(a,'Prediction (training)',par3+1,TRUE) a<-table.element(a,'Prediction (testing)',par3+1,TRUE) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'Actual',1,TRUE) for (jjj in 1:par3) a<-table.element(a,paste('C',jjj,sep=''),1,TRUE) a<-table.element(a,'CV',1,TRUE) for (jjj in 1:par3) a<-table.element(a,paste('C',jjj,sep=''),1,TRUE) a<-table.element(a,'CV',1,TRUE) a<-table.row.end(a) for (i in 1:10) { ind <- sample(2, nrow(x), replace=T, prob=c(0.9,0.1)) m.ct <- ctree(as.formula(paste('as.factor(',colnames(x)[par1],') ~ .',sep='')),data =x[ind==1,]) if (i==1) { m.ct.i.pred <- predict(m.ct, newdata=x[ind==1,]) m.ct.i.actu <- x[ind==1,par1] m.ct.x.pred <- predict(m.ct, newdata=x[ind==2,]) m.ct.x.actu <- x[ind==2,par1] } else { m.ct.i.pred <- c(m.ct.i.pred,predict(m.ct, newdata=x[ind==1,])) m.ct.i.actu <- c(m.ct.i.actu,x[ind==1,par1]) m.ct.x.pred <- c(m.ct.x.pred,predict(m.ct, newdata=x[ind==2,])) m.ct.x.actu <- c(m.ct.x.actu,x[ind==2,par1]) } } print(m.ct.i.tab <- table(m.ct.i.actu,m.ct.i.pred)) numer <- 0 for (i in 1:par3) { print(m.ct.i.tab[i,i] / sum(m.ct.i.tab[i,])) numer <- numer + m.ct.i.tab[i,i] } print(m.ct.i.cp <- numer / sum(m.ct.i.tab)) print(m.ct.x.tab <- table(m.ct.x.actu,m.ct.x.pred)) numer <- 0 for (i in 1:par3) { print(m.ct.x.tab[i,i] / sum(m.ct.x.tab[i,])) numer <- numer + m.ct.x.tab[i,i] } print(m.ct.x.cp <- numer / sum(m.ct.x.tab)) for (i in 1:par3) { a<-table.row.start(a) a<-table.element(a,paste('C',i,sep=''),1,TRUE) for (jjj in 1:par3) a<-table.element(a,m.ct.i.tab[i,jjj]) a<-table.element(a,round(m.ct.i.tab[i,i]/sum(m.ct.i.tab[i,]),4)) for (jjj in 1:par3) a<-table.element(a,m.ct.x.tab[i,jjj]) a<-table.element(a,round(m.ct.x.tab[i,i]/sum(m.ct.x.tab[i,]),4)) a<-table.row.end(a) } a<-table.row.start(a) a<-table.element(a,'Overall',1,TRUE) for (jjj in 1:par3) a<-table.element(a,'-') a<-table.element(a,round(m.ct.i.cp,4)) for (jjj in 1:par3) a<-table.element(a,'-') a<-table.element(a,round(m.ct.x.cp,4)) a<-table.row.end(a) a<-table.end(a) table.save(a,file="/var/wessaorg/rcomp/tmp/17zhn1324475147.tab") } } m postscript(file="/var/wessaorg/rcomp/tmp/2f2p61324475147.ps",horizontal=F,onefile=F,pagecentre=F,paper="special",width=8.3333333333333,height=5.5555555555556) plot(m) dev.off() postscript(file="/var/wessaorg/rcomp/tmp/3epkg1324475147.ps",horizontal=F,onefile=F,pagecentre=F,paper="special",width=8.3333333333333,height=5.5555555555556) plot(x[,par1] ~ as.factor(where(m)),main='Response by Terminal Node',xlab='Terminal Node',ylab='Response') dev.off() if (par2 == 'none') { forec <- predict(m) result <- as.data.frame(cbind(x[,par1],forec,x[,par1]-forec)) colnames(result) <- c('Actuals','Forecasts','Residuals') print(result) } if (par2 != 'none') { print(cbind(as.factor(x[,par1]),predict(m))) myt <- table(as.factor(x[,par1]),predict(m)) print(myt) } postscript(file="/var/wessaorg/rcomp/tmp/4k2g61324475147.ps",horizontal=F,onefile=F,pagecentre=F,paper="special",width=8.3333333333333,height=5.5555555555556) if(par2=='none') { op <- par(mfrow=c(2,2)) plot(density(result$Actuals),main='Kernel Density Plot of Actuals') plot(density(result$Residuals),main='Kernel Density Plot of Residuals') plot(result$Forecasts,result$Actuals,main='Actuals versus Predictions',xlab='Predictions',ylab='Actuals') plot(density(result$Forecasts),main='Kernel Density Plot of Predictions') par(op) } if(par2!='none') { plot(myt,main='Confusion Matrix',xlab='Actual',ylab='Predicted') } dev.off() if (par2 == 'none') { detcoef <- cor(result$Forecasts,result$Actuals) a<-table.start() a<-table.row.start(a) a<-table.element(a,'Goodness of Fit',2,TRUE) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'Correlation',1,TRUE) a<-table.element(a,round(detcoef,4)) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'R-squared',1,TRUE) a<-table.element(a,round(detcoef*detcoef,4)) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'RMSE',1,TRUE) a<-table.element(a,round(sqrt(mean((result$Residuals)^2)),4)) a<-table.row.end(a) a<-table.end(a) table.save(a,file="/var/wessaorg/rcomp/tmp/564nn1324475147.tab") a<-table.start() a<-table.row.start(a) a<-table.element(a,'Actuals, Predictions, and Residuals',4,TRUE) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'#',header=TRUE) a<-table.element(a,'Actuals',header=TRUE) a<-table.element(a,'Forecasts',header=TRUE) a<-table.element(a,'Residuals',header=TRUE) a<-table.row.end(a) for (i in 1:length(result$Actuals)) { a<-table.row.start(a) a<-table.element(a,i,header=TRUE) a<-table.element(a,result$Actuals[i]) a<-table.element(a,result$Forecasts[i]) a<-table.element(a,result$Residuals[i]) a<-table.row.end(a) } a<-table.end(a) table.save(a,file="/var/wessaorg/rcomp/tmp/6p4my1324475147.tab") } if (par2 != 'none') { a<-table.start() a<-table.row.start(a) a<-table.element(a,'Confusion Matrix (predicted in columns / actuals in rows)',par3+1,TRUE) a<-table.row.end(a) a<-table.row.start(a) a<-table.element(a,'',1,TRUE) for (i in 1:par3) { a<-table.element(a,paste('C',i,sep=''),1,TRUE) } a<-table.row.end(a) for (i in 1:par3) { a<-table.row.start(a) a<-table.element(a,paste('C',i,sep=''),1,TRUE) for (j in 1:par3) { a<-table.element(a,myt[i,j]) } a<-table.row.end(a) } a<-table.end(a) table.save(a,file="/var/wessaorg/rcomp/tmp/7cdtj1324475147.tab") } try(system("convert tmp/2f2p61324475147.ps tmp/2f2p61324475147.png",intern=TRUE)) try(system("convert tmp/3epkg1324475147.ps tmp/3epkg1324475147.png",intern=TRUE)) try(system("convert tmp/4k2g61324475147.ps tmp/4k2g61324475147.png",intern=TRUE))