R/hypersub.R

In spatstat.geom: Geometrical Functionality of the 'spatstat' Family

##
## hypersub.R
##
##
##  subset operations for hyperframes
##
##  $Revision: 1.29 $    $Date: 2023/02/03 00:45:34 $
##

"[.hyperframe" <- function(x, i, j, drop=FALSE, strip=drop, ...) {
  x <- unclass(x)
  if(!missing(i)) {
    if(length(dim(i)) > 1)
      stop("Matrix index i is not supported in '[.hyperframe'", call.=FALSE)
    y <- x
    y$df     <- x$df[i, , drop=FALSE]
    y$ncases <- nrow(y$df)
    y$hypercolumns <- lapply(x$hypercolumns, "[", i=i)
    x <- y
  }
  if(!missing(j)) {
    if(length(dim(j)) > 1)
      stop("Matrix index j is not supported in '[.hyperframe'", call.=FALSE)
    y <- x
    patsy <- seq_len(y$nvars)
    names(patsy) <- y$vname
    jj <- patsy[j]
    names(jj) <- NULL
    y$nvars <- length(jj)
    y$vname <- vname <- x$vname[jj]
    y$vtype <- vtype <- x$vtype[jj]
    y$vclass <- x$vclass[jj]
    if(ncol(x$df) != 0) 
      y$df    <- x$df[ , vname[vtype == "dfcolumn"], drop=FALSE]
    y$hyperatoms <- x$hyperatoms[ vname[ vtype == "hyperatom" ]]
    y$hypercolumns <- x$hypercolumns[ vname [ vtype == "hypercolumn" ] ]
    x <- y
  }
  if(drop) {
    nrows <- x$ncases
    ncols <- x$nvars
    if(nrows == 1 && ncols == 1 && strip) {
      ## return a single object 
      y <- switch(as.character(x$vtype),
                  dfcolumn    = x$df[, , drop=TRUE],
                  hypercolumn = (x$hypercolumns[[1L]])[[1L]],
                  hyperatom   = x$hyperatoms[[1L]])
      return(y)
    } else if(nrows == 1) {
      ## return the row as a vector or a list
      if(strip && all(x$vtype == "dfcolumn"))
        return(x$df[ , , drop=TRUE])
      n <- x$nvars
      y <- vector(mode="list", length=n)
      names(y) <- nama <- x$vname
      for(k in seq_len(n)) {
        namk <- nama[k]
        y[[k]] <- switch(as.character(x$vtype[k]),
                         dfcolumn = x$df[ , namk, drop=TRUE],
                         hyperatom = x$hyperatoms[[namk]],
                         hypercolumn = (x$hypercolumns[[namk]])[[1L]]
                         )
      }
      return(as.solist(y, demote=TRUE))
    } else if(ncols == 1) {
      ## return a column as an 'anylist'/'solist' or a vector
      switch(as.character(x$vtype),
             dfcolumn = {
               return(x$df[, , drop=TRUE])
             },
             hypercolumn = {
               y <- as.solist(x$hypercolumns[[1L]], demote=TRUE)
               names(y) <- row.names(x$df)
               return(y)
             },
             hyperatom = {
               ## replicate it to make a hypercolumn
               ha <- x$hyperatoms[1L]
               names(ha) <- NULL
               hc <- rep.int(ha, x$ncases)
               hc <- as.solist(hc, demote=TRUE)
               names(hc) <- row.names(x$df)
               return(hc)
             }
           )
    }
  }
  class(x) <- c("hyperframe", class(x))
  return(x)
}

"$.hyperframe" <- function(x,name) {
  m <- match(name, unclass(x)$vname)
  if(is.na(m))
    return(NULL)
  return(x[, name, drop=TRUE, strip=FALSE])
}

"$<-.hyperframe" <- function(x, name, value) {
  y <- as.list(x)
  if(is.hyperframe(value)) {
    if(ncol(value) == 1) {
      y[name] <- as.list(value)
    } else {
      y <- insertinlist(y, name, as.list(value))
    }
  } else {
    dfcol <- is.atomic(value) && (is.vector(value) || is.factor(value))
    if(!dfcol && !is.null(value))
      value <- as.list(value)
    y[[name]] <- value
  }
  z <- do.call(hyperframe, append(y, list(row.names=row.names(x),
                                            stringsAsFactors=FALSE)))
  return(z)
}

