.packageName <- "PK"
AUC <- function(conc, time, exact=NA, numintp=2, numtail=3, prev=0) {		     

	# function for linear interpolation/extrapolation
	linpol <- function(conc, time, exact){
		parms <- lm(conc~time)$coef
		return(parms[2] * exact + parms[1])
	}
         
	# function to add parts of auc and aumc
	add <- function(time, conc) {
		auc <- 0; aumc <- 0
		len <- length(conc)
		timediff <- diff(time)
		auc <- 0.5*sum(timediff*rowSums(cbind(conc[2:len],conc[1:(len-1)])))
		aumc <- 0.5*sum(timediff*rowSums(cbind(conc[2:len]*time[2:len],conc[1:(len-1)]*time[1:(len-1)])))
		return(list(auc=auc, aumc=aumc))
	}

	# check input parameters and exclude missing values
	if (!is.vector(time) || !is.vector(conc)) {stop('argument time and/or conc invalid')}
	if (length(time) != length(conc)) {stop('time and conc differ in length')}
	if (any(time < 0)) {stop('at least one timepoint below zero')}
	if (numtail < 2) {stop('number of points for tail area correction must be greater than 1')}
	if (numintp < 2) {stop('number of points for interpolation must be greater than 1')}
	data <- na.omit(data.frame(conc, time))
	
	# check input parameters and remove values below zero
	if (prev < 0) {stop('pre-dosing value must be greater 0')}
	if (prev > 0) {data$conc <- data$conc - prev}
	if (any(data$conc < 0)) {
		data$conc[data$conc < 0] <- NA
		warning('concentration below zero were omitted')
		data <- na.omit(data)	
	}
	if (nrow(data) < 4) {stop('a minimum of 4 observations are required')}

	# use data as vectors
	data <- data[order(data$time),]
	n <- nrow(data)
	time <- data$time
	conc <- data$conc
	 	                
	# calculate observed auc and aumc
	auc.observed  <- add(time=time, conc=conc)$auc        
	aumc.observed <- add(time=time, conc=conc)$aumc

	# calculate auc from 0 to infinity and aumc from 0 to infinity by using last numtail points above zero
	tail <- subset(data.frame(conc, time), conc > 0)
	tail <- tail[(nrow(tail)-numtail+1) : nrow(tail), ]	

	lamda <- as.real(lm(log(tail$conc)~tail$time)$coef[2])*(-1)
	auc.infinity <- auc.observed + conc[n]/lamda 
	aumc.infinity <- aumc.observed + (conc[n]*time[n])/lamda + conc[n]/lamda**2
	if(lamda < 0){
		warning('tail area correction incorrect due to increasing concentration of last numtail points')	
		auc.infinity <- NA
		aumc.infinity <- NA
	}

	# calculate auc and aumc from 0 to exact where exact must be greater than time[n-1]
	auc.interpol <- NA; aumc.interpol <- NA	
	if (!is.na(exact) & exact > time[n-1] & exact == time[n]) { # special case
		auc.interpol <- auc.observed; aumc.interpol <- aumc.observed
	}	
	if (!is.na(exact) & exact > time[n-1] & exact != time[n]) {
		conc[n] <- linpol(conc=conc[(n-numintp+1):n], time=time[(n-numintp+1):n], exact=exact)
		time[n] <- exact
		if(conc[n] < 0){warning('interpolated value below zero')}
		auc.interpol <- add(time=time, conc=conc)$auc
		aumc.interpol <- add(time=time, conc=conc)$aumc		
	} 

	# define output object
	res <- data.frame(AUC=c(as.real(auc.observed), as.real(auc.interpol), as.real(auc.infinity)), 
		AUMC=c(as.real(aumc.observed), as.real(aumc.interpol), as.real(aumc.infinity)))
	rownames(res) <- c('observed', 'interpolated', 'infinity')
	return(res)      
}
biexp <- function(conc, time, prev=0, tol=1E-9, maxit=500){

	# get start values for optim by curve peeling
	curve.peeling <- function(x, y){
	
		n <- length(y)	
		res <- NA
		Fmin <- Inf
	
		for(i in (n-3):3) { 
			parms1 <- tryCatch(lm(log(y[(i+1):n])~x[(i+1):n])$coef, error=function(e) rep(NA,2))
			if(!is.na(all(parms1))){
				b2 <- parms1[2]*(-1)
				a2 <- exp(parms1[1])
				ynew <- abs(y - a2*exp(-b2*x))
				parms2 <- tryCatch(lm(log(ynew[1:i])~x[1:i])$coef, error=function(e) rep(NA,2))
				if(!is.na(all(parms2))){
					b1 <- parms2[2]*(-1)
					a1 <- exp(parms2[1])
					F <- sum((y-(a1*exp(-b1*x)+a2*exp(-b2*x)))*(y-(a1*exp(-b1*x)+a2*exp(-b2*x))))
					if (F < Fmin && all(b1>0,b2>0,b1>b2)) {
						res <- as.real(c(a1=a1, dl=log(b1)-log(b2), a2=a2, b2=log(b2)))
						Fmin <- F
					}

				}
			}

		}

		if (is.na(all(res))){
			parms <- tryCatch(lm(log(y)~x), error=function(e) rep(NA,2))
			if(!is.na(all(parms))){
				b <- parms$coef[2]*(-1)
				a <- exp(parms$coef[1])
				F <- sum(parms$resid*parms$resid)
				if (b > 0){
					res <- as.real(c(a=a, b=log(b)))
					Fmin <- F
				}
			}
		}
		return(res)
	}	



	# check input parameters and exclude missing values
	if (!is.vector(time) || !is.vector(conc)) {stop('argument time and/or conc invalid')}
	if (length(time) != length(conc)) {stop('time and conc differ in length')}
	if (any(time < 0)) {stop('at least one timepoint below zero')}
	data <- na.omit(data.frame(conc, time))
	
	# check input parameters and remove values below or equal to zero
	if (prev < 0) {stop('pre-dosing value must be greater 0')}
	if (prev > 0) {data$conc <- data$conc - prev}
	if (any(data$conc <= 0)) {
		data$conc[data$conc <= 0] <- NA
		warning('concentration below or equal to zero were omitted')
		data <- na.omit(data)	
	}
	if (nrow(data) < 4) {stop('a minimum of 4 observations are required')}

	# use data as vectors
	n <- nrow(data)
	time <- data$time
	conc <- data$conc

	# loss function for biexp
	biexploss <- function(par){
		a1 <- par[1]
		dl <- par[2]
		a2 <- par[3]
		b2 <- par[4]
		sum((conc - a1*exp(-(exp(b2) + exp(dl))*time) - a2*exp(-exp(b2)*time))^2)
	}

	# loss function for single exp
	singleloss <- function(par){
		a <- par[1]
		b <- par[2]
		sum((conc - a*exp(-exp(b)*time))^2)
	}

	# get starting values
	start <- curve.peeling(y=conc, x=time)
	type <- as.character(length(start))

	# check sum of squared residuals using estimates obtained by curve peeling
	switch(type,
		"4" = {sum.resid <- biexploss(par=start)},
		"2" = {sum.resid <- singleloss(par=start)},
	)
	if(sum.resid == Inf){type <- "1"}

	switch(type, 
		"4" = {sol <- optim(par=start, fn=biexploss,  method=c("Nelder-Mead"), control=list(reltol=tol, maxit=maxit))$par	
			b1 <- (exp(sol[4]) + exp(sol[2]))
			a1 <- sol[1]
			b2 <- exp(sol[4])
			a2 <- sol[3]},
		"2" = {sol <- optim(par=start, fn=singleloss,  method=c("Nelder-Mead"), control=list(reltol=tol, maxit=maxit))$par
			b1 <- exp(sol[2]) 
			a1 <- sol[1]
			b2 <- exp(sol[2])
			a2 <- sol[1]},
		"1" = {a1 <- NA; b1 <- NA; a2<- NA; b2 <- NA},
	)

	# calculate halflife
	init.hl <- log(2) / b1
	term.hl <- log(2) / b2

	# format output object
	parms <- data.frame(initial=as.real(c(init.hl, b1, a1)),
			   terminal=as.real(c(term.hl, b2, a2)))
	rownames(parms) <- c('halflife', 'slope', 'intercept')
	res <- list(parms=parms, conc=conc, time=time, method="biexp")
	class(res) <- 'halflife'
	return(res)
}







