.packageName <- "gld"
dgl <- function(x,lambda1=0,lambda2=1,lambda3,lambda4,param="fmkl",
  inverse.eps=1e-8,max.iterations=500)
{
# Check the parameters
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param)) {
        stop(paste("The parameter values", lambda1, lambda2, lambda3, lambda4,
"\ndo not produce a proper distribution with the",param,
"parameterisation - see \ndocumentation for gl.check.lambda"))
        }
# calculate u=F(x) numerically, then use qdgl
# Unless x is outside the range, then density should be zero
extreme<-qgl(c(0,1),lambda1,lambda2,lambda3,lambda4,param)
# It may be better to change this to simply  
# (x <= extreme[2])*(x >= extreme[1])
outside.range <- !as.logical((x<=extreme[2])*(x>=extreme[1]))
u <- pgl(x,lambda1,lambda2,lambda3,lambda4,param,inverse.eps,
  max.iterations)
dens <- qdgl(u,lambda1,lambda2,lambda3,lambda4,param)
dens[outside.range] <- 0
dens
}

pgl <- function(q,lambda1=0,lambda2=1,lambda3,lambda4,param="fmkl",
    inverse.eps=1e-8,max.iterations=500)
{
# Thanks to Steve Su, <s.su@qut.edu.au>, for improvements to this code
# Check the parameters
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param)) {
	stop(paste("The parameter values", lambda1, lambda2, lambda3,lambda4,
    	"\ndo not produce a proper distribution with the",param,
    	"parameterisation - see \ndocumentation for gl.check.lambda"))
    	} 
jr <- q; jr[sort.list(q)] <- seq(along=q) 
order.x<-order(q) 
xx<-sort(q) 
# xx has the sorted data, and jr & order.x the information to get back to the
# original order.
extreme<-qgl(c(inverse.eps,1-inverse.eps),lambda1,lambda2,lambda3,lambda4,param)
max.e<-extreme[2]
min.e<-extreme[1]
ind.min<-xx<=min.e
ind.max<-xx>=max.e 
# This simpler comparison works here because we are using inverse.eps as our
# tolerance
q<-xx[as.logical((xx<max.e)*(xx>min.e))] 
# We only want to calculate the probabilities for q values inside the support
length.of.vector <- length(q) 
# Need a blank u to send to C
u <- 0*q 
result <- switch(param, 
	freimer=, # allows for alternate expressions 
	frm=, # allows for alternate expressions 
	FMKL=, 
	fmkl=.C("gl_fmkl_distfunc",lambda1,lambda2,lambda3,lambda4, 
		as.double(0),as.double(1),inverse.eps,
		as.integer(max.iterations),as.double(q),as.double(u),
		as.integer(length.of.vector),PACKAGE="gld"), 
    	ramberg=, # Ramberg & Schmeiser 
    	ram=, 
    	RS=, 
    	rs=.C("gl_rs_distfunc",lambda1,lambda2,lambda3,lambda4, 
    		as.double(0),as.double(1),inverse.eps,max.iterations, 
    		as.double(q),as.double(u),as.integer(length.of.vector),
		PACKAGE="gld"), 
    	stop("Error: Parameterisation must be either fmkl or rs") 
    	) # closes "switch" 
