Nothing
## TODO: the extraction of EXIF tags with identify does not work!
read.image <- function(filename, compress=TRUE) {
fileparts <- strsplit(filename,"\\.")[[1]]
ext <- tolower(fileparts[length(fileparts)])
name <- filename
if (ext %in% c("tif","tiff","pgm","ppm","png","pnm","gif","jpg","jpeg","bmp")) {
if (ext %in% c("tif","tiff","png","gif","jpg","jpeg","bmp")) {
if(is.na(Sys.getenv("ImageMagick",unset=NA))) stop("need ImageMagick installed to read image files")
convert.path <- file.path(Sys.getenv("ImageMagick"),"convert")
imgctype <- system(paste(Sys.getenv("ImageMagick"),"identify -format %r \"",filename,"\"",sep=""),intern=TRUE)
if(regexpr("Gray",imgctype)!=-1){
tmpfile <- paste(tempfile("pgm"),".pgm",sep="")
tmpext <- "pgm"
} else {
tmpfile <- paste(tempfile("ppm"),".ppm",sep="")
tmpext <- "ppm"
}
if (file.exists(filename)) {
system(paste(convert.path," -compress None \"",filename,"\" \"",tmpfile,"\"",sep=""),wait=TRUE)
filename <- tmpfile
} else {
stop(paste("Error: file",filename,"does not exist!"))
}
}
if(ext%in%c("pgm","ppm")) tmpext <- ext
object <- list()
if (tmpext == "pgm") {
if (file.exists(filename)) {
object$img <- read.pgm(filename)
} else {
stop("cannot find ",filename,"\n")
}
object$type <- "greyscale"
object$cspace <- "greyscale"
} else {
if (file.exists(filename)) {
object$img <- read.ppm(filename)
} else {
stop("cannot find ",filename,"\n")
}
object$type <- "rgb"
object$cspace <- "sRGB"
}
object$depth <- attr(object$img, "depth")
attr(object$img, "depth") <- NULL
object$dim <- dim(object$img)[1:2]
if (ext %in% c("tif","tiff","png","gif","jpg","jpeg")) file.remove(tmpfile)
# in case of length(dim(img))==3 test if image contains same information in all channels
if(length(dim(object$img)) == 3)
if(sum(abs(range(object$img[,,1]-object$img[,,2]))+abs(range(object$img[,,1]-object$img[,,3])))==0) {
object$img <- object$img[,,1]
object$type <- "greyscale"
}
description <- if(!is.na(Sys.getenv("ImageMagick",unset=NA)))
paste(system(paste(Sys.getenv("ImageMagick"),"identify -format %c \"",name,"\" ",sep=""),intern=TRUE),collapse="\n",sep="")
else ""
interpolation <- extract.info(description,"Interpolation")
if(is.null(interpolation)) interpolation <- "unknown"
object$interp <- interpolation
gammatype <- extract.info(description,"Gammatype")
if(is.null(gammatype)) gammatype <- "ITU"
object$gammatype <- gammatype
object$gamma <- gammatype %in% c("ITU","sRGB","CIE")
whitep <- extract.info(description,"WhitePoint")
if(is.null(whitep)) whitep <- "D65"
object$whitep <- whitep
wb <- extract.info(description,"WhiteBalance")
if(is.null(wb)) wb <- "IMAGE"
object$wb <- wb
cspace <- extract.info(description,"Cspace")
if(is.null(cspace)) cspace <- if(ext == "pgm") "greyscale" else "sRGB"
# if cspace %in% c("xyz","hsi","yiq","yuv") we need to reconstruct the image
if(cspace %in% c("xyz","hsi","yiq","yuv")){
object$img <- object$img/65535
object$type <- cspace
compress <- FALSE
}
if(cspace == "yiq") {
object$img[,,2] <- 1.2*object$img[,,2]-0.595716
object$img[,,3] <- 1.06*object$img[,,3]-0.522591
}
if(cspace == "yuv") {
object$img[,,2] <- object$img[,,2]-0.493
object$img[,,3] <- 1.76*object$img[,,3]-0.877
}
object$cspace <- cspace
if(compress) {
dim(object$img) <- NULL
object$img <- writeBin(as.integer(object$img),raw(),2)
}
file <- extract.info(description,"File")
if(is.null(file)) file <- name
object$file <- file
object$xind <- extract.info(description,"xind")
object$yind <- extract.info(description,"yind")
ctype <- extract.info(description,"Type")
if((!is.null(ctype))&&ctype=="RAW") {
object$type <- "RAW"
}
object$description <- description
object <- modify.info(object,add=FALSE)
# remove duplicated informmation from description
object$compressed <- compress
class(object) <- "adimpro"
invisible(object)
} else {
warning(paste("Error: cannot handle file extension",ext))
invisible(NULL)
}
}
write.image <- function(img, file="tmp.ppm", max.x = NULL, max.y =NULL, depth=NULL,
gammatype="ITU", whitep = NULL, temp = NULL, cspace = NULL, black=0, exposure=1) {
if(is.na(Sys.getenv("ImageMagick",unset=NA))) stop("need ImageMagick installed to write image files")
convert.path <- file.path(Sys.getenv("ImageMagick"),"convert")
if(!check.adimpro(img)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
if(is.null(cspace)) cspace <- img$cspace
if(!(cspace %in% c("sRGB","Adobe","wGamut","kodak","xyz","yuv","yiq","hsi"))) {
cspace <- "sRGB"
}
if(cspace %in% c("xyz","yuv","yiq","hsi")){
gammatype <- "None"
}
if(img$compressed) img <- decompress.image(img)
if(!is.null(max.x)||!is.null(max.y)) img <- shrink.image(img, xt=max.x, yt=max.y, method="nearest",compress=FALSE)
fileparts <- strsplit(file,"\\.")[[1]]
ext <- tolower(fileparts[length(fileparts)])
# supported color depths
if (is.null(depth)) {
depth <- switch(img$depth,
"8bit" = 8,
"16bit" = 16,
8)
}
# image dimension
dimg <- dim(img$img)
# determine file name for PPM intermediate
fileparts <- strsplit(file,"\\.")[[1]]
ext <- tolower(fileparts[length(fileparts)])
if (img$type == "greyscale") {
tmpfile <- paste(tempfile("pgm"),".pgm",sep="")
} else {
tmpfile <- paste(tempfile("ppm"),".ppm",sep="")
}
# white balance
dogamma <- !is.null(gammatype)&&gammatype!=img$gammatype
docspace <- cspace!=img$cspace
dowhite <- (!is.null(whitep)&&whitep!=img$whitep)||(!is.null(temp))
doexposure <- !is.null(exposure)&&(exposure!=1||black!=0)
if(dogamma||docspace||dowhite||doexposure){
img <- adjust.image(img, gammatype=gammatype, cspace=cspace,
whitep=whitep, temp=temp, black=black, exposure=exposure, compress=FALSE)
}
if(img$cspace %in% c("xyz","hsi")){
img$img <- array(as.integer(65535*img$img),dim(img$img))
}
if(img$cspace=="yiq"){
img$img[,,2] <- (img$img[,,2] + 0.595716)/1.2
img$img[,,3] <- (img$img[,,3] + 0.522591)/1.06
img$img <- array(as.integer(65535*img$img),dim(img$img))
}
if(img$cspace=="yuv"){
img$img[,,2] <- (img$img[,,2] + 0.493)
img$img[,,3] <- (img$img[,,3] + 0.877)/1.76
img$img <- array(as.integer(65535*img$img),dim(img$img))
}
# rotate image appropriately
pimg <- switch(img$type,
"greyscale" = img$img[,dimg[2]:1],
img$img[,dimg[2]:1,])
# now write
if(img$type != "unknown") {
if (depth == 8) {
pimg <- as.integer(pimg / 256)
dim(pimg) <- dimg
maximg <- 255
} else {
maximg <- 65535
}
ptype <- switch(img$type,
"greyscale" = "P5","P6")
con <- file(tmpfile, "wb")
writeChar(ptype,con,eos=NULL)
writeBin(charToRaw("\n"),con)
writeChar(paste(dimg[1],dimg[2]),con,eos=NULL)
writeBin(charToRaw("\n"),con)
writeChar(as.character(maximg),con,eos=NULL)
writeBin(charToRaw("\n"),con)
close(con)
if (img$type != "greyscale") pimg <- aperm(pimg,c(3,1,2))
if (depth == 8) {
con <- file(tmpfile, "ab")
writeBin(as.vector(pimg), con, 1)
close(con)
} else {
con <- file(tmpfile, "ab")
writeBin(as.vector(pimg), con, 2, endian="big")
close(con)
}
img <- modify.info(img,add=TRUE)
# write additional information to image description
if (tmpfile != file) {
system(paste(convert.path,
" -compress None -comment \"",img$description,"\" \"",
tmpfile,"\" \"",file,"\"",sep=""),wait=TRUE)
file.remove(tmpfile)
} else {
system(paste(Sys.getenv("ImageMagick"),
"mogrify -comment \"",img$description,"\" \"",tmpfile,"\"",sep=""),wait=TRUE)
}
} else {
stop("Error: unknown colorspace type! exiting!")
}
invisible(NULL)
}
write.raw <- function(img, filename="tmp.png") {
if(is.na(Sys.getenv("ImageMagick",unset=NA))) stop("need ImageMagick installed to write image file")
convert.path <- file.path(Sys.getenv("ImageMagick"),"convert")
if(!check.adimpro(img)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
fileparts <- strsplit(filename,"\\.")[[1]]
if(!(tolower(fileparts[length(fileparts)]) %in% c("png"))){
filename <- paste(filename,".png",sep="")
}
if(img$compressed) img <- decompress.image(img)
depth <- 16
dimg <- dim(img$img)
# determine file name for PPM intermediate
tmpfile <- paste(tempfile("pgm"),".pgm",sep="")
pimg <- img$img[,dimg[2]:1]
# now write
maximg <- 65535
ptype <- "P5"
con <- file(tmpfile, "wb")
writeChar(ptype,con,eos=NULL)
writeBin(charToRaw("\n"),con)
writeChar(paste(dimg[1],dimg[2]),con,eos=NULL)
writeBin(charToRaw("\n"),con)
writeChar(as.character(maximg),con,eos=NULL)
writeBin(charToRaw("\n"),con)
close(con)
con <- file(tmpfile, "ab")
writeBin(as.vector(pimg), con, 2, endian="big")
close(con)
img <- modify.info(img,add=TRUE)
system(paste(convert.path,
" -compress None -comment \"",img$description,"\" \"",
tmpfile,"\" \"",filename,"\"",sep=""),wait=TRUE)
file.remove(tmpfile)
invisible(NULL)
}
show.image <- function (img, max.x = 1e+03, max.y =1e+03, gammatype = "ITU", whitep = NULL, temp = NULL,
cspace = "sRGB", black=0, exposure=1, channel=NULL, new = FALSE, ...) {
if(!check.adimpro(img)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
if(cspace %in% c("grey","gray","grayscale")) cspace <- "greyscale"
dimg0 <- img$dim
if(dimg0[1]>=max.x||dimg0[2]>=max.y){
img <- shrink.image(img,xt=max.x,yt=max.y,method="nearest",compress=FALSE)
} else if(img$compressed) img <- decompress.image(img)
dimg <- img$dim
# we need of course!
di <- dim(img$img)
# convert colorspace if neccessary
if(!(cspace %in% c("sRGB","Adobe","wGamut","kodak"))) gammatype <- "None"
if(toupper(img$type) == "RAW") {
# avoid calling adjust.image
cspace <- img$cspace
whitep <- temp <- NULL
exposure <- 1
black <- 0
gammatype <- img$gammatype
}
if( cspace != img$cspace || !is.null(whitep) || !is.null(temp) ||exposure!=1||black!=0||gammatype!=img$gammatype) {
img <- adjust.image(img,gammatype = gammatype, whitep = whitep, temp = temp,
cspace = cspace, black= black, exposure = exposure, compress=FALSE)
}
# if color.space %in% c("hsi","yuv","yiq","xyz") scale channels to provide maximum contrast
if(img$type %in% c("yuv","yiq")){
for(i in 1:3){
img$img[,,i] <- as.integer(65535*(img$img[,,i]-min(img$img[,,i]))/(max(img$img[,,i])-min(img$img[,,i])))
}
}
if(img$type %in% c("xyz","hsi")) img$img <- img$img*65535
if(img$type=="hsi") img$img[,,1] <- (img$img[,,1]-min(img$img[,,1]))/diff(range(img$img[,,1]))*65535
if (!is.null(channel)&&img$type!="greyscale") {
if(channel %in% (1:3)){
img$img <- img$img[,,channel]
img$type <- "greyscale"
}
}
if (new) dev.new()
# now plot according to image type attribute
switch(img$type,
"greyscale" = show.greyscale(img,dimg0,...),
"RAW" = show.greyscale(img,dimg0,...),
"rgb" = show.rgb(img,dimg0,...),
"hsi" = show.rgb(img,dimg0,...),
"yuv" = show.rgb(img,dimg0,...),
"yiq" = show.rgb(img,dimg0,...),
"xyz" = show.rgb(img,dimg0,...),
return())
}
show.rgb <- function(img,dimg0,...) {
# check colorspace
if(any(is.na(img$img))) cat("NA's in img$img\n")
img$img[img$img < 0] <- as.integer(0)
img$img[is.na(img$img)] <- as.integer(0)
minimg <- min(img$img)
maximg <- max(img$img)
# should never be executed!!!
if (maximg > 65535) {
if(img$type=="rgb") warning("Found values smaller than 0 or larger than 65535. Please check!")
# img$img <- 65535*(img$img - minimg) / (maximg - minimg)
img$img[img$img> 65535] <- 65535
}
# end check colorspace
dimg <- img$dim
# define an image z of same size as img and fill with increasing numbers
z <- matrix(1:prod(dimg),nrow = dimg[1],ncol = dimg[2])
# define the clor map such that for every pixel the color is set
# according to the value of z
# color <-
# rgb(img$img[,,1]/65535,img$img[,,2]/65535,img$img[,,3]/65535)
# we do _not_ use build-in R function rgb() due to memory usage!
# define 0 to 255 in hexadecimal notation
hex <- c(0:9, LETTERS[1:6])
hex <- paste(hex[(0:255)%/%16+1],hex[(0:255)%%16+1],sep="")
color <- paste("#",hex[img$img[,,1]%/%256+1],hex[img$img[,,2]%/%256+1],hex[img$img[,,3]%/%256+1],sep="")
x <- seq(1,dimg0[1],length=dimg[1])
y <- seq(1,dimg0[2],length=dimg[2])
# display the image
image(x, y, z, col = color, asp = 1, xlab="",ylab="", ...)
}
show.greyscale <- function(img,dimg0,...) {
# if max.pixel is exceeded, shrink the image to a displayable size
dimg <- img$dim
# check colorspace
img$img[img$img < 0] <- 0
img$img[is.na(img$img)] <- 0
minimg <- min(img$img)
maximg <- max(img$img)
# should never be executed!!!
if (maximg > 65535) {
if(img$type=="rgb") warning("Found values smaller than 0 or larger than 65535. Please check!")
# img$img <- (img$img - minimg) / (maximg - minimg)
img$img[img$img> 65535] <- 65535
}
# end check colorspace
# define an image z of same size as img and fill with increasing numbers
z <- matrix(1:prod(dimg),nrow = dimg[1],ncol = dimg[2])
color <- grey(img$img/65535)
x <- seq(1,dimg0[1],length=dimg[1])
y <- seq(1,dimg0[2],length=dimg[2])
# display the image
image(x,y,z,col=color, asp=1, xlab="",ylab="",...)
}
read.ppm <- function(filename) {
# read header
con <- file(filename,"r")
type <- readLines(con,n=1)
count <- 0
while (TRUE) {
nl <- readLines(con,n=1)
if ((regexpr("^ *#", nl) != -1) || (regexpr("^ *$", nl) != -1)) {
count <- count + 1
} else {
size <- nl
break
}
}
size <- as.integer(strsplit(size," ")[[1]])
sizex <- as.integer(size[1])
sizey <- as.integer(size[2])
maxval <- as.integer(readLines(con,n=1))
if(is.na(maxval)) maxval <- 65535
# this should not occur but did, if assume 16 bit image
close(con)
# read all
if (type == "P3") {
img <- as.integer(scan(filename,"int",sizex*sizey*3,skip=3+count,quiet=TRUE))
if (maxval < 256) {
img <- img * 256 # make "16bit"
dd <- "8bit"
} else {
dd <- "16bit"
}
} else if (type == "P6") {
con <- file(filename,"rb")
ttt <- readLines(con,n=3+count) # header again
if (maxval > 255) {
# endianess not clear. use quasi-standard
img <- readBin(con,"int",n=sizex*sizey*3,2,signed=FALSE,endian="big")
dd <- "16bit"
} else {
img <- readBin(con,"int",n=sizex*sizey*3,1,signed=FALSE)
img <- img * 256 # make "16bit"
dd <- "8bit"
}
close(con)
} else {
stop("Cannot handle PPM type",type,"\n")
}
img <- as.integer(img)
dim(img) <- c(3,sizex,sizey)
img <- aperm(img,c(2,3,1))[,sizey:1,]
attr(img,"depth") <- dd
invisible(img)
}
read.pgm <- function(filename) {
# read header
con <- file(filename,"r")
type <- readLines(con,n=1)
count <- 0
while (TRUE) {
nl <- readLines(con,n=1)
if ((regexpr("^ *#", nl) != -1) || (regexpr("^ *$", nl) != -1)) {
count <- count + 1
} else {
size <- nl
break
}
}
size <- as.integer(strsplit(size," ")[[1]])
sizex <- as.integer(size[1])
sizey <- as.integer(size[2])
maxval <- as.integer(readLines(con,n=1))
close(con)
# read all
if (type == "P2") {
img <- as.integer(scan(filename,"int",sizex*sizey,skip=3+count,quiet=TRUE))
if (maxval < 256) {
img <- img * 256 # make "16bit"
dd <- "8bit"
} else {
dd <- "16bit"
}
} else if (type == "P5") {
con <- file(filename,"rb")
ttt <- readLines(con,n=3+count) # header again
if (maxval > 255) {
# endianess not clear. use quasi-standard
img <- readBin(con,"int",n=sizex*sizey*3,2,signed=FALSE,endian="big")
dd <- "16bit"
} else {
img <- readBin(con,"int",n=sizex*sizey*3,1,signed=FALSE)
img <- img * 256 # make "16bit"
dd <- "8bit"
}
close(con)
} else {
stop("Cannot handle PGM type",type,"\n")
}
img <- as.integer(img)
dim(img) <- c(sizex,sizey)
img <- img[,sizey:1]
attr(img,"depth") <- dd
invisible(img)
}
read.raw <- function (filename,type="PPM",wb="CAMERA",cspace="Adobe",interp="Bilinear",maxrange=TRUE,rm.ppm=TRUE,compress=TRUE) {
# check the image to be a grey-value png that can be interpreted as
# containing RAW-data
# otherwise just take it as a color image without gamma correction
fileparts <- strsplit(filename,"\\.")[[1]]
ext <- fileparts[length(fileparts)]
if(tolower(ext) == "png"){
img <- read.image(filename)
if(img$type=="RAW") {
img$depth <- "16bit"
img$orientation <- "horizontal"
img$interp <- "None"
img$cspace <- cspace
img$whitep <- "D65"
img$wb <- "CAMERA"
if(type!="RAW"){
img <- develop.raw(img,"BILINEAR",maxrange=TRUE)
}
}
return(invisible(img))
}
opt1 <- switch(toupper(type),PPM="-4",RAW="-4 -d",HALFSIZE="-h",INFO="-i -v","-4")
opt2 <- if (opt1 == "-i -v") NULL else switch(toupper(wb),NONE=NULL,AUTO="-a",CAMERA="-w")
opt3 <- switch(cspace,RAW="-o 0",sRGB=NULL,Adobe="-o 2",wGamut="-o 3",kodak="-o 4",XYZ="-o 5",NULL)
opt4 <- switch(interp,Bilinear="-q 0",VNG="-q 2",AHD="-q 3",FourC="-f","-q 0")
# VNG seems to provide minimal spatial correlation
tmpfile0 <- tempfile("raw")
tmpfile <- paste(c(tmpfile0,ext),collapse=".")
file.copy(filename,tmpfile)
if(!file.exists(Sys.which("dcraw"))) stop("Reading RAW images requires to install dcraw, see \n
http://cybercom.net/~dcoffin/dcraw/ for LINUX and http://www.insflug.org/raw/
for macOS and Windows \n")
system(paste("dcraw", opt1, opt2, opt3, opt4, tmpfile))
object <- list()
if(opt1 != "-i -v") {
if(opt1 == "-4 -d") {
filenamep <- paste(tmpfile0,".pgm",sep="")
object$img <- read.pgm(filenamep)
object$type <- "RAW"
interp <- "None"
cspace <- "CAMERA"
wb <- "None"
} else {
filenamep <- paste(tmpfile0,".ppm",sep="")
if (file.exists(filenamep)) {
object$img <- read.ppm(filenamep)
} else {
# ImageMagick under WINDOWS contains version of dcraw that
# creates image.ppm instead of filename.ppm
filename2 <- "image.ppm"
if (file.exists(filename2)) {
object$img <- read.ppm(filename2)
filenamep <- filename2
} else {
stop("cannot find neither ",filename," nor ",filename2,"\n")
}
}
object$type <- "rgb"
}
if(rm.ppm) file.remove(filenamep)
}
description <- system(paste("dcraw -i -v", filename),intern=TRUE)
object$description <- paste(description,collapse="\n",sep="")
object$depth <- attr(object$img, "depth")
attr(object$img, "depth") <- NULL
object$dim <- dim(object$img)[1:2]
if(object$type=="RAW") object$orientation <- if(object$dim[1]>=object$dim[2]) "horizontal" else "vertical"
object$file <- filename
object$interp <- interp
object$cspace <- cspace
object$whitep <- "D65"
object$gamma <- FALSE
object$gammatype <- "None"
object$wb <- toupper(wb)
if(compress) {
dim(object$img) <- NULL
object$img <- writeBin(as.integer(object$img),raw(),2)
}
object$compressed <- compress
class(object) <- "adimpro"
invisible(object)
}
plot.adimpro <- function(x, new = FALSE, gammatype=NULL, cspace=NULL, whitep=NULL, temp=NULL, black=0, exposure=1,...) {
if(!check.adimpro(x)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
if(x$compressed) x <- decompress.image(x)
if(!(is.null(gammatype)&&is.null(cspace)&&is.null(whitep)&&is.null(temp)&&exposure==1&&black==0)) {
x <- adjust.image(x, gammatype=gammatype, cspace=cspace, whitep=whitep, temp=temp, black=black,exposure=exposure,compress=FALSE)
}
if ("ni" %in% names(x)) {
aws <- TRUE
ni <- make.image(65535* x$ni / x$ni0, compress=FALSE, gammatype="None")
} else {
aws <- FALSE
}
if (x$type == "rgb") {
col1 <- "red"
col2 <- "green"
col3 <- "blue"
tt <- c("Red channel","Green channel","Blue channel")
xlim1 <- c(0,65535)
xlim2 <- c(0,65535)
xlim3 <- c(0,65535)
} else if (x$type == "hsi") {
col1 <- hsv(0:99/99,rep(1,100),rep(1,100))
col2 <- hsv(rep(1,100),0:99/99,rep(1,100))
col3 <- grey(0:99/99)
tt <- c("Hue","Saturation","Intensity")
xlim1 <- c(0,1)
xlim2 <- c(0,1)
xlim3 <- c(0,1)
} else if (x$type == "yuv") {
col1 <- grey(0:99/99)
col2 <- "green1"
col3 <- "green4"
tt <- c("Intensity","U channel","V channel")
xlim1 <- c(0,1)
xlim2 <- c(-.436,.436)
xlim3 <- c(-0.615,0.615)
} else if (x$type == "yiq") {
col1 <- grey(0:99/99)
col2 <- "blue1"
col3 <- "blue4"
tt <- c("Intensity","I channel","Q channel")
xlim1 <- c(0,1)
xlim2 <- c(-.596,.596)
xlim3 <- c(-.523,.523)
} else if (x$type == "xyz") {
col1 <- grey(0:99/99)
col2 <- "blue1"
col3 <- "blue4"
tt <- c("X channel","Y channel","Z channel")
xlim1 <- range(x$img[,,1])
xlim2 <- range(x$img[,,2])
xlim3 <- range(x$img[,,3])
} else if (x$type == "greyscale") {
col <- grey(0:99/99)
tt <- "Grey level"
xlim <- c(0,65535)
} else {
stop("Really dont know what to do with this image type! Sorry!")
}
if (x$type == "greyscale") {
if (aws) {
if (new) dev.new(width=5,height=5)
oldpar <- par(mfrow = c(2,2),mar=c(3,3,3,1))
on.exit(par(oldpar))
} else {
if (new) dev.new(width=7,height=3)
oldpar <- par(mfrow = c(1,3),mar=c(3,3,3,1))
on.exit(par(oldpar))
}
hist(x$img,100,col=col,border=col,xlim=xlim,main=tt)
show.image(x,max.x=400,max.y=400,gammatype=if(is.null(gammatype)) "ITU" else gammatype)
plot(c(0,1),c(0,1),type="n",xaxt="n",yaxt="n",xlab="",ylab="",frame.plot=FALSE)
text(0,1,paste("Image file",x$file),pos=4)
text(0,0.9,paste("Min",min(x$img)),pos=4)
text(0,0.8,paste("Max",max(x$img)),pos=4)
if (aws) show.image(ni,max.x=400,max.y=400)
} else {
if (new) dev.new(width=7,height=5)
oldpar <- par(mfrow = c(2,3),mar=c(3,3,3,1))
on.exit(par(oldpar))
hist(x$img[,,1],100,col=col1,border=col1,xlim=xlim1,main=tt[1])
hist(x$img[,,2],100,col=col2,border=col2,xlim=xlim2,main=tt[2])
hist(x$img[,,3],100,col=col3,border=col3,xlim=xlim3,main=tt[3])
show.image(x,max.x=400,max.y=400, gammatype=if(is.null(gammatype)) "ITU" else gammatype)
plot(c(0,1),c(0,1),type="n",xaxt="n",yaxt="n",xlab="",ylab="",frame.plot=FALSE)
text(0,1,paste("Image file",x$file),pos=4)
text(0,0.9,paste("Min",min(x$img)),pos=4)
text(0,0.8,paste("Max",max(x$img)),pos=4)
text(0,0.7,paste("Colorspace",x$cspace),pos=4)
if(is.character(x$whitep)) wp <- x$whitep else wp <- paste("Temp=",temp)
text(0,0.6,paste("White point",wp, paste("(",paste(signif(whitepoint(x$whitep),4),collapse=","),")")),pos=4)
if(black!=0) text(0,0.5,paste("Black",black),pos=4)
if(exposure!=1) text(0,0.4,paste("Exposure",exposure),pos=4)
text(0,0.3,paste("Gamma",x$gammatype),pos=4)
if (aws) show.image(ni,max.x=400,max.y=400)
}
}
summary.adimpro <- function(object, ...) {
if(!check.adimpro(object)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
# if(object$compressed) object <- decompress.image(object)
cat(" Image file:", object$file,"\n")
if(!is.null(object$xind))
cat("horizontal clipping:", min(object$xind),":",max(object$xind),"\n")
if(!is.null(object$yind))
cat(" vertical clipping:", min(object$yind),":",max(object$yind),"\n")
if(!is.null(object$rotate))
cat(" Image rotated by:", object$rotate*90,"degrees\n")
cat(" Image dimension:", object$dim,"\n")
cat(" Color space:", object$type)
if(object$type=="rgb") cat("(", object$cspace, ")")
cat("\n")
cat(" Color depth:", object$depth,"\n")
cat(" Gamma correction:", object$gamma," Type:", object$gammatype,"\n")
cat(" White point:", object$whitep,"\n")
if(!object$compressed) cat(" Range:", as.integer(range(object$img)),"\n")
if(object$compressed) cat(" Compressed image\n")
if (!is.null(object$hmax))
cat(" max. bandwidth:", signif(object$hmax,2),"\n")
if (!object$compressed && !is.null(object$ni))
cat("mean rel adaptation:", signif(mean(object$ni)/object$ni0,2),"\n")
if (!is.null(object$scorr))
cat("spatial correlation:", object$scorr,"\n")
if (!is.null(object$chcorr))
cat("channel correlation:", object$chcorr,"\n")
if (!is.null(object$varcoef))
cat("est. variance param:", object$varcoef,"\n")
if(!is.null(object$description)) {
cat("\nEXIF-Information:\n")
cat(object$description,"\n")
}
}
make.image <- function(x, compress=TRUE, gammatype="None", whitep="D65", cspace="Adobe", scale="Original", xmode="RGB"){
if(gammatype %in% c("ITU","sRGB","CIE")) {
gamma <- TRUE
} else {
gamma <- FALSE
gammatype <- "None"
}
dimg <- dim(x)
if(is.null(dimg) || !(length(dimg) %in% 2:3)) return(warning("x is not an array of appropriate dimensions."))
if(diff(range(x))==0) {
xmode=="RGB"
}
if(xmode=="RGB"){
if(diff(range(x))==0) {
x <- 0*x
} else {
if(scale=="Maxcontrast"){
if(length(dimg)==2){
x <- 65535*(x-min(x))/(max(x)-min(x))
} else {
for(i in 1:dimg[3]) x[,,i] <- 65535*(x[,,i]-min(x[,,i]))/(max(x[,,i])-min(x[,,i]))
}
} else {
if(min(x) < 0) x <- (x-min(x))/(max(x)-min(x))*max(x)
if( max(x) <= 1) x <- 65535 * x
if( max(x) > 65535 ) x <- x/max(x)*65535
}
}
dim(x) <- NULL
x <- if(compress) writeBin(as.integer(x),raw(),2) else array(as.integer(x),dimg)
img <- list(img=x, type=switch(length(dimg)-1,"greyscale","rgb"),depth="16bit",
dim=dimg[1:2], gamma=gamma, gammatype=gammatype,whitep=whitep,description="",
cspace=switch(length(dimg)-1,"greyscale",cspace), file="artificial",wb="MAKE.IMAGE",compressed=compress)
class(img) <- "adimpro"
} else {
# interprete components in x as HSI
if(min(x[,,1])<0||max(x[,,1])>1) {
x[,,1] <- (x[,,1]-min(x[,,1]))/(max(x[,,1])-min(x[,,1]))
}
if(min(x[,,2])<0||max(x[,,2])>1) {
x[,,2] <- (x[,,2]-min(x[,,2]))/(max(x[,,2])-min(x[,,2]))
}
if(min(x[,,3])<0||max(x[,,3])>1) {
x[,,3] <- (x[,,3]-min(x[,,3]))/(max(x[,,3])-min(x[,,3]))
}
img <- list(img=x, type="hsi",dim=dimg[1:2],depth="16bit", gamma=gamma, wb="UNKNOWN", file="artificial",compressed=FALSE, gammatype=gammatype, whitep=whitep,description="")
class(img) <- "adimpro"
img <- hsi2rgb(img)
}
invisible(img)
}
extract.ni <- function (object, gammatype = "ITU", compress=TRUE) {
if (!check.adimpro(object)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
if (object$compressed)
object <- decompress.image(object)
if ("ni" %in% names(object)) {
aws <- TRUE
ni <- make.image(65535 * object$ni/object$ni0, compress = compress, gammatype = gammatype)
}
else {
stop("image was not processed by awsimage or awspimage")
}
invisible(ni)
}
extract.image <- function (object) {
if (!check.adimpro(object)) {
stop(" Consistency check for argument object failed (see warnings).\n")
}
if (object$compressed)
object <- decompress.image(object)
invisible(object$img)
}
## TODO: This function should be generalized to arbitrary Tags and should still work for RAW and JPG
extract.info <- function(object, what="Bayer"){
if (inherits(object, "adimpro")) {
description <- object$description
} else {
description <- as.character(object)
}
if(!is.null(description)){
erg<-switch(what,
Bayer=substr(strsplit(description,"Filter pattern: ")[[1]][2],1,4),
Daymulti=strsplit(description,"Daylight multipliers: ")[[1]][2],
Cammulti=strsplit(description,"Camera multipliers: ")[[1]][2],
Camera=strsplit(description,"Camera: ")[[1]][2],
Isize=strsplit(description,"Image size: ")[[1]][2],
Osize=strsplit(description,"Output size: ")[[1]][2],
File=strsplit(description,"File: ")[[1]][2],
Interpolation=strsplit(description,"Interpolation: ")[[1]][2],
Gammatype=strsplit(description,"Gammatype: ")[[1]][2],
WhiteBalance=strsplit(description,"White Balance: ")[[1]][2],
WhitePoint=strsplit(description,"White Point: ")[[1]][2],
Cspace=strsplit(description,"Color Space: ")[[1]][2],
Type=strsplit(description,"Type: ")[[1]][2],
xind=strsplit(description,"Xind: ")[[1]][2],
yind=strsplit(description,"Yind: ")[[1]][2],
NULL
)
if(!is.null(erg)&&is.na(erg)) erg <- NULL
# case of no information
if(!is.null(erg)) {
erg <- strsplit(erg,"\n")[[1]][1]
if(what%in%c("xind","yind")) {
erg <- strsplit(erg,":")[[1]]
erg <- as.integer(erg[1]):as.integer(erg[2])
}
if(what %in% c("Daymulti","Cammulti")){
zz <- textConnection(erg)
erg <- scan(zz, numeric(1))
close(zz)
}
}
} else {
erg <- NULL
}
erg
}
modify.info <- function(img,add=TRUE){
if(!is.null(img$description)){
z <- textConnection(img$description,"r")
description <- readLines(z)
close(z)
if(add){
description <- c(description,paste("File:",img$file),
paste("Interpolation:",img$interp),
paste("Gammatype:",img$gammatype),
paste("White Balance:",img$wb),
paste("White Point:",img$whitep),
paste("Type:",img$type),
paste("Color Space:",img$cspace),
if(!is.null(img$xind)) paste("Xind:",paste(min(img$xind),max(img$xind),sep=":")),
if(!is.null(img$yind)) paste("Yind:",paste(min(img$yind),max(img$yind),sep=":")))
} else {
# remove components that are stored elsewhere
description <- strsplit(img$description,"File: ")[[1]][1]
}
}
img$description <- paste(description,collapse="\n",sep="")
img
}
develop.raw <- function(object,method="BILINEAR",wb=c(1,1,1),maxrange=TRUE,compress=TRUE){
#
# converts Sensor data into RGB-images
# white balance is applied as a correction on the sensor data
# in contrast to other functions where white balance is done in XYZ
#
method <- toupper(method)
if(!(method %in% c("FULL","HALF","BILINEAR","MEDIAN16","MEDIAN4"))) stop("Method not implemented")
if(object$type!="RAW") stop("object does not contain RAW sensor data,
please read the image by read.raw(filename,type=''RAW'')")
if(object$compressed) object <- decompress.image(object)
dimg <- dim(object$img)
n1 <- dimg[1]
n2 <- dimg[2]
bayer <- switch(extract.info(object),RGGB=1,GRBG=2,BGGR=3,GBRG=4)
if(extract.info(object,"Isize")!=extract.info(object,"Osize")) bayer <- bayer+1
bayer <- (bayer-1)%%4+1
if(!is.null(object$rotate)) {
bayer <- object$rotate+bayer
bayer <- (bayer-1)%%4+1
}
if(any(wb!=1)){
# White balance if specified
object$img <- matrix(.Fortran(C_wbalance,
sensor=as.integer(object$img),
as.integer(n1),
as.integer(n2),
as.double(wb),
as.integer(bayer),
PACKAGE="adimpro")$sensor,n1,n2)
}
if(maxrange){
minimg <- min(object$img)
rangeimg <- max(object$img)-minimg
object$img <- matrix(as.integer((object$img-minimg)/rangeimg*65535),n1,n2)
}
h1 <- switch(method,FULL=n1-4,HALF=n1%/%2-1,MEDIAN16=n1-6,MEDIAN16=n1-2,n1)
h2 <- switch(method,FULL=n2-4,HALF=n2%/%2-1,MEDIAN16=n2-6,MEDIAN16=n1-2,n2)
theta <- array(switch(method,
FULL=.Fortran(C_fullsize,
as.integer(object$img),
theta=integer(h1*h2*3),
as.integer(n1),
as.integer(n2),
as.integer(h1),
as.integer(h2),
as.integer(bayer),
PACKAGE="adimpro")$theta,
HALF=.Fortran(C_halfsize,
as.integer(object$img),
theta=integer(h1*h2*3),
as.integer(n1),
as.integer(n2),
as.integer(h1),
as.integer(h2),
as.integer(bayer),
PACKAGE="adimpro")$theta,
BILINEAR=.Fortran(C_indemos4,
as.integer(object$img),
theta=integer(n1*n2*3),
as.integer(n1),
as.integer(n2),
as.integer(bayer),
as.integer(rep(1,3*n1*n2)),
integer(3*n1*n2),
PACKAGE="adimpro")$theta,
MEDIAN16=.Fortran(C_demmed16,
as.integer(object$img),
theta=integer(h1*h2*3),
as.integer(n1),
as.integer(n2),
as.integer(h1),
as.integer(h2),
as.integer(bayer),
PACKAGE="adimpro")$theta,
MEDIAN4=.Fortran(C_demmed4,
as.integer(object$img),
theta=integer(h1*h2*3),
as.integer(n1),
as.integer(n2),
as.integer(h1),
as.integer(h2),
as.integer(bayer),
PACKAGE="adimpro")$theta),c(h1,h2,3))
n <- h1*h2
out.cam <- cam2rgbmat(object)
object$img <- array(.Fortran(C_cam2rgb,
as.integer(theta),
as.integer(n),
as.double(out.cam),
theta=integer(n*3),
PACKAGE="adimpro")$theta,c(h1,h2,3))
object$type <- "rgb"
object$dim <- c(h1,h2)
object$interp <- method
if(method=="HALF"){
if(!is.null(object$xind)) object$xind<-unique(object$xind[-1]%/%2)
if(!is.null(object$yind)) object$yind<-unique(object$yind[-1]%/%2)
}
invisible(if(compress) compress.image(object) else object)
}
adimpro2biOps <- function(img) {
if (!("adimpro" %in% class(img))) stop("No adimpro object!")
if (img$compressed) {
nimg <- extract.image(img)
} else {
nimg <- img$img
}
if (length(dim(nimg)) == 3) { # RGB image
nimg <- aperm(nimg, c(2,1,3))
type <- "rgb"
nimg <- nimg[dim(nimg)[1]:1,,]
} else if (length(dim(nimg)) == 2) { # greyscale
nimg <- t(nimg)
type <- "grey"
nimg <- nimg[dim(nimg)[1]:1,]
} else {
stop("ERROR: Image data has dimension",dim(nimg),"do not know what to do! Expecting (x,y,3) or (x,y)!")
}
nimg <- nimg/256
attr(nimg, "type") <- type
class(nimg) <- c("imagedata", class(nimg))
invisible(nimg)
}
biOps2adimpro <- function(img,
gammatype = "ITU",
whitep = "D65",
cspace = "sRGB") {
if (!("imagedata" %in% class(img))) stop("No imagedata (biOps) object!")
if (length(dim(img)) == 3) { # RGB image
img <- aperm(img, c(2,1,3))
type <- "rgb"
img <- img[,dim(img)[2]:1,]
} else if (length(dim(img)) == 2) { # greyscale
img <- t(img)
type <- "greyscale"
img <- img[,dim(img)[2]:1]
} else {
stop("ERROR: Image data has dimension",dim(img),"do not know what to do! Expecting (x,y,3) or (x,y)!")
}
img <- img/255 # biOps seems to expect range [0,255]
# don't know which default values!!
invisible(make.image(img,
compress = TRUE,
gammatype = gammatype,
whitep = whitep,
cspace = cspace,
scale = "Original",
xmode = "RGB"))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.