R/hformat.R

In mlxR: Simulation of Longitudinal Data

hformat  <-  function(list.input)
{
  #hformat 
  treatment=list.input$treatment
  parameter=list.input$parameter
  output=list.input$output
  regressor=list.input$regressor
  varlevel=list.input$varlevel
  group=list.input$group
  id=list.input$id
  if (isfield(id,"newId"))
    id <- id$newId
  nv=c('treatment','parameter','output','regressor','varlevel')
  lv=list(treatment,parameter,output,regressor,varlevel)
  
  #------------------------------------
  if (!is.null(group)) {
    if (!is.null(names(group))) 
      group <- list(group) 
    N=length(group)
    
    model <- list.input$model
    
    if (identical(file_ext(model),"R")) 
      Rfile <- TRUE 
    else 
      Rfile <- FALSE
    if ( !is.null(model) && exists(model, mode="function") )
      Rsource <- TRUE
    else 
      Rsource <- FALSE
    
    if (Rsource || Rfile) {
      for (k in (1:N)) {
        if (is.null(group[[k]]$size))
          group[[k]]$size <- 1
        if (length(group$size)>1)
          stop("Define group$size as a scalar instead of a vector.", call.=FALSE)
        if (!is.null(group[[k]]$level))
          warning("'level' defined in 'group' is not used with a R model.", call.=FALSE)
      }
    } else {    
      model.info <- parse.model(model)
      for (k in (1:N)) {
        if (is.null(group[[k]]$size)) {
          group[[k]]$size <- rep(1, length(model.info$level))
          group[[k]]$level <- model.info$level
        } else {
          if (is.null(group[[k]]$level)) {
            if (length(group[[k]]$size)>1)
              stop("levels of randomization associated to the sizes have not been defined in 'group'", call.=FALSE)      
            if ("population" %in% model.info$level)
              group[[k]]$level <- "population"
            else if ("covariate" %in% model.info$level)
              group[[k]]$level <- "covariate"
            else if ("individual" %in% model.info$level)
              group[[k]]$level <- "individual"
            else
              group[[k]]$level <- "longitudinal"
            
            if (group[[k]]$level != "longitudinal")
              warning(paste0("level of randomization has not been defined in group ", k,": '", 
                             group[[k]]$level, "' is used"), call.=FALSE)      
            
          }
          else
          {
            if (!is.null(group[[k]]$size) & (length(group[[k]]$size)!=length(group[[k]]$level)))
              stop("'level' and 'size' defined in 'group' have different lengths.", call.=FALSE)      
            gk <- group[[k]]$level
            sk <- rep(1, length(model.info$level))
            for (jk in (1:length(gk)))
            {
              rk <- grep(gk[jk],model.info$level)
              if (length(rk)>0)
                sk[rk] <- group[[k]]$size[jk]
            }
            group[[k]]$size <- sk
            group[[k]]$level <- model.info$level
          }
        }
      }
    }
  } else {
    N <- nrow(list.input$id)
    # N=NULL
  }
  
  Nid<-NULL
  for (k in seq(1,length(lv))) {
    lvk <- lv[[k]]
    if (!is.null(names(lvk))) {  
      lvk <- list(lvk) 
      lv[[k]] <- lvk
    }
    if (length(lvk)>0) {
      for (j in seq(1,length(lvk))) {
        lvkj <- lvk[[j]]
        if (isfield(lvkj,"id")) {
          lvkj$id <- match(lvkj$id, id)
          Nid <- c(Nid,lvkj$id)
        }
        else if(isfield(lvkj,"design")) {
          lvkj$design$id <- match(lvkj$design$id, id)
          Nid <- c(Nid,lvkj$design$id)
          if (!is.null(lvkj))
            lv[[k]][[j]]=lvkj
        }
        else if(isfield(lvkj,"time")) {
          if (!isfield(lvkj$time,"id") & isfield(lvkj$time,"ID") ) {
            warning("\n'ID' is used instead of 'id' in an input argument of 'simulx'\n")
            lvkj$time$id <- lvkj$time$ID
            lvkj$time$ID <- NULL
          }
          if (isfield(lvkj$time,"id")) {
            lvkj$time$id <- match(lvkj$time$id, id)
            Nid <- c(Nid,lvkj$time$id)
          }
        }
        else if(isfield(lvkj,'header')) {
          warning("deprecated syntax:  use 'colNames' instead of 'header'",immediate.=TRUE)
          names(lvkj)[names(lvkj)=="header"]<-"colNames"
        }
        
        if (isfield(lvkj,'colNames')) {
          Nid=c(Nid,lvkj$value[,1]) #assuming that first column = id
        }
        if (!is.null(lvkj))
          lv[[k]][[j]]=lvkj
      }
    }
  }    
  if (!is.null(Nid))
    Nid = length(which(!is.na(unique(Nid))))
  else
    Nid <- 0
  
  if (is.null(N))
    N <- Nid 
  
  if (is.null(N)||N==0)
    N=1
  else
    N = unique(N)
  
  if (is.null(group)) {
    group <- vector("list",N)
    for (i in seq(1,N))
      group[[i]] <- list(size=1)
  }
  
  id.ori=list()
  #---  parameters
  iv <- which(nv=="parameter")
  parameter <- vector("list", N)
  if (!is.null(lv[[iv]])) {
    r <- format.parameter(parameter,lv[[iv]],seq(1,N))
    if (length(r$id)>0) {id.ori=c(id.ori,r$id)}
    parameter <- r$parameter
  }
  for (i in seq(1,N)) {
    gi <- group[[i]]
    if (isfield(gi,'parameter')) {
      r <- format.parameter(parameter,gi$parameter,i)
      parameter <- r$parameter
      group[[i]]$parameter <- NULL
    }
  }
  parameter <- merge.parameter(parameter)
  list.output=list(parameter=parameter)  
  
  #---  outputs
  output <- list(individual=vector("list", N),group=vector("list", N), id=id)
  for (i in seq(1,N)) {
    output$individual[[i]]=list(name=NULL,time=NULL)
    output$group[[i]]=list(name=NULL)
  }
  iv <- which(nv=="output")
  r <- format.output(output,lv[[iv]],seq(1,N))
  if (length(r$id)>0) {id.ori=c(id.ori,r$id)}
  output <- r$output
  for (i in seq(1,N)) {
    gi <- group[[i]]
    if (isfield(gi,'output')) {
      r <- format.output(output,gi$output,i)
      output <- r$output
    }
    group[[i]]$output <- output$group[[i]]$name
  }
  output <- output$individual
  list.output$output <- output
  
  #---  treatments
  iv <- which(nv=="treatment")
  if (!is.null(lv[[iv]])) {
    r <- format.treatment(lv[[iv]],seq(1,N))
    if (length(r$id)>0) 
      id.ori=c(id.ori,r$id)
    treatment <- r$treatment
  }
  for (i in seq(1,N)) {
    gi <- group[[i]]
    if (isfield(gi,'treatment')) {
      r <- format.treatment(gi$treatment,i)
      pgi <- r$treatment
      treatment <- c(treatment, pgi)
      group[[i]]$treatment <- NULL
    }
  }
  if (!is.null(treatment)) {
    r <- merge.treatment(treatment,N)
    list.output <- c(list.output, r)
  }
  
  #---  regressor
  iv <- which(nv=="regressor")
  if (!is.null(lv[[iv]])) {
    r <- format.regressor(lv[[iv]],seq(1,N))
    if (length(r$id)>0) 
      id.ori=c(id.ori,r$id)
    regressor <- r$regressor
  }
  for (i in seq(1,N)) {
    gi <- group[[i]]
    if (isfield(gi,'regressor')) {
      r <- format.regressor(gi$regressor,i)
      pgi <- r$regressor
      regressor <- c(regressor, pgi)
      group[[i]]$regressor <- NULL
    }
  }
  if (!is.null(regressor))
    list.output$regressor=merge.regressor(regressor,N)
  
  #---  varlevel
  iv <- which(nv=="varlevel")
  if (!is.null(lv[[iv]])) {
    r <- format.varlevel(lv[[iv]],seq(1,N))
    if (length(r$id)>0) 
      id.ori=c(id.ori,r$id)
    varlevel <- r$varlevel
  }
  for (i in seq(1,N)) {
    gi <- group[[i]]
    if (isfield(gi,'varlevel')) {
      r <- format.varlevel(gi$varlevel,i)
      pgi <- r$varlevel
      varlevel <- c(varlevel, pgi)
      group[[i]]$varlevel <- NULL
    }
  }
  if (!is.null(varlevel))
    list.output$varlevel <- merge.varlevel(varlevel,N)
  
  #--------------------
  if (length(unique(id.ori))>0) {
    if (length(unique(id.ori))>1) {
      #stop("\n\nid's should be the same in the different input arguments (parameters, treatment, output,...)\n")
    } else
      list.output$id.ori <- unique(id.ori)#[[1]]
  } else
    list.output$id.ori <- NULL
  
  #--------------------
  list.output$group=group
  return(list.output)
}

