tests/testsEtoF.R

In spatstat.core: Core Functionality of the 'spatstat' Family

#'
#'   Header for all (concatenated) test files
#'
#'   Require spatstat.core
#'   Obtain environment variable controlling tests.
#'
#'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $

require(spatstat.core)
FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0)
ALWAYS   <- TRUE
cat(paste("--------- Executing",
          if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of",
          "test code -----------\n"))
#
#  tests/envelopes.R
#
#  Test validity of envelope data
#
#  $Revision: 1.25 $  $Date: 2022/04/22 01:57:57 $
#


local({
checktheo <- function(fit) {
  fitname <- deparse(substitute(fit))
  en <- envelope(fit, nsim=4, verbose=FALSE, nrep=1e3)
  nama <- names(en)
  expecttheo <- is.poisson(fit) && is.stationary(fit)
  context <- paste("Envelope of", fitname)
  if(expecttheo) {
    if(!("theo" %in% nama))
      stop(paste(context, "did not contain", sQuote("theo")))
    if("mmean" %in% nama)
      stop(paste(context, "unexpectedly contained", sQuote("mmean")))
  } else {
    if("theo" %in% nama)
      stop(paste(context, "unexpectedly contained", sQuote("theo")))
    if(!("mmean" %in% nama))
      stop(paste(context, "did not contain", sQuote("mmean")))
  }
  cat(paste(context, "has correct format\n"))
}

if(ALWAYS) {
  checktheo(ppm(cells ~x))
}
if(FULLTEST) {
  checktheo(ppm(cells))
  checktheo(ppm(cells ~1, Strauss(0.1)))
}

# check envelope calls from 'alltypes'
if(ALWAYS) a <- alltypes(demopat, Kcross, nsim=4, envelope=TRUE)
if(FULLTEST) b <- alltypes(demopat, Kcross, nsim=4, envelope=TRUE, global=TRUE)

# check 'transform' idioms
if(ALWAYS) A <- envelope(cells, Kest, nsim=4, transform=expression(. - .x))
if(FULLTEST) B <- envelope(cells, Kest, nsim=4, transform=expression(sqrt(./pi) - .x))

#' check savefuns/savepatterns with global 
fit <- ppm(cells~x)
if(ALWAYS) Ef <- envelope(fit, Kest, nsim=4, savefuns=TRUE, global=TRUE)
if(FULLTEST) Ep <- envelope(fit, Kest, nsim=4, savepatterns=TRUE, global=TRUE)

#' check handling of 'dangerous' cases
if(FULLTEST) {
  fut <- ppm(redwood ~ x)
  Ek <- envelope(fut, Kinhom, update=FALSE, nsim=4)
  kfut <- kppm(redwood3 ~ x)
  Ekk <- envelope(kfut, Kinhom, lambda=density(redwood3), nsim=7)
}

# check conditional simulation
if(FULLTEST) {
  e1 <- envelope(cells, Kest, nsim=4, fix.n=TRUE)
  e2 <- envelope(amacrine, Kest, nsim=4, fix.n=TRUE)
  e3 <- envelope(amacrine, Kcross, nsim=4, fix.marks=TRUE)
  e4 <- envelope(finpines, Kest, nsim=4, fix.n=TRUE) # multiple columns of marks
  e5 <- envelope(finpines, Kest, nsim=4, fix.marks=TRUE)
}
if(ALWAYS) { # invokes C code
  fit <- ppm(japanesepines ~ 1, Strauss(0.04))
  e6 <- envelope(fit, Kest, nsim=4, fix.n=TRUE)
  fit2 <- ppm(amacrine ~ 1, Strauss(0.03))
  e7 <- envelope(fit2, Gcross, nsim=4, fix.marks=TRUE)
}

# check pooling of envelopes in global case
E1 <- envelope(cells, Kest, nsim=5, savefuns=TRUE, global=TRUE)
E2 <- envelope(cells, Kest, nsim=12, savefuns=TRUE, global=TRUE)
p12 <- pool(E1, E2)
p12 <- pool(E1, E2, savefuns=TRUE)
if(FULLTEST) {
  F1 <- envelope(cells, Kest, nsim=5,
                 savefuns=TRUE, savepatterns=TRUE, global=TRUE)
  F2 <- envelope(cells, Kest, nsim=12,
                 savefuns=TRUE, savepatterns=TRUE, global=TRUE)
  p12 <- pool(F1, F2)
  p12 <- pool(F1, F2, savefuns=TRUE, savepatterns=TRUE)
  E1r <- envelope(cells, Kest, nsim=5, savefuns=TRUE, global=TRUE,
                  ginterval=c(0.05, 0.15))
  E2r <- envelope(cells, Kest, nsim=12, savefuns=TRUE, global=TRUE,
                  ginterval=c(0.05, 0.15))
  p12r <- pool(E1r, E2r)
}
})

