.packageName <- "rimage"
##
## fft_filter: fftw interface
##
## $Header: /database/repository/rimage/R/fft_filter.R,v 1.4.2.5 2004/03/17 06:35:05 tomo Exp $
##
## Copyright (c) 2003 Nikon Systems Inc.
## For complete license terms see file LICENSE

fftw <- function(img, dir = -1, debug=FALSE) {
  h <- dim(img)[1]
  w <- dim(img)[2]
  matrix(.C("fftw_access_func",
            as.complex(img),
            as.integer(w),
            as.integer(h),
            as.integer(dir),
            as.integer(debug),
            spec = complex(w*h),
            PACKAGE="rimage"
            )$spec, nrow=dim(img)[1], ncol=dim(img)[2])
}

fftImg <- function(img) {
  img.fft <- normalize(imagematrix(log1p(Mod(fftw(img, -1))), noclipping=TRUE))
  # reordering
  w <- dim(img)[2]
  h <- dim(img)[1]
  imagematrix(img.fft[c(ceiling(h/2):h,1:(ceiling(h/2)-1)),
                      c(ceiling(w/2):w, 1:(ceiling(w/2)-1))], noclipping=TRUE)
}

## the end of file

## $Header: /database/repository/rimage/R/freq.R,v 1.1.2.3 2004/03/17 06:35:18 tomo Exp $
##
## Copyright (c) 2003 Nikon Systems Inc.
## For complete license terms see file LICENSE


lowpass <- function(img, radius=40) {
  ## computes a low pass
  ## image is just for giving dimensions
  get.lp <- function(img, radius) {
    h <- dim(img)[1]
    w <- dim(img)[2]
    matrix(.C("getLowPass",
              as.double(img),
              as.integer(w),
              as.integer(h),
              as.integer(radius),
              spec = double(h*w),
              PACKAGE="rimage"
              )$spec, nrow=h, ncol=w)
  }
  fft <- fftw(img)
  t1 <- rbind(fft,fft)
  t2 <- cbind(t1,t1)
  x1 <- dim(fft)[1]/2 + 1
  x2 <- 1.5*dim(fft)[1]
  y1 <- dim(fft)[2]/2 + 1
  y2 <- 1.5*dim(fft)[2]
  fft <- t2[ x1:x2 , y1:y2 ]
  lp <- get.lp(img, radius)
  filtered <- fft*lp
  ifft <- fftw(filtered,1)
  imagematrix(abs(ifft), noclipping=TRUE)
}

highpass <- function(img, radius=40) {
  ## computes high pass
  get.hp <- function(img, radius) {
    h <- dim(img)[1]
    w <- dim(img)[2]
    matrix(.C("getHighPass",
              as.double(img),
              as.integer(w),
              as.integer(h),
              as.integer(radius),
              spec = double(w*h),
              PACKAGE="rimage"
              )$spec, nrow=dim(img)[1], ncol=dim(img)[2])
  }
  fft <- fftw(img)
  t1 <- rbind(fft,fft)
  t2 <- cbind(t1,t1)
  x1 <- dim(fft)[1]/2 + 1
  x2 <- 1.5*dim(fft)[1]
  y1 <- dim(fft)[2]/2 + 1
  y2 <- 1.5*dim(fft)[2]
  fft <- t2[ x1:x2 , y1:y2 ]
  hp <- get.hp(img, radius)
  filtered <- fft*hp
  ifft <- fftw(filtered,1)
  imagematrix(abs(ifft), noclipping=TRUE)
}


## the end of file
##
## imagematrix class definition
##
## $Header: /database/repository/rimage/R/Attic/imagematrix.R,v 1.1.2.5 2004/03/17 06:35:18 tomo Exp $
##
## Copyright (c) 2003 Nikon Systems Inc.
## For complete license terms see file LICENSE

