## ----style, echo = FALSE, results = 'asis', message=FALSE---------------------
BiocStyle::markdown()

## ----echo = FALSE, message = FALSE--------------------------------------------
library(Chromatograms)
library(BiocStyle)

## ----message = FALSE----------------------------------------------------------
library(Chromatograms)

#' Definition of the backend class extending ChromBackend
setClass("ChromBackendTest",
    contains = "ChromBackend",
    slots = c(
        chromData = "data.frame",
        peaksData = "list"
    ),
    prototype = prototype(
        chromData = data.frame(),
        peaksData = list()
    )
)

#' Simple constructor function
ChromBackendTest <- function() {
    new("ChromBackendTest")
}

## ----message = FALSE----------------------------------------------------------
#' Basic validation function
setValidity("ChromBackendTest", function(object) {
    if (length(object@peaksData) != nrow(object@chromData)) {
        return(
            "length of 'peaksData' has to match the number of rows of ",
            "'chromData'"
        )
    }
    NULL
})

## -----------------------------------------------------------------------------
#' Create an empty instance of ChromBackendTest
be <- ChromBackendTest()
be

## -----------------------------------------------------------------------------
#' implementation of show for ChromBackendTest
setMethod("show", "ChromBackendTest", function(object) {
    cd <- object@chromData
    cat(class(object), "with", nrow(cd), "chromatograms\n")
})
be

## -----------------------------------------------------------------------------
#' dataStorage method to provide information *where* data is stored
setMethod("dataStorage", "ChromBackendTest", function(object) {
    as.character(object@chromData$dataStorage)
})

## -----------------------------------------------------------------------------
dataStorage(be)

## -----------------------------------------------------------------------------
#' length to provide information on the number of chromatograms
setMethod("length", "ChromBackendTest", function(x) {
    nrow(x@chromData)
})
length(be)

## -----------------------------------------------------------------------------
#' backendInitialize method to fill the backend with data.
setMethod(
    "backendInitialize", "ChromBackendTest",
    function(object, chromData, peaksData) {
        if (!is.data.frame(chromData)) {
            stop(
                "'chromData' needs to be a 'data.frame' with the general",
                "chromatogram variables"
            )
        }
        ## Defining dataStorage and dataOrigin, if not available
        if (is.null(chromData$dataOrigin)) {
            chromData$dataOrigin <- NA_character_
        }
        ## Validate the provided data
        validChromData(chromData)
        validPeaksData(peaksData)
        ## Fill the object with data
        object@chromData <- chromData
        object@peaksData <- peaksData
        object
    }
)

## -----------------------------------------------------------------------------
# A data.frame with chromatogram variables.
cdata <- data.frame(
    msLevel = c(1L, 1L),
    mz = c(112.2, 123.3)
)

# Retention time and intensity values for each chromatogram.
pdata <- list(
    data.frame(
        rtime = c(12.4, 12.8, 13.2, 14.6),
        intensity = c(123.3, 153.6, 2354.3, 243.4)
    ),
    data.frame(
        rtime = c(45.1, 46.2),
        intensity = c(100, 80.1)
    )
)

#' Create and initialize the backend
be <- backendInitialize(ChromBackendTest(),
    chromData = cdata, peaksData = pdata
)
be

## -----------------------------------------------------------------------------
#' List core chromatogram variables along with data types.
coreChromVariables()

## -----------------------------------------------------------------------------
#' Accessor for available chromatogram variables
setMethod("chromVariables", "ChromBackendTest", function(object) {
    union(names(object@chromData), names(coreChromVariables()))
})

chromVariables(be)

## -----------------------------------------------------------------------------
#' Get the data.frame with the available chrom variables
be@chromData
#' Complete this data.frame with missing core variables
fillCoreChromVariables(be@chromData)

