
cols <- t(col2rgb(palette()))

## One full space1-XYZ-space2 conversion

convertColor(cols, 'sRGB', 'Lab', scale.in=255)

## to XYZ, then to every defined space

XYZ <- convertColor(cols, 'sRGB', 'XYZ', scale.in=255)
fromXYZ <- vapply(
  names(colorspaces), convertColor, FUN.VALUE=XYZ,
  from='XYZ', color=XYZ, clip=NA
)
round(fromXYZ, 4)

## Back to XYZ, delta to original XYZ should be close to zero

tol <- 1e-5
toXYZ <- vapply(
  dimnames(fromXYZ)[[3]],
  function(x) all(abs(convertColor(fromXYZ[,,x], from=x, to='XYZ') - XYZ)<tol),
  logical(1)
)
toXYZ
stopifnot(all(toXYZ | is.na(toXYZ)))

## Test Apple and CIE RGB on smaller gamuts since they clip

XYZ2 <- XYZ * .7 + .15
fromXYZ2 <- vapply(
  c('Apple RGB', 'CIE RGB'), convertColor, FUN.VALUE=XYZ2,
  from='XYZ', color=XYZ2, clip=NA
)
round(fromXYZ2, 4)
toXYZ2 <- vapply(
  dimnames(fromXYZ2)[[3]],
  function(x)
    all(abs(convertColor(fromXYZ2[,,x], from=x, to='XYZ') - XYZ2)<tol),
  logical(1)
)
stopifnot(all(toXYZ2))

# Seg.fault in R 3.5.3 -- 4.1.1 (but not 3.4.4) -- PR#18183
stopifnot(identical(character(0),
                    gray(numeric(), alpha=1/2)))

## xy.coords() and xyz.coords() -- gets *classed* warning
tools::assertWarning(xy.coords(-2:10, log = "y"), verbose=TRUE)
op <- options(warn = 2)# ==> warnings are errors
suppressWarnings(xy.coords(-2:10, log = "y"), classes="log_le_0") -> xy
stopifnot(identical(xy$y, c(rep(NA_real_,3), 1:10)))
options(op) # (reverting)
tools::assertWarning(xy.coords(-2:10, log = "y"), verbose=TRUE)
## [Bug 18476] alpha handling in palette functions  (23 Feb 2023)
##             https://bugs.r-project.org/show_bug.cgi?id=18476
## Attachment 3131 https://bugs.r-project.org/attachment.cgi?id=3131
## and comment #3  by Achim Zeileis


## from attachment #3131 :
check_alpha <- function(colors = "topo.colors", ncolor = 3, nalpha = 3, ...) {
  ## alpha sequence of length nalpha
  alpha <- seq(0, 1, length.out = nalpha)

  ## generate colors with alpha=...
  col1 <- tryCatch(do.call(colors, c(list(n = ncolor, alpha = alpha), list(...))),
                   error = identity)
  if(inherits(col1, "error")) return(FALSE)

  ## generate colors without alpha= and add manually afterwards
  alpha <- format(as.hexmode(round(alpha * 255 + 0.0001)), width = 2L, upper.case = TRUE)
  col2 <- paste0(do.call(colors, c(list(n = ncolor), list(...))),
                 rep_len(alpha, ncolor))

  ## check whether both strategies yield identical output
  identical(col1, col2)
}

expndGrid <- function(...)
          expand.grid(..., KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)

iSamp <- function(n, f=1/4, nS = max(min(n, 24L), f*n), full = interactive())
    if(full) seq_len(n) else sample.int(n, nS)

chkALLalpha <- function(d)
    vapply(iSamp(nrow(d)), function(i) do.call(check_alpha, d[i,]), NA)

## Check old palettes ------------------
d1 <- expndGrid(colors = c("rainbow", "topo.colors", "terrain.colors",
                           "heat.colors", "cm.colors", "gray.colors"),
  ncolor = c(1, 3, 9, 100),
  nalpha = c(2, 3, 9, 100))
table(L <- chkALLalpha(d1)) ## R-4.2.x: 71 FALSE, 25 TRUE -- now 96 TRUE
if(!all(L)) stop("---> not all ok")


## Check the new palettes -----------------

d2 <- expndGrid(colors = "palette.colors",
  ncolor = c(1, 3, 7),
  nalpha = c(2, 3, 7),
  palette = print(palette.pals()))
table(L <- chkALLalpha(d2)) ## R-4.2.x: 64 FALSE, 80 TRUE -- now 144 TRUE
if(!all(L)) stop("---> not all ok")

d3 <- expndGrid(colors = "hcl.colors",
  ncolor = c(1, 3, 9, 100),
  nalpha = c(2, 3, 9, 100),
  palette = print(hcl.pals()))
table(L <- chkALLalpha(d3)) ## R-4.2.x: 1057 FALSE, 783 TRUE -- now 1840 TRUE
if(!all(L)) stop("---> not all ok")
## tests of the fonts in the postscript() device.