if(FULLTEST) {
local({
  #' as.data.frame.envelope
  Nsim <- 5
  E <- envelope(cells, nsim=Nsim, savefuns=TRUE)
  A <- as.data.frame(E)
  B <- as.data.frame(E, simfuns=TRUE)
  stopifnot(ncol(B) - ncol(A) == Nsim)
})
}

if(FULLTEST) {
local({
  #' cases not covered elsewhere
  A <- envelope(cells, nsim=5, alternative="less",
                do.pwrong=TRUE, use.theory=FALSE,
                savepatterns=TRUE, savefuns=TRUE)
  print(A)
  B <- envelope(A, nsim=5, savefuns=TRUE)
  D <- envelope(cells, "Lest", nsim=5)
  
  UU <- envelope(cells, nsim=5, foreignclass="ppp", clipdata=TRUE)
  
  AA <- envelope(cells, nsim=5, jsim=5, alternative="greater", global=TRUE)
  AA <- envelope(cells, nsim=5, jsim=5, alternative="less", global=TRUE)
  AA <- envelope(cells, nsim=5, jsim=5, alternative="greater", VARIANCE=TRUE)
  AA <- envelope(cells, nsim=5, jsim=5, alternative="greater", VARIANCE=TRUE)

  fit <- ppm(cells ~ 1, Strauss(0.07))
  U <- envelope(fit, nsim=3, simulate=expression(runifpoint(20)))
  kfit <- kppm(redwood3 ~ x)
  UU <- envelope(kfit, nsim=7, simulate=expression(simulate(kfit, drop=TRUE)))
  VV <- envelope(kfit, nsim=7, weights=1:7)
  MM <- envelope(kfit, nsim=7, Kinhom, lambda=density(redwood3))

  #' spotted by Art Stock - bugs in ratfv class support
  BB <- envelope(redwood, Kinhom, nsim=5, sigma=bw.scott,              ratio=TRUE, correction="border")
  CC <- envelope(redwood, Kinhom, nsim=5, sigma=bw.scott, global=TRUE, ratio=TRUE, correction="border")
  DD <- envelope(redwood, Finhom, nsim=5, sigma=bw.scott,              ratio=TRUE, correction="trans")
  EE <- envelope(redwood, Finhom, nsim=5, sigma=bw.scott, global=TRUE, ratio=TRUE, correction="trans")
  
  #'  envelopes based on sample variance
  E <- envelope(cells, nsim=8, VARIANCE=TRUE)
  G <- envelope(cells, nsim=8, VARIANCE=TRUE,
                use.theory=FALSE, do.pwrong=TRUE)
  print(G)
  #' summary method
  summary(E)
  summary(envelope(cells, nsim=5, simulate=expression(runifpoint(42))))
  #' weights argument
  H1 <- envelope(cells, nsim=4, weights=npoints, savefuns=TRUE)
  H2 <- envelope(cells, nsim=4, weights=npoints, savefuns=TRUE)
  J1 <- envelope(cells, nsim=4, weights=npoints, VARIANCE=TRUE)
  J2 <- envelope(cells, nsim=4, weights=npoints, VARIANCE=TRUE)
  #' pooling with weights
  H <- pool(H1, H2)
  J <- pool(J1, J2)
  #' pooling envelopes with non-identical attributes
  H0 <- envelope(cells, nsim=4, savefuns=TRUE)
  HH <- pool(H0, H1)
  #' undocumented/secret
  K <- envelope(cells, nsim=4, saveresultof=npoints, collectrubbish=TRUE)
  #' so secret I've even forgotten how to do it
  M <- envelope(cells, nsim=4, internal=list(eject="patterns"))
})
}