#-----------------------------
format.treatment <- function(treatment,uN) {
  N <- length(uN)
  if (!is.null(names(treatment))) 
    treatment <- list(treatment) 
  id.ori <- NULL
  for (k in seq(1,length(treatment))) {
    trtk <- treatment[[k]]
    if (isfield(trtk,'colNames')) {
      pp <- as.data.frame(trtk$value)
      names(pp) <- trtk$colNames
      trtk=pp
    } else if (!is.data.frame(trtk)) {
      trtk <- as.data.frame(trtk,stringsAsFactors =FALSE)
      if (is.null(trtk$time))
        stop("'time' should be defined in a treatment list\n", call.=FALSE)
      if (is.null(trtk$amount) & is.null(trtk$amt))
        trtk$amt <- 0
      n <- nrow(trtk)
      trtk <- trtk[rep(1:n,each=N),] 
      trtk$id <- rep(uN,n)
    } else {
      if (is.null(trtk$id) & !is.null(trtk$ID) ) {
        warning("\n'ID' is used instead of 'id' in the treatment list\n", call.=FALSE)
        trtk$id <- trtk$ID
        trtk$ID <- NULL
      }
      
      idk <- sort(unique(trtk$id))
    }
    if (is.null(trtk$time) | (is.null(trtk$amount) & is.null(trtk$amt)) )
      stop("\n\nBoth 'time' and 'amount' should be defined in a treatment list\n", call.=FALSE)
    
    names(trtk)[names(trtk)=="amt"] <- "amount"
    names(trtk)[names(trtk)=="adm"] <- "type"
    
    if (!is.null(trtk$rate)) {
      irate <- !is.na(trtk$rate)
      jrate <- trtk$rate[irate] !="."
      
      trtkrate = rep(Inf,length(trtk$rate))
      trtkrate[irate][jrate] = as.numeric(as.character(trtk$rate[irate][jrate]))
      trtk$rate <- trtkrate
    }
    if (!is.null(trtk$tinf)) {
      names(trtk)[names(trtk)=="tinf"] <- "rate"
      
      irate <- !is.na(trtk$rate)
      jrate <- trtk$rate[irate] !="."
      
      trtkrate=  rep(Inf,length(trtk$rate))
      trtkrate[irate][jrate] = trtk$amount[irate][jrate] / as.numeric(as.character(trtk$rate[irate][jrate]))
      trtk$rate <- trtkrate
    }
    if (is.null(trtk$rate))
      trtk$rate <- Inf
    treatment[[k]] <- trtk   
  }
  r <- list(treatment=treatment, id=unique(id.ori))
  return(r)
}