imagematrix <- function(mat, type=NULL, ncol=dim(mat)[1], nrow=dim(mat)[2],
                        noclipping=FALSE) {
  if (is.null(dim(mat)) && is.null(type)) stop("Type should be specified.")
  if (length(dim(mat)) == 2 && is.null(type)) type <- "grey"
  if (length(dim(mat)) == 3 && is.null(type)) type <- "rgb"
  if (type != "rgb" && type != "grey") stop("Type is incorrect.")
  if (is.null(ncol) || is.null(nrow)) stop("Dimension is uncertain.")
  imgdim <- c(ncol, nrow, if (type == "rgb") 3 else NULL)
  if (length(imgdim) == 3 && type == "grey") {
    # force to convert grey image
    mat <- rgb2grey(mat)
  }
  if (noclipping == FALSE && ((min(mat) < 0) || (1 < max(mat)))) {
    warning("Pixel values were automatically clipped because of range over.") 
    mat <- clipping(mat)
  }
  mat <- array(mat, dim=imgdim)
  attr(mat, "type") <- type
  class(mat) <- c("imagematrix", class(mat))
  mat
}

print.imagematrix <- function(x, ...) {
  x.dim <- dim(x)
  cat("size: ", x.dim[1], "x", x.dim[2], "\n")
  cat("type: ", attr(x, "type"), "\n")
}

plot.imagematrix <- function(x, ...) {
  colvec <- switch(attr(x, "type"),
                grey=grey(x),
                rgb=rgb(x[,,1], x[,,2], x[,,3]))
  if (is.null(colvec)) stop("image matrix is broken.")
  colors <- unique(colvec)
  colmat <- array(match(colvec, colors), dim=dim(x)[1:2])
  image(x = 0:(dim(colmat)[2]), y=0:(dim(colmat)[1]),
        z = t(colmat[nrow(colmat):1, ]), col=colors,
        xlab="", ylab="", axes=FALSE, asp=1, ...)
}

imageType <- function(x) {
  attr(x, "type")
}

# the end of file
##
## JPEG read functions
##
##  $Header: /database/repository/rimage/R/Attic/jpeg.R,v 1.1.2.3 2004/03/17 06:35:18 tomo Exp $
##
## Copyright (c) 2003 Nikon Systems Inc.
## For complete license terms see file LICENSE

read.jpeg <- function(filename) {
  res <- .C("get_imagesize_of_JPEG_file", as.character(filename),
            width=integer(1), height=integer(1), depth=integer(1),
            ret=integer(1), PACKAGE="rimage")
  if (res$ret < 0)
    stop(if (res$ret==-1) "Can't open file." else "Internal error")
  imgtype <- if (res$depth == 1) "grey" else "rgb"
  imgdim <- c(res$height, res$width, if (res$depth == 3) res$depth else NULL)
  res <- .C("read_JPEG_file", as.character(filename),
            image=double(res$width * res$height * res$depth),
            ret=integer(1), PACKAGE="rimage")
  img <- array(res$image, dim=imgdim)
  imagematrix(img/255, type=imgtype)
}

## the end of file

##
## rimage: Image Processing Library for R
##
## $Header: /database/repository/rimage/R/rimage.R,v 1.8.2.8 2004/03/17 06:35:18 tomo Exp $
##
## Copyright (c) 2003 Nikon Systems Inc.
## For complete license terms see file LICENSE


##
## Grey level adjustment
##

thresholding <- function(img, mode="fixed", th=0.5) {
  th.by.discrim <- function(img, L=255) {
    img.int <- floor(L*img)
    h <- hist(img.int, breaks=0:(L+1), plot=FALSE)$density
    lv <- 0:L
    u.img <- sum(lv * h) / sum(h)
    s.img <- sum(h * (lv - u.img)^2)
    Fs <- sapply(1:(L-1), function(k) {
      w.0 <- sum(h[1:k])
      w.1 <- sum(h[(k+1):L])
      u.0 <- sum((1:k) * h[1:k]) / w.0
      u.1 <- sum(((k+1):L) * h[(k+1):L]) / w.1
      s.B <- w.0 * (u.0 - u.img)^2 + w.1 * (u.1 - u.img)^2
      s.B / s.img
    })
    lv[rev(order(Fs, na.last = NA))[1]]/L
  }

  th <- switch(mode, fixed=th, da=th.by.discrim(img))
  if (is.null(th)) stop("Either mode or threshold isn't correct.")
  img[img < th] <- 0
  img[img >= th] <- 1
  img
}

clipping <- function(img, low=0, high=1) {
  img[img < low] <- low
  img[img > high] <- high
  img
}

normalize <- function(img) {
  (img - min(img))/(max(img) - min(img))
}

rgb2grey <- function(img, coefs=c(0.30, 0.59, 0.11)) {
  if (is.null(dim(img))) stop("image matrix isn't correct.")
  if (length(dim(img))<3) stop("image matrix isn't rgb image.")
  imagematrix(coefs[1] * img[,,1] + coefs[2] * img[,,2] + coefs[3] * img[,,3],
              type="grey")
}