if(FULLTEST) {
local({
  #' envelope computations in other functions
  P <- lurking(cells, expression(x), envelope=TRUE, nsim=9)
  print(P)
  #' re-using envelope objects in other functions
  A <- envelope(cells, nsim=9, savepatterns=TRUE, savefuns=TRUE)
  S <- lurking(cells, expression(x), envelope=A, nsim=9)
  #' envelope.envelope
  B <- envelope(cells, nsim=5, savepatterns=TRUE, savefuns=FALSE)
  envelope(B)
})
}

if(ALWAYS) {
local({
  #' Test robustness of envelope() sorting procedure when NA's are present
  #' Fails with spatstat.utils 1.12-0
  set.seed(42)
  EP <- envelope(longleaf, pcf, nsim=10, nrank=2)

  #' Test case when the maximum permitted number of failures is exceeded
  X <- amacrine[1:153] # contains exactly one point with mark='off'
  #' High probability of generating a pattern with no marks = 'off'
  E <- envelope(X, Kcross, nsim=39, maxnerr=2, maxerr.action="warn")
  A <- alltypes(X, Kcross, envelope=TRUE, nsim=39, maxnerr=2)
})
}

if(ALWAYS) {
local({
  #' Internals: envelope.matrix
  Y <- matrix(rnorm(200), 10, 20)
  rr <- 1:10
  oo <- rnorm(10)
  zz <- numeric(10)
  E <- envelope(Y, rvals=rr, observed=oo, nsim=10)
  E <- envelope(Y, rvals=rr, observed=oo, jsim=1:10)
  E <- envelope(Y, rvals=rr, observed=oo, theory=zz,
                type="global", use.theory=TRUE)
  E <- envelope(Y, rvals=rr, observed=oo, theory=zz,
                type="global", use.theory=TRUE, nsim=10)
  E <- envelope(Y, rvals=rr, observed=oo, theory=zz,
                type="global", use.theory=FALSE, nsim=10)
  E <- envelope(Y, rvals=rr, observed=oo, type="global",
                nsim=10, nsim2=10)
  E <- envelope(Y, rvals=rr, observed=oo, type="global",
                jsim=1:10, jsim.mean=11:20)
  if(FULLTEST) print(E)
  E <- envelope(Y, rvals=rr, observed=oo, type="global",
                nsim=10, jsim.mean=11:20)
  E <- envelope(Y, rvals=rr, observed=oo, type="global",
                jsim=1:10, nsim2=10)
})
}

if(ALWAYS) {
local({
  #' quirk with handmade summary functions ('conserve' attribute)
  Kdif <- function(X, r=NULL) { # note no ellipsis
    Y <- split(X)
    K1 <- Kest(Y[[1]], r=r)
    K2 <- Kest(Y[[2]], r=r)
    D <- eval.fv(K1-K2)
    return(D)
  }
  envelope(amacrine, Kdif, nsim=3)
})
}



#'  tests/enveltest.R
#'     Envelope tests (dclf.test, mad.test)
#'     and two-stage tests (bits.test, dg.test, bits.envelope, dg.envelope)
#' 
#'     $Revision: 1.3 $  $Date: 2020/04/28 12:58:26 $ 
#'
if(FULLTEST) {
local({
  #' handling of NA function values (due to empty point patterns)
  set.seed(1234)
  X <- rThomas(5, 0.05, 10) 
  fit <- kppm(X ~ 1, "Thomas")
  set.seed(100000)
  dclf.test(fit)
  set.seed(909)
  dg.test(fit, nsim=9)
  #' other code blocks
  dclf.test(fit, rinterval=c(0, 3), nsim=9)
  envelopeTest(X, exponent=3, clamp=TRUE, nsim=9)
})
}
#
#    tests/fastgeyer.R
#
# checks validity of fast C implementation of Geyer interaction
#
#    $Revision: 1.4 $  $Date: 2020/04/28 12:58:26 $
#
if(FULLTEST) {  # depends on hardware
local({
  X <- redwood
  Q <- quadscheme(X)
  U <- union.quad(Q)
  EP <- equalpairs.quad(Q)
  G <- Geyer(0.11, 2)
# The value r=0.11 is chosen to avoid hardware numerical effects (gcc bug 323).
# It avoids being close any value of pairdist(redwood).
# The nearest such values are 0.1077.. and 0.1131..
# By contrast if r = 0.1 there are values differing from 0.1 by 3e-17
  a <- pairsat.family$eval(X,U,EP,G$pot,G$par,"border")
  b <-          G$fasteval(X,U,EP,G$pot,G$par,"border")
  if(!all(a==b))
    stop("Results of Geyer()$fasteval and pairsat.family$eval do not match")
# ...
# and again for a non-integer value of 'sat'
# (spotted by Thordis Linda Thorarinsdottir)  
  G <- Geyer(0.11, 2.5)
  a <- pairsat.family$eval(X,U,EP,G$pot,G$par,"border")
  b <-          G$fasteval(X,U,EP,G$pot,G$par,"border")
  if(!all(a==b))
    stop("Results of Geyer()$fasteval and pairsat.family$eval do not match when sat is not an integer")
# and again for sat < 1
# (spotted by Rolf)  
  G <- Geyer(0.11, 0.5)
  a <- pairsat.family$eval(X,U,EP,G$pot,G$par,"border")
  b <-          G$fasteval(X,U,EP,G$pot,G$par,"border")
  if(!all(a==b))
    stop("Results of Geyer()$fasteval and pairsat.family$eval do not match when sat < 1")
})
}

