#######################################################################
#
# Package Name: SeqArray
#
# Description:
#     Data Management of Large-scale Whole-Genome Sequence Variant Calls
#


#######################################################################

# R expressions called in C internally
.lang_eval <- list(
    new_rle = quote(new("Rle", values=values, lengths=lengths)),
    as_List = quote(as(object, "List"))
)

# Compressed Lists in IRanges
.List_IRanges_value <- list(
    logical   = LogicalList(),
    integer   = IntegerList(),
    numeric   = NumericList(),
    character = CharacterList(),
    raw       = RawList(),
    factor    = FactorList(),
    "unlistData", "partitioning", "end"
)

.onLoad <- function(lib, pkg)
{
    .Call(SEQ_Pkg_Init, .dim_name, process_count, process_index,
        process_block_count, process_block_index,
        .lang_eval, .List_IRanges_value)
    TRUE
}



#######################################################################
# Get the file name of an example
#
seqExampleFileName <- function(type=c("gds", "vcf", "KG_Phase1", "dosage"))
{
    type <- match.arg(type)
    fn <- switch(type,
        gds = "CEU_Exon.gds",
        vcf = "CEU_Exon.vcf.gz",
        KG_Phase1 = "1KG_phase1_release_v3_chr22.gds",
        dosage = "Imputed_dosages.gds"
    )
    system.file("extdata", fn, package="SeqArray")
}



#######################################################################
# Setup the parallel parameters in SeqArray
#

.release_pkg_func <- function(env)
{
    # release seqarray.parallel
    cl <- .PkgEnv$seqarray.parallel
    if (inherits(cl, "cluster"))
    {
        .PkgEnv$seqarray.parallel <- NULL
        parallel::stopCluster(cl)
    }
    # release seqarray.multicore
    cl <- .PkgEnv$seqarray.multicore
    if (inherits(cl, "cluster"))
    {
        .PkgEnv$seqarray.multicore <- NULL
        parallel::stopCluster(cl)
    }
    # return none
    invisible()
}

.reg_finalizer <- function()
{
    if (is.null(.PkgEnv$.finalizer))
    {
        .PkgEnv$.finalizer <- new.env()
        reg.finalizer(.PkgEnv$.finalizer, .release_pkg_func, onexit=TRUE)
    }
    invisible()
}

seqParallelSetup <- function(cluster=TRUE, verbose=TRUE)
{
    # check
    stopifnot(is.null(cluster) || is.logical(cluster) ||
        is.numeric(cluster) || inherits(cluster, "cluster"))
    stopifnot(is.logical(verbose), length(verbose)==1L)
    if (is.na(verbose)) verbose <- FALSE

    if (is.null(cluster) || isFALSE(cluster))
    {
        cl <- .PkgEnv$seqarray.parallel
        if (inherits(cl, "cluster"))
        {
            .PkgEnv$seqarray.parallel <- NULL
            stopCluster(cl)
            if (verbose)
                cat("Stop the computing cluster.\n")
        }
        return(invisible())
    }

    # Windows platform does not support forking, we have to setup a cluster
    if (.Platform$OS.type == "windows")
    {
        setup <- function(num.cores)
        {
            cl <- makeCluster(num.cores, outfile="")
            clusterCall(cl, function() {
                library(SeqArray, quietly=TRUE, verbose=FALSE)
                TRUE
            })
            cl
        }

        if (is.logical(cluster))
        {
            stopifnot(length(cluster) == 1L)
            if (isTRUE(cluster))
            {
                cl <- detectCores() - 1L
                if (cl <= 1L) cl <- 2L
                cluster <- setup(cl)
                if (verbose)
                {
                    cat("Enable the computing cluster with", cl,
                        "R processes.\n")
                }
            } else {
                if (verbose) cat("No computing cluster.\n")
            }
        } else if (is.numeric(cluster))
        {
            stopifnot(length(cluster) == 1L)
            if (cluster > 1L)
            {
                cl <- cluster
                cluster <- setup(cluster)
                if (verbose)
                {
                    cat("Enable the computing cluster with", cl,
                        "R processes.\n")
                }
            }
        }
    } else {
        # unix forking technique
        if (isTRUE(cluster))
        {
            n <- detectCores() - 1L
            if (n <= 1L) n <- 2L
            if (verbose)
            {
                cat("Enable the computing cluster with", n,
                    "forked R processes.\n")
            }
        } else if (is.numeric(cluster))
        {
            stopifnot(length(cluster) == 1L)
            if (cluster > 1L)
            {
                if (verbose)
                {
                    cat("Enable the computing cluster with", cluster,
                        "forked R processes.\n")
                }
            }
        }
    }

    .PkgEnv$seqarray.parallel <- cluster
    # need a finalizer when end the R session
    .reg_finalizer()
    # return
    invisible()
}


seqMulticoreSetup <- function(num=TRUE, type=c("psock", "fork"), verbose=TRUE)
{
    # check
    stopifnot(is.logical(num) || is.numeric(num), length(num)==1L)
    type <- match.arg(type)
    stopifnot(is.logical(verbose), length(verbose)==1L)

    # multicore parallel object if available
    cl <- .PkgEnv$seqarray.multicore
    if (inherits(cl, "cluster"))
    {
        stopCluster(cl)
        .PkgEnv$seqarray.multicore <- NULL
    }

    # setup
    if (isTRUE(num))
        num <- detectCores()
    if (!is.na(num) && (num > 1L))
    {
        if ((type == "psock") || (.Platform$OS.type == "windows"))
        {
            cl <- makeCluster(num, outfile="")
            if (isTRUE(verbose))
                cat("Enable the multicore cluster: ")
        } else {
            cl <- makeForkCluster(num)
            if (isTRUE(verbose))
                cat("Enable the multicore cluster via forking: ")
        }
        if (isTRUE(verbose)) print(cl)
        .PkgEnv$seqarray.multicore <- cl
        # need a finalizer when end the R session
        .reg_finalizer()
        # return
        return(invisible(cl))

    } else {
        if (isTRUE(verbose))
            cat("Disable the pre-defined multicore cluster.\n")
    }

    # return nothing
    invisible()
}



