###################################### # 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()