#--------------------------
merge.treatment <- function(treatment,N) {
  p <- vector("list",N)
  ptr <- treatment[[1]]
  np <- length(treatment)
  if (np>1) {
    for (j in seq(2,np))
      ptr=rbind(ptr,treatment[[j]])
  }
  
  if (isfield(ptr,"target")) {
    ptr$target = as.factor(ptr$target)
    list.target <- levels(ptr$target)
    nt <- length(list.target)
    depot <- vector("list", nt)
    for (k in seq(1,nt))
      depot[[k]] <- list(type=k, target=list.target[k])
    ptr$type    <- as.numeric(ptr$target)
    ptr$target  <- NULL
  } else {
    depot<-NULL
  }
  
  for (i in seq(1,N)) {
    pi <- NULL
    ij <- which(ptr$id==i)
    if (length(ij)>0) 
      pi <- ptr[ij,]
    pi$id=NULL
    
    if (!isfield(pi,"type"))
      pi$type <- 1
    
    if (!is.null(pi$time)) {
      pi <- pi[with(pi,order(time)),]
      p[[i]] <- as.list(pi)
    }
  }
  r <- list(treatment=p, depot=depot)
  return(r)
}

#-----------------------------
format.parameter <- function(parameter,param,uN) {
  N <- length(uN)
  if (!is.null(names(param)))
    param=list(param) 
  param <- param[!unlist(lapply(param, is.null))]
  id.ori <- NULL
  for (k in seq(1,length(param))) {
    paramk <- param[[k]]
    if (isfield(paramk,'colNames')) {
      pp=as.data.frame(paramk$value)
      names(pp)=paramk$colNames
      paramk=pp
    }
    id <- uN
    if (!is.data.frame(paramk)) {
      if (!is.list(paramk))
        paramk <- list(name=names(paramk),value=as.vector(paramk))
      pk <- rep(paramk$value,N)
      pk <- t(matrix(pk,ncol=N))
      pk <- cbind(uN,pk)
      pk <- data.frame(pk)
      names(pk) <- c('id',paramk$name)
      paramk <- pk
    } else {
      if (!isfield(paramk,"id")) {
        paramk <- paramk[rep(1,each=N),] 
        paramk$id <- uN
      } else {
        idk <- sort(unique(paramk$id))
        if (any(idk != uN)) {
          id.ori<-c(id.ori,idk) 
          paramk$id <- match(paramk$id, idk)
        }
        p.chr <- which(unlist(lapply(paramk,is.character)))
        for (jch in seq_len(length(p.chr)))
          paramk[[p.chr[jch]]] <- as.factor(paramk[[p.chr[jch]]])
        if (length(p.chr) >0)
          warning(paste0(c("parameters/covariates ", names(p.chr), " have been converted to factors"), collapse = " "), call. = FALSE)
      }
    }
    for (i in uN) {
      pki <- subset(paramk, id==i)
      pki$id <- i
      if (is.null(parameter[[i]]))
        parameter[[i]] <- pki
      else
        parameter[[i]][names(pki)]=pki
#        parameter[[i]] <- merge(parameter[[i]],pki)
    }
  }
  r <- list(parameter=parameter, id=unique(id.ori))
  return(r)
}

