pepkit / BiocProject / 391

pending completion

Build # 391

Build Type

Pull #39

travis-ci

Committed by

web-flow

Commit Message

<a href="https://github.com/pepkit/BiocProject/commit/<a class=hub.com/pepkit/BiocProject/commit/<a class="double-link" href="https://git"><a class=hub.com/pepkit/BiocProject/commit/<a class="double-link" href="https://git"><a class=hub.com/pepkit/BiocProject/commit/<a class="double-link" href="https://git"><a class=hub.com/pepkit/BiocProject/commit/38f906eba47aba9cd2d5b7d8a59c0dbb531c1ce6">38f906eba">&lt;a href=&quot;https://github.com/pepkit/BiocProject/commit/</a><a class="double-link" href="https://github.com/pepkit/BiocProject/commit/&lt;a class=&quot;double-link&quot; href=&quot;https://git">&lt;a class=</a>hub.com/pepkit/BiocProject/commit/&lt;a class=&quot;double-link&quot; href=&quot;https://git">&lt;a class=</a>hub.com/pepkit/BiocProject/commit/&lt;a class=&quot;double-link&quot; href=&quot;https://git">&lt;a class=</a>hub.com/pepkit/BiocProject/commit/&lt;a class=&quot;double-link&quot; href=&quot;https://git">&lt;a class=</a>hub.com/pepkit/BiocProject/commit/38f906eba47aba9cd2d5b7d8a59c0dbb531c1ce6">38f906eba</a><a href="https://github.com/pepkit/BiocProject/commit/38f906eba47aba9cd2d5b7d8a59c0dbb531c1ce6">&quot;&gt;&amp;lt;a href=&amp;quot;https://github.com/pepkit/BiocProject/commit/&lt;/a&gt;&lt;a class=&quot;double-link&quot; href=&quot;https://github.com/pepkit/BiocProject/commit/&amp;lt;a class=&amp;quot;double-link&amp;quot; href=&amp;quot;https://git&quot;&gt;&amp;lt;a class=&lt;/a&gt;hub.com/pepkit/BiocProject/commit/&amp;lt;a class=&amp;quot;double-link&amp;quot; href=&amp;quot;https://git&quot;&gt;&amp;lt;a class=&lt;/a&gt;hub.com/pepkit/BiocProject/commit/&amp;lt;a class=&amp;quot;double-link&amp;quot; href=&amp;quot;https://git&quot;&gt;&amp;lt;a class=&lt;/a&gt;hub.com/pepkit/BiocProject/commit/&amp;lt;a class=&amp;quot;double-link&amp;quot; href=&amp;quot;https://git&quot;&gt;&amp;lt;a class=&lt;/a&gt;hub.com/pepkit/BiocProject/commit/38f906eba47aba9cd2d5b7d8a59c0dbb531c1ce6&quot;&gt;38f906eba&lt;/a&gt;&lt;a href=&quot;https://github.com/pepkit/BiocProject/commit/38f906eba47aba9cd2d5b7d8a59c0dbb531c1ce6&quot;&gt;&amp;quot;&amp;gt;&amp;amp;lt;a href=&amp;amp;quot;https://github.com/pepkit/BiocProject/commit/&amp;lt;/a&amp;gt;&amp;lt;a class=&amp;quot;double-link&amp;quot; href=&amp;quot;https://github.com/pepkit/BiocProject/comm... (continued)

Pull Request Pull Request #39: v0.2.1

Run Details

339 of 339 new or added lines in 4 files covered. (100.0%)

340 of 413 relevant lines covered (82.32%)

8.91 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

81.52

/R/utils.R

#' Determine whether the string is a valid URL
#'
#' @param str string to inspect
#'
#' @return logical indicating whether a string is a valid URL
.isValidUrl = function(str) {
    ans = FALSE
    if (grepl("www.|http:|https:", 
        str)) {
        ans = RCurl::url.exists(str)
    }
    ans
}

#' Read a YAML-formatted schema
#' 
#' Remote or local schemas are supported
#'
#' @param path path to a local schema or URL pointing to a remote one 
#' @param parent a path to parent folder to use
#' @return list read schema
#' @export
#' @importFrom RCurl getURLContent
#' @examples
#' readSchema('https://schema.databio.org/pep/2.0.0.yaml')
readSchema = function(path, parent = NULL) {
    if (.isValidUrl(path)) 
        return(yaml::yaml.load(getURLContent(path)))
    file = pepr::.makeAbsPath(path, 
        parent)
    if (file.exists(file)) {
        return(yaml::read_yaml(file))
    }
    stop(paste0("Schema has to be either a valid URL or an existing path. ", 
        "Got: ", path))
}

