h5Variant: HDF5 infrastructure for Variant data

#' initialize h5Variant
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @keywords internal

setMethod("initialize", "h5Variant",
    function(.Object, h5_location, map_location = NULL,
        overwrite, type = c("RLE", "sparse", "uncompress"),  ...) {

        type <- match.arg(type)
        
        h5_location <- normalizePath(h5_location, mustWork = TRUE)

        if(is.null(map_location))
            map_location <- gsub("\\.h5$", ".bed", h5_location)

        map_location <- normalizePath(map_location, mustWork = TRUE)

        for(x in c(h5_location, map_location)) {
            if(!file.exists(x)) {
                stop(paste0("File ", x, " not found\n"))
            }
        }

        .Object@h5_location <- h5_location
        .Object@map_location <- map_location

        x <- rhdf5::h5ls(h5_location)
        groups <- x[x$group == "/", -c(1,3,4) ]
        n_chunk <- nrow(x[x$otype == "H5I_GROUP", ]) - 1
         groups[2,2] <- n_chunk
         .Object@dimension$blocksize <- h5readAttributes(h5_location, "blocksize")
         .Object@dimension$chunsize <- h5readAttributes(h5_location, "chunksize")
        .Object@dimension$rownames <- as.integer(groups[groups$name == "rownames", 2])
        .Object@dimension$colnames <- as.integer(groups[groups$name == "colnames", 2])
        .Object@dimension$seqnames <- as.integer(groups[groups$name == "seqnames", 2])
        .Object@dimension$seqnames <- as.integer(groups[groups$name == "seqnames", 2])
        .Object@dimension$seqlevels <- as.integer(groups[groups$name == "seqlevels", 2])
        .Object@dimension$map <- c(.Object@dimension$rownames,
            as.integer(gsub("x|\\s", " ",groups[groups$name == "map", 2])))
        .Object@dimension$data <- c(.Object@dimension$rownames, .Object@dimension$colnames)
        .Object@type <- type
        .Object
})

#' show
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases show,h5Variant-method
#' @exportMethod show

setMethod("show", "h5Variant",
    function(object) {

        greentext <- crayon::green
        line <- greentext(paste0(clisymbols::symbol$line,
                                 clisymbols::symbol$line))
        arrow <-  greentext(clisymbols::symbol$arrow_right)
        vline <-  greentext("|")
        redtext <- crayon::red

        data_dim <- paste0(redtext(object@dimension$data[1]), " x ",
                                 redtext(object@dimension$data[2]))
        map_dim <- paste0(redtext(object@dimension$map[1]), " x ",
                                redtext(object@dimension$map[2]))
        rownames_dim <- redtext(object@dimension$rownames)
        colnames_dim <- redtext(object@dimension$colnames)
        seqnames_dim <- redtext(object@dimension$seqnames)
        seqlevels_dim <- redtext(object@dimension$seqlevels)


        cat(greentext("\nROOT\n"),
            vline, "\n ")
            if(object@type == "RLE") {
            cat(vline, line, "data ",arrow , data_dim, arrow, " RLE chunks \n",
            vline,"                             ",vline, line, " value  ", arrow,
            rownames_dim, "\n",
            vline,"                             ",vline,  line, " length ", arrow,
            rownames_dim, "\n ")
            } else {
            cat(vline, line, "data ",arrow , data_dim, arrow, " sparse chunks \n",
            vline,"                             ",vline, line, " x  ", arrow,
            rownames_dim, "\n",
            vline,"                             ",vline,  line, " i ", arrow,
            rownames_dim, "\n",
            vline,"                             ",vline, line, " p  ", arrow,
            rownames_dim, "\n",
            vline,"                             ",vline,  line, " codes ", arrow,
            rownames_dim, "\n ")
            }
            cat(vline, "\n",
            vline, line, "rownames ", arrow, rownames_dim, "\n",
            vline, "\n",
            vline, line, "colnames ", arrow, colnames_dim,  "\n",
            vline, "\n",
            vline, line, "seqnames ", arrow, seqnames_dim,  "\n",
            vline, "\n",
            vline, line, "seqlevels ", arrow, seqlevels_dim,  "\n",
            vline, "\n",
            vline, line,  "map ", arrow, map_dim,   "\n\n")
})

#' nrow
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases nrow,h5Variant-method
#' @export

setMethod("nrow", "h5Variant", function(x) {
    x@dimension$data[1]
})