testit <- function(family, encoding="default")
{ 
    postscript("ps-tests.ps", height=7, width=7, family=family,
               encoding=encoding)
    plot(1:10, type="n")
    text(5, 9, "Some text")
    text(5, 8 , expression(italic("italic")))
    text(5, 7 , expression(bold("bold")))
    text(5, 6 , expression(bolditalic("bold & italic")))
    text(8, 3, expression(paste(frac(1, sigma*sqrt(2*pi)), " ",
        plain(e)^{frac(-(x-mu)^2, 2*sigma^2)})))
    dev.off()
}

testit("Helvetica")
testit("AvantGarde")
testit("Bookman")
testit("Courier")
testit("Helvetica-Narrow")
testit("NewCenturySchoolbook")
testit("Palatino")
testit("Times")

testit("URWGothic")
testit("URWBookman")
testit("NimbusMon")
testit("NimbusSan")
testit("NimbusSanCond")
testit("CenturySch")
testit("URWPalladio")
testit("NimbusRom")
testit("URWHelvetica")
testit("URWTimes")

testit("ComputerModern", "TeXtext.enc")

unlink("ps-tests.ps")

R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> ## tests of the fonts in the postscript() device.
> 
> testit <- function(family, encoding="default")
+ { 
+     postscript("ps-tests.ps", height=7, width=7, family=family,
+                encoding=encoding)
+     plot(1:10, type="n")
+     text(5, 9, "Some text")
+     text(5, 8 , expression(italic("italic")))
+     text(5, 7 , expression(bold("bold")))
+     text(5, 6 , expression(bolditalic("bold & italic")))
+     text(8, 3, expression(paste(frac(1, sigma*sqrt(2*pi)), " ",
+         plain(e)^{frac(-(x-mu)^2, 2*sigma^2)})))
+     dev.off()
+ }
> 
> testit("Helvetica")
null device 
          1 
> testit("AvantGarde")
null device 
          1 
> testit("Bookman")
null device 
          1 
> testit("Courier")
null device 
          1 
> testit("Helvetica-Narrow")
null device 
          1 
> testit("NewCenturySchoolbook")
null device 
          1 
> testit("Palatino")
null device 
          1 
> testit("Times")
null device 
          1 
> 
> testit("URWGothic")
null device 
          1 
> testit("URWBookman")
null device 
          1 
> testit("NimbusMon")
null device 
          1 
> testit("NimbusSan")
null device 
          1 
> testit("NimbusSanCond")
null device 
          1 
> testit("CenturySch")
null device 
          1 
> testit("URWPalladio")
null device 
          1 
> testit("NimbusRom")
null device 
          1 
> testit("URWHelvetica")
null device 
          1 
> testit("URWTimes")
null device 
          1 
> 
> testit("ComputerModern", "TeXtext.enc")
null device 
          1 
> 
> unlink("ps-tests.ps")
> 
> proc.time()
   user  system elapsed 
  0.995   0.084   1.062 
## From: Winston Chang
## To: R Devel List ...@r-project.org
## Subject: [Rd] recordPlot/replayPlot not working with saveRDS/readRDS
## Date: Mon, 2 Apr 2018 12:23:06 -0500

if (FALSE) { # bitmap png() device is optional for webR
# Save displaylist for a simple plot
png('test.png')
dev.control(displaylist ="enable")
plot(1:5, 1:5)
r <- recordPlot()
dev.off()

# Replay plot. This works.
png('test1.png')
replayPlot(r)
dev.off()

## Save the plot and load it, then replay it (in *same* R session):
## Now works, too
saveRDS(r, 'recordedplot.rds')
r2 <- readRDS('recordedplot.rds')
png('test2.png')
replayPlot(r2)
## Gave  Error: NULL value passed as symbol address
dev.off()

## Now check the three PNG graphics files do not differ:
(files <- dir(pattern = "test.*[.]png"))
tt <- lapply(files, readBin, what = "raw", n = 2^12)
lengths(tt)
sapply(tt, head)
stopifnot(
    identical(tt[[1]], tt[[2]]),
    identical(tt[[3]], tt[[2]]))
}
## tests for the xfig device



xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)

unlink("xfig-tests.fig")

## tests for the xfig device



xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)

unlink("xfig-tests.fig")

## tests for the xfig device



xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)

unlink("xfig-tests.fig")

## tests for the xfig device



xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)

unlink("xfig-tests.fig")

## tests for the xfig device



xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)

unlink("xfig-tests.fig")

## tests for the xfig device



xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)

xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)

unlink("xfig-tests.fig")


R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> ## tests for the xfig device
> 
> 
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)
> 
> unlink("xfig-tests.fig")
> 
> ## tests for the xfig device
> 
> 
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)
> 
> unlink("xfig-tests.fig")
> 
> ## tests for the xfig device
> 
> 
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)
> 
> unlink("xfig-tests.fig")
> 
> ## tests for the xfig device
> 
> 
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)
> 
> unlink("xfig-tests.fig")
> 
> ## tests for the xfig device
> 
> 
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)
> 
> unlink("xfig-tests.fig")
> 
> ## tests for the xfig device
> 
> 
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=TRUE,textspecial=FALSE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=TRUE)
> 
> xfig("xfig-tests.fig",onefile=TRUE,defaultfont=FALSE,textspecial=FALSE)
> 
> unlink("xfig-tests.fig")
> 
> 
> proc.time()
   user  system elapsed 
  0.392   0.073   0.446 
