R/utils.R

In naryn: Native Access Medical Record Retriever for High Yield Analytics

.emr_call <- function(...) {
    tryCatch(
        {
            res <- .Call(...)
        },
        interrupt = function(interrupt) {
            stop("Command interrupted!", call. = FALSE)
        }
    )
    res
}

.emr_env <- function() {
    e <- new.env(parent = parent.frame(2))
    assign(".naryn", .naryn, envir = e)
    return(e)
}

.emr_checkroot <- function() {
    if (!exists("EMR_GROOT", envir = .naryn) || is.null(get("EMR_GROOT", envir = .naryn))) {
        stop("Database root directory is not set. Please call emr_db.connect().", call. = FALSE)
    }
}

#' Get a vector of variables inside an expression
#'
#' @param expr string with a naryn expression
#'
#' @return vector of the variables inside an expression
#'
#' @examples
#' .emr_expr_vars("a + b")
#'
#' @keywords internal
#' @export
.emr_expr_vars <- function(expr) {
    res <- c()

    if (!is.null(expr) && expr != "") {
        res <- all.vars(as.list(parse(text = expr))[[1]])
    }
    return(res)
}

.emr_getOption <- function(x, default = NULL) {
    if (missing(default)) {
        return(options(x)[[1L]])
    }
    if (x %in% names(options())) {
        options(x)[[1L]]
    } else {
        default
    }
}

is_ascii_character <- function(x) {
    !is.na(x) & !is.na(iconv(x, "ASCII", "ASCII"))
}

#' Create a syntactically valid variable name from a string
#'
#' Spaces are replaced with '_' and other non valid characters are encoded as '.' + two bit
#' hexadecimal representation.
#' Variables which start with an underscore or a dot are prepended with the letter 'X'.
#' The result is sent to \code{make.names} in order to deal with reserved words.
#'
#' Note that strings starting with 'X.' would not be translated back correctly using \code{var_to_string},
#' i.e. \code{string_to_var(var_to_string("X.saba"))} would result ".saba".
#'
#' @param str string
#'
#' @return a syntactically valid variable name
#'
#' @examples
#' string_to_var("a & b")
#' string_to_var("saba and savta")
#' string_to_var("/home/mydir")
#' string_to_var("www.google.com")
#' string_to_var("my_variable + 3")
#' string_to_var(".hidden variable")
#' string_to_var("NULL")
#'
#' @export
string_to_var <- function(str) {
    if (any(grepl("X\\.", str))) {
        warning("String starting with 'X.' would not be translated back correctly using 'var_to_string'")
    }
    ok_chars <- paste0("[^", "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz0123456789", "]")
    s <- strsplit(str, "")[[1]]
    bad_chars <- grep(ok_chars, s)
    if (length(bad_chars)) {
        replacement <- vapply(s[bad_chars], function(x) {
            if (x == " ") {
                return("_")
            } else {
                return(
                    paste0(
                        ".",
                        toupper(as.character(charToRaw(x))),
                        collapse = ""
                    )
                )
            }
        }, "")
        s[bad_chars] <- replacement
    }
    if (s[1] == "." || s[1] == "_") { # do not allow hidden variables or variables starting with '_'
        s <- c("X", s)
    }
    var <- paste(s, collapse = "")
    var <- make.names(var) # deal with reserved words
    return(var)
}

#' Decode a variable created by string_to_var
#'
#' Convert a variable created by \code{string_to_var} back to the original string.
#'
#' @param str string which was generated by \code{string_to_var}
#'
#' @return the original string
#'
#' @examples
#' var_to_string(string_to_var("a & b"))
#' var_to_string(string_to_var("saba and savta"))
#' var_to_string(string_to_var("/home/mydir"))
#' var_to_string(string_to_var("www.google.com"))
#' var_to_string(string_to_var("my_variable + 3"))
#' var_to_string(string_to_var(".hidden variable"))
#' var_to_string(string_to_var("NULL"))
#'
#' @export
var_to_string <- function(str) {
    str <- sub("^X\\.", ".", str)
    x <- charToRaw(str)
    dot <- charToRaw(".")
    underscore <- charToRaw("_")
    space <- charToRaw(" ")
    out <- raw(0)
    i <- 1
    while (i <= length(x)) {
        if (x[i] == underscore) {
            out <- c(out, space)
            i <- i + 1
        } else if (x[i] == dot) {
            if (i == length(x)) { # we have a dot as the last character
                i <- i + 1
                break
            }
            y <- as.integer(x[i + 1:2])
            y[y > 96] <- y[y > 96] - 32
            y[y > 57] <- y[y > 57] - 7
            y <- sum((y - 48) * c(16, 1))
            out <- c(out, as.raw(as.character(y)))
            i <- i + 3
        } else {
            out <- c(out, x[i])
            i <- i + 1
        }
    }
    out <- rawToChar(out)
    return(out)
}