bincombinations <- function(p) {

  retval <- matrix(0, nrow=2^p, ncol=p)
  
  for(n in 1:p){
    retval[,n] <- rep(c(rep(0, (2^p/2^n)), rep(1, (2^p/2^n))),
                      length=2^p)
  }
  retval
}



rdiscrete <- function (n, probs, values = 1:length(probs), method="inverse",
                       aliasmatrix = NULL)
{
    
    if (length(probs) != length(values))
        stop("rdiscrete: probs and values must have the same length.")
    if (sum(probs < 0) > 0)
        stop("rdiscrete: probs must not contain negative values.")
    
    if (n == 1)
        return (values[sum(runif(1) > p) + 1])
    else
    {
        method <- pmatch(method, c("inverse", "alias"))
        if (is.na(method))
            stop("rdiscrete: unknown method.")
        if (method == 1)
        {
            p <- cumsum(probs)/sum(probs)
            l <- length(probs)
            m <- numeric(n)
            a <- runif(n)
            for (i in 1:n)
                m[i] <- sum(a[i] > p)
            return(values[m + 1])
        }
        else
        {
            if (missing(aliasmatrix))
                aliasmatrix <- aliasmat(probs)
            return(rdiscrete.alias(n, probs, aliasmatrix))
        }
    }
}

aliasmat <- function(p)
{
    p <- p / sum(p)
    q <- p * (pn <- length(p))
    r <- matrix(0, nrow=pn, ncol=3)

    eps <- .Machine$double.eps
    while (sum(!is.na(q))>1)
    {
        qklein <- min((1:pn)[q<=1+eps],na.rm=TRUE)
        qgross <- max((1:pn)[q>=1-eps],na.rm=TRUE)
        r[qklein,] <- c(q[qklein],qklein,qgross)
        q[qgross] <- q[qgross] + q[qklein] - 1
        q[qklein] <- NA
    }
    qmittel <- (1:pn)[!is.na(q)]
    r[qmittel,] <-  c(q[qmittel],qmittel,qmittel)

    return(r)
}

rdiscrete.alias <- function(n, p, aliasmatrix = aliasmat(p))
{
    x <- sample(1:nrow(aliasmatrix), n, replace=TRUE)
    y <- runif(n)
    
    retval <- rep(0, length=n)
    
    eins <- (y <= aliasmatrix[x,1])
    
    retval[eins] <- (1:length(p))[aliasmatrix[x[eins],2]]
    retval[!eins] <- (1:length(p))[aliasmatrix[x[!eins],3]]
    
    return(retval)
}

    
    
aliasmat2prob <- function(r)
{
    p <- rep(0, length = length(unique(r[,2:3])))
    names(p) <- (pnames <- sort(unique(r[,2:3])))
    
    for(n in pnames){
        if(any(r[,2]==n)){
            p[n] <- r[r[,2]==n,1]
        }
        if(any(r[,3]==n)){
            p[n] <- p[n] + sum(1 - r[r[,3]==n,1])
        }
    }
    p<- p/length(p)
    p
}



ddiscrete <- function (x, probs, values = 1:length(probs))
{
    
    if (length(probs) != length(values))
        stop("ddiscrete: probs and values must have the same length.")
    if (sum(probs < 0) > 0)
        stop("ddiscrete: probs must not contain negative values.")
    if (!is.array(x) && !is.vector(x) && !is.factor(x))
        stop("ddiscrete: x must be an array or a vector or a factor.")
    
    p <- probs/sum(probs)
    
    y <- as.vector(x)
    l <- length(y)
    z <- rep(0,l)
    
    for (i in 1:l)
        if (any(values == y[i]))
            z[i] <- p[values == y[i]]
    
    z <- as.numeric(z)
    if (is.array(x))
        dim(z) <- dim(x)
    
    return(z)
}


pdiscrete <- function (q, probs, values = 1:length(probs))
{
    
    if (length(probs) != length(values))
        stop("pdiscrete: probs and values must have the same length.")
    if (sum(probs < 0) > 0)
        stop("pdiscrete: probs must not contain negative values.")
    if (!is.array(q) & !is.vector(q))
        stop("pdiscrete: q must be an array or a vector")
    
    p <- probs/sum(probs)
    
    y <- as.vector(q)
    l <- length(y)
    z <- rep(0,l)
    
    for (i in 1:l)
        z[i] <- sum(p[values <= y[i]])
    
    z <- as.numeric(z)
    if (is.array(q))
        dim(z) <- dim(q)
    
    return(z)
}

