R/read_ods.R

In readODS: Read and Write ODS Files

#' Determine whether to show progress bar
#'
#' By default, readODS displays a progress bar unless one of the following is TRUE:
#' - The progress is explicitly disabled by setting options(readODS.show_progress = FALSE).
#' - The code is run in a non-interactive session (interactive() is FALSE).
#' - The code is run by knitr / rmarkdown.
#'
#' @return logical indicating whether to show progress
#' @export
readODS_progress <- function() {
    # Check if explicitly disabled
    if (isFALSE(getOption("readODS.show_progress", TRUE))) {
        return(FALSE)
    }

    # Don't show in non-interactive sessions
    # make mockable (see utils.R)
    if (!.is_interactive()) {
        return(FALSE)
    }

    # Don't show when knitting
    if (isTRUE(getOption("knitr.in.progress", FALSE))) {
        return(FALSE)
    }

    # Don't show in RStudio notebook chunks
    if (Sys.getenv("RSTUDIO_NOTEBOOK") != "") {
        return(FALSE)
    }

    return(TRUE)
}

.create_progress_bar <- function(progress, total_work = 100) {
    if (!isTRUE(progress)) {
        # Return a no-op progress bar with zero overhead
        noop <- function(...) invisible(NULL)
        return(list(tick = noop, terminate = noop, update = noop))
    }

    # Efficient progress bar with minimal overhead
    start_time <- Sys.time()
    current_progress <- 0L
    last_displayed_percent <- -1L

    list(
        tick = function() {
            current_progress <<- current_progress + 1L
            percent <- as.integer((current_progress / total_work) * 100)
            if (percent != last_displayed_percent && (percent %% 10L == 0L || percent >= 100L)) {
                last_displayed_percent <<- percent
                .update_progress_display(current_progress, total_work, start_time)
            }
        },
        terminate = function() {
            if (current_progress > 0L) {
                .update_progress_display(total_work, total_work, start_time)
                cat("
")
            }
        },
        update = function(current = NULL) {
            if (!is.null(current)) {
                current_progress <<- as.integer(current)
                percent <- as.integer((current_progress / total_work) * 100)
                if (percent != last_displayed_percent) {
                    last_displayed_percent <<- percent
                    .update_progress_display(current_progress, total_work, start_time)
                }
            }
        }
    )
}

.update_progress_display <- function(current, total, start_time) {
    percent <- min(100L, as.integer((current / total) * 100))
    bar_width <- 50L
    filled_width <- as.integer((percent / 100) * bar_width)

    # Pre-allocate strings for efficiency
    equals <- strrep("=", filled_width)
    spaces <- strrep(" ", bar_width - filled_width)

    elapsed <- as.numeric(difftime(Sys.time(), start_time, units = "secs"))
    if (elapsed > 0 && current > 0) {
        rate <- current / elapsed
        if (rate > 0) {
            eta <- (total - current) / rate
            eta_str <- if (eta < 60) {
                sprintf("ETA: %ds", round(eta))
            } else {
                sprintf("ETA: %dm", round(eta / 60))
            }
        } else {
            eta_str <- ""
        }
    } else {
        eta_str <- ""
    }

    # Construct progress bar display
    bar <- sprintf("[%s%s]", equals, spaces)

    # Use carriage return to overwrite the same line
    cat(sprintf("\r%s %3d%% %s", bar, percent, eta_str))
    flush.console()
}

.return_zerorow <- function(x, row_header, .name_repair) {
    jcol <- ifelse(row_header, 2, 1)
    col_n <- vctrs::vec_as_names(as.character(x[1,jcol:ncol(x)]), repair = .name_repair)
    g <- data.frame(matrix(data = NA_character_, ncol = length(col_n), nrow = 0))
    colnames(g) <- col_n
    return(g)
}

.change_df_with_col_row_header <- function(x, col_header, row_header, .name_repair) {
    if (nrow(x) == 1 && col_header && isFALSE(getOption("readODS.v200", FALSE))) {
        return(.return_zerorow(x, row_header, .name_repair))
    }
    if (((nrow(x) < 2 && col_header ) || (ncol(x) < 2 && row_header)) &&
        isTRUE(getOption("readODS.v200", FALSE))) {
        ## 2.0.0 behavior
        warning("Cannot make column/row names if this would cause the dataframe to be empty.", call. = FALSE)
        return(x)
    }
    irow <- ifelse(col_header, 2, 1)
    jcol <- ifelse(row_header, 2, 1)

    g <- x[irow:nrow(x), jcol:ncol(x), drop = FALSE] # maintain as dataframe for single column


    rownames(g) <- if(row_header) x[seq(irow, nrow(x)), 1] else NULL # don't want character row headers given by 1:nrow(g)
    cols <- ncol(x)
    if (row_header) {
        cols <- cols - 1
    }
    col_n <- if(col_header) x[1, seq(jcol, ncol(x))] else c(rep("", cols))
    colnames(g) <- vctrs::vec_as_names(unlist(col_n), repair = .name_repair)
    return(g)
}

## Based on readxl, although the implementation is different.
## If max row is -1, read to end of row.
## Row and column-numbers are 1-based
.standardise_limits <- function(range, skip, n_max) {
    if(is.null(range)) {
        skip <- check_nonnegative_integer(x = skip, argument = "skip")
        n_max <- check_nonnegative_integer(x = n_max, argument = "n_max")
        if (n_max == Inf) {
            max_row <- -1
        } else {
            max_row <- n_max + 1
        }
        return(c(min_row = skip + 1, max_row = max_row, min_col = 1, max_col = -1))
    }
    if(skip != 0 || n_max != Inf) {
        warning("Range and non-default value for skip or n_max given. Defaulting to range.", call. = FALSE)
    }
    tryCatch({
        limits <- cellranger::as.cell_limits(range)
    }, error = function(e) {
        stop("Invalid `range`")
    })
    return(c(min_row = limits[["ul"]][1],
             max_row = limits[["lr"]][1],
             min_col = limits[["ul"]][2],
             max_col = limits[["lr"]][2]
    ))
}

.convert_strings_to_factors <- function(df) {
    i <- vapply(df, is.character, logical(1))
    df[i] <- lapply(df[i], as.factor)
    return(df)
}

.check_read_args <- function(path,
                        sheet = 1,
                        col_names = TRUE,
                        col_types = NULL,
                        na = "",
                        skip = 0,
                        formula_as_formula = FALSE,
                        range = NULL,
                        row_names = FALSE,
                        strings_as_factors = FALSE,
                        verbose = FALSE,
                        as_tibble = TRUE,
                        trim_ws = TRUE,
                        n_max = Inf,
                        guess_max = min(1000, n_max),
                        progress = readODS_progress()) {
    if (!file.exists(path)) {
        stop("file does not exist", call. = FALSE)
    }
    if (!is.logical(col_names)) {
        stop("col_names must be of type `boolean`", call. = FALSE)
    }
    if (!is.logical(formula_as_formula)) {
        stop("formula_as_formula must be of type `boolean`", call. = FALSE)
    }
    if (!is.logical(row_names)) {
        stop("row_names must be of type `boolean`", call. = FALSE)
    }
    if (!is.logical(strings_as_factors)) {
        stop("strings_as_factors must be of type `boolean`", call. = FALSE)
    }
    if (!is.logical(verbose)) {
        stop("verbose must be of type `boolean`", call. = FALSE)
    }
    if (!is.logical(as_tibble)) {
        stop("as_tibble must be of type `boolean", call. = FALSE)
    }
    if (!is.logical(trim_ws)) {
        stop("trim_ws must be of type `boolean", call. = FALSE)
    }
    if (row_names && as_tibble) {
        stop("Tibbles do not support row names. To use row names, set as_tibble to false", call. = FALSE)
    }
    if (!inherits(col_types, "col_spec") &&
        isFALSE(is.na(col_types)) &&
        isFALSE(is.null(col_types)) &&
        isFALSE(is.character(col_types)) &&
        isFALSE(is.list(col_types))) {
        stop("Unknown col_types. Can either be a class col_spec, list, character, NULL or NA.",
             call. = FALSE)
    }
    if (!is.numeric(n_max)) {
        stop("n_max must be numeric.", call. = FALSE)
    }
    if (!is.numeric(guess_max)) {
        stop("guess_max must be numeric.", call. = FALSE)
    }
    if (!is.logical(progress)) {
        stop("progress must be of type `boolean`", call. = FALSE)
    }
}

.return_empty <- function(as_tibble = FALSE) {
    if (getOption("readODS.v200", FALSE)) {
        warning("empty sheet, return empty data frame.", call. = FALSE)
    }
    if (as_tibble) {
        return(tibble::tibble())
    }
    return(data.frame())
}

.handle_col_types <- function(res, col_types, verbose, na, trim_ws, guess_max = NA) {
    if (isTRUE(is.na(col_types)) || nrow(res) == 0) {
        return(res)
    }
    minty::type_convert(df = res, col_types = col_types, verbose = verbose, na = na, trim_ws = trim_ws, guess_max = guess_max)
}

## standardise `sheet` parameter as a number, i.e. sheet_index
.standardise_sheet <- function(sheet, sheet_names, range) {
    sheet_from_range <- cellranger::as.cell_limits(range)[["sheet"]]
    if (!is.null(range) && !is.na(sheet_from_range)) {
        if (sheet != 1) {
            warning("Sheet suggested in range and using sheet argument. Defaulting to range",
                    call. = FALSE)
        }
        sheet <- sheet_from_range ## override; should be a sheet_name
    }
    is_in_sheet_names <- stringi::stri_cmp(e1 = sheet, e2 = sheet_names) == 0
    if (!is.numeric(sheet) && !any(is_in_sheet_names)) {
        stop(paste0("No sheet found with name '", sheet, "'", sep = ""),
             call. = FALSE)
    }
    if (is.numeric(sheet) && sheet > length(sheet_names)) {
        stop(paste0("File contains only ", length(sheet_names), " sheets. Sheet index out of range.",
                    call. = FALSE))
    }
    if (!is.numeric(sheet)) {
        sheet_index <- which(is_in_sheet_names)
    } else {
        sheet_index <- sheet
    }
    return(sheet_index)
}

.read_ods <- function(path,
                      sheet = 1,
                      col_names = TRUE,
                      col_types = NULL,
                      na = "",
                      skip = 0,
                      formula_as_formula = FALSE,
                      range = NULL,
                      row_names = FALSE,
                      strings_as_factors = FALSE,
                      verbose = FALSE,
                      as_tibble = TRUE,
                      .name_repair = "unique",
                      flat = FALSE,
                      trim_ws = TRUE,
                      n_max = Inf,
                      guess_max = min(1000, n_max),
                      progress = readODS_progress()) {
    .check_read_args(path,
        sheet,
        col_names,
        col_types,
        na,
        skip,
        formula_as_formula,
        range,
        row_names,
        strings_as_factors,
        verbose,
        as_tibble,
        trim_ws,
        n_max,
        guess_max,
        progress)
    path <- normalizePath(path)

    # Initialize progress bar
    pb <- .create_progress_bar(progress, total_work = 5)

    if (flat) {
        .get_sheet_names_func <- get_flat_sheet_names_
        .read_ods_func <- read_flat_ods_
    } else {
        .get_sheet_names_func <- get_sheet_names_
        .read_ods_func <- read_ods_
    }

    pb$tick() # Step 1: Setup complete
    ## Get cell range info
    limits <- .standardise_limits(range, skip, n_max)
    pb$tick() # Step 2: Range calculated

    sheet_index <- .standardise_sheet(sheet = sheet, sheet_names = .get_sheet_names_func(file = path, include_external_data = TRUE),
                                      range = range)
    pb$tick() # Step 3: Sheet identified

    strings <- .read_ods_func(file = path,
                              start_row = limits["min_row"],
                              stop_row = limits["max_row"],
                              start_col = limits["min_col"],
                              stop_col = limits["max_col"],
                              sheet_index = sheet_index,
                              formula_as_formula = formula_as_formula)
    pb$tick() # Step 4: Raw data read

    if (((strings[1] == 0 || strings[2] == 0)) &&
        isTRUE(getOption("readODS.v200", FALSE))) {
        pb$terminate()
        return(.return_empty(as_tibble = as_tibble))
    }
    if (((strings[1] == 0 || strings[2] == 0) || (strings[1] == 1 && row_names)) &&
        isFALSE(getOption("readODS.v200", FALSE))) {
        pb$terminate()
        return(.return_empty(as_tibble = as_tibble))
    }
    res <- as.data.frame(
        matrix(
            strings[-1:-2],
            ncol = strtoi(strings[1]),
            byrow = TRUE),
        stringsAsFactors = FALSE)
    res <- .change_df_with_col_row_header(x = res, col_header = col_names, row_header = row_names, .name_repair = .name_repair)
    res <- .handle_col_types(res, col_types = col_types, verbose = verbose, na = na, trim_ws = trim_ws, guess_max = guess_max)
    if (strings_as_factors) {
        res <- .convert_strings_to_factors(df = res)
    }
    if (trim_ws && ncol(res) >= 1) {
        colnames(res) <- stringi::stri_trim_both(colnames(res))
    }
    if (as_tibble) {
        res <- tibble::as_tibble(x = res, .name_repair = .name_repair)
    }

    pb$tick() # Step 5: Data processed
    pb$terminate() # Finish progress bar

    return(res)
}

.determine_ods_format <- function(path, guess = FALSE, ods_format = "auto") {
    if (missing(path) || !is.character(path)) {
        stop("No file path was provided for the 'path' argument. Please provide a path to a file to import.", call. = FALSE)
    }
    if (ods_format != "auto") {
        return(ods_format)
    }
    ext <- tolower(tools::file_ext(path))
    formats <- c(
        ods = "ods",
        fods = "fods",
        xml = "fods"
    )
    if (!isTRUE(guess)) {
        ext <- unname(formats[ext])
        if (is.na(ext)) {
            return("ods")
        }
        return(ext)
    }
    zip_sig <- as.raw(c(
        "0x50", "0x4B", "0x03", "0x04"
    ))
    if (identical(zip_sig, readBin(path, n = 4, what = "raw"))) {
        return("ods")
    }
    return("fods")
}

#' Read Data From (F)ODS File
#'
#' read_ods is a function to read a single sheet from an (f)ods file and return a data frame. The function can be used for reading both ods and flat ods files.
#' (\code{read_fods}) is also available, which can only read flat ods files.
#'
#' @param path path to the (f)ods file.
#' @param sheet sheet to read. Either a string (the sheet name), or an integer sheet number. The default is 1.
#' @param col_names logical, indicating whether the file contains the names of the variables as its first line. Default is TRUE.
#' @param col_types Either NULL to guess from the spreadsheet or refer to [readr::type_convert()] to specify cols specification. It can also be a shorthand such as "ccf" ("character", "character", "factor"), a list, or an object created by [readr::cols()]. NA will return a data frame with all columns being "characters". Please note that it will not speed up the reading by a lot by specifying this parameter explicitly. It is more for accuracy.
#' @param na Character vector of strings to use for missing values. By default read_ods converts blank cells to missing data. It can also be set to
#' NULL, so that empty cells are treated as NA.
#' @param skip the number of lines of the data file to skip before beginning to read data. If this parameter is larger than the total number of lines in the ods file, an empty data frame is returned.
#' @param formula_as_formula logical, a switch to display formulas as formulas "SUM(A1:A3)" or as the resulting value "3"... or "8".. . Default is FALSE.
#' @param range selection of rectangle using Excel-like cell range, such as \code{range = "D12:F15"} or \code{range = "R1C12:R6C15"}. Cell range processing is handled by the [cellranger::as.cell_limits()]. If sheet name is in the range, such as \code{range = "Sheet2!A2:B7"}, this sheet name is used instead of the provided `sheet`. If `sheet` is not the default value (1), a warning is given.
#' @param row_names logical, indicating whether the file contains the names of the rows as its first column. Default is FALSE.
#' @param strings_as_factors logical, if character columns to be converted to factors. Default is FALSE.
#' @param verbose logical, if messages should be displayed. Default is FALSE.
#' @param as_tibble logical, if the output should be a tibble (as opposed to a data.frame). Default is TRUE.
#' @param .name_repair A string or function passed on as `.name_repair` to [tibble::as_tibble()]
#'  - `"minimal"`: No name repair
#'  - `"unique"` : Make sure names are unique and not empty
#'  - `"check_unique"`: Check names are unique, but do not repair
#'  - `"universal"` : Checks names are unique and valid R variables names in scope
#'  - A function to apply custom name repair.
#'
#'  Default is `"unique"`.
#'
#' @param ods_format character, must be "auto", "ods" or "fods". The default "auto" is to determine the format automatically. By default, the format is determined by file extension, unless `guess` is `FALSE`.
#' @param guess logical, If the file extension is absent or not recognized, this
#'   controls whether we attempt to guess format based on the file signature or
#'   "magic number".
#' @param trim_ws logical, should leading and trailing whitespace be trimmed?
#' @param n_max numeric, Maximum number of data rows to read. Ignored if `range` is given.
#' @param guess_max numeric, Maximum number of data rows to use for guessing column types. Defaults to min(1000, n_max).
#' @param progress logical, Display a progress bar? By default, shows a progress bar in interactive sessions unless disabled. See \code{\link{readODS_progress}} for more details.
#' @return A tibble (\code{tibble}) or data frame (\code{data.frame}) containing a representation of data in the (f)ods file.
#' @author Peter Brohan <peter.brohan+cran@@gmail.com>, Chung-hong Chan <chainsawtiney@@gmail.com>, Gerrit-Jan Schutten <phonixor@@gmail.com>
#' @examples
#' \dontrun{
#' # Read an ODS file
#' read_ods("starwars.ods")
#' # Read a specific sheet, e.g. the 2nd sheet
#' read_ods("starwars.ods", sheet = 2)
#' # Read a specific range, e.g. A1:C11
#' read_ods("starwars.ods", sheet = 2, range = "A1:C11")
#' # Read an FODS file
#' read_ods("starwars.fods")
#' # Read a specific sheet, e.g. the 2nd sheet
#' read_ods("starwars.fods", sheet = 2)
#' # Read a specific range, e.g. A1:C11
#' read_ods("starwars.fods", sheet = 2, range = "A1:C11")
#' # Give a warning and read from Sheet1 (not 2)
#' read_ods("starwars.fods", sheet = 2, range = "Sheet1!A1:C11")
#' # Specifying col_types as shorthand, the third column as factor; other by guessing
#' read_ods("starwars.ods", col_types = "??f")
#' # Specifying col_types as list
#' read_ods("starwars.ods", col_types = list(species = "f"))
#' # Using read_fods, although you don't have to
#' read_ods("starwars.fods")
#' }
#' @export
read_ods <- function(path,
                     sheet = 1,
                     col_names = TRUE,
                     col_types = NULL,
                     na = "",
                     skip = 0,
                     formula_as_formula = FALSE,
                     range = NULL,
                     row_names = FALSE,
                     strings_as_factors = FALSE,
                     verbose = FALSE,
                     as_tibble = TRUE,
                     .name_repair = "unique",
                     ods_format = c("auto", "ods", "fods"),
                     guess = FALSE,
                     trim_ws = TRUE,
                     n_max = Inf,
                     guess_max = min(1000, n_max),
                     progress = readODS_progress()) {
    ods_format <- .determine_ods_format(path = path, guess = guess, ods_format = match.arg(ods_format))
    ## Should use match.call but there's a weird bug if one of the variable names is 'file'
    .read_ods(path = path,
        sheet = sheet,
        col_names = col_names,
        col_types = col_types,
        na = na,
        skip = skip,
        formula_as_formula = formula_as_formula,
        range = range,
        row_names = row_names,
        strings_as_factors = strings_as_factors,
        verbose = verbose,
        as_tibble = as_tibble,
        .name_repair = .name_repair,
        flat = ods_format == "fods",
        trim_ws = trim_ws,
        n_max = n_max,
        guess_max = guess_max,
        progress = progress)
}

#' @rdname read_ods
#' @export
read_fods <- function(path,
                      sheet = 1,
                      col_names = TRUE,
                      col_types = NULL,
                      na = "",
                      skip = 0,
                      formula_as_formula = FALSE,
                      range = NULL,
                      row_names = FALSE,
                      strings_as_factors = FALSE,
                      verbose = FALSE,
                      as_tibble = TRUE,
                      .name_repair = "unique",
                      trim_ws = TRUE,
                      n_max = Inf,
                      guess_max = min(1000, n_max),
                      progress = readODS_progress()) {
    ## Should use match.call but there's a weird bug if one of the variable names is 'file'
    .read_ods(path = normalizePath(path, mustWork = FALSE),
              sheet = sheet,
              col_names = col_names,
              col_types = col_types,
              na = na,
              skip = skip,
              formula_as_formula = formula_as_formula,
              range = range,
              row_names = row_names,
              strings_as_factors = strings_as_factors,
              verbose = verbose,
              as_tibble = as_tibble,
              .name_repair = .name_repair,
              flat = TRUE,
              trim_ws = trim_ws,
              n_max = n_max,
              guess_max = guess_max,
              progress = progress)
}