## -----------------------------------------------------------------------------
#' function to extract the full chromData
setMethod(
    "chromData", "ChromBackendTest",
    function(object, columns = chromVariables(object),
    drop = FALSE) {
        if (!any(chromVariables(object) %in% columns)) {
            stop(
                "Some of the requested Chromatogram variables are not ",
                "available"
            )
        }
        res <- fillCoreChromVariables(object@chromData)
        res <- res[, columns, drop = drop]
        res
    }
)

## -----------------------------------------------------------------------------
#' Extract the full data
chromData(be)

#' Selected variables
chromData(be, c("mz", "msLevel"))

#' Only missing core chromatograms variables
chromData(be, c("collisionEnergy", "mzMin"))

## -----------------------------------------------------------------------------
setMethod("peaksVariables", "ChromBackendTest", function(object) {
    union(names(corePeaksVariables()), names(object@peaksData[[1]]))
})

## -----------------------------------------------------------------------------
peaksVariables(be)

## -----------------------------------------------------------------------------
corePeaksVariables()

## -----------------------------------------------------------------------------
#' method to extract the full chromatographic data as list of arrays
setMethod(
    "peaksData", "ChromBackendTest",
    function(object, columns = peaksVariables(object), drop = FALSE) {
        if (!all(columns %in% peaksVariables(object))) {
            stop("Some of the requested peaks variables are not available")
        }
        res <- lapply(object@peaksData, function(x) x[, columns, drop = drop])
        res
    }
)

## -----------------------------------------------------------------------------
#' Extract the *peaks* data (i.e. intensity and retention times)
peaksData(be)

## -----------------------------------------------------------------------------
#' Main subset method.
setMethod("[", "ChromBackendTest", function(x, i, j, ..., drop = FALSE) {
    i <- MsCoreUtils::i2index(i, length = length(x))
    x@chromData <- x@chromData[i, ]
    x@peaksData <- x@peaksData[i]
    x
})

## -----------------------------------------------------------------------------
a <- be[1]
chromData(a)

## -----------------------------------------------------------------------------
a <- be[c(1, 1, 1)]
chromData(a)

## -----------------------------------------------------------------------------
#' Access a single chromatogram variable
setMethod("$", "ChromBackendTest", function(x, name) {
    if (name %in% union(chromVariables(x), names(coreChromVariables()))) {
        res <- chromData(x, columns = name, drop = TRUE)
    } else if (name %in% peaksVariables(x)) {
        res <- peaksData(x, columns = name, drop = TRUE)
    } else {
        stop("The requested variable '", name, "' is not available")
    }
    res
})

## -----------------------------------------------------------------------------
be$msLevel

## -----------------------------------------------------------------------------
be$precursorMz

## -----------------------------------------------------------------------------
be$intensity

## -----------------------------------------------------------------------------
#' Method allowing to join (concatenate) backends
setMethod("backendMerge", "ChromBackendTest", function(object, ...) {
    res <- object
    object <- unname(c(list(object), list(...)))
    res@peaksData <- do.call(c, lapply(object, function(z) z@peaksData))
    res@chromData <- do.call(
        MsCoreUtils::rbindFill,
        lapply(object, function(z) z@chromData)
    )
    validObject(res)
    res
})

## -----------------------------------------------------------------------------
a <- backendMerge(be, be[2], be)
a

## -----------------------------------------------------------------------------
#' Default for backends:
isReadOnly(be)

## -----------------------------------------------------------------------------
#' Implementation of isReadOnly for ChromBackendTest
setMethod("isReadOnly", "ChromBackendTest", function(object) FALSE)
isReadOnly(be)

## -----------------------------------------------------------------------------
#' Replacement method for the full chromatogram data
setReplaceMethod("chromData", "ChromBackendTest", function(object, value) {
    if (is(value, "DataFrame")) {
        value <- as(value, "data.frame")
    }
    if (!inherits(value, "data.frame")) {
        stop("'value' is expected to be a 'data.frame'")
    }
    if (length(object) && length(object) != nrow(value)) {
        stop("'value' has to be a 'data.frame' with ", length(object), " rows")
    }
    validChromData(value)
    object@chromData <- value
    object
})