#
#  tests/fastK.R
#
# check fast and slow code for Kest
#       and options not tested elsewhere
#
#   $Revision: 1.5 $   $Date: 2020/04/28 12:58:26 $
#
if(ALWAYS) {
local({
  ## fast code
  Kb <- Kest(cells, nlarge=0)
  Ku <- Kest(cells, correction="none")
  Kbu <- Kest(cells, correction=c("none", "border"))
  ## slow code, full set of corrections, sqrt transformation, ratios
  Ldd <- Lest(unmark(demopat), correction="all", var.approx=TRUE, ratio=TRUE)
  ## Lotwick-Silverman var approx (rectangular window)
  Loo <- Lest(cells, correction="all", var.approx=TRUE, ratio=TRUE)
  ## Code for large dataset
  nbig <- .Machine$integer.max
  if(!is.null(nbig)) {
    nn <- ceiling(sqrt(nbig))
    if(nn < 1e6) Kbig <- Kest(runifpoint(nn),
                              correction=c("border", "bord.modif", "none"),
                              ratio=TRUE)
  }
  
  ## Kinhom
  lam <- density(cells, at="points", leaveoneout=TRUE)
  ## fast code
  Kib <- Kinhom(cells, lam, nlarge=0)
  Kiu <- Kest(cells, lam, correction="none")
  Kibu <- Kest(cells, lam, correction=c("none", "border"))
  ## slow code
  Lidd <- Linhom(unmark(demopat), sigma=bw.scott)
})

}
#' tests/formuli.R
#'
#'  Test machinery for manipulating formulae
#' 
#' $Revision: 1.7 $  $Date: 2020/04/28 12:58:26 $

local({

  ff <- function(A, deletevar, B) {
    D <- reduceformula(A, deletevar)
    if(!spatstat.utils::identical.formulae(D, B)) {
      AD <- as.expression(substitute(reduceformula(A,d),
                                     list(A=A, d=deletevar)))
      stop(paste(AD, "\n\tyields ", spatstat.utils::pasteFormula(D),
                 " instead of ", spatstat.utils::pasteFormula(B)),
           call.=FALSE)
    }
    invisible(NULL)
  }

  ff(~ x + z, "x", ~z)

  ff(y ~ x + z, "x", y~z)

  ff(~ I(x^2) + z, "x",  ~z)

  ff(y ~ poly(x,2) + poly(z,3), "x", y ~poly(z,3))

  ff(y ~ x + z, "g", y ~ x + z)

  reduceformula(y ~ x+z, "g", verbose=TRUE)
  reduceformula(y ~ sin(x-z), "z", verbose=TRUE)
  
  illegal.iformula(~str*g, itags="str", dfvarnames=c("marks", "g", "x", "y"))
})



##  
##     tests/funnymarks.R
##
## tests involving strange mark values
## $Revision: 1.7 $ $Date: 2020/04/28 12:58:26 $

