R/Gems2.R

In GUIgems: Graphical User Interface for Generalized Multistate Simulation Model

#' makeM 
#'  
#' @description
#' Builds hazard function matrix based on the hazard function names matrix. 
#' If some function is not defined, the name itself is copied to M matrix. 
#' @param hfNames - a matrix with names of hazard functions. 
#' One can use predefined function names: "Impossible", "Exponential", "Weibull", "MultWeibull"
#' @return matrix M generated by generateHazardMatrix
#' with hazard functions, which names are in hfNames matrix.
#' @examples 
#' hfNames <- array(rep("Exponential", 36), dim = c(6,6))
#' hfNames[3,4:5] <-  rep("impossible",2)
#' hfNames[1:4,6] <- rep("sr.fun", 4)
#' hfNames[2, 4:5] <- rep("treat.fun", 2)
#' hfNames[col(hfNames)<=row(hfNames)]<-"NULL"
#' M <- makeM(hfNames)
#' @export
makeM <- function(hfNames){
  n <- dim(hfNames)[1]   
  print(rownames(hfNames))
  M <-generateHazardMatrix(n,rownames(hfNames))
  print(M)
  for (g in seq(2,n,1)){
    for (f in seq(1,g-1)){
      if (!(hfNames[f,g] %in% c("Weibull", "Exponential", "impossible"))) {
        
        fun_exists <- tryCatch(M[[f,g]] 
                  <-(eval(parse(text=hfNames[f,g]))),
                  error=function(error){print("NAF")})

        
        if (!is.function(fun_exists)){
          if (fun_exists=="NAF"){
            M[[f,g]] <-hfNames[f,g]
          } 
        }
      }
      else {
        M[[f,g]] <-hfNames[f,g]
      }
    }
  } 
  return(M)
}

# Like formals, but with pre-defined functions (Weibull, impossible, Exponential)
# @description 
# Like formals(fun_name), returning also parameters 
# for pre-defined hazard function names ("impossible", 
# "Weibull", "Exponential"). 
# @param function_name
# @return formals
my_formals<- function(function_name){
  # predefinedParameters <- list("Experimental"=list("rate"=NULL), "Weibull"=list("shape"=NULL, "scale"=NULL), "impossible"=list())
  #declared in gui3.R  
  if (is.null(function_name))
    return(NULL)
  
  if (!is.function(function_name)){ 
  if (function_name %in% c("Exponential", "Weibull", "impossible")){
    return(as.list(((predefinedParameters(function_name)))))
    
  }}
  
  res <- tryCatch({
    as.list(formals(function_name))
    print(as.list((formals(function_name))))
  },
  error=function(cond){"empty"},
  warning = function(cond){"empty"}
  )
  
  if (length(res)==0){
    print(res)
    return(list())
  }
  if (!(any(res=="empty"))){
    print(res)
    return(res)
  }
  
  res<-tryCatch({
    as.list((formals((parse(text = function_name)))))
  },
  error=function(cond){"empty"},
  warning = function(cond){"empty"}
  )
  
  if (length(res)==0){
    print(res)
    return(list())
  }
  if (!(any(res=="empty"))){
    print(res)
    return(res)
  }
  
  return(print("ERROR")) 
}
   



# Check if the parameter list is consistent with the function name 
# @param params_list, functionName
# @return TRUE/FALSE 
consistentParamsFunction <- function(params_list, functionName){
  tmp_names <-names(my_formals(functionName))#[[1]])
  
  if ((length(tmp_names)==0)&length(names(params_list))==0)
    return(TRUE)
  short_tmp_names <- tmp_names[!tmp_names %in% c("bl", "t", "history")]
  
  if ((length(short_tmp_names)==0)&length(names(params_list))==0)
    return(TRUE)
  
  tmp_ok <-(length(short_tmp_names)==length(names(params_list))) &
    (all(sort(names(params_list))==sort(tmp_names[!tmp_names %in% c("bl", "t", "history")])))
  
  return(tmp_ok)  
}


# Prepares time to transition ttt matrix based on M matrix. 
# If names of the functions include "ttt", it is asumed to be time.to.transition function
# @param M (generated be generateHazardMatrix)
# @return mypanel
M2ttt <- function(M){
  tmp <- M@list.matrix
  ttt <- matrix(FALSE, M@states.number, M@states.number)
  ttt["ttt" %in% tmp] <- TRUE
  ttt
}


####################################
#           Working                #
#              with                #   
#            cohort                #  
####################################

# @title simulation the cohort from the gui level 
# @name guiSimCoh
# @description
# The function to simulate cohort from the level of rpanel::rp.panel.
# mypanel must have defined model (hazard functions, baseline, cohortSize)
#
# Calles 
# graph_HF - plots the paths the patients followed
# @param 
# mypanel - a structure that has attributes:
# 
# @keywords simulateCohort mypanel

guiSimCoh<- function(mypanel){
  #todo -new baseline only if size of the cohort has changed
  n<- mypanel$numStates
  if (!is.function(mypanel$baselineFunction) & length(mypanel$baseline)<mypanel$cohortSize) 
    mypanel$baseline <- matrix(NA, nrow = mypanel$cohortSize)
  else{ 
   if (length(mypanel$baseline)<mypanel$cohortSize)
    mypanel$baseline <- do.call(mypanel$baselineFunction, list(mypanel$cohortSize))  
  }
   
  updateM <- FALSE
  functionToUpdate <- list()
  #TODO: it is copied from setStatesNum, make a function out of it
  for (g in seq(2,n,1)){
    for (f in seq(1,g-1)){
      if ("ttt" %in% mypanel$hfNames[f,g]) {
        mypanel$ttt[f,g] <- TRUE
      }
      if (!(mypanel$hfNames[f,g] %in% c("Weibull", "Exponential", "impossible"))) {
        
        fun_exists <- tryCatch(mypanel$M[[f,g]] <-(eval(parse(text=mypanel$hfNames[f,g]))), 
                               error=function(error){print("NAF")})
        # does hfNames work here??
        if (!is.function(fun_exists)){             
          if (fun_exists=="NAF"){
            mypanel$M[[f,g]] <-mypanel$hfNames[f,g]
            updateM <- TRUE
            functionToUpdate <- c(functionToUpdate, mypanel$hfNames[f,g])
          }
        }
      }
      else {
        mypanel$M[[f,g]] <-mypanel$hfNames[f,g]
        #Weibull and Exponential are not ttt 
      }
    }
  }
  if (updateM == TRUE){
    functions <- toString(paste(functionToUpdate, sep =" "))
    msg <- paste("There are function you have to define:", functions, sep = " ")
    rpanel::rp.messagebox(msg, title = "Undefined functions") 
    return(mypanel)
  }
  
  ok <- TRUE
  functionBadParameters <- list()
  for (g in seq(2,n,1)){
    for (f in seq(1,g-1)){
    print("checking consistency of parameters before simulation")
   print(my_formals(mypanel$hfNames[f,g]))
   print(names(mypanel$params[[f,g]]))
    tmp_ok <- consistentParamsFunction(mypanel$params[[f,g]],(mypanel$hfNames[f,g]))
    if (!tmp_ok){
        functionBadParameters <- c(functionBadParameters,paste(mypanel$hfNames[f,g], f,g,sep="_" ))
        ok <- FALSE
      }
    }
  }
  if (!ok){
    functions <- toString(paste(functionBadParameters, sep =" "))
    msg <- paste("There are inappropriate parameters for functions:", functions, sep = " ")
    rpanel::rp.messagebox(msg, title = "wrong parameters functions") 
    return(mypanel)
  } 
  
#TODO: check parametersCovariances
  cohort <- simulateCohort(transitionFunctions = mypanel$M,
                           parameters = mypanel$params,
                           cohortSize = mypanel$cohortSize,
                           parameterCovariances = mypanel$covariance,
                           timeToTransition = mypanel$ttt,
                           baseline = mypanel$baseline,
                           baselineFunction = mypanel@baselineFunction,
                           to = mypanel$max_time)
  cohort@baselineFunction <- mypanel$baselineFunction
  colnames(cohort@time.to.state) <- mypanel$statesNames
  mypanel$cohort <- cohort
  print(mypanel$statesNames)
  
  mypanel$subcohorts <- list()
  mypanel$subcohorts[["the main cohort"]] <- as.data.frame(c(as.data.frame(mypanel$baseline), 
                                                             as.data.frame(cohort@time.to.state))) 
  
  mypanel <- showCohort(mypanel)
}


#' @import utils
chooseSubcohort <- function(mypanel, query=""){
  
  cohort <- mypanel$cohort
  if (query=="")
    query <- mypanel$query
  else
    mypanel$query <- query
  
  print(query)
  cohortBl <-  as.data.frame(c(as.data.frame(cohort@baseline), as.data.frame(cohort@time.to.state)))
  colnames(cohortBl) <- c(colnames(cohort@baseline), colnames(cohort@time.to.state))
  subcohort <- cohortBl[eval(parse(text = query)),]
  #query1 <- gsub( "\"", "",query)
  mypanel$subcohorts[[query]] <- cohortBl[eval(parse(text = query)),]
  View(query)
  # print(mypanel$subcohorts[[query]] )
  #updateCohortPanel(mypanel)
  
  mypanel

}
#' @import utils
listSubcohorts <- function(mypanel){
  if (!is.null(mypanel$subcohorts)){
    View(names(mypanel$subcohorts))
    #print((mypanel$subcohorts))
  }
  mypanel  
}

#' @import utils
listStatesM <- function(mypanel){
  if (!is.null(names(mypanel$cohorts[[1]])@time.to.state)){
    states_names <-(as.array(names(mypanel$cohorts[[1]])@time.to.state))
    View(states_names)
    #print((mypanel$subcohorts))
  }
  mypanel  
}

#' @import utils
listStates <- function(mypanel){
  if (!is.null(names(mypanel$cohort@time.to.state))){
    states_names <-(as.array(names(mypanel$cohort@time.to.state)))
    View(states_names)
    #print((mypanel$subcohorts))
  }
mypanel  
}

  
chooseSubcohorts <- function(subcohorts, chosen ) {
  out <- tryCatch(
{ subcohorts[chosen] },
error=function(cond) {
  message(paste("There are no such subcohorts:", chosen))
  message(cond)
  return(NA)
},
warning=function(cond) {
  message(paste("Chosen subcohorts caused a warning:", chosen))
  message(cond)
  return(NULL)
},
finally={
}  )    
return(out)
}