## -----------------------------------------------------------------------------
d <- chromData(be)
d$new_col <- c("a", "b")

chromData(be) <- d

## -----------------------------------------------------------------------------
be$new_col

## -----------------------------------------------------------------------------
#' Replace or add a single chromatogram variable.
setReplaceMethod("$", "ChromBackendTest", function(x, name, value) {
    if (length(x) && length(value) != length(x)) {
        stop(
            "length of 'value' needs to match the number of chromatograms ",
            "in object."
        )
    }
    if (name %in% peaksVariables(x)) {
        if (!is.list(value)) {
            stop("The value for peaksData should be a list")
        }
        for (i in seq_along(value)) {
            x@peaksData[[i]][[name]] <- value[[i]]
            validPeaksData(x@peaksData)
        }
    } else {
        x@chromData[, name] <- value
        validChromData(x@chromData)
    }
    x
})

## -----------------------------------------------------------------------------
#' Values before replacement
be$msLevel

#' Replace MS levels
be$msLevel <- c(3L, 2L)

#' Values after replacement
be$msLevel

## -----------------------------------------------------------------------------
#' Add a new chromatogram variable
be$name <- c("A", "B")
be$name

## -----------------------------------------------------------------------------
#' Replace intensity values
be$msLevel3 <- be$msLevel + 3
be$msLevel3

## -----------------------------------------------------------------------------
#' replacement method for peaks data
setReplaceMethod("peaksData", "ChromBackendTest", function(object, value) {
    if (!is.list(value)) {
        stop("'value' is expected to be a list")
    }
    if (length(object) && length(object) != length(value)) {
        stop("'value' has to be a list with ", length(object), " elements")
    }
    validPeaksData(value)
    object@peaksData <- value
    object
})

## -----------------------------------------------------------------------------
#' Create a list with peaks matrices; our backend has 3 chromatograms
#' thus our `list` has to be of length 3
tmp <- list(
    data.frame(
        rtime = c(12.3, 14.4, 15.4, 16.4),
        intensity = c(200, 312, 354.1, 232)
    ),
    data.frame(
        rtime = c(14.4),
        intensity = c(13.4)
    )
)

be_2 <- be
#' Assign this peaks data to one of our test backends
peaksData(be_2) <- tmp

#' Evaluate that we properly added the peaks data
peaksData(be_2)

## ----eval = FALSE-------------------------------------------------------------
# #' Is there a specific way how the object could be best split for
# #' parallel processing?
# setMethod("backendParallelFactor", "ChromBackend", function(object, ...) {
#     factor()
# })

## -----------------------------------------------------------------------------
backendParallelFactor(be)

## ----eval = FALSE-------------------------------------------------------------
# #' get the values for the chromIndex chromatogram variable
# setMethod(
#     "chromIndex", "ChromBackend",
#     function(object, columns = chromVariables(object)) {
#         chromData(object, columns = "chromIndex", drop = TRUE)
#     }
# )

## -----------------------------------------------------------------------------
chromIndex(be)

## ----eval = FALSE-------------------------------------------------------------
# #' get the values for the collisionEnergy chromatogram variable
# setMethod("collisionEnergy", "ChromBackend", function(object) {
#     chromData(object, columns = "collisionEnergy", drop = TRUE)
# })

