Repository of Reproducible Computations

Free Statistics

of Irreproducible Research!

Author's title

Author

*Unverified author*

R Software Module

rwasp_logisticregression.wasp

Title produced by software

Bias-Reduced Logistic Regression

Date of computation

Mon, 04 Jun 2018 23:02:08 +0200

Cite this page as follows

Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?v=date/2018/Jun/04/t15281462761ditm2kemecu007.htm/, Retrieved Mon, 06 May 2024 08:08:33 +0200

Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=, Retrieved Mon, 06 May 2024 08:08:33 +0200

QR Codes:

Paste this QR Code to cite your computation.

Original text written by user:

IsPrivate?

This computation is private

User-defined keywords

Estimated Impact

Dataseries X:

Download CSV

Histogram

Boxplots

skutecznosc;RF 1, cryo 0 ;Wiek;EF;LA - AP;średnia przed;EKG po;różnica;%;niew serc;nadcisni;płec;wiek>65;wiek>75;udar;ch.naczyn;cukrzyca;chdsvasc
1;1;55;65;34;62;75;13;20,96774194;0;1;0;0;0;0;0;0;1
1;1;62;65;45;76;74;-2;-2,631578947;0;1;1;0;0;0;0;0;2
1;0;67;65;45;53;65;12;22,64150943;0;1;0;1;0;0;0;0;2
1;1;45;;;61;64;3;4,918032787;0;0;0;0;0;0;0;0;0
1;0;53;62;33;56;80;24;42,85714286;0;0;0;0;0;0;0;0;0
1;1;37;66;40;65;81;16;24,61538462;0;1;0;0;0;0;0;0;1
1;1;55;48;36;63;63;0;0;0;1;0;0;0;0;0;0;1
1;0;62;60;32;69;76;7;10,14492754;0;0;0;0;0;0;0;0;0
1;0;53;58;44;43;67;24;55,81395349;0;0;0;0;0;0;0;0;0
1;0;40;52;46;82;85;3;3,658536585;0;0;0;0;0;0;0;0;0
1;1;52;;;62;83;21;33,87096774;0;1;0;0;0;0;0;0;1
1;0;44;58;35;56;75;19;33,92857143;0;0;0;0;0;0;0;0;0
1;0;67;66;38;71;71;0;0;0;1;0;1;0;0;0;0;2
1;0;70;60;39;47;65;18;38,29787234;0;1;0;0;0;0;0;0;1
1;1;60;58;35;65;66;1;1,538461538;0;1;0;0;0;0;0;0;1
1;0;66;60;40;67;64;-3;-4,47761194;0;1;0;1;0;0;0;1;3
1;0;32;60;33;67;84;17;25,37313433;0;0;0;0;0;0;0;0;0
1;1;63;63;42;54;79;25;46,2962963;0;1;0;0;0;0;0;0;1
1;0;60;61;38;53;72;19;35,8490566;0;0;0;0;0;0;0;0;0
1;0;34;58;32;81;88;7;8,641975309;0;0;0;0;0;0;0;0;0
1;0;50;57;31;48;64;16;33,33333333;0;0;0;0;0;0;0;0;0
1;0;55;62;43;60;64;4;6,666666667;0;1;0;0;0;0;0;0;1
1;1;62;61;34;61;67;6;9,836065574;0;0;0;0;0;0;0;1;1
1;1;64;45;40;77;80;3;3,896103896;0;1;0;0;0;0;0;0;1
1;0;39;53;42;49;51;2;4,081632653;0;0;0;0;0;0;0;0;0
1;0;48;56;36;51;83;32;62,74509804;0;0;0;0;0;0;0;0;0
1;0;49;58;34;54;70;16;29,62962963;0;0;0;0;0;0;0;0;0
1;1;54;57;35;66;63;-3;-4,545454545;0;1;0;0;0;0;0;0;1
1;0;56;56;35;61;70;9;14,75409836;0;0;0;0;0;0;0;0;0
1;0;57;65;39;56;82;26;46,42857143;0;1;0;0;0;0;0;0;1
1;0;28;32;65;85;93;8;9,411764706;0;0;0;0;0;0;0;0;0
1;0;50;65;44;68;87;19;27,94117647;0;0;0;0;0;0;0;0;0
1;0;40;65;36;66;74;8;12,12121212;0;0;0;0;0;0;0;0;0
1;0;49;50;38;52;66;14;26,92307692;0;0;0;0;0;1;0;0;1
1;0;65;57;37;45;57;12;26,66666667;0;1;0;1;0;0;0;0;2
1;1;30;65;31;65;104;39;60;0;0;0;0;0;0;0;0;0
1;1;64;;;62;88;26;41,93548387;1;1;1;0;0;0;0;0;3
1;0;60;58;38;64;76;12;18,75;0;1;1;0;0;0;0;1;3
1;0;64;65;45;53;64;11;20,75471698;0;1;1;0;0;0;0;0;2
1;0;72;56;41;51;54;3;5,882352941;0;1;0;1;0;0;1;0;3
1;1;56;75;42;44;51;7;15,90909091;0;0;0;0;0;0;0;0;0
1;1;63;60;44;62;58;-4;-6,451612903;0;1;0;0;0;0;0;0;1
1;1;52;68;36;60;81;21;35;0;0;0;0;0;0;0;0;0
1;1;58;71;35;50;74;24;48;0;0;0;0;0;0;1;0;1
1;1;64;66;35;58;76;18;31,03448276;0;0;1;0;0;0;0;0;1
1;1;59;59;46;48;51;3;6,25;0;0;0;0;0;0;0;0;0
1;1;38;75;33;43;68;25;58,13953488;0;1;0;0;0;0;0;0;1
1;1;44;75;36;57;81;24;42,10526316;0;0;0;0;0;0;0;0;0
1;1;57;62;32;62;90;28;45,16129032;0;0;1;0;0;0;0;0;1
1;1;58;59;41;43;73;30;69,76744186;0;0;0;0;0;0;0;0;0
1;0;64;68;41;52;75;23;44,23076923;0;1;1;0;0;0;0;0;2
1;0;56;73;39;55;79;24;43,63636364;0;1;0;0;0;0;0;0;1
1;1;32;56;37;61;85;24;39,3442623;0;0;0;0;0;0;0;0;0
1;0;56;63;42;63;90;27;42,85714286;0;1;0;0;0;0;0;1;2
1;0;60;59;41;59;86;27;45,76271186;0;1;0;0;0;0;0;0;1
1;0;50;58;31;55;79;24;43,63636364;0;0;1;0;0;0;0;0;1
1;0;52;74;40;54;72;18;33,33333333;0;1;0;0;0;0;0;1;2
1;0;60;65;43;60;68;8;13,33333333;0;1;0;0;0;0;0;0;1
1;0;38;65;34;63;87;24;38,0952381;0;0;0;0;0;0;0;0;0
1;1;75;60;43;57;75;18;31,57894737;0;1;1;1;0;0;0;0;3
1;0;62;66;28;57;78;21;36,84210526;0;1;1;0;0;0;0;0;2
1;0;65;59;34;51;65;14;27,45098039;0;1;1;0;0;0;0;0;2
1;0;60;77;37;54;77;23;42,59259259;0;0;0;0;0;0;0;0;0
1;0;27;62;38;56;60;4;7,142857143;0;0;0;0;0;0;0;0;0
1;1;60;59;40;44;49;5;11,36363636;0;0;0;0;0;0;0;0;0
1;1;37;64;34;68;76;8;11,76470588;0;1;0;0;0;0;0;0;1
1;1;59;64;32;62;105;43;69,35483871;0;1;1;0;0;0;0;1;3
1;0;55;60;42;59;85;26;44,06779661;0;1;0;0;0;0;0;0;1
1;1;54;67;44;51;63;12;23,52941176;0;1;0;0;0;0;0;0;1
1;1;39;74;38;54;84;30;55,55555556;0;0;0;0;0;0;0;0;0
1;0;44;73;37;54;73;19;35,18518519;0;0;0;0;0;0;0;0;0
1;1;47;70;41;60;65;5;8,333333333;0;1;0;0;0;0;0;0;1
1;0;54;62;41;62;79;17;27,41935484;0;1;0;0;0;0;1;0;2
1;1;44;66;40;57;70;13;22,80701754;0;0;0;0;0;0;0;0;0
0;1;46;60;49;46;57;11;23,91304348;0;0;0;0;0;0;0;0;0
0;0;52;;;58;61;3;5,172413793;0;0;0;0;0;0;0;0;0
0;0;65;60;34;48;66;18;37,5;0;1;0;1;0;0;1;0;3
0;1;65;65;48;57;71;14;24,56140351;0;1;0;1;0;0;1;1;4
0;1;48;55;44;65;73;8;12,30769231;0;1;0;0;0;0;0;0;1
0;0;53;50;37;54;77;23;42,59259259;0;0;0;0;0;0;0;0;0
0;1;47;50;31;60;76;16;26,66666667;0;0;0;0;0;0;0;0;0
0;1;56;59;35;61;69;8;13,1147541;0;0;0;0;0;0;0;0;0
0;0;57;65;31;48;72;24;50;0;0;0;0;0;0;0;0;0
0;1;59;64;43;43;57;14;32,55813953;0;0;0;0;0;0;0;0;0
0;1;56;64;38;59;72;13;22,03389831;0;1;0;0;0;0;0;0;1
0;1;52;78;43;73;74;1;1,369863014;0;0;0;0;0;0;0;0;0
0;1;62;64;43;73;65;-8;-10,95890411;0;1;1;0;0;0;0;0;2
0;1;47;63;27;70;75;5;7,142857143;0;0;0;0;0;0;0;0;0
0;1;66;61;41;55;66;11;20;0;0;0;1;0;0;0;0;1
0;1;58;73;41;56;56;0;0;0;1;1;0;0;0;0;1;3
0;1;58;65;38;64;87;23;35,9375;0;0;0;0;0;0;0;0;0
0;0;60;60;42;51;74;23;45,09803922;0;1;0;0;0;0;0;0;1
0;0;40;76;38;53;78;25;47,16981132;0;0;0;0;0;0;0;0;0
0;1;61;74;41;53;80;27;50,94339623;0;1;0;0;0;0;0;0;1
0;1;59;64;40;40;68;28;70;0;0;0;0;0;0;0;0;0
0;1;64;70;43;49;64;15;30,6122449;0;1;0;0;0;0;1;0;2
0;0;62;75;40;42;51;9;21,42857143;0;1;0;0;0;0;1;0;2
0;1;64;55;41;61;73;12;19,67213115;0;0;0;0;0;0;0;0;0
0;1;61;59;40;64;57;-7;-10,9375;0;1;1;0;0;0;0;1;3
0;0;60;65;34;57;63;6;10,52631579;0;0;0;0;0;0;0;0;0
0;1;77;69;40;52;62;10;19,23076923;0;1;1;1;0;0;1;1;5
0;0;63;59;34;49;59;10;20,40816327;0;1;0;0;0;0;0;0;1
0;0;62;61;35;53;52;-1;-1,886792453;0;0;0;0;0;0;0;0;0
0;0;70;65;38;52;62;10;19,23076923;0;0;0;1;0;0;0;0;1
0;0;57;75;45;56;61;5;8,928571429;0;1;1;0;0;0;0;1;3
0;1;74;70;37;57;62;5;8,771929825;0;1;1;1;0;0;0;0;3
0;1;59;70;47;69;67;-2;-2,898550725;0;0;0;0;0;0;0;0;0
0;1;67;69;39;60;71;11;18,33333333;0;0;1;1;0;0;0;0;2
0;0;55;61;40;58;70;12;20,68965517;0;0;0;0;0;0;0;0;0
0;1;53;65;46;54;59;5;9,259259259;0;0;0;0;0;0;0;0;0
0;1;65;61;42;45;54;9;20;0;0;0;0;0;0;0;0;0

