| # File src/library/grDevices/R/postscript.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2016 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| ## An environment not exported from namespace:graphics used to pass |
| ## .PostScript.Options and .PDF.options to the windows() device for |
| ## use in its menus, and also to hide the variables. |
| .PSenv <- new.env() |
| |
| check.options <- |
| function(new, name.opt, reset = FALSE, assign.opt = FALSE, |
| envir = .GlobalEnv, check.attributes = c("mode", "length"), |
| override.check = FALSE) |
| { |
| lnew <- length(new) |
| if(lnew != length(newnames <- names(new))) |
| stop(gettextf("invalid arguments in '%s' (need named args)", |
| deparse(sys.call(sys.parent()))), domain = NA) |
| if(!is.character(name.opt)) |
| stop("'name.opt' must be character, name of an existing list") |
| if(reset) { |
| if(exists(name.opt, envir=envir, inherits=FALSE)) { |
| if(length(utils::find(name.opt)) > 1) |
| rm(list=name.opt, envir=envir) |
| |
| } else stop(gettextf("cannot reset non-existent '%s'", name.opt), |
| domain = NA) |
| } |
| old <- get(name.opt, envir=envir, inherits=FALSE) |
| if(!is.list(old)) |
| stop(gettextf("invalid options in '%s'", name.opt), domain = NA) |
| oldnames <- names(old) |
| if(lnew > 0) { |
| matches <- pmatch(newnames, oldnames) |
| if(any(is.na(matches))) |
| stop(sprintf(ngettext(as.integer(sum(is.na(matches))), |
| "invalid argument name %s in '%s'", |
| "invalid argument names %s in '%s'"), |
| paste(sQuote(newnames[is.na(matches)]), |
| collapse=", "), |
| deparse(sys.call(sys.parent()))), |
| domain = NA) |
| else { #- match(es) found: substitute if appropriate |
| i.match <- oldnames[matches] |
| prev <- old[i.match] |
| doubt <- rep.int(FALSE, length(prev)) |
| for(fn in check.attributes) |
| if(any(ii <- sapply(prev, fn) != sapply(new, fn))) { |
| ## skip 'fonts'; |
| ii <- ii & (names(prev) != "fonts") |
| if(!any(ii)) next |
| doubt <- doubt | ii |
| do.keep <- ii & !override.check |
| warning(paste(sQuote(paste0(fn, "(", names(prev[ii]), ")" )), |
| collapse = " and "), " ", |
| ngettext(as.integer(sum(ii)), |
| "differs between new and previous", |
| "differ between new and previous"), |
| if(any(do.keep)) { |
| paste0("\n\t ==> ", |
| gettextf("NOT changing %s", |
| paste(sQuote(names(prev[do.keep])), |
| collapse=" & "))) |
| } else "", |
| domain = NA, call. = FALSE) |
| } |
| names(new) <- NULL |
| if(any(doubt)) { |
| ii <- !doubt | override.check |
| old[i.match[ii]] <- new[ii] |
| } else old[i.match] <- new |
| |
| } |
| if(assign.opt) assign(name.opt, old, envir=envir) |
| } |
| old |
| } |
| |
| ps.options <- function(..., reset = FALSE, override.check = FALSE) |
| { |
| ## do initialization if needed |
| initPSandPDFfonts() |
| old <- get(".PostScript.Options", envir = .PSenv) |
| if(reset) { |
| assign(".PostScript.Options", |
| get(".PostScript.Options.default", envir = .PSenv), |
| envir = .PSenv) |
| } |
| l... <- length(new <- list(...)) |
| if(m <- match("append", names(new), 0L)) { |
| warning("argument 'append' is for back-compatibility and will be ignored", |
| immediate. = TRUE) |
| new <- new[-m] |
| } |
| check.options(new, name.opt = ".PostScript.Options", envir = .PSenv, |
| assign.opt = l... > 0, override.check = override.check) |
| if(reset || l... > 0) invisible(old) else old |
| } |
| |
| setEPS <- function(...) |
| { |
| dots <- list(...) |
| args <- list(width = 7, height = 7) |
| args[names(dots)] <- dots |
| force <- list(onefile = FALSE, horizontal = FALSE, paper = "special") |
| args[names(force)] <- force |
| do.call("ps.options", args) |
| } |
| |
| setPS <- function(...) |
| { |
| dots <- list(...) |
| args <- list(width = 0, height = 0) |
| args[names(dots)] <- dots |
| force <- list(onefile = TRUE, horizontal = TRUE, paper = "default") |
| args[names(force)] <- force |
| do.call("ps.options", args) |
| } |
| |
| pdf.options <- function(..., reset=FALSE) |
| { |
| ## do initialization if needed |
| initPSandPDFfonts() |
| old <- get(".PDF.Options", envir = .PSenv) |
| if(reset) { |
| assign(".PDF.Options", |
| get(".PDF.Options.default", envir = .PSenv), |
| envir = .PSenv) |
| } |
| l... <- length(new <- list(...)) |
| check.options(new, name.opt = ".PDF.Options", envir = .PSenv, |
| assign.opt = l... > 0) |
| if(reset || l... > 0) invisible(old) else old |
| } |
| |
| guessEncoding <- function(family) |
| { |
| # Three special families have special encodings, regardless of locale |
| if (!missing(family) && |
| family %in% c("ComputerModern", "ComputerModernItalic")) { |
| switch(family, |
| "ComputerModern" = "TeXtext.enc", |
| "ComputerModernItalic" = "TeXtext.enc") |
| } else { |
| switch(.Platform$OS.type, |
| "windows" = { |
| switch(utils::localeToCharset()[1L], |
| "ISO8859-2" = "CP1250.enc", |
| "ISO8859-7" = "CP1253.enc", # Greek |
| "ISO8859-13" = "CP1257.enc", |
| "CP1251" = "CP1251.enc", # Cyrillic |
| "WinAnsi.enc") |
| }, |
| { lc <- utils::localeToCharset() |
| if(length(lc) == 1L) |
| switch(lc, |
| "ISO8859-1" = "ISOLatin1.enc", |
| "ISO8859-2" = "ISOLatin2.enc", |
| "ISO8859-5" = "Cyrillic.enc", |
| "ISO8859-7" = "Greek.enc", |
| "ISO8859-13" = "ISOLatin7.enc", |
| "ISO8859-15" = "ISOLatin9.enc", |
| "KOI8-R" = "KOI8-R.enc", |
| "KOI8-U" = "KOI8-U.enc", |
| "ISOLatin1.enc") |
| else if(lc[1L] == "UTF-8") |
| switch(lc[2L], |
| "ISO8859-1" = "ISOLatin1.enc", # what about Euro? |
| "ISO8859-2" = "ISOLatin2.enc", |
| "ISO8859-5" = "Cyrillic.enc", |
| "ISO8859-7" = "Greek.enc", |
| "ISO8859-13" = "ISOLatin7.enc", |
| "ISOLatin1.enc") |
| else "ISOLatin1.enc"}) |
| } |
| } |
| |
| ##--> source in devPS.c : |
| |
| postscript <- function(file = if(onefile) "Rplots.ps" else "Rplot%03d.ps", |
| onefile, family, title , fonts, encoding, bg, fg, |
| width, height, horizontal, pointsize, |
| paper, pagecentre, print.it, command, colormodel, |
| useKerning, fillOddEven) |
| { |
| ## do initialization if needed |
| initPSandPDFfonts() |
| |
| new <- list() |
| if(!missing(onefile)) new$onefile <- onefile |
| ## 'family' is handled separately |
| if(!missing(title)) new$title <- title |
| if(!missing(fonts)) new$fonts <- fonts |
| if(!missing(encoding)) new$encoding <- encoding |
| if(!missing(bg)) new$bg <- bg |
| if(!missing(fg)) new$fg <- fg |
| if(!missing(width)) new$width <- width |
| if(!missing(height)) new$height <- height |
| if(!missing(horizontal)) new$horizontal <- horizontal |
| if(!missing(pointsize)) new$pointsize <- pointsize |
| if(!missing(paper)) new$paper <- paper |
| if(!missing(pagecentre)) new$pagecentre <- pagecentre |
| if(!missing(print.it)) new$print.it <- print.it |
| if(!missing(command)) new$command <- command |
| if(!missing(colormodel)) new$colormodel <- colormodel |
| if(!missing(useKerning)) new$useKerning <- useKerning |
| if(!missing(fillOddEven)) new$fillOddEven <- fillOddEven |
| |
| old <- check.options(new, name.opt = ".PostScript.Options", envir = .PSenv) |
| |
| if(is.null(old$command) || old$command == "default") |
| old$command <- if(!is.null(cmd <- getOption("printcmd"))) cmd else "" |
| |
| # need to handle this case before encoding |
| if(!missing(family) && |
| (inherits(family, "Type1Font") || inherits(family, "CIDFont"))) { |
| enc <- family$encoding |
| if(inherits(family, "Type1Font") &&!is.null(enc) && enc != "default" |
| && (is.null(old$encoding) || old$encoding == "default")) |
| old$encoding <- enc |
| family <- family$metrics |
| } |
| if(is.null(old$encoding) || old$encoding == "default") |
| old$encoding <- guessEncoding(family) |
| |
| ## handle family separately as length can be 1, 4, or 5 |
| if(!missing(family)) { |
| # Case where family is a set of AFMs |
| if(length(family) == 4L) { |
| family <- c(family, "Symbol.afm") |
| } else if (length(family) == 5L) { |
| ## nothing to do |
| } else if (length(family) == 1L) { |
| ## If family has been specified, match with a font in the |
| ## font database (see postscriptFonts()) |
| ## and pass in a device-independent font name. |
| ## NOTE that in order to match, we need both family name |
| ## and encoding to match. |
| pf <- postscriptFonts(family)[[1L]] |
| if(is.null(pf)) |
| stop(gettextf("unknown family '%s'", family), domain = NA) |
| matchFont(pf, old$encoding) |
| } else |
| stop("invalid 'family' argument") |
| old$family <- family |
| } |
| |
| onefile <- old$onefile # for 'file' |
| if(!checkIntFormat(file)) |
| stop(gettextf("invalid 'file' argument '%s'", file), domain = NA) |
| .External(C_PostScript, |
| file, old$paper, old$family, old$encoding, old$bg, old$fg, |
| old$width, old$height, old$horizontal, old$pointsize, |
| onefile, old$pagecentre, old$print.it, old$command, |
| old$title, old$fonts, old$colormodel, old$useKerning, |
| old$fillOddEven) |
| # if .ps.prolog is searched for and fails, NULL got returned. |
| invisible() |
| } |
| |
| xfig <- function (file = if(onefile) "Rplots.fig" else "Rplot%03d.fig", |
| onefile = FALSE, encoding = "none", |
| paper = "default", horizontal = TRUE, |
| width = 0, height = 0, family = "Helvetica", |
| pointsize = 12, bg = "transparent", fg = "black", |
| pagecentre = TRUE, |
| defaultfont = FALSE, textspecial = FALSE) |
| { |
| ## do initialization if needed |
| initPSandPDFfonts() |
| |
| if(!checkIntFormat(file)) |
| stop(gettextf("invalid 'file' argument '%s'", file), domain = NA) |
| .External(C_XFig, file, paper, family, bg, fg, |
| width, height, horizontal, pointsize, |
| onefile, pagecentre, defaultfont, textspecial, encoding) |
| invisible() |
| } |
| |
| pdf <- function(file = if(onefile) "Rplots.pdf" else "Rplot%03d.pdf", |
| width, height, onefile, family, title, fonts, version, |
| paper, encoding, bg, fg, pointsize, pagecentre, colormodel, |
| useDingbats, useKerning, fillOddEven, compress) |
| { |
| ## do initialization if needed |
| initPSandPDFfonts() |
| |
| new <- list() |
| if(!missing(width)) new$width <- width |
| if(!missing(height)) new$height <- height |
| if(!missing(onefile)) new$onefile <- onefile |
| ## 'family' is handled separately |
| if(!missing(title)) new$title <- title |
| if(!missing(fonts)) new$fonts <- fonts |
| if(!missing(version)) new$version <- version |
| if(!missing(paper)) new$paper <- paper |
| if(!missing(encoding)) new$encoding <- encoding |
| if(!missing(bg)) new$bg <- bg |
| if(!missing(fg)) new$fg <- fg |
| if(!missing(pointsize)) new$pointsize <- pointsize |
| if(!missing(pagecentre)) new$pagecentre <- pagecentre |
| if(!missing(colormodel)) new$colormodel <- colormodel |
| if(!missing(useDingbats)) new$useDingbats <- useDingbats |
| if(!missing(useKerning)) new$useKerning <- useKerning |
| if(!missing(fillOddEven)) new$fillOddEven <- fillOddEven |
| if(!missing(compress)) new$compress <- compress |
| |
| old <- check.options(new, name.opt = ".PDF.Options", envir = .PSenv) |
| |
| ## need to handle this before encoding |
| if(!missing(family) && |
| (inherits(family, "Type1Font") || inherits(family, "CIDFont"))) { |
| enc <- family$encoding |
| if(inherits(family, "Type1Font") &&!is.null(enc) && enc != "default" |
| && (is.null(old$encoding) || old$encoding == "default")) |
| old$encoding <- enc |
| family <- family$metrics |
| } |
| if(is.null(old$encoding) || old$encoding == "default") |
| old$encoding <- guessEncoding() |
| ## handle family separately as length can be 1, 4, or 5 |
| if(!missing(family)) { |
| # Case where family is a set of AFMs |
| if(length(family) == 4L) { |
| family <- c(family, "Symbol.afm") |
| } else if (length(family) == 5L) { |
| ## nothing to do |
| } else if (length(family) == 1L) { |
| ## If family has been specified, match with a font in the |
| ## font database (see postscriptFonts()) |
| ## and pass in a device-independent font name. |
| ## NOTE that in order to match, we need both family name |
| ## and encoding to match. |
| pf <- pdfFonts(family)[[1L]] |
| if(is.null(pf)) |
| stop(gettextf("unknown family '%s'", family), domain = NA) |
| matchFont(pf, old$encoding) |
| } else |
| stop("invalid 'family' argument") |
| old$family <- family |
| } |
| # Extract version |
| version <- old$version |
| versions <- c("1.1", "1.2", "1.3", "1.4", "1.5", "1.6", "1.7", "2.0") |
| if (version %in% versions) |
| version <- as.integer(strsplit(version, "[.]")[[1L]]) |
| else |
| stop("invalid PDF version") |
| |
| onefile <- old$onefile # needed to set 'file' |
| if(!checkIntFormat(file)) |
| stop(gettextf("invalid 'file' argument '%s'", file), domain = NA) |
| .External(C_PDF, |
| file, old$paper, old$family, old$encoding, old$bg, old$fg, |
| old$width, old$height, old$pointsize, onefile, old$pagecentre, |
| old$title, old$fonts, version[1L], version[2L], |
| old$colormodel, old$useDingbats, old$useKerning, |
| old$fillOddEven, old$compress) |
| invisible() |
| } |
| |
| .ps.prolog <- c( |
| "/gs { gsave } bind def", |
| "/gr { grestore } bind def", |
| "/ep { showpage gr gr } bind def", |
| "/m { moveto } bind def", |
| "/l { rlineto } bind def", |
| "/np { newpath } bind def", |
| "/cp { closepath } bind def", |
| "/f { fill } bind def", |
| "/o { stroke } bind def", |
| "/c { newpath 0 360 arc } bind def", |
| "/r { 4 2 roll moveto 1 copy 3 -1 roll exch 0 exch rlineto 0 rlineto -1 mul 0 exch rlineto closepath } bind def", |
| "/p1 { stroke } bind def", |
| "/p2 { gsave bg fill grestore newpath } bind def", |
| "/p3 { gsave bg fill grestore stroke } bind def", |
| "/p6 { gsave bg eofill grestore newpath } bind def", |
| "/p7 { gsave bg eofill grestore stroke } bind def", |
| "/t { 5 -2 roll moveto gsave rotate", |
| " 1 index stringwidth pop", |
| " mul neg 0 rmoveto show grestore } bind def", |
| "/ta { 4 -2 roll moveto gsave rotate show } bind def", |
| "/tb { 2 -1 roll 0 rmoveto show } bind def", |
| "/cl { grestore gsave newpath 3 index 3 index moveto 1 index", |
| " 4 -1 roll lineto exch 1 index lineto lineto", |
| " closepath clip newpath } bind def", |
| "/rgb { setrgbcolor } bind def", |
| "/s { scalefont setfont } bind def") |
| |
| .ps.prolog.srgb <- c(## From PLRM 3rd Ed pg 225 |
| "/sRGB { [ /CIEBasedABC", |
| " << /DecodeLMN", |
| " [ { dup 0.03928 le", |
| " {12.92321 div}", |
| " {0.055 add 1.055 div 2.4 exp }", |
| " ifelse", |
| " } bind dup dup", |
| " ]", |
| " /MatrixLMN [0.412457 0.212673 0.019334", |
| " 0.357576 0.715152 0.119192", |
| " 0.180437 0.072175 0.950301]", |
| " /WhitePoint [0.9505 1.0 1.0890]", |
| " >>", |
| " ] setcolorspace } bind def" |
| ) |
| |
| #################### |
| # PostScript font database |
| # |
| # PostScript fonts may be either Type1 or CID-keyed fonts |
| # (the latter provides support for CJK fonts) |
| #################### |
| |
| assign(".PostScript.Fonts", list(), envir = .PSenv) |
| |
| checkFont <- function(font) UseMethod("checkFont") |
| |
| checkFont.default <- function(font) stop("Invalid font type") |
| |
| # A Type1 font family has a name, plus a vector of 4 or 5 directories |
| # for font metric afm files, plus an encoding file |
| |
| # Check that the font has the correct structure and information |
| # Already checked that it had a name |
| checkFont.Type1Font <- function(font) { |
| if (is.null(font$family) || !is.character(font$family)) |
| stop("invalid family name in font specification") |
| if (is.null(font$metrics) || !is.character(font$metrics) || |
| length(font$metrics) < 4L) |
| stop("invalid metric information in font specification") |
| ## Add default symbol font metric if none provided |
| if (length(font$metrics) == 4L) |
| font$metrics <- c(font$metrics, "Symbol.afm") |
| if (is.null(font$encoding) || !is.character(font$encoding)) |
| stop("invalid encoding in font specification") |
| font |
| } |
| |
| # A CID-keyed font family has a name, four afm files, |
| # a CMap name, a CMap encoding, and (for now at least) a |
| # PDF chunk |
| # (I really hope we can dispense with the latter!) |
| checkFont.CIDFont <- function(font) { |
| if (!inherits(font, "CIDFont")) |
| stop("Not a CID font") |
| if (is.null(font$family) || !is.character(font$family)) |
| stop("invalid family name in font specification") |
| if (is.null(font$metrics) || !is.character(font$metrics) || |
| length(font$metrics) < 4L) |
| stop("invalid metric information in font specification") |
| ## Add default symbol font metric if none provided |
| if (length(font$metrics) == 4L) |
| font$metrics <- c(font$metrics, "Symbol.afm") |
| if (is.null(font$cmap) || !is.character(font$cmap)) |
| stop("invalid CMap name in font specification") |
| if (is.null(font$cmapEncoding) || !is.character(font$cmapEncoding)) |
| stop("invalid 'cmapEncoding' in font specification") |
| if (is.null(font$pdfresource) || !is.character(font$pdfresource)) |
| stop("invalid PDF resource in font specification") |
| font |
| } |
| |
| isPDF <- function(fontDBname) { |
| switch(fontDBname, |
| .PostScript.Fonts=FALSE, |
| .PDF.Fonts=TRUE, |
| stop("Invalid font database name")) |
| } |
| |
| checkFontInUse <- function(names, fontDBname) { |
| for (i in names) |
| if (.Call(C_Type1FontInUse, i, isPDF(fontDBname)) |
| || .Call(C_CIDFontInUse, i, isPDF(fontDBname))) |
| stop(gettextf("font %s already in use", i), domain = NA) |
| invisible() |
| } |
| |
| setFonts <- function(fonts, fontNames, fontDBname) { |
| fonts <- lapply(fonts, checkFont) |
| fontDB <- get(fontDBname, envir=.PSenv) |
| existingFonts <- fontNames %in% names(fontDB) |
| if (sum(existingFonts) > 0) { |
| checkFontInUse(fontNames[existingFonts], fontDBname) |
| fontDB[fontNames[existingFonts]] <- fonts[existingFonts] |
| } |
| if (sum(existingFonts) < length(fontNames)) |
| fontDB <- c(fontDB, fonts[!existingFonts]) |
| assign(fontDBname, fontDB, envir=.PSenv) |
| } |
| |
| printFont <- function(font) UseMethod("printFont") |
| |
| printFont.Type1Font <- function(font) |
| paste0(font$family, "\n (", paste(font$metrics, collapse = " "), |
| "\n ", font$encoding, "\n") |
| |
| printFont.CIDFont <- function(font) |
| paste0(font$family, "\n (", paste(font$metrics, collapse = " "), |
| ")\n ", font$CMap, "\n ", font$encoding, "\n") |
| |
| printFonts <- function(fonts) |
| cat(paste0(names(fonts), ": ", unlist(lapply(fonts, printFont)), |
| collapse = "")) |
| |
| # If no arguments specified, return entire font database |
| # If no named arguments specified, all args should be font names |
| # on which to get info from the database |
| # Else, must specify new fonts to enter into database (all |
| # of which must be valid PostScript font descriptions and |
| # all of which must be named args) |
| postscriptFonts <- function(...) |
| { |
| ## do initialization if needed: not recursive |
| initPSandPDFfonts() |
| ndots <- length(fonts <- list(...)) |
| if (ndots == 0L) |
| get(".PostScript.Fonts", envir=.PSenv) |
| else { |
| fontNames <- names(fonts) |
| nnames <- length(fontNames) |
| if (nnames == 0L) { |
| if (!all(sapply(fonts, is.character))) |
| stop(gettextf("invalid arguments in '%s' (must be font names)", |
| "postscriptFonts"), domain = NA) |
| else |
| get(".PostScript.Fonts", envir=.PSenv)[unlist(fonts)] |
| } else { |
| if (ndots != nnames) |
| stop(gettextf("invalid arguments in '%s' (need named args)", |
| "postscriptFonts"), domain = NA) |
| setFonts(fonts, fontNames, ".PostScript.Fonts") |
| } |
| } |
| } |
| |
| # Create a valid postscript font description |
| Type1Font <- function(family, metrics, encoding="default") |
| { |
| font <- list(family=family, metrics=metrics, encoding=encoding) |
| class(font) <- "Type1Font" |
| checkFont(font) |
| } |
| |
| CIDFont <- function(family, cmap, cmapEncoding, pdfresource="") |
| { |
| font <- list(family=family, metrics=c("", "", "", ""), cmap=cmap, |
| cmapEncoding=cmapEncoding, pdfresource=pdfresource) |
| class(font) <- "CIDFont" |
| checkFont(font) |
| } |
| |
| |
| #################### |
| # PDF font database |
| # |
| # PDF fonts may be either Type1 or CID-keyed fonts |
| # (the latter provides support for CJK fonts) |
| # |
| # PDF font database separate from PostScript one because |
| # some standard CID fonts are different |
| #################### |
| |
| assign(".PDF.Fonts", list(), envir = .PSenv) |
| |
| pdfFonts <- function(...) |
| { |
| ## do initialization if needed: not recursive |
| initPSandPDFfonts() |
| ndots <- length(fonts <- list(...)) |
| if (ndots == 0L) |
| get(".PDF.Fonts", envir=.PSenv) |
| else { |
| fontNames <- names(fonts) |
| nnames <- length(fontNames) |
| if (nnames == 0L) { |
| if (!all(sapply(fonts, is.character))) |
| stop(gettextf("invalid arguments in '%s' (must be font names)", |
| "pdfFonts"), domain = NA) |
| else |
| get(".PDF.Fonts", envir=.PSenv)[unlist(fonts)] |
| } else { |
| if (ndots != nnames) |
| stop(gettextf("invalid arguments in '%s' (need named args)", |
| "pdfFonts"), domain = NA) |
| setFonts(fonts, fontNames, ".PDF.Fonts") |
| } |
| } |
| } |
| |
| # Match an encoding |
| # NOTE that if encoding in font database is "default", that is a match |
| matchEncoding <- function(font, encoding) UseMethod("matchEncoding") |
| |
| matchEncoding.Type1Font <- function(font, encoding) { |
| ## the trailing .enc is optional |
| font$encoding %in% c("default", encoding, paste0(encoding, ".enc")) |
| } |
| |
| # Users should not be specifying a CID font AND an encoding |
| # when starting a new device |
| matchEncoding.CIDFont <- function(font, encoding) TRUE |
| |
| # Match a font name (and an encoding) |
| matchFont <- function(font, encoding) { |
| if (is.null(font)) |
| stop("unknown font") |
| if (!matchEncoding(font, encoding)) |
| stop(gettextf("font encoding mismatch '%s'/'%s'", |
| font$encoding, encoding), domain=NA) |
| } |
| |
| # Function to initialise default PostScript and PDF fonts |
| # Called at first use |
| # a) because that's a sensible place to do initialisation of package globals |
| # b) because it does not work to do it BEFORE then. In particular, |
| # if the body of this function is evaluated when the R code of the |
| # package is sourced, then the method dispatch on checkFont() does |
| # not work because when the R code is sourced, the S3 methods in |
| # this package have not yet been registered. |
| # Also, we want the run-time locale not the install-time locale. |
| |
| initPSandPDFfonts <- function() { |
| if(exists(".PostScript.Options", envir = .PSenv, inherits=FALSE)) return() |
| |
| assign(".PostScript.Options", |
| list(onefile = TRUE, |
| family = "Helvetica", |
| title = "R Graphics Output", |
| fonts = NULL, |
| encoding = "default", |
| bg = "transparent", |
| fg = "black", |
| width = 0, |
| height = 0, |
| horizontal = TRUE, |
| pointsize = 12, |
| paper = "default", |
| pagecentre = TRUE, |
| print.it = FALSE, |
| command = "default", |
| colormodel = "srgb", |
| useKerning = TRUE, |
| fillOddEven = FALSE), envir = .PSenv) |
| assign(".PostScript.Options.default", |
| get(".PostScript.Options", envir = .PSenv), |
| envir = .PSenv) |
| |
| assign(".PDF.Options", |
| list(width = 7, |
| height = 7, |
| onefile = TRUE, |
| family = "Helvetica", |
| title = "R Graphics Output", |
| fonts = NULL, |
| version = "1.4", |
| paper = "special", |
| encoding = "default", |
| bg = "transparent", |
| fg = "black", |
| pointsize = 12, |
| pagecentre = TRUE, |
| colormodel = "srgb", |
| useDingbats = TRUE, |
| useKerning = TRUE, |
| fillOddEven = FALSE, |
| compress = TRUE), envir = .PSenv) |
| assign(".PDF.Options.default", |
| get(".PDF.Options", envir = .PSenv), |
| envir = .PSenv) |
| |
| |
| postscriptFonts(# Default Serif font is Times |
| serif = Type1Font("Times", |
| c("Times-Roman.afm", "Times-Bold.afm", |
| "Times-Italic.afm", "Times-BoldItalic.afm", |
| "Symbol.afm")), |
| # Default Sans Serif font is Helvetica |
| sans = Type1Font("Helvetica", |
| c("Helvetica.afm", "Helvetica-Bold.afm", |
| "Helvetica-Oblique.afm", "Helvetica-BoldOblique.afm", |
| "Symbol.afm")), |
| # Default Monospace font is Courier |
| mono = Type1Font("Courier", |
| c("Courier.afm", "Courier-Bold.afm", |
| "Courier-Oblique.afm", "Courier-BoldOblique.afm", |
| "Symbol.afm")), |
| # Remainder are standard Adobe fonts that |
| # should be present on PostScript devices |
| AvantGarde = Type1Font("AvantGarde", |
| c("agw_____.afm", "agd_____.afm", |
| "agwo____.afm", "agdo____.afm", |
| "Symbol.afm")), |
| Bookman = Type1Font("Bookman", |
| c("bkl_____.afm", "bkd_____.afm", |
| "bkli____.afm", "bkdi____.afm", |
| "Symbol.afm")), |
| Courier = Type1Font("Courier", |
| c("Courier.afm", "Courier-Bold.afm", |
| "Courier-Oblique.afm", "Courier-BoldOblique.afm", |
| "Symbol.afm")), |
| Helvetica = Type1Font("Helvetica", |
| c("Helvetica.afm", "Helvetica-Bold.afm", |
| "Helvetica-Oblique.afm", "Helvetica-BoldOblique.afm", |
| "Symbol.afm")), |
| "Helvetica-Narrow" = Type1Font("Helvetica-Narrow", |
| c("hvn_____.afm", "hvnb____.afm", |
| "hvno____.afm", "hvnbo___.afm", |
| "Symbol.afm")), |
| NewCenturySchoolbook = Type1Font("NewCenturySchoolbook", |
| c("ncr_____.afm", "ncb_____.afm", |
| "nci_____.afm", "ncbi____.afm", |
| "Symbol.afm")), |
| Palatino = Type1Font("Palatino", |
| c("por_____.afm", "pob_____.afm", |
| "poi_____.afm", "pobi____.afm", |
| "Symbol.afm")), |
| Times = Type1Font("Times", |
| c("Times-Roman.afm", "Times-Bold.afm", |
| "Times-Italic.afm", "Times-BoldItalic.afm", |
| "Symbol.afm")), |
| # URW equivalents |
| URWGothic = Type1Font("URWGothic", |
| c("a010013l.afm", "a010015l.afm", |
| "a010033l.afm", "a010035l.afm", |
| "s050000l.afm")), |
| URWBookman = Type1Font("URWBookman", |
| c("b018012l.afm", "b018015l.afm", |
| "b018032l.afm", "b018035l.afm", |
| "s050000l.afm")), |
| NimbusMon = Type1Font("NimbusMon", |
| c("n022003l.afm", "n022004l.afm", |
| "n022023l.afm", "n022024l.afm", |
| "s050000l.afm")), |
| NimbusSan = Type1Font("NimbusSan", |
| c("n019003l.afm", "n019004l.afm", |
| "n019023l.afm", "n019024l.afm", |
| "s050000l.afm")), |
| URWHelvetica = Type1Font("URWHelvetica", |
| c("n019003l.afm", "n019004l.afm", |
| "n019023l.afm", "n019024l.afm", |
| "s050000l.afm")), |
| NimbusSanCond = Type1Font("NimbusSanCond", |
| c("n019043l.afm", "n019044l.afm", |
| "n019063l.afm", "n019064l.afm", |
| "s050000l.afm")), |
| CenturySch = Type1Font("CenturySch", |
| c("c059013l.afm", "c059016l.afm", |
| "c059033l.afm", "c059036l.afm", |
| "s050000l.afm")), |
| URWPalladio = Type1Font("URWPalladio", |
| c("p052003l.afm", "p052004l.afm", |
| "p052023l.afm", "p052024l.afm", |
| "s050000l.afm")), |
| NimbusRom = Type1Font("NimbusRom", |
| c("n021003l.afm", "n021004l.afm", |
| "n021023l.afm", "n021024l.afm", |
| "s050000l.afm")), |
| URWTimes = Type1Font("URWTimes", |
| c("n021003l.afm", "n021004l.afm", |
| "n021023l.afm", "n021024l.afm", |
| "s050000l.afm")), |
| ## And Monotype Arial |
| ArialMT = Type1Font("ArialMT", |
| c("ArialMT.afm", "ArialMT-Bold.afm", |
| "ArialMT-Italic.afm", "ArialMT-BoldItalic.afm", |
| "Symbol.afm")) |
| ) |
| |
| ## All of the above Type1 fonts are the same for PostScript and PDF |
| do.call("pdfFonts", postscriptFonts()) |
| |
| ## add ComputerModern to postscript only |
| postscriptFonts(# Computer Modern as recoded by Brian D'Urso |
| ComputerModern = Type1Font("ComputerModern", |
| c("CM_regular_10.afm", "CM_boldx_10.afm", |
| "CM_italic_10.afm", "CM_boldx_italic_10.afm", |
| "CM_symbol_10.afm"), encoding = "TeXtext.enc"), |
| ComputerModernItalic = Type1Font("ComputerModernItalic", |
| c("CM_regular_10.afm", "CM_boldx_10.afm", "cmti10.afm", |
| "cmbxti10.afm", "CM_symbol_10.afm"), |
| encoding = "TeXtext.enc") |
| ) |
| |
| |
| # CJK fonts |
| postscriptFonts(Japan1 = CIDFont("HeiseiKakuGo-W5", "EUC-H", "EUC-JP"), |
| Japan1HeiMin = CIDFont("HeiseiMin-W3", "EUC-H", "EUC-JP"), |
| Japan1GothicBBB = |
| CIDFont("GothicBBB-Medium", "EUC-H", "EUC-JP"), |
| Japan1Ryumin = CIDFont("Ryumin-Light", "EUC-H", "EUC-JP"), |
| Korea1 = CIDFont("Baekmuk-Batang", "KSCms-UHC-H", "CP949"), |
| Korea1deb = CIDFont("Batang-Regular", "KSCms-UHC-H", "CP949"), |
| CNS1 = CIDFont("MOESung-Regular", "B5pc-H", "CP950"), |
| GB1 = CIDFont("BousungEG-Light-GB", "GBK-EUC-H", "GBK")) |
| |
| pdfFonts(Japan1 = CIDFont("KozMinPro-Regular-Acro", "EUC-H", "EUC-JP", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 740 /Ascent 1075 /Descent -272 /StemV 72", |
| " /FontBBox [-195 -272 1110 1075]", |
| " /ItalicAngle 0 /Flags 6 /XHeight 502", |
| " /Style << /Panose <000001000500000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(Japan1) /Supplement 2 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 632 500 ", |
| " 8718 [500 500] ", |
| "]\n", |
| sep = "\n ")), |
| Japan1HeiMin = CIDFont("HeiseiMin-W3-Acro", "EUC-H", "EUC-JP", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 709 /Ascent 723 /Descent -241 /StemV 69", |
| " /FontBBox [-123 -257 1001 910]", |
| " /ItalicAngle 0 /Flags 6 /XHeight 450", |
| " /Style << /Panose <000002020500000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(Japan1) /Supplement 2 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 632 500 ", |
| " 8718 [500 500] ", |
| "]\n", |
| sep = "\n ")), |
| Japan1GothicBBB = CIDFont("GothicBBB-Medium", "EUC-H", "EUC-JP", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 737 /Ascent 752 /Descent -271 /StemV 99", |
| " /FontBBox [-22 -252 1000 892]", |
| " /ItalicAngle 0 /Flags 4", |
| " /Style << /Panose <0801020b0500000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(Japan1) /Supplement 2 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 632 500", |
| " 8718 [500 500]", |
| "]\n", |
| sep = "\n ")), |
| Japan1Ryumin = CIDFont("Ryumin-Light", "EUC-H", "EUC-JP", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 709 /Ascent 723 /Descent -241 /StemV 69", |
| " /FontBBox [-54 -305 1000 903]", |
| " /ItalicAngle 0 /Flags 6", |
| " /Style << /Panose <010502020300000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(Japan1) /Supplement 2 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 632 500", |
| " 8718 [500 500]", |
| "]\n", |
| sep = "\n ")), |
| Korea1 = CIDFont("HYSMyeongJoStd-Medium-Acro", "KSCms-UHC-H", "CP949", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 720 /Ascent 880 /Descent -148 /StemV 59", |
| " /FontBBox [-28 -148 1001 880]", |
| " /ItalicAngle 0 /Flags 6 /XHeight 468", |
| " /Style << /Panose <000001000600000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(Korea1) /Supplement 1 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 94 500", |
| " 97 [500] ", |
| " 8094 8190 500", |
| "]\n", |
| sep = "\n ")), |
| Korea1deb = CIDFont("HYGothic-Medium-Acro", "KSCms-UHC-H", "CP949", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 737 /Ascent 752 /Descent -271 /StemV 58", |
| " /FontBBox [-6 -145 1003 880]", |
| " /ItalicAngle 0 /Flags 4 /XHeight 553", |
| " /Style << /Panose <000001000600000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(Korea1) /Supplement 1 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 94 500", |
| " 97 [500] ", |
| " 8094 8190 500", |
| "]\n", |
| sep = "\n ")), |
| CNS1 = CIDFont("MSungStd-Light-Acro", "B5pc-H", "CP950", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 662 /Ascent 1071 /Descent -249 /StemV 66", |
| " /FontBBox [-160 -249 1015 1071]", |
| " /ItalicAngle 0 /Flags 6 /XHeight 400", |
| " /Style << /Panose <000001000600000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(CNS1) /Supplement 0 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 33 500", |
| " 34 [749 673 679 679 685 671 738 736 333 494 739 696 902 720 750 674 746 672 627 769 707 777 887 709 616]", |
| " 60 65 500", |
| " 66 [500 511 502 549 494 356 516 550 321 321 510 317 738 533 535 545 533 376 443 261 529 742 534 576 439]", |
| " 92 95 500", |
| " 13648 13742 500", |
| " 17603 [500]", |
| "]\n", |
| sep = "\n ")), |
| GB1 = CIDFont("STSong-Light-Acro", "GBK-EUC-H", "GBK", |
| paste("/FontDescriptor", |
| "<<", |
| " /Type /FontDescriptor", |
| " /CapHeight 626 /Ascent 905 /Descent -254 /StemV 48", |
| " /FontBBox [-134 -254 1001 905]", |
| " /ItalicAngle 0 /Flags 6 /XHeight 416", |
| " /Style << /Panose <000000000400000000000000> >>", |
| ">>", |
| "/CIDSystemInfo << /Registry(Adobe) /Ordering(GB1) /Supplement 2 >>", |
| "/DW 1000", |
| "/W [", |
| " 1 95 500", |
| " 814 939 500", |
| " 7712 7716 500", |
| " 22127 22357 500", |
| "]\n", |
| sep = "\n "))) |
| } |
| |
| # Call ghostscript to process postscript or pdf file to embed fonts |
| # (could also be used to convert ps or pdf to any supported format) |
| embedFonts <- function(file, # The ps or pdf file to convert |
| format, # Default guessed from file suffix |
| outfile = file, # By default overwrite file |
| fontpaths = character(), |
| options = character() # Additional options to ghostscript |
| ) |
| { |
| if(!is.character(file) || length(file) != 1L || !nzchar(file)) |
| stop("'file' must be a non-empty character string") |
| gsexe <- tools::find_gs_cmd() |
| if(!nzchar(gsexe)) stop("GhostScript was not found") |
| if(.Platform$OS.type == "windows") gsexe <- shortPathName(gsexe) |
| suffix <- gsub(".+[.]", "", file) |
| if (missing(format)) |
| format <- switch(suffix, |
| ps = , eps = "ps2write", |
| pdf = "pdfwrite") |
| if (!is.character(format)) stop("invalid output format") |
| check_gs_type(gsexe, format) |
| tmpfile <- tempfile("Rembed") |
| if (length(fontpaths)) |
| fontpaths <- |
| paste0("-sFONTPATH=", |
| shQuote(paste(fontpaths, collapse = .Platform$path.sep))) |
| args <- c(paste0("-dNOPAUSE -dBATCH -q -dAutoRotatePages=/None -sDEVICE=", format), |
| paste0(" -sOutputFile=", tmpfile), |
| fontpaths, options, shQuote(file)) |
| ret <- system2(gsexe, args) |
| if(ret != 0) |
| stop(gettextf("status %d in running command '%s'", ret, cmd), |
| domain = NA) |
| if(outfile != file) args[2] <- paste0(" -sOutputFile=", shQuote(outfile)) |
| cmd <- paste(c(shQuote(gsexe), args), collapse = " ") |
| file.copy(tmpfile, outfile, overwrite = TRUE) |
| invisible(cmd) |
| } |
