labkey.experiment.R

##
#  Copyright (c) 2018 LabKey Corporation
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.
##
labkey.experiment.SAMPLE_DERIVATION_PROTOCOL <- "Sample Derivation Protocol"

## Create an ExpData object
##
labkey.experiment.createData <- function(config, dataClassId = NULL, dataClassName = NULL, dataFileUrl = NULL)
{
    ## check required parameters
    if (missing(config))
        stop (paste("A list of ExpObject config params must be specified in the config parameter."))

    data <- config

    if (!is.null(dataFileUrl))
        data$dataFileURL = dataFileUrl

    if (!is.null(dataClassId) || !is.null(dataClassName))
    {
        dataClass <- list()
        if (!is.null(dataClassId))
            dataClass$id = dataClassId
        if (!is.null(dataClassName))
            dataClass$name = dataClassName

        data$dataClass = dataClass
    }
    return (data)
}

## Create an ExpMaterial object
##
labkey.experiment.createMaterial <- function(config, sampleSetId = NULL, sampleSetName = NULL)
{
    ## check required parameters
    if (missing(config))
        stop (paste("A list of ExpObject config params must be specified in the config parameter."))

    material <- config

    if (!is.null(sampleSetId) || !is.null(sampleSetName))
    {
        sampleSet <- list()
        if (!is.null(sampleSetId))
            sampleSet$id = sampleSetId
        if (!is.null(sampleSetName))
            sampleSet$name = sampleSetName

        material$sampleSet = sampleSet
    }
    return (material)
}

## Create an ExpRun object
##
labkey.experiment.createRun <- function(config, dataInputs = NULL, dataOutputs = NULL, dataRows = NULL, materialInputs = NULL, materialOutputs = NULL)
{
    ## check required parameters
    if (missing(config))
        stop (paste("A list of ExpObject config params must be specified in the config parameter."))

    run <- config

    ## validate run properties if provided
    if (!is.null(run$properties) && !is.list(run$properties))
        stop (paste("config properties must be a list of key value pairs."))

    if (!is.null(dataInputs))
    {
        if (!is.list(dataInputs))
            stop (paste("dataInputs must be a list of data objects, see labkey.experiment.createData."))

        ## ensure dataInputs is serialized as an array of objects
        run$dataInputs = ensureNestedList(dataInputs)
    }

    if (!is.null(dataOutputs))
    {
        if (!is.list(dataOutputs))
            stop (paste("dataOutputs must be a list of data objects, see labkey.experiment.createData."))

        run$dataOutputs = ensureNestedList(dataOutputs)
    }

    if (!is.null(materialInputs))
    {
        if (!is.list(materialInputs))
            stop (paste("materialInputs must be a list of material objects, see labkey.experiment.createMaterial."))

        run$materialInputs = ensureNestedList(materialInputs)
    }

    if (!is.null(materialOutputs))
    {
        if (!is.list(materialOutputs))
            stop (paste("materialOutputs must be a list of material objects, see labkey.experiment.createMaterial."))

        run$materialOutputs = ensureNestedList(materialOutputs)
    }

    if (!is.null(dataRows))
    {
        if (!is.data.frame(dataRows))
            stop (paste("dataRows must be a data frame."))

    	## build Assay object tree based on R lists
    	nrows <- nrow(dataRows)
    	ncols <- ncol(dataRows)
    	cnames <- colnames(dataRows)
    	rowsVector <- vector(mode="list", length=nrows)
    	for (j in 1:nrows)
    	{
    		cvalues <- as.list(dataRows[j,])
    		names(cvalues) <- cnames
    		rowsVector[[j]] <- cvalues
    	}

        run$dataRows <- rowsVector
    }
    return (run)
}

## Helper to ensure the passed object is serialized to JSON as an array of objects
##
ensureNestedList <- function(data)
{
    if (is.null(names(data)))
        data
    else
        data <- list(data)

    return (data)
}

labkey.experiment.saveBatch <- function(baseUrl=NULL, folderPath, assayConfig = NULL, protocolName = NULL, batchPropertyList = NULL, runList)
{
    baseUrl=labkey.getBaseUrl(baseUrl)

    ## Validate required parameters
    if (missing(folderPath)) stop (paste("A value must be specified for folderPath."))
    if (missing(runList)) stop (paste("A value must be specified for runList."))

    if (is.null(assayConfig) && is.null(protocolName))
        stop (paste("Either an assay config list or protocolName must be specified. The assay configuration must contain either an assayId or both assayName and providerName"))

	## Now post form with batch object filled out
    url <- labkey.buildURL(baseUrl, "assay", "saveAssayBatch.api", folderPath)

    if (!is.null(assayConfig))
        params = assayConfig
    else if (!is.null(protocolName))
    {
        params = list()
        params$protocolName = protocolName
    }
    params$batch = c(batchPropertyList, list(runs = ensureNestedList(runList)))

    response <- labkey.post(url, toJSON(params, auto_unbox=TRUE))

	return (fromJSON(response, simplifyVector=FALSE, simplifyDataFrame=FALSE))
}

labkey.experiment.saveRuns <- function(baseUrl=NULL, folderPath, protocolName, runList)
{
    baseUrl=labkey.getBaseUrl(baseUrl)

    ## Validate required parameters
    if (missing(folderPath)) stop (paste("A value must be specified for folderPath."))
    if (missing(protocolName)) stop (paste("A value must be specified for protocolName."))
    if (missing(runList)) stop (paste("A value must be specified for runList."))

    ## Now post form with runs object filled out
    url <- labkey.buildURL(baseUrl, "assay", "saveAssayRuns.api", folderPath)

    if (!is.null(runList))
    {
        params = list()
        params$protocolName = protocolName
    }
    params$runs = ensureNestedList(runList)

    response <- labkey.post(url, toJSON(params, auto_unbox=TRUE))

    return (fromJSON(response, simplifyVector=FALSE, simplifyDataFrame=FALSE))
}

## Get lineage parent/child relationships and information for exp objects by LSID(s)
##
## Optional parameters (passed via options) include:
##   parents: (boolean) include parent objects in the lineage
##   children: (boolean) include child objects in the lineage
##   depth: (integer) the depth of the lineage to retrieve
##   expType: the type of experiment objects to retrieve lineage for
##   cpasType: the type of CPAS object to retrieve lineage for
##   runProtocolLsid: the LSID of the run protocol to retrieve lineage for
##   includeProperties: (boolean) include properties in the lineage response
##   includeInputsAndOutputs: (boolean) include inputs and outputs in the lineage response
##   includeRunSteps: (boolean) include run steps in the lineage response
##
labkey.experiment.lineage <- function(baseUrl=NULL, folderPath, lsids, options = NULL)
{
    baseUrl=labkey.getBaseUrl(baseUrl)

    ## check required parameters
    if (missing(folderPath))
        stop (paste("A value must be specified for folderPath."))
    if (missing(lsids))
        stop (paste("A value must be specified for lsids."))
    if (!missing(lsids) & !(is.vector(lsids) && is.atomic(lsids)))
        stop (paste("The lsids parameter must be a vector data structure."))
    if (!missing(options) & !is.list(options))
        stop (paste("The options parameter must be a list data structure."))

    params <- list(lsids=lsids)
    if (!missing(options))
        params <- c(params, options)

    url <- labkey.buildURL(baseUrl, "experiment", "lineage.api", folderPath)
    response <- labkey.post(url, toJSON(params, auto_unbox=TRUE))

    return (fromJSON(response, simplifyVector=FALSE, simplifyDataFrame=FALSE))
}