Summary of computational transaction
Raw Input	view raw input (R code)
Raw Output	view raw output of R engine
Computing time	0 seconds
R Server	Big Analytics Cloud Computing Center

\begin{tabular}{lllllllll}
\hline
Summary of computational transaction \tabularnewline
Raw Input view raw input (R code)  \tabularnewline
Raw Outputview raw output of R engine  \tabularnewline
Computing time0 seconds \tabularnewline
R ServerBig Analytics Cloud Computing Center \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=&T=0

[TABLE]
[ROW]

Summary of computational transaction[/C][/ROW] [ROW]

Raw Input[/C]

view raw input (R code) [/C][/ROW] [ROW]

Raw Output[/C]

view raw output of R engine [/C][/ROW] [ROW]

Computing time[/C]

0 seconds[/C][/ROW] [ROW]

R Server[/C]

Big Analytics Cloud Computing Center[/C][/ROW] [/TABLE] Source: https://freestatistics.org/blog/index.php?pk=&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=&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 Input	view raw input (R code)
Raw Output	view raw output of R engine
Computing time	0 seconds
R Server	Big Analytics Cloud Computing Center

Parameters (Session):

Parameters (R input):

R code (references can be found in the software module):

library(brglm)
roc.plot <- function (sd, sdc, newplot = TRUE, ...)
{
sall <- sort(c(sd, sdc))
sens <- 0
specc <- 0
for (i in length(sall):1) {
sens <- c(sens, mean(sd >= sall[i], na.rm = T))
specc <- c(specc, mean(sdc >= sall[i], na.rm = T))
}
if (newplot) {
plot(specc, sens, xlim = c(0, 1), ylim = c(0, 1), type = 'l',
xlab = '1-specificity', ylab = 'sensitivity', main = 'ROC plot', ...)
abline(0, 1)
}
else lines(specc, sens, ...)
npoints <- length(sens)
area <- sum(0.5 * (sens[-1] + sens[-npoints]) * (specc[-1] -
specc[-npoints]))
lift <- (sens - specc)[-1]
cutoff <- sall[lift == max(lift)][1]
sensopt <- sens[-1][lift == max(lift)][1]
specopt <- 1 - specc[-1][lift == max(lift)][1]
list(area = area, cutoff = cutoff, sensopt = sensopt, specopt = specopt)
}
roc.analysis <- function (object, newdata = NULL, newplot = TRUE, ...)
{
if (is.null(newdata)) {
sd <- object$fitted[object$y == 1]
sdc <- object$fitted[object$y == 0]
}
else {
sd <- predict(object, newdata, type = 'response')[newdata$y ==
1]
sdc <- predict(object, newdata, type = 'response')[newdata$y ==
0]
}
roc.plot(sd, sdc, newplot, ...)
}
hosmerlem <- function (y, yhat, g = 10)
{
cutyhat <- cut(yhat, breaks = quantile(yhat, probs = seq(0,
1, 1/g)), include.lowest = T)
obs <- xtabs(cbind(1 - y, y) ~ cutyhat)
expect <- xtabs(cbind(1 - yhat, yhat) ~ cutyhat)
chisq <- sum((obs - expect)^2/expect)
P <- 1 - pchisq(chisq, g - 2)
c('X^2' = chisq, Df = g - 2, 'P(>Chi)' = P)
}
x <- as.data.frame(t(y))
r <- brglm(x)
summary(r)
rc <- summary(r)$coeff
try(hm <- hosmerlem(y[1,],r$fitted.values),silent=T)
try(hm,silent=T)
bitmap(file='test0.png')
ra <- roc.analysis(r)
dev.off()
te <- array(0,dim=c(2,99))
for (i in 1:99) {
threshold <- i / 100
numcorr1 <- 0
numfaul1 <- 0
numcorr0 <- 0
numfaul0 <- 0
for (j in 1:length(r$fitted.values)) {
if (y[1,j] > 0.99) {
if (r$fitted.values[j] >= threshold) numcorr1 = numcorr1 + 1 else numfaul1 = numfaul1 + 1
} else {
if (r$fitted.values[j] < threshold) numcorr0 = numcorr0 + 1 else numfaul0 = numfaul0 + 1
}
}
te[1,i] <- numfaul1 / (numfaul1 + numcorr1)
te[2,i] <- numfaul0 / (numfaul0 + numcorr0)
}
bitmap(file='test1.png')
op <- par(mfrow=c(2,2))
plot((1:99)/100,te[1,],xlab='Threshold',ylab='Type I error', main='1 - Specificity')
plot((1:99)/100,te[2,],xlab='Threshold',ylab='Type II error', main='1 - Sensitivity')
plot(te[1,],te[2,],xlab='Type I error',ylab='Type II error', main='(1-Sens.) vs (1-Spec.)')
plot((1:99)/100,te[1,]+te[2,],xlab='Threshold',ylab='Sum of Type I & II error', main='(1-Sens.) + (1-Spec.)')
par(op)
dev.off()
load(file='createtable')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'Coefficients of Bias-Reduced Logistic Regression',5,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Variable',header=TRUE)
a<-table.element(a,'Parameter',header=TRUE)
a<-table.element(a,'S.E.',header=TRUE)
a<-table.element(a,'t-stat',header=TRUE)
a<-table.element(a,'2-sided p-value',header=TRUE)
a<-table.row.end(a)
for (i in 1:length(rc[,1])) {
a<-table.row.start(a)
a<-table.element(a,labels(rc)[[1]][i],header=TRUE)
a<-table.element(a,rc[i,1])
a<-table.element(a,rc[i,2])
a<-table.element(a,rc[i,3])
a<-table.element(a,2*(1-pt(abs(rc[i,3]),r$df.residual)))
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'Summary of Bias-Reduced Logistic Regression',2,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Deviance',1,TRUE)
a<-table.element(a,r$deviance)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Penalized deviance',1,TRUE)
a<-table.element(a,r$penalized.deviance)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Residual Degrees of Freedom',1,TRUE)
a<-table.element(a,r$df.residual)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'ROC Area',1,TRUE)
a<-table.element(a,ra$area)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Hosmer–Lemeshow test',2,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Chi-square',1,TRUE)
phm <- array('NA',dim=3)
for (i in 1:3) { try(phm[i] <- hm[i],silent=T) }
a<-table.element(a,phm[1])
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Degrees of Freedom',1,TRUE)
a<-table.element(a,phm[2])
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'P(>Chi)',1,TRUE)
a<-table.element(a,phm[3])
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,'Fit of Logistic Regression',4,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Index',1,TRUE)
a<-table.element(a,'Actual',1,TRUE)
a<-table.element(a,'Fitted',1,TRUE)
a<-table.element(a,'Error',1,TRUE)
a<-table.row.end(a)
for (i in 1:length(r$fitted.values)) {
a<-table.row.start(a)
a<-table.element(a,i,1,TRUE)
a<-table.element(a,y[1,i])
a<-table.element(a,r$fitted.values[i])
a<-table.element(a,y[1,i]-r$fitted.values[i])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable2.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'Type I & II errors for various threshold values',3,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Threshold',1,TRUE)
a<-table.element(a,'Type I',1,TRUE)
a<-table.element(a,'Type II',1,TRUE)
a<-table.row.end(a)
for (i in 1:99) {
a<-table.row.start(a)
a<-table.element(a,i/100,1,TRUE)
a<-table.element(a,te[1,i])
a<-table.element(a,te[2,i])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable3.tab')

Free Statistics

Description of Statistical Computation

Tree of Dependent Computations

Dataset

Tables (Output of Computation)

Figures (Output of Computation)

Input Parameters & R Code