if (!(is.numeric(result[[1]]))){ 
	stop("Values for quantiles outside range. This shouldn't happen") 
} 
u <- result[[10]] 
xx[as.logical((xx<max.e)*(xx>min.e))]<-u 
xx[ind.min]<-0 
xx[ind.max]<-1 
# Revert to the original order of the dataset: 
xx[jr] 
} 
plotgld <- function(lambda1 = 0, lambda2 = 1, lambda3, lambda4, param =
"fmkl", new.plot = TRUE, truncate = 0, bnw = FALSE, col.or.type = 1, granularity = 4000, 
xlab = NULL, ylab=NULL, quant.probs = seq(0,1,.25),...)
{
	if (is.null(xlab)){xlab <- "x"}
	u <- seq(from = 0, to = 1, by = 1/granularity)
	# Only difference across parameterisations is calculating the 
	# quantiles and density
	quantiles <- qgl(u, lambda1, lambda2, lambda3, lambda4,param)
	density <- qdgl(u,lambda1,lambda2,lambda3,lambda4,param)
	if(truncate > 0) {
		if(new.plot) {
			if (is.null(ylab)){
				ylab <- paste( "probability density (values below", deparse(substitute(truncate)), "not shown)")
			}
			if(bnw) {
				plot(quantiles[density > truncate], 
				density[density > truncate], type = "l", 
				xlab = xlab, ylab = ylab, lty = col.or.type,...)
			}
			else {
				plot(quantiles[density > truncate], 
				density[density > truncate], type = "l", 
				xlab = xlab, ylab = ylab, col = col.or.type,...)
			}

		}
		else {
			if(bnw) {
				lines(quantiles[density > truncate], density[
				  density > truncate], lty = col.or.type)
			}
			else {
				lines(quantiles[density > truncate], density[
				  density > truncate], col = col.or.type)
			}
		}
	}
	else {
		if(new.plot) {
			if (is.null(ylab)){
				ylab <- "probability density"
			}
			if(bnw) {
				plot(quantiles, density, type = "l", xlab = xlab,ylab = ylab, lty=col.or.type, ...) 	
			}
			else {
				plot(quantiles, density, type = "l", xlab =
xlab,ylab = ylab, col=col.or.type, ...) 	
			}
		}
		else {
			if(bnw) {
				lines(quantiles, density, lty = col.or.type)
			}
			else {
				lines(quantiles, density, col = col.or.type)
			}
		}
	}
	if (!is.null(quant.probs)){quantile(quantiles,quant.probs) } 
}

plotglc <- function(lambda1 = 0, lambda2 = 1, lambda3, lambda4,param="fmkl", granularity=4000,
xlab="x",ylab="cumulative probability",...)
{
	u <- seq(from = 1/granularity, to = 1 - 1/granularity, length = 
		granularity - 1)
	x <- qgl(u,lambda1,lambda2,lambda3,lambda4,param)
	plot(x, u, pch = ".",xlab=xlab,ylab=ylab,...)
}
gl.check.lambda <- function(lambda1,lambda2,lambda3,lambda4,param="fmkl")
# Checks to see that the lambda values given are allowed.
{
# Check all the parameters are finite
if (sum(is.finite(c(lambda1,lambda2,lambda3,lambda4)))<4) 
	{ return(FALSE)
	}
param <- switch(param,  
# Different tests apply for each parameterisation
	freimer=,  # allows for alternate expressions
	frm=,  # allows for alternate expressions
	FMKL=,
	fmkl={
	if (lambda2<=0) {ret <- FALSE}
	else {ret <- TRUE}
	},
	ramberg=, # Ramberg & Schmeiser
	ram=,
	RS=,
	rs={
	if (lambda3*lambda4>0) { # regions 3 and 4 
				 # all values of lambda 3 and lambda 4 OK
				 # check lambda 2
		if ((lambda3>0)&(lambda4>0)) { # region 3 - l2 >0
			if (lambda2<=0) {ret <- FALSE}
			else {ret <- TRUE}
			}
		if ((lambda3<0)&(lambda4<0)) { # region 4 - l2 <0
			if (lambda2>=0) {ret <- FALSE}
			else {ret <- TRUE}
			}
		}	
	else { 	# other quadrants - lambda 2 must be negative, and lambda3 
		# lambda 4 values need checking.
		if (lambda2>=0) {return(FALSE)}
		# Rectangular regions where RS is not defined 
		if ((lambda3>0)&(lambda3<1)&(lambda4<0)) {return(FALSE)}
		if ((lambda4>0)&(lambda4<1)&(lambda3<0)) {return(FALSE)}
		# Different here because there are a 
		# number of ways in which the parameters can fail.
		# 
		# Curved regions where RS is not defined
		# change to shorter var names
		lc <- lambda3
		ld <- lambda4
		if ((lambda3>-1)&(lambda3<0)&(lambda4>1)) {  # region 5 or not?
			if ( ((1-lc)^(1-lc)*(ld-1)^(ld-1))/((ld-lc)^(ld-lc)) > -lc/ld )	
				{return(FALSE)}
			else 	{return(TRUE)}
			}
		# Second curved region 
		if ((lambda4>-1)&(lambda4<0)&(lambda3>1)) {  # region 6 or not?
			if ( ((1-ld)^(1-ld)*(lc-1)^(lc-1))/((lc-ld)^(lc-ld)) > -ld/lc )
				{return(FALSE)}
			else 	{return(TRUE)}
			}
		# There may be some limit results that mean these are not correct, but
		# I'll check that later
		if (lambda3 == 0) {
			warning('lambda 3 = 0 - could be a problem')
			return(FALSE)
			}
		if (lambda4 == 0) {
			warning('lambda 4 = 0 - could be a problem')
			return(FALSE)
			}
		# If we get here, then the parameters are OK.
		ret <- TRUE
		}
	},
	stop("Error when checking validity of parameters.\n Parameterisation must be either fmkl or rs")
	) # closes "switch"
ret
}