#' Switch from python to R list accession syntax
#' 
#' Python uses a dot to access attributes, while R uses \code{$}; this function
#' converts the python style into R so that we can use R code to populate
#' variables with R lists. From this: '\code{{sample.name}}' 
#' to this: '\code{{sample$name}}'
#' @param str String to recode
#' @return string with the recoded accession syntax
#' @export
#' @examples 
#' .pyToR('{sample.genome}/{sample.read_type}/test')
.pyToR = function(str) {
    # This is the regex where the
    # magic happens
    pytor = function(str) gsub("(\\{[^\\.\\}]+)\\.", 
        "\\1$", str)
    # This loop allows multi-layer
    # accession
    res = str
    prev = ""
    while (prev != res) {
        prev = res
        res = pytor(res)
    }
    return(res)
}

#' Populate a variable-encoded string with sample/project variables
#' 
#' Given a string and a project this function will go through samples and 
#' populate the variables. Used to return real files for each sample from an 
#' output variable in the pipeline interface
#' 
#' @param string Variable-encoded string to populate
#' @param project \code{\link[pepr]{Project-class}} object with values 
#'  to draw from
#' @param sampleName string, name of the sample to use
#' @param projectContext logical indicating whether project context should be 
#' applied for string formatting. Default: sample
#' 
#' @return a named list of populated strings
#' @importFrom glue glue
.populateString = function(string, 
    project, sampleName = NULL, 
    projectContext = FALSE) {
    # Apply this glue function on
    # each row in the samples
    # table, coerced to a list
    # object to allow attribute
    # accession.
    samplesSubset = subset(sampleTable(project), 
        sample_name == sampleName)
    if (!projectContext && NROW(samplesSubset) < 
        1) 
        return(invisible(NULL))
    if (projectContext) {
        populatedStrings = with(config(project), 
            glue(.pyToR(string)))
    } else {
        populatedStrings = as.list(apply(samplesSubset, 
            1, function(s) {
                return(with(s, 
                  glue(.pyToR(string))))
            }))
    }
    if (!projectContext && length(populatedStrings) != 
        NROW(samplesSubset)) {
        warning("Paths templates populating problem: number of paths (", 
            length(populatedStrings), 
            ") does not correspond to the number of samples (", 
            NROW(samplesSubset), 
            "). Path template '", 
            string, "' will not be populated")
        return(invisible(NULL))
    }
    names(populatedStrings) = unlist(samplesSubset$sample_name)
    return(populatedStrings)
}

#' Insert a PEP metadata in a metadata slot of Annotated
#' 
#' This function inserts the PEP (\code{\link[pepr]{Project-class}}) 
#' into the metadata slot of objects that 
#' extend the \code{\link[S4Vectors]{Annotated-class}}
#' 
#' Additionally, if the object extends the 
#' \code{\link[S4Vectors]{Annotated-class}} (or is a list that will be
#' automatically converted to a \code{\link[S4Vectors]{List}}) the show method 
#' for its class is redefined to display the \code{\link[pepr]{Project-class}} 
#' as the metadata.
#' 
#' @param object an object of \code{\link[S4Vectors]{Annotated-class}}
#' @param pep an object of class \code{\link[pepr]{Project-class}}
#' 
#' @return an object of the same class as the object argument but enriched
#'  with the metadata from the pep argument
#' 
#' @examples 
#' # If the object is of class Annotated
#' object = S4Vectors::List(result='test')
#' result = .insertPEP(object, pepr::Project())
#' metadata(result)
#' 
#' # If the object is not of class Annotated
#' object1 = 'test'
#' result1 = .insertPEP(object1, pepr::Project())
#' metadata(result1)
#' @import S4Vectors methods
#' @export
.insertPEP = function(object, pep) {
    if (!methods::is(pep, "Project")) 
        stop("the pep argument has to be of class 'Project', 
             got '", 
            class(pep), "'")
    # do we throw a warning/message
    # saying what happens in the
    # next line?
    if (methods::is(object, "list")) 
        object = S4Vectors::List(object)
    if (methods::is(object, "Annotated")) {
        S4Vectors::metadata(object) = .unionList(S4Vectors::metadata(object), 
                                                 list(PEP = pep))
    } else {
        warning("BiocProject expects data loading functions to return an 
                'Annotated' object, but your function returned a '", 
            class(object), "' object. Therefore, this returned object has", 
            "been placed in the first slot of a S4Vectors::List")
        result = S4Vectors::List(result = object)
        S4Vectors::metadata(result) = list(PEP = pep)
        object = result
    }
    .setShowMethod(object)
    object
}


