R/IO.R

In gson: Base Class and Methods for 'gson' Format

#' read and write gson file
#'
#' @rdname IO
#' @param file A gson file
#'
#' @return A `GSON` instance
#' @importFrom jsonlite fromJSON
#' @importFrom stats setNames
#' @export
#'
#' @examples
#' wpfile <- system.file('extdata', "wikipathways-20220310-gmt-Homo_sapiens.gmt", package='gson')
#' x <- read.gmt.wp(wpfile, output = "GSON")
#' f = tempfile(fileext = '.gson')
#' write.gson(x, f)
#' read.gson(f)
read.gson <- function(file) {
  x <- gson_from_json(file)
  gsid2gene <- gson_membership_table(x$gsid2gene, file)
  gsid2gene <- setNames(gsid2gene[, c(2,1)], c("gsid", "gene"))

  gsid2name <- gson_name_table(x$gsid2name, "gsid2name", file)
  gene2name <- gson_name_table(x$gene2name, "gene2name", file)

  schema_version <- get_value("schema_version", x)
  if (is.null(schema_version)) {
    schema_version <- "1.0"
  }
  species <- get_value("species", x)
  gsname <- get_value("gsname", x)
  version <- get_value("version", x)
  accessed_date <- get_value("accessed_date", x)
  keytype <- get_value("keytype", x)
  gsidtype <- get_value("gsidtype", x)
  urlpattern <- get_value("urlpattern", x)
  info <- get_value("info", x)
  
  gson(gsid2gene = gsid2gene, gsid2name = gsid2name,
       gene2name = gene2name, schema_version = schema_version,
       species = species,
       gsname = gsname, version = version,
       accessed_date = accessed_date, 
       keytype = keytype,
       gsidtype = gsidtype,
       urlpattern = urlpattern,
       info = info)
}

## a gson file is written by other programs as often as by this one, so a file
## that does not hold what the format says is reported as what is missing rather
## than as whatever jsonlite happened to notice
gson_file_error <- function(file, ...) {
    stop("the gson file ", file, " ", paste0(...), call. = FALSE)
}

gson_from_json <- function(file) {
    if (is.character(file) && length(file) == 1 &&
        !grepl("^[a-zA-Z][a-zA-Z0-9+.-]*://", file) && !file.exists(file)) {
        gson_file_error(file, "does not exist")
    }
    x <- tryCatch(
        yread(file, jsonlite::fromJSON),
        error = function(e)
            gson_file_error(file, "could not be read: ", conditionMessage(e)))
    if (!is.list(x) || is.null(names(x))) {
        gson_file_error(file, "is not a gene set collection: it holds ",
                        gson_json_shape(x), ", while a gson file is an object ",
                        "with a 'gsid2gene' member, e.g. ",
                        '{"gsid2gene": {"GS1": ["101", "102"]}}')
    }
    x
}

gson_membership_table <- function(value, file) {
    if (is.null(value)) {
        gson_file_error(file, "has no 'gsid2gene' member; a gene set collection ",
                        "maps every gene set ID to its genes, e.g. ",
                        '{"gsid2gene": {"GS1": ["101", "102"]}}')
    }
    if (is.list(value) && length(value) == 0) {
        ## an object that holds no gene set is a collection with nothing in it,
        ## which is what write.gson() of an empty GSON writes out
        return(data.frame(values = character(0), ind = character(0),
                          stringsAsFactors = FALSE))
    }
    if (!is.list(value) || is.data.frame(value) ||
        is.null(names(value)) || !all(nzchar(names(value)))) {
        gson_file_error(file, "holds 'gsid2gene' as ", gson_json_shape(value),
                        ", but the memberships must be an object keyed by gene ",
                        "set ID, e.g. {\"GS1\": [\"101\", \"102\"]}")
    }
    empty <- vapply(value, function(v) is.list(v) && length(v) == 0, logical(1))
    if (any(empty)) {
        ## jsonlite reads [] as an empty list; a gene set of no genes is a set
        ## the class cannot hold, and losing it in silence would look like the
        ## file never mentioned it
        named <- names(value)[empty]
        shown <- named[seq_len(min(5, length(named)))]
        gson_file_error(file, "holds gene set ", paste0("'", shown, "'",
                          collapse = ", "), " with an empty gene list; a GSON ",
                        "cannot hold a set of no genes, and write.gson() omits ",
                        "such sets with a warning")
    }
    if (!all(vapply(value, function(v) is.atomic(v) && is.null(dim(v)),
                    logical(1)))) {
        gson_file_error(file, "holds a gene set whose genes are not a flat list ",
                        "of identifiers; every entry of 'gsid2gene' maps one ",
                        "gene set ID to an array of gene identifiers")
    }
    gsid2gene <- stack(value)
    ## a null in a gene array comes back as a gene genuinely called NA, which is
    ## the disease the write side skips such rows for; the read side skips them
    ## on the same terms
    keep <- !is.na(gsid2gene$values) & nzchar(gsid2gene$values)
    if (!all(keep)) {
        warning(sum(!keep), " membership(s) with a missing or empty gene were ",
                "omitted from 'gsid2gene'; validate_gson() reports objects ",
                "that carry them", call. = FALSE)
    }
    gsid2gene[keep, , drop = FALSE]
}

