From 279f924eb233d698a76fc529a914dcb25eb33321 Mon Sep 17 00:00:00 2001 From: Stefan Hoffmeister Date: Sun, 27 May 2018 23:16:07 +0200 Subject: [PATCH 1/3] Use RStudio Code -> Reindent Lines to create consistent indentation with spaces only; this is a whitespace change only --- R/pnm.R | 239 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 120 insertions(+), 119 deletions(-) diff --git a/R/pnm.R b/R/pnm.R index 847161c..e16e2b3 100644 --- a/R/pnm.R +++ b/R/pnm.R @@ -1,73 +1,74 @@ read.pnm <- function(file, ...) + { - fsz <- file.info(file)$size - con <- file(file, open="rb") - - pnmhead <- read.pnmhead(con) - retval <- read.pnmdata(con, pnmhead, ...) - - if (fsz != seek(con)) - warning("Possible reading error: file size ", fsz, - " bytes, but ", seek(con), " bytes read") - close(con) - retval + fsz <- file.info(file)$size + con <- file(file, open="rb") + + pnmhead <- read.pnmhead(con) + retval <- read.pnmdata(con, pnmhead, ...) + + if (fsz != seek(con)) + warning("Possible reading error: file size ", fsz, + " bytes, but ", seek(con), " bytes read") + close(con) + retval } read.pnmdata <- function(con, pnmhead, ...) { - ds <- pnmhead$datastart - seek(con, ds) - type <- pnmhead$type - nl <- ifelse(type == "ppm", 3, 1) - nc <- pnmhead$nc - nr <- pnmhead$nr - ncells <- nl*nc*nr - if (pnmhead$ascii) { - xx <- scan(con, integer(0), n=ncells) + ds <- pnmhead$datastart + seek(con, ds) + type <- pnmhead$type + nl <- ifelse(type == "ppm", 3, 1) + nc <- pnmhead$nc + nr <- pnmhead$nr + ncells <- nl*nc*nr + if (pnmhead$ascii) { + xx <- scan(con, integer(0), n=ncells) + } + else { + if (type == "pbm") { ## black & white, i.e. pixel = bit + BytesPerRow <- ceiling(nc/8) + bxx <- readBin(con, "integer", + n=nr*BytesPerRow, size=1, signed=FALSE) + + as.integer.bytes <- function (x) { + ## unpacks bytes in 0:255 into {0,1} integers + n <- length(x <- as.integer(x)) + if (any(x < 0) || any(x > 255)) + stop("Not an unsigned byte (value outside 0:255)") + ans <- matrix(integer(8 * n), 8, n) + two <- as.integer(2) + for (i in 8:1) { + ans[i,] <- x %% two + x <- x %/% two + } + ans + } + + xx <- as.integer.bytes(bxx) + ncb <- BytesPerRow*8 + xx <- 1 - array(xx, c(nl, ncb, nr))[,1:nc,] } else { - if (type == "pbm") { ## black & white, i.e. pixel = bit - BytesPerRow <- ceiling(nc/8) - bxx <- readBin(con, "integer", - n=nr*BytesPerRow, size=1, signed=FALSE) - - as.integer.bytes <- function (x) { - ## unpacks bytes in 0:255 into {0,1} integers - n <- length(x <- as.integer(x)) - if (any(x < 0) || any(x > 255)) - stop("Not an unsigned byte (value outside 0:255)") - ans <- matrix(integer(8 * n), 8, n) - two <- as.integer(2) - for (i in 8:1) { - ans[i,] <- x %% two - x <- x %/% two - } - ans - } - - xx <- as.integer.bytes(bxx) - ncb <- BytesPerRow*8 - xx <- 1 - array(xx, c(nl, ncb, nr))[,1:nc,] - } - else { - xx <- readBin(con, "integer", - n=ncells, size=1, signed=FALSE) - } - } - - res <- array(xx, dim = c(nl, nc, nr)) / pnmhead$maxval - - if(nl==1) { ## non-RGB: - ##FIXME(MM): use "indexed" for B&W - z = pixmapGrey(t(res[1,,]), ...) - } - else{ - z = pixmapRGB(0, ncol=dim(res)[2], nrow=dim(res)[3], ...) - z@red = t(res[1,,]) - z@green = t(res[2,,]) - z@blue = t(res[3,,]) + xx <- readBin(con, "integer", + n=ncells, size=1, signed=FALSE) } - z + } + + res <- array(xx, dim = c(nl, nc, nr)) / pnmhead$maxval + + if(nl==1) { ## non-RGB: + ##FIXME(MM): use "indexed" for B&W + z = pixmapGrey(t(res[1,,]), ...) + } + else{ + z = pixmapRGB(0, ncol=dim(res)[2], nrow=dim(res)[3], ...) + z@red = t(res[1,,]) + z@green = t(res[2,,]) + z@blue = t(res[3,,]) + } + z } @@ -75,64 +76,64 @@ read.pnmdata <- function(con, pnmhead, ...) write.pnm <- function(object, file=NULL, forceplain=FALSE, type=NULL, maxval=255) { - if(!is(object, "pixmap")) - stop("Can only write pixmap objects") - - if(is.null(type)) - type <- if(is(object, "pixmapGrey")) "pgm" else "ppm" - else - type <- match.arg(type, c("pbm", "pgm", "ppm")) - do <- object@size - - switch(type, - "pbm" = { - object <- as(object, "pixmapGrey") - object <- t(object@grey < 0.5) - storage.mode(object) <- "integer" - code <- 4 - forceplain <- TRUE - }, - "pgm" = { - object <- as(object, "pixmapGrey") - object <- t(round(object@grey*maxval, 0)) - storage.mode(object) <- "integer" - code <- 5 - }, - "ppm" = { - object <- as(object, "pixmapRGB") - object1 <- array(0, dim=c(3, do[2], do[1])) - object1[1,,] <- t(object@red) - object1[2,,] <- t(object@green) - object1[3,,] <- t(object@blue) - object <- object1 - object <- round(object*maxval, 0) - storage.mode(object) <- "integer" - code <- 6 - }) - - if (is.null(file)) file <- paste("Rimage.", type, sep="") - comment <- "# R write.pnm output" - if(forceplain) { - con <- file(file, open="w") - code <- code - 3 - cat("P", code, "\n", file=con, sep="") - cat(comment, "\n", file=con, sep="") - cat(do[2], " ", do[1], "\n", file=con, sep="") - if (type != "pbm") - cat(maxval, "\n", file=con, sep="") - - write(object, ncolumns=3, file=con) - } - else { - con <- file(file, open="wb") - writeChar(paste("P", code, "\n", sep=""), con=con, eos=NULL) - writeChar(paste(comment, "\n", sep=""), con=con, eos=NULL) - writeChar(paste(do[2], " ", do[1], "\n", sep=""), - con=con, eos=NULL) - if (type != "pbm") writeChar(paste(maxval, "\n", sep=""), + if(!is(object, "pixmap")) + stop("Can only write pixmap objects") + + if(is.null(type)) + type <- if(is(object, "pixmapGrey")) "pgm" else "ppm" + else + type <- match.arg(type, c("pbm", "pgm", "ppm")) + do <- object@size + + switch(type, + "pbm" = { + object <- as(object, "pixmapGrey") + object <- t(object@grey < 0.5) + storage.mode(object) <- "integer" + code <- 4 + forceplain <- TRUE + }, + "pgm" = { + object <- as(object, "pixmapGrey") + object <- t(round(object@grey*maxval, 0)) + storage.mode(object) <- "integer" + code <- 5 + }, + "ppm" = { + object <- as(object, "pixmapRGB") + object1 <- array(0, dim=c(3, do[2], do[1])) + object1[1,,] <- t(object@red) + object1[2,,] <- t(object@green) + object1[3,,] <- t(object@blue) + object <- object1 + object <- round(object*maxval, 0) + storage.mode(object) <- "integer" + code <- 6 + }) + + if (is.null(file)) file <- paste("Rimage.", type, sep="") + comment <- "# R write.pnm output" + if(forceplain) { + con <- file(file, open="w") + code <- code - 3 + cat("P", code, "\n", file=con, sep="") + cat(comment, "\n", file=con, sep="") + cat(do[2], " ", do[1], "\n", file=con, sep="") + if (type != "pbm") + cat(maxval, "\n", file=con, sep="") + + write(object, ncolumns=3, file=con) + } + else { + con <- file(file, open="wb") + writeChar(paste("P", code, "\n", sep=""), con=con, eos=NULL) + writeChar(paste(comment, "\n", sep=""), con=con, eos=NULL) + writeChar(paste(do[2], " ", do[1], "\n", sep=""), con=con, eos=NULL) - writeBin(as.integer(as.vector(object)), con, size=1) - } - close(con) + if (type != "pbm") writeChar(paste(maxval, "\n", sep=""), + con=con, eos=NULL) + writeBin(as.integer(as.vector(object)), con, size=1) + } + close(con) } From 2033b88bf0e77d7ac6ef56b82f7f2e791cbcbce3 Mon Sep 17 00:00:00 2001 From: Stefan Hoffmeister Date: Sun, 27 May 2018 23:19:08 +0200 Subject: [PATCH 2/3] Enable reading of files with cells comprising of two bytes (maxval = 65535) --- R/pnm.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/pnm.R b/R/pnm.R index e16e2b3..e3dfc9e 100644 --- a/R/pnm.R +++ b/R/pnm.R @@ -51,8 +51,11 @@ read.pnmdata <- function(con, pnmhead, ...) xx <- 1 - array(xx, c(nl, ncb, nr))[,1:nc,] } else { + dataSize <- 1 + if (pnmhead$maxval > 255) + dataSize <- 2 xx <- readBin(con, "integer", - n=ncells, size=1, signed=FALSE) + n=ncells, size=dataSize, signed=FALSE) } } From de316e49c44d5c5ad0ab4d1d833ac61e5372cbe7 Mon Sep 17 00:00:00 2001 From: Stefan Hoffmeister Date: Mon, 28 May 2018 00:35:20 +0200 Subject: [PATCH 3/3] Remove runtime warning In rep(cellres, length = 2) : 'x' is NULL so the result will be NULL --- R/pixmap.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/pixmap.R b/R/pixmap.R index b243276..289fe35 100644 --- a/R/pixmap.R +++ b/R/pixmap.R @@ -33,7 +33,8 @@ pixmap <- function(data=NULL, nrow=dim(data)[1], ncol=dim(data)[2], bbox=NULL, bbcent=FALSE, cellres=NULL) { - cellres <- rep(cellres, length=2) + if (!is.null(cellres)) + cellres <- rep(cellres, length=2) if(is.null(bbox)){ if(is.null(cellres)) cellres <- c(1,1)