#######################################################################
# Get the parallel parameters in SeqArray
#
seqGetParallel <- function()
{
    ans <- .PkgEnv$seqarray.parallel
    if (is.null(ans)) ans <- FALSE
    ans
}



#######################################################################
# Storage options for the SeqArray GDS file
#
seqStorageOption <- function(compression=c("ZIP_RA", "ZIP_RA.fast",
    "ZIP_RA.max", "LZ4_RA", "LZ4_RA.fast", "LZ4_RA.max",
    "LZMA_RA", "LZMA_RA.fast", "LZMA_RA.max", "Ultra", "UltraMax", "none"),
    mode=NULL, float.mode="float32", geno.compress=NULL, info.compress=NULL,
    format.compress=NULL, index.compress=NULL, ...)
{
    # check
    compression <- match.arg(compression)
    z <- switch(compression,
        none="", Ultra="LZMA_RA.ultra", UltraMax="LZMA_RA.ultra_max")
    if (!is.null(z)) compression <- z

    stopifnot(is.null(mode) | is.character(mode))
    stopifnot(is.character(float.mode), length(float.mode) > 0L)

    if (!is.null(geno.compress))
        stopifnot(is.character(geno.compress), length(geno.compress)==1L)
    if (!is.null(info.compress))
        stopifnot(is.character(info.compress), length(info.compress)==1L)
    if (!is.null(format.compress))
        stopifnot(is.character(format.compress), length(format.compress)==1L)
    if (!is.null(index.compress))
        stopifnot(is.character(index.compress), length(index.compress)==1L)

    if (compression %in% c("ZIP_RA.max", "LZ4_RA.max", "LZMA_RA.max"))
    {
        suf_b <- ":1M"; suf_i <- ":1M"; suf_f <- ":4M"
        if (is.null(index.compress)) index.compress <- compression
    } else if (compression=="LZMA_RA.ultra")
    {
        suf_b <- ":4M"; suf_i <- ":4M"; suf_f <- ":8M"
        if (is.null(index.compress)) index.compress <- "LZMA.max"
    } else if (compression=="LZMA_RA.ultra_max")
    {
        suf_b <- suf_i <- suf_f <- ":8M"
        if (is.null(index.compress)) index.compress <- "LZMA.max"
    } else {
        suf_b <- suf_i <- ""
        suf_f <- ":1M"
        if (is.null(index.compress)) index.compress <- compression
    }

    if (is.null(geno.compress))
    {
        if (compression == "LZMA_RA.ultra")
            geno.compress <- "LZMA_RA.ultra:1M"
        else if (compression == "LZMA_RA.ultra_max")
            geno.compress <- "LZMA_RA.ultra_max:8M"
    }

    rv <- list(compression = paste0(compression, suf_b),
        mode = mode, float.mode = float.mode,
        geno.compress = ifelse(is.null(geno.compress), compression,
            geno.compress),
        info.compress = ifelse(is.null(info.compress),
            ifelse(compression=="", "", paste0(compression, suf_i)),
            info.compress),
        format.compress = ifelse(is.null(format.compress),
            ifelse(compression=="", "", paste0(compression, suf_f)),
            format.compress),
        index.compress = index.compress,
        ...)
    class(rv) <- "SeqGDSStorageClass"
    return(rv)
}



#######################################################################
# Apply functions in parallel
#

# get the temporary file names for showing the status of child processes
.get_status_filename <- function(njobs)
{
    i <- as.integer(Sys.time())
    if (is.na(i)) i <- 0L
    i <- (i %% 90000L) + 10000L
    basename(tempfile(
        pattern=sprintf("_parallel_%d_n%d-%d_", i, njobs, seq_len(njobs)),
        tmpdir=".", fileext=".txt"))
}

# initialize the internal variables for child processes
.init_proc <- function(idx=0L, cnt=0L, fname=FALSE)
{
    .Call(SEQ_SetProcess, idx, cnt, fname)
}

# set the block current index and total count
.set_proc_block <- function(idx=0L, cnt=0L)
{
    .Call(SEQ_SetProcessBlock, idx, cnt)
}

# finalize the child process by resetting the status
.done_proc <- function()
{
    .init_proc()
    .set_proc_block()
    .PkgEnv$process_status_fname <- NULL
}

# get the multiple for balancing jobs, the default is 4
.get_bl_multiple <- function()
{
    m <- getOption("seqarray.balancing_multiple", process_balancing_multiple)
    if (!is.numeric(m) || length(m)!=1L || !is.finite(m))
        stop("'seqarray.balancing_multiple' should be a positive number.")
    m
}

# auto set the block size
.auto_bl_size <- function(cnt, njobs)
{
    m <- .get_bl_multiple()
    n <- as.integer(ceiling(cnt / (njobs * m)))
    if (n <= 0L) n <- 1L
    n
}

# get the number of blocks according to the block size
.get_nblock_bl_size <- function(njobs, cnt, bl_size)
{
    if (is.na(bl_size) || (bl_size<=0L))
        bl_size <- .auto_bl_size(cnt, njobs)
    nblock <- cnt %/% bl_size
    if (cnt %% bl_size) nblock <- nblock + 1L
    if (nblock < njobs)
    {
        bl_size <- cnt %/% njobs
        if (cnt %% njobs) bl_size <- bl_size + 1L
        nblock <- cnt %/% bl_size
        if (cnt %% bl_size) nblock <- nblock + 1L
    }
    c(nblock, bl_size)  # return
}

# prepare data for load balancing with a GDS file
.prepare_balancing <- function(gdsfile, njobs, dm, split, .bl_size)
{
    if (split == "by.variant")
    {
        totcnt <- dm[3L]
        v <- .get_nblock_bl_size(njobs, totcnt, .bl_size)
        nblock <- v[1L]
        .bl_size <- v[2L]
        ii <- seqGetData(gdsfile, "$variant_index")
    } else {
        totcnt <- dm[2L]
        v <- .get_nblock_bl_size(njobs, totcnt, .bl_size)
        nblock <- v[1L]
        .bl_size <- v[2L]
        ii <- seqGetData(gdsfile, "$sample_index")
    }
    # return
    list(totcnt = totcnt, nblock = nblock, bl_size = .bl_size,
        sel_idx = ii[seq.int(1L, by=.bl_size, length.out=nblock)])
}


