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, ...)


kmeans <- function (x, centers, iter.max=100, verbose=FALSE, method=0)
{
    
  xrows<-dim(x)[1]
  xcols<-dim(x)[2]

  if (is.matrix(centers))   # initial values are given
      ncenters <- dim(centers)[1]
  else
    {                   # take centers random vectors as initial values
      ncenters <- centers
      centers <- x[rank(runif(xrows))[1:ncenters],]
    }

  initcenters <- centers
  dist <- matrix(0,xrows,ncenters)
  pos <- as.factor(1:ncenters)   # necessary for empty clusters
  rownames(centers) <- pos

  iter <- integer(1)
  changes <- integer(iter.max)
  cluster <- integer(xrows)
  clustersize <- integer(ncenters)

  retval <- .C("kmeans",
               xrows = as.integer(xrows),
               xcols = as.integer(xcols),
               x = as.double(x),
               ncenters = as.integer(ncenters),
               centers = as.double(centers),
               cluster = as.integer(cluster),
               iter.max = as.integer(iter.max),
               iter = as.integer(iter),
               changes = as.integer(changes),
               clustersize = as.integer(clustersize),
               verbose = as.integer(verbose),
               method = as.integer(method))


  centers <- matrix(retval$centers,
                    ncol=xcols, dimnames=dimnames(initcenters))
  cluster <- retval$cluster + 1
  
  if (method == 0)
    error <- mean(sqrt((apply(((x-centers[cluster,])^2),1,sum))))
  else
    error <- mean(apply((abs(x-centers[cluster,])),1,sum))
  
  retval <- list (centers = centers,
                  initcenters = initcenters,
                  ncenters = ncenters,
                  cluster = cluster,
                  size = retval$clustersize,
                  iter = retval$iter - 1,
                  changes = retval$changes,
                  method = method,
                  error = error)
                  


  class(retval)<-"cluster"
  return(retval)
}


print.cluster <- function (clobj)
  {
    if (clobj$method == 0)
      methodname <- "Mean Square Error"
    else
      methodname <- "Mean Absolute Error"

    if (!is.null(clobj$iter))
      cat("\n                            Clustering on Training Set\n\n\n")
    else
      cat("\n                              Clustering on Test Set\n\n\n")
    
    cat("Number of Clusters: ", clobj$ncenters, "\n")
    cat("Sizes  of Clusters: ", clobj$size, "\n\n")

    if (!is.null(clobj$iter))
      {
        if (clobj$iter < length(clobj$changes))
          cat("Algorithm converged after", clobj$iter, "iterations.\n")
        else
          cat("Algorithm did not converge after", clobj$iter, "iterations.\n")
        cat("Changes:", clobj$changes[1:clobj$iter], "\n\n")
      }
    cat("Method:", methodname, "\n")
    cat("Error: ", clobj$error, "\n")
  }

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)
}
plot.pgm <- function(pgmobj, xlab=NULL, ylab=NULL,
                     axes=FALSE, ...){

  d <- dim(pgmobj)
  maxval <- attr(pgmobj, "maxval")
  image(x=1:d[2], y=1:d[1], z=t(pgmobj[d[1]:1,]),
        col=gray((0:maxval)/maxval),
        xlab=xlab, ylab=ylab, axes=axes, ...)

}

read.pgm <- function(file){

  pgmhead <- .C("readpgminit",
                file = as.character(file),
                nc = as.integer(1),
                nr = as.integer(1),
                maxval = as.integer(1))

  retval <- .C("readpgm",
               file = as.character(file),
               image = integer(pgmhead$nc * pgmhead$nr))
  
  retval <- matrix(retval$image, ncol = pgmhead$nc, byrow=TRUE)
  attr(retval, "maxval") <- pgmhead$maxval
  class(retval) <- "pgm"
  retval
}


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

  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))
}
            
plot.cluster <- function(clobj, x, centers=TRUE, initcenters=TRUE,
                         color=rainbow(clobj$ncenters),...){

  
  x <- as.matrix(x)
  
  cl <- predict(clobj, x)

  
  if(dim(x)[2]>2){
    pairs(x, col=color[cl$cluster], ...)
    }
  else{
    plot(x, col=color[cl$cluster], ...)
    if(centers)
      points(cl$centers, pch="X",col=color)
    if(initcenters)
      points(cl$initcenters, pch="+",col=color)
  }
}



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)
}
predict.cluster <- function(clobj, x){

  xrows<-dim(x)[1]
  xcols<-dim(x)[2]
  ncenters <- clobj$ncenters
  cluster <- integer(xrows)
  clustersize <- integer(ncenters)
  

  if(dim(clobj$centers)[2] != xcols){
    stop("Number of variables in cluster object and x are not the same!")
  }

  
  retval <- .C("assign",
               xrows = as.integer(xrows),
               xcols = as.integer(xcols),
               x = as.double(x),
               ncenters = as.integer(ncenters),
               centers = as.double(clobj$centers),
               cluster = as.integer(cluster),
               clustersize = as.integer(clustersize),
               method = as.integer(clobj$method))

  cluster <- retval$cluster + 1
  
  if (retval$method == 0)
    error <- mean(sqrt((apply(((x-clobj$centers[cluster,])^2),1,sum))))
  else
    error <- mean(apply((abs(x-clobj$centers[cluster,])),1,sum))
   

  clobj$initcenters <- NULL
  clobj$iter <- NULL
  clobj$changes <- NULL
  clobj$error <- error
  clobj$cluster <- cluster
  clobj$size <- retval$clustersize

  return(clobj)
}


rbridge <- function(end=1, frequency=1000) {

  z <- rwiener(end=end, frequency=frequency)
  ts(z - time(z)*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)
  }



write.table <- function(x, file = "", sep =" ", col.names = TRUE,
			row.names = TRUE, quote = FALSE, na = NA,
			eol = "\n")
{
  if (is.data.frame(x) && is.logical(quote) && quote)
    quote <- which(unlist(lapply(x, is.character)))
  x <- as.matrix(x)
  p <- ncol(x)
  d <- dimnames(x)
  x[is.na(x)] <- na
  if (is.logical(quote))
    quote <- if (quote && is.character(x)) 1 : p else NULL
  else if (is.numeric(quote)) {
    if (any(quote < 1 | quote > p))
      stop("invalid numbers in quote")
  }
  else
    stop("invalid quote specification")
      
  if (is.logical(row.names)) {
    if (row.names)
      x <- cbind(d[[1]], x)
  }
  else {
    row.names <- as.character(row.names)
    if (length(row.names) == nrow(x))
      x <- cbind(row.names, x)
    else
      stop("invalid row.names specification")
  }
  if (!is.null(quote) && (p < ncol(x)))
    quote <- c(0, quote) + 1

  APPEND <- FALSE
  if (is.logical(col.names))
    col.names <- if (col.names) d[[2]] else NULL
  else {
    col.names <- as.character(col.names)
    if (length(col.names) != p)
      stop("invalid col.names specification")
  }
  if (!is.null(col.names)) {
    if (!is.null(quote))
      col.names <- paste("\"", col.names, "\"", sep = "")
    cat(col.names, file = file, sep = rep(sep, p - 1))
    cat(eol, file = file, append = TRUE)
    APPEND <- TRUE
  }

  for (i in quote)
    x[, i] <- paste("\"", x[, i], "\"", sep = "")

  cat(t(x), file = file, sep = c(rep(sep, ncol(x) - 1), eol),
      append = APPEND)
}
library.dynam("e1071.so")