gson_name_table <- function(value, member, file) {
    if (is_empty_json_value(value)) {
        return(NULL)
    }
    if (is.data.frame(value)) {
        return(value)
    }
    if (!is.list(value)) {
        gson_file_error(file, "holds '", member, "' as ", gson_json_shape(value),
                        ", but it must be an object holding the arrays '",
                        sub("2name$", "", member), "' and 'name', e.g. ",
                        '{"gsid": ["GS1"], "name": ["cell cycle"]}')
    }
    as.data.frame(value)
}

gson_json_shape <- function(x) {
    if (is.null(x)) {
        return("nothing")
    }
    if (is.data.frame(x)) {
        return("a table")
    }
    if (is.list(x)) {
        if (is.null(names(x))) {
            return("an array")
        }
        return("an object")
    }
    if (is.matrix(x)) {
        return("a matrix")
    }
    if (is.character(x)) {
        return("a string")
    }
    if (is.logical(x)) {
        return("a true/false value")
    }
    if (is.numeric(x)) {
        return("a number")
    }
    paste0("a ", class(x)[1])
}

##' @rdname IO
##' @param x A `GSON` instance
##' @importFrom jsonlite toJSON
##' @export
write.gson <- function(x, file = "") {
  res <- jsonlite::toJSON(as.list.GSON(x), pretty = TRUE, null = "null")
  if (file == "") return(res)

  ### for UTF-8 code error
  ##res <- iconv(res, "ASCII", "UTF-8") # may return NA
  
  # for lexical error: invalid character inside string.
  res <- gsub("\\t", " ", res)
  #info <- paste0("R package: gson v=",  packageVersion("gson"), ", ", Sys.Date())
  cat(res, file = file,  sep = "\n")
}

##' @method as.list GSON
##' @export
as.list.GSON <- function(x,  ...) {
  gsid2gene <- usable_memberships(x@gsid2gene)
  ## the keys go out in the order the object holds its gene sets; split() alone
  ## sorts the IDs, and a file written in an order the collection does not have
  ## reads back as a different collection -- names(x), print() and x[1] among
  ## them
  gsid <- unique(gsid2gene$gsid)
  memberships <- split(gsid2gene$gene,
                       factor(gsid2gene$gsid, levels = gsid))
  list(
    gsid2gene = stats::setNames(memberships, gsid),
    gsid2name =  data_frame_to_list(x@gsid2name),
    gene2name = data_frame_to_list(x@gene2name),
    schema_version = x@schema_version,
    species = x@species,
    gsname = x@gsname,
    version = x@version,
    accessed_date = x@accessed_date,
    keytype = x@keytype,
    gsidtype = x@gsidtype,
    urlpattern = x@urlpattern,
    info = x@info
  )
}

data_frame_to_list <- function(x) {
  if (is.null(x)) {
    return(NULL)
  }
  as.list(x)
}

is_empty_json_value <- function(x) {
  is.null(x) || (is.list(x) && length(x) == 0)
}

get_value <- function(value, x) {
  result <- x[[value]]
  if (is_empty_json_value(result) || length(result) == 0) {
    return(NULL)
  }
  as.character(result)
}