####  Run with a single core  ####

# run with a single core
.run_single_core <- function(gdsfile, FUN, split, .combine, .selection.flag,
    .initialize, .finalize, .initparam, ...)
{
    # initialize
    .init_proc(idx=1L, cnt=1L)
    if (is.function(.initialize)) .initialize(1L, .initparam)
    on.exit({
        .init_proc()
        if (is.function(.finalize)) .finalize(1L, .initparam)        
    })
    # call the user-defined function
    if (!is.numeric(gdsfile))
    {
        if (.selection.flag)
        {
            # gdsfile should be GDS file
            stopifnot(inherits(gdsfile, "SeqVarGDSClass"))
            dm <- .seldim(gdsfile)
            if (split == "by.variant")
                ans <- FUN(gdsfile, rep(TRUE, dm[3L]), ...)
            else if (split == "by.sample")
                ans <- FUN(gdsfile, rep(TRUE, dm[2L]), ...)
            else
                ans <- FUN(gdsfile, NULL, ...)
        } else {
            if (is.null(gdsfile))
                ans <- FUN(...)
            else
                ans <- FUN(gdsfile, ...)
        }
        # finalize
        if (is.function(.combine))
        {
            if (length(formals(args(.combine))) == 1L)
                .combine(ans)
        }
    } else {
        # initial values
        argone <- FALSE
        if (is.function(.combine))
            argone <- length(formals(args(.combine))) == 1L
        is_c_list <-
            identical(.combine, "unlist") || identical(.combine, "list")
        ans <- if (is_c_list) vector("list", gdsfile) else NULL
        # for-loop
        for (i in seq_len(gdsfile))
        {
            v <- FUN(i, ...)  # call
            if (is.function(.combine))
            {
                if (argone)
                {
                    .combine(v)
                } else {
                    ans <- if (is.null(ans)) v else .combine(ans, v)
                }
            } else if (is_c_list)
            {
                # assignment NULL would remove it from the list
                if (!is.null(v)) ans[[i]] <- v
            }
        }
    }
    # return
    ans
}


####  run with a cluster object  ####

.fc_parallel_initializer <- function(i, njobs, st_fname, gdsfn, totnum,
    init, param)
{
    # load the package
    for (pkg in attr(gdsfn, "pkgname"))
        library(pkg, character.only=TRUE, quietly=TRUE, verbose=FALSE)
    library(SeqArray, quietly=TRUE, verbose=FALSE)
    # export to global variables
    .init_proc(i, njobs, st_fname)
    .set_proc_block(0L, totnum)
    .PkgEnv$process_status_fname <- st_fname
    if (is.function(init)) init(i, param)
    NULL
}

.fc_parallel_initializer_bl <- function(i, njobs, st_fname, nblock, gdsfn,
    sel, totcnt, init, param)
{
    # load the package
    for (pkg in attr(gdsfn, "pkgname"))
        library(pkg, character.only=TRUE, quietly=TRUE, verbose=FALSE)
    library(SeqArray, quietly=TRUE, verbose=FALSE)
    # export to global variables
    .init_proc(i, njobs, st_fname)
    .set_proc_block(1L, nblock)
    .PkgEnv$process_status_fname <- st_fname
    # save internally
    .PkgEnv$gdsfile <- seqOpen(gdsfn, allow.duplicate=TRUE)
    .PkgEnv$sample.sel <- .decompress(sel[[1L]])
    .PkgEnv$variant.sel <- .decompress(sel[[2L]])
    .PkgEnv$totcnt <- totcnt
    # set filter
    seqSetFilter(.PkgEnv$gdsfile,
        sample.sel = .PkgEnv$sample.sel,
        variant.sel = .PkgEnv$variant.sel,
        verbose=FALSE)
    # call
    if (is.function(init)) init(i, param)
    NULL
}

.fc_parallel_finalizer <- function(i, fc, param)
{
    if (is.function(fc)) fc(i, param)
    if (inherits(.PkgEnv$gdsfile, "SeqVarGDSClass"))
        seqClose(.PkgEnv$gdsfile)
    .PkgEnv$gdsfile <- NULL
    remove("gdsfile", envir=.PkgEnv)
    .done_proc()
}

.fc_parallel_do <- function(i, .cnt, .gds.fn, .sel, FUN, .split,
    .selection.flag, ...)
{
    # export to global variables
    .set_proc_block(i, NULL)
    # open the file
    f <- seqOpen(.gds.fn, allow.duplicate=TRUE)
    on.exit(seqClose(f))
    # set filter
    seqSetFilter(f,
        sample.sel = .decompress(.sel[[1L]]),
        variant.sel = .decompress(.sel[[2L]]),
        verbose=FALSE)
    s <- .Call(SEQ_SplitSelection, f, .split, i, .cnt, .selection.flag)
    # call the user-defined function
    if (.selection.flag) FUN(f, s, ...) else FUN(f, ...)
}

.fc_parallel_do_bl <- function(i, FUN, .split, .sel_idx, .bl_size,
    .selection.flag, ...)
{
    # set the block index
    .set_proc_block(i, NULL)
    # set filter
    .s <- .Call(SEQ_SplitSelectionX, .PkgEnv$gdsfile, i, .split,
        .sel_idx, .PkgEnv$variant.sel, .PkgEnv$sample.sel,
        .bl_size, .selection.flag, .PkgEnv$totcnt)
    # call the user-defined function
    if (.selection.flag)
        FUN(.PkgEnv$gdsfile, .s, ...)
    else
        FUN(.PkgEnv$gdsfile, ...)
}

.fc_parallel_do_0 <- function(i, FUN, ...)
{
    # export to global variables
    .set_proc_block(i, NULL)
    # call the user-defined function
    FUN(...)
}

