R/as.mxMatrix.R

In metaSEM: Meta-Analysis using Structural Equation Modeling

as.mxMatrix <- function(x, name, ...) {
    ## If it is a vector, the output is a column matrix.
    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    # suppress warnings
    ## warn <- options()$warn
    ## options(warn=-1)
    nRow <- nrow(x)
    nCol <- ncol(x)

    # check if "name" was give
    # if not, use the matrix name
    if (missing(name)) {
        name <- as.character(match.call())[2]

        ## Check if "$" is present
        ## Suppose RAM$F, the output name is "F"
        if (grepl("$", name, fixed=TRUE)) {
            name <- strsplit(name, "$", fixed=TRUE)[[1]][2]
        }    
    }

    values <- suppressWarnings(as.numeric(x))  # They are NA for characters
    free <- is.na(values)    # They are TRUE for parameters with labels
    freePara1 <- x[free]     # Extract free parameters
    # check if there are any free parameters

    if (length(freePara1)>0) {
        freePara2 <- strsplit(freePara1, "*", fixed=TRUE)
        # replace NA with starting values 0.5 before "0.5*a"
        values[free] <- suppressWarnings(sapply(freePara2, function(x){ as.numeric(x[1])}))
        labels <- matrix(NA, ncol=nCol, nrow=nRow)
        labels[free] <- sapply(freePara2, function(x){ x[2]})
    
        ## Replace TRUE by FALSE in free when there are definition variables or [,]
        free[grep("data.", labels)] <- FALSE
        free[grep("\\[|,|\\]", labels)] <- FALSE

        ## Check any "@"
        x_pos <- grep("@", x, fixed=TRUE)
        if (length(x_pos)>0) {
            x_at <- strsplit(x=x[x_pos], split="@", fixed=TRUE)
            for (i in seq_along(x_at)) {
                values[x_pos[i]] <- as.numeric(x_at[[i]][1])
                labels[x_pos[i]] <- x_at[[i]][2]
                free[x_pos[i]] <- FALSE                
            }
        }
        
        out <- mxMatrix(type = "Full", nrow=nRow, ncol=nCol, values=values, free=free,
                        name=name, labels=labels, ...)
    } else {
        out <- mxMatrix(type = "Full", nrow=nRow, ncol=nCol, values=values, free=free,
                        name=name, ...)
    }

    ## Add the dimnames only when there are dimnames
    if (!is.null(dimnames(x))) {
        if (!is.null(rownames(x))) {
            if (rownames(x)[1] != "1") {
                ## Make the names valid for the Mmatrix, which has "1" as the rownames
                dim.names <- lapply(dimnames(x), make.names)
                dimnames(out@values) <- dimnames(out@labels) <- dimnames(out@free) <- dim.names
            }
        }
   }
    
  ## options(warn=warn)
  out
}

as.symMatrix <- function(x) {
  if (is.list(x)) {
    ## for (i in seq_along(x)) {
    ## Exclude mxalgebras, which creates troubles
    for (i in c("A", "S", "F", "M")) {
      x[[i]][] <- vapply(x[[i]], function(z) gsub(".*\\*", "", z), character(1))
    }
  } else {
    x[] <- vapply(x, function(z) gsub(".*\\*", "", z), character(1))
  }
  x
}

as.mxAlgebra <- function(x, startvalues=NULL, lbound=NULL, ubound=NULL,
                         name="X") {
  ## If it is a vector, the output is a column matrix.
  if (!is.matrix(x)) {
    x <- as.matrix(x)
  }
  
  ## Xvars: a column vector of the parameters in x, e.g., a, b, c.
  vars <- sort(all.vars(parse(text=x)))
  ## Provide 0 as starting value 
  Xvars <- create.mxMatrix(paste0("0*", vars), ncol=1, nrow=length(vars))
  ## Change the matrix name
  Xvars@name <- paste0(name, "vars")

  ## Change the starting values in Xvars, if provided
  if (!is.null(startvalues)) {
    for (i in seq_along(startvalues)) {
      starti <- unlist(startvalues[i])
      Xvars$values[Xvars$labels==names(starti)] <- starti
    }
  }

  ## Add lbound
  if (!is.null(lbound)) {
    for (i in seq_along(lbound)) {
      index <- Xvars$labels==names(lbound)[i]
      ## NAs are treated as FALSE
      index[is.na(index)] <- FALSE
      Xvars$lbound[index] <- lbound[[i]]
    }
  }

  ## Add ubound
  if (!is.null(ubound)) {
    for (i in seq_along(ubound)) {
      index <- Xvars$labels==names(ubound)[i]
      index[is.na(index)] <- FALSE
      Xvars$ubound[index] <- ubound[[i]]
    }
  }
    
  xrow <- nrow(x)
  xcol <- ncol(x)

  ## This is general but not efficient
  ## The mxAlgebra matrix is built on rbind(cbind(...)) of each Xi_j
  ## If x[i,j] = a^b, then Xij <- mxAlgebra(a^b, name="xi_j")
  for (j in seq_len(xcol))
    for (i in seq_len(xrow)) {
      ## Elements of each Xi_j
      Xij <- paste0(name,i,"_",j, " <- mxAlgebra(",x[i,j], ", name='",name,i,"_",j,"')")
      eval(parse(text=Xij))               
    }

  ## Xmat: a matrix of the named Xi_j of mxalgebra
  Xmat <- outer(seq_len(xrow), seq_len(xcol), function(x, y) paste0(name,x,"_",y))
  Xmat <- paste0("cbind(", apply(Xmat, 1, paste0, collapse=", "), ")")
  Xmatrix  <- paste0(name, " <- mxAlgebra(rbind(", paste0(Xmat, collapse=", "),
                       "), name='", name,"')")
  eval(parse(text=Xmatrix))

  ## Prepare mxalgebra matrices for output
  ## "name", e.g., A: the mxAlgebra object
  ## Xvars, e.g., Avars: the variables (parameters) to build the mxAlgebra
  ## names: a list of the names of these matrices
  ## Xlist, e.g., Alist: a list of mxalgebra of X1_1, X1_2, X2_1, ...
  Xlist <- outer(seq_len(xrow), seq_len(xcol), function(x,y) paste0(name,x,"_",y))
  Xnames <- c(name, Xvars@name, Xlist)
  Xlist <- paste0("list(", paste0(Xlist, "=", Xlist, collapse=", "), ")")
  Xlist <- eval(parse(text=Xlist))
  # list(Xmatrix=Xmatrix, Xvars=Xvars, Xnames=Xnames, Xlist=Xlist)
  
  ## out <- paste0("out <- list(", name, "=", name, ", names=Xnames, ", name, 
  ##               "vars=Xvars, ", name, "list=Xlist",")" )
  out <- paste0("out <- list(mxalgebra=", name, ", parameters=Xvars, list=Xlist",")" )
  eval(parse(text=out))
  out
}