.packageName <- "logistf"
#library(logistf)
#LOGISTF library by Meinhard Ploner, Daniela Dunkler, Harry Southworth, Georg Heinze, University of Vienna
#any comments to georg.heinze@univie.ac.at
#Version 27.11.2002

logistf <-
function(formula = attr(data, "formula"), data = sys.parent(), pl = TRUE, alpha = 0.05, 
	maxit = 25, maxhs = 5, epsilon = 0.0001, maxstep = 10, firth = TRUE, beta0)
{
	#n <- nrow(data)
	y <- as.vector(model.extract(model.frame(formula, data = data), response))
	n <- length(y)
	x <- model.matrix(formula, data = data)	## Model-Matrix

	k <- ncol(x)	## Anzahl Effekte

	if (dimnames(x)[[2]][1] == "(Intercept)")  { 
		int <- 1
		coltotest <- 2:k
	}

	else {
		int <- 0
		coltotest <-1:k
	}


	beta <- c(log((sum(y)/n)/(1 - sum(y)/n)), rep(0, k - 1))	
	if(!missing(beta0))
		beta[1] <- beta[1] - sum(x %*% beta0)/n
	iter <- 0
	pi <- as.vector(1/(1 + exp( - x %*% beta)))
	loglik <- sum(y * log(pi) + (1 - y) * log(1 - pi))
	if(firth) {
		XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	#### X' (W ^ 1/2)
		Fisher <- crossprod(t(XW2))	#### X' W  X
		loglik <- loglik + 0.5 * determinant(Fisher)$modulus[1]
	}
	repeat {
		iter <- iter + 1
		XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	#### X' (W ^ 1/2)
		Fisher <- crossprod(t(XW2))	#### X' W  X
		covs <- solve(Fisher)	### (X' W  X) ^ -1
		H <- crossprod(XW2, covs) %*% XW2
		if(firth)
			U.star <- crossprod(x, y - pi + diag(H) * (0.5 - pi))
		else U.star <- crossprod(x, y - pi)
		delta <- as.vector(covs %*% U.star)
		mx <- max(abs(delta))/maxstep
		if(mx > 1)
			delta <- delta/mx
		beta <- beta + delta
		loglik.old <- loglik
		for(halfs in 1:maxhs) {
## Half-Steps
			pi <- as.vector(1/(1 + exp( - x %*% beta)))
			loglik <- sum(y * log(pi) + (1 - y) * log(1 - pi))
			if(firth) {
				XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	
	#### X' (W ^ 1/2)
				Fisher <- crossprod(t(XW2))	#### X' W  X
				loglik <- loglik + 0.5 * determinant(Fisher)$modulus[1]
			}
			if(loglik > loglik.old)
				break
			beta <- beta - delta * 2^( - halfs)	
	##beta-Aenderung verkleinern
		}
		if(iter == maxit | sum(abs(delta)) <= epsilon)
			break
	}

	fit <- list(coefficients = beta, alpha = alpha, var = covs, df = (k-int), loglik = 
		logistftest(formula, data, test=coltotest)$loglik, iter = iter, n = n, terms = 
		colnames(x), y = y, formula = formula(formula), call=match.call())
	fit$linear.predictors <- as.vector(x %*% beta)
	if(firth)
		fit$method <- "Penalized ML"
	else fit$method <- "Standard ML"
	vars <- diag(covs)
	if(pl) {
		LL.0 <- loglik - qchisq(1 - alpha, 1)/2
		fit$ci.lower <- fit$ci.upper <- rep(0, k)
		for(i in 1:k) {
			fit$ci.lower[i] <- logistpl(x, y, beta, i, LL.0, maxit, maxhs, 
				epsilon, maxstep, firth, -1)$beta
			fit$ci.upper[i] <- logistpl(x, y, beta, i, LL.0, maxit, maxhs, 
				epsilon, maxstep, firth, 1)$beta
			fit$prob[i] <- logistftest(formula, data, test = i, 0, maxit, 
				maxhs, epsilon, maxstep, firth)$prob
		}
		fit$method.ci <- "Profile Likelihood"
	}
	else {
		fit$prob <- 1 - pchisq((beta^2/vars), 1)
		fit$method.ci <- "Wald"
		fit$ci.lower <- as.vector(beta + qnorm(alpha/2) * vars^0.5)
		fit$ci.upper <- as.vector(beta + qnorm(1 - alpha/2) * vars^0.5)
	}
	names(fit$prob) <- names(fit$ci.upper) <- names(fit$ci.lower) <- names(fit$
		coefficients) <- dimnames(covs)[[1]]
	attr(fit, "class") <- c("logistf")
	fit
}