.fc_parallel_do_1 <- function(i, FUN, ...)
{
    # export to global variables
    .set_proc_block(i, NULL)
    # call the user-defined function
    FUN(i, ...)
}

# run with a cluster object
.run_parallel_cluster <- function(cl, gdsfile, FUN, split, .combine,
    .selection.flag, .initialize, .finalize, .initparam,
    .balancing, .bl_size, .bl_progress, .status_file, ...)
{
    # number of nodes
    stopifnot(inherits(cl, "cluster"))
    njobs <- length(cl)
    # status files
    st_fname <- NULL
    if (isTRUE(.status_file))
    {
        st_fname <- .get_status_filename(njobs)
        file.create(st_fname, showWarnings=FALSE)
        on.exit(unlink(st_fname, force=TRUE))
    }

    if (split %in% c("by.variant", "by.sample"))
    {
        stopifnot(inherits(gdsfile, "SeqVarGDSClass"))
        dm <- .seldim(gdsfile)
        if (split == "by.variant")
        {
            if (njobs > dm[3L]) cl <- cl[1L:dm[3L]]
        } else {
            if (njobs > dm[2L]) cl <- cl[1L:dm[2L]]
        }
        sel <- seqGetFilter(gdsfile, .useraw=TRUE)
        sel$sample.sel <- .compress(sel$sample.sel)
        sel$variant.sel <- .compress(sel$variant.sel)
    } else {
        sel <- list(sample.sel=raw(), variant.sel=raw())
    }

    # call the user-defined function
    if (!isTRUE(.balancing) || split=="none")
    {
        totnum <- njobs
        if (is.numeric(gdsfile)) totnum <- as.integer(gdsfile)

        # initialize the cluster
        clusterApply(cl, seq_len(njobs), fun = .fc_parallel_initializer,
            njobs=njobs, st_fname=st_fname,
            gdsfn = if (inherits(gdsfile, "SeqVarGDSClass"))
                gdsfile$filename else NULL,
            totnum = if (is.numeric(gdsfile)) totnum else 0L,
            init=.initialize, param=.initparam)
        # exit call
        on.exit({
            clusterApply(cl, seq_len(njobs), fun=.fc_parallel_finalizer,
                fc=.finalize, param=.initparam)
        }, add=TRUE)

        # call in parallel
        if (is.null(gdsfile))
        {
            ans <- .DynamicClusterCall(cl, totnum, .fun = .fc_parallel_do_0,
                .combinefun=.combine, FUN = FUN, ...)
        } else if (inherits(gdsfile, "SeqVarGDSClass"))
        {
            ans <- .DynamicClusterCall(cl, totnum, .fun = .fc_parallel_do,
                .combinefun=.combine, .cnt=totnum, .gds.fn = gdsfile$filename,
                .sel = sel, FUN = FUN, .split = split,
                .selection.flag = .selection.flag, ...
            )
        } else {
            stopifnot(is.numeric(gdsfile))
            ans <- .DynamicClusterCall(cl, totnum, .fun = .fc_parallel_do_1,
                .combinefun=.combine, FUN = FUN, ...)
        }

    } else {
        ## load balancing

        # selection indexing
        v <- .prepare_balancing(gdsfile, njobs, dm, split, .bl_size)
        .bl_size <- v$bl_size
        progress <- if (.bl_progress) .seqProgress(v$totcnt) else NULL
        updatefun <- if (.bl_progress)
            function(i) .seqProgForward(progress, .bl_size) else NULL

        # initialize the cluster & distribute data
        clusterApply(cl, seq_len(njobs),
            fun = .fc_parallel_initializer_bl,
            njobs = njobs, st_fname = st_fname, nblock = v$nblock,
            gdsfn = gdsfile$filename, sel = sel, totcnt = v$totcnt,
            init = .initialize, param = .initparam
        )
        remove(sel)
        # exit call
        on.exit({
            clusterApply(cl, seq_len(njobs), fun=.fc_parallel_finalizer,
                fc=.finalize, param=.initparam)
        })

        # do parallel
        ans <- .DynamicClusterCall(cl, v$nblock,
            .fun = .fc_parallel_do_bl,
            .combinefun=.combine, .updatefun=updatefun, FUN = FUN,
            .split = (split=="by.variant"), .sel_idx = v$sel_idx,
            .bl_size = .bl_size, .selection.flag = .selection.flag, ...
        )
        # close progress object
        remove(progress)
    }

    # return
    if (is.list(ans) & identical(.combine, "unlist"))
        ans <- unlist(ans, recursive=FALSE)
    ans
}


####  Run using forking in Unix/Linux    ####