lee <- function(time, conc, points=3, prev=0, method=c("lad", "ols", "hub", "npr"), longer.terminal=TRUE) {

	# function for lad regression
	lad <- function(y, x) {
		resid <- Inf
		for (i in 1:length(y)) {
			for (j in 1:length(y)) {
				if ((i != j) & (x[j] != x[i])) {
					slope <- (y[j] - y[i]) / (x[j] - x[i])
					intct <- y[j] - slope*x[j] 
					absresid <- abs(y - (intct + slope*x))
					if (sum(absresid) < resid) {
						mad <- median(absresid)
						resid <- sum(absresid)
						k <- slope
						d <- intct
					}
				}
			}
		}
		return(list(k=as.real(k), d=as.real(d), resid=as.real(resid), mad=as.real(mad)))
	}
	
	# function for huber m regression 
	# acknowledgment to werner engl
	#sigmafactor and kfactor removed from function arguments
	hub <- function(y, x, mad=lad(y=y,x=x)$mad) { 
		hubloss <- function(kd) { # Huber loss for k=kd[1], d=kd[2]
			absresid <- abs(y-kd[[1]]*x-kd[[2]])
			khuber <- 2.2245*mad
			#end edit
			sum(ifelse(absresid < khuber, absresid*absresid, khuber*(2*absresid-khuber))) 
		}
		start <- as.vector(c(lm(y~x)$coef[2], lm(y~x)$coef[1]))
		res <- optim(start, hubloss, method="Nelder-Mead", control=c(reltol=1e-9))		
		return(list(k = as.real(res$par[1]), d = as.real(res$par[2]), resid = as.real(res$value)))		
	}

	# function for nonparametric regression
	npr <- function(y, x) { 

		weighted.median <- function(w, x) { 
			data <- data.frame(x, w)
			data <- data[order(data$x),]
			i <- 1; while(sum(data$w[1:i]) <= 0.5) {i <- i + 1}
			ifelse (sum(data$w[1:i-1]) == 0.5, return((data$x[i-1]+data$x[i])/2), return(data$x[i]))
		}

		total <- 0
		for(i in 1:(length(y)-1)) {
			for(j in (i+1):length(y)){total <- total + abs(x[i]-x[j])}
		}

		l <- 1
		b <- array(1:(length(y)*(length(y)-1)/2))
		w <- array(1:(length(y)*(length(y)-1)/2))
		for(i in 1:(length(y)-1)) {
			for(j in (i+1):length(y)){	
				b[l] <- ((y[i]-y[j])/(x[i]-x[j]))
				w[l] <- abs(x[i]-x[j]) / total			 
				l <- l + 1									
			}
		}

		data <- subset(data.frame(w=as.vector(w), b=as.vector(b)), b != Inf & b != -Inf)
		k <- weighted.median(w=data$w, x=data$b)
		d <- median(y-k*x)
		e <- y-k*x-d
		resid <- sum((rank(e) - 1/2*(length(y)+1))*e)
		return(list(k=as.real(k), d=as.real(d), resid=as.real(resid)))
	}
	
	# function for internal ols regression
	ols <- function(y, x){
		res <- lm(y~x)
		return(list(k = as.real(res$coef[2]), 
	    		d = as.real(res$coef[1]), 
	    		resid = as.real(sum(res$resid*res$resid))))

	}

	# check input parameters and exclude missing values
	method = match.arg(method)
	if (!is.vector(time) || !is.vector(conc)) {stop('argument time and/or conc invalid')}
	if (length(time) != length(conc)) {stop('time and conc differ in length')}
	if (any(time < 0)) {stop('at least one timepoint below zero')}
	if (!is.logical(longer.terminal)) {stop('argument longer.terminal invalid')}
	if (points < 2) {stop('not enough points in terminal phase')}
	data <- na.omit(data.frame(conc, time))
	
	# check input parameters and remove values below or equal to zero
	if (prev < 0) {stop('pre-dosing value must be greater 0')}
	if (prev > 0) {data$conc <- data$conc - prev}
	if (any(data$conc <= 0)) {
		data$conc[data$conc <= 0] <- NA
		warning('concentration below or equal to zero were omitted')
		data <- na.omit(data)	
	}
	if (nrow(data) < 4) {stop('a minimum of 4 observations are required')}
  
	# transform data by logarithm at base 10
	data <- data[order(data$time),]
	n <- nrow(data)
 	conc <- log10(data$conc)
	time <- data$time
	
	# calculate parameters of one-phase model
	switch(method, 
		"lad"={model <- lad(y=conc, x=time)}, 
		"ols"={model <- ols(y=conc, x=time)}, 
		"hub"={model <- hub(y=conc, x=time, mad=lad(y=conc, x=time)$mad)},
		"npr"={model <- npr(y=conc, x=time)
	},)

	# inital halflife = terminal halflife for one-phase model
	final.term.model <- model
	final.init.model <- model
	resid <- model$resid
	final.chgpt <- NA

	# check special cases
	if(model$k >= 0) {
		resid <- Inf
		final.term.model$k <- NA
		final.init.model$k <- NA
	}
		
	# calculate parameters of two-phase models
	if (points > n-2) {stop('not enough points for inital phase')}
	for (i in 2:(n-points)) {

		init.conc <- conc[1:i]
		init.time <- time[1:i]
		term.conc <- conc[(i+1):n]
		term.time <- time[(i+1):n]

		# calculate parameters of two-phase model
		switch(method, 
			"lad"={
				init.model <- lad(y=init.conc, x=init.time)
				term.model <- lad(y=term.conc, x=term.time)
		},	"ols"={
				init.model <- ols(y=init.conc, x=init.time)
				term.model <- ols(y=term.conc, x=term.time)
		}, 	"hub"={
				init.model <- hub(y=init.conc, x=init.time, mad=lad(y=init.conc, x=init.time)$mad)
				term.model <- hub(y=term.conc, x=term.time, mad=lad(y=term.conc, x=term.time)$mad)
		}, 	"npr"={
				init.model <- npr(y=init.conc, x=init.time)
				term.model <- npr(y=term.conc, x=term.time)
		},)


		# check changeover criteria and for negative slopes 
		lower <- data$time[i]
		upper <- data$time[i+1]
		chgpt <- (init.model$d - term.model$d) / (term.model$k - init.model$k)
		if (!(chgpt <= lower | chgpt >= upper) &
			(term.model$k < 0) & (init.model$k < 0)) {

			if(!longer.terminal){
  				if (sum(term.model$resid, init.model$resid) < resid) {
					final.init.model <- init.model
					final.term.model <- term.model
					final.chgpt <- as.real(chgpt)
					resid <- sum(term.model$resid, init.model$resid)
				}  
			}

			if(longer.terminal){
  				if (init.model$k <= term.model$k & sum(term.model$resid, init.model$resid) < resid) {
					final.init.model <- init.model
					final.term.model <- term.model
					final.chgpt <- as.real(chgpt)
					resid <- sum(term.model$resid, init.model$resid)
				}  
			}


		}
	}	

	init.hl <- -log10(2)/final.init.model$k
	term.hl <- -log10(2)/final.term.model$k
	if(is.na(init.hl) | is.na(term.hl)){warning('No model evaluated')}

	# format output objects
	parms <- data.frame(initial=as.real(c(init.hl, final.init.model$k, final.init.model$d)),
			terminal=as.real(c(term.hl, final.term.model$k, final.term.model$d)))
	rownames(parms) <- c('halflife', 'slope', 'intercept')
	res <- list(parms=parms, chgpt=as.real(final.chgpt), conc=10**conc, time=time, method='lee')
	class(res) <- 'halflife'
	return(res)
	
}