#-----------------------------
merge.parameter <- function(parameter) {
  if (!is.null(parameter[[1]])) {
    N <- length(parameter)
    pp <- parameter[[1]]
    if (N>1) {
      for (i in seq(2,N))
        pp <- rbind(pp, parameter[[i]])
    }
    parameter <- pp[with(pp,order(id)),]
  } else {
    parameter=NULL
  }
  return(parameter)
}

#-----------------------------
format.output <- function(output, out,uN) {
  N <- length(uN)
  if (!is.null(names(out)))
    out=list(out) 
  
  ioutput <- output$individual
  goutput <- output$group
  id.ori <- NULL
  for (k in seq(1,length(out))) {
    outk <- out[[k]]
    if (is.data.frame(outk)) {
      n.outk <- names(outk)
      outk <- list(name=n.outk[!(n.outk %in% c("id","time"))], 
                   time = outk[,c("id","time")])
    }
    if (!isfield(outk,"name"))
      outk <- list(name=outk)
    okname <- unlist(outk$name)
    nok <- length(okname)
    if (isfield(outk,'colNames')) {
      pp=as.data.frame(outk$value)
      names(pp)=outk$colNames
      outk$design=pp
    }
    if (!isfield(outk$time,"id") & isfield(outk$time,"ID") ) {
      warning("\n'id' is used instead of 'ID' in the output list\n")
      outk$time$id <- outk$time$ID
      outk$time$ID <- NULL
    }
    
    if (!is.null(outk$time) && ("id" %in% names(outk$time))) {      
      idk <- match(sort(unique(outk$time$id)),uN)
      for (i in seq(1:length(idk))) {
        ji <- which(outk$time$id == idk[i])
        ti <- sort(outk$time$time[ji])
        oitime <- vector("list" , nok)
        for (j in seq(1,nok))
          oitime[[j]] <- ti
        ik <- idk[i]
        goutput[[ik]]$name=c(goutput[[ik]]$name,okname)
        ioutput[[ik]]$name=c(ioutput[[ik]]$name,okname)
        ioutput[[ik]]$time=c(ioutput[[ik]]$time,oitime)
      }
    } else { 
      for (i in uN) {
        if (isfield(outk,"time")) {
          oitime <- vector("list" , nok)
          for (j in seq(1,nok))
            oitime[[j]] <- sort(outk$time)
          ioutput[[i]]$time=c(ioutput[[i]]$time,oitime)
          ioutput[[i]]$name=c(ioutput[[i]]$name,okname)
        }
        goutput[[i]]$name=c(goutput[[i]]$name,okname)
      }
    }
  }
  output$individual <- ioutput 
  output$group <- goutput
  r <- list(output=output, id=unique(id.ori))
  return(r)
}