plotFun <- function(mypanel, subcohorts_nums = -1, states_to_plot = -1, myfunction = NULL){
  ##only for R cmd check
  probability <- NULL
  lower <- NULL
  upper <- NULL
  subcohort <- NULL
  ## end of only for R cmd check
  
  if (subcohorts_nums[1] == -1)
    subcohorts_nums <- eval(parse(text=mypanel$StatesToPlot["subcohorts"]))
  if (states_to_plot[1] == -1)
    states_to_plot <- eval(parse(text =mypanel$StatesToPlot["states"]))
  if (is.null(myfunction))
    myfunction <- mypanel$functionToPlot
  
    print(myfunction)
  Mcohorts <- FALSE
  width_bl <- 0
  if ("baseline" %in% names(attributes(mypanel$cohort))){
#    if (!is.null(mypanel$cohort@baseline)){
      print("one cohort")
  width_bl <- ncol(mypanel$cohort@baseline)
  follow.up <- mypanel$cohort@follow.up
  statesNames <- names(mypanel$cohort@time.to.state)
  # }
  }
  else
    if(!is.null(mypanel$cohorts[[1]])){
      print("multicohorts")
      Mcohorts <- TRUE
      width_bl <- ncol(mypanel$cohorts[[1]]@baseline)
      follow.up <- mypanel$cohorts[[1]]@follow.up
      statesNames <- names(mypanel$cohorts[[1]]@time.to.state)
    }
  #TODO: different baselines for different cohorts -- removing baseline separately for different cohorts. Or take the cohorts without baseline
  
  subcohorts <- chooseSubcohorts(mypanel$subcohorts, subcohorts_nums) 
  #the above: try -catch version. subcohorts <- (mypanel$subcohorts[subcohorts_nums])
  subcohorts_names <- names( subcohorts)
  print(subcohorts_names)
  n <- length(subcohorts)
  k <- length(states_to_plot)
  post <- list()
  for (g in seq(1:n)){
    if (Mcohorts) { 
      width_bl <-ncol(mypanel$cohorts[[subcohorts_names[g]]]@baseline)
  }
    post[[subcohorts_names[g]]] <-
    eval(parse(text = myfunction))((as.data.frame(subcohorts[[g]]))[,-(1:width_bl)], 
                                     times=seq(0.1, follow.up, .1)) 
  } 
 print("preparing data frame for plotting")
  dframe <- prepare_ggplot(post, states_to_plot, mypanel)
  if (is.null(dframe)){
    return(mypanel)
  }
 print("start plotting")
 View(dframe)
write.table(dframe, "dframe.dat")
 if (k < 7){
    print( ggplot2::ggplot(data=dframe, ggplot2::aes(x= time, y= probability, 
                          ymin=as.numeric(lower), ymax = as.numeric(upper),  
                          group=subcohort, colour=subcohort, fill=subcohort)) 
           + ggplot2::facet_wrap(~state, nrow=floor(sqrt(k)))
           + ggplot2::geom_line()+ggplot2::geom_ribbon(alpha=.05) 
           + ggplot2::ggtitle(myfunction))
    
  }
  else {
    for (f in seq(1:k)){
      state_name <-statesNames[states_to_plot[f]]#paste("state",states_to_plot[f], sep=" ")
      dev.new()
      state_title <- paste(myfunction,state_name, sep=" " )
      print( ggplot2::ggplot(as.data.frame(dframe[dframe["state"]==state_name,]), ggplot2::aes(x= time, y= probability,
                                                                     ymin=as.numeric(lower), ymax = as.numeric(upper),  
                                                                     group=subcohort, colour=subcohort, fill=subcohort))+ 
               ggplot2::geom_line()
             +ggplot2::geom_ribbon(alpha=.05)
             + ggplot2::ggtitle(state_title))
    }}
  
  mypanel
} 

#' @import utils
updateSubcohorts <- function(mypanel){
  paths <- FALSE
  cohort <- mypanel$cohort
  View(cohort@time.to.state)
  cohortBl <-  as.data.frame(c(as.data.frame(cohort@baseline), as.data.frame(cohort@time.to.state)))
  colnames(cohortBl) <- c(colnames(cohort@baseline), colnames(cohort@time.to.state))
  View(cohortBl)
  for (f in names(mypanel$subcohorts)){
    if (grepl("main", f))    {
      mypanel$subcohorts[[f]]<-cohortBl  
    }
    else { if (grepl("path", f))    {
      mypanel$subcohorts[[f]]<-NULL  
      paths <- TRUE
    }
    else{ 
      print(f)
    #  f1 <- gsub( "\"", "",f)
      mypanel$subcohorts[[f]] <- cohortBl[eval(parse(text = f)),]
    }
    }
  }
  if (paths){
    mypanel <- statesPaths(mypanel)  
  }
  mypanel
}


# # @export
removeSubcohorts <- function(mypanel){
  cohortBl<- mypanel$subcohorts[[1]]
  mypanel$subcohorts <- head(mypanel$subcohorts,1)
mypanel  
}