# plot function for halflife objects 
plot.halflife <- function(x, xlab='Time', ylab='Concentration', main='Half-life Estimation', xlim=NULL, ylim=NULL, ...) {

	init.k <- x$parms[2,1] 
	init.d <- x$parms[3,1] 
	term.k <- x$parms[2,2] 
	term.d <- x$parms[3,2] 

	if(is.null(xlim)){xlim <- c(min(x$time), max(x$time))}
	if(is.null(ylim)){ylim <- c(min(x$conc), max(x$conc))}

	plot(x$time, x$conc, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, main=main, ...)

	switch(x$method,
		"lee"={
			if (is.na(x$chgpt)) {x$chgpt <- min(x$time)}
			plot(function(x) 10**(init.k*x+init.d), xlim[1], x$chgpt, add=TRUE)
			plot(function(x) 10**(term.k*x+term.d), x$chgpt, xlim[2], add=TRUE) 	
	},	"biexp"={
			if (init.k == term.k){
				plot(function(x) init.d*exp(-init.k*x), xlim[1], xlim[2], add=TRUE)
			}
			if (init.k != term.k){
				plot(function(x) init.d*exp(-init.k*x)+term.d*exp(-term.k*x), xlim[1], xlim[2], add=TRUE)
			}
	},)

		
}	