# run using forking in Unix/Linux
.run_forking <- function(njobs, gdsfile, FUN, split, .combine, .selection.flag,
    .initialize, .finalize, .initparam, .balancing, .bl_size, .bl_progress,
    .status_file, ...)
{
    # check # of nodes
    stopifnot(is.numeric(njobs))
    # status files
    st_fname <- NULL
    if (isTRUE(.status_file))
    {
        st_fname <- .get_status_filename(njobs)
        file.create(st_fname, showWarnings=FALSE)
        on.exit(unlink(st_fname, force=TRUE))
    }

    if (split %in% c("by.variant", "by.sample"))
    {
        stopifnot(inherits(gdsfile, "SeqVarGDSClass"))
        dm <- .seldim(gdsfile)
        if (split == "by.variant")
        {
            if (njobs > dm[3L]) njobs <- dm[3L]
        } else {
            if (njobs > dm[2L]) njobs <- dm[2L]
        }
    }

    # export to global variables
    .init_proc(0L, 0L, st_fname)
    .set_proc_block()
    .PkgEnv$process_status_fname <- st_fname
    on.exit({
        .done_proc()
        .PkgEnv$process_status_fname <- NULL
    }, add=TRUE)

    # the first argument is NA for forking
    if (is.function(.initialize))
        .initialize(NA_integer_, .initparam)
    if (is.function(.finalize))
        on.exit(.finalize(NA_integer_, .initparam), add=TRUE)

    # call the user-defined function
    if (!isTRUE(.balancing) || split=="none")
    {
        # run
        if (is.null(gdsfile))
        {
            ans <- .DynamicForkCall(njobs, njobs, .fun = function(.ji, .i, ...)
            {
                .init_proc(.ji, njobs, NULL)  # export to global variables
                FUN(...)
            }, .combinefun=.combine, .updatefun=NULL, ...)
        } else if (inherits(gdsfile, "SeqVarGDSClass"))
        {
            ans <- .DynamicForkCall(njobs, njobs, .fun = function(.ji, .i, ...)
            {
                # actually .ji = .i
                # export to global variables
                .init_proc(.ji, njobs, NULL)
                # set filter
                .s <- .Call(SEQ_SplitSelection, gdsfile, split, .i, njobs,
                    .selection.flag)
                # call the user-defined function
                if (.selection.flag)
                    FUN(gdsfile, .s, ...)
                else
                    FUN(gdsfile, ...)
            }, .combinefun=.combine, .updatefun=NULL, ...)
        } else {
            stopifnot(is.numeric(gdsfile))
            totnum <- as.integer(gdsfile)
            # call forking
            ans <- .DynamicForkCall(njobs, totnum, .fun = function(.ji, .i, ...)
            {
                # export to global variables
                .init_proc(.ji, njobs, NULL)
                .set_proc_block(.i, totnum)
                FUN(.i, ...)
            }, .combinefun=.combine, .updatefun=NULL, ...)
        }
    } else {
        ## load balancing

        # selection indexing
        v <- .prepare_balancing(gdsfile, njobs, dm, split, .bl_size)
        .bl_size <- v$bl_size
        .sel_idx <- v$sel_idx
        totcnt <- v$totcnt
        nblock <- v$nblock
        remove(v)
        progress <- if (.bl_progress) .seqProgress(totcnt) else NULL
        updatefun <- if (.bl_progress)
            function(i) .seqProgForward(progress, .bl_size) else NULL
        .sel <- seqGetFilter(gdsfile, .useraw=TRUE)
        split <- split == "by.variant"

        # do parallel
        ans <- .DynamicForkCall(njobs, nblock, .fun = function(.ji, .i, ...)
        {
            # set the process & block index
            .init_proc(.ji, njobs, NULL)
            .set_proc_block(.i, nblock)
            # set filter
            .s <- .Call(SEQ_SplitSelectionX, gdsfile, .i, split,
                .sel_idx, .sel$variant.sel, .sel$sample.sel, .bl_size,
                .selection.flag, totcnt)
            # call the user-defined function
            if (.selection.flag)
                FUN(gdsfile, .s, ...)
            else
                FUN(gdsfile, ...)
        }, .combinefun=.combine,
            .updatefun=function(i) .seqProgForward(progress, .bl_size), ...)

        remove(progress)
    }

    # return
    if (is.list(ans) & identical(.combine, "unlist"))
        ans <- unlist(ans, recursive=FALSE)
    ans
}


####  Run with BiocParallel  ####

# combine results from bplapply
.bp_combine_results <- function(ans, .combine)
{
    if (identical(.combine, "none"))
    {
        return(invisible())
    } else if (identical(.combine, "unlist"))
    {
        return(unlist(ans, recursive=FALSE))
    } else if (identical(.combine, "list"))
    {
        return(ans)
    } else if (is.function(.combine))
    {
        if (length(formals(args(.combine))) == 1L)
        {
            for (v in ans) .combine(v)
            return(invisible())
        } else {
            return(Reduce(.combine, ans))
        }
    }
    ans
}

