--- a +++ b/R/simQOutput.R @@ -0,0 +1,163 @@ +#Contains the functions associated with class SimQOutput for the +#from data part of the project. See class definition below + +##' A class containing the expected (and CI) dates for a specific item of interest +##' +##' For example subject recruitment, events occurring, or subject dropout. +##' Each item of interest will have its own SimQOutput object. This class will +##' be created for the user and does not need to be manually created +##' +##' As an example median[1] is the expected date of the first specific item of interest +##' whereas upper[1] is the upper CI of the first specific item of interest. +##' @slot median A vector of the expected (i.e median) dates +##' of the first, second, ..., item of interest +##' The length of the vector is the total number of this type of item. +##' @slot upper A vector of the expected dates for the upper CI +##' of the first, second, ..., item of interest +##' @slot lower A vector of the expected dates for the lower CI +##' of the first, second, ..., item of interest +##' @seealso \code{\link{simulate,EventModel,missing,missing-method}} \code{\link{FromDataResults-class}} +##' @export +setClass("SimQOutput", + slots=list( + upper="Date", + median="Date", + lower="Date" + ) +) + +# Constructor for \code{SimQOutput} object +# +# See class description for further details +# @param upper A vector of the upper CI dates +# @param median A vector for the median dates +# @param lower A vector for the lower CI dates +# @return A \code{SimQOutput} object +SimQOutput <- function(upper,median,lower){ + + if(length(upper)!= length(median) || length(median) != length(lower)){ + stop("Invalid arguments when creating SimQOutput object") + } + + + new("SimQOutput",upper=upper,median=median,lower=lower) + +} + + +# Create a SimQOutput object from a matrix of (numeric) Dates +# @param details An unsorted matrix with 1 column per subject +# and one row per simulation of numeric Dates +# @param limit limit and 1 - limit will be used as the quantile +# values to be calculated for the lower and upper slot returned SimQOutput object +# @param Nsim The number of rows in \code{details} +# @param event.type An unsorted matrix with 1 column per subject +# and one row per simulation of event.types (integers) +# @param non.inf.event.type Only dates in the details matrix which have event.type= +# non.inf.event.type will be taken into account for the SimQOutput object all others +# will be ignored +# @return A SimQOutput object with the median and quantiles derived from +# the details matrix +SimQOutputFromMatrix <- function(details,limit,Nsim,event.type=NULL,non.inf.event.type=NULL){ + + if(!is.null(event.type)){ + details[event.type!=non.inf.event.type] <- as.Date(Inf,origin="1970-01-01") + } + + times <- apply(details,1,sort) + if(class(times)=="numeric") times <- matrix(times,ncol=Nsim) + times <- apply(times, 1, stats::quantile, prob=c(limit, 0.5, 1-limit)) + + ans <- lapply(1:3,function(x){as.Date(times[x,],origin="1970-01-01")}) + + w <- which(!(ans[[3]]==ans[[2]]& ans[[2]]==ans[[1]] & ans[[1]]==WithdrawnEventDate())) + + SimQOutput( + upper = ans[[3]][w], + median= ans[[2]][w], + lower = ans[[1]][w] + ) +} + + + +##' @name show +##' @rdname show-methods +##' @aliases show,SimQOutput-method +##' @export +setMethod("show", + "SimQOutput", +function(object) { + cat("Lower CI:\n") + cat(str(object@lower)) + cat("\nMedian:\n") + cat(str(object@median)) + cat("\nUpper CI:\n") + cat(str(object@upper)) + cat("\n") +}) + + +# Output the expected time a given number of events occur +# @param event.pred A vector of target event levels +# @param simQ A SimQOutput object (i.e. eventQuantiles slot of WeibullResults) +# @return A data frame containing the median times and confidence intervals for the target event levels +PredictGivenTargetEvents <- function(event.pred,simQ){ + + if(any(event.pred <= 0 || event.pred > length(simQ@median))) + stop("Invalid event.pred value") + + ans <- lapply(event.pred,function(x){ + list(time=simQ@median[x], + event=x, + CI_low=simQ@lower[x], + CI_high=simQ@upper[x]) + }) + + ans <- do.call(rbind.data.frame, ans) + ans$time <- as.Date(ans$time,origin="1970-01-01") + ans$CI_high <- as.Date(ans$CI_high,origin="1970-01-01") + ans$CI_low <- as.Date(ans$CI_low,origin="1970-01-01") + ans +} + +# Output the expected (median) number of events for a given set of dates +# @param time.pred A vector of dates +# @param simQ A SimQOutput object (i.e. eventQuantiles slot of WeibullResults) +# @return A data frame containing the median and confidence intervals for the number of events +# at the requested dates +PredictGivenDates <- function(time.pred,simQ){ + + findEvents <- function(date,event.times){ + if(date < event.times[1]) return(0) + if(date > event.times[length(event.times)]) return (length(event.times)) + + start <- 0 + end <- length(event.times) + + while(end-start>1){ + centre <- floor((start+end)/2) + if(date < event.times[centre]){ + end <- centre + } + else{ + start <- centre + } + } + return(start) + + } + + ans <- lapply(time.pred,function(x){ + list(time=x, + event=findEvents(x,simQ@median), + CI_low=findEvents(x,simQ@upper), #These are the right way round! + CI_high=findEvents(x,simQ@lower) + ) + }) + ans <- do.call(rbind.data.frame, ans) + ans$time <- as.Date(ans$time,origin="1970-01-01") + + ans + +}