"[<-.hyperframe" <- 
function (x, i, j, value)
{
  sumry <- summary(x)
  colnam <- sumry$col.names
  dimx <- sumry$dim
  igiven <- !missing(i)
  jgiven <- !missing(j)
  if(igiven) {
    if(length(dim(i)) > 1)
      stop("Matrix index i is not supported in '[<-.hyperframe'", call.=FALSE)
    singlerow    <- ((is.integer(i) && length(i) == 1 && i > 0)
                    || (is.character(i) && length(i) == 1)
                    || (is.logical(i) && sum(i) == 1))
  } else {
    i <- seq_len(dimx[1L])
    singlerow <- FALSE
  }
  if(jgiven) {
    if(length(dim(j)) > 1)
      stop("Matrix index j is not supported in '[<-.hyperframe'", call.=FALSE)
    singlecolumn <- ((is.integer(j) && length(j) == 1 && j > 0)
                    || (is.character(j) && length(j) == 1)
                    || (is.logical(j) && sum(j) == 1))
  } else {
    j <- seq_len(dimx[2L])
    singlecolumn <- FALSE
  }
    
  if(!igiven && jgiven) {
    # x[, j] <- value
    if(singlecolumn) {
      # expecting single hypercolumn
      if(is.logical(j)) j <- names(x)[j]
      y <- get("$<-.hyperframe")(x, j, value)
    } else {
      # expecting hyperframe 
      xlist <- as.list(x)
      xlist[j] <- as.list(as.hyperframe(value))
      # the above construction accepts all indices including extra entries
      y <- do.call(hyperframe, append(xlist,
                                        list(row.names=row.names(x))))
    }
  } else {
    ## x[, ] <- value or x[i, ] <- value or x[i,j] <- value 
    ## convert indices to positive integers
    rowseq <- seq_len(dimx[1L])
    colseq <- seq_len(dimx[2L])
    names(rowseq) <- row.names(x)
    names(colseq) <- colnam
    I <- rowseq[i]
    J <- colseq[j]
    ## convert to lists 
    xlist <- as.list(x)
    if(singlerow && singlecolumn) {
      vlist <- list(anylist(value))
      nrowV <- ncolV <- 1
    } else {
      hv <- if(is.hyperframe(value)) value else
            as.hyperframe(as.solist(value, demote=TRUE))
      vlist <- as.list(hv)
      nrowV <- dim(hv)[1L]
      ncolV <- dim(hv)[2L]
    }
    if(nrowV != length(I)) {
      if(nrowV == 1) {
        ## replicate
        vlist <- lapply(vlist, rep, times=nrowV)
      } else stop(paste("Replacement value has wrong number of rows:",
                        nrowV, "should be", length(I)),
                  call.=FALSE)
    }
    if(ncolV != length(J)) {
      if(ncolV == 1) {
        ## replicate
        vlist <- rep(vlist, times=ncolV)
      } else stop(paste("Replacement value has wrong number of columns:",
                        ncolV, "should be", length(J)),
                  call.=FALSE)
    }
    ## replace entries
    for(k in seq_along(J)) {
      jj <- J[k]
      xlist[[jj]][I] <- vlist[[k]]
    }
    ## put back together
    y <- do.call(hyperframe, append(xlist,
                                      list(row.names=row.names(x))))
  } 
  return(y)
}

"[[.hyperframe" <-
function(x, ...)
{
  rr <- as.data.frame(row(x))
  cc <- as.data.frame(col(x))
  dimnames(rr) <- dimnames(cc) <- dimnames(x)
  chosen.rows <- unique(as.integer(rr[[...]]))
  chosen.cols <- unique(as.integer(cc[[...]]))
  nr <- length(chosen.rows)
  nc <- length(chosen.cols)
  if(nc == 0 || nr == 0) {
    ## should never be reached
    stop("No data selected", call.=FALSE)
  } else if(nc > 1) {
    ## should never be reached
    stop("More than one item (or column) of data selected", call.=FALSE)
  }
  if(nr == 1) {
    ## single item
    result <- x[chosen.rows, chosen.cols, drop=TRUE, strip=TRUE]
  } else if(length(chosen.rows) == nrow(rr)) {
    ## column
    result <- x[,chosen.cols, drop=TRUE, strip=FALSE]
  } else {
    ## subset of a column
    stop("Cannot select part of a column in '[['", call.=FALSE)
  }
  return(result)
}
                            
