Nothing
#' @rdname plot-methods
#' @aliases plot,DepthCurve
#' @export
setMethod("plot", signature = c(x = "DepthCurve"), function(x)
{
plot(new(paste0(class(x),"List"),x))
})
#' @rdname plot-methods
#' @aliases plot,DepthCurveList
#' @export
setMethod("plot", signature = c(x = "DepthCurveList"), function(x)
{
p = getPlot(x)
print(p)
})
#############################################################
setMethod("initialize","DepthCurveList", function(.Object, ...)
{
tmp = list(...)
n = length(tmp)
if(n>0)
{
.Object[[1]] = tmp[[1]]
if(n > 1) for(i in 2:length(tmp)) .Object = .Object %+% tmp[[i]]
}
return(.Object)
})
#######################################################################
#######################################################################
#' @rdname grapes-plus-grapes-methods
#' @aliases grapes-plus-grapes-methods,DepthCurveList,DepthCurve
#' @export
setMethod("%+%", signature(e1 = "DepthCurveList", e2 = "DepthCurve"), function(e1, e2)
{
names = sapply(e1,function(x) x@depth@name)
new_name = e2@depth@name
if(any(new_name == names))
{
warning("Names in DepthCurveList are not unique!")
k = 1
new_name_tmp = paste0(new_name)
while(any(new_name_tmp == names)) { new_name_tmp = paste0(new_name,k); k = k+1}
e2@depth@name = new_name_tmp
}
n = length(e1)
e1[[n+1]] = e2
return(e1)
})
#' @rdname grapes-plus-grapes-methods
#' @aliases grapes-plus-grapes-methods,DepthCurve,DepthCurveList
#' @export
setMethod("%+%", signature(e1 = "DepthCurve", e2 = "DepthCurveList"), function(e1, e2)
{
return(e2 %+% e1)
})
#' @rdname grapes-plus-grapes-methods
#' @aliases grapes-plus-grapes-methods,DepthCurve,DepthCurve
#' @export
setMethod("%+%", signature(e1 = "DepthCurve", e2 = "DepthCurve"), function(e1, e2)
{
return(new(paste0(class(e1),"List"), e1, e2))
})
########################################################################################
setMethod(".getPlot", "DepthCurveList", function(object)
{
value = unlist(object)
alpha = as.vector(sapply(object, function(x) x@alpha))
len_alpha = sapply(object, function(x) length(x@alpha))
names = sapply(object,function(x) x@depth@name)
names = rep(names,len_alpha)
data = data.frame(value, alpha, names)
p = ggplot()
p = p + geom_line(data = data, aes(x = alpha,y = value, col = names), size = 1.5)
p = p + theme_bw() + .depTheme()
p = p + ylim(c(0, max(data$value, na.rm=TRUE)))
p = p + xlim(c(0, max(data$alpha, na.rm=TRUE)))
return(p)
})
########################
#' @rdname as.matrix-methods
#' @aliases as.matrix,DepthCurveList
#' @export
setMethod("as.matrix", signature(x = "DepthCurveList"), function(x)
{
names = sapply(object,function(x) x@depth@name)
tmp = matrix(unlist(object), ncol = length(object))
colnames(tmp) = names
tmp
})
setMethod("show", "DepthCurve", function(object)
{
cat("Object of class:", class(object))
plot(object)
})
setMethod("show", "DepthCurveList", function(object)
{
cat("Object of class:", class(object))
print(getPlot(object))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.