#' Get the preferred source of the bioconductor section
#'
#' @param p \code{\link[pepr]{Project-class}} object
#' @param projectLevel logical indicating whether a only project-level pifaces 
#'  should be considered. Otherwise, only sample-level ones are. 
#'
#' @return a list with the selected config
#' @importFrom pepr checkSection config
#' @importFrom methods new
.getBiocConfig = function(p, projectLevel = FALSE) {
    if (checkSection(config(p), 
        BIOC_SECTION)) {
        # if the BIOC_SECTION section
        # is found in the project
        # config, override any other
        # locations
        message("The '", BIOC_SECTION, 
            "' key found in the Project config")
        return(config(p))
    }
    # check for BIOC_SECTION in
    # pipeline interfaces
    pifaceSource = gatherPipelineInterfaces(p, 
        projectLevel = projectLevel)
    if (length(pifaceSource) > 
        0) {
        pifaceSource = pifaceSource[1]
        message("Muliple pipeline interface sources matched.", 
            " Using the first one: ", 
            pifaceSource)
    }
    
    
    if (!is.null(pifaceSource)) {
        piface = yaml::read_yaml(pifaceSource)
        if (pepr::.checkSection(piface, 
            BIOC_SECTION)) {
            message("The '", BIOC_SECTION, 
                "' key found in the pipeline interface")
            return(.makeReadFunPathAbs(piface, 
                parent = dirname(pifaceSource)))
        } else {
            warning("The '", BIOC_SECTION, 
                "' key is missing in Project config and pipeline interface")
            return(invisible(NULL))
        }
    } else {
        warning("The '", BIOC_SECTION, 
            "' key is missing in Project config and pipeline interface")
        return(invisible(NULL))
    }
}

#' Make readFunPath absolute
#' 
#' Uses the absolute pipeline interface path in the config to determine the
#' absolute path to the readFunPath file that consists of the data 
#' processing function
#'
#' @param piface \code{\link[pepr]{Config-class}}/list with a pipeline interface
#' @param parent a path to parent folder to use
#'
#' @return piface \code{\link[pepr]{Config-class}} pipeline interface with 
#' the readFunPath made absolute
.makeReadFunPathAbs = function(piface, 
    parent) {
    pth = piface[[BIOC_SECTION]][[FUNCTION_PATH]]
    absReadFunPath = .makeAbsPath(pth, 
        parent)
    if (!.isAbsolute(absReadFunPath)) 
        stop("Failed to make the readFunPath absolute: ", 
            absReadFunPath)
    piface[[BIOC_SECTION]][[FUNCTION_PATH]] = absReadFunPath
    piface
}


# internal function used for
# wrapping the user-supplied
# function meessages in a box
.wrapFunMessages = function(messages, 
    type) {
    n = options("width")[[1]]
    header = ifelse(length(messages) > 
        1, paste0(" Your function ", 
        type, "s (", length(messages), 
        ") "), paste0(" Your function ", 
        type, " "))
    nH = floor(nchar(header)/2)
    nFill = floor(n/2)
    message("\n", rep("-", nFill - 
        nH), header, rep("-", nFill - 
        nH))
    i = 1
    for (i in seq_along(messages)) {
        m = trimws(messages[i], 
            which = "both")
        message("\n", type, " ", 
            i, ": ", m, "\n")
    }
    message(rep("-", n), "\n")
}

# internal function that wraps
# the external function
# execution in tryCatch to
# indicate problems with the
# external function execution
.callBiocFun <- function(func, 
    arguments) {
    if (!is(arguments, "list")) 
        stop("The 'arguments' argument has to be a list, got '", 
            class(arguments), "'")
    .warnings = c()
    frameNumber <- sys.nframe()
    wHandler <- function(w) {
        # warning handler
        assign(".warnings", append(.warnings, 
            w$message), envir = sys.frame(frameNumber))
        invokeRestart("muffleWarning")
    }
    eHandler <- function(e) {
        # error handler
        .wrapFunMessages(e$message, 
            "error")
        message("No data was read. The error message was returned instead.")
        S4Vectors::List(errorMessage = e$message, 
            errorSource = e$call)
    }
    res = withCallingHandlers(tryCatch(do.call(func, 
        arguments), error = eHandler), 
        warning = wHandler)
    if (length(.warnings) > 0) {
        warning("There were warnings associated with your function execution.")
        .wrapFunMessages(.warnings, 
            "warning")
    }
    return(res)
}

#' Create an absolute path from a primary target and a parent candidate.
#'
#' @param perhapsRelative Path to primary target directory.
#' @param parent a path to parent folder to use if target isn't absolute.
#'
#' @return Target itself if already absolute, else target nested within parent.
.makeAbsPath = function(perhapsRelative, 
    parent) {
    if (!.isDefined(perhapsRelative)) 
        return(perhapsRelative)
    perhapsRelative = pepr::.expandPath(perhapsRelative)
    if (.isAbsolute(perhapsRelative)) {
        abspath = perhapsRelative
    } else {
        abspath = file.path(normalizePath(parent), 
            perhapsRelative)
    }
    if (!.isAbsolute(abspath)) {
        errmsg = sprintf("Relative path '%s' and parent '%s' failed to create
        absolute path: '%s'", 
            perhapsRelative, parent, 
            abspath)
        stop(errmsg)
    }
    return(abspath)
}