####################################################################
################# logistfplot ######################################
#################             ######################################

logistfplot <- function(formula = attr(data, "formula"), data = sys.parent(), which, pitch = 0.05, limits,
					alpha = 0.05, maxit = 25, maxhs = 5, epsilon = 0.0001, maxstep = 10, firth = TRUE,
					legends = TRUE){

# by MP, 06.02.01
# which  ... righthand formula des zu plottenden Term (z.B. ~B oder ~A:D)
# pitch  ... distances between points in std's
# limits ... vector of MIN & MAX in std's, default=extremes of both CI's
#            +- 0.5 std. of beta
#

# Next line added by Harry Southworth, 22/10/02.
 if (missing(which)) stop("You must specify which (a one-sided formula).")

 fit <- logistf(formula = formula, data = data, alpha = alpha, maxit = maxit,
				maxhs = maxhs, epsilon = epsilon, maxstep = maxstep, firth = firth, pl = TRUE)
 coefs <- coef(fit) ## "normale" Koeffizienten
 covs <- fit$var ## Varianzen
# n <- nrow(data)
 resp <- model.extract(model.frame(formula, data = data), response)
 mm <- model.matrix(formula, data = data) ## Model-Matrix
 n <- nrow(mm)
 cov.name <- labels(mm)[[2]]
 k <- ncol(mm) #--> nun Berechnungen fuer Schleife
 cov.name2 <- labels(model.matrix(which, data = data))[[2]] ## Label des Test-Fakt.
 pos <- match(cov.name2, cov.name) ## Position des Testfakors
 std.pos <- diag(fit$var)[pos]^0.5
 if(missing(limits)) {
  lim.pl <- (c(fit$ci.lower[pos], fit$ci.upper[pos]) - coef(fit)[pos])/std.pos
  limits <- c(min(qnorm(alpha/2), lim.pl[1]) - 0.5, max(qnorm(1 - alpha/2), lim.pl[2]) + 0.5)
 }

 limits <- c(floor(limits[1]/pitch) * pitch, ceiling(limits[2]/pitch) * pitch)

 knots <- seq(limits[1], limits[2], pitch)
 nn <- length(knots)
 res <- matrix(knots, nn, 3) #initialisiere Werte
 dimnames(res) <- list(1:nn, c("std", cov.name2, "log-likelihood"))
 for(i in 1:nn) {
  res[i, 2] <- coefs[pos] + covs[pos, pos]^0.5 * knots[i]
  if(i == 1)
   xx <- logistftest(formula, data, test = which, values = res[i, 2], maxit=maxit,
			maxhs = maxhs, epsilon = epsilon, maxstep = maxstep, firth = firth)
  else xx <- logistftest(formula, data, test = which, values = res[i, 2], maxit = maxit,
		    maxhs = maxhs, epsilon = epsilon, maxstep = maxstep, firth = firth, beta0 = xx$beta) ##verwende vorige Lsung!

  res[i, 3] <- xx$loglik[1]
 }

 #### Graphischer Output:

 my.par <- act.par <- par()
 my.par$mai[3] <- 1.65 * act.par$mai[3]
 if(legends) my.par$mai[1] <- 2 * act.par$mai[1]
 par(mai = my.par$mai)
 ind <- (1:nn)[round(4 * res[, 1]) == round(4 * res[, 1], 10)]
 if(length(ind) == 0) ind <- 1:nn
 pp <- max(res[, 3]) - 0.5 * res[, 1]^2

 plot(res[, -1], type = "l", xlab = paste("BETA of", cov.name2)) ##Profile likelihood

 #lines(res[,2], pp, lty=4)  #<<<Wald approximative profile lik. >>>

 points(res[res[, 1] == 0, 2], max(res[, 3])) ##Maximum of likelihood

 segments(min(res[, 2]), max(res[, 3]) - 0.5 * qchisq(1 - alpha, 1),
				max(res[, 2]), max(res[, 3]) - 0.5 * qchisq(1 - alpha, 1), lty = 3) ##refer.line
				
 yy <- par("usr")[4] - (par("usr")[4] - par("usr")[3]) * c(0.9, 0.95)

 segments(coef(fit)[pos] - qnorm(alpha/2) * std.pos, yy[1], coef(fit)[pos] - qnorm(1 - alpha/2) *
			std.pos, yy[1], lty = 6) ##Wald-CI
 segments(fit$ci.lower[pos], yy[2], fit$ci.upper[pos], yy[2], lty = 8) ##prof.pen.lik.-CI

 axis(side = 3, at = res[ind, 2], labels = res[ind, 1])

 mtext("distance from maximum in standard deviations", side = 3, line = 3)

 if(legends)   key(par("usr")[1], par("usr")[3] - 0.24 * (par("usr")[4] - par("usr")[3]),
					lines = list(type = c("l", "l", "p", "l", "l")), text = c("Profile penalizedlikelihood",
				   paste(100 * (1 - alpha), "% - reference line", sep = ""),
				   "Maximum of Likelihood", "Wald - confidence interval",
				   "Profile penalized likelihood CI"), lty = c(1, 3, 1, 6, 8), border = FALSE,
					columns = 2, between.columns = 1)
 par(mai = act.par$mai)
 title("Profile likelihood")
 invisible(res)
}

