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 computationThu, 15 Dec 2011 16:21:46 -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/15/t1323984200ecyd11039m10ek1.htm/, Retrieved Thu, 31 Oct 2024 23:15:11 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=155722, Retrieved Thu, 31 Oct 2024 23:15:11 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact128
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]
-   PD  [Recursive Partitioning (Regression Trees)] [Recursive partiti...] [2011-12-15 18:59:13] [15a5dd358825f04074b70fc847ec6454]
-           [Recursive Partitioning (Regression Trees)] [Recursive partiti...] [2011-12-15 21:21:46] [614dd89c388120cee0dd25886939832b] [Current]
-             [Recursive Partitioning (Regression Trees)] [Recursive partiti...] [2011-12-15 21:59:03] [15a5dd358825f04074b70fc847ec6454]
Feedback Forum

Post a new message
Dataseries X:
70	500	20	18	129404	22622	28
68	329	38	17	130358	73570	39
0	72	0	0	7215	1929	0
68	584	49	22	112861	36294	54
120	1100	76	30	219904	62378	80
120	1585	104	31	397355	167760	144
72	442	37	19	117604	52443	36
96	321	53	25	126737	57283	48
109	406	42	30	99729	36614	42
104	818	62	26	256310	93268	71
54	568	50	20	113066	35439	49
98	556	65	25	157228	72405	74
49	494	28	15	69952	24044	27
88	818	48	22	152673	55909	83
57	338	42	16	130642	44689	31
74	419	47	19	125769	49319	28
112	364	71	28	123467	62075	98
45	284	0	12	56232	2341	2
110	674	50	28	108330	40551	43
39	188	12	13	22762	11621	24
55	286	16	14	48554	18741	16
102	640	77	27	182081	84202	95
96	520	29	25	140857	15334	22
86	532	38	30	93773	28024	33
78	547	50	21	133398	53306	45
64	428	33	17	113933	37918	59
82	561	49	22	153851	54819	66
100	266	59	28	140711	89058	70
99	783	55	26	303804	103354	56
67	746	40	17	161651	70239	55
87	394	40	23	123344	33045	27
65	482	51	20	157640	63852	37
43	568	41	11	91279	30905	48
80	746	73	20	189374	24242	26
84	668	51	21	178768	78907	64
0	0	0	0	0	0	0
105	835	46	27	175403	36005	21
51	464	44	14	92342	31972	44
98	418	31	29	100023	35853	36
124	607	71	31	178277	115301	89
75	539	61	19	145062	47689	101
120	519	28	30	110980	34223	31
84	309	21	23	86039	43431	65
82	647	42	21	125481	52220	71
87	321	44	22	95535	33863	102
78	261	40	21	126456	46879	53
97	180	15	32	61554	23228	41
76	576	46	19	164752	42827	46
104	544	43	26	159121	65765	37
93	758	47	25	129362	38167	51
82	205	12	22	48188	14812	14
73	317	46	19	95461	32615	40
87	709	56	24	229864	82188	77
95	590	47	26	191094	51763	51
105	526	48	27	150640	59325	43
37	443	35	10	111388	48976	33
96	419	44	26	165098	43384	47
88	205	25	23	63205	26692	31
83	310	47	21	109102	53279	31
124	785	28	34	137303	20652	40
116	434	48	29	125304	38338	42
76	576	32	19	85332	36735	35
65	317	28	19	95808	42764	40
86	288	31	23	83419	44331	30
85	285	13	22	101723	41354	11
107	391	38	29	94982	47879	41
124	446	39	31	129700	103793	53
78	715	68	21	113325	52235	82
83	208	32	21	81518	49825	41
78	101	5	21	31970	4105	6
59	858	53	15	192268	58687	81
33	302	33	9	91086	40745	47
92	360	54	23	80820	33187	100
52	411	36	18	83261	14063	46
121	561	52	31	116290	37407	38
92	292	0	25	56544	7190	0
99	492	52	24	116173	49562	45
86	669	45	22	111488	76324	56
75	253	16	21	60138	21928	18
96	366	33	26	73422	27860	54
81	192	48	22	67751	28078	37
104	616	33	26	213351	49577	40
76	221	24	20	51185	28145	37
90	438	37	25	97181	36241	36
75	247	17	19	45100	10824	34
86	388	32	22	115801	46892	49
100	541	55	25	186310	61264	82
88	233	39	22	71960	22933	36
80	333	31	21	80105	20787	33
73	422	26	20	103613	43978	55
88	452	37	23	98707	51305	50
79	584	66	22	136234	55593	71
81	366	35	21	136781	51648	31
48	406	24	12	105863	30552	42
33	254	18	9	38775	23470	31
120	606	37	32	179997	77530	51
90	491	86	24	169406	57299	64
2	67	13	1	19349	9604	14
96	607	21	24	153069	34684	37
86	597	32	25	109510	41094	37
15	240	8	4	43803	3439	8
48	219	38	15	47062	25171	38
81	349	45	21	110845	23437	23
84	241	24	23	92517	34086	22
46	136	23	12	58660	24649	18
59	194	2	16	27676	2342	1
96	222	52	24	98550	45571	48
29	153	5	9	43646	3255	5
0	0	0	0	0	0	0
83	251	43	23	67312	30002	46
63	240	18	17	57359	19360	33
68	358	44	18	104330	43320	41
84	302	45	21	70369	35513	57
54	267	29	17	65494	23536	49
0	14	0	0	3616	0	0
0	0	0	0	0	0	0
75	287	32	20	143931	54438	45
87	476	65	26	117946	56812	78
104	509	26	26	131175	33838	46
80	243	24	20	84336	32366	25
3	292	7	1	43410	13	1
93	410	62	24	136250	55082	59
55	217	30	14	79015	31334	29
96	422	49	26	92937	16612	26
48	160	3	12	57586	5084	4
8	75	10	2	19764	9927	10
60	412	42	16	105757	47413	43
84	309	18	22	97213	27389	36
112	417	40	28	113402	30425	41
8	79	1	2	11796	0	0
0	25	0	0	7627	0	0
52	431	29	17	121085	33510	32
4	11	0	1	6836	0	0
57	564	46	17	139563	40389	53
0	6	5	0	5118	0	0
14	183	8	4	40248	6012	6
0	0	0	0	0	0	0
91	295	21	25	95079	22205	18
89	230	21	26	80763	17231	26
0	27	0	0	7131	0	0
0	14	0	0	4194	0	0
54	240	15	15	60378	11017	16
77	251	47	20	109173	46741	84
76	347	17	19	83484	39869	22




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

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







Confusion Matrix (predicted in columns / actuals in rows)
C1C2
C1648
C2072

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

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



Parameters (Session):
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')
}