qdiscrete <- function (p, probs, values = 1:length(probs))
{
    
    if (length(probs) != length(values))
        stop("qdiscrete: probs and values must have the same length.")
    if (sum(probs < 0) > 0)
        stop("qdiscrete: probs must not contain negative values.")
    if (!is.array(p) & !is.vector(p))
        stop("qdiscrete: p must be an array or a vector")
    
    probs <- cumsum(probs)/sum(probs)
    
    y <- as.vector(p)
    l <- length(y)
    z <- rep(0,l)
    
    for (i in 1:l)
        z[i] <- length(values) - sum(y[i] <= probs) + 1
    
    z <- as.numeric(z)
    z <- values[z]
    if (is.array(p))
        dim(z) <- dim(p)
    
    return(z)
  }



element <- function(x, i) {

  if(!is.array(x))
    stop("x is not an array")
  
  ni <- length(i)
  dx <- dim(x)
  
  if(length(i)!=length(dx))
    stop("Wrong number of subscripts")

  if(ni==1){
    return(x[i])
  }
  else{
    m1 <- c(i[1], i[2:ni]-1)
    m2 <- c(1,cumprod(dx)[1:(ni-1)])
    return(x[sum(m1*m2)])
  }
}

hamming.distance <- function(x,y){
  
  z<-NULL
  
  if(is.vector(x) && is.vector(y)){
    z <- sum(as.logical(x) != as.logical(y))
  }
  else{
    z <- matrix(0,nrow=nrow(x),ncol=nrow(x))
    for(k in 1:(nrow(x)-1)){
      for(l in (k+1):nrow(x)){
	z[k,l] <- hamming.distance(x[k,], x[l,])
	z[l,k] <- z[k,l]
      }
    }
    dimnames(z) <- list(dimnames(x)[[1]], dimnames(x)[[1]])
  }
  z
}



















hamming.window <- function (n)
  {
    if (n == 1)
      c <- 1
    else
      {
	n <- n-1
	c <- 0.54 - 0.46*cos(2*pi*(0:n)/n)
      }
    return(c)
  }
hanning.window <- function (n)
  {
    if (n == 1)
      c <- 1
    else
      {
	n <- n-1
	c <- 0.5 - 0.5*cos(2*pi*(0:n)/n)
      }
    return(c)
  }
ica <- function(X, lrate, epochs=100, ncomp=dim(X)[2], 
                      fun="negative")
  {
    if (!is.matrix(X))
      {
        if (is.data.frame(X))
          X <- as.matrix(X)
        else
          stop("ica: X must be a matrix or a data frame")
      }
    if (!is.numeric(X))
      stop("ica: X contains non numeric elements")
            
    m <- dim(X)[1]
    n <- dim(X)[2]

    Winit <- matrix(rnorm(n*ncomp), ncomp, n)
    W <- Winit

    if (!is.function(fun))
      {
        funlist <- c("negative kurtosis", "positive kurtosis",
                     "4th moment")
        p <- pmatch(fun, funlist)
        if (is.na(p))
          stop("ica: invalid fun")
        funname <- funlist[p]
        if (p == 1) fun <- tanh
        else if (p == 2) fun <- function(x) {x - tanh(x)}
        else if (p == 3) fun <- function(x) {sign(x)*x^2}
      }
    else funname <- as.character(substitute(fun))
    
    for (i in 1:epochs)
      for (j in 1:m)
        {
          x <- X[j,, drop=F]
          y <- W%*%t(x)
          gy <- fun(y)
          W <- W + lrate*gy%*%(x-t(gy)%*%W)
        }
    colnames(W) <- NULL
    pr <- X%*%t(W)
    retval <- list(weights = W, projection = pr, epochs = epochs,
                fun = funname, lrate = lrate, initweights = Winit)
    class(retval) <- "ica"
    return(retval)
  }


print.ica <- function(x)
  {
    cat(x$epochs, "Trainingssteps with a learning rate of", x$lrate, "\n")
    cat("Function used:", x$fun,"\n\n")
    cat("Weightmatrix\n")
    print(x$weights)
  }

plot.ica <- function(x, ...) pairs(x$pr, ...)

interpolate <- function(x, a, adims=lapply(dimnames(a), as.numeric),
                        method="linear"){

  if(is.vector(x)) x<- matrix(x, ncol=length(x))

  if(!is.array(a))
    stop("a is not an array")

  ad <- length(dim(a))
  
  method <- pmatch(method, c("linear", "constant"))
  if (is.na(method)) 
    stop("invalid interpolation method")
  
  if(any(unlist(lapply(adims, diff))<0))
    stop("dimensions of a not ordered")

  retval <- rep(0, nrow(x))
  bincombi <- bincombinations(ad)
  
  for(n in 1:nrow(x)){

    ## the `leftmost' corner of the enclosing hypercube 
    leftidx <- rep(0, ad)
    xabstand <- rep(0, ad)
    aabstand <- rep(0, ad)

    for(k in 1:ad){
      if(x[n,k] < min(adims[[k]]) || x[n,k] > max(adims[[k]]))
        stop("No extrapolation allowed")
      else{
        leftidx[k] <- max(seq(adims[[k]])[adims[[k]] <= x[n,k]])
        ## if at the right border, go one step to the left
        if(leftidx[k] == length(adims[[k]]))
          leftidx[k] <- leftidx[k] - 1
        
        xabstand[k] <- x[n,k] - adims[[k]][leftidx[k]]
        aabstand[k] <- adims[[k]][leftidx[k]+1] - adims[[k]][leftidx[k]]
      }
    }

    coefs <- list()
    if(method==1){
      for(k in 1:(2^ad)){
        retval[n] <- retval[n] +
          element(a, leftidx+bincombi[k,]) *
            prod((aabstand-
                  convexcoeff(xabstand, aabstand*bincombi[k,]))/aabstand)
      }
    }
    else if(method==2){
      retval[n] <- element(a, leftidx)
    }
  }

  names(retval) <- rownames(x)
  retval
}
  
  

          