print.logistf <-
function(x, ...)
{
# x ... object of class logistf
 print(x$call)
 cat("Model fitted by", x$method)
 cat("\nConfidence intervals and p-values by", x$method.ci, "\n\n")
 out <- cbind(x$coefficients, diag(x$var)^0.5, x$ci.lower,
x$ci.upper, qchisq(1 - x$
  prob, 1), x$prob)
 dimnames(out) <- list(names(x$coefficients), c("coef", "se(coef)",
paste(c("lower", "upper"),
  1 - x$alpha), "z", "p"))
 if(x$method.ci != "Wald")
  dimnames(out)[[2]][5] <- "Chisq"
 print(out)
 LL <- 2 * diff(x$loglik)
 cat("\nLikelihood ratio test=", LL, " on ", x$df, " df, p=", 1 -
pchisq(LL, x$df), ", n=",
  x$n, "\n\n", sep = "")
 invisible(x)
}

summary.logistf <- function(object, ...){
# object ... object of class logistf
 print(object$call)
 cat("\nModel fitted by", object$method)
 cat("\nConfidence intervals and p-values by", object$method.ci, "\n\n")
 out <- cbind(object$coefficients, diag(object$var)^0.5, object$ci.lower,
object$ci.upper, qchisq(1 - object$
  prob, 1), object$prob)
 dimnames(out) <- list(names(object$coefficients), c("coef", "se(coef)",
paste(c("lower", "upper"),
  1 - object$alpha), "z", "p"))
 if(object$method.ci != "Wald")
  dimnames(out)[[2]][5] <- "Chisq"
 print(out)
 LL <- 2 * diff(object$loglik)
 cat("\nLikelihood ratio test=", LL, " on ", object$df, " df, p=", 1 -
pchisq(LL, object$df), ", n=",
  object$n, sep = "")
 wald.z <- t(coef(object)) %*% solve(object$var) %*% coef(object)
 cat("\nWald test =", wald.z, "on", object$df, "df, p =", 1 - pchisq(wald.z,
object$df))
 cat("\n\nCovariance-Matrix:\n")
 print(object$var)
 invisible(object)
}

####################################################################
################# logistftest ######################################
#################             ######################################


print.logistftest <- function(x, ...){
# x ... object of class logistftest
 print(x$call)
 cat("Model fitted by", x$method, "\n\nFactors fixed as follows:\n")
 print(x$testcov)
 LL <- 2 * diff(x$loglik)
 out <- c(x$loglik[1], x$loglik[2], LL/2)
 names(out) <- c("Restricted model", "Full model", "difference")
 cat("\nLikelihoods:\n")
 print(out)
 cat("\nLikelihood ratio test=", LL, " on ", x$df, " df, p=", x$prob, "\n", sep = "")
 invisible(x)
}


