https://github.com/cran/Epi
Raw File
Tip revision: c81bbfbd28945aaec8aacae4e8a999a6f4b36c65 authored by Bendix Carstensen on 23 August 2018, 04:44:26 UTC
version 2.32
Tip revision: c81bbfb
mod.Lexis.R
modLexis <- 
function( Lx, resp, formula, xpos, link="log", scale, verbose=TRUE, ..., model )
{
# A common wrapper for glm and gam modeling of Lexis FU
  
# is this a Lexis object ?
if( !inherits(Lx,"Lexis") ) stop( "The first argument must be a Lexis object.\n")
nameLx <- deparse(substitute(Lx))
# Beginning of a new feature with a countmultiplier of the transitions considered 
if( !("lex.N" %in% names(Lx)) ) Lx$lex.N <- 1
    
# check that events are actual levels of lex.Xst 
if( is.numeric(resp) ) resp <- levels( Lx$lex.Xst )[resp]
wh <- match( resp, levels(Lx$lex.Xst) )
if( any(is.na(wh)) ) stop("'resp' must be a subset of: '", 
                     paste(levels(Lx$lex.Xst), collapse="','", sep=""), "'\n" )  

# is xpos supplied?
if( missing(xpos) ) {
  xpos <- levels( factor(Lx$lex.Cst) )
  } else {
# check that xpos are actual levels of lex.Cst 
if( is.numeric(xpos) ) xpos <- levels( Lx$lex.Cst )[xpos]
wh <- match( xpos, levels(Lx$lex.Cst) )
if( any(is.na(wh)) ) stop("'xpos' must be a subset of: '", 
                     paste(levels(Lx$lex.Cst), collapse="','", sep=""), "'\n" )  
Lx <- Lx[Lx$lex.Cst %in% xpos,]                     
  } 
                     
# construct the model formula - note that we want the possibility of
# transitions to transient states, hence the lex.Xst != lex.Cst
if( length(formula) != 2 ) stop( "formula must be a one-sided formula")
form <- cbind( (Lx$lex.Xst %in% resp &
                Lx$lex.Xst != Lx$lex.Cst)*Lx$lex.N,
               Lx$lex.dur ) ~ 1
form[3] <- formula[2]
xpos <- levels( factor(Lx$lex.Cst) ) # only levels present in lex.Cst

# Scaling
Lx$lex.dur <- Lx$lex.dur/scale
    
# Tell what we intend to and then do it
if( verbose ){
cat( deparse(substitute(model)),
     " Poisson analysis of Lexis object ", nameLx, " with ", link, " link",
     ":\n Transition rates from '", paste( xpos, collapse="','"), 
                          "' to '", paste( resp, collapse="','"), "'",
     if( scale!=1 ) paste(" scaled by", scale ), "\n", sep="" )
             }
    
# Fit the model
mod <- model( form, family = poisreg(link=link), data = Lx, ... )

# An explanatory attribute
attr( mod, "Lexis" ) <- list( Exposure=xpos, Events=resp, scale=scale )     
mod
}

# Here are the actual functions of interest

glm.Lexis <- 
function( Lx, resp, formula, xpos, link="log", scale=1    , verbose=TRUE   , ... ) {
modLexis( Lx, resp, formula, xpos, link=link , scale=scale, verbose=verbose, ..., model=stats::glm ) }

gam.Lexis <- 
function( Lx, resp, formula, xpos, link="log", scale=1    , verbose=TRUE   , ... ) {
modLexis( Lx, resp, formula, xpos, link=link , scale=scale, verbose=verbose, ..., model= mgcv::gam ) }

# and here the coxph counterpart:

coxph.Lexis <- 
function( Lx, # Lexis object 
        resp, # Events ('to' states)
     formula, # timescale ~ model
        xpos, # exposure states ('from' states)
     verbose = TRUE,
          ... )
{
# Lexis object ?
if( !inherits(Lx,"Lexis") ) stop( "The first argument must be a Lexis object.\n")
nameLx <- deparse(substitute(Lx))

# check levels    
if( is.numeric(resp) ) resp <- levels( Lx$lex.Xst )[resp]
wh <- match(resp,levels(Lx$lex.Xst))
if( any(is.na(wh)) ) stop("'resp' must be a subset of: '", 
                     paste(levels(Lx$lex.Xst), collapse="','", sep=""), "'\n" )  

# is xpos supplied?
if( !missing(xpos) )
  {
# check that xpos are actual levels of lex.Cst 
if( is.numeric(xpos) ) xpos <- levels( Lx$lex.Cst )[xpos]
wh <- match( xpos, levels(Lx$lex.Cst) )
if( any(is.na(wh)) ) stop("'xpos' must be a subset of: '", 
                     paste(levels(Lx$lex.Cst), collapse="', '", sep=""), "'\n" )  
Lx <- Lx[Lx$lex.Cst %in% xpos,]                     
  } 

# Correct formula?
if( length(formula) != 3 ) stop("'formula' must be a 2-sided formula, with the l.h.s. the timescale")

# Is the l.h.s. a timescale?
ts <- as.character( formula[2] )
if( !(ts %in% (tms<-timeScales(Lx))) ) 
  stop( "l.h.s. of formula must be a timescale; one of:\n", tms, "\n" )

# What are the 'from' states
xpos <- levels( factor(Lx$lex.Cst) )
    
# construct a Surv response object, and note that we want the possibility
# of transitions to transient states, hence the lex.Xst != lex.Cst 
Sobj <- Surv( Lx[,ts], 
              Lx[,ts]+Lx$lex.dur,
              Lx$lex.Xst %in% resp &
              Lx$lex.Xst != Lx$lex.Cst )

# Tell what we intend to and then do it    
cat( "survival::coxph analysis of Lexis object ", nameLx, " using timescale ", ts,
     ":\nTransition rates from '", paste( xpos, collapse="','"), 
                         "' to '", paste( resp, collapse="','"),  "'\n", sep="" )
mod <- coxph( as.formula( paste( "Sobj", 
                                 as.character(formula[3]),
                                 sep="~") ), 
              data = Lx, ... )

# An explanatory attribute
attr( mod, "Lexis" ) <- list( Exposure=xpos, Events=resp, Timescale=ts )
mod
}
back to top