######################################
# Functions for image and outline analysis using
# (normalisierter) elliptical Fourier analysis
# make functions work with:
#    source("path/to/this/ASCII-nonHTMLfile.R")
# Date: 2009-02-20 19:27:59
# Author: Andreas Plank (andreas.plank@web.de)
# Functions for Outline Programm SHAPE:
# http://life.bio.sunysb.edu/morph/ >  Outlines > Shape
# Inhalt:
#   plotchain()       - chain plot after Freemann 1974
#   readchain()       - read chain data from program SHAPE  ( *.chc files)
#   readnef()         - read nef data from program SHAPE ( *.nef files)
#   plotnef()         - plot nef data obtained from readnef()
#   chainToXY()       - convert a chain to x-y coordinates
#   harmonic.simple() - calculate harmonics
#   getharmonics()    - getharmonics from a chain
########


######################################
# plot chain data after Herbert Freemann 1974:
#   Computer processing of line-drawing images (Computing Surveys, VoL 6, No. 1, March 1974)
# directions:
# 3 2 1
#  \|/
# 4- -0
#  /|\
# 5 6 7
# [Sample name]_[Number] [X] [Y] [Area (mm2) per pixel] [Area (pixels)]
# [Chain code] -1
  plotchain <- function(
    chain,          # string from chain coding file file *.chc
    originsfift = c(0,0), # x, y shift from default
    print=FALSE,   # print coordinates
    pch=".",       # type of point: (p)lotting (ch)aracter
    polygon=FALSE, # plot polygon?
    legend = TRUE,
    main="chain plot after Freemann 1974\nComputer Processing of Line-Drawing Images",
    ...            # additional arguments to plot(...)
    ) {
    if(!is.character(chain))
    stop("\n#> 'chain' should be a character string like \"Sample1_1 121 101 1.123525 5178 5 4 4 5 4 6 5 ... -1\"!")
    if(length(originsfift)!=2)
    stop("\n#> 'originsfift' needs 2 coordinates as 'c(x,y)'!")
    # split the chian code
    chainsplit <- strsplit(chain," ")
      #save parameters
      chainsplit[[1]][1] -> sample # sample name
      (as.numeric(chainsplit[[1]][2]) -> x)+originsfift[1] -> xstart # x
      (as.numeric(chainsplit[[1]][3]) -> y)+originsfift[2] -> ystart # y
      as.numeric(chainsplit[[1]][4]) -> areamm2  # Area (mm2) per pixel
      as.numeric(chainsplit[[1]][5]) -> areapx   # Area (pixels)
    chain <- as.numeric(chainsplit[[1]][6:(length(chainsplit[[1]])-1)]) # chain
    n.chain <- length(chain)
    # directions
    dir = c(0,1,2,3,4,5,6,7)
      # 3 2 1  directions
      #  \|/
      # 4- -0
      #  /|\
      # 5 6 7
    n.dir <- length(dir)       # number of directions
    # pi*0.0  = 0    # 0
    # pi*0.25 = 45   # 1
    # pi*0.5  = 90   # 2
    # pi*0.75 = 135  # 3
    # pi*1.0  = 180  # 4
    # pi*1.25 = 225  # 5
    # pi*1.5  = 270  # 6
    # pi*1.75 = 315  # 7
    # pi*2.0  = 360  # length(dir)+1
    # (dir.radangles   = pi*2.0/(length(dir)+1))
    (dir.radangles <- seq(0,2*pi, length.out=n.dir+1))
    chain.df <- cbind(chain,
      "x.dir" = round(cos(dir.radangles[chain+1]),0), # round to 1
      "y.dir" = round(sin(dir.radangles[chain+1]),0)  # round to 1
    )
    chain.df <- cbind(chain.df,
      "x" = cumsum(chain.df[,"x.dir"]), # cumulate x-coordinates
      "y" = cumsum(chain.df[,"y.dir"])  # cumulate y-coordinates
    )
    chain.x <- chain.df[,"x"] + xstart
    chain.y <- chain.df[,"y"] + ystart
  #   print(cbind(chain.x,chain.df[,"x"]))
    plot(chain.x,chain.y,
      asp=1,
      pch=pch,main=main,...)
    if(polygon==TRUE) polygon(chain.x,chain.y,...)
    if(legend==TRUE) {
      legend("topleft",
        title=sample,
        legend=c(
          paste("start-xy: ",xstart," ",ystart,sep=""),
          paste("area: ",areapx,"px",sep=""),
          paste("area: ",areamm2,"mm²",sep=""),
          paste("n =",n.chain)
        ),
        bty="n",
        cex = 0.8
      )
    }
  # points(chain.x[c(1,n.chain-1)],chain.y[c(1,n.chain-1)],col=c("red","blue"),pch=c(0,3))
    if(print==TRUE) {
      return(
        list(
        "coordinates" = chain.df,
        "start" = c(xstart,ystart),
        "areamm2" = areamm2,
        "areapx" = areapx,
        "n" = n.chain
        )
      )
    }
  }