# Must test for is.null first,
# since is.na(NULL) returns a
# logical(0) which is not a
# boolean
.isDefined = function(var) {
    !(is.null(var) || is.na(var))
}


# Determine whether a path is
# absolute.  @param path The
# path to check for seeming
# absolute-ness.  @return Flag
# indicating whether the
# \code{path} appears to be
# absolute.
.isAbsolute = function(path) {
    if (!is.character(path)) 
        stop("The path must be character.")
    firstChar = substr(path, 1, 
        1)
    return(identical("/", firstChar) | 
        identical("~", firstChar))
}

#' Update list with another list
#'
#' This function performs a union of two lists and updates the elements of the 
#' first one if are found in the other one. 
#' 
#' Both elements have to be lists. If some elements are not named, they are 
#' preserved but the order might be lost.
#' 
#' @param list1 a list to be updated
#' @param list2 a list to update with
#' @param combine a logical indicating whether the elements of the second list 
#' should replace (\code{FALSE}, default) or append to (\code{TRUE}) the 
#' first one.
#' 
#' @return an updated list
#' 
#' @examples 
#' list1=list(a=1,b=2)
#' list2=list(a=1,b=1,c=3)
#' .unionList(list1,list2)
#' 
#' @export
.unionList = function(list1, list2, 
    combine = FALSE) {
    if ((!is.list(list1)) || (!is.list(list2))) 
        stop("One of the arguments is not a list")
    nms1 = names(list1)
    nms2 = names(list2)
    if (is.null(nms2)) 
        nms2 = ""
    counter = 1
    for (n in nms2) {
        idx = which(nms1 == n)
        if (length(idx) > 0) {
            if (combine) {
                list1[[idx]] = append(list1[[idx]], 
                  list2[[n]])
            } else {
                list1[[idx]] = list2[[n]]
            }
        } else {
            add = list(list2[[counter]])
            names(add) = n
            list1 = append(list1, 
                add)
        }
        counter = counter + 1
    }
    return(list1)
}

# Finds the pepr::Project
# object in a list and returns
# its index If it is not
# present, returns integer(0)
.findProjectInList = function(l) {
    which(as.logical(lapply(l, 
        function(x) {
            is(x, "Project")
        })))
}

#' Redefine the show method of the object
#' 
#' Adds the Project objects display to the default show method 
#' of an \code{\link[S4Vectors]{Annotated-class}}
#' 
#' The method is defined in the environment in which the function was called, 
#' see: \code{\link[base]{sys.parent}}
#' 
#' @param returnedObject object of \code{\link[S4Vectors]{Annotated-class}}
#' 
#' @return \code{FALSE} if the function was not set
#'
#' @export
#'
#' @examples
#' x = S4Vectors::List(c('so','cool'))
#' metadata(x) = list(PEP=pepr::Project())
#' .setShowMethod(x)
#' x
.setShowMethod = function(returnedObject) {
    oriClass = class(returnedObject)
    if (!is(returnedObject, "Annotated")) {
        warning("The show method was not redefined for '", 
            oriClass, "'")
        return(FALSE)
    }
    oriShow = selectMethod("show", 
        oriClass)
    # the new method is created
    # only if the environment of
    # the original one is locked.
    # this way the method will not
    # be redefined over and over
    # again when the BiocProject
    # functon is called.
    if (environmentIsLocked(environment(oriShow))) 
        setMethod("show", signature = oriClass, 
            definition = function(object) {
                do.call(oriShow, 
                  list(object))
                pep = getProject(object)
                cat("\nmetadata: ")
                selectMethod("show", 
                  "Project")(pep)
            }, where = parent.frame())
}

#' Make all paths absolute by parent dir
#'
#' @param paths path to make absolute 
#' @param parent parent directory
#'
#' @return string, a path amde absolute
.mkPathsAbs <- function(paths, 
    parent) {
    return(as.vector(vapply(paths, 
        function(x) {
            pepr::.makeAbsPath(x, 
                parent)
        }, character(1))))
}

.checkPifaceType <- function(piface, 
    type) {
    if (!pepr::.checkSection(piface, 
        PIP_TYPE_KEY) || piface[[PIP_TYPE_KEY]] != 
        type) {
        warning(sprintf("%s pipeline interface has to specify '%s' pipeline type in '%s'", 
            type, type, PIP_TYPE_KEY))
        return(FALSE)
    }
    return(TRUE)
}