## -----------------------------------------------------------------------------
collisionEnergy(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default replacement method for collisionEnergy
# setReplaceMethod(
#     "collisionEnergy", "ChromBackend", function(object, value) {
#         object$collisionEnergy <- value
#         object
#     }
# )

## -----------------------------------------------------------------------------
#' Replace the collision energy
collisionEnergy(be) <- c(20, 30)
collisionEnergy(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementation to access dataOrigin
# setMethod("dataOrigin", "ChromBackend", function(object) {
#     chromData(object, columns = "dataOrigin", drop = TRUE)
# })

## -----------------------------------------------------------------------------
#' Access the dataOrigin values
dataOrigin(be)

## -----------------------------------------------------------------------------
#' Default implementation of the `dataOrigin<-` replacement method
setReplaceMethod("dataOrigin", "ChromBackend", function(object, value) {
    object$dataOrigin <- value
    object
})

## -----------------------------------------------------------------------------
#' Replace the backend's dataOrigin values
dataOrigin(be) <- rep("from somewhere", 2)
dataOrigin(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default method to extract intensity values
# setMethod("intensity", "ChromBackend", function(object) {
#     if (length(object)) {
#         peaksData(object, column = "intensity", drop = TRUE)
#     } else {
#         list()
#     }
# })

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementation of the replacement method for intensity values
# setReplaceMethod("intensity", "ChromBackend", function(object, value) {
#     pd <- peaksData(object)
#     if (!is.list(value) || length(pd) != length(value)) {
#         stop("'value' should be a list of the same length as 'object'")
#     }
#     for (i in seq_along(pd)) {
#         if (length(value[[i]]) != nrow(pd[[i]])) {
#             stop(paste0(
#                 "Length of 'value[[", i, "]]' does not match ",
#                 "the number of rows in the intensity of chromatogram: ",
#                 i, "'"
#             ))
#         }
#     }
#     peaksData(object) <- lapply(seq_along(pd), function(i) {
#         pd[[i]]$intensity <- value[[i]]
#         return(pd[[i]])
#     })
#     object
# })

## -----------------------------------------------------------------------------
#' Replace intensity values
intensity(be)[[1]] <- intensity(be)[[1]] + 10
intensity(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementation for `isEmpty()`
# setMethod("isEmpty", "ChromBackend", function(x) {
#     lengths(x) == 0L
# })

## -----------------------------------------------------------------------------
isEmpty(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementation of `isReadOnly()`
# setMethod("isReadOnly", "ChromBackend", function(object) {
#     TRUE
# })

## -----------------------------------------------------------------------------
isReadOnly(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementation for `length()`
# setMethod("length", "ChromBackend", function(x) {
#     nrow(chromData(x, columns = "dataStorage"))
# })

## -----------------------------------------------------------------------------
length(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementation for `lengths()`
# setMethod("lengths", "ChromBackend", function(x) {
#     lengths(intensity(x))
# })

## -----------------------------------------------------------------------------
lengths(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default methods to get or set MS levels
# setMethod("msLevel", "ChromBackend", function(object) {
#     chromData(object, columns = "msLevel", drop = TRUE)
# })
# setReplaceMethod("msLevel", "ChromBackend", function(object, value) {
#     object$msLevel <- value
#     object
# })

## -----------------------------------------------------------------------------
msLevel(be) <- c(1L, 2L)
msLevel(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations to get or set m/z value(s)
# setMethod("mz", "ChromBackend", function(object) {
#     chromData(object, columns = "mz", drop = TRUE)
# })
# setReplaceMethod("mz", "ChromBackend", function(object, value) {
#     object$mz <- value
#     object
# })

## -----------------------------------------------------------------------------
mz(be) <- c(314.3, 312.5)
mz(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations to get or set upper m/z limits
# setMethod("mzMax", "ChromBackend", function(object) {
#     chromData(object, columns = "mzMax", drop = TRUE)
# })
# setReplaceMethod("mzMax", "ChromBackend", function(object, value) {
#     object$mzMax <- value
#     object
# })

## -----------------------------------------------------------------------------
mzMax(be) <- mz(be) + 0.01
mzMax(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default methods to get or set the lower m/z boundary
# setMethod("mzMin", "ChromBackend", function(object) {
#     chromData(object, columns = "mzMin", drop = TRUE)
# })
# 
# setReplaceMethod("mzMin", "ChromBackend", function(object, value) {
#     object$mzMin <- value
#     object
# })

## -----------------------------------------------------------------------------
mzMin(be) <- mz(be) - 0.01
mzMin(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations to get or set the precursorMz chrom variable
# setMethod("precursorMz", "ChromBackend", function(object) {
#     chromData(object, columns = "precursorMz", drop = TRUE)
# })
# setReplaceMethod("precursorMz", "ChromBackend", function(object, value) {
#     object$precursorMz <- value
#     object
# })

## -----------------------------------------------------------------------------
precursorMz(be) <- c(NA_real_, 123.3)
precursorMz(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations for `precursorMzMax`
# setMethod("precursorMzMax", "ChromBackend", function(object) {
#     chromData(object, columns = "precursorMzMax", drop = FALSE)
# })
# setReplaceMethod("precursorMzMax", "ChromBackend", function(object, value) {
#     object$precursorMzMax <- value
#     object
# })

## -----------------------------------------------------------------------------
precursorMzMax(be) <- precursorMz(be) + 0.1
precursorMzMax(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations for `precursorMzMin`
# setMethod("precursorMzMin", "ChromBackend", function(object) {
#     chromData(object, columns = "precursorMzMin", drop = FALSE)
# })
# setReplaceMethod("precursorMzMin", "ChromBackend", function(object, value) {
#     object$precursorMzMin <- value
#     object
# })

## -----------------------------------------------------------------------------
precursorMzMin(be) <- precursorMz(be) - 0.1
precursorMzMin(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations for `productMz`
# setMethod("productMz", "ChromBackend", function(object) {
#     chromData(object, columns = "productMz", drop = TRUE)
# })
# setReplaceMethod("productMz", "ChromBackend", function(object, value) {
#     object$productMz <- value
#     object
# })

## -----------------------------------------------------------------------------
productMz(be) <- c(123.2, NA_real_)
productMz(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations for `productMzMax`
# setMethod("productMzMax", "ChromBackend", function(object) {
#     chromData(object, columns = "productMzMax", drop = FALSE)
# })
# setReplaceMethod("productMzMax", "ChromBackend", function(object, value) {
#     object$productMzMax <- value
#     object
# })

## -----------------------------------------------------------------------------
productMzMax(be) <- productMz(be) + 0.02
productMzMax(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default implementations for `productMzMin`
# setMethod("productMzMin", "ChromBackend", function(object) {
#     chromData(object, columns = "productMzMin", drop = FALSE)
# })
# setReplaceMethod("productMzMin", "ChromBackend", function(object, value) {
#     object$productMzMin <- value
#     object
# })

## -----------------------------------------------------------------------------
productMzMin(be) <- productMz(be) - 0.2
productMzMin(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default methods for `rtime()` and `rtime<-`
# setMethod("rtime", "ChromBackend", function(object) {
#     if (length(object)) {
#         peaksData(object, column = "rtime", drop = TRUE)
#     } else {
#         list()
#     }
# })
# 
# setReplaceMethod("rtime", "ChromBackend", function(object, value) {
#     pd <- peaksData(object)
#     if (!is.list(value) || length(pd) != length(value)) {
#         stop("'value' should be a list of the same length as 'object'")
#     }
#     for (i in seq_along(pd)) {
#         if (length(value[[i]]) != nrow(pd[[i]])) {
#             stop(paste0(
#                 "Length of 'value[[", i, "]]' does not match ",
#                 "the number of rows in 'the rtime of chromatogram: ", i, "'"
#             ))
#         }
#     }
#     peaksData(object) <- lapply(seq_along(pd), function(i) {
#         pd[[i]]$rtime <- value[[i]]
#         return(pd[[i]])
#     })
#     object
# })

## -----------------------------------------------------------------------------
rtime(be)[[1]] <- rtime(be)[[1]] + 2
rtime(be)

## ----eval = FALSE-------------------------------------------------------------
# #' Default method to split a backend
# setMethod("split", "ChromBackend", function(x, f, drop = FALSE, ...) {
#     split.default(x, f, drop = drop, ...)
# })

## -----------------------------------------------------------------------------
split(be, f = c(1, 2, 1))

## ----si-----------------------------------------------------------------------
sessionInfo()