Diff of /R/simQOutput.R [000000] .. [f2e496]

Switch to side-by-side view

--- 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
+  
+}