"[[<-.hyperframe" <-
function(x, i, j, value)
{
  ## detect 'blank' arguments like second argument in x[i, ] 
  ngiven <- length(sys.call())
  nmatched <- length(match.call())
  nblank <- ngiven - nmatched
  itype <- if(missing(i)) "absent" else "given"
  jtype <- if(missing(j)) "absent" else "given"
  if(nblank == 1) {
    if(!missing(i)) jtype <- "blank"
    if(!missing(j)) itype <- "blank"
  } else if(nblank == 2) {
    itype <- jtype <- "blank"
  }
  ## detect idiom x[[ ]] or x[[ , ]]
  if(itype != "given" && jtype != "given" && prod(dim(x)) > 1)
    stop("More than one cell or column of cells selected", call.=FALSE)
  ## find selected rows and columns
  rr <- as.data.frame(row(x))
  cc <- as.data.frame(col(x))
  dimnames(rr) <- dimnames(cc) <- dimnames(x)
  switch(paste0(itype, jtype),
         givengiven = {
           chosen.rows <- rr[[i, j]]
           chosen.cols <- cc[[i, j]]
         },
         givenabsent = {
           chosen.rows <- rr[[i]]
           chosen.cols <- cc[[i]]
         },
         givenblank = {
           chosen.rows <- rr[[i, ]]
           chosen.cols <- cc[[i, ]]
         },
         absentgiven = {
           ## cannot occur
           chosen.rows <- rr[[, j]]
           chosen.cols <- cc[[, j]]
         },
         absentabsent = {
           chosen.rows <- rr[[ ]]
           chosen.cols <- cc[[ ]]
         },
         absentblank = {
           ## cannot occur
           chosen.rows <- rr[[ , ]]
           chosen.cols <- cc[[ , ]]
         },
         blankgiven = {
           chosen.rows <- rr[[, j]]
           chosen.cols <- cc[[, j]]
         },
         blankabsent = {
           ## cannot occur
           chosen.rows <- rr[[]]
           chosen.cols <- cc[[]]
         },
         blankblank = {
           chosen.rows <- rr[[ , ]]
           chosen.cols <- cc[[ , ]]
         })
  chosen.rows <- unique(as.integer(chosen.rows))
  chosen.cols <- unique(as.integer(chosen.cols))
  nr <- length(chosen.rows)
  nc <- length(chosen.cols)
  if(nc == 0 || nr == 0) {
    ## should never be reached
    stop("No cells selected", call.=FALSE)
  } else if(nc > 1) {
    ## should never be reached
    stop("More than one cell or column of cells selected", call.=FALSE)
  }
  if(nr == 1) {
    ## single item
    xj <- x[[chosen.cols]]
    if(!is.atomic(xj)) {
      ## check class of replacement value
      vcj <- unclass(x)$vclass[[chosen.cols]]
      if(!inherits(value, vcj))
        stop(paste("Replacement value does not have required class",
                   sQuote(vcj)),
             call.=FALSE)
    }
    xj[[chosen.rows]] <- value
    x[,chosen.cols] <- xj
  } else if(length(chosen.rows) == nrow(rr)) {
    ## column
    x[,chosen.cols] <- value
  } else {
    ## subset of a column
    stop("Cannot assign part of a column in '[[<-'", call.=FALSE)
  }
  return(x)
}

split.hyperframe <- local({

  split.hyperframe <- function(x, f, drop=FALSE, ...) {
    y <- data.frame(id=seq_len(nrow(x)))
    z <- split(y, f, drop=drop)
    z <- lapply(z, getElement, name="id")
    out <- lapply(z, indexi, x=x)
    return(out)
  }

  indexi <- function(i, x) x[i,]
  
  split.hyperframe
})


"split<-.hyperframe" <- function(x, f, drop=FALSE, ..., value) {
  ix <- split(seq_len(nrow(x)), f, drop = drop, ...)
  n <- length(value)
  j <- 0
  for (i in ix) {
    j <- j%%n + 1L
    x[i, ] <- value[[j]]
  }
  x
}