| # File src/library/utils/R/read.fortran.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2013 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/ |
| |
| |
| read.fortran <- function(file, format, ..., as.is = TRUE, colClasses = NA) |
| { |
| |
| processFormat <- function(format){ |
| format <- toupper(format) |
| template <- "^([0-9]*)([FXAI])([0-9]*)\\.?([0-9]*)" |
| reps <- as.numeric(sub(template,"\\1",format)) |
| types <- sub(template, "\\2", format) |
| lengths <- as.numeric(sub(template, "\\3", format)) |
| decimals <- as.numeric(sub(template, "\\4", format)) |
| |
| reps[is.na(reps)] <- 1L |
| lengths[is.na(lengths) & types=="X"] <- 1L |
| |
| charskip <- types=="X" |
| lengths[charskip] <- reps[charskip]*lengths[charskip] |
| reps[charskip] <- 1 |
| |
| if (anyNA(lengths)) |
| stop("missing lengths for some fields") |
| |
| lengths <- rep.int(lengths,reps) |
| types <- rep.int(types,reps) |
| decimals <- rep.int(decimals,reps) |
| types <- match(types, c("F","D","X","A","I")) |
| |
| if (any(!is.na(decimals) & types>2L)) |
| stop("invalid format") |
| colClasses <- c("numeric", "numeric", NA, |
| if(as.is) "character" else NA, "integer")[types] |
| colClasses <- colClasses[!(types==3L)] |
| decimals <- decimals [!(types==3L)] |
| lengths[types==3] <- -lengths[types==3L] |
| |
| list(lengths,colClasses,decimals) |
| } |
| |
| if(is.list(format)){ |
| ff <- lapply(format,processFormat) |
| widths <- lapply(ff,"[[",1L) |
| if (is.na(colClasses)) |
| colClasses <- do.call("c",lapply(ff,"[[",2L)) |
| decimals <- do.call("c",lapply(ff,"[[",3L)) |
| } else { |
| ff <- processFormat(format) |
| widths <- ff[[1L]] |
| if (is.na(colClasses)) |
| colClasses <- ff[[2L]] |
| decimals <- ff[[3L]] |
| } |
| rval <- read.fwf(file,widths=widths, ..., colClasses=colClasses) |
| for(i in which(!is.na(decimals))) |
| rval[,i] <- rval[,i]*(10^-decimals[i]) |
| rval |
| } |