qgl.fmkl <- function(p,lambda1,lambda2,lambda3,lambda4)
{
# Check the values are OK)
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param="fmkl")) {
        stop(paste("The parameter values", lambda1, lambda2, lambda3, lambda4,
"\ndo not produce a proper distribution with the FMKL parameterisation - see \ndocumentation for gl.check.lambda"))
	}
# abandoned this for the simpler
# outside.range <- !as.logical(((p<1)*(p>0))|(sapply(p, all.equal,1)=="TRUE")| (sapply(p, all.equal, 0)=="TRUE"))
outside.range <- !as.logical((p<=1)*(p>=0))
# u gets only the probabilities in [0,1]
u <- p[!outside.range]
# If OK, determine special cases
if (lambda3 == 0) { 
	if (lambda4 == 0) { # both log
		quants <- lambda1 + (log(u) - log(1 - u))/lambda2
		}
	else	{ # l3 zero, l4 non-zero
		quants <- lambda1 + 
			(log(u) - ((1 - u)^lambda4 - 1)/lambda4)/lambda2
		}
	}
else 	{ # lambda3 non-zero
	if (lambda4 == 0) { # non-zero, l4 zero
		quants <- lambda1 + 
			((u^lambda3 - 1)/lambda3 - log(1 - u))/lambda2
		}
	else	{ # both non-zero - use usual formula
		quants <- lambda1 + ( ( u ^ lambda3 - 1)	/ lambda3 
			- ( (1-u)^lambda4 - 1) /lambda4 ) / lambda2
		}
	}
# Now we have the quantiles for p values inside [0,1], put them in the right
# place in the result vector
result <- p*NaN
result[!outside.range] <- quants
# The remaining "quantiles" are NaN
result
}

qgl.rs <- function(p,lambda1,lambda2,lambda3,lambda4)
{
u <- p
# Check the values are OK)
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param="rs")) {
        stop(paste("The parameter values", lambda1, lambda2, lambda3, lambda4,
"\ndo not produce a proper distribution with the RS parameterisation - see \ndocumentation for gl.check.lambda"))
	}
# At present, I'm rejecting zero values for l3 and l4, though I think there 
# are limit results, so one functional form.
quants <- lambda1 + ( u ^ lambda3 - (1-u)^lambda4 ) / lambda2
quants
}

qgl <- function(p,lambda1,lambda2,lambda3,lambda4,param="fmkl")
{
u <- p
result <- switch(param,  
# Different tests apply for each parameterisation
	freimer=,  # allows for alternate expressions
	frm=,  # allows for alternate expressions
	FMKL=,
	fmkl=qgl.fmkl(u,lambda1,lambda2,lambda3,lambda4),
	ramberg=, # Ramberg & Schmeiser
	ram=,
	RS=,
	rs=qgl.rs(u,lambda1,lambda2,lambda3,lambda4),
	stop("Error: Parameterisation must be either fmkl or rs")
	) # closes "switch"
result
}

