FreeStatistics.org

Free Statistics

of Irreproducible Research!

Description of Statistical Computation

Author's title

Author*Unverified author*
R Software Modulerwasp_regression_trees1.wasp
Title produced by softwareRecursive Partitioning (Regression Trees)
Date of computationTue, 20 Dec 2011 04:13:53 -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/20/t1324372499s9gpan11mpewlz1.htm/, Retrieved Mon, 06 May 2024 02:04:51 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=157817, Retrieved Mon, 06 May 2024 02:04:51 +0000
QR Codes:

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

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 20:13:50] [b98453cac15ba1066b407e146608df68]
- R PD  [Recursive Partitioning (Regression Trees)] [Recursive Partiti...] [2011-12-13 17:55:41] [570fce4db58fd7864ac807c4286d6e49]
-   PD      [Recursive Partitioning (Regression Trees)] [Recursive Partiti...] [2011-12-20 09:13:53] [d41d8cd98f00b204e9800998ecf8427e] [Current]
Feedback Forum

Post a new message

Dataset

Dataseries X:
Download CSV
Histogram
Boxplots 
140824	269998	116	165	90
110459	176565	127	132	63
105079	222373	106	121	59
112098	218443	133	145	135
43929	157206	64	71	48
76173	70849	89	47	46
187326	482608	122	177	109
22807	33186	22	5	46
144408	207822	117	124	75
66485	211698	82	92	72
79089	292874	136	149	78
81625	235891	184	93	61
68788	156623	106	70	58
103297	344166	162	148	114
69446	211787	86	100	45
114948	369753	199	142	127
167949	292100	139	194	58
125081	315018	92	113	90
125818	168686	85	162	41
136588	256016	174	186	59
112431	269240	148	147	99
103037	425544	144	137	101
82317	161962	84	71	62
118906	189897	208	123	65
83515	200545	144	134	150
104581	203723	139	115	72
103129	267198	127	138	91
83243	263212	136	125	60
37110	155915	99	66	53
113344	326805	135	137	140
139165	271661	165	152	49
86652	197192	139	159	81
112302	318563	178	159	53
69652	97717	137	31	40
119442	346931	148	185	72
69867	273950	127	78	87
101629	411809	141	117	72
70168	208192	89	109	67
31081	115469	46	41	36
103925	328339	143	149	45
92622	324178	122	123	42
79011	157897	103	103	70
93487	192883	108	87	82
64520	173450	126	71	85
93473	153778	45	51	82
114360	445562	122	70	792
33032	78800	66	21	57
96125	208051	180	155	80
151911	323152	165	172	116
89256	175523	146	133	68
95671	213050	137	125	48
5950	24188	7	7	20
149695	372225	157	158	81
32551	65029	61	21	21
31701	101097	41	35	70
100087	269593	120	133	124
169707	302218	208	169	80
150491	315889	127	256	206
120192	322546	147	190	62
95893	246873	127	100	77
151715	360665	161	171	65
176225	296186	73	267	146
59900	232336	94	80	71
104767	254550	142	126	59
114799	228595	125	132	58
72128	216027	87	121	58
143592	187959	128	156	54
89626	227699	148	133	89
131072	229698	116	199	78
126817	166791	89	98	62
81351	239277	154	109	63
22618	73566	67	25	39
88977	242498	171	113	58
92059	187167	90	126	94
81897	178281	133	137	61
108146	349060	137	121	92
126372	323126	133	178	48
249771	206059	125	63	50
71154	184970	134	109	58
71571	168990	110	101	67
55918	153613	89	61	41
160141	429481	138	157	114
38692	145919	99	38	45
102812	280343	92	159	57
56622	80953	27	58	31
15986	148106	77	27	175
123534	146777	127	108	63
108535	336054	137	83	278
93879	307486	122	88	91
144551	178495	143	164	68
56750	251466	85	96	58
127654	230961	131	192	71
65594	175244	90	94	86
59938	261494	135	107	89
146975	301883	132	144	134
143372	189252	139	123	64
168553	222504	127	170	72
183500	278170	104	210	61
165986	367723	221	193	123
184923	392346	106	297	73
140358	281033	161	125	80
149959	273642	130	204	85
57224	186856	59	70	116
43750	43287	64	49	43
48029	185302	36	82	85
104978	203088	88	205	72
100046	259692	125	111	110
101047	301456	124	135	55
197426	119969	83	59	44
160902	153028	127	70	79
147172	306952	143	108	58
109432	297807	115	141	70
1168	23623	0	11	9
83248	175532	94	130	49
25162	61857	30	28	25
45724	163766	119	101	107
110529	384053	102	216	63
855	21054	0	4	2
101382	252805	77	97	67
14116	31961	9	39	22
89506	294609	137	119	152
135356	235069	157	118	78
116066	174862	146	41	112
144244	152043	84	107	47
8773	38214	21	16	52
102153	189451	139	69	108
117440	344802	168	160	110
104128	190943	163	158	61
134238	396160	167	161	134
134047	314212	145	165	120
279488	396712	175	246	111
79756	187992	137	89	49
66089	102424	100	49	55
102070	283392	150	107	149
146760	401260	163	182	155
154771	135936	137	16	103
165933	373146	149	173	142
64593	157429	112	90	76
92280	236370	135	140	83
67150	258959	114	142	185
128692	214338	45	126	69
124089	363154	120	123	117
125386	232339	115	239	63
37238	173260	78	15	37
140015	317676	136	170	56
150047	168994	179	123	122
154451	233293	118	151	52
156349	301585	147	194	64
0	1	0	0	0
6023	14688	0	5	0
0	98	0	0	0
0	455	0	0	0
0	0	0	0	0
0	0	0	0	0
84601	216803	88	122	58
68946	365230	115	173	109
0	0	0	0	0
0	203	0	0	0
1644	7199	0	6	0
6179	46660	13	13	7
3926	17547	4	3	3
52789	116678	76	35	89
0	969	0	0	0
100350	195592	63	72	46

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'Gwilym Jenkins' @ jenkins.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 & 'Gwilym Jenkins' @ jenkins.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=157817&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]'Gwilym Jenkins' @ jenkins.wessa.net[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=157817&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=157817&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'Gwilym Jenkins' @ jenkins.wessa.net






Confusion Matrix (predicted in columns / actuals in rows)
C1C2
C111911
C21519

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

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


Figures (Output of Computation)

Input Parameters & R Code

Parameters (Session):
par1 = 1 ; par2 = equal ; par3 = 2 ; 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')
}