######################################
# read chain data ( *.chc files) after Herbert Freemann 1974:
#   Computer processing of line-drawing images (Computing Surveys, VoL 6, No. 1, March 1974)
# directions:
# 3 2 1
#  \|/
# 4- -0
#  /|\
# 5 6 7
# [Sample nema]_[Number] [X] [Y] [Area (mm2) per pixel] [Area (pixels]
# [Chain code] -1
  readchain <- function(
    file,    # *.chc files
    sep="\n" # \n -> line end is seperator
    ){
    data <- read.table(file,sep=sep)
    data <- as.character(data$V1)
    (data <- sub(",",".",data)) # print data as charcters
  }


######################################
# read normalized eliptic Fourier datasets from *.nef file
  readnef <- function(
      file,      # from *.nef file
      nharmo=20, # number of harmonics
      ndata=1    # number of datasets
      ){
    for(i in 1:ndata){
      if(i==1){
        name <- read.fwf(file,
          widths=30,
          skip=2,
          n=1,
          col.names="name"
        )
        data <- read.fwf(file,
          widths=rep(15,4),
          skip=3,
          n=nharmo,
          col.names=c("a","b","c","d")
        )
        dataframe <- list(
          list(
            "nharmo" = nharmo,
            "sample" = name,
            "nefabcd" = data
          )
        )
      }
      else {
        name <- read.fwf(file,
          widths=30,
          skip=2+(nharmo+1)*(i-1),
          n=1,
          col.names="name"
        )
        data <- read.fwf(file,
          widths=rep(15,4),
          skip=3+(nharmo+1)*(i-1),
          n=nharmo,
          col.names=c("a","b","c","d")
        )
        dataframe[[i]] <- list(
          "nharmo" = nharmo,
          "sample" = name,
          "nefabcd" = data
        )
      }
    }
    dataframe # print data
  }

#########################################
# function from rhelp list
# Thomas Petzoldt (Sat 19 Jan 2002 - 23:41:28 EST)
# calculate harmonics
  harmonic.simple <- function(x, a0, a, b, t, ord) {
    y <- a0
    for (p in ord) {
      k <- 2 * pi * p * x/t
      y <- y + a[p] * cos(k) + b[p] * sin(k)
    }
    y
  }# end harmonic.simple()