convexcoeff <- function(x, y) {
  for(k in 1:length(x)){
    if(y[k]>0)
      x[k] <- y[k]-x[k]
  }
  x
}
        
kurtosis <- function (x, na.rm = FALSE)
{
  if (na.rm) 
    x <- x[!is.na(x)]
  sum((x-mean(x))^4)/(length(x)*var(x)^2) - 3
}


moment <- function(x, order = 1, center = FALSE, absolute = FALSE,
		   na.rm = FALSE) {
  if (na.rm) 
    x <- x[!is.na(x)]
  if (center)
    x <- x - mean(x)
  if (absolute)
    x <- abs(x)
  sum(x ^ order) / length(x)
}
rmvnorm <- function(n, mu=rep(0, nrow(sigma)),
                      sigma=diag(length(mu))){

  if(nrow(sigma) != ncol(sigma)){
    stop("sigma must be a square matrix")
  }

  if(length(mu) != nrow(sigma)){
    stop("mu and sigma have non-conforming size")
  }
  
  sigsvd <- svd(sigma)
  retval <- t(sigsvd$v %*% (t(sigsvd$u) * sqrt(sigsvd$d)))
  retval <- matrix(rnorm(n * ncol(sigma)), nrow = n) %*% retval
  retval <- sweep(retval, 2, mu, "+")
  retval
}


dmvnorm <- function(x, mu, sigma){

  if(is.vector(x)){
    x <- matrix(x, ncol=length(x))
  }

  if(missing(mu)){
    mu <- rep(0, length=ncol(x))
  }
  
  if(missing(sigma)){
    sigma <- diag(ncol(x))
  }

  if(length(x) != ncol(sigma)){
    stop("x and sigma have non-conforming size")
  }
  
  if(nrow(sigma) != ncol(sigma)){
    stop("sigma must be a square matrix")
  }
  if(length(mu) != nrow(sigma)){
    stop("mu and sigma have non-conforming size")
  }

  retval <- exp(-mahalanobis(x, center=mu, cov=sigma)/2)
  det <- prod(eigen(sigma, sym=TRUE)$values)
  retval<- retval / (sqrt(det) * sqrt(2*pi)^ncol(x))

  retval
}
  
plot.stft <- function (Y, col = gray (63:0/63))
  {
    x <- Y$values
    image(x=1:dim(x)[1], y=1:dim(x)[2], z=x, col=col)
}
# Generated automatically from pnm.R.in by configure.

plot.pnm <- function(pnmobj, xlab="", ylab="",
                     axes=FALSE, ...) {

  d <- dim(pnmobj)
  maxval <- attr(pnmobj, "maxval")

  if(attr(pnmobj, "type") =="ppm"){
    col <- rgb(pnmobj[1,,]/maxval,pnmobj[2,,]/maxval,pnmobj[3,,]/maxval)
    z <- matrix(1:length(col), nrow=d[2])
    image(x=1:d[3], y=1:d[2], z=t(z[d[2]:1,]),
        col=col, xlab=xlab, ylab=ylab, axes=axes, ...)
  }
  else{
    image(x=1:d[2], y=1:d[1], z=t(pnmobj[d[1]:1,]),
          col=gray((0:maxval)/maxval),
          xlab=xlab, ylab=ylab, axes=axes, ...)
  }
}