logistftest <-
function(formula = attr(data, "formula"), data = sys.parent(), test, values, maxit = 
	25, maxhs = 5, epsilon = 0.0001, maxstep = 10, firth = TRUE, beta0)
{
	#n <- nrow(data)
	y <- model.extract(model.frame(formula, data = data), response)
	n <- length(y)
	x <- model.matrix(formula, data = data)	## Model-Matrix
	cov.name <- labels(x)[[2]]
	k <- ncol(x)
	if (dimnames(x)[[2]][1] == "(Intercept)")  { 
		int <- 1
		coltotest <- 2:k
	}

	else {
		int <- 0
		coltotest <-1:k
	}

	beta <- c(log((sum(y)/n)/(1 - sum(y)/n)), rep(0, k - 1))	
##berechne Startwerte
	iter <- 0
	loglik <- rep(0, 2)
	pi <- as.vector(1/(1 + exp( - x %*% beta)))
	if(missing(beta0)) {
################## coxphfplot braucht dies nicht! ###
		loglik[2] <- sum(y * log(pi) + (1 - y) * log(1 - pi))
		if(firth) {
			XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	
#### X' (W ^ 1/2)
			Fisher <- crossprod(t(XW2))	#### X' W  X
			loglik[2] <- loglik[2] + 0.5 * determinant(Fisher)$modulus[1]
		}
		repeat {
			iter <- iter + 1
			XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	
#### X' (W ^ 1/2)
			Fisher <- crossprod(t(XW2))	#### X' W  X
			covs <- solve(Fisher)	### (X' W  X) ^ -1
			H <- crossprod(XW2, covs) %*% XW2
			if(firth)
				U.star <- crossprod(x, y - pi + diag(H) * (0.5 - pi))
			else U.star <- crossprod(x, y - pi)
			delta <- as.vector(covs %*% U.star)
			mx <- max(abs(delta))/maxstep
			if(mx > 1)
				delta <- delta/mx
			beta <- beta + delta
			loglik.old <- loglik[2]
			for(halfs in 1:maxhs) {
## 5 Half-Steps
				pi <- as.vector(1/(1 + exp( - x %*% beta)))
				loglik[2] <- sum(y * log(pi) + (1 - y) * log(1 - pi))
				if(firth) {
				  XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	
	#### X' (W ^ 1/2)
				  Fisher <- crossprod(t(XW2))	#### X' W  X
				  loglik[2] <- loglik[2] + 0.5 * determinant(Fisher)$
				    modulus[1]
				}
				if(loglik[2] > loglik.old)
				  break
				beta <- beta - delta * 2^( - halfs)	
	##beta-Aenderung verkleinern
			}
			if(iter == maxit | sum(abs(delta)) <= epsilon)
				break
		}
	}
########################################################
## Labels der Test-Fakt.
	if(missing(test))
		test <- coltotest
	if(is.vector(test))
		cov.name2 <- cov.name[test]
	else cov.name2 <- labels(model.matrix(test, data = data))[[2]]
	pos <- match(cov.name2, cov.name)	## Position der Testfakt.
	OK <- !is.na(pos)
	pos <- pos[OK]
	cov.name2 <- cov.name2[OK]
	k2 <- length(cov.name2)	## Anzahl Faktoren
	if(!missing(beta0))
		offset <- beta0
	else offset <- rep(0, k)	## Vektor der fixierten Werte
	if(!missing(values))
		offset[pos] <- values
	beta <- offset	########################################
	iter <- 0
	pi <- as.vector(1/(1 + exp( - x %*% beta)))
	loglik[1] <- sum(y * log(pi) + (1 - y) * log(1 - pi))
	if(firth) {
		XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	#### X' (W ^ 1/2)
		Fisher <- crossprod(t(XW2))	#### X' W  X
		loglik[1] <- loglik[1] + 0.5 * determinant(Fisher)$modulus[1]
	}
	repeat {
		if(k2 == k) break	## -> Overall Test
		iter <- iter + 1
		XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	#### X' (W ^ 1/2)
		Fisher <- crossprod(t(XW2))	#### X' W  X
		covs <- solve(Fisher)	### (X' W  X) ^ -1
		H <- crossprod(XW2, covs) %*% XW2
		if(firth)
			U.star <- crossprod(x, y - pi + diag(H) * (0.5 - pi))
		else U.star <- crossprod(x, y - pi)
		XX.XW2 <- crossprod(x[,  - pos, drop = FALSE], diag(pi * (1 - pi))^0.5)	
	#### Teil von X' (W ^ 1/2)
		XX.Fisher <- crossprod(t(XX.XW2))	#### Teil von  X' W  X
		XX.covs <- matrix(0, k, k)
		XX.covs[ - pos,  - pos] <- solve(XX.Fisher)	
	### aufblasen der Cov-Matrix
		delta <- as.vector(XX.covs %*% U.star)
		mx <- max(abs(delta))/maxstep
		if(mx > 1)
			delta <- delta/mx
		beta <- beta + delta
		loglik.old <- loglik[1]
		for(halfs in 1:maxhs) {
## Half-Steps
			pi <- as.vector(1/(1 + exp( - x %*% beta)))
			loglik[1] <- sum(y * log(pi) + (1 - y) * log(1 - pi))
			if(firth) {
				XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	
	#### X' (W ^ 1/2)
				Fisher <- crossprod(t(XW2))	#### X' W  X
				loglik[1] <- loglik[1] + 0.5 * determinant(Fisher)$
				  modulus[1]
			}
			if(loglik[1] > loglik.old)
				break
			beta <- beta - delta * 2^( - halfs)	
	##beta-Aenderung verkleinern
		}
		if(iter == maxit | sum(abs(delta)) <= epsilon)
			break
	}
#######################
	offset[ - pos] <- NA
	names(offset) <- cov.name
	fit <- list(testcov = offset, loglik = loglik, df = k2, prob = 1 - pchisq(2 * 
		diff(loglik), k2), call = match.call(), beta = beta)
	if(firth)
		fit$method <- "Penalized ML"
	else fit$method <- "Standard ML"
	attr(fit, "class") <- "logistftest"
	fit
}


