Free Statistics

of Irreproducible Research!

Author's title

Author*The author of this computation has been verified*
R Software Modulerwasp_regression_trees1.wasp
Title produced by softwareRecursive Partitioning (Regression Trees)
Date of computationSun, 09 Dec 2012 12:30:44 -0500
Cite this page as followsStatistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?v=date/2012/Dec/09/t1355074275lnpvzk650qhpq1c.htm/, Retrieved Fri, 29 Mar 2024 12:27:18 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=198006, Retrieved Fri, 29 Mar 2024 12:27:18 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact94
Family? (F = Feedback message, R = changed R code, M = changed R Module, P = changed Parameters, D = changed Data)
-     [Recursive Partitioning (Regression Trees)] [] [2010-12-05 19:35:21] [b98453cac15ba1066b407e146608df68]
- R PD  [Recursive Partitioning (Regression Trees)] [] [2011-12-11 15:00:07] [b4c8fd31b0af00c33711722ddf8d2c4c]
-   PD    [Recursive Partitioning (Regression Trees)] [] [2011-12-12 15:10:27] [74be16979710d4c4e7c6647856088456]
-             [Recursive Partitioning (Regression Trees)] [WS 10 (4)] [2012-12-09 17:30:44] [6b9eda33bf4cae06c9f9f024b199ddfb] [Current]
Feedback Forum

Post a new message
Dataseries X:
0	0	264530	165119
0	0	135248	107269
0	0	207253	93497
0	0	202898	100269
0	0	145249	91627
0	0	65295	47552
0	0	439387	233933
0	0	33186	6853
0	0	183696	104380
0	0	190673	98431
0	0	287239	156949
0	0	205260	81817
0	0	141987	59238
0	0	322679	101138
0	0	199717	107158
0	0	349227	155499
0	0	276709	156274
0	0	273576	121777
0	0	157448	105037
0	0	242782	118661
0	0	256814	131187
0	0	405874	145026
0	0	161189	107016
0	0	156189	87242
0	0	200181	91699
0	0	192645	110087
0	0	249893	145447
0	0	241171	143307
0	0	143182	61678
0	0	285266	210080
0	0	243048	165005
0	0	176062	97806
0	0	305210	184471
0	0	87995	27786
0	0	343613	184458
0	0	264159	98765
0	0	394976	178441
0	0	192718	100619
0	0	114673	58391
0	0	310108	151672
0	0	292891	124437
0	0	157518	79929
0	0	180362	123064
0	0	146175	50466
0	0	140319	100991
0	0	405267	79367
0	0	78800	56968
0	0	201970	106257
0	0	305322	178412
0	0	164733	98520
0	1	199186	153670
0	1	24188	15049
0	1	346142	174478
0	1	65029	25109
0	1	101097	45824
0	1	255082	116772
0	1	287314	189150
1	1	308944	194404
1	1	280943	185881
1	1	225816	67508
1	1	348943	188597
1	1	283283	203618
1	1	199642	87232
1	1	232791	110875
1	1	212262	144756
1	1	201345	129825
1	1	180424	92189
1	1	204450	121158
1	1	197813	96219
1	1	138731	84128
1	1	216153	97960
1	1	73566	23824
1	1	219392	103515
1	1	181728	91313
1	1	150006	85407
1	1	325723	95871
1	1	265348	143846
1	1	202410	155387
1	1	173420	74429
1	1	162366	74004
1	1	136341	71987
1	1	390163	150629
1	1	145905	68580
1	1	238921	119855
1	1	80953	55792
1	1	133301	25157
1	1	138630	90895
1	1	334082	117510
1	1	277542	144774
1	1	170849	77529
1	1	236398	103123
1	1	207178	104669
1	1	157125	82414
1	1	242395	82390
1	1	273632	128446
1	1	178489	111542
1	1	207720	136048
1	1	268066	197257
1	1	349934	162079
1	1	368833	206286
1	1	247804	109858
1	1	265849	182125
1	1	174311	74168
1	1	43287	19630
1	1	176724	88634
1	1	189021	128321
1	1	237531	118936
1	1	279589	127044
1	1	106655	178377
1	1	135798	69581
1	1	290495	168019
1	1	266805	113598
1	1	23623	5841
1	1	174970	93116
1	1	61857	24610
1	1	147760	60611
1	1	358662	226620
1	1	21054	6622
1	1	230091	121996
1	1	31414	13155
1	1	284519	154158
1	1	209481	78489
1	1	161691	22007
1	1	137093	72530
1	1	38214	13983
1	1	166059	73397
1	1	319346	143878
1	1	186273	119956
1	1	374212	181558
1	1	275578	208236
1	1	368863	237085
1	1	179928	110297
1	1	94381	61394
1	1	251253	81420
1	1	382564	191154
1	1	118033	11798
1	1	370878	135724
1	1	147989	68614
1	1	236370	139926
1	1	193220	105203
1	1	189020	80338
1	1	341992	121376
1	1	224936	124922
1	1	173260	10901
1	1	286161	135471
1	1	130908	66395
1	1	209639	134041
1	1	262412	153554
1	1	1	0
1	1	14688	7953
1	1	98	0
1	1	455	0
1	1	0	0
1	1	0	0
1	1	195822	98922
1	1	347930	165395
1	1	0	0
1	1	203	0
1	1	7199	4245
1	1	46660	21509
1	1	17547	7670
1	1	107465	15167
1	1	969	0
1	1	179994	63891




Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time4 seconds
R Server'Gertrude Mary Cox' @ cox.wessa.net