1	#' Determine whether the string is a valid URL
2	#'
3	#' @param str string to inspect
4	#'
5	#' @return logical indicating whether a string is a valid URL
6	.isValidUrl = function(str) {
7	ans = FALSE	20✔
8	if (grepl("www.\|http:\|https:",	20✔
9	str)) {	20✔
10	ans = RCurl::url.exists(str)	×
11	}
12	ans	20✔
13	}
14
15	#' Read a YAML-formatted schema
16	#'
17	#' Remote or local schemas are supported
18	#'
19	#' @param path path to a local schema or URL pointing to a remote one
20	#' @param parent a path to parent folder to use
21	#' @return list read schema
22	#' @export
23	#' @importFrom RCurl getURLContent
24	#' @examples
25	#' readSchema('https://schema.databio.org/pep/2.0.0.yaml')
26	readSchema = function(path, parent = NULL) {
27	if (.isValidUrl(path))	20✔
28	return(yaml::yaml.load(getURLContent(path)))	×
29	file = pepr::.makeAbsPath(path,	20✔
30	parent)	20✔
31	if (file.exists(file)) {	20✔
32	return(yaml::read_yaml(file))	20✔
33	}
34	stop(paste0("Schema has to be either a valid URL or an existing path. ",	×
35	"Got: ", path))	×
36	}
37
38	#' Switch from python to R list accession syntax
39	#'
40	#' Python uses a dot to access attributes, while R uses \code{$}; this function
41	#' converts the python style into R so that we can use R code to populate
42	#' variables with R lists. From this: '\code{{sample.name}}'
43	#' to this: '\code{{sample$name}}'
44	#' @param str String to recode
45	#' @return string with the recoded accession syntax
46	#' @export
47	#' @examples
48	#' .pyToR('{sample.genome}/{sample.read_type}/test')
49	.pyToR = function(str) {
50	# This is the regex where the
51	# magic happens
52	pytor = function(str) gsub("(\\{[^\\.\\}]+)\\.",	40✔
53	"\\1$", str)	40✔
54	# This loop allows multi-layer
55	# accession
56	res = str	40✔
57	prev = ""	40✔
58	while (prev != res) {	40✔
59	prev = res	40✔
60	res = pytor(res)	40✔
61	}
62	return(res)	40✔
63	}
64
65	#' Populate a variable-encoded string with sample/project variables
66	#'
67	#' Given a string and a project this function will go through samples and
68	#' populate the variables. Used to return real files for each sample from an
69	#' output variable in the pipeline interface
70	#'
71	#' @param string Variable-encoded string to populate
72	#' @param project \code{\link[pepr]{Project-class}} object with values
73	#' to draw from
74	#' @param sampleName string, name of the sample to use
75	#' @param projectContext logical indicating whether project context should be
76	#' applied for string formatting. Default: sample
77	#'
78	#' @return a named list of populated strings
79	#' @importFrom glue glue
80	.populateString = function(string,
81	project, sampleName = NULL,
82	projectContext = FALSE) {
83	# Apply this glue function on
84	# each row in the samples
85	# table, coerced to a list
86	# object to allow attribute
87	# accession.
88	samplesSubset = subset(sampleTable(project),	40✔
89	sample_name == sampleName)	40✔
90	if (!projectContext && NROW(samplesSubset) <	40✔
91	1)	40✔
92	return(invisible(NULL))	×
93	if (projectContext) {	40✔
94	populatedStrings = with(config(project),	4✔
95	glue(.pyToR(string)))	4✔
96	} else {
97	populatedStrings = as.list(apply(samplesSubset,	36✔
98	1, function(s) {	36✔
99	return(with(s,	36✔
100	glue(.pyToR(string))))	36✔
101	}))
102	}
103	if (!projectContext && length(populatedStrings) !=	40✔
104	NROW(samplesSubset)) {	40✔
105	warning("Paths templates populating problem: number of paths (",	×
106	length(populatedStrings),	×
107	") does not correspond to the number of samples (",	×
108	NROW(samplesSubset),	×
109	"). Path template '",	×
110	string, "' will not be populated")	×
111	return(invisible(NULL))	×
112	}
113	names(populatedStrings) = unlist(samplesSubset$sample_name)	40✔
114	return(populatedStrings)	40✔
115	}
116
117	#' Insert a PEP metadata in a metadata slot of Annotated
118	#'
119	#' This function inserts the PEP (\code{\link[pepr]{Project-class}})
120	#' into the metadata slot of objects that
121	#' extend the \code{\link[S4Vectors]{Annotated-class}}
122	#'
123	#' Additionally, if the object extends the
124	#' \code{\link[S4Vectors]{Annotated-class}} (or is a list that will be
125	#' automatically converted to a \code{\link[S4Vectors]{List}}) the show method
126	#' for its class is redefined to display the \code{\link[pepr]{Project-class}}
127	#' as the metadata.
128	#'
129	#' @param object an object of \code{\link[S4Vectors]{Annotated-class}}
130	#' @param pep an object of class \code{\link[pepr]{Project-class}}
131	#'
132	#' @return an object of the same class as the object argument but enriched
133	#' with the metadata from the pep argument
134	#'
135	#' @examples
136	#' # If the object is of class Annotated
137	#' object = S4Vectors::List(result='test')
138	#' result = .insertPEP(object, pepr::Project())
139	#' metadata(result)
140	#'
141	#' # If the object is not of class Annotated
142	#' object1 = 'test'
143	#' result1 = .insertPEP(object1, pepr::Project())
144	#' metadata(result1)
145	#' @import S4Vectors methods
146	#' @export
147	.insertPEP = function(object, pep) {
148	if (!methods::is(pep, "Project"))	15✔
149	stop("the pep argument has to be of class 'Project',	1✔
150	got '",	1✔
151	class(pep), "'")	1✔
152	# do we throw a warning/message
153	# saying what happens in the
154	# next line?
155	if (methods::is(object, "list"))	14✔
156	object = S4Vectors::List(object)	×
157	if (methods::is(object, "Annotated")) {	14✔
158	S4Vectors::metadata(object) = .unionList(S4Vectors::metadata(object),	12✔
159	list(PEP = pep))	12✔
160	} else {
161	warning("BiocProject expects data loading functions to return an	2✔
162	'Annotated' object, but your function returned a '",	2✔
163	class(object), "' object. Therefore, this returned object has",	2✔
164	"been placed in the first slot of a S4Vectors::List")	2✔
165	result = S4Vectors::List(result = object)	2✔
166	S4Vectors::metadata(result) = list(PEP = pep)	2✔
167	object = result	2✔
168	}
169	.setShowMethod(object)	14✔
170	object	14✔
171	}
172
173
174	#' Get the preferred source of the bioconductor section
175	#'
176	#' @param p \code{\link[pepr]{Project-class}} object
177	#' @param projectLevel logical indicating whether a only project-level pifaces
178	#' should be considered. Otherwise, only sample-level ones are.
179	#'
180	#' @return a list with the selected config
181	#' @importFrom pepr checkSection config
182	#' @importFrom methods new
183	.getBiocConfig = function(p, projectLevel = FALSE) {
184	if (checkSection(config(p),	17✔
185	BIOC_SECTION)) {	17✔
186	# if the BIOC_SECTION section
187	# is found in the project
188	# config, override any other
189	# locations
190	message("The '", BIOC_SECTION,	14✔
191	"' key found in the Project config")	14✔
192	return(config(p))	14✔
193	}
194	# check for BIOC_SECTION in
195	# pipeline interfaces
196	pifaceSource = gatherPipelineInterfaces(p,	3✔
197	projectLevel = projectLevel)	3✔
198	if (length(pifaceSource) >	3✔
199	0) {	3✔
200	pifaceSource = pifaceSource[1]	2✔
201	message("Muliple pipeline interface sources matched.",	2✔
202	" Using the first one: ",	2✔
203	pifaceSource)	2✔
204	}
205
206
207	if (!is.null(pifaceSource)) {	3✔
208	piface = yaml::read_yaml(pifaceSource)	2✔
209	if (pepr::.checkSection(piface,	2✔
210	BIOC_SECTION)) {	2✔
211	message("The '", BIOC_SECTION,	2✔
212	"' key found in the pipeline interface")	2✔
213	return(.makeReadFunPathAbs(piface,	2✔
214	parent = dirname(pifaceSource)))	2✔
215	} else {
216	warning("The '", BIOC_SECTION,	×
217	"' key is missing in Project config and pipeline interface")	×
218	return(invisible(NULL))	×
219	}
220	} else {
221	warning("The '", BIOC_SECTION,	1✔
222	"' key is missing in Project config and pipeline interface")	1✔
223	return(invisible(NULL))	1✔
224	}
225	}
226
227	#' Make readFunPath absolute
228	#'
229	#' Uses the absolute pipeline interface path in the config to determine the
230	#' absolute path to the readFunPath file that consists of the data
231	#' processing function
232	#'
233	#' @param piface \code{\link[pepr]{Config-class}}/list with a pipeline interface
234	#' @param parent a path to parent folder to use
235	#'
236	#' @return piface \code{\link[pepr]{Config-class}} pipeline interface with
237	#' the readFunPath made absolute
238	.makeReadFunPathAbs = function(piface,
239	parent) {
240	pth = piface[[BIOC_SECTION]][[FUNCTION_PATH]]	2✔
241	absReadFunPath = .makeAbsPath(pth,	2✔
242	parent)	2✔
243	if (!.isAbsolute(absReadFunPath))	2✔
244	stop("Failed to make the readFunPath absolute: ",	×
245	absReadFunPath)	×
246	piface[[BIOC_SECTION]][[FUNCTION_PATH]] = absReadFunPath	2✔
247	piface	2✔
248	}
249
250
251	# internal function used for
252	# wrapping the user-supplied
253	# function meessages in a box
254	.wrapFunMessages = function(messages,
255	type) {
256	n = options("width")[[1]]	5✔
257	header = ifelse(length(messages) >	5✔
258	1, paste0(" Your function ",	5✔
259	type, "s (", length(messages),	5✔
260	") "), paste0(" Your function ",	5✔
261	type, " "))	5✔
262	nH = floor(nchar(header)/2)	5✔
263	nFill = floor(n/2)	5✔
264	message("\n", rep("-", nFill -	5✔
265	nH), header, rep("-", nFill -	5✔
266	nH))	5✔
267	i = 1	5✔
268	for (i in seq_along(messages)) {	5✔
269	m = trimws(messages[i],	5✔
270	which = "both")	5✔
271	message("\n", type, " ",	5✔
272	i, ": ", m, "\n")	5✔
273	}
274	message(rep("-", n), "\n")	5✔
275	}
276
277	# internal function that wraps
278	# the external function
279	# execution in tryCatch to
280	# indicate problems with the
281	# external function execution
282	.callBiocFun <- function(func,
283	arguments) {
284	if (!is(arguments, "list"))	17✔
285	stop("The 'arguments' argument has to be a list, got '",	1✔
286	class(arguments), "'")	1✔
287	.warnings = c()	16✔
288	frameNumber <- sys.nframe()	16✔
289	wHandler <- function(w) {	16✔
290	# warning handler
291	assign(".warnings", append(.warnings,	1✔
292	w$message), envir = sys.frame(frameNumber))	1✔
293	invokeRestart("muffleWarning")	1✔
294	}
295	eHandler <- function(e) {	16✔
296	# error handler
297	.wrapFunMessages(e$message,	4✔
298	"error")	4✔
299	message("No data was read. The error message was returned instead.")	4✔
300	S4Vectors::List(errorMessage = e$message,	4✔
301	errorSource = e$call)	4✔
302	}
303	res = withCallingHandlers(tryCatch(do.call(func,	16✔
304	arguments), error = eHandler),	16✔
305	warning = wHandler)	16✔
306	if (length(.warnings) > 0) {	16✔
307	warning("There were warnings associated with your function execution.")	1✔
308	.wrapFunMessages(.warnings,	1✔
309	"warning")	1✔
310	}
311	return(res)	16✔
312	}
313
314	#' Create an absolute path from a primary target and a parent candidate.
315	#'
316	#' @param perhapsRelative Path to primary target directory.
317	#' @param parent a path to parent folder to use if target isn't absolute.
318	#'
319	#' @return Target itself if already absolute, else target nested within parent.
320	.makeAbsPath = function(perhapsRelative,
321	parent) {
322	if (!.isDefined(perhapsRelative))	5✔
323	return(perhapsRelative)	×
324	perhapsRelative = pepr::.expandPath(perhapsRelative)	5✔
325	if (.isAbsolute(perhapsRelative)) {	5✔
326	abspath = perhapsRelative	3✔
327	} else {
328	abspath = file.path(normalizePath(parent),	2✔
329	perhapsRelative)	2✔
330	}
331	if (!.isAbsolute(abspath)) {	5✔
332	errmsg = sprintf("Relative path '%s' and parent '%s' failed to create	×
333	absolute path: '%s'",	×
334	perhapsRelative, parent,	×
335	abspath)	×
336	stop(errmsg)	×
337	}
338	return(abspath)	5✔
339	}
340
341	# Must test for is.null first,
342	# since is.na(NULL) returns a
343	# logical(0) which is not a
344	# boolean
345	.isDefined = function(var) {
346	!(is.null(var) \|\| is.na(var))	9✔
347	}
348
349
350	# Determine whether a path is
351	# absolute. @param path The
352	# path to check for seeming
353	# absolute-ness. @return Flag
354	# indicating whether the
355	# \code{path} appears to be
356	# absolute.
357	.isAbsolute = function(path) {
358	if (!is.character(path))	15✔
359	stop("The path must be character.")	×
360	firstChar = substr(path, 1,	15✔
361	1)	15✔
362	return(identical("/", firstChar) \|	15✔
363	identical("~", firstChar))	15✔
364	}
365
366	#' Update list with another list
367	#'
368	#' This function performs a union of two lists and updates the elements of the
369	#' first one if are found in the other one.
370	#'
371	#' Both elements have to be lists. If some elements are not named, they are
372	#' preserved but the order might be lost.
373	#'
374	#' @param list1 a list to be updated
375	#' @param list2 a list to update with
376	#' @param combine a logical indicating whether the elements of the second list
377	#' should replace (\code{FALSE}, default) or append to (\code{TRUE}) the
378	#' first one.
379	#'
380	#' @return an updated list
381	#'
382	#' @examples
383	#' list1=list(a=1,b=2)
384	#' list2=list(a=1,b=1,c=3)
385	#' .unionList(list1,list2)
386	#'
387	#' @export
388	.unionList = function(list1, list2,
389	combine = FALSE) {
390	if ((!is.list(list1)) \|\| (!is.list(list2)))	19✔
391	stop("One of the arguments is not a list")	1✔
392	nms1 = names(list1)	18✔
393	nms2 = names(list2)	18✔
394	if (is.null(nms2))	18✔
395	nms2 = ""	1✔
396	counter = 1	18✔
397	for (n in nms2) {	18✔
398	idx = which(nms1 == n)	23✔
399	if (length(idx) > 0) {	23✔
400	if (combine) {	4✔
401	list1[[idx]] = append(list1[[idx]],	×
402	list2[[n]])	×
403	} else {
404	list1[[idx]] = list2[[n]]	4✔
405	}
406	} else {
407	add = list(list2[[counter]])	19✔
408	names(add) = n	19✔
409	list1 = append(list1,	19✔
410	add)	19✔
411	}
412	counter = counter + 1	23✔
413	}
414	return(list1)	18✔
415	}
416
417	# Finds the pepr::Project
418	# object in a list and returns
419	# its index If it is not
420	# present, returns integer(0)
421	.findProjectInList = function(l) {
422	which(as.logical(lapply(l,	9✔
423	function(x) {	9✔
424	is(x, "Project")	15✔
425	})))
426	}
427
428	#' Redefine the show method of the object
429	#'
430	#' Adds the Project objects display to the default show method
431	#' of an \code{\link[S4Vectors]{Annotated-class}}
432	#'
433	#' The method is defined in the environment in which the function was called,
434	#' see: \code{\link[base]{sys.parent}}
435	#'
436	#' @param returnedObject object of \code{\link[S4Vectors]{Annotated-class}}
437	#'
438	#' @return \code{FALSE} if the function was not set
439	#'
440	#' @export
441	#'
442	#' @examples
443	#' x = S4Vectors::List(c('so','cool'))
444	#' metadata(x) = list(PEP=pepr::Project())
445	#' .setShowMethod(x)
446	#' x
447	.setShowMethod = function(returnedObject) {
448	oriClass = class(returnedObject)	14✔
449	if (!is(returnedObject, "Annotated")) {	14✔
450	warning("The show method was not redefined for '",	×
451	oriClass, "'")	×
452	return(FALSE)	×
453	}
454	oriShow = selectMethod("show",	14✔
455	oriClass)	14✔
456	# the new method is created
457	# only if the environment of
458	# the original one is locked.
459	# this way the method will not
460	# be redefined over and over
461	# again when the BiocProject
462	# functon is called.
463	if (environmentIsLocked(environment(oriShow)))	14✔
464	setMethod("show", signature = oriClass,	3✔
465	definition = function(object) {	3✔
466	do.call(oriShow,	×
467	list(object))	×
468	pep = getProject(object)	×
469	cat("\nmetadata: ")	×
470	selectMethod("show",	×
471	"Project")(pep)	×
472	}, where = parent.frame())	3✔
473	}
474
475	#' Make all paths absolute by parent dir
476	#'
477	#' @param paths path to make absolute
478	#' @param parent parent directory
479	#'
480	#' @return string, a path amde absolute
481	.mkPathsAbs <- function(paths,
482	parent) {
483	return(as.vector(vapply(paths,	23✔
484	function(x) {	23✔
485	pepr::.makeAbsPath(x,	38✔
486	parent)	38✔
487	}, character(1))))	23✔
488	}
489
490	.checkPifaceType <- function(piface,
491	type) {
492	if (!pepr::.checkSection(piface,	20✔
493	PIP_TYPE_KEY) \|\| piface[[PIP_TYPE_KEY]] !=	20✔
494	type) {	20✔
495	warning(sprintf("%s pipeline interface has to specify '%s' pipeline type in '%s'",	×
496	type, type, PIP_TYPE_KEY))	×
497	return(FALSE)	×
498	}
499	return(TRUE)	20✔
500	}

pepkit / BiocProject / 391

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous