#This file contains the private functions

#for the predict from data part of the package

#apart from those used within the simulate function

#see fromDataSimInternal.R. For functions called by 

#AddTimeColumn see timeInternal.R

##'@include common.R simQOutput.R timeInternal.R

NULL

# Deal with subjects who have time = 0 or NA when creating 

# the EventData object

# 

# @param remove.0.time logical if TRUE then all subjects with time = NA or 0 are removed from the

# data set and not included in the object. If FALSE then they are included in the simulation 

# (but not in the model fitting)

# @param subject.data A data frame to be included in the subject.data slot 

# of the EventData object

# @return subject.data with appropriate subjects removed/time set to 0

warnNAtime <- function(remove.0.time,subject.data){

  if(!is.logical(remove.0.time) || length(remove.0.time) > 1){

    stop("Invalid remove.0.time argument")

  }

  index <- which(subject.data$time==0 | is.na(subject.data$time))

  if(length(index)==0){

    return(subject.data)

  }

  if(remove.0.time){

    warning(paste("Subjects",paste(subject.data[index,]$subject,collapse=", "),"have time=NA or 0",

                  "and have been removed from the data set."))

    subject.data <- subject.data[!1:nrow(subject.data) %in% index,] 

  }

  else{

    warning(paste("Subjects", paste(subject.data[index,]$subject, collapse=", "),

                  "have time=NA or 0, their time has been set to 0 and",

                  "they will not be used when fitting the model but will have event times simulated",

                  "when performing the predictions unless withdrawn is set to 1."))

    subject.data$time[is.na(subject.data$time)] <- 0

  }

  subject.data

}

# Get the multiplicative factor to convert units to

# days for the KM-plot

# @param units "Days", "Months" or "Years"

# @param daysinyear The number of days in a year (e.g. 365 or 365.25)

# @return 1, daysinyear/12 or daysinyear respectively

GetScaleForKM <- function(units,daysinyear){

  if(!units %in% c("Days","Months","Years")){

    stop("Invalid units argument")

  }

  xscale <- 1

  if(units == "Months") xscale <- daysinyear/12

  if(units == "Years") xscale <- daysinyear

  return(xscale)

}

# Function which inputs a vector of dates/strings

# and outputs a vector of dates

# 

# If S3 dates are input they are returned unchanged.

# If character strings are input then they must all

# have the same format either "YYYY-MM-DD", "DD/MM/YYYY"

# or "DD Month YYYY"

# 

# @param vec The vector of characters

# @return a vector of Dates.

# If conversion fails an error is thrown

FixDates <- function(vec){

   if(all(is.na(vec))) return(as.Date(vec))

   if(class(vec)=="Date") return(vec)

   vec[vec==""] <- NA

   formats <- c("%d/%m/%Y","%d %b %Y","%Y-%m-%d")

   ans <- lapply(formats,function(x){

     as.Date(vec,format=x)

   })

   which_date <- unlist(lapply(1:3,function(x){

     sum(is.na(ans[[x]]))==sum(is.na(vec))

   }))

   if(sum(which_date)!= 1){

     stop("Error reading date format it should be of the form

        YYYY-MM-DD, DD/MM/YYYY or DD Month YYYY ") 

   }

  ans <- ans[[which(which_date,TRUE)]]

  years <- as.character((ans),format="%Y") 

  years <- years[!is.na(years)]

  if(any(as.numeric(years) < 1000) ){

    stop("All years must have 4 digits, e.g. 01/01/2015 not 01/01/15")

  } 

  return(ans) 

}

# Set the censored.at.follow.up column for EventData@@subject.data

# @param subject.data An EventData@@subject.data data frame without the

# censored.at.follow.up column

# @param followup The follow period (in days)

# @return subject.data with additional censored.at.follow.up column

# Warnings will be output if dates have to be changed due to invalid data 

# for example if event occurs after followup period 

IncludeFollowUp <- function(subject.data,followup){

  subject.data$censored.at.follow.up <- as.numeric(subject.data$time > followup)

  subject.data$time <-ifelse(subject.data$censored.at.follow.up==1,followup,subject.data$time)

  resetToFollowUp <- function(data,idx,warning.msg){

    if(length(idx)>0){

      data$withdrawn[idx] <- 0

      data$has.event[idx] <- 0

      data$event.type[idx] <- NA

      warning(paste("Subjects",paste(data[idx,"subject"],collapse=", "),warning.msg))

    }

    data

  }

  subject.data <- resetToFollowUp(data=subject.data,

                   idx=which(subject.data$withdrawn==1 & subject.data$censored.at.follow.up==1),

                   warning.msg="have withdrawn dates after followup period and so have been censored at followup")

  resetToFollowUp(data=subject.data,

                 idx=which(subject.data$has.event==1 & subject.data$censored.at.follow.up==1),

                 warning.msg="had event after followup period and so have been censored at followup instead of having an event")

}

# Create an empty data frame for 

# event.pred.data or time.pred.data

# slots of the \code{WeibullResults} class

# @return This empty data frame

EmptyPredictionDF <- function(){

  data.frame(time=as.Date(character()),

                 event=numeric(),

                 CI_low=numeric(),

                 CI_high=numeric(),

                 daysatrisk=numeric())

}

# Create the text for summarizing a \code{FromDataResults object}

# @param object A \code{FromDataResults} object

# @param round.method See \code{eventPrediction:::myRound.Date}

# @param text.width numeric The width of the text to be returned. See \code{base::strwrap}

# @param show.predictions Logical if TRUE then include the time.pred.data and

# event.pred.data information in the text 

# @param show.at.risk Output the median number of at risk years

# @return A string (which can be output using cat)

getFromDataResultsSummaryText <- function(object,round.method="None",text.width=60,show.predictions=TRUE,show.at.risk=TRUE){

  daysinyear <- standarddaysinyear()

  data <- object@event.data

  indat <- data@subject.data

  indat$event.date <- ifelse(indat$has.event, LastDate(indat),NA)

  N.subjects <- length(indat$rand.date) #subjects in data set

  title <- ""

  if(N.subjects!=0){

    last.date <- if(any(!is.na(indat$event.date))) as.Date(max(indat$event.date, na.rm=TRUE),origin="1970-01-01")

                 else "NA"

    title <- paste0(N.subjects, " patients recruited where last patient in on ", max(indat$rand.date))

    if(class(last.date)=="Date"){

      title <- paste0(title, " and last event observed at ", last.date,

              " (",sum( indat$has.event, na.rm=TRUE), " events). ")

    }

    else{

      title <- paste0(title," and no events observed. ")

    }

  }

  if(object@Naccrual > 0){

      title <- paste0(title, 

                      " Out of ", N.subjects+object@Naccrual, " patients ",  object@Naccrual, 

                      " were simulated using ", object@accrualGenerator@text," ")

  }

  title <- paste(title, "Using ", object@simParams@type ," survival model. ",sep="")

  NA.note <- ""

  if(nrow(object@event.pred.data)!=0 && show.predictions){

    df <- object@event.pred.data 

    ans <- lapply(1:nrow(df),function(x){

      target <- myRound.Date(c(df[x,"CI_low"],df[x,"time"],df[x,"CI_high"]),round.method)

      retVal <- paste0("The time at which ", df[x,"event"]," events have occurred is predicted to be ",

             target[2], " [", target[1], ", ", target[3], "]" )

      if(show.at.risk){

        retVal <- paste(retVal," with an expected ",round(df[x,"daysatrisk"]/daysinyear,2)," years of subjects at risk at this time",sep="")

      }  

      paste(retVal,". ",sep="")

    }) 

    if(any(object@event.pred.data$time==as.Date(Inf,origin="1970-01-01"))){

      NA.note <- paste("An expected time of NA implies that,",

                       "in fewer than 50% of simulations the given number of events occurred.")

    }else if(any(object@event.pred.data$CI_high==as.Date(Inf,origin="1970-01-01"))){

      NA.note <- paste("A CI value of NA implies that, due to subject dropout, ",

                       "in fewer than ",100*(1-object@limit),

                        "% of the simulations the given number of events occurred.", sep="")

    }

    title <- paste(title,paste(ans,collapse=""),sep="")

  }

  if(nrow(object@time.pred.data)!=0 && show.predictions){

    df <- object@time.pred.data 

    ans <- lapply(1:nrow(df),function(x){

      retVal <- paste0("On ", df[x,"time"]," the predicted number of events is ",

             df[x,"event"], " [", df[x,"CI_low"], ", ", df[x,"CI_high"], "]" )

      if(show.at.risk){

        retVal <- paste(retVal," with an expected ",round(df[x,"daysatrisk"]/daysinyear,2)," years of subjects at risk",sep="")

      }  

      paste(retVal,". ",sep="")  

    }) 

    title <- paste(title,paste(ans,collapse=""),sep="")

  }

  title <- paste(title,NA.note,sep="")

  return(AddLineBreaks(title,text.width=text.width))

}

# Round dates

# 

# @param mydates a vector of 3 dates, the

# lower CI value, the median and the upper CI value

# @param round.method character, if "toMonths" then 

# the following procedure is applied:

# lower CI: take the month of the date 15 days earlier \cr

# median: take the month of the given date \cr

# upper CI: take the month of the date 15 days later \cr 

# otherwise the dates are unchanged

# @return The rounded dates

myRound.Date <- function(mydates,round.method){

  if(round.method=="toMonths"){

     c(format( mydates[1] - 15, format="%b %Y" ),

       format( mydates[2], format="%b %Y"),

       format( mydates[3] + 15, format="%b %Y" ))

  }

  else{

    mydates

  }

}

# Calculate the last date on study for subjects

# 

# Code: \code{ifelse(time==0,rand.date,time+rand.date-1)}

# 

# @param time A vector of times on study

# @param rand.date A vector of randomization dates

# @return A vector of dates

internal.Date <- function(time,rand.date){

   as.Date(ifelse(time==0,rand.date,time+rand.date-1),origin="1970-01-01")

}

# Calculate the last date on study for subjects

#

# The last date is the date of censoring or date of withdrawal

# or date of event for subjects

# @param indat  A data frame e.g. EventData@@subject.data

# @return A vector of dates

LastDate <- function(indat){

  internal.Date(indat$time,indat$rand.date)

}

# Create a data frame which contains only subjects

# who have been censored before a given date

# @param data A data frame e.g. EventData@@subject.data

# @param censor.date The given censored cutoff date

# @return The subset of \code{data} which is censored (i.e. does not

# have an event and is not withdrawn) before the given date

GetLaggedSubjects <- function(data,censor.date){

  data <- data[LastDate(data) < censor.date,]

  data[data$has.event==0 & data$withdrawn==0 & data$censored.at.follow.up==0,]

}

# Function to derive the time on study for subjects given 

# columns such as dth.date, event.date etc.

# 

# See the vignette for the logic used in calculating the time. 

# Note the changing of times so they are <= followup period is

# carried out in a subsequent function

# 

# see timeInternal.R

#

# @param data A data frame 

# @param rand.date string, the column name of randomization dates

# @param has.event string, the column name of whether a subject had an event

# (1) or not (0) 

# @param withdrawn string, the column name of whether a subject has withdrawn

# (1) or not (0)  

# @param subject, the column name of the subject ID

# @param time.list A list of column names used to calculate the time on study for example

# \code{time=list(last.date="lastDate",dth.date="dthDate", prog.date="progDate",

# withdrawn.date="withdrawnDate")}

# @return A vector containing time on study

AddTimeColumn <- function(data,rand.date,has.event,withdrawn,subject,time.list){

  allowed.colnames <- c("dth.date","event.date","prog.date","withdrawn.date","last.date")

  validate.time.list.arguments(data,rand.date,has.event,withdrawn,time.list,allowed.colnames)

  #create the date objects

  for(x in allowed.colnames){

    if(!is.null(time.list[[x]])) data[,x] <- FixDates(data[,time.list[[x]]]) 

  }

  #check prog is <= dth if they exist

  if("dth.date" %in% names(time.list) && "prog.date" %in% names(time.list)){

    idx <- which(!is.na(data[,"dth.date"]) & 

                 !is.na(data[,"prog.date"]) & 

                   data[,"dth.date"] < data[,"prog.date"])

    if(length(idx)>0){

      warning(paste("Subjects",paste(data[idx,subject] ,collapse=", ")  ,

                    "have progression date after death date. This is invalid and should be fixed"))

    }

  }

  #This vector will be populated with subjects time on study and returned 

  ans <- rep(NA,nrow(data))

  #first deal with subjects who are censored

  are.censored <- which(!data[,has.event] & !data[,withdrawn])

  ans <- Time.Deal.With.Censored(ans,data,rand.date,are.censored,time.list,allowed.colnames[1:4],subject)

  #next deal with subjects who have event

  subs.had.event <- which(data[,has.event]==1)

  ans <- Time.Deal.With.Had.Event(ans,data,rand.date,subs.had.event,time.list,allowed.colnames[1:3],subject,has.event)

  #finally subjects who have withdrawn

  has.withdrawn <- which(data[,withdrawn]==1 & data[,has.event]==0)

  ans <- Time.Deal.With.Withdrawn(ans,data,rand.date,has.withdrawn,time.list,withdrawn,subject,has.event)

  #output warning if subject has withdranw date but have not been withdrawn

  if(!is.null(time.list[["withdrawn.date"]])){

    r <- which(any(!is.na(data[,"withdrawn.date"]) & data[,withdrawn]==0))

    if(any(r)){

      warning(paste("Subjects",paste(data[r,subject],collapse=", "), "have not withdrawn yet have a withdrawn date.",

              "The withdrawn dates are ignored"))

    }

  }

  #if we have not been able to calculate a time then output

  #an error if had event or warning if censored/withdrawn

  if(any(is.na(ans))){

    r <- which(is.na(ans))

    if(any(data[r,has.event]==1)){

      s <- intersect(which(data[,has.event]==1), r)

      stop(paste("Subjects",paste(data[s,subject],collapse=", "), "have an event but no time on study can be calculated.",

                 "Is there any missing data in your data set?"))

    }

    warning(paste("Subjects",paste(data[r,subject],collapse=", "),

                  "are censored/withdrawn subject(s) and no time on study can be calculated.",

                  "For these subjects the time on study is set to 0. Is there any missing data",

                  "in your data set?"))

  }  

  return(as.numeric(ans))

} 

# Maximum Likelihood estimate of uniform

# accrual parameter k

# 

# @param B recruitment period

# @param s.i a vector of recruitment

# times (numeric, time since start of recruitment period)

# @return estimate of k = 1/(logB- mean(log(s.i)))

MLestimateK <- function(B,s.i){

  if(any(s.i<=0) || B <= 0 || any(s.i > B)) stop("Invalid arguments in MLestimateK")

  s <- mean(log(s.i))

  return(1/(log(B)-s))

}

# Calculate the average recruitment rate (subjects/day)

# @param N number of subjects recruited

# @param first.date the date of the first recruitment (numeric)

# @param last.date the date of the last recruitment (numeric)

# @return The average recruitment

average.rec <- function(N,first.date,last.date){ 

  N/(last.date-first.date+1)

}