\begin{tabular}{lllllllll}
\hline
Summary of computational transaction \tabularnewline
Raw Input & view raw input (R code)  \tabularnewline
Raw Output & view raw output of R engine  \tabularnewline
Computing time & 4 seconds \tabularnewline
R Server & 'Gertrude Mary Cox' @ cox.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=198006&T=0

[TABLE]
[ROW][C]Summary of computational transaction[/C][/ROW]
[ROW][C]Raw Input[/C][C]view raw input (R code) [/C][/ROW]
[ROW][C]Raw Output[/C][C]view raw output of R engine [/C][/ROW]
[ROW][C]Computing time[/C][C]4 seconds[/C][/ROW]
[ROW][C]R Server[/C][C]'Gertrude Mary Cox' @ cox.wessa.net[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=198006&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=198006&T=0

As an alternative you can also use a QR Code:  

The GUIDs for individual cells are displayed in the table below:

Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time4 seconds
R Server'Gertrude Mary Cox' @ cox.wessa.net







Confusion Matrix (predicted in columns / actuals in rows)
C1C2
C1775
C22161

\begin{tabular}{lllllllll}
\hline
Confusion Matrix (predicted in columns / actuals in rows) \tabularnewline
 & C1 & C2 \tabularnewline
C1 & 77 & 5 \tabularnewline
C2 & 21 & 61 \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=198006&T=1

[TABLE]
[ROW][C]Confusion Matrix (predicted in columns / actuals in rows)[/C][/ROW]
[ROW][C][/C][C]C1[/C][C]C2[/C][/ROW]
[ROW][C]C1[/C][C]77[/C][C]5[/C][/ROW]
[ROW][C]C2[/C][C]21[/C][C]61[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=198006&T=1

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=198006&T=1

As an alternative you can also use a QR Code:  

The GUIDs for individual cells are displayed in the table below:

Confusion Matrix (predicted in columns / actuals in rows)
C1C2
C1775
C22161



Parameters (Session):
par1 = 3 ; par2 = quantiles ; par3 = 2 ; par4 = no ;
Parameters (R input):
par1 = 3 ; par2 = quantiles ; par3 = 2 ; par4 = no ;
R code (references can be found in the software module):
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)
}
load(file='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='mytable3.tab')
}
}
m
bitmap(file='test1.png')
plot(m)
dev.off()
bitmap(file='test1a.png')
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)
}
bitmap(file='test2.png')
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='mytable1.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='mytable.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='mytable2.tab')
}