# run with a BiocParallelParam object
.run_biocparallel <- function(cl, gdsfile, FUN, split, .combine,
    .selection.flag, .initialize, .finalize, .initparam,
    .balancing, .bl_size, .bl_progress, ...)
{
    # number of workers
    njobs <- BiocParallel::bpnworkers(cl)

    # initialize workers
    if (is.function(.initialize))
    {
        BiocParallel::bplapply(seq_len(njobs),
            function(i, .initparam) {
                library(SeqArray, quietly=TRUE, verbose=FALSE)
                .initialize(i, .initparam)
            }, .initparam=.initparam, BPPARAM=cl)
    }
    # finalize workers on exit
    on.exit({
        if (is.function(.finalize))
        {
            BiocParallel::bplapply(seq_len(njobs),
                function(i, .initparam) {
                    library(SeqArray, quietly=TRUE, verbose=FALSE)
                    .finalize(i, .initparam)
                }, .initparam=.initparam, BPPARAM=cl)
        }
    })

    if (split %in% c("by.variant", "by.sample"))
    {
        stopifnot(inherits(gdsfile, "SeqVarGDSClass"))
        dm <- .seldim(gdsfile)
        sel <- seqGetFilter(gdsfile, .useraw=TRUE)
        .sel_sample <- .compress(sel$sample.sel)
        .sel_variant <- .compress(sel$variant.sel)
    } else {
        dm <- NULL
        .sel_sample <- raw()
        .sel_variant <- raw()
    }

    # get GDS filename
    .gds.fn <- NULL
    if (inherits(gdsfile, "SeqVarGDSClass"))
        .gds.fn <- gdsfile$filename

    if (!isTRUE(.balancing) || split == "none")
    {
        ####  non-balancing path  ####

        if (is.null(gdsfile))
        {
            # no GDS file: call FUN(...) on each worker
            ans <- BiocParallel::bplapply(seq_len(njobs),
                function(.proc_idx, .proc_cnt, .FUN, ...)
                {
                    library(SeqArray, quietly=TRUE, verbose=FALSE)
                    .init_proc(.proc_idx, .proc_cnt, NULL)
                    .FUN(...)
                },
                .proc_cnt=njobs, .FUN=FUN, ..., BPPARAM=cl)

        } else if (inherits(gdsfile, "SeqVarGDSClass"))
        {
            # GDS file: open, set filter, split, call FUN
            ans <- BiocParallel::bplapply(seq_len(njobs),
                function(.proc_idx, .proc_cnt, .gds.fn, .sel_sample,
                    .sel_variant, .FUN, .split, .selection.flag, ...)
                {
                    library(SeqArray, quietly=TRUE, verbose=FALSE)
                    .init_proc(.proc_idx, .proc_cnt, NULL)
                    f <- seqOpen(.gds.fn, allow.duplicate=TRUE)
                    on.exit(seqClose(f))
                    seqSetFilter(f,
                        sample.sel = .decompress(.sel_sample),
                        variant.sel = .decompress(.sel_variant),
                        verbose=FALSE)
                    .s <- .Call(SEQ_SplitSelection, f, .split, .proc_idx,
                        .proc_cnt, .selection.flag)
                    if (.selection.flag) .FUN(f, .s, ...) else .FUN(f, ...)
                },
                .proc_cnt=njobs, .gds.fn=.gds.fn,
                .sel_sample=.sel_sample, .sel_variant=.sel_variant,
                .FUN=FUN, .split=split, .selection.flag=.selection.flag,
                ..., BPPARAM=cl)

        } else {
            # numeric gdsfile: call FUN(i, ...) for i in 1:gdsfile
            stopifnot(is.numeric(gdsfile))
            totnum <- as.integer(gdsfile)
            ans <- BiocParallel::bplapply(seq_len(totnum),
                function(.i, .njobs, .FUN, ...)
                {
                    library(SeqArray, quietly=TRUE, verbose=FALSE)
                    .init_proc(0L, .njobs, NULL)
                    .set_proc_block(.i, NULL)
                    .FUN(.i, ...)
                },
                .njobs=njobs, .FUN=FUN, ..., BPPARAM=cl)
        }

    } else {
        ####  load-balancing path  ####

        # selection indexing
        v <- .prepare_balancing(gdsfile, njobs, dm, split, .bl_size)
        .bl_size <- v$bl_size
        nblock <- v$nblock
        .sel_idx <- v$sel_idx
        .totcnt <- v$totcnt
        .is_by_variant <- (split == "by.variant")

        # use BiocParallel's progress bar if requested
        if (isTRUE(.bl_progress))
        {
            old_prog <- BiocParallel::bpprogressbar(cl)
            BiocParallel::bpprogressbar(cl) <- TRUE
            on.exit({
                BiocParallel::bpprogressbar(cl) <- old_prog
            }, add=TRUE)
        }

        # distribute blocks across workers via bplapply
        ans <- BiocParallel::bplapply(seq_len(nblock),
            function(.block_idx, .gds.fn, .sel_sample, .sel_variant,
                .FUN, .split, .sel_idx, .bl_size, .selection.flag, .totcnt,
                ...)
            {
                library(SeqArray, quietly=TRUE, verbose=FALSE)
                f <- seqOpen(.gds.fn, allow.duplicate=TRUE)
                on.exit(seqClose(f))
                seqSetFilter(f,
                    sample.sel = .decompress(.sel_sample),
                    variant.sel = .decompress(.sel_variant),
                    verbose=FALSE)
                .s <- .Call(SEQ_SplitSelectionX, f, .block_idx, .split,
                    .sel_idx, .decompress(.sel_variant),
                    .decompress(.sel_sample),
                    .bl_size, .selection.flag, .totcnt)
                if (.selection.flag) .FUN(f, .s, ...) else .FUN(f, ...)
            },
            .gds.fn=.gds.fn, .sel_sample=.sel_sample,
            .sel_variant=.sel_variant, .FUN=FUN, .split=.is_by_variant,
            .sel_idx=.sel_idx, .bl_size=.bl_size,
            .selection.flag=.selection.flag, .totcnt=.totcnt,
            ..., BPPARAM=cl)
    }

    # combine results
    .bp_combine_results(ans, .combine)
}