#' colnames
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases colnames,h5Variant-method
#' @exportMethod colnames

setMethod("colnames", "h5Variant", function(x) {
    rhdf5::h5read(x@h5_location, "/colnames")
})


#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases rownames,h5Variant-method
#' @exportMethod rownames

setMethod("rownames", "h5Variant", function(x) {
    rhdf5::h5read(x@h5_location, "/rownames")
})

#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases seqnames,h5Variant-method
#' @exportMethod seqnames

setMethod("seqnames", "h5Variant", function(x) {
    h5read(x@h5_location, "/seqnames")
})

#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases seqlevels,h5Variant-method
#' @exportMethod seqlevels

setMethod("seqlevels", "h5Variant", function(x) {
    rhdf5::h5read(x@h5_location, "/seqlevels")
})

#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases ranges,h5Variant-method
#' @exportMethod ranges
setMethod("ranges", "h5Variant", function(x) {
    coordinates <- rhdf5::h5read(x@h5_location, "/map",
        index = list(seq_len(nrow(x)), 1:2))
        IRanges::IRanges(start = coordinates[, 1])
})


#' ncol
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases ncol,h5Variant-method
#' @exportMethod ncol

setMethod("ncol", "h5Variant", function(x) {
    x@dimension$data[2]
})


#' [
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases [,h5Variant,numericORmissing,character,ANY-method

setMethod("[", c("h5Variant", "numericORmissing", "characterORmissing", "ANY"),

    function(x, i, j, ..., drop = FALSE) {

        if(missing(j))  return(new("Rle"))

        if(j != "r" && j != "b" & j != "m") {
            stop("j must be 'r' (row), 'b' (block RleArray) or 'm' (block matrix)")
        }
        # empty i, return x
        if(missing(i) || length(i) == 0 || i == 0 || missing(j)) {
            return(new("Rle"))
        } else{
            if(j == "r") {
                h5v_get_row(x, i)
            } else if(j == "b") {
                h5v_get_block(x, i)
            }else if(j == "m") {
                h5v_get_block_matrix(x, i)
            }
        }
})


#' [
#' @author Leandro Roser \email{learoser@@gmail.com}
#' @rdname h5Variant-methods
#' @aliases [,h5Variant,numericORmissing,character,ANY-method

setMethod("[", c("h5Variant", "missing", "numericORmissing", "characterORmissing"),
    
    function(x, i, j, k, drop = FALSE) {
        
        if(missing(k))  return(matrix(nrow = 0, ncol = 0))
        
        if(k != "bs" && j != "re" && j != "me"  && j != "rle") {
            stop("j must be 'bs' (binary search),
                're' (row expansion), 'me' (matrix expansion) 
                or 'rle (Rle expansion)")
        }
        # empty i, return x
        if(missing(j) || length(j) == 0 || j == 0 || missing(j)) {
            return(new("Rle"))
        } else{
            if(j == "bs") {
                h5v_get_column_binary_search(x, i)
            } else if(j == "re") {
                h5v_get_column_row_expansion(x, i)
            } else if(j == "me") {
                h5v_get_column_matrix_expansion(x, i)
            } else if(j == "rle") {
                h5v_get_column_matrix_expansion(x, i)
            }
        }
    })

#
# region_to_position <- function(file, ranges_object) {
# x <- scan_tabix(file, ranges_object)[, 3]
# }
#
# #fl <- system.file("extdata", "example.gtf.gz", package="Rsamtools",
# mustWork=TRUE)
# tbx <- TabixFile(fl)
#
# param <- GRanges(c("chr1", "chr2"), IRanges(c(1, 1), width=100000))
# countTabix(tbx)
# countTabix(tbx, param=param)
# res <- scanTabix(tbx, param=param)
# sapply(res, length)
# res[["chr1:1-100000"]][1:2]
#
# ## parse to list of data.frame's
# dff <- Map(function(elt) {
#     read.csv(textConnection(elt), sep="\t", header=FALSE)
# }, res)
# dff[["chr1:1-100000"]][1:5,1:8]
#
# ## parse 100 records at a time
# length(scanTabix(tbx)[[1]]) # total number of records
# tbx <- open(TabixFile(fl, yieldSize=100))
# while(length(res <- scanTabix(tbx)[[1]]))
#     cat("records read:", length(res), "\n")
# close(tbx)