######################################
# plot normalized eliptic Fourier datasets from *.nef file
  plotnef <- function(nefdf, # normalized elliptic fourier data frame
      cex=0.7,      # character expansion
      orig =c(0,0), # origin
      print=FALSE,  # print results?
      main = "normalized elliptic Fourier shape",
      linecol = "black", # line color
      lty= "dotted",     # line type
      ...           # arguments to plot()
    ){
    n <- length(nefdf$nefabcd[,1])
    x <- harmonic.simple(x=1:n,a0=0,a=nefdf$nefabcd[,"a"],b=nefdf$nefabcd[,"b"],n,1:n)#;
    y <- harmonic.simple(x=1:n,a0=0,a=nefdf$nefabcd[,"c"],b=nefdf$nefabcd[,"d"],n,1:n)#;

  #   print(nefdf$nefabcd[,1])
  #   cat(x,sep="\n")
  #   orig=c("x"=0,"y"=0)
    # angle=90
    a <- x - orig[1]
    b <- y - orig[2]
    c <- sqrt(a^2 + b^2)
    # sin(alpha) y-Komponente
    (ysin <- b/c)
    # cos(alpha) x-Komponente
    (xcos <- a/c)

    plot(x,y,
      type="n",
      asp=1,
      main=main,
      ...
    )
    lines(c(x,x[1]), c(y,y[1]),col=linecol,lty=lty)
    text(x,y,
    labels=1:n,
    cex=cex
    )
  #   lines(aspline(x,y),col="red")
  #   segments(
  #       rep(0,nx),
  #       rep(0,ny),
  #       xcos#c,
  #       ysin*c,
  #       lty="28"
  #   )

  #   abline(h=orig[1],col="gray20")
  #   abline(v=orig[0],col="gray20")
    if(print==TRUE) cbind(x,y)
  }# end plotnef()



########################################
# convert a chain to x-y coordinates
#     n <- length(nefdf$nefabcd[,1])
#     x <- harmonic.simple(x=1:n,a0=0,a=nefdf$nefabcd[,"a"],b=nefdf$nefabcd[,"b"],n,1:n)#;
#     y <- harmonic.simple(x=1:n,a0=0,a=nefdf$nefabcd[,"c"],b=nefdf$nefabcd[,"d"],n,1:n)#;
#  e.g. file 'chainfile.txt' contains name and chaincode as follows:
  # ------------8<-----------
  # NameOfPicture
  # 7667767707770770707070707007070070707
  # 7070770700000110101010010101010100101
  # 7070707070707007070707070707070070707
  # 0010010010010001001001001000100100100
  # 2322232323232232233222322322322222232
  # 2232232323232333456566566665666553222
  # ....
  # ------------8<-----------
  #### than do for instance:
  # test <- chainToXY(file="/path/to/a/chainfile.txt")
  # names(test)
  # # [1] "name" "chaincode"
  # harmo <- getharmonics(test$chain,n=100,verbose=FALSE)
  # plot(test$x, test$y,
  #   main=paste("Raw outline of:",test$name), pch=".", asp=1)
  # plot(harmo$normalized$x, harmo$normalized$y,
  #   asp=1, pch=".",  main=paste("Normalized elliptic Fourier reconstruction:\n",main=test$name))
  # see also R-package 'shapes'

  chainToXY <- function(
    chain="",
    name="givenName" ,
    file=NULL
    ){
    if (missing(chain) && is.null(file)){
      stop("Stop: chain data needed with directions:\n3   2   1\n  \\\ | /  \n4 - X - 0\n  / | \\\  \n5   6   7\n")
    }
    if(is.character(chain)){
      if(nchar(chain)< 4 && is.null(file)) stop("Stop: length of chain must have at least 4 elements.")
    }else if(length(chain)< 4 && is.null(file)) stop("Stop: length of chain must have at least 4 elements.")
    if(!is.null(file)){## catch from file like:
      #PsclPs_barb_men_Tsa1999_r
      #66070770070007...
      #00070000000000...
      #
      # ^^
      # With a last line blank (=return). If it is missing only a warning will appear.
      data <- readLines(con=file, n=-11)# read all lines, first with name
      for(i in 2:length(data)){
        tmp <- gsub("(.)","\\1 ",data[i])
        tmp <- strsplit(tmp, " ")
        if(i==2) chaincode <- tmp else chaincode <- append(chaincode, tmp)
      }
      chaincode <- as.numeric(unlist(chaincode))
      chain <- list(
        name=data[1],
        chaincode = chaincode
      )
    }# end catch from file
    if(is.character(chain)){## chain given as character
      for(i in 1:length(chain)){
        tmp <- gsub("(.)","\\1 ",chain[i])
        tmp <- strsplit(tmp, " ")
        if(i==1) chaincode <- tmp else chaincode <- append(chaincode, tmp)
      }
      chaincode <- as.numeric(unlist(chaincode))
      chain <- list(
        name=name,
        chaincode = chaincode
      )
    }
    if(is.numeric(chain)){
      chaincode <- as.vector(unlist(chain))
      chain <- list(
        name=name,
        chaincode = chaincode
      )
    }
    distXY  <- 1+( (sqrt(2) -1)/2 ) * (1-(-1)^chain$chaincode)
    distXYcumsum <- cumsum(distXY)
    xdelta <- sapply(chain$chaincode,function(c){switch(as.character(c),
        '0'= 1, '1'= 1, '2'= 0, '3'= -1, '4'= -1, '5'= -1, '6'= 0, '7'= 1
      )}# end switch(cchaincode)
    )
    ydelta <- sapply(chain$chaincode,function(c){switch(as.character(c),
        '0'= 0, '1'= 1, '2'= 1, '3'= 1, '4'= 0, '5'= -1, '6'=-1, '7'=-1
      )}# end switch(chaincode)
    )
    chain <- list(
      name=chain$name,
      chain=chain$chaincode,
      distXY=distXY,
      distXYcumsum=distXYcumsum,
      xdelta = xdelta,
      ydelta = ydelta,
      x = cumsum(xdelta),
      y = cumsum(ydelta)
    )
    # output
    return(chain)
  } # end chainToXY()


