FreeStatistics.org

Free Statistics

of Irreproducible Research!

Description of Statistical Computation

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 computationFri, 23 Dec 2011 02:49:54 -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/23/t13246266093kmogwspch9iau4.htm/, Retrieved Mon, 29 Apr 2024 21:06:53 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=160172, Retrieved Mon, 29 Apr 2024 21:06:53 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact121

Tree of Dependent Computations

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-23 07:49:54] [44862125718ce971d51d71f1796e585f] [Current]
Feedback Forum

Post a new message

Dataset

Dataseries X:
Download CSV
Histogram
Boxplots 
140824	73	279055	95	96
110459	74	212083	68	75
105079	83	233939	64	70
112098	106	222117	139	134
43929	54	179751	51	72
76173	28	70849	46	8
187326	131	568125	118	169
22807	19	33186	46	1
144408	62	227332	79	88
66485	48	258874	76	98
79089	119	357366	82	112
81625	130	263934	66	125
68788	83	204003	60	57
103297	85	368577	117	139
69446	88	269455	50	87
114948	187	395936	133	176
167949	76	335567	63	114
125081	171	423110	100	121
125818	58	182016	44	103
136588	88	267365	65	135
112431	73	279428	103	123
103037	111	508849	103	99
82317	47	206722	62	74
118906	58	200004	70	103
83515	133	257139	159	158
104581	137	270815	78	116
103129	133	296850	101	102
83243	90	307100	73	132
37110	58	184160	58	62
113344	79	393860	147	150
139165	89	327660	54	143
86652	82	252512	84	50
112302	102	373013	56	141
69652	47	115602	45	48
119442	103	430118	87	141
69867	56	273950	87	83
101629	128	428077	77	112
70168	91	251349	72	79
31081	34	115658	36	33
103925	209	395417	51	152
92622	85	343783	44	126
79011	77	207083	75	85
93487	82	214456	87	84
64520	67	182398	97	68
93473	84	157164	90	50
114360	157	459455	860	101
33032	42	78800	57	20
96125	84	217932	99	101
151911	123	368086	120	150
89256	67	215843	76	118
95676	80	244765	56	99
5950	24	24188	20	8
149695	333	399093	94	88
32551	17	65029	21	21
31701	64	101097	70	30
100087	65	305640	133	98
169707	90	369627	86	163
150491	204	367127	224	132
120192	152	374193	65	161
95893	89	270099	86	89
151715	151	391871	70	160
176225	121	315924	148	139
59900	124	291391	72	104
104767	93	295075	59	103
114799	81	280018	67	66
72128	71	267432	58	163
143592	140	215924	60	93
89626	157	256641	105	85
131072	87	260919	84	150
126817	73	182961	63	143
81351	74	256967	67	107
22618	32	73566	39	22
88977	93	272362	60	85
92059	61	220707	94	91
81897	68	228835	67	131
108146	91	371391	96	140
126372	104	398210	54	156
249771	110	220401	54	81
71154	70	229333	62	137
71571	71	217623	71	102
55918	53	200046	50	72
160141	131	483074	117	161
38692	71	145943	45	30
102812	108	295224	61	120
56622	25	80953	31	49
15986	61	180759	175	71
123534	61	179344	70	76
108535	221	415550	284	85
93879	128	369093	95	146
144551	106	180679	72	165
56750	104	299505	63	89
127654	84	292260	75	168
65594	67	199481	90	48
59938	78	282361	89	149
146975	89	329281	138	75
165904	48	234577	68	107
169265	67	297995	80	116
183500	88	305984	65	165
165986	163	416463	130	155
184923	118	414359	85	165
140358	142	297080	83	121
149959	70	318283	89	156
57224	197	222281	116	86
43750	14	43287	43	13
48029	86	223456	87	113
104978	159	261598	80	114
100046	60	299566	132	133
101047	95	321797	59	169
197426	89	174736	50	30
160902	102	169579	87	121
147172	77	354041	62	82
109432	90	303273	70	148
1168	13	23668	9	12
83248	79	196743	54	146
25162	25	61857	25	23
45724	53	207339	113	84
110529	123	431443	63	163
855	16	21054	2	4
101382	52	252805	67	81
14116	22	31961	22	18
89506	124	360401	157	118
135356	76	251240	79	76
116066	96	187003	113	55
144244	58	180842	50	62
8773	34	38214	52	16
102153	55	278173	113	98
117440	84	358276	115	137
104128	66	211775	78	50
134238	89	445926	135	152
134047	99	348017	120	163
279488	133	441946	122	142
79756	42	210700	54	77
66089	46	126320	63	59
102070	361	316128	162	94
146760	198	466139	162	128
154771	62	162279	107	63
165933	139	412099	146	127
64593	83	173802	77	59
92280	54	292443	87	118
67150	100	283913	192	110
128692	126	244802	75	45
124089	125	387072	131	96
125386	92	246963	67	128
37238	63	173260	37	41
140015	108	346748	61	146
150047	58	176654	127	147
154451	92	264767	58	121
156349	112	314070	71	185
0	0	1	0	0
6023	10	14688	0	4
0	1	98	0	0
0	2	455	0	0
0	0	0	0	0
0	0	0	0	0
84601	92	284420	72	85
68946	164	410509	123	157
0	0	0	0	0
0	4	203	0	0
1644	5	7199	0	7
6179	20	46660	7	12
3926	5	17547	3	0
52789	46	121550	106	37
0	2	969	0	0
100350	74	242258	53	62

Tables (Output of Computation)





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=160172&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=160172&T=0

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

As an alternative you can also use a QR Code:  
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
C1739
C23448

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

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

As an alternative you can also use a QR Code:  
QR Code


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

Confusion Matrix (predicted in columns / actuals in rows)
C1C2
C1739
C23448


Figures (Output of Computation)

Input Parameters & R Code

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')
}