| # File src/library/utils/R/aspell.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/ |
| |
| aspell <- |
| function(files, filter, control = list(), encoding = "unknown", |
| program = NULL, dictionaries = character()) |
| { |
| ## Take the given files and feed them through spell checker in |
| ## Ispell pipe mode. |
| |
| ## Think about options and more command line options eventually. |
| |
| program <- aspell_find_program(program) |
| if(is.na(program)) |
| stop("No suitable spell-checker program found") |
| |
| ## Be nice. |
| if(inherits(files, "Rd")) |
| files <- list(files) |
| |
| files_are_names <- is.character(files) |
| |
| filter_args <- list() |
| if(missing(filter) || is.null(filter)) { |
| filter <- if(!files_are_names) { |
| function(ifile, encoding) { |
| if(inherits(ifile, "srcfile")) |
| readLines(ifile$filename, encoding = encoding, |
| warn = FALSE) |
| else if(inherits(ifile, "connection")) |
| readLines(ifile, encoding = encoding, warn = FALSE) |
| else { |
| ## What should this do with encodings? |
| as.character(ifile) |
| } |
| } |
| } |
| else NULL |
| } |
| else if(is.character(filter)) { |
| ## Look up filter in aspell filter db. |
| filter_name <- filter[1L] |
| filter <- aspell_filter_db[[filter_name]] |
| ## Warn if the filter was not found in the db. |
| if(is.null(filter)) |
| warning(gettextf("Filter '%s' is not available.", |
| filter_name), |
| domain = NA) |
| } |
| else if(is.list(filter)) { |
| ## Support |
| ## list("Rd", drop = "\\references" |
| ## at least for now. |
| filter_name <- filter[[1L]][1L] |
| filter_args <- filter[-1L] |
| filter <- aspell_filter_db[[filter_name]] |
| ## Warn if the filter was not found in the db. |
| if(is.null(filter)) |
| warning(gettextf("Filter '%s' is not available.", |
| filter_name), |
| domain = NA) |
| } |
| else if(!is.function(filter)) |
| stop("Invalid 'filter' argument.") |
| |
| encoding <- rep_len(encoding, length(files)) |
| |
| verbose <- getOption("verbose") |
| |
| db <- data.frame(Original = character(), File = character(), |
| Line = integer(), Column = integer(), |
| stringsAsFactors = FALSE) |
| db$Suggestions <- list() |
| |
| tfile <- tempfile("aspell") |
| on.exit(unlink(tfile)) |
| |
| if(length(dictionaries)) { |
| paths <- aspell_find_dictionaries(dictionaries) |
| ind <- paths == "" |
| if(any(ind)) { |
| warning(gettextf("The following dictionaries were not found:\n%s", |
| paste(sprintf(" %s", dictionaries[ind]), |
| collapse = "\n")), |
| domain = NA) |
| paths <- paths[!ind] |
| } |
| if(length(paths)) { |
| words <- unlist(lapply(paths, readRDS), use.names = FALSE) |
| personal <- tempfile("aspell_personal") |
| on.exit(unlink(personal), add = TRUE) |
| ## <FIXME> |
| ## How can we get the right language set (if needed)? |
| ## Maybe aspell() needs an additional 'language' arg? |
| aspell_write_personal_dictionary_file(words, personal, |
| program = program) |
| ## </FIXME> |
| control <- c(control, "-p", shQuote(personal)) |
| } |
| } |
| |
| ## No special expansion of control argument for now. |
| control <- as.character(control) |
| |
| fnames <- names(files) |
| files <- as.list(files) |
| |
| for (i in seq_along(files)) { |
| |
| file <- files[[i]] |
| if(files_are_names) |
| fname <- file |
| else { |
| ## Try srcfiles and srcrefs ... |
| fname <- if(inherits(file, "srcfile")) |
| file$filename |
| else |
| attr(attr(file, "srcref"), "srcfile")$filename |
| ## As a last resort, try the names of the files argument. |
| if(is.null(fname)) |
| fname <- fnames[i] |
| ## If unknown ... |
| if(is.null(fname)) |
| fname <- "<unknown>" |
| } |
| |
| enc <- encoding[i] |
| |
| if(verbose) |
| message(gettextf("Processing file %s", fname), |
| domain = NA) |
| |
| lines <- if(is.null(filter)) |
| readLines(file, encoding = enc, warn = FALSE) |
| else { |
| ## Assume that filter takes an input file (and additional |
| ## arguments) and return a character vector. |
| do.call(filter, c(list(file, encoding = enc), filter_args)) |
| } |
| |
| ## Allow filters to pass additional control arguments, in case |
| ## these need to be inferred from the file contents. |
| control <- c(control, attr(lines, "control")) |
| |
| ## Need to escape all lines with carets to ensure Aspell handles |
| ## them as data: the Aspell docs say |
| ## It is recommended that programmatic interfaces prefix every |
| ## data line with an uparrow to protect themselves against |
| ## future changes in Aspell. |
| writeLines(paste0("^", lines), tfile) |
| ## Note that this re-encodes character strings with marked |
| ## encodings to the current encoding (which is definitely fine |
| ## if this is UTF-8 and Aspell was compiled with full UTF-8 |
| ## support). Alternatively, we could try using something along |
| ## the lines of |
| ## writeLines(paste0("^", lines), tfile, |
| ## useBytes = TRUE) |
| ## and pass the encoding info to Aspell in case we know it. |
| |
| out <- tools:::.system_with_capture(program, c("-a", control), |
| stdin = tfile) |
| |
| if(out$status != 0L) |
| stop(gettextf("Running aspell failed with diagnostics:\n%s", |
| paste(out$stderr, collapse = "\n")), |
| domain = NA) |
| |
| ## Hopefully everything worked ok. |
| lines <- out$stdout[-1L] |
| pos <- cumsum(lines == "") + 1L |
| |
| ## Format is as follows. |
| ## First line is a header. |
| ## Blank lines separate the results for each line. |
| ## Results for the word on each line are given as follows. |
| ## * If the word was found in the main dictionary, or your personal |
| ## dictionary, then the line contains only a `*'. |
| ## * If the word is not in the dictionary, but there are |
| ## suggestions, then the line contains an `&', a space, the |
| ## misspelled word, a space, the number of near misses, the number |
| ## of characters between the beginning of the line and the |
| ## beginning of the misspelled word, a colon, another space, and a |
| ## list of the suggestions separated by commas and spaces. |
| ## * If the word does not appear in the dictionary, and there are no |
| ## suggestions, then the line contains a `#', a space, the |
| ## misspelled word, a space, and the character offset from the |
| ## beginning of the line. |
| ## This can be summarized as follows: |
| ## OK: * |
| ## Suggestions: & original count offset: miss, miss, ... |
| ## None: # original offset |
| |
| ## Look at words not in dictionary with suggestions. |
| |
| if(any(ind <- startsWith(lines, "&"))) { |
| info <- strsplit(lines[ind], ": ", fixed = TRUE) |
| one <- strsplit(sapply(info, `[`, 1L), " ", fixed = TRUE) |
| two <- strsplit(sapply(info, `[`, 2L), ", ", fixed = TRUE) |
| db1 <- data.frame(Original = |
| as.character(sapply(one, `[`, 2L)), |
| File = fname, |
| Line = pos[ind], |
| Column = |
| as.integer(sapply(one, `[`, 4L)), |
| stringsAsFactors = FALSE) |
| db1$Suggestions <- two |
| db <- rbind(db, db1) |
| } |
| ## Looks at words not in dictionary with no suggestions. |
| if(any(ind <- startsWith(lines, "#"))) { |
| one <- strsplit(lines[ind], " ", fixed = TRUE) |
| db1 <- data.frame(Original = |
| as.character(sapply(one, `[`, 2L)), |
| File = fname, |
| Line = pos[ind], |
| Column = |
| as.integer(sapply(one, `[`, 3L)), |
| stringsAsFactors = FALSE) |
| db1$Suggestions <- vector("list", length(one)) |
| db <- rbind(db, db1) |
| } |
| } |
| |
| class(db) <- c("aspell", "data.frame") |
| db |
| } |
| |
| format.aspell <- |
| function(x, sort = TRUE, verbose = FALSE, indent = 2L, ...) |
| { |
| if(!nrow(x)) return(character()) |
| |
| if(sort) |
| x <- x[order(x$Original, x$File, x$Line, x$Column), ] |
| |
| from <- split(sprintf("%s:%d:%d", x$File, x$Line, x$Column), |
| x$Original) |
| |
| if(verbose) { |
| unlist(Map(function(w, f, s) { |
| sprintf("Word: %s\nFrom: %s\n%s", |
| w, |
| paste0(c("", rep.int(" ", length(f) - 1L)), |
| f, collapse = "\n"), |
| paste(strwrap(paste("Suggestions:", |
| paste(s[[1L]], collapse = " ")), |
| exdent = 6L, indent = 0L), |
| collapse = "\n")) |
| }, |
| names(from), |
| from, |
| split(x$Suggestions, x$Original))) |
| } else { |
| sep <- sprintf("\n%s", strrep(" ", indent)) |
| paste(names(from), |
| vapply(from, paste, "", collapse = sep), |
| sep = sep) |
| } |
| } |
| |
| print.aspell <- |
| function(x, ...) |
| { |
| if(nrow(x)) |
| writeLines(paste(format(x, ...), collapse = "\n\n")) |
| invisible(x) |
| } |
| |
| summary.aspell <- |
| function(object, ...) |
| { |
| words <- sort(unique(object$Original)) |
| if(length(words)) { |
| writeLines("Possibly mis-spelled words:") |
| print(words) |
| } |
| invisible(words) |
| } |
| |
| aspell_filter_db <- new.env(hash = FALSE) # small |
| aspell_filter_db$Rd <- tools::RdTextFilter |
| aspell_filter_db$Sweave <- tools::SweaveTeXFilter |
| |
| aspell_find_program <- |
| function(program = NULL) |
| { |
| check <- !is.null(program) || !is.null(names(program)) |
| if(is.null(program)) |
| program <- getOption("aspell_program") |
| if(is.null(program)) |
| program <- c("aspell", "hunspell", "ispell") |
| program <- Filter(nzchar, Sys.which(program))[1L] |
| if(!is.na(program) && check) { |
| out <- c(system(sprintf("%s -v", program), |
| intern = TRUE), "")[1L] |
| if(grepl("really Aspell", out)) |
| names(program) <- "aspell" |
| else if(grepl("really Hunspell", out)) |
| names(program) <- "hunspell" |
| else if(grepl("International Ispell", out)) |
| names(program) <- "ispell" |
| else |
| names(program) <- NA_character_ |
| } |
| program |
| } |
| |
| aspell_dictionaries_R <- "en_stats" |
| |
| aspell_find_dictionaries <- |
| function(dictionaries, dirnames = character()) |
| { |
| dictionaries <- as.character(dictionaries) |
| if(!(n <- length(dictionaries))) return(character()) |
| |
| ## Always search the R system dictionary directory first. |
| dirnames <- c(file.path(R.home("share"), "dictionaries"), dirnames) |
| |
| ## For now, all dictionary files should be .rds files. |
| if(any(ind <- !endsWith(dictionaries, ".rds"))) |
| dictionaries[ind] <- sprintf("%s.rds", dictionaries[ind]) |
| |
| out <- character(n) |
| ## Dictionaries with no path separators are looked for in the given |
| ## dictionary directories (by default, the R system dictionary |
| ## directory). |
| ind <- grepl(.Platform$file.sep, dictionaries, fixed = TRUE) |
| ## (Equivalently, could check where paths == basename(paths).) |
| if(length(pos <- which(ind))) { |
| pos <- pos[file_test("-f", dictionaries[pos])] |
| out[pos] <- normalizePath(dictionaries[pos], "/") |
| } |
| if(length(pos <- which(!ind))) { |
| out[pos] <- find_files_in_directories(dictionaries[pos], |
| dirnames) |
| } |
| out |
| } |
| |
| ### Utilities. |
| |
| aspell_inspect_context <- |
| function(x) |
| { |
| x <- split(x, x$File) |
| y <- Map(function(f, x) { |
| lines <- readLines(f, warn = FALSE)[x$Line] |
| cbind(f, |
| x$Line, |
| substring(lines, 1L, x$Column - 1L), |
| x$Original, |
| substring(lines, x$Column + nchar(x$Original))) |
| }, |
| names(x), x) |
| y <- data.frame(do.call(rbind, y), stringsAsFactors = FALSE) |
| names(y) <- c("File", "Line", "Left", "Original", "Right") |
| class(y) <- c("aspell_inspect_context", "data.frame") |
| y |
| } |
| |
| print.aspell_inspect_context <- |
| function(x, ...) |
| { |
| s <- split(x, x$File) |
| nms <- names(s) |
| for(i in seq_along(s)) { |
| e <- s[[i]] |
| writeLines(c(sprintf("File '%s':", nms[i]), |
| sprintf(" Line %s: \"%s\", \"%s\", \"%s\"", |
| format(e$Line), |
| gsub("\"", "\\\"", e$Left), |
| e$Original, |
| gsub("\"", "\\\"", e$Right)), |
| "")) |
| } |
| invisible(x) |
| } |
| |
| |
| ## For spell-checking the R manuals: |
| |
| ## This can really only be done with Aspell as the other checkers have |
| ## no texinfo mode. |
| |
| aspell_control_R_manuals <- |
| list(aspell = |
| c("--master=en_US", |
| "--add-extra-dicts=en_GB", |
| "--mode=texinfo", |
| "--add-texinfo-ignore=acronym", |
| "--add-texinfo-ignore=deftypefun", |
| "--add-texinfo-ignore=deftypefunx", |
| "--add-texinfo-ignore=findex", |
| "--add-texinfo-ignore=enindex", |
| "--add-texinfo-ignore=include", |
| "--add-texinfo-ignore=ifclear", |
| "--add-texinfo-ignore=ifset", |
| "--add-texinfo-ignore=math", |
| "--add-texinfo-ignore=macro", |
| "--add-texinfo-ignore=multitable", |
| "--add-texinfo-ignore=node", |
| "--add-texinfo-ignore=pkg", |
| "--add-texinfo-ignore=printindex", |
| "--add-texinfo-ignore=set", |
| "--add-texinfo-ignore=vindex", |
| "--add-texinfo-ignore-env=menu", |
| "--add-texinfo-ignore=CRANpkg" |
| ), |
| hunspell = |
| c("-d en_US,en_GB")) |
| |
| aspell_R_manuals <- |
| function(which = NULL, dir = NULL, program = NULL, |
| dictionaries = aspell_dictionaries_R) |
| { |
| if(is.null(dir)) dir <- tools:::.R_top_srcdir_from_Rd() |
| ## Allow specifying 'R-exts' and alikes, or full paths. |
| files <- if(is.null(which)) { |
| Sys.glob(file.path(dir, "doc", "manual", "*.texi")) |
| } else { |
| ind <- which(which == |
| basename(tools::file_path_sans_ext(which))) |
| which[ind] <- |
| file.path(dir, "doc", "manual", |
| sprintf("%s.texi", which[ind])) |
| which |
| } |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| control = aspell_control_R_manuals[[names(program)]], |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking the R Rd files: |
| |
| aspell_control_R_Rd_files <- |
| list(aspell = |
| c("--master=en_US", |
| "--add-extra-dicts=en_GB"), |
| hunspell = |
| c("-d en_US,en_GB")) |
| |
| aspell_R_Rd_files <- |
| function(which = NULL, dir = NULL, drop = "\\references", |
| program = NULL, dictionaries = aspell_dictionaries_R) |
| { |
| files <- character() |
| |
| if(is.null(dir)) dir <- tools:::.R_top_srcdir_from_Rd() |
| |
| if(is.null(which)) { |
| which <- tools:::.get_standard_package_names()$base |
| # CHANGES.Rd could be dropped from checks in the future; |
| # it will not be updated post 2.15.0 |
| files <- c(file.path(dir, "doc", "NEWS.Rd"), |
| file.path(dir, "src", "gnuwin32", "CHANGES.Rd")) |
| files <- files[file_test("-f", files)] |
| } |
| |
| files <- |
| c(files, |
| unlist(lapply(file.path(dir, "src", "library", which, "man"), |
| tools::list_files_with_type, |
| "docs", OS_subdirs = c("unix", "windows")), |
| use.names = FALSE)) |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("Rd", drop = drop), |
| control = aspell_control_R_Rd_files[[names(program)]], |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking Rd files in a package: |
| |
| aspell_package_Rd_files <- |
| function(dir, drop = c("\\author", "\\references"), |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| dir <- normalizePath(dir, "/") |
| |
| subdir <- file.path(dir, "man") |
| files <- if(dir.exists(subdir)) |
| tools::list_files_with_type(subdir, |
| "docs", |
| OS_subdirs = c("unix", "windows")) |
| else character() |
| |
| meta <- tools:::.get_package_metadata(dir, installed = FALSE) |
| if(is.na(encoding <- meta["Encoding"])) |
| encoding <- "unknown" |
| |
| defaults <- .aspell_package_defaults(dir, encoding)$Rd_files |
| if(!is.null(defaults)) { |
| ## Direct settings currently override (could add a list add = |
| ## TRUE mechanism eventually). |
| if(!is.null(d <- defaults$drop)) |
| drop <- d |
| if(!is.null(d <- defaults$control)) |
| control <- d |
| if(!is.null(d <- defaults$program)) |
| program <- d |
| if(!is.null(d <- defaults$dictionaries)) { |
| dictionaries <- |
| aspell_find_dictionaries(d, file.path(dir, ".aspell")) |
| } |
| ## <FIXME> |
| ## Deprecated in favor of specifying R level dictionaries. |
| ## Maybe give a warning (in particular if both are given)? |
| if(!is.null(d <- defaults$personal)) |
| control <- c(control, |
| sprintf("-p %s", |
| shQuote(file.path(dir, ".aspell", d)))) |
| ## </FIXME> |
| } |
| |
| macros <- tools::loadPkgRdMacros(dir, |
| macros = file.path(R.home("share"), |
| "Rd", "macros", |
| "system.Rd")) |
| |
| aspell(files, |
| filter = list("Rd", drop = drop, macros = macros), |
| control = control, |
| encoding = encoding, |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking the R vignettes: |
| |
| ## This should really be done with Aspell as the other checkers have far |
| ## less powerful TeX modes. |
| |
| aspell_control_R_vignettes <- |
| list(aspell = |
| c("--mode=tex", |
| "--master=en_US", |
| "--add-extra-dicts=en_GB", |
| "--add-tex-command='code p'", |
| "--add-tex-command='pkg p'", |
| "--add-tex-command='CRANpkg p'" |
| ), |
| hunspell = |
| c("-t", "-d en_US,en_GB")) |
| |
| aspell_R_vignettes <- |
| function(program = NULL, dictionaries = aspell_dictionaries_R) |
| { |
| files <- Sys.glob(file.path(tools:::.R_top_srcdir_from_Rd(), |
| "src", "library", "*", "vignettes", |
| "*.Rnw")) |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = "Sweave", |
| control = aspell_control_R_vignettes[[names(program)]], |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking vignettes in a package: |
| |
| ## This should really be done with Aspell as the other checkers have far |
| ## less powerful TeX modes. |
| |
| aspell_control_package_vignettes <- |
| list(aspell = |
| c("--add-tex-command='citep oop'", |
| "--add-tex-command='Sexpr p'", |
| "--add-tex-command='code p'", |
| "--add-tex-command='pkg p'", |
| "--add-tex-command='proglang p'", |
| "--add-tex-command='samp p'" |
| )) |
| |
| aspell_package_vignettes <- |
| function(dir, |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| dir <- tools::file_path_as_absolute(dir) |
| |
| vinfo <- tools::pkgVignettes(dir = dir) |
| files <- vinfo$docs |
| if(!length(files)) return(aspell(character())) |
| |
| ## We need the package encoding to read the defaults file ... |
| meta <- tools:::.get_package_metadata(dir, installed = FALSE) |
| if(is.na(encoding <- meta["Encoding"])) |
| encoding <- "unknown" |
| |
| defaults <- .aspell_package_defaults(dir, encoding)$vignettes |
| if(!is.null(defaults)) { |
| if(!is.null(d <- defaults$control)) |
| control <- d |
| if(!is.null(d <- defaults$program)) |
| program <- d |
| if(!is.null(d <- defaults$dictionaries)) { |
| dictionaries <- |
| aspell_find_dictionaries(d, file.path(dir, ".aspell")) |
| } |
| ## <FIXME> |
| ## Deprecated in favor of specifying R level dictionaries. |
| ## Maybe give a warning (in particular if both are given)? |
| if(!is.null(d <- defaults$personal)) |
| control <- c(control, |
| sprintf("-p %s", |
| shQuote(file.path(dir, ".aspell", d)))) |
| ## </FIXME> |
| } |
| |
| program <- aspell_find_program(program) |
| |
| fgroups <- split(files, vinfo$engines) |
| egroups <- split(vinfo$encodings, vinfo$engines) |
| |
| do.call(rbind, |
| Map(function(fgroup, egroup, engine) { |
| engine <- tools::vignetteEngine(engine) |
| aspell(fgroup, |
| filter = engine$aspell$filter, |
| control = |
| c(engine$aspell$control, |
| aspell_control_package_vignettes[[names(program)]], |
| control), |
| encoding = egroup, |
| program = program, |
| dictionaries = dictionaries) |
| }, |
| fgroups, |
| egroups, |
| names(fgroups) |
| ) |
| ) |
| } |
| |
| ## Spell-checking R files. |
| |
| aspell_filter_db$R <- |
| function(ifile, encoding = "unknown", ignore = character()) |
| { |
| pd <- get_parse_data_for_message_strings(ifile, encoding) |
| if(is.null(pd) || !NROW(pd)) return(character()) |
| |
| ## Strip the string delimiters. |
| pd$text <- substring(pd$text, 2L, nchar(pd$text) - 1L) |
| ## Replace whitespace C backslash escape sequences by whitespace. |
| pd$text <- gsub("(^|[^\\])\\\\[fnrt]", "\\1 ", pd$text) |
| pd$text <- gsub( "([^\\])\\\\[fnrt]", "\\1 ", pd$text) |
| ## (Do this twice for now because in e.g. |
| ## \n\t\tInformation on package %s |
| ## the first \t is not matched the first time. Alternatively, we |
| ## could match with |
| ## (^|[^\\])((\\\\[fnrt])+) |
| ## but then computing the replacement (\\1 plus as many blanks as |
| ## the characters in \\2) is not straightforward. |
| ## For gettextf() calls, replace basic percent escape sequences by |
| ## whitespace. |
| ind <- pd$caller == "gettextf" |
| if(any(ind)) { |
| pd$text[ind] <- |
| gsub("(^|[^%])%[dioxXfeEgGaAs]", "\\1 ", pd$text[ind]) |
| pd$text[ind] <- |
| gsub(" ([^%])%[dioxXfeEgGaAs]", "\\1 ", pd$text[ind]) |
| ## (See above for doing this twice.) |
| } |
| |
| lines <- readLines(ifile, encoding = encoding, warn = FALSE) |
| |
| ## Column positions in the parse data have tabs expanded to tab |
| ## stops using a tab width of 8, so for lines with tabs we need to |
| ## map the column positions back to character positions. |
| lines_in_pd <- sort(unique(c(pd$line1, pd$line2))) |
| tab <- Map(function(tp, nc) { |
| if(tp[1L] == -1L) return(NULL) |
| widths <- rep.int(1, nc) |
| for(i in tp) { |
| cols <- cumsum(widths) |
| widths[i] <- 8 - (cols[i] - 1) %% 8 |
| } |
| cumsum(widths) |
| }, |
| gregexpr("\t", lines[lines_in_pd], fixed = TRUE), |
| nchar(lines[lines_in_pd])) |
| names(tab) <- lines_in_pd |
| |
| lines[lines_in_pd] <- gsub("[^\t]", " ", lines[lines_in_pd]) |
| lines[-lines_in_pd] <- "" |
| |
| for(entry in split(pd, seq_len(NROW(pd)))) { |
| line1 <- entry$line1 |
| line2 <- entry$line2 |
| col1 <- entry$col1 |
| col2 <- entry$col2 |
| if(line1 == line2) { |
| if(length(ptab <- tab[[as.character(line1)]])) { |
| col1 <- which(ptab == col1) + 1L |
| col2 <- which(ptab == col2) - 1L |
| } |
| substring(lines[line1], col1, col2) <- entry$text |
| } else { |
| texts <- unlist(strsplit(entry$text, "\n", fixed = TRUE)) |
| n <- length(texts) |
| if(length(ptab <- tab[[as.character(line1)]])) { |
| col1 <- which(ptab == col1) + 1L |
| } |
| substring(lines[line1], col1) <- texts[1L] |
| pos <- seq.int(from = 2L, length.out = n - 2L) |
| if(length(pos)) |
| lines[line1 + pos - 1] <- texts[pos] |
| if(length(ptab <- tab[[as.character(line2)]])) { |
| col2 <- which(ptab == col2) - 1L |
| } |
| substring(lines[line2], 1L, col2) <- texts[n] |
| } |
| } |
| |
| blank_out_ignores_in_lines(lines, ignore) |
| } |
| |
| get_parse_data_for_message_strings <- |
| function(file, encoding = "unknown") |
| { |
| ## The message strings considered are the string constants subject to |
| ## translation in gettext-family calls (see below for details). |
| |
| exprs <- |
| suppressWarnings(tools:::.parse_code_file(file = file, |
| encoding = encoding, |
| keep.source = TRUE)) |
| if(!length(exprs)) return(NULL) |
| |
| pd <- getParseData(exprs) |
| |
| ## Function for computing grandparent ids. |
| parents <- pd$parent |
| names(parents) <- pd$id |
| gpids <- function(ids) |
| parents[as.character(parents[as.character(ids)])] |
| |
| ind <- (pd$token == "SYMBOL_FUNCTION_CALL") & |
| !is.na(match(pd$text, |
| c("warning", "stop", |
| "message", "packageStartupMessage", |
| "gettext", "gettextf", "ngettext"))) |
| |
| funs <- pd$text[ind] |
| |
| ids <- gpids(pd$id[ind]) |
| calls <- getParseText(pd, ids) |
| |
| table <- pd[pd$token == "STR_CONST", ] |
| ## Could have run into truncation ... |
| table$text <- getParseText(table, table$id) |
| pos <- match(gpids(table$id), ids) |
| ind <- !is.na(pos) |
| table <- split(table[ind, ], factor(pos[ind], seq_along(ids))) |
| |
| ## We have synopses |
| ## message(..., domain = NULL, appendLF = TRUE) |
| ## packageStartupMessage(..., domain = NULL, appendLF = TRUE) |
| ## warning(..., call. = TRUE, immediate. = FALSE, domain = NULL) |
| ## stop(..., call. = TRUE, domain = NULL) |
| ## gettext(..., domain = NULL) |
| ## ngettext(n, msg1, msg2, domain = NULL) |
| ## gettextf(fmt, ..., domain = NULL) |
| ## For the first five, we simply take all unnamed strings. |
| ## (Could make this more precise, of course.) |
| ## For the latter two, we take the msg1/msg2 and fmt arguments, |
| ## provided these are strings. |
| |
| ## <NOTE> |
| ## Using domain = NA inhibits translation: perhaps it should |
| ## optionally also inhibit spell checking? |
| ## </NOTE> |
| |
| extract_message_strings <- function(fun, call, table) { |
| ## Matching a call containing ... gives |
| ## Error in match.call(message, call) : |
| ## ... used in a situation where it doesn't exist |
| ## so eliminate these. |
| ## (Note that we also drop "..." strings.) |
| call <- parse(text = call)[[1L]] |
| call <- call[ as.character(call) != "..." ] |
| mc <- as.list(match.call(get(fun, envir = .BaseNamespaceEnv), |
| call)) |
| args <- if(fun == "gettextf") |
| mc["fmt"] |
| else if(fun == "ngettext") |
| mc[c("msg1", "msg2")] |
| else { |
| if(!is.null(names(mc))) |
| mc <- mc[!nzchar(names(mc))] |
| mc[-1L] |
| } |
| strings <- as.character(args[vapply(args, is.character, TRUE)]) |
| ## Need to canonicalize to match string constants before and |
| ## after parsing ... |
| texts <- vapply(parse(text = table$text), as.character, "") |
| pos <- which(!is.na(match(texts, strings))) |
| cbind(table[pos, ], caller = rep.int(fun, length(pos))) |
| } |
| |
| do.call(rbind, |
| Map(extract_message_strings, |
| as.list(funs), as.list(calls), table)) |
| } |
| |
| ## For spell-checking the R R files. |
| |
| aspell_R_R_files <- |
| function(which = NULL, dir = NULL, |
| ignore = c("[ \t]'[^']*'[ \t[:punct:]]", |
| "[ \t][[:alnum:]_.]*\\(\\)[ \t[:punct:]]"), |
| program = NULL, dictionaries = aspell_dictionaries_R) |
| { |
| if(is.null(dir)) dir <- tools:::.R_top_srcdir_from_Rd() |
| if(is.null(which)) |
| which <- tools:::.get_standard_package_names()$base |
| |
| files <- |
| unlist(lapply(file.path(dir, "src", "library", which, "R"), |
| tools::list_files_with_type, |
| "code", |
| OS_subdirs = c("unix", "windows")), |
| use.names = FALSE) |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("R", ignore = ignore), |
| control = aspell_control_R_Rd_files[[names(program)]], |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking R files in a package. |
| |
| aspell_package_R_files <- |
| function(dir, ignore = character(), |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| dir <- tools::file_path_as_absolute(dir) |
| |
| subdir <- file.path(dir, "R") |
| files <- if(dir.exists(subdir)) |
| tools::list_files_with_type(subdir, |
| "code", |
| OS_subdirs = c("unix", "windows")) |
| else character() |
| |
| meta <- tools:::.get_package_metadata(dir, installed = FALSE) |
| if(is.na(encoding <- meta["Encoding"])) |
| encoding <- "unknown" |
| |
| defaults <- .aspell_package_defaults(dir, encoding)$R_files |
| if(!is.null(defaults)) { |
| if(!is.null(d <- defaults$ignore)) |
| ignore <- d |
| if(!is.null(d <- defaults$control)) |
| control <- d |
| if(!is.null(d <- defaults$program)) |
| program <- d |
| if(!is.null(d <- defaults$dictionaries)) { |
| dictionaries <- |
| aspell_find_dictionaries(d, file.path(dir, ".aspell")) |
| } |
| } |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("R", ignore = ignore), |
| control = control, |
| encoding = encoding, |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## Spell-checking pot files. |
| |
| ## (Of course, directly analyzing the message strings would be more |
| ## useful, but require writing appropriate text filters.) |
| |
| ## See also tools:::checkPoFile(). |
| |
| aspell_filter_db$pot <- |
| function (ifile, encoding = "unknown", ignore = character()) |
| { |
| lines <- readLines(ifile, encoding = encoding, warn = FALSE) |
| |
| ind <- grepl("^msgid[ \t]", lines) |
| |
| do_entry <- function(s) { |
| out <- character(length(s)) |
| i <- 1L |
| out[i] <- blank_out_regexp_matches(s[i], "^msgid[ \t]+\"") |
| while(startsWith(s[i <- i + 1L], '"')) |
| out[i] <- sub("^\"", " ", s[i]) |
| if(grepl("^msgid_plural[ \t]", s[i])) { |
| out[i] <- blank_out_regexp_matches(s[i], "^msgid_plural[ \t]+\"") |
| while(startsWith(s[i <- i + 1L], '"')) |
| out[i] <- sub("^\"", " ", s[i]) |
| } |
| out |
| } |
| |
| entries <- split(lines, cumsum(ind)) |
| lines <- c(character(length(entries[[1L]])), |
| as.character(do.call(c, lapply(entries[-1L], do_entry)))) |
| |
| lines <- sub("\"[ \t]*$", " ", lines) |
| |
| ## <FIXME> |
| ## Could replace backslash escapes for blanks and percent escapes by |
| ## blanks, similar to what the R text filter does. |
| ## </FIXME> |
| |
| blank_out_ignores_in_lines(lines, ignore) |
| } |
| |
| ## For spell-checking all pot files in a package. |
| |
| aspell_package_pot_files <- |
| function(dir, ignore = character(), |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| dir <- tools::file_path_as_absolute(dir) |
| subdir <- file.path(dir, "po") |
| files <- if(dir.exists(subdir)) |
| Sys.glob(file.path(subdir, "*.pot")) |
| else character() |
| |
| meta <- tools:::.get_package_metadata(dir, installed = FALSE) |
| if(is.na(encoding <- meta["Encoding"])) |
| encoding <- "unknown" |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("pot", ignore = ignore), |
| control = control, |
| encoding = encoding, |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking the R C files. |
| |
| aspell_R_C_files <- |
| function(which = NULL, dir = NULL, |
| ignore = c("[ \t]'[[:alnum:]_.]*'[ \t[:punct:]]", |
| "[ \t][[:alnum:]_.]*\\(\\)[ \t[:punct:]]"), |
| program = NULL, dictionaries = aspell_dictionaries_R) |
| { |
| if(is.null(dir)) dir <- tools:::.R_top_srcdir_from_Rd() |
| if(is.null(which)) |
| which <- tools:::.get_standard_package_names()$base |
| if(!is.na(pos <- match("base", which))) |
| which[pos] <- "R" |
| |
| files <- sprintf("%s.pot", |
| file.path(dir, "src", "library", |
| which, "po", which)) |
| files <- files[file_test("-f", files)] |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("pot", ignore = ignore), |
| control = aspell_control_R_Rd_files[[names(program)]], |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## For spell-checking package C files. |
| |
| aspell_package_C_files <- |
| function(dir, ignore = character(), |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| dir <- tools::file_path_as_absolute(dir) |
| ## Assume that the package C message template file is shipped as |
| ## 'po/PACKAGE.pot'. |
| files <- file.path(dir, "po", |
| paste(basename(dir), "pot", collapse = ".")) |
| files <- files[file_test("-f", files)] |
| |
| meta <- tools:::.get_package_metadata(dir, installed = FALSE) |
| if(is.na(encoding <- meta["Encoding"])) |
| encoding <- "unknown" |
| |
| defaults <- .aspell_package_defaults(dir, encoding)$C_files |
| if(!is.null(defaults)) { |
| if(!is.null(d <- defaults$ignore)) |
| ignore <- d |
| if(!is.null(d <- defaults$control)) |
| control <- d |
| if(!is.null(d <- defaults$program)) |
| program <- d |
| if(!is.null(d <- defaults$dictionaries)) { |
| dictionaries <- |
| aspell_find_dictionaries(d, file.path(dir, ".aspell")) |
| } |
| } |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("pot", ignore = ignore), |
| control = control, |
| encoding = encoding, |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## Spell-checking DCF files. |
| |
| aspell_filter_db$dcf <- |
| function(ifile, encoding, keep = c("Title", "Description"), |
| ignore = character()) |
| { |
| lines <- readLines(ifile, encoding = encoding, warn = FALSE) |
| line_has_tags <- grepl("^[^[:blank:]][^:]*:", lines) |
| tags <- sub(":.*", "", lines[line_has_tags]) |
| lines[line_has_tags] <- |
| blank_out_regexp_matches(lines[line_has_tags], "^[^:]*:") |
| lines <- split(lines, cumsum(line_has_tags)) |
| ind <- is.na(match(tags, keep)) |
| lines[ind] <- lapply(lines[ind], function(s) rep.int("", length(s))) |
| ind <- !ind |
| lines[ind] <- lapply(lines[ind], paste0, " ") |
| lines <- unlist(lines, use.names = FALSE) |
| blank_out_ignores_in_lines(lines, ignore) |
| } |
| |
| ## For spell-checking package DESCRIPTION files. |
| |
| aspell_package_description <- |
| function(dir, ignore = character(), |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| dir <- tools::file_path_as_absolute(dir) |
| files <- file.path(dir, "DESCRIPTION") |
| |
| meta <- tools:::.get_package_metadata(dir, installed = FALSE) |
| if(is.na(encoding <- meta["Encoding"])) |
| encoding <- "unknown" |
| |
| ## Allow providing package defaults but make this controllable via |
| ## _R_ASPELL_USE_DEFAULTS_FOR_PACKAGE_DESCRIPTION_ |
| ## to safeguard against possible mis-use for CRAN incoming checks. |
| defaults <- |
| Sys.getenv("_R_ASPELL_USE_DEFAULTS_FOR_PACKAGE_DESCRIPTION_", |
| "TRUE") |
| defaults <- if(tools:::config_val_to_logical(defaults)) { |
| .aspell_package_defaults(dir, encoding)$description |
| } else NULL |
| if(!is.null(defaults)) { |
| if(!is.null(d <- defaults$ignore)) |
| ignore <- d |
| if(!is.null(d <- defaults$control)) |
| control <- d |
| if(!is.null(d <- defaults$program)) |
| program <- d |
| if(!is.null(d <- defaults$dictionaries)) { |
| dictionaries <- |
| aspell_find_dictionaries(d, file.path(dir, ".aspell")) |
| } |
| } |
| |
| program <- aspell_find_program(program) |
| |
| aspell(files, |
| filter = list("dcf", ignore = ignore), |
| control = control, |
| encoding = encoding, |
| program = program, |
| dictionaries = dictionaries) |
| } |
| |
| ## Spell-checking Markdown files. |
| |
| aspell_filter_db$md <- |
| function(ifile, encoding = "UTF-8") |
| { |
| x <- readLines(ifile, encoding = encoding, warn = FALSE) |
| n <- nchar(x) |
| y <- strrep(rep.int(" ", length(x)), n) |
| ## Determine positions of 'texts' along the lines of |
| ## spelling::parse_text_md () by Jeroen Ooms. |
| md <- commonmark::markdown_xml(x, extensions = TRUE, |
| sourcepos = TRUE) |
| doc <- xml2::xml_ns_strip(xml2::read_xml(md)) |
| pos <- strsplit(xml2::xml_attr(xml2::xml_find_all(doc, |
| "//text[@sourcepos]"), |
| "sourcepos"), |
| "[:-]") |
| ## Now use the following idea. |
| ## Each elt of pos now has positions for l1:c1 to l2:c2. |
| ## If l1 < l2 |
| ## Lines in (l1, l2) are taken as a whole |
| ## Line l1 from c1 to nchar for l1 |
| ## Line l2 from 1 to c1 |
| ## otherwise |
| ## Line l1 from c1 to c2. |
| for(p in pos) { |
| p <- as.integer(p) |
| ## Legibility ... |
| l1 <- p[1L]; c1 <- p[2L]; l2 <- p[3L]; c2 <- p[4L] |
| if(l1 < l2) { |
| substring(y[l1], c1, n[l1]) <- substring(x[l1], c1, n[l1]) |
| if(l1 + 1L < l2) { |
| w <- seq.int(from = l1 + 1L, to = l2 - 1L) |
| y[w] <- x[w] |
| } |
| substring(y[l2], 1L, c2) <- substring(x[l2], 1L, c2) |
| } else { |
| substring(y[l1], c1, c2) <- substring(x[l1], c1, c2) |
| } |
| } |
| y |
| } |
| |
| ## For spell checking packages. |
| |
| aspell_package <- |
| function(dir, |
| control = list(), program = NULL, dictionaries = character()) |
| { |
| args <- list(dir = dir, |
| program = program, |
| control = control, |
| dictionaries = dictionaries) |
| a <- rbind(do.call(aspell_package_description, args), |
| do.call(aspell_package_Rd_files, args), |
| do.call(aspell_package_vignettes, args), |
| do.call(aspell_package_R_files, args), |
| do.call(aspell_package_C_files, args)) |
| if(nrow(a)) { |
| a$File <- tools:::.file_path_relative_to_dir(a$File, |
| dirname(dir)) |
| } |
| a |
| } |
| |
| ## For writing personal dictionaries: |
| |
| aspell_write_personal_dictionary_file <- |
| function(x, out, language = "en", program = NULL) |
| { |
| if(inherits(x, "aspell")) |
| x <- sort(unique(x$Original)) |
| |
| program <- aspell_find_program(program) |
| if(is.na(program)) |
| stop("No suitable spell check program found.") |
| |
| ## <NOTE> |
| ## Ispell and Hunspell take simple word lists as personal dictionary |
| ## files, but Aspell requires a special format, see e.g. |
| ## http://aspell.net/man-html/Format-of-the-Personal-and-Replacement-Dictionaries.html |
| ## and one has to create these by hand, as |
| ## aspell --lang=en create personal ./foo "a b c" |
| ## gives: Sorry "create/merge personal" is currently unimplemented. |
| |
| ## Encodings are a nightmare. |
| ## Try to canonicalize to UTF-8 for Aspell (which allows recording |
| ## the encoding in the personal dictionary). |
| ## <FIXME> |
| ## What should we do for Hunspell (which can handle UTF-8, but has |
| ## no encoding information in the personal dictionary), or Ispell |
| ## (which cannot handle UTF-8)? |
| ## </FIXME> |
| |
| if(names(program) == "aspell") { |
| header <- sprintf("personal_ws-1.1 %s %d UTF-8", |
| language, length(x)) |
| x <- enc2utf8(x) |
| } |
| else { |
| header <- NULL |
| } |
| |
| writeLines(c(header, x), out, useBytes = TRUE) |
| } |
| |
| ## For reading package defaults: |
| |
| .aspell_package_defaults <- |
| function(dir, encoding = "unknown") |
| { |
| dfile <- file.path(dir, ".aspell", "defaults.R") |
| if(!file_test("-f", dfile)) |
| return(NULL) |
| exprs <- parse(dfile, encoding = encoding) |
| envir <- new.env() |
| for(e in exprs) eval(e, envir) |
| as.list(envir) |
| } |
| |
| ## Utilities. |
| |
| blank_out_regexp_matches <- |
| function(s, re, ...) |
| { |
| m <- gregexpr(re, s, ...) |
| regmatches(s, m) <- |
| Map(function(n) strrep(" ", n), |
| lapply(regmatches(s, m), nchar)) |
| s |
| } |
| |
| blank_out_ignores_in_lines <- |
| function(lines, ignore) |
| { |
| args <- list() |
| if(is.list(ignore)) { |
| args <- ignore[-1L] |
| ignore <- ignore[[1L]] |
| } |
| for(re in ignore[nzchar(ignore)]) |
| lines <- do.call(blank_out_regexp_matches, |
| c(list(lines, re), args)) |
| lines |
| } |
| |
| find_files_in_directories <- |
| function(basenames, dirnames) |
| { |
| dirnames <- dirnames[dir.exists(dirnames)] |
| dirnames <- normalizePath(dirnames, "/") |
| |
| out <- character(length(basenames)) |
| pos <- seq_along(out) |
| |
| for(dir in dirnames) { |
| paths <- file.path(dir, basenames[pos]) |
| ind <- file_test("-f", paths) |
| out[pos[ind]] <- paths[ind] |
| pos <- pos[!ind] |
| if(!length(pos)) break |
| } |
| |
| out |
| } |