########################################
# get harmonics to reconstruct an image outline by
# (normalized) elliptic Fourier transformation
#
  getharmonics <- function(
    chain,# chaincode
    n=20, # number of harmonics
    verbose=TRUE,
    debug=FALSE){
#     if (missing(chain)){
#       stop("Stop: chain data needed with directions:\n3   2   1\n  \\\ | /  \n4 - X - 0\n  / | \\\  \n5   6   7\n")
#     }
#     if(nchar(chain)< 4 ) stop("Stop: length of chain must have at least 4.")
    chain <- chainToXY(chain)
    tp <- append(chain$distXYcumsum, values=0, after=0)
    # normally tp[p] and tp[p-1] but here 0 value is prepended, because tp[p-1] cause an error
    # therefore here is tp[p+1] and tp[p] used
    dT <- chain$distXY
    x  <- chain$x
    y  <- chain$y
    dx <- chain$xdelta
    dy <- chain$ydelta
    T  <- sum(chain$distXY)
    K  <- length(dx)
    Asums=numeric(n);
    Bsums=numeric(n);
    Csums=numeric(n);
    Dsums=numeric(n);
    An=numeric(n);
    Bn=numeric(n);
    Cn=numeric(n);
    Dn=numeric(n);
    ndig <- ceiling(log10(n))
    an =0
    an <- T/(2*(1:n)^2*pi^2)
    t1 <- Sys.time()
    for(ni in 1:n){
      if(ni==1 && verbose)   cat("Calculate Fourier descriptors for (",n," harmonics)\n", sep="")
      #cat(sprintf(paste("\n%1$",ndig,"s: ", sep=""), n-ni), sep="")
      if(debug && ni==1)## some information
        cat("
+------- debug information ------+
|                    .-\"-.       |
|     .-\"-.       @@/     \\      |
|    /     \\@@    Y '-<<<-'      |
|    '->>>-' Y        '''        |
| jgs (http://www.ascii-art.de/) |
+--------------------------------+\n",
          "T=",T," (total length)\nK=",K," (length of chain)",
          sprintf("\n\nFor each Harmonic number 1...%2$s run through points 1...%3$s:",ni,n,K),
          "\n",sep=""
        )

      p <- 1:K
        Asums[ni] <- sum(dx[p]/dT[p] * ( cos( 2 * ni * pi * tp[p+1] / T) - ( cos( 2 * ni * pi * tp[p] / T ) ) ) )
        Bsums[ni] <- sum(dx[p]/dT[p] * ( sin( 2 * ni * pi * tp[p+1] / T) - ( sin( 2 * ni * pi * tp[p] / T ) ) ) )
        Csums[ni] <- sum(dy[p]/dT[p] * ( cos( 2 * ni * pi * tp[p+1] / T) - ( cos( 2 * ni * pi * tp[p] / T ) ) ) )
        Dsums[ni] <- sum(dy[p]/dT[p] * ( sin( 2 * ni * pi * tp[p+1] / T) - ( sin( 2 * ni * pi * tp[p] / T ) ) ) )

        if(debug && ni==1){## some information
          dig=ceiling(log10(T))
          cat(
            sprintf(
              paste("p %1$",dig,
                "s: dX dY(%2$2s,%3$2s), differences XY: dT(%4$1.3f) and cumsum XY: tp tp-1(%6$",
                (dig+4),
                ".3f, %5$",
                (dig+4),
                ".3f)", sep=""
              ),
              p , dx[p], dy[p], dT[p], if(p==1) 0 else tp[p-1], tp[p]
            ),"\n"
          )## end cat()
        }## end debug
      An[ni] <- an[ni] * Asums[ni]
      Bn[ni] <- an[ni] * Bsums[ni]
      Cn[ni] <- an[ni] * Csums[ni]
      Dn[ni] <- an[ni] * Dsums[ni]
      if(verbose) cat(".", if(ni %% 50 ==0) "\n" else "", sep="")
      if(ni==n && verbose) cat("done\n")
    }# end for 1:n
    aNorm = numeric(n); bNorm = numeric(n); cNorm = numeric(n); dNorm = numeric(n);
    aStar = numeric(n); bStar = numeric(n); cStar = numeric(n); dStar = numeric(n);
    # normA = numeric(n)
    # normB = numeric(n)
    # normC = numeric(n)
    # normD = numeric(n)
    θ = numeric(n)
    for(ni in 1:n) {##calculate matrices
        # theta
      if(ni==1 && verbose)      cat("Calculate normalization\n")
      if(verbose) cat(".", if(ni %% 50 ==0) "\n" else "", sep="")
      if(ni==n && verbose) cat("done\n")

        θ[ni]  =
            0.5 *
              atan(
                2*( An[ni]*Bn[ni] + Cn[ni]*Dn[ni] )
                  /
                ( An[ni]^2 + Cn[ni]^2 - Bn[ni]^2 - Dn[ni]^2 )
              )
          ;
        aStar[ni] = (An[1] *        cos( θ[ni] )) + (Bn[1] * sin( θ[ni] ));
        bStar[ni] = (An[1] * (-1) * sin( θ[ni] )) + (Bn[1] * cos( θ[ni] ));
        cStar[ni] = (Cn[1] *        cos( θ[ni] )) + (Dn[1] * sin( θ[ni] ));
        dStar[ni] = (Cn[1] * (-1) * sin( θ[ni] )) + (Dn[1] * cos( θ[ni] ));
      if(ni==1){
        E_Star = sqrt( (aStar[1]^2  + cStar[1]^2)  );
        ψ    =   atan( (cStar[1] / aStar[1]) );
          ## returns '+' but PHP returns '-' but range after Kuhl and Giardina 1982 0 <= ψ₁ <= 2π
      }
      if(debug){
        cat(
          sprintf(
            "θ[ni=%8$2s]:%1$32.50f ψ=%2$8.5f E*=%3$8.5f\n  a*=%4$+-10.5e b*=%5$+-10.5e  c*=%6$+-10.5e d*=%7$+-10.5e cos=%9$8.5f sin=%10$8.5e",
              θ[ni] , ψ, E_Star, aStar[1], bStar[1], cStar[1], dStar[1], ni, cos( θ[ni] ), sin( θ[ni] )
          ),
          "\n", sep=""
        );
        cat(
          "  a*=",An[1] ,"*", cos( θ[ni] ) ,"+", Bn[1] ,"*", sin( θ[ni] ),
          "\n"
        )
      }
      # m12_11 =  cos(ψ)*An[ni] + sin(ψ)*Cn[ni]; m12_12 =  cos(ψ)*Bn[ni] + sin(ψ)*Dn[ni];
      # m12_21 = -sin(ψ)*An[ni] + cos(ψ)*Cn[ni]; m12_22 = -sin(ψ)*Bn[ni] + cos(ψ)*Dn[ni];
      #
      # m23_11 = m12_11 * cos(ni*θ[1]) + m12_12 * sin(ni*θ[1]);  m23_12 = m12_11 * (-1) * sin(ni*θ[1]) + m12_12 * cos(ni*θ[1]);
      # m23_21 = m12_21 * cos(ni*θ[1]) + m12_22 * sin(ni*θ[1]);  m23_22 = m12_21 * (-1) * sin(ni*θ[1]) + m12_22 * cos(ni*θ[1]);
      #
      # aNorm[ni] = 1 / E_Star * m23_11;       bNorm[ni] = 1 / E_Star * m23_12;
      # cNorm[ni] = 1 / E_Star * m23_21;       dNorm[ni] = 1 / E_Star * m23_22;
      m1 <- matrix(c(       cos(ψ),       sin(ψ),
                           -sin(ψ),       cos(ψ)), 2, 2, byrow=TRUE)
      m2 <- matrix(c(       An[ni],       Bn[ni],
                            Cn[ni],       Dn[ni]), 2, 2, byrow=TRUE)
      m3 <- matrix(c( cos(ni*θ[1]), -sin(ni*θ[1]),
                      sin(ni*θ[1]),  cos(ni*θ[1])), 2, 2, byrow=TRUE)
      aNorm[ni] <- (1/E_Star *(m1 %*% m2 %*% m3))[1,1]
      bNorm[ni] <- (1/E_Star *(m1 %*% m2 %*% m3))[1,2]
      cNorm[ni] <- (1/E_Star *(m1 %*% m2 %*% m3))[2,1]
      dNorm[ni] <- (1/E_Star *(m1 %*% m2 %*% m3))[2,2]

    }## end calculate matrices
  ## return reconstructed x y
  if(verbose) cat("Reconstruct x-y values...\n")
  xNorm <- harmonic.simple(x=1:n,a0=0,a=aNorm,b=bNorm,n,1:n)#;
  yNorm <- harmonic.simple(x=1:n,a0=0,a=cNorm,b=dNorm,n,1:n)#;
  xnotNorm <- harmonic.simple(x=1:n,a0=0,a=An,b=Bn,n,1:n)#;
  ynotNorm <- harmonic.simple(x=1:n,a0=0,a=Cn,b=Dn,n,1:n)#;
      #cat(time,units(time)," ")
    harmo <- list(
      nharmo = n,
      notnormalized = data.frame(
        a = An,
        b = Bn,
        c = Cn,
        d = Dn,
        x = xnotNorm,
        y = ynotNorm
      ),
      normalized = data.frame(
        a = aNorm,
        b = bNorm,
        c = cNorm,
        d = dNorm,
        x = xNorm,
        y = yNorm
      )
    )
      t2 <- Sys.time()
      time <- round(difftime(t2,t1), 3)
    if(verbose) cat("Normalized and not normalized values returned\nDone calculation in ", time," ",units(time),".\n", sep="")
    return(harmo) # output values
  } # end getharmonics()