qdgl <- function(p,lambda1,lambda2,lambda3,lambda4,param="fmkl")
{
u <- p
result <- switch(param,  
# Different tests apply for each parameterisation
	freimer=,  # allows for alternate expressions
	frm=,  # allows for alternate expressions
	FMKL=,
	fmkl=qdgl.fmkl(u,lambda1,lambda2,lambda3,lambda4),
	ramberg=, # Ramberg & Schmeiser
	ram=,
	RS=,
	rs=qdgl.rs(u,lambda1,lambda2,lambda3,lambda4),
	stop("Error: Parameterisation must be either fmkl or rs")
	) # closes "switch"
result
}


qdgl.rs <- function(p,lambda1=0,lambda2=1,lambda3,lambda4)
{
u <- p
# Check the values are OK)
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param="rs")) {
        stop(paste("The parameter values", lambda1, lambda2, lambda3, lambda4,
"\ndo not produce a proper distribution with the",param,
"parameterisation - see \ndocumentation for gl.check.lambda"))
	}
dens <-  lambda2/(lambda3 * (u^(lambda3 -1)) + lambda4 * ((1 - u)^(lambda4 -1)))
dens
}


qdgl.fmkl <- function(p,lambda1,lambda2,lambda3,lambda4)
{
u <- p
# Check the values are OK)
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param="fmkl")) {
        stop(paste("The parameter values", lambda1, lambda2, lambda3, lambda4,
"\ndo not produce a proper distribution with the",param,
"parameterisation - see \ndocumentation for gl.check.lambda"))
	}
# The density is given by 1/Q'(u)
dens <- lambda2/(u^(lambda3 - 1) + (1 - u)^(lambda4 - 1))
dens
}
qqgl <- function (y, lambda1, lambda2, lambda3, lambda4, param = "fmkl",abline=TRUE,...) 
{
	n <- length(y)
	u <- seq(from = 1/(n + 1), by = 1/(n + 1), length = n)
    	q <- switch(param, freimer = , frm = , FMKL = , fmkl = qgl.fmkl(u, 
       	 lambda1, lambda2, lambda3, lambda4), ramberg = , ram = , 
        RS = , rs = qgl.rs(u, lambda1, lambda2, lambda3, lambda4), 
        stop("Error: Parameterisation must be either fmkl or rs"))
	if(abline) { 
		ret <- qqplot(q,y,...)
		abline(0,1)
		}
	else {ret <- qqplot(q,y,...)}
invisible(ret)
}
rgl <- function(n,lambda1=0,lambda2=1,lambda3,lambda4,param="fmkl")
{
# Check the parameters
if(!gl.check.lambda(lambda1,lambda2,lambda3,lambda4,param)) {
        stop(paste("The parameter values", lambda1, lambda2, lambda3, lambda4,
"\ndo not produce a proper distribution with the",param,
"parameterisation - see \ndocumentation for gl.check.lambda"))
        }
# Produce the uniform data
p <- runif(n)
# convert to gl
res <- qgl(p,lambda1,lambda2,lambda3,lambda4,param)
res
}
# $Id: starship.R,v 1.3 2003-05-13 16:28:27+10 king Exp $
starship <- function(data,optim.method="Nelder-Mead",initgrid=NULL,
	param="FMKL",optim.control=NULL) {
# call adaptive grid first to find a first minimum
if (is.null(initgrid) ) {gridmin <- starship.adaptivegrid(data,param=param) }
else 	{ 
	warning("No checks for grids implemented")
	gridmin <- starship.adaptivegrid(data,initgrid$lcvect,initgrid$ldvect, 
		param=param)
	}
# If they haven't sent any control parameters, scale by max(lambda1,1),
# lambda2 (can't be <= 0), don't scale for lambda3, lambda4
if (is.null(optim.control) ) {
	optim.control <- list(
		parscale=c(max(1,abs(gridmin$lambda[1])),abs(gridmin$lambda[2]),
		1,1))
	}
# else use what they sent - this should allow them to change other stuff in the
# control while keeping parscale 
# call optimiser
optimmin <- optim(par=gridmin$lambda,fn=starship.obj,method=optim.method,
	control=optim.control,data=data,param=param)
list(lambda=optimmin$par,grid.results=gridmin,optim.results=optimmin)
}