read.pnm <- function(file){

    if(! TRUE) stop("Sorry, no pnm library available")


    pnmhead <- .C("readpnminit",
                  file = as.character(file),
                  nc = as.integer(1),
                  nr = as.integer(1),
                  maxval = as.integer(1),
                  type="XXX")
    
    red <- integer(pnmhead$nc * pnmhead$nr)
    if(pnmhead$type == "ppm"){
        green <- integer(pnmhead$nc * pnmhead$nr)
        blue <- integer(pnmhead$nc * pnmhead$nr)
        retval <- array(dim=c(3, pnmhead$nr, pnmhead$nc),
                        dimnames=c(c("red", "gtreen", "blue"), NULL, NULL))
    }
    else {
        green <- as.integer(1)
        blue <- as.integer(1)
        retval <- matrix(ncol = pnmhead$nc, nrow=pnmhead$nr)
    }
    
    
    pnm <- .C("readpnm",
              file = as.character(file),
              red=red, green=green, blue=blue);
    
    
    if(pnmhead$type == "ppm"){
        retval[1,,] <- matrix(pnm$red, ncol = pnmhead$nc, byrow=TRUE)
        retval[2,,] <- matrix(pnm$green, ncol = pnmhead$nc, byrow=TRUE)
        retval[3,,] <- matrix(pnm$blue, ncol = pnmhead$nc, byrow=TRUE)
    }
    else{
        retval <- matrix(pnm$red, ncol = pnmhead$nc, byrow=TRUE)
    }
    attr(retval, "maxval") <- pnmhead$maxval
    attr(retval, "type") <- pnmhead$type
    class(retval) <- "pnm"
    retval
}


write.pgm <- function(pgmobj, file="Rimage.pgm",
                      forceplain=FALSE){

    if(! TRUE) stop("Sorry, no pnm library available")

    retval <- .C("writepgm",
                 file = as.character(file),
                 image = as.integer(t(pgmobj)),
                 nc = as.integer(ncol(pgmobj)),
                 nr = as.integer(nrow(pgmobj)),
                 maxval = as.integer(attr(pgmobj, "maxval")),
                 forceplain = as.integer(forceplain))
}


channel.pnm <- function(pnmobj, chan="red"){
    
    chan <- pmatch(chan, c("red", "green", "blue"))
    
    retval <- pnmobj[chan,,]
    attr(retval, "maxval") <- attr(pnmobj, "maxval")
    attr(retval, "type") <- "pgm"
    class(retval) <- "pnm"
    retval
}
  
rbridge <- function(end=1, frequency=1000) {

  z <- rwiener(end=end, frequency=frequency)
  ts(z - time(z)*as.vector(z)[frequency],
     start=1/frequency, frequency=frequency)
}

read.octave <- function (file, quiet=FALSE) {

  nr <- 0
  nc <- 0

  if(!quiet)
    cat("Header: ")
  
  head <- scan(file=file,what=character(),nlines=4, sep=":", quiet=quiet)
  if(length(head) != 8){
    stop("Header seem to be corrupt")
  }
  for(k in 1:4){
    if(head[2*k-1] == "# rows"){
      nr <- as.integer(head[2*k])
    }
      else if(head[2*k-1] == "# columns"){
	nc <- as.integer(head[2*k])
      }
  }

  if(!quiet)
    cat("Data  : ")

  z <- scan(file=file,skip=4,quiet=quiet)
  if(length(z) != nc*nr){
    stop("Wrong number of data elements")
  }

  if((nr>1) && (nc>1)){
    if(!quiet)
      cat(paste("Matrix:", nr, "rows,", nc, "columns\n"))
    
    z<-matrix(z, nrow=nr, ncol=nc, byrow=TRUE)
  }
    else if(!quiet){
      cat("Vector:", nr*nc, "elements\n")
    }
  z
}
	      
rectangle.window <- function (n)
  rep (1, n)
rwiener <- function(end=1, frequency=1000) {

  z<-cumsum(rnorm(end*frequency)/sqrt(frequency))
  ts(z, start=1/frequency, frequency=frequency)
}

skewness <- function (x, na.rm = FALSE)
{
  if (na.rm) 
    x <- x[!is.na(x)]
  sum((x-mean(x))^3)/(length(x)*sd(x)^3)
}

stft <- function(X, win=min(80,floor(length(X)/10)), 
                 inc=min(24, floor(length(X)/30)), coef=64, 
		 wtype="hanning.window")
  {
    numcoef <- 2*coef
    if (win > numcoef)
      {
	win <- numcoef
	cat ("stft: window size adjusted to", win, ".\n")
      }
    numwin <- trunc ((length(X) - win) / inc)

    ## compute the windows coefficients
    wincoef <- eval(parse(text=wtype))(win)

    ## create a matrix Z whose columns contain the windowed time-slices
    z <- matrix (0, numwin + 1, numcoef)
    y <- z
    st <- 1
    for (i in 0:numwin)
      {
	z[i+1, 1:win] <- X[st:(st+win-1)] * wincoef
	y[i+1,] <- fft(z[i+1,])
	st <- st + inc
      }

    Y<- list (values = Mod(y[,1:coef]), windowsize=win, increment=inc,
		  windowtype=wtype)
    class(Y) <- "stft"
    return(Y)
  }



# Generated automatically from zzz.R.in by configure.

.First.lib <- function(lib, pkg){

    if(TRUE) library.dynam("pnm", pkg, lib)
}