#-----------------------------
format.regressor <- function(reg, uN) {
  N <- length(uN)
  if (!is.null(names(reg))) 
    reg=list(reg) 
  
  regressor <- vector("list",length(reg))
  #id.ori <- list()
  id.ori <- NULL
  for (k in seq(1,length(reg))) {
    regk <- reg[[k]]
    if (!is.data.frame(regk)) {
      if (isfield(regk,'colNames')) {
        mk <- regk$value
        colNames=regk$colNames
      } else {
        if (length(regk$time)==1) {
          regk$time <- c(regk$time, regk$time)
        }
        nk <- length(regk$time)
        idk <- rep(uN,each=nk)
        mk <- cbind(regk$time,regk$value)
        mk <- mk[rep(1:nk,N),]
        mk <- cbind(idk, mk)
        colNames <- c("id","time",regk$name)
      }
      regk <- data.frame(mk)
      names(regk) <- colNames
    } else {
      mk <- regk
      if (is.null(mk$id))
        mk <- cbind(list(id=1),mk)
      regk <- mk
    }
    regk <- regk[order(regk$id,regk$time),]
    regressor[[k]] <- unique(regk)
  }
  r <- list(regressor=regressor, id=unique(id.ori))
  return(r)
}

#-----------------------------
merge.regressor <- function(reg, N) {
  if (length(reg)>1) {
    r <- NULL
    for (i in seq(1,N)) {
      ri <- NULL
      for (k in seq(1,length(reg))) {
        rik <- reg[[k]][reg[[k]]$id==i,]
        if (nrow(rik)>0)
          if (is.null(ri))
            ri <- rik
          else {
            ri <- merge(ri,rik,
                        by.x=c("id","time"), by.y=c("id","time"),
                        all.x=TRUE,all.y=TRUE) 
            ri <- ri[order(ri$time),]
          }
      }
      r <- rbind(r,ri)
    }
  } else
    r <- reg[[1]]
  m <- matrix(as.numeric(unlist(r)),nrow=nrow(r))
  colNames <- names(r)
  colTypes <- rep("x",length(colNames))
  colTypes[colNames=="id"] <- "id"
  colTypes[colNames=="time"] <- "time"
  regressor <- list(colNames=colNames, colTypes=colTypes, value=m)
  return(regressor)
}