# call the user-defined function in parallel
seqParallel <- function(cl=seqGetParallel(), gdsfile, FUN,
    split=c("by.variant", "by.sample", "none"), .combine="unlist",
    .selection.flag=FALSE, .initialize=NULL, .finalize=NULL, .initparam=NULL,
    .balancing=FALSE, .bl_size=NA_integer_, .bl_progress=FALSE,
    .status_file=FALSE, .proc_time=FALSE, ...)
{
    # check
    stopifnot(is.null(cl) || is.logical(cl) || is.numeric(cl) ||
        inherits(cl, "cluster") || inherits(cl, "BiocParallelParam"))
    stopifnot(is.null(gdsfile) || inherits(gdsfile, "SeqVarGDSClass") ||
        is.numeric(gdsfile))
    if (is.numeric(gdsfile))
    {
        if (!is.finite(gdsfile) || gdsfile<1L)
        {
            stop("'gdsfile' should be NULL, a SeqVarGDSClass object ",
                "or a positive integer.")
        }
    }
    stopifnot(is.function(FUN))
    split <- match.arg(split)
    stopifnot(is.character(.combine) | is.function(.combine))
    stopifnot(is.null(.initialize) | is.function(.initialize))
    stopifnot(is.null(.finalize) | is.function(.finalize))
    stopifnot(is.logical(.selection.flag), length(.selection.flag)==1L)
    stopifnot(is.logical(.status_file), length(.status_file)==1L)
    stopifnot(is.logical(.proc_time), length(.proc_time)==1L)
    stopifnot(is.logical(.balancing), length(.balancing)==1L)
    if (is.na(.balancing))
        .balancing <- isTRUE(getOption("seqarray.balancing", TRUE))
    if (isTRUE(.balancing))
    {
        stopifnot(is.numeric(.bl_size), length(.bl_size)==1L)
        stopifnot(is.logical(.bl_progress), length(.bl_progress)==1L)
    }

    if (is.character(.combine))
    {
        stopifnot(length(.combine) == 1L)
        if (!(.combine %in% c("unlist", "list", "none")))
            .combine <- match.fun(.combine)
    }

    # check dimension
    if (is.null(gdsfile) || is.numeric(gdsfile))
    {
        if (split != "none")
            stop("'split' should be 'none' if 'gdsfile' is NULL or an integer.")
    } else {
        dm <- .seldim(gdsfile)
        if (split == "by.variant")
        {
            if (dm[3L] <= 0L) stop("No variants selected.")
        } else if (split == "by.sample") {
            if (dm[2L] <= 0L) stop("No samples selected.")
        }
    }

    # initialize internally
    tm <- as.double(Sys.time())
    .init_proc()

    # get the number of workers
    cl <- .McoreParallel(cl)
    njobs <- .NumParallel(cl)
    if (njobs <= 1L)
    {
        # run with a single core
        ans <- .run_single_core(gdsfile, FUN, split, .combine, .selection.flag,
            .initialize, .finalize, .initparam, ...)

    } else if (inherits(cl, "cluster"))
    {
        # multiple processes with a cluster object
        ans <- .run_parallel_cluster(cl, gdsfile, FUN, split, .combine,
            .selection.flag, .initialize, .finalize, .initparam,
            .balancing, .bl_size, .bl_progress, .status_file, ...)

    } else if (inherits(cl, "BiocParallelParam"))
    {
        ## multiple processes with a predefined cluster from BiocParallel
        ans <- .run_biocparallel(cl, gdsfile, FUN, split, .combine,
            .selection.flag, .initialize, .finalize, .initparam,
            .balancing, .bl_size, .bl_progress, ...)

    } else {
        # forking processes, when cl is an integer
        if (getOption("seqarray.nofork", FALSE) || .Platform$OS.type=="windows")
        {
            # no forking on windows
            capture.output({ cl <- makeCluster(njobs, outfile="") })
            on.exit(stopCluster(cl))
            # call
            return(seqParallel(cl, gdsfile, FUN, split, .combine,
                .selection.flag, .initialize, .finalize, .initparam,
                .balancing, .bl_size, .bl_progress, .status_file, ...))
        }
        # call
        ans <- .run_forking(njobs, gdsfile, FUN, split, .combine,
            .selection.flag, .initialize, .finalize, .initparam,
            .balancing, .bl_size, .bl_progress, .status_file, ...)
    }

    # show the elapsed time
    if (isTRUE(.proc_time) && isFALSE(.balancing && .bl_progress))
    {
        tm <- as.double(Sys.time()) - tm
        .cat("\r[==================================================] 100%",
            ", complete, ", .Call(SEQ_SecToTime, tm), "    ")
    }

    # output
    if (identical(.combine, "none"))
        invisible()
    else
        ans
}


seqParApply <- function(cl=seqGetParallel(), x, FUN, .balancing=TRUE, ...)
{
    # check
    cl <- .McoreParallel(cl)
    njobs <- .NumParallel(cl, "cl")
    stopifnot(is.logical(.balancing), length(.balancing)==1L)
    if (is.na(.balancing))
        .balancing <- isTRUE(getOption("seqarray.balancing", TRUE))

    if (njobs <= 1L)
    {
        # a single process
        ans <- lapply(x, FUN, ...)
    } else if (inherits(cl, "BiocParallelParam"))
    {
        # multiple cores
        ans <- BiocParallel::bplapply(x, FUN, ..., BPPARAM=cl)
    } else {
        # multiple cores
        if (!inherits(cl, "cluster"))
        {
            if (.Platform$OS.type == "windows")
                cl <- makeCluster(njobs)
            else
                cl <- makeForkCluster(njobs)
            on.exit({ stopCluster(cl) })
        }

        # a load balancing version
        if (.balancing)
            ans <- clusterApplyLB(cl, x, FUN, ...)
        else
            ans <- clusterApply(cl, x, FUN, ...)
    }

    # output
    ans
}



#######################################################################
# Modify the SeqArray data structure
#######################################################################

#######################################################################
# Delete data variables
#

seqDelete <- function(gdsfile, info.var=character(), fmt.var=character(),
    samp.var=character(), verbose=TRUE)
{
    # check
    stopifnot(inherits(gdsfile, "SeqVarGDSClass"))
    if (gdsfile$readonly)
        stop("The GDS file is read-only.")

    stopifnot(is.character(info.var))
    stopifnot(is.character(fmt.var))
    stopifnot(is.character(samp.var))
    stopifnot(is.logical(verbose), length(verbose)==1L)

    if (verbose) cat("Delete INFO variable(s):")
    if (length(info.var) == 0L) cat(" <None>")
    for (i in seq_along(info.var))
    {
        nm <- info.var[i]
        n <- index.gdsn(gdsfile, paste0("annotation/info/", nm))
        delete.gdsn(n, force=TRUE)
        n <- index.gdsn(gdsfile, paste0("annotation/info/@", nm), silent=TRUE)
        if (!is.null(n))
            delete.gdsn(n, force=TRUE)
        if (verbose) cat(ifelse(i>1L, ",", ""), nm)
    }
    if (verbose) cat("\n")

    if (verbose) cat("Delete FORMAT variable(s):")
    if (length(fmt.var) == 0L) cat(" <None>")
    for (i in seq_along(fmt.var))
    {
        nm <- fmt.var[i]
        n <- index.gdsn(gdsfile, paste0("annotation/format/", nm))
        delete.gdsn(n, force=TRUE)
        if (verbose) cat(ifelse(i>1L, ",", ""), nm)
    }
    if (verbose) cat("\n")

    if (verbose) cat("Delete Sample Annotation variable(s):")
    if (length(samp.var) == 0L) cat(" <None>")
    for (i in seq_along(samp.var))
    {
        nm <- samp.var[i]
        n <- index.gdsn(gdsfile, paste0("sample.annotation/", nm))
        delete.gdsn(n, force=TRUE)
        if (verbose) cat(ifelse(i>1L, ",", ""), nm)
    }
    if (verbose) cat("\n")

    # return
    invisible()
}



#######################################################################
# Transpose data variable(s)
#

