R/parsedesign.R

In kkholst/lava: Latent Variable Models

sumsplit <- function(x,...) {
    plus <- strsplit(x,"\\+")[[1]]
    spl <- unlist(lapply(plus, function(x) {
        val <- strsplit(x,"\\-")[[1]]
        val[-1] <- paste0("-",val[-1])
        setdiff(val,"")
    }))
    res <- c()
    for (st in spl) {
        st <- gsub(" ","",st)
        st0 <- gsub("^[-0-9\\*]*","",st)
        val <- gsub("\\*","",regmatches(st,gregexpr("^[-0-9\\*]*",st))[[1]])
        if (val=="") val <- "1"
        val <- switch(val,"-"=-1,val)
        res <- c(res,val,st0)    
    }
    return(res)
}

##' @export
parsedesign <- function(coef,x,...,regex=FALSE,diff=TRUE) {
    if (!is.vector(coef)) coef <- stats::coef(coef)
    if (is.numeric(coef) && !is.null(names(coef))) coef <- names(coef)    
    dots <- lapply(substitute(list(...)),function(x) x)[-1]
    expr <- suppressWarnings(inherits(try(x,silent=TRUE),"try-error"))
    if (expr) {
        ee <- c(deparse(substitute(x)), unlist(lapply(dots, deparse)))
    } else {
        ee <- c(deparse(x), sapply(dots, function(x) deparse(x)))
    }
    if (!expr && is.numeric(x)) {
        return(do.call(contr, list(c(list(x),list(...)),n=length(coef),diff=diff)))
    }
    res <- c()
    diff <- rep(diff,length.out=length(ee))
    count <- 0
    for (e in ee) {
        count <- count+1
        diff0 <- FALSE
        Val <- rbind(rep(0,length(coef)))
        if (grepl('\"',e)) {        
            diff0 <- diff[count] && grepl("^c\\(",e)
            e0 <- gsub(" |\\)$|^c\\(","",e)
            ff <- strsplit(e0,'\"')[[1L]]
        } else {
            ff <- sumsplit(e)
        }
        for (i in seq(length(ff)/2)) {
            val0 <- gsub("[*()]","",ff[2*(i-1)+1])            
            val <- char2num(val0)
            if (is.na(val)) {
                val <- switch(val0,"-"=-1,1)
            }
            par0 <- ff[2*i]
            par0int <- as.integer(char2num(par0))
            if (!regex) par0 <- glob2rx(par0)
            if (is.na(par0int)) par0int <- grep(par0,coef)
            if (length(par0int)>1) {
                diff0 <- diff[count]
                for (k in seq_along(par0int)) {
                    if (par0int[k]<=length(Val)) {
                        if (diff[count]) {
                            Val[par0int[k]] <- val
                        } else {
                            Val0 <- Val; Val0[] <- 0
                            Val0[par0int[k]] <- val
                            res <- rbind(res,Val0)
                        }
                    }
                }
            } else {
                if (length(par0int)>0 && par0int<=length(Val)) Val[par0int] <- val
            }
        }
        if (diff0) {
            n <- sum(Val!=0)
            if (n>1) {
                Val0 <- Val
                ii <- which(Val0!=0)
                Val <- matrix(0,nrow=n-1,ncol=length(Val))
                for (i in seq(n-1)) {
                    Val[i,ii[c(1,i+1)]] <- Val0[ii[c(1,i+1)]]*c(1,-1)
                }
            }
        }
        if (any(Val!=0)) res <- rbind(res,Val)
    }
    res
}