##
## Edge Detection Filters
##

sobel.h <- function(img) {
  w <- dim(img)[2]
  h <- dim(img)[1]
  imagematrix(abs(matrix(.C("sobel_h",
                            as.double(img), as.integer(w), as.integer(h),
                            eimg = double(w * h),
                            PACKAGE="rimage")$eimg,
                         nrow=h, ncol=w)), noclipping=TRUE)
}

sobel.v <- function(img) {
  w <- dim(img)[2]
  h <- dim(img)[1]
  imagematrix(abs(matrix(.C("sobel_v",
                            as.double(img), as.integer(w), as.integer(h),
                            eimg = double(w * h),
                            PACKAGE="rimage")$eimg,
                         nrow=h, ncol=w)), noclipping=TRUE)
}

sobel <- function(img) {
  h.img <- sobel.h(img)
  v.img <- sobel.v(img)
  (h.img + v.img)/2
}

laplacian <- function(img) {
  w <- dim(img)[2]
  h <- dim(img)[1]
  l.img <- imagematrix(matrix(.C("laplacian",
                                 as.double(img), as.integer(w), as.integer(h),
                                 eimg = double(w * h),
                                 PACKAGE="rimage")$eimg,
                              nrow=h, ncol=w),
                       noclipping=TRUE)
}

##
## Rank Filters
##

meanImg <- function(img) {
  expand.h <- cbind(img[,1], img, img[,dim(img)[2]])
  ex.img <- rbind(expand.h[1,], expand.h, expand.h[dim(img)[1],])
  w <- dim(ex.img)[2]
  h <- dim(ex.img)[1]
  f.img <- matrix(.C("meanfilter",
                     as.double(ex.img), as.integer(w), as.integer(h),
                     eimg = double(w * h),
                     PACKAGE="rimage")$eimg,
                  nrow=h, ncol=w)
  imagematrix(f.img[2:(dim(f.img)[1]-1),2:(dim(f.img)[2]-1)])
}

minImg <- function(img) {
  expand.h <- cbind(img[,1], img, img[,dim(img)[2]])
  ex.img <- rbind(expand.h[1,], expand.h, expand.h[dim(img)[1],])
  w <- dim(ex.img)[2]
  h <- dim(ex.img)[1]
  f.img <- matrix(.C("minfilter",
                     as.double(ex.img), as.integer(w), as.integer(h),
                     eimg = double(w * h),
                     PACKAGE="rimage")$eimg,
                  nrow=h, ncol=w)
  imagematrix(f.img[2:(dim(f.img)[1]-1),2:(dim(f.img)[2]-1)])
}

maxImg <- function(img) {
  expand.h <- cbind(img[,1], img, img[,dim(img)[2]])
  ex.img <- rbind(expand.h[1,], expand.h, expand.h[dim(img)[1],])
  w <- dim(ex.img)[2]
  h <- dim(ex.img)[1]
  f.img <- matrix(.C("maxfilter",
                     as.double(ex.img), as.integer(w), as.integer(h),
                     eimg = double(w * h),
                     PACKAGE="rimage")$eimg,
                  nrow=h, ncol=w)
  imagematrix(f.img[2:(dim(f.img)[1]-1),2:(dim(f.img)[2]-1)])
}


##
## Equalization
##


## image takes up values 0..1
equalize <- function(img) {
  img <- (img-min(img))*255 / (max(img)-min(img)) ## normalize it to 0..255
  h <- dim(img)[1]
  w <- dim(img)[2]
  res <- matrix(.C("equalize",
                   as.double(img),
                   as.integer(w),
                   as.integer(h),
                   spec = double(w*h),
                   PACKAGE="rimage"
                   )$spec, nrow=h, ncol=w)
  imagematrix(res / 255)  ## map it to 0..1
}


## the end of file
##
## zzz: initialization of rimage
##
## $Header: /database/repository/rimage/R/zzz.R,v 1.1.2.5 2004/03/17 06:35:18 tomo Exp $
##
## Copyright (c) 2003 Nikon Systems Inc.
## For complete license terms see file LICENSE

.First.lib <- function(lib, pkg) {
  library.dynam("rimage", pkg, lib)
}


# the end of file