starship.adaptivegrid <- function(data,lcvect=c(-1.5,-1,-.5,-.1,0,.1,.2,.4,
	.8,1,1.5), ldvect=c(-1.5,-1,-.5,-.1,0,.1,.2,.4,.8,1,1.5),param="FMKL") 
{
data <- sort(data)
quarts <- quantile(data)
nombo <- length(data)
minresponse <- 1000
minlambda <- c(NA,NA,NA,NA)

for (ld in ldvect) {
	for (lc in lcvect) {
		# calculate expected lambda2 on basis of IQR
		# IQR for 0,1,lc,ld
		iqr1 <- qgl(.75,0,1,lc,ld,param=param) -
qgl(.25,0,1,lc,ld,param=param)
		# actual IQR
		iqr <- quarts[4] - quarts[2]
		# so estimated lambda 2 from IQR
		lbguess <- iqr1/iqr
		for (lb in (c(0.5,0.7,1,1.5,2)*lbguess) )
			{
			# calculate expected lambda1 on the basis of median
			lavect <- quarts[3] -
c(qgl(0.65,0,lb,lc,ld,param=param),
			qgl(0.55,0,lb,lc,ld,param=param),qgl(0.5,0,lb,lc,ld,param=param), 
			qgl(0.45,0,lb,lc,ld,param=param),qgl(0.35,0,lb,lc,ld,param=param) )
			for (la in lavect) {
				# calculate uniform g-o-f
				response <- starship.obj(c(la,lb,lc,ld),data,param)
				if (response < minresponse) {
					minresponse <- response
					minlambda <- c(la,lb,lc,ld)
				} # new minimum
				# otherwise try the next
			} #lavect
		} #lbvect
	} # lcvct
} # ldvect
list(response=minresponse,lambda=minlambda)
}

starship.obj <- function(par,data,param="fmkl") 
{
l1 <- par[1]; l2 <- par[2];
l3 <- par[3]; l4 <- par[4];

# Check that these are legitimate parameter values.  If not, give a very
# large internal g-o-f measure.  We do this instead of NAs to make the
# optimistations easy to code.  Should investigate using NAs instead
if (!gl.check.lambda(l1, l2, l3, l4, param)) {
	return(54321)
	}

x <- sort(data)
# defining other variables
nombo <- length(x)

# MAIN FUNCTION This was the original guts of the C starship program (King
# and MacGillivray 1999)

xacc <- 1e-8
# values sent to pgl
# lower & upper limit on u
x1 <- xacc 
x2 <- 1.0 - xacc

u <- pgl(x,l1,l2,l3,l4,param=param);
# write.table(matrix(c(u),nrow=1),"interim-output/u1.txt",append=T,sep=",",quote=F,col.names=F)
response <- .anddarl(u,nombo);
# write.table(matrix(c(response),nrow=1),"interim-output/response.txt",append=T,sep=",",quote=F,col.names=F)
return(response)
}

# ANDERSON-DARLING TEST
.anddarl <- function(u,nombo)
{
ad <- c(dim(nombo),dim(1));
for(j in 1:nombo) {ad[j] <- ((2*j-1)/nombo)*(log(u[j])+log(1-u[nombo+1-j]))}
# This is useful in opt to illustrate what its doing
# hist(u)
asum <- -nombo-sum(ad);
asum;
}
# END OF ANDERSON-DARLING TEST
.First.lib <- function(lib, pkg) {
  library.dynam("gld", pkg, lib)
}
