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 computationTue, 13 Dec 2011 12:55:41 -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/13/t1323799016cd1hmx4au2o971r.htm/, Retrieved Thu, 02 May 2024 19:37:33 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=154588, Retrieved Thu, 02 May 2024 19:37:33 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact133
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 20:13:50] [b98453cac15ba1066b407e146608df68]
- R PD    [Recursive Partitioning (Regression Trees)] [Recursive Partiti...] [2011-12-13 17:55:41] [8e74b77f6c0ad21b554439c4ef29c61b] [Current]
-   PD      [Recursive Partitioning (Regression Trees)] [Recursive Partiti...] [2011-12-20 09:13:53] [74be16979710d4c4e7c6647856088456]
- R PD      [Recursive Partitioning (Regression Trees)] [] [2011-12-23 13:38:35] [80bca13c5f9401fbb753952fd2952f4a]
- R PD      [Recursive Partitioning (Regression Trees)] [] [2011-12-23 13:41:43] [80bca13c5f9401fbb753952fd2952f4a]
- R PD      [Recursive Partitioning (Regression Trees)] [] [2011-12-23 13:44:42] [80bca13c5f9401fbb753952fd2952f4a]
-   P         [Recursive Partitioning (Regression Trees)] [] [2011-12-23 18:52:09] [80bca13c5f9401fbb753952fd2952f4a]
Feedback Forum

