| # File src/library/utils/R/edit.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/ |
| |
| check_for_XQuartz <- function() |
| { |
| if (file.exists("/usr/bin/otool") && |
| file.exists(DSO <- file.path(R.home("modules"), "R_de.so"))) { |
| out <- system2("/usr/bin/otool", c("-L", shQuote(DSO)), stdout = TRUE) |
| ind <- grep("libX11[.][0-9]+[.]dylib", out) |
| if(length(ind)) { |
| this <- sub(" .*", "", sub("^\t", "", out[ind])) |
| if(!file.exists(this)) |
| stop("X11 library is missing: install XQuartz from xquartz.macosforge.org", domain = NA) |
| } |
| } |
| } |
| |
| dataentry <- function (data, modes) |
| { |
| check <- Sys.getenv("_R_CHECK_SCREEN_DEVICE_", "") |
| msg <- "dataentry() should not be used in examples etc" |
| if (identical(check, "stop")) |
| stop(msg, domain = NA) |
| else if (identical(check, "warn")) |
| warning(msg, immediate. = TRUE, noBreaks. = TRUE, domain = NA) |
| |
| if(!is.list(data) || !length(data) || !all(sapply(data, is.vector))) |
| stop("invalid 'data' argument") |
| if(!is.list(modes) || |
| (length(modes) && !all(sapply(modes, is.character)))) |
| stop("invalid 'modes' argument") |
| if (grepl("darwin", R.version$os)) check_for_XQuartz() |
| .External2(C_dataentry, data, modes) |
| } |
| |
| View <- function (x, title) |
| { |
| check <- Sys.getenv("_R_CHECK_SCREEN_DEVICE_", "") |
| msg <- "View() should not be used in examples etc" |
| if (identical(check, "stop")) |
| stop(msg, domain = NA) |
| else if (identical(check, "warn")) |
| warning(msg, immediate. = TRUE, noBreaks. = TRUE, domain = NA) |
| |
| ## could multi-line deparse with maliciously-designed inputs |
| if(missing(title)) title <- paste("Data:", deparse(substitute(x))[1]) |
| as.num.or.char <- function(x) |
| { |
| if (is.character(x)) x |
| else if (is.numeric(x)) {storage.mode(x) <- "double"; x} |
| else as.character(x) |
| } |
| x0 <- as.data.frame(x) |
| x <- as.list(format.data.frame(x0)) |
| rn <- row.names(x0) |
| if(any(rn != seq_along(rn))) x <- c(list(row.names = rn), x) |
| if(!is.list(x) || !length(x) || !all(sapply(x, is.atomic)) || |
| !max(lengths(x))) |
| stop("invalid 'x' argument") |
| if (grepl("darwin", R.version$os)) check_for_XQuartz() |
| invisible(.External2(C_dataviewer, x, title)) |
| } |
| |
| edit <- function(name,...)UseMethod("edit") |
| |
| edit.default <- |
| function (name = NULL, file = "", title = NULL, |
| editor = getOption("editor"), ...) |
| { |
| if (is.null(title)) title <- deparse(substitute(name)) |
| if (is.function(editor)) invisible(editor(name = name, file = file, title = title)) |
| else .External2(C_edit, name, file, title, editor) |
| } |
| |
| edit.data.frame <- |
| function(name, factor.mode = c("character", "numeric"), |
| edit.row.names = any(row.names(name) != 1L:nrow(name)), ...) |
| { |
| if (.Platform$OS.type == "unix" && .Platform$GUI != "AQUA") |
| if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY") == "" ) |
| return (edit.default(name, ...)) |
| |
| is.vector.unclass <- function(x) is.vector(unclass(x)) |
| if (length(name) && !all(sapply(name, is.vector.unclass) |
| | sapply(name, is.factor))) |
| stop("can only handle vector and factor elements") |
| |
| if (grepl("darwin", R.version$os)) check_for_XQuartz() |
| |
| factor.mode <- match.arg(factor.mode) |
| |
| as.num.or.char <- function(x) |
| { |
| if (is.numeric(x)) x |
| else if (is.factor(x) && factor.mode == "numeric") as.numeric(x) |
| else as.character(x) |
| } |
| |
| attrlist <- lapply(name, attributes) |
| datalist <- lapply(name, as.num.or.char) |
| factors <- if (length(name)) |
| which(sapply(name, is.factor)) |
| else |
| numeric() |
| |
| logicals <- if (length(name)) |
| which(sapply(name, is.logical)) |
| else |
| numeric() |
| |
| if(length(name)) { |
| has_class <- |
| sapply(name, function(x) (is.object(x) || isS4(x)) && !is.factor(x)) |
| if(any(has_class)) |
| warning(sprintf(ngettext(sum(has_class), |
| "class discarded from column %s", |
| "classes discarded from columns %s"), |
| paste(sQuote(names(name)[has_class]), |
| collapse=", ")), |
| domain = NA, call. = FALSE, immediate. = TRUE) |
| } |
| |
| modes <- lapply(datalist, mode) |
| if (edit.row.names) { |
| datalist <- c(list(row.names = row.names(name)), datalist) |
| modes <- c(list(row.names = "character"), modes) |
| } |
| rn <- attr(name, "row.names") |
| |
| out <- .External2(C_dataentry, datalist, modes) |
| if(length(out) == 0L) { |
| ## e.g. started with 0-col data frame or NULL, and created no cols |
| return (name) |
| } |
| lengths <- lengths(out) |
| maxlength <- max(lengths) |
| if (edit.row.names) rn <- out[[1L]] |
| for (i in which(lengths != maxlength)) |
| out[[i]] <- c(out[[i]], rep.int(NA, maxlength - lengths[i])) |
| if (edit.row.names) { |
| out <- out[-1L] |
| if((ln <- length(rn)) < maxlength) |
| rn <- c(rn, paste0("row", (ln+1):maxlength)) |
| } else if(length(rn) != maxlength) rn <- seq_len(maxlength) |
| for (i in factors) { |
| if(factor.mode != mode(out[[i]])) next # user might have switched mode |
| a <- attrlist[[i]] |
| if (factor.mode == "numeric") { |
| o <- as.integer(out[[i]]) |
| ok <- is.na(o) | (o > 0 & o <= length(a$levels)) |
| if (any(!ok)) { |
| warning(gettextf("invalid factor levels in '%s'", names(out)[i]), |
| domain = NA) |
| o[!ok] <- NA |
| } |
| attributes(o) <- a |
| } else { |
| o <- out[[i]] |
| if (any(new <- is.na(match(o, c(a$levels, NA_integer_))))) { |
| new <- unique(o[new]) |
| warning(gettextf("added factor levels in '%s'", names(out)[i]), |
| domain = NA) |
| o <- factor(o, levels=c(a$levels, new), |
| ordered = is.ordered(o)) |
| } else { |
| o <- match(o, a$levels) |
| attributes(o) <- a |
| } |
| } |
| out[[i]] <- o |
| } |
| for (i in logicals) out[[i]] <- as.logical(out[[i]]) |
| |
| attr(out, "row.names") <- rn |
| attr(out, "class") <- "data.frame" |
| if (edit.row.names) { |
| if(anyDuplicated(rn)) { |
| warning("edited row names contain duplicates and will be ignored") |
| attr(out, "row.names") <- seq_len(maxlength) |
| } |
| } |
| out |
| } |
| |
| edit.matrix <- |
| function(name, edit.row.names = !is.null(dn[[1L]]), ...) |
| { |
| if (.Platform$OS.type == "unix" && .Platform$GUI != "AQUA") |
| if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY")=="" ) |
| return (edit.default(name, ...)) |
| if(!is.matrix(name) || |
| ! mode(name) %in% c("numeric", "character", "logical") || |
| any(dim(name) < 1)) |
| stop("invalid input matrix") |
| |
| if (grepl("darwin", R.version$os)) check_for_XQuartz() |
| |
| ## logical matrices will be edited as character |
| logicals <- is.logical(name) |
| if (logicals) mode(name) <- "character" |
| if(is.object(name) || isS4(name)) |
| warning("class of 'name' will be discarded", |
| call. = FALSE, immediate. = TRUE) |
| |
| dn <- dimnames(name) |
| ## <FIXME split.matrix> |
| datalist <- split(c(name), col(name)) |
| if(!is.null(dn[[2L]])) names(datalist) <- dn[[2L]] |
| else names(datalist) <- paste0("col", 1L:ncol(name)) |
| modes <- as.list(rep.int(mode(name), ncol(name))) |
| ## guard aginst user error (PR#10500) |
| if(edit.row.names && is.null(dn[[1L]])) |
| stop("cannot edit NULL row names") |
| if (edit.row.names) { |
| datalist <- c(list(row.names = dn[[1L]]), datalist) |
| modes <- c(list(row.names = "character"), modes) |
| } |
| |
| out <- .External2(C_dataentry, datalist, modes) |
| |
| lengths <- lengths(out) |
| maxlength <- max(lengths) |
| if (edit.row.names) rn <- out[[1L]] |
| for (i in which(lengths != maxlength)) |
| out[[i]] <- c(out[[i]], rep.int(NA, maxlength - lengths[i])) |
| if (edit.row.names) { |
| out <- out[-1L] |
| if((ln <- length(rn)) < maxlength) |
| rn <- c(rn, paste0("row", (ln+1L):maxlength)) |
| } |
| out <- do.call("cbind", out) |
| if (edit.row.names) |
| rownames(out) <- rn |
| else if(!is.null(dn[[1L]]) && length(dn[[1L]]) == maxlength) |
| rownames(out) <- dn[[1L]] |
| if (logicals) mode(out) <- "logical" |
| out |
| } |
| |
| file.edit <- |
| function (..., title = file, editor = getOption("editor"), fileEncoding = "") |
| { |
| file <- path.expand(c(...)) |
| title <- rep_len(as.character(title), length(file)) |
| if(nzchar(fileEncoding) && fileEncoding != "native.enc") { |
| tfile <- file |
| for(i in seq_along(file)) { |
| ## We won't know when that is done with |
| ## so leave around for the R session. |
| tfile <- tempfile() |
| con <- file(file[i], encoding = fileEncoding) |
| writeLines(readLines(con), tfile) |
| close(con) |
| file[i] <- tfile |
| } |
| } |
| if (is.function(editor)) invisible(editor(file = file, title = title)) |
| else invisible(.External2(C_fileedit, file, title, editor)) |
| } |
| |
| vi <- function(name = NULL, file = "") |
| edit.default(name, file, editor = "vi") |
| |
| emacs <- function(name = NULL, file = "") |
| edit.default(name, file, editor = "emacs") |
| |
| xemacs <- function(name = NULL, file = "") |
| edit.default(name, file, editor = "xemacs") |
| |
| xedit <- function(name = NULL, file = "") |
| edit.default(name, file, editor = "xedit") |
| |
| pico <- function(name = NULL, file = "") |
| edit.default(name, file, editor = "pico") |
| |