#-----------------------------
format.varlevel <- function(var, uN) {
  N <- length(uN)
  if (!is.null(names(var))) 
    var=list(var) 
  
  varlevel <- vector("list",length(var))
  id.ori <- NULL
  for (k in seq(1,length(var))) {
    vark <- var[[k]]
    if (!is.data.frame(vark)) {
      if (isfield(vark,'colNames')) {
        mk <- vark$value
        colNames=vark$colNames
      } else {
        nk <- length(vark$time)
        idk <- rep(uN,each=nk)
        occk <- rep(1:nk,N)
        mk <- vark$time[occk]
        mk <- cbind(idk, mk, occk)
        colNames <- c("id","time",vark$name)
      }
      vark <- data.frame(mk)
      names(vark) <- colNames
    }
    varlevel[[k]] <- vark
  }
  r <- list(varlevel=varlevel, id=id.ori)
  return(r)
}

#-----------------------------
merge.varlevel <- function(var, N) {
  if (length(var)>1) {
    r <- NULL
    for (i in seq(1,N)) {
      ri <- NULL
      for (k in seq(1,length(var))) {
        rik <- var[[k]][var[[k]]$id==i,]
        if (nrow(rik)>0)
          if (is.null(ri)) {
            ri <- rik
          }
        else {
          ri <- merge(ri,rik,
                      by.x=c("id","time"), by.y=c("id","time"),
                      all.x=TRUE,all.y=TRUE) 
          for (j in seq(1,ncol(ri))) {
            ij <- c(which(!is.na(ri[,j])),nrow(ri)+1)
            
            for (l in seq(1,length(ij)-1)) {
              ijl <- ij[l]
              if (ij[l+1]-ijl>1)
                ri[seq(ijl+1,ij[l+1]-1),j] <- ri[ijl,j]
            }
          }
        }
      }
      r <- rbind(r,ri)
    }
  }else{
    r <- var[[1]]
  }
  
  m <- matrix(as.numeric(unlist(r)),nrow=nrow(r))
  #m <- data.matrix(r)
  colNames <- names(r)
  colTypes <- rep("OCC",length(colNames))
  colTypes[colNames=="id"] <- "id"
  colTypes[colNames=="time"] <- "time"
  varlevel <- list(colNames=colNames, colTypes=colTypes, value=m)
  return(varlevel)
}

#-----------------------------
parse.model <- function(model) 
{
  con        = file(model, open = "r")
  lines      = readLines(con, warn=FALSE)
  close(con)
  ip <- grep(";",lines, fixed=TRUE)
  if (length(ip)>0)
  {
    for (k in (1:length(ip)))
    {
      ll <- lines[ip[k]]
      il <- regexpr(";",ll)
      il <- il[1]
      if (il>1)
        lines[ip[k]] <- substr(ll,start=1,stop=(il-1))
      else
        lines[ip[k]] <- ''
    }
  }
  
  i1 <- grep("[POPULATION]",lines, fixed=TRUE)
  i2 <- grep("[COVARIATE]",lines, fixed=TRUE)
  i3 <- grep("[INDIVIDUAL]",lines, fixed=TRUE)
  i4 <- grep("[LONGITUDINAL]",lines, fixed=TRUE)
  
  level <- NULL
  if (length(i1)>0)
    level <- c(level,'population')
  if (length(i2)>0)
    level <- c(level,'covariate')
  if (length(i3)>0)
    level <- c(level,'individual')
  if (length(i4)>0)
    level <- c(level,'longitudinal')
  
  fs <- fsort(c(i1, i2, i3, i4))
  model.info <- list(level=level[fs[[2]]])  
  return(model.info)
  
}