From 3fdec074f66de3b323190d2dabd953dd995c8fb7 Mon Sep 17 00:00:00 2001 From: Adrian Baddeley Date: Sun, 29 Sep 2024 12:03:41 +0800 Subject: [PATCH] Marks of a tessellation may be a hyperframe --- DESCRIPTION | 4 +- NEWS | 15 +++++ R/tess.R | 127 ++++++++++++++++++++++++++++--------- inst/doc/packagesizes.txt | 1 + inst/info/packagesizes.txt | 1 + man/marks.tess.Rd | 8 +-- man/tess.Rd | 3 +- 7 files changed, 121 insertions(+), 38 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e99eecd..0f53b51 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: spatstat.geom -Version: 3.3-3 -Date: 2024-09-18 +Version: 3.3-3.001 +Date: 2024-09-29 Title: Geometrical Functionality of the 'spatstat' Family Authors@R: c(person("Adrian", "Baddeley", role = c("aut", "cre", "cph"), diff --git a/NEWS b/NEWS index a95f545..b87a30f 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,18 @@ + CHANGES IN spatstat.geom VERSION 3.3-3.001 + +OVERVIEW + + o Tessellations can have any kind of marks + +SIGNIFICANT USER-VISIBLE CHANGES + + o tess, marks<-.tess + A tessellation can now have any kind of marks + (vector, list, data frame or hyperframe). + + o intersect.tess + Now handles marks of any kind (vector, list, data frame or hyperframe). + CHANGES IN spatstat.geom VERSION 3.3-3 OVERVIEW diff --git a/R/tess.R b/R/tess.R index 0f0f235..78a51ae 100644 --- a/R/tess.R +++ b/R/tess.R @@ -3,7 +3,7 @@ # # support for tessellations # -# $Revision: 1.111 $ $Date: 2024/02/04 08:04:51 $ +# $Revision: 1.113 $ $Date: 2024/09/29 03:41:18 $ # tess <- function(..., xgrid=NULL, ygrid=NULL, tiles=NULL, image=NULL, window=NULL, marks=NULL, keepempty=FALSE, @@ -106,7 +106,14 @@ tess <- function(..., xgrid=NULL, ygrid=NULL, tiles=NULL, image=NULL, } else stop("Internal error: unrecognised format") ## add marks! if(!is.null(marks)) { - marks <- as.data.frame(marks) + mf <- markformat(marks) + switch(mf, + none = { marks <- NULL }, + list = { marks <- hyperframe(marks=marks, row.names=NULL) }, + vector = { marks <- data.frame(marks=marks, row.names=NULL) }, + dataframe = , + hyperframe = { row.names(marks) <- NULL } + ) if(nrow(marks) != out$n) stop(paste("wrong number of marks:", nrow(marks), "should be", out$n), @@ -155,10 +162,43 @@ print.tess <- function(x, ..., brief=FALSE) { } else splat(nlev, "tiles (levels of a pixel image)") }) if(!is.null(marx <- x$marks)) { - m <- dim(marx)[2] %orifnull% 1 - if(m == 1) splat("Tessellation is marked") else - splat("Tessellation has", m, "columns of marks:", - commasep(sQuote(colnames(marx)))) + mf <- markformat(marx) + switch(mf, + none = { }, + vector = { + splat("Tessellation has", paste0(typeof(marx), "-valued marks")) + }, + list = { + if(is.solist(marx)) { + splat("Tessellation has a list of spatial objects as marks") + } else { + cls <- unique(sapply(marks, class)) + if(!is.character(cls)) { + splat("Tessellation has a list of marks") + } else { + splat("Tessellation has a list of marks of class", + commasep(sQuote(cls))) + } + } + }, + dataframe = { + splat("Tessellation has a data frame of marks:") + nc <- ncol(marx) + cn <- colnames(marx) + ty <- unname(sapply(marx, typeof)) + for(i in seq_len(nc)) { + cat(paste0("\t$", cn[i], ":\t\t", ty[i], "\n")) + } + }, + hyperframe = { + splat("Tessellation has a hyperframe of marks:") + nc <- ncol(marx) + cn <- colnames(marx) + cls <- sQuote(unclass(marx)$vclass) + for(i in seq_len(nc)) { + cat(paste0("\t$", cn[i], ":\t\t", cls[i], "\n")) + } + }) } if(full) print(win) invisible(NULL) @@ -552,14 +592,19 @@ marks.tess <- function(x, ...) { "marks<-.tess" <- function(x, ..., value) { stopifnot(is.tess(x)) if(!is.null(value)) { - value <- as.data.frame(value) + mf <- markformat(value) + switch(mf, + none = { value <- NULL }, + list = { value <- hyperframe(marks=value, row.names=NULL) }, + vector = { value <- data.frame(marks=value, row.names=NULL) }, + dataframe = , + hyperframe = { row.names(value) <- NULL } + ) ntil <- x$n if(nrow(value) != ntil) stop(paste("replacement value for marks has wrong length:", nrow(value), "should be", ntil), call.=FALSE) - rownames(value) <- NULL - if(ncol(value) == 1) colnames(value) <- "marks" } x$marks <- value return(x) @@ -837,7 +882,7 @@ intersect.tess <- function(X, Y, ..., keepempty=FALSE, keepmarks=FALSE, sep="x") if(keepmarks) { marx <- marks(X) if(!is.null(marx)) - marx <- as.data.frame(marx)[!isempty, , drop=FALSE] + marx <- marksubset(marx, !isempty) marks(out) <- marx } return(out) @@ -854,22 +899,43 @@ intersect.tess <- function(X, Y, ..., keepempty=FALSE, keepmarks=FALSE, sep="x") if(keepmarks) { ## initialise the mark variables to be inherited from parent tessellations - Xmarks <- as.data.frame(marks(X)) - Ymarks <- as.data.frame(marks(Y)) - gotXmarks <- (ncol(Xmarks) > 0) - gotYmarks <- (ncol(Ymarks) > 0) + Xmarks <- marks(X) + Ymarks <- marks(Y) + mfX <- markformat(Xmarks) + mfY <- markformat(Ymarks) + gotXmarks <- (mfX != "none") + gotYmarks <- (mfY != "none") if(gotXmarks && gotYmarks) { - colnames(Xmarks) <- paste0("X", colnames(Xmarks)) - colnames(Ymarks) <- paste0("Y", colnames(Ymarks)) + ## marks from each input will be combined as separate columns + switch(mfX, + vector = { Xmarks <- data.frame(Xmarks=Xmarks) }, + list = { Xmarks <- hyperframe(Xmarks=Xmarks) }, + hyperframe = , + dataframe = { + colnames(Xmarks) <- paste0("X", colnames(Xmarks)) + }) + switch(mfY, + vector = { Ymarks <- data.frame(Ymarks=Ymarks) }, + list = { Ymarks <- hyperframe(Ymarks=Ymarks) }, + hyperframe = , + dataframe = { + colnames(Ymarks) <- paste0("Y", colnames(Ymarks)) + }) + ## ensure hyperframe code is dispatched where required + if(is.hyperframe(Xmarks) && !is.hyperframe(Ymarks)) + Ymarks <- as.hyperframe(Ymarks) + if(!is.hyperframe(Xmarks) && is.hyperframe(Ymarks)) + Xmarks <- as.hyperframe(Xmarks) } + ## initialise if(gotXmarks || gotYmarks) { marx <- if(gotXmarks && gotYmarks) { - cbind(Xmarks[integer(0), , drop=FALSE], - Ymarks[integer(0), , drop=FALSE]) + cbind(marksubset(Xmarks, integer(0)), + marksubset(Ymarks, integer(0))) } else if(gotXmarks) { - Xmarks[integer(0), , drop=FALSE] + marksubset(Xmarks, integer(0)) } else { - Ymarks[integer(0), , drop=FALSE] + marksubset(Ymarks, integer(0)) } } else keepmarks <- FALSE } @@ -879,22 +945,21 @@ intersect.tess <- function(X, Y, ..., keepempty=FALSE, keepmarks=FALSE, sep="x") for(i in seq_along(Xtiles)) { Xi <- Xtiles[[i]] Ti <- lapply(Ytiles, intersect.owin, B=Xi, ..., fatal=FALSE) - isempty <- !keepempty & sapply(Ti, is.empty) - nonempty <- !isempty - if(any(nonempty)) { - Ti <- Ti[nonempty] - names(Ti) <- if(Xtrivial) namesY[nonempty] else - paste(namesX[i], namesY[nonempty], sep=sep) + keep <- keepempty | !sapply(Ti, is.empty) + if(any(keep)) { + Ti <- Ti[keep] + names(Ti) <- if(Xtrivial) namesY[keep] else + paste(namesX[i], namesY[keep], sep=sep) Ztiles <- append(Ztiles, Ti) if(keepmarks) { extra <- if(gotXmarks && gotYmarks) { - data.frame(X=Xmarks[i, ,drop=FALSE], - Y=Ymarks[nonempty, ,drop=FALSE], - row.names=NULL) + cbind(marksubset(Xmarks, i), + marksubset(Ymarks, keep), + row.names=NULL) } else if(gotYmarks) { - Ymarks[nonempty, ,drop=FALSE] + marksubset(Ymarks, keep) } else { - Xmarks[rep(i, sum(nonempty)), ,drop=FALSE] + marksubset(Xmarks, rep(i, sum(keep))) } marx <- rbind(marx, extra) } diff --git a/inst/doc/packagesizes.txt b/inst/doc/packagesizes.txt index c087d73..687fb19 100755 --- a/inst/doc/packagesizes.txt +++ b/inst/doc/packagesizes.txt @@ -29,3 +29,4 @@ date version nhelpfiles nobjects ndatasets Rlines srclines "2024-07-05" "3.3-0" 442 1186 0 35638 15596 "2024-07-09" "3.3-2" 442 1186 0 35638 15596 "2024-09-18" "3.3-3" 443 1187 0 35818 15596 +"2024-09-29" "3.3-3.001" 443 1187 0 35883 15596 diff --git a/inst/info/packagesizes.txt b/inst/info/packagesizes.txt index c087d73..687fb19 100755 --- a/inst/info/packagesizes.txt +++ b/inst/info/packagesizes.txt @@ -29,3 +29,4 @@ date version nhelpfiles nobjects ndatasets Rlines srclines "2024-07-05" "3.3-0" 442 1186 0 35638 15596 "2024-07-09" "3.3-2" 442 1186 0 35638 15596 "2024-09-18" "3.3-3" 443 1187 0 35818 15596 +"2024-09-29" "3.3-3.001" 443 1187 0 35883 15596 diff --git a/man/marks.tess.Rd b/man/marks.tess.Rd index 5d7634e..bdedb70 100644 --- a/man/marks.tess.Rd +++ b/man/marks.tess.Rd @@ -28,7 +28,7 @@ } } \value{ - For \code{marks(x)}, the result is a vector, factor or data frame, + For \code{marks(x)}, the result is a vector, factor, data frame or hyperframe, containing the mark values attached to the tiles of \code{x}. If there are no marks, the result is \code{NULL}. @@ -50,13 +50,13 @@ dataset \code{x}, and updates the dataset \code{x} in the current environment. - The marks can be a vector, a factor, or a data frame. + The marks can be a vector, a factor, a data frame or a hyperframe. For the assignment \code{marks(x) <- value}, the \code{value} should be a vector or factor of length equal to the number of - tiles in \code{x}, or a data frame with as many rows + tiles in \code{x}, or a data frame or hyperframe with as many rows as there are tiles in \code{x}. If \code{value} is a single value, - or a data frame with one row, then it will be replicated + or a data frame or hyperframe with one row, then it will be replicated so that the same marks will be attached to each tile. To remove marks, use \code{marks(x) <- NULL} or \code{unmark(x)}. diff --git a/man/tess.Rd b/man/tess.Rd index fcdf5d5..90de600 100644 --- a/man/tess.Rd +++ b/man/tess.Rd @@ -31,7 +31,8 @@ An object of class \code{"owin"}. } \item{marks}{ - Optional vector or data frame of marks associated with the tiles. + Optional vector, data frame or hyperframe + of marks associated with the tiles. } \item{keepempty}{ Logical flag indicating whether empty tiles should be retained