if(ALWAYS) { # depends on locale
local({
  ## ppm() where mark levels contain illegal characters
  hyphenated <- c("a", "not-a")
  spaced <- c("U", "non U")
  suffixed <- c("a+", "a*")
  charred <- c("+", "*")

  irad <- matrix(0.1, 2,2)
  hrad <- matrix(0.005, 2, 2)

  tryit <- function(types, X, irad, hrad) { 
    levels(marks(X)) <- types
    fit <- ppm(X ~marks + polynom(x,y,2),
               MultiStraussHard(types=types,iradii=irad,hradii=hrad))
    print(fit)
    print(coef(fit))
    val <- fitted(fit)
    pred <- predict(fit)
    return(invisible(NULL))
  }

  tryit(hyphenated, amacrine, irad, hrad)
  tryit(spaced, amacrine, irad, hrad)
  tryit(suffixed, amacrine, irad, hrad)
  tryit(charred, amacrine, irad, hrad)

  ## marks which are dates
  X <- cells
  n <- npoints(X)
  endoftime <- rep(ISOdate(2001,1,1), n)
  eotDate   <- rep(as.Date("2001-01-01"), n)
  markformat(endoftime)
  markformat(eotDate)
  marks(X) <- endoftime
  print(X)
  Y <- X %mark% data.frame(id=1:42, date=endoftime, dd=eotDate)
  print(Y)
  md <- markformat(endoftime)
  
  ## mark formats
  Z <- Y
  marks(Z) <- marks(Z)[1,,drop=FALSE]
  ms <- markformat(solist(cells, redwood))
  marks(Z) <- factor(1:npoints(Z))
  marks(Z)[12] <- NA
  mz <- is.multitype(Z)
  cZ <- coerce.marks.numeric(Z)
  marks(Z) <- data.frame(n=1:npoints(Z),
                         a=factor(sample(letters, npoints(Z), replace=TRUE)))
  cZ <- coerce.marks.numeric(Z)
  stopifnot(is.multitype(cells %mark% data.frame(a=factor(1:npoints(cells)))))

  a <- numeric.columns(finpines)
  b1 <- numeric.columns(amacrine)
  b2 <- coerce.marks.numeric(amacrine)
  d <- numeric.columns(cells)
  f <- numeric.columns(longleaf)
  ff <- data.frame(a=factor(letters[1:10]), y=factor(sample(letters, 10)))
  numeric.columns(ff)

  ## mark operations
  df <- data.frame(x=1:2, y=sample(letters, 2))
  h <- hyperframe(z=1:2, p=solist(cells, cells))
  a <- NULL %mrep% 3
  a <- 1:4 %mrep% 3
  a <- df %mrep% 3
  a <- h %mrep% 3
  b <- markcbind(df, h)
  b <- markcbind(h, df)
})
}
## 
##    tests/fvproblems.R
##
##    problems with fv, ratfv and fasp code
##
##    $Revision: 1.15 $  $Date: 2020/04/28 12:58:26 $

#' This appears in the workshop notes
#' Problem detected by Martin Bratschi

if(FULLTEST) {
local({
  Jdif <- function(X, ..., i) {
    Jidot <- Jdot(X, ..., i=i)
    J <- Jest(X, ...)
    dif <- eval.fv(Jidot - J)
    return(dif)
  }
  Z <- Jdif(amacrine, i="on")
})
}
#'
#'  Test mathlegend code
#'
local({
  K <- Kest(cells)
  if(FULLTEST) {
    plot(K)
    plot(K, . ~ r)
    plot(K, . - theo ~ r)
  }
  if(ALWAYS) {
    plot(K, sqrt(./pi)  ~ r)
  }
  if(FULLTEST) {
    plot(K, cbind(iso, theo) ~ r)
    plot(K, cbind(iso, theo) - theo ~ r)
    plot(K, sqrt(cbind(iso, theo)/pi)  ~ r)
    plot(K, cbind(iso/2, -theo) ~ r)
    plot(K, cbind(iso/2, trans/2) - theo ~ r)
  }
  if(FULLTEST) {
    ## test expansion of .x and .y
    plot(K, . ~ .x)
    plot(K, . - theo ~ .x)
    plot(K, .y - theo ~ .x)
  }
  if(ALWAYS) {
    plot(K, sqrt(.y) - sqrt(theo) ~ .x)
  }

  # problems with parsing weird strings in levels(marks(X))
  # noted by Ulf Mehlig
  if(ALWAYS) {
    levels(marks(amacrine)) <- c("Nasticreechia krorluppia", "Homo habilis")
    plot(Kcross(amacrine))
    plot(alltypes(amacrine, "K"))
  }
  if(FULLTEST) {
    plot(alltypes(amacrine, "J"))
    plot(alltypes(amacrine, pcfcross))
  }
})