Post a new message
Dataseries X:
210907	56	3	79	94
120982	56	4	58	103
176508	54	12	60	93
179321	89	2	108	103
123185	40	1	49	51
52746	25	3	0	70
385534	92	0	121	91
33170	18	0	1	22
101645	63	0	20	38
149061	44	5	43	93
165446	33	0	69	60
237213	84	0	78	123
173326	88	7	86	148
133131	55	7	44	90
258873	60	3	104	124
180083	66	9	63	70
324799	154	0	158	168
230964	53	4	102	115
236785	119	3	77	71
135473	41	0	82	66
202925	61	7	115	134
215147	58	0	101	117
344297	75	1	80	108
153935	33	5	50	84
132943	40	7	83	156
174724	92	0	123	120
174415	100	0	73	114
225548	112	5	81	94
223632	73	0	105	120
124817	40	0	47	81
221698	45	0	105	110
210767	60	3	94	133
170266	62	4	44	122
260561	75	1	114	158
84853	31	4	38	109
294424	77	2	107	124
101011	34	0	30	39
215641	46	0	71	92
325107	99	0	84	126
7176	17	0	0	0
167542	66	2	59	70
106408	30	1	33	37
96560	76	0	42	38
265769	146	2	96	120
269651	67	10	106	93
149112	56	6	56	95
175824	107	0	57	77
152871	58	5	59	90
111665	34	4	39	80
116408	61	1	34	31
362301	119	2	76	110
78800	42	2	20	66
183167	66	0	91	138
277965	89	8	115	133
150629	44	3	85	113
168809	66	0	76	100
24188	24	0	8	7
329267	259	8	79	140
65029	17	5	21	61
101097	64	3	30	41
218946	41	1	76	96
244052	68	5	101	164
341570	168	1	94	78
103597	43	1	27	49
233328	132	5	92	102
256462	105	0	123	124
206161	71	12	75	99
311473	112	8	128	129
235800	94	8	105	62
177939	82	8	55	73
207176	70	8	56	114
196553	57	2	41	99
174184	53	0	72	70
143246	103	5	67	104
187559	121	8	75	116
187681	62	2	114	91
119016	52	5	118	74
182192	52	12	77	138
73566	32	6	22	67
194979	62	7	66	151
167488	45	2	69	72
143756	46	0	105	120
275541	63	4	116	115
243199	75	3	88	105
182999	88	6	73	104
135649	46	2	99	108
152299	53	0	62	98
120221	37	1	53	69
346485	90	0	118	111
145790	63	5	30	99
193339	78	2	100	71
80953	25	0	49	27
122774	45	0	24	69
130585	46	5	67	107
112611	41	0	46	73
286468	144	1	57	107
241066	82	0	75	93
148446	91	1	135	129
204713	71	1	68	69
182079	63	2	124	118
140344	53	6	33	73
220516	62	1	98	119
243060	63	4	58	104
162765	32	2	68	107
182613	39	3	81	99
232138	62	0	131	90
265318	117	10	110	197
85574	34	0	37	36
310839	92	9	130	85
225060	93	7	93	139
232317	54	0	118	106
144966	144	0	39	50
43287	14	4	13	64
155754	61	4	74	31
164709	109	0	81	63
201940	38	0	109	92
235454	73	0	151	106
220801	75	1	51	63
99466	50	0	28	69
92661	61	1	40	41
133328	55	0	56	56
61361	77	0	27	25
125930	75	4	37	65
100750	72	0	83	93
224549	50	4	54	114
82316	32	4	27	38
102010	53	3	28	44
101523	42	0	59	87
243511	71	0	133	110
22938	10	0	12	0
41566	35	5	0	27
152474	65	0	106	83
61857	25	4	23	30
99923	66	0	44	80
132487	41	0	71	98
317394	86	1	116	82
21054	16	0	4	0
209641	42	5	62	60
22648	19	0	12	28
31414	19	0	18	9
46698	45	0	14	33
131698	65	0	60	59
91735	35	0	7	49
244749	95	2	98	115
184510	49	7	64	140
79863	37	1	29	49
128423	64	8	32	120
97839	38	2	25	66
38214	34	0	16	21
151101	32	2	48	124
272458	65	0	100	152
172494	52	0	46	139
108043	62	1	45	38
328107	65	3	129	144
250579	83	0	130	120
351067	95	3	136	160
158015	29	0	59	114
98866	18	0	25	39
85439	33	0	32	78
229242	247	4	63	119
351619	139	4	95	141
84207	29	11	14	101
120445	118	0	36	56
324598	110	0	113	133
131069	67	4	47	83
204271	42	0	92	116
165543	65	1	70	90
141722	94	0	19	36
116048	64	0	50	50
250047	81	0	41	61
299775	95	9	91	97
195838	67	1	111	98
173260	63	3	41	78
254488	83	10	120	117
104389	45	5	135	148
136084	30	0	27	41
199476	70	2	87	105
92499	32	0	25	55
224330	83	1	131	132
135781	31	2	45	44
74408	67	4	29	21
81240	66	0	58	50
14688	10	0	4	0
181633	70	2	47	73
271856	103	1	109	86
7199	5	0	7	0
46660	20	0	12	13
17547	5	0	0	4
133368	36	1	37	57
95227	34	0	37	48
152601	48	2	46	46
98146	40	0	15	48
79619	43	3	42	32
59194	31	6	7	68
139942	42	0	54	87
118612	46	2	54	43
72880	33	0	14	67
65475	18	2	16	46
99643	55	1	33	46
71965	35	1	32	56
77272	59	2	21	48
49289	19	1	15	44
135131	66	0	38	60
108446	60	1	22	65
89746	36	3	28	55
44296	25	0	10	38
77648	47	0	31	52
181528	54	0	32	60
134019	53	0	32	54
124064	40	1	43	86
92630	40	4	27	24
121848	39	0	37	52
52915	14	0	20	49
81872	45	0	32	61
58981	36	7	0	61
53515	28	2	5	81
60812	44	0	26	43
56375	30	7	10	40
65490	22	3	27	40
80949	17	0	11	56
76302	31	0	29	68
104011	55	6	25	79
98104	54	2	55	47
67989	21	0	23	57
30989	14	0	5	41
135458	81	3	43	29
73504	35	0	23	3
63123	43	1	34	60
61254	46	1	36	30
74914	30	0	35	79
31774	23	1	0	47
81437	38	0	37	40
87186	54	0	28	48
50090	20	0	16	36
65745	53	0	26	42
56653	45	0	38	49
158399	39	0	23	57
46455	20	0	22	12
73624	24	0	30	40
38395	31	0	16	43
91899	35	0	18	33
139526	151	0	28	77
52164	52	0	32	43
51567	30	2	21	45
70551	31	0	23	47
84856	29	1	29	43
102538	57	1	50	45
86678	40	0	12	50
85709	44	0	21	35
34662	25	0	18	7
150580	77	0	27	71
99611	35	0	41	67
19349	11	0	13	0
99373	63	1	12	62
86230	44	0	21	54
30837	19	0	8	4
31706	13	0	26	25
89806	42	0	27	40
62088	38	1	13	38
40151	29	0	16	19
27634	20	0	2	17
76990	27	0	42	67
37460	20	0	5	14
54157	19	0	37	30
49862	37	0	17	54
84337	26	0	38	35
64175	42	0	37	59
59382	49	0	29	24
119308	30	0	32	58
76702	49	0	35	42
103425	67	1	17	46
70344	28	0	20	61
43410	19	0	7	3
104838	49	1	46	52
62215	27	0	24	25
69304	30	6	40	40
53117	22	3	3	32
19764	12	1	10	4
86680	31	2	37	49
84105	20	0	17	63
77945	20	0	28	67
89113	39	0	19	32
91005	29	3	29	23
40248	16	1	8	7
64187	27	0	10	54
50857	21	0	15	37
56613	19	1	15	35
62792	35	0	28	51
72535	14	0	17	39




Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time4 seconds
R Server'Herman Ole Andreas Wold' @ wold.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 & 'Herman Ole Andreas Wold' @ wold.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=154588&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]'Herman Ole Andreas Wold' @ wold.wessa.net[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=154588&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=154588&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'Herman Ole Andreas Wold' @ wold.wessa.net







Confusion Matrix (predicted in columns / actuals in rows)
C1C2
C120714
C21553

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

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



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