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, 18 Dec 2011 08:15:43 -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/2011/Dec/18/t13242143945hagg9o2eu5yji8.htm/, Retrieved Thu, 31 Oct 2024 23:28:31 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=156840, Retrieved Thu, 31 Oct 2024 23:28:31 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact179
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-18 13:15:43] [47d38a19087200036e90a9f702d012f8] [Current]
-  M        [Recursive Partitioning (Regression Trees)] [] [2011-12-19 06:55:31] [74be16979710d4c4e7c6647856088456]
-           [Recursive Partitioning (Regression Trees)] [] [2011-12-20 09:04:10] [74be16979710d4c4e7c6647856088456]
-           [Recursive Partitioning (Regression Trees)] [] [2011-12-22 16:57:21] [74be16979710d4c4e7c6647856088456]
-           [Recursive Partitioning (Regression Trees)] [] [2011-12-23 15:39:26] [74be16979710d4c4e7c6647856088456]
Feedback Forum

Post a new message
Dataseries X:
140824	186099	38	165
110459	113854	34	135
105079	99776	42	121
112098	106194	38	148
43929	100792	27	73
76173	47552	35	49
187326	250931	33	185
22807	6853	18	5
144408	115466	34	125
66485	110896	33	93
79089	169351	46	154
81625	94853	55	98
68788	72591	37	70
103297	101345	55	148
69446	113713	44	100
114948	165354	59	150
167949	164263	36	197
125081	135213	39	114
125818	111669	29	169
136588	134163	51	200
112431	140303	49	148
103037	150773	39	140
82317	111848	25	74
118906	102509	52	128
83515	96785	45	140
104581	116136	38	116
103129	158376	41	147
83243	153990	43	132
37110	64057	32	70
113344	230054	41	144
139165	184531	47	155
86652	114198	50	165
112302	198299	48	161
69652	33750	37	31
119442	189723	43	199
69867	100826	42	78
101629	188355	44	121
70168	104470	36	112
31081	58391	17	41
103925	164808	42	158
92622	134097	39	123
79011	80238	41	104
93487	133252	36	94
64520	54518	47	73
93473	121850	45	52
114360	79367	41	71
33032	56968	26	21
96125	106314	52	155
151911	191889	47	174
89256	104864	45	136
95671	160791	40	128
5950	15049	4	7
149695	191179	44	165
32551	25109	18	21
31701	45824	14	35
100087	129711	37	137
169707	210012	61	174
150491	194679	39	257
120192	197680	42	207
95893	81180	36	103
151715	197765	49	171
176225	214738	28	279
59900	96252	43	83
104767	124527	42	130
114799	153242	37	131
72128	145707	30	126
143592	113963	35	158
89626	134904	44	138
131072	114268	36	200
126817	94333	28	104
81351	102204	45	111
22618	23824	23	26
88977	111563	45	115
92059	91313	38	127
81897	89770	38	140
108146	100125	46	121
126372	165278	36	183
249771	181712	41	68
71154	80906	38	112
71571	75881	37	103
55918	83963	28	63
160141	175721	45	166
38692	68580	26	38
102812	136323	44	163
56622	55792	8	59
15986	25157	27	27
123534	100922	38	108
108535	118845	37	88
93879	170492	57	92
144551	81716	45	170
56750	115750	37	98
127654	105590	40	205
65594	92795	31	96
59938	82390	36	107
146975	135599	40	150
143372	111542	36	123
168553	162519	35	176
183500	211381	39	213
165986	189944	65	208
184923	226168	30	307
140358	117495	51	125
149959	195894	41	208
57224	80684	36	73
43750	19630	19	49
48029	88634	23	82
104978	139292	44	206
100046	128602	40	112
101047	135848	40	139
197426	178377	30	60
160902	106330	41	70
147172	178303	40	112
109432	116938	45	142
1168	5841	1	11
83248	106020	40	130
25162	24610	11	31
45724	74151	45	132
110529	232241	38	219
855	6622	0	4
101382	127097	30	102
14116	13155	8	39
89506	160501	39	125
135356	91502	48	121
116066	24469	48	42
144244	88229	29	111
8773	13983	8	16
102153	80716	43	70
117440	157384	52	162
104128	122975	53	173
134238	191469	48	171
134047	231257	48	172
279488	258287	50	254
79756	122531	40	90
66089	61394	36	50
102070	86480	40	113
146760	195791	46	187
154771	18284	42	16
165933	147581	46	175
64593	72558	39	90
92280	147341	41	140
67150	114651	46	145
128692	100187	32	141
124089	130332	39	125
125386	134218	39	241
37238	10901	21	16
140015	145758	45	175
150047	75767	50	132
154451	134969	36	154
156349	169216	44	198
0	0	0	0
6023	7953	0	5
0	0	0	0
0	0	0	0
0	0	0	0
0	0	0	0
84601	105406	37	125
68946	174586	52	174
0	0	0	0
0	0	0	0
1644	4245	0	6
6179	21509	5	13
3926	7670	1	3
52789	15673	43	35
0	0	0	0
100350	75882	34	80




Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time3 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 & 3 seconds \tabularnewline
R Server & 'Gertrude Mary Cox' @ cox.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=156840&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]3 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=156840&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=156840&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 time3 seconds
R Server'Gertrude Mary Cox' @ cox.wessa.net







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

\begin{tabular}{lllllllll}
\hline
Confusion Matrix (predicted in columns / actuals in rows) \tabularnewline
 & C1 & C2 \tabularnewline
C1 & 77 & 5 \tabularnewline
C2 & 32 & 50 \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=156840&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]32[/C][C]50[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=156840&T=1

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=156840&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
C23250



Parameters (Session):
par1 = 1 ; par2 = quantiles ; par3 = 2 ; par4 = no ;
Parameters (R input):
par1 = 1 ; 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')
}