#'
#'  Test quirks related to 'alim' attribute

if(FULLTEST) {
local({
  K <- Kest(cells)
  attr(K, "alim") <- NULL
  plot(K)
  attr(K, "alim") <- c(0, 0.1)
  plot(tail(K))
})
}

#'
#' Check that default 'r' vector passes the test for fine spacing

if(ALWAYS) {
local({
  a <- Fest(cells)
  A <- Fest(cells, r=a$r)
  b <- Hest(heather$coarse)
  B <- Hest(heather$coarse, r=b$r)
  # from Cenk Icos
  X <- runifpoint(100, owin(c(0,3), c(0,10)))
  FX <- Fest(X)
  FXr <- Fest(X, r=FX$r)
  JX <- Jest(X)
})
}

##' various functionality in fv.R

if(ALWAYS) {
local({
  M <- cbind(1:20, matrix(runif(100), 20, 5))
  A <- as.fv(M)
  fvlabels(A) <- c("r","%s(r)", "%s[A](r)", "%s[B](r)", "%s[C](r)", "%s[D](r)")
  A <- rename.fv(A, "M", quote(M(r)))
  A <- tweak.fv.entry(A, "V1", new.tag="r")
  A[,3] <- NULL
  A$hogwash <- runif(nrow(A))
  fvnames(A, ".") <- NULL
  #' bind.fv with qualitatively different functions
  GK <- harmonise(G=Gest(cells), K=Kest(cells))
  G <- GK$G
  K <- GK$K
  ss <- c(rep(TRUE, nrow(K)-10), rep(FALSE, 10))
  U <- bind.fv(G, K[ss, ], clip=TRUE)
  #'
  H <- rebadge.as.crossfun(K, "H", "inhom", 1, 2)
  H <- rebadge.as.dotfun(K, "H", "inhom", 3)
  #' text layout
  op <- options(width=27)
  print(K)
  options(width=18)
  print(K)
  options(op)
  #' collapse.fv
  Kb <- Kest(cells, correction="border")
  Ki <- Kest(cells, correction="isotropic")
  collapse.fv(Kb, Ki, same="theo")
  collapse.fv(anylist(B=Kb, I=Ki), same="theo")
  collapse.fv(anylist(B=Kb), I=Ki, same="theo")
  Xlist <- replicate(3, runifpoint(30), simplify=FALSE)
  Klist <- anylapply(Xlist, Kest) 
  collapse.fv(Klist, same="theo", different=c("iso", "border"))
  names(Klist) <- LETTERS[24:26]
  collapse.fv(Klist, same="theo", different=c("iso", "border"))
})
}

if(FULLTEST) {
local({
  ## rat
  K <- Kest(cells, ratio=TRUE)
  G <- Gest(cells, ratio=TRUE)
  print(K)
  compatible(K, K)
  compatible(K, G)
  H <- rat(K, attr(K, "numerator"), attr(K, "denominator"), check=TRUE)
})
}

if(FULLTEST) {
local({
  ## bug in Jmulti.R colliding with breakpts.R
  B <- owin(c(0,3), c(0,10))
  Y <- superimpose(A=runifpoint(1212, B), B=runifpoint(496, B))
  JDX <- Jdot(Y)
  JCX <- Jcross(Y)
  Jdif <- function(X, ..., i) {
    Jidot <- Jdot(X, ..., i=i)
    J <- Jest(X, ...)
    dif <- eval.fv(Jidot - J)
    return(dif)
  }
  E <- envelope(Y, Jdif, nsim=19, i="A", simulate=expression(rlabel(Y)))
})
}

if(FULLTEST) {
local({
  #' fasp axes, title, dimnames
  a <- alltypes(amacrine)
  a$title <- NULL
  plot(a, samex=TRUE, samey=TRUE)
  dimnames(a) <- lapply(dimnames(a), toupper)

  b <- as.fv(a)
})
}

if(FULLTEST) {
local({
  ## plot.anylist (fv)
  b <- anylist(A=Kcross(amacrine), B=Kest(amacrine))
  plot(b, equal.scales=TRUE, main=expression(sqrt(pi)))
  plot(b, arrange=FALSE)
})
}