.Transpose <- function(gdsfile, src.fn, prefix, compress=NULL)
{
    dst.fn <- .var_path(src.fn, prefix)
    if (is.null(index.gdsn(gdsfile, dst.fn, silent=TRUE)))
    {
        node <- index.gdsn(gdsfile, src.fn)
        desp <- objdesp.gdsn(node)
        dm <- desp$dim
        if (length(dm) > 1L)
        {
            # dimension
            dm <- c(dm[-(length(dm)-1L)], 0L)
            # folder
            nm <- unlist(strsplit(src.fn, "/"))
            if (length(nm) <= 1)
                folder <- gdsfile$root
            else
                folder <- index.gdsn(gdsfile, index=nm[-length(nm)])
            # compress
            if (is.null(compress))
                compress <- desp$compress

            pm <- list(node = folder,
                name = paste(prefix, nm[length(nm)], sep=""),
                val = NULL, storage = desp$storage,
                valdim = dm, compress = compress)
            if (!is.null(desp$param))
                pm <- c(pm, desp$param)

            newnode <- do.call(add.gdsn, pm)
            moveto.gdsn(newnode, node, relpos="after")

            # write data
            apply.gdsn(node, margin=length(dm)-1L, as.is="gdsnode",
                FUN=`c`, target.node=newnode, .useraw=TRUE)

            readmode.gdsn(newnode)
        }
    }
    invisible()
}


seqTranspose <- function(gdsfile, var.name, compress=NULL, digest=TRUE,
    verbose=TRUE)
{
    # check
    stopifnot(inherits(gdsfile, "SeqVarGDSClass"))
    stopifnot(is.character(var.name) & is.vector(var.name))
    stopifnot(length(var.name) == 1L)
    stopifnot(is.logical(digest) | is.character(digest), length(digest)==1L)
    stopifnot(is.logical(verbose), length(verbose)==1L)

    node <- index.gdsn(gdsfile, var.name)
    desp <- objdesp.gdsn(node)
    dm <- desp$dim
    if (length(dm) > 1L)
    {
        # dimension
        dm <- c(dm[-(length(dm)-1L)], 0L)
        # folder
        index <- unlist(strsplit(var.name, "/"))
        if (length(index) <= 1L)
            folder <- gdsfile$root
        else
            folder <- index.gdsn(gdsfile, index=index[-length(index)])
        # compress
        if (is.null(compress))
            compress <- desp$compress

        name <- paste("~", index[length(index)], sep="")
        newnode <- add.gdsn(folder, name, val=NULL, storage=desp$storage,
            valdim=dm, compress=compress)
        moveto.gdsn(newnode, node, relpos="after")

        # write data
        apply.gdsn(node, margin=length(dm)-1L, as.is="none", FUN=function(g) {
            append.gdsn(newnode, g)
        }, .useraw=TRUE)

        readmode.gdsn(newnode)
        .DigestCode(newnode, digest, FALSE)
        if (verbose)
            print(newnode, attribute=TRUE, attribute.trim=TRUE)
    } else
        warning("It is a vector.")

    invisible()
}



#######################################################################
# Optimize data by transposing
#

# Run-length encoding on chromosome codes
.optim_chrom <- function(gdsfile)
{
    # check
    stopifnot(inherits(gdsfile, "gds.class"))
    # read
    n <- index.gdsn(gdsfile, "chromosome")
    readmode.gdsn(n)
    chr <- read.gdsn(n)
    s <- rle(chr)
    n1 <- add.gdsn(gdsfile, "@chrom_rle_val", s$values, replace=TRUE,
        visible=FALSE)
    n2 <- add.gdsn(gdsfile, "@chrom_rle_len", s$lengths, replace=TRUE,
        visible=FALSE)
    moveto.gdsn(n2, n)
    moveto.gdsn(n1, n)
    # return
    invisible()
}

seqOptimize <- function(gdsfile, target=c("chromosome", "by.sample"),
    format.var=TRUE, cleanup=TRUE, verbose=TRUE)
{
    # check
    stopifnot(inherits(gdsfile, "gds.class") || is.character(gdsfile))
    target <- match.arg(target)
    stopifnot(is.logical(format.var) || is.character(format.var))
    stopifnot(is.logical(cleanup), length(cleanup)==1L)
    stopifnot(is.logical(verbose), length(verbose)==1L)
    if (is.na(verbose)) verbose <- FALSE

    # the open file
    if (is.character(gdsfile))
    {
        stopifnot(length(gdsfile) == 1L)
        if (verbose)
            .cat("Open ", sQuote(basename(gdsfile)))
        gdsfn <- gdsfile
        gdsfile <- seqOpen(gdsfn, readonly=FALSE)
        on.exit(seqClose(gdsfile))
    } else {
        # do not call cleanup.gds
        cleanup <- FALSE
    }
    if (gdsfile$readonly)
        stop("'gdsfile' should not be read-only.")

    # process
    if ("by.sample" %in% target)
    {
        # genotype
        if (verbose) cat("Working on 'genotype' ...\n")
        .Transpose(gdsfile, "genotype/data", "~")

        # phase
        if (verbose) cat("Working on 'phase' ...\n")
        .Transpose(gdsfile, "phase/data", "~")

        # annotation - format
        if (isTRUE(format.var) || is.character(format.var))
        {
            n <- index.gdsn(gdsfile, "annotation/format", silent=TRUE)
            if (!is.null(n))
            {
                nm <- ls.gdsn(n)
                if (isTRUE(format.var)) format.var <- nm
                for (i in nm)
                {
                    if (i %in% format.var)
                    {
                        if (verbose)
                        {
                            cat("Working on 'annotation/format/", i,
                                "' ...\n", sep="")
                        }
                        .Transpose(gdsfile,
                            paste("annotation/format", i, "data", sep="/"), "~")
                    }
                }
            }
        }

    } else if ("chromosome" %in% target)
    {
        if (verbose)
            cat("Adding run-length encoding for chromosomes ...")
        # run-length encoding on chromosome codes
        .optim_chrom(gdsfile)
        if (verbose) cat("  [Done]\n")
    }

    if (isTRUE(cleanup))
    {
        on.exit()
        seqClose(gdsfile)
        cleanup.gds(gdsfn, verbose=verbose)
    }
    invisible()
}