logistpl <- function(x, y, beta, i, LL.0, maxit, maxhs, epsilon, 
	maxstep, firth, which = -1)
{
## which -1...left, +1...right
	k <- length(beta)
	iter <- 0
	pi <- as.vector(1/(1 + exp( - x %*% beta)))
	XW2 <- crossprod(x, diag(pi * (1 - pi))^0.5)	
	#### X' (W ^ 1/2)
	Fisher <- crossprod(t(XW2))	#### X' W  X
	loglik <- sum(y * log(pi) + (1 - y) * log(1 - 
		pi))
	if(firth)
		loglik <- loglik + 0.5 * determinant(Fisher)$modulus[1]
	repeat {
		iter <- iter + 1
		covs <- solve(Fisher)
		H <- crossprod(XW2, covs) %*% XW2
		if(firth)
			U.star <- crossprod(x, y - pi + 
				diag(H) * (0.5 - pi))
		else U.star <- crossprod(x, y - pi)
		V.inv <-  - covs
		lambda <- which * ((2 * ((LL.0 - loglik
			) + 0.5 * crossprod(U.star, 
			V.inv) %*% U.star))/V.inv[i, i]
			)^0.5
		delta <-  - V.inv %*% (U.star + lambda *
 
			diag(k)[i,  ])
		mx <- max(abs(delta))/maxstep
		if(mx > 1)
			delta <- delta/mx
		beta <- beta + delta
		loglik.old <- loglik
		pi <- as.vector(1/(1 + exp( - x %*% 
			beta)))
		loglik <- sum(y * log(pi) + (1 - y) * 
			log(1 - pi))
		if(firth) {
			XW2 <- crossprod(x, diag(pi * (
				1 - pi))^0.5)	
	#### X' (W ^ 1/2)
			Fisher <- crossprod(t(XW2))	
	#### X' W  X
			loglik <- loglik + 0.5 * 
				determinant(Fisher)$
				modulus[1]
		}
		if(iter == maxit | abs(loglik - LL.0) <=
 
			epsilon)
			break
	}
	list(beta = beta[i], LL = loglik)
}

.First.lib <- function(...)
	cat("LOGISTF library by Meinhard Ploner, Daniela Dunkler, Harry Southworth, Georg Heinze, University of Vienna\nVersion 27November2002\n")

