\newcommand{\NWtarget}[2]{\hypertarget{#1}{#2}} \newcommand{\NWlink}[2]{\hyperlink{#1}{#2}} \newcommand{\NWtxtMacroDefBy}{Fragment defined by} \newcommand{\NWtxtMacroRefIn}{Fragment referenced in} \newcommand{\NWtxtMacroNoRef}{Fragment never referenced} \newcommand{\NWtxtDefBy}{Defined by} \newcommand{\NWtxtRefIn}{Referenced in} \newcommand{\NWtxtNoRef}{Not referenced} \newcommand{\NWtxtFileDefBy}{File defined by} \newcommand{\NWtxtIdentsUsed}{Uses:} \newcommand{\NWtxtIdentsNotUsed}{Never used} \newcommand{\NWtxtIdentsDefed}{Defines:} \newcommand{\NWsep}{${\diamond}$} \newcommand{\NWnotglobal}{(not defined globally)} \newcommand{\NWuseHyperlinks}{} \documentclass[a4paper]{report} \usepackage{a4wide} %%% DO NOT EDIT THIS FILE %%% Edit 'lmvnorm_src.w' and run 'nuweb -r lmvnorm_src.w' %% packages \usepackage{amsfonts,amstext,amsmath,amssymb,amsthm,nicefrac} %\VignetteIndexEntry{Multivariate Normal Log-likelihoods in the mvtnorm Package} %\VignetteDepends{mvtnorm,qrng,numDeriv} %\VignetteKeywords{multivariate normal distribution} %\VignettePackage{mvtnorm} \usepackage[utf8]{inputenc} \newif\ifshowcode \showcodetrue \usepackage{latexsym} %\usepackage{html} \usepackage{listings} \usepackage{color} \definecolor{linkcolor}{rgb}{0, 0, 0.7} \usepackage[% backref,% raiselinks,% pdfhighlight=/O,% pagebackref,% hyperfigures,% breaklinks,% colorlinks,% pdfpagemode=None,% pdfstartview=FitBH,% linkcolor={linkcolor},% anchorcolor={linkcolor},% citecolor={linkcolor},% filecolor={linkcolor},% menucolor={linkcolor},% pagecolor={linkcolor},% urlcolor={linkcolor}% ]{hyperref} \usepackage[round]{natbib} %\setlength{\oddsidemargin}{0in} %\setlength{\evensidemargin}{0in} %\setlength{\topmargin}{0in} %\addtolength{\topmargin}{-\headheight} %\addtolength{\topmargin}{-\headsep} %\setlength{\textheight}{8.9in} %\setlength{\textwidth}{6.5in} %\setlength{\marginparwidth}{0.5in} \newcommand{\pkg}[1]{\textbf{#1}} \newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\cmd}[1]{\texttt{#1()}} \newcommand{\R}{\mathbb{R} } \newcommand{\Prob}{\mathbb{P} } \newcommand{\ND}{\mathbb{N} } \newcommand{\J}{J} \newcommand{\K}{K} \newcommand{\V}{\mathbb{V}} %% cal{\mbox{\textnormal{Var}}} } \newcommand{\E}{\mathbb{E}} %%mathcal{\mbox{\textnormal{E}}} } \newcommand{\yvec}{\mathbf{y}} \newcommand{\wvec}{\mathbf{w}} \newcommand{\avec}{\mathbf{a}} \newcommand{\bvec}{\mathbf{b}} \newcommand{\xvec}{\mathbf{x}} \newcommand{\svec}{\mathbf{s}} \newcommand{\jvec}{\mathbf{j}} \newcommand{\muvec}{\boldsymbol{\mu}} \newcommand{\etavec}{\boldsymbol{\eta}} \newcommand{\rY}{\mathbf{Y}} \newcommand{\rX}{\mathbf{X}} \newcommand{\rZ}{\mathbf{Z}} \newcommand{\mC}{\mathbf{C}} \newcommand{\mL}{\mathbf{L}} \newcommand{\mP}{\mathbf{P}} \newcommand{\mR}{\mathbf{R}} \newcommand{\mT}{\mathbf{T}} \newcommand{\mB}{\mathbf{B}} \newcommand{\mI}{\mathbf{I}} \newcommand{\mS}{\mathbf{S}} \newcommand{\mA}{\mathbf{A}} \newcommand{\mD}{\mathbf{D}} \newcommand{\diag}{\text{diag}} \newcommand{\mSigma}{\mathbf{\Sigma}} \newcommand{\argmin}{\operatorname{argmin}\displaylimits} \newcommand{\argmax}{\operatorname{argmax}\displaylimits} \newcommand{\vecop}{\text{vec}} <>= year <- substr(packageDescription("mvtnorm")$Date, 1, 4) version <- packageDescription("mvtnorm")$Version @ <>= options(digits = 4) @ \author{Torsten Hothorn} \date{Version \Sexpr{version}} \title{Multivariate Normal Log-likelihoods \\ in the \pkg{mvtnorm} Package \footnote{Please cite this document as: Torsten Hothorn (\Sexpr{year}) Multivariate Normal Log-likelihoods in the \pkg{mvtnorm} Package. \textsf{R} package vignette version \Sexpr{version}, URL \href{https://doi.org/10.32614/CRAN.package.mvtnorm}{DOI:10.32614/CRAN.package.mvtnorm}.} } \begin{document} \pagenumbering{roman} \maketitle \tableofcontents \chapter*{Licence} {\setlength{\parindent}{0cm} Copyright (C) 2022-- Torsten Hothorn \\ This file is part of the \pkg{mvtnorm} \proglang{R} add-on package. \\ \pkg{mvtnorm} is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, version 2. \\ \pkg{mvtnorm} is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. \\ You should have received a copy of the GNU General Public License along with \pkg{mvtnorm}. If not, see . } \chapter{Introduction} \pagenumbering{arabic} This document describes an implementation of \cite{numerical-:1992} and, partially, of \cite{Genz_Bretz_2002}, for the evaluation of $N$ multivariate $\J$-dimensional normal probabilities \begin{eqnarray} \label{pmvnorm} p_i(\mC_i \mid \avec_i, \bvec_i) = \Prob(\avec_i < \rY_i \le \bvec_i \mid \mC_i ) = (2 \pi)^{-\frac{\J}{2}} \text{det}(\mC_i)^{-1} \int_{\avec_i}^{\bvec_i} \exp\left(-\frac{1}{2} \yvec^\top \mC_i^{-\top} \mC_i^{-1} \yvec\right) \, d \yvec \end{eqnarray} where $\avec_i = (a^{(i)}_1, \dots, a^{(i)}_\J)^\top \in \R^\J$ and $\bvec_i = (b^{(i)}_1, \dots, b^{(i)}_\J)^\top \in \R^\J$ are integration limits, $\mC_i = (c^{(i)}_{j\jmath}) \in \R^{\J \times \J}$ is a lower triangular matrix with $c^{(i)}_{j \jmath} = 0$ for $1 \le j < \jmath < \J$, and thus $\rY_i \sim \ND_\J(\mathbf{0}_\J, \mC_i \mC_i^\top)$ for $i = 1, \dots, N$. One application of these integrals is the estimation of the Cholesky factor $\mC$ of a $\J$-dimensional normal distribution based on $N$ interval-censored observations $\rY_1, \dots, \rY_\J$ (encoded by $\avec$ and $\bvec$) via maximum-likelihood \begin{eqnarray*} \hat{\mC} = \argmax_\mC \sum_{i = 1}^N \log(p_i(\mC \mid \avec_i, \bvec_i)). \end{eqnarray*} In other applications, the Cholesky factor might also depend on $i$ in some structured way. Function \code{pmvnorm} in package \code{mvtnorm} computes $p_i$ based on the covariance matrix $\mC_i \mC_i^\top$. However, the Cholesky factor $\mC_i$ of the given covariance matrix is computed in \proglang{FORTRAN} first each time this function is called. Function \code{pmvnorm} is not vectorised over $i = 1, \dots, N$ and thus separate calls to this function are necessary in order to compute likelihood contributions. The implementation described here is a re-implementation (in \proglang{R} and \proglang{C}) of Alan Genz' original \proglang{FORTRAN} code, focusing on efficient computation of the log-likelihood $\sum_{i = 1}^N \log(p_i)$ and the corresponding score function. The document first describes a class and some useful methods for dealing with multiple lower triangular matrices $\mC_i, i = 1, \dots, N$ in Chapter~\ref{ltMatrices}. The multivariate normal log-likelihood, and the corresponding score function, is implemented as outlined in Chapter~\ref{lpmvnorm}. An example demonstrating maximum-likelihood estimation of Cholesky factors in the presence of interval-censored observations is discussed in Chapter~\ref{ML}. We use the technology developed here to implement the log-likelihood and score function for situations where some variables have been observed exactly and others only in form of interval-censoring in Chapter~\ref{cdl} and for nonparametric maximum-likelihood estimation in unstructured Gaussian copulae in Chapter~\ref{copula}. An attempt to provide useRs with a simple and (hopefully) bullet proof interface is documented in Chapter~\ref{inter}. The development of this infrastructure was motivated by the necessity to evaluate probabilities~(\ref{pmvnorm}) arising in the likelihood of multivariate conditional transformation models \citep{Klein_Hothorn_Barbanti_2020} for discrete or censored observations. Some forms of the likelihood for such nonparanormal models are discussed in \cite{Hothorn_2024}. \chapter{Lower Triangular Matrices} \label{ltMatrices} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap1}\raggedright\small \NWtarget{nuweb2}{} \verb@"ltMatrices.R"@\nobreak\ {\footnotesize {2}}$\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape R Header}\nobreak\ {\footnotesize \NWlink{nuweb136}{136}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb6a}{6a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape syMatrices}\nobreak\ {\footnotesize \NWlink{nuweb6b}{6b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape dim ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb6c}{6c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape dimnames ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb7a}{7a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape names ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb7b}{7b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape is.ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb7c}{7c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape as.ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb114b}{114b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape print ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb11}{11}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape reorder ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb12}{12}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape subset ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb14}{14}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lower triangular elements}\nobreak\ {\footnotesize \NWlink{nuweb17}{17}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape diagonals ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb19}{19}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape diagonal matrix}\nobreak\ {\footnotesize \NWlink{nuweb22}{22}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mult ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb23a}{23a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mult syMatrices}\nobreak\ {\footnotesize \NWlink{nuweb27}{27}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape solve ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb31}{31}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape logdet ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb33b}{33b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape tcrossprod ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb37}{37}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape crossprod ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb38}{38}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape chol syMatrices}\nobreak\ {\footnotesize \NWlink{nuweb39}{39}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape add diagonal elements}\nobreak\ {\footnotesize \NWlink{nuweb20}{20}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape assign diagonal elements}\nobreak\ {\footnotesize \NWlink{nuweb21}{21}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape kronecker vec trick}\nobreak\ {\footnotesize \NWlink{nuweb44}{44}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape convenience functions}\nobreak\ {\footnotesize \NWlink{nuweb48}{48}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape aperm}\nobreak\ {\footnotesize \NWlink{nuweb51a}{51a}, \ldots\ }$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape marginal}\nobreak\ {\footnotesize \NWlink{nuweb52b}{52b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape conditional}\nobreak\ {\footnotesize \NWlink{nuweb55}{55}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape check obs}\nobreak\ {\footnotesize \NWlink{nuweb57b}{57b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape colSumsdnorm ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb58b}{58b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap2}\raggedright\small \NWtarget{nuweb3}{} \verb@"ltMatrices.c"@\nobreak\ {\footnotesize {3}}$\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape C Header}\nobreak\ {\footnotesize \NWlink{nuweb137}{137}}$\,\rangle$}\verb@@\\ \mbox{}\verb@#ifndef USE_FC_LEN_T@\\ \mbox{}\verb@# define USE_FC_LEN_T@\\ \mbox{}\verb@#endif@\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include /* for dtptri */@\\ \mbox{}\verb@#ifndef FCONE@\\ \mbox{}\verb@# define FCONE@\\ \mbox{}\verb@#endif@\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include @\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape colSumsdnorm}\nobreak\ {\footnotesize \NWlink{nuweb58a}{58a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape solve}\nobreak\ {\footnotesize \NWlink{nuweb29}{29}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape solve C}\nobreak\ {\footnotesize \NWlink{nuweb30}{30}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape logdet}\nobreak\ {\footnotesize \NWlink{nuweb33a}{33a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape tcrossprod}\nobreak\ {\footnotesize \NWlink{nuweb36}{36}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mult}\nobreak\ {\footnotesize \NWlink{nuweb24b}{24b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mult transpose}\nobreak\ {\footnotesize \NWlink{nuweb26}{26}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape chol}\nobreak\ {\footnotesize \NWlink{nuweb40}{40}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape vec trick}\nobreak\ {\footnotesize \NWlink{nuweb42a}{42a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We first define and implement infrastructure for dealing with multiple lower triangular matrices $\mC_i \in \R^{\J \times \J}$ for $i = 1, \dots, N$. We note that each such matrix $\mC$ can be stored in a vector of length $\J (\J + 1) / 2$. If all diagonal elements are one (that is, $c^{(i)}_{jj} \equiv 1, j = 1, \dots, \J$), the length of this vector is $\J (\J - 1) / 2$. \section{Multiple Lower Triangular Matrices} We can store $N$ such matrices in an $\J (\J + 1) / 2 \times N$ matrix (\code{diag = TRUE}) or, for \code{diag = FALSE}, in an $\J (\J - 1) / 2 \times N$ matrix. Each vector might define the corresponding lower triangular matrix either in row or column-major order: \begin{eqnarray*} \mC & = & \begin{pmatrix} c_{11} & & & & 0\\ c_{21} & c_{22} \\ c_{31} & c_{32} & c_{33} \\ \vdots & \vdots & & \ddots & \\ c_{J1} & c_{J2} & \ldots & & c_{JJ} \end{pmatrix} \text{matrix indexing}\\ & = & \begin{pmatrix} c_{1} & & & & 0\\ c_{2} & c_{J + 1} \\ c_{3} & c_{J + 2} & c_{2J} \\ \vdots & \vdots & & \ddots & \\ c_{J} & c_{2J - 1} & \ldots & & c_{J(J + 1) / 2} \end{pmatrix} \text{column-major, \code{byrow = FALSE}} \\ & = & \begin{pmatrix} c_{1} & & & & 0\\ c_{2} & c_{3} \\ c_{4} & c_{5} & c_{6} \\ \vdots & \vdots & & \ddots & \\ c_{J((J + 1) / 2 -1) + 1} & c_{J((J + 1) / 2 -1) + 2} & \ldots & & c_{J(J + 1) / 2} \end{pmatrix} \text{row-major, \code{byrow = TRUE}} \end{eqnarray*} Based on some matrix \code{object}, the dimension $\J$ is computed and checked as \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap3}\raggedright\small \NWtarget{nuweb4}{} $\langle\,${\itshape ltMatrices dim}\nobreak\ {\footnotesize {4}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@J <- floor((1 + sqrt(1 + 4 * 2 * nrow(object))) / 2 - diag)@\\ \mbox{}\verb@if (nrow(object) != J * (J - 1) / 2 + diag * J)@\\ \mbox{}\verb@ stop("Dimension of object does not correspond to lower @\\ \mbox{}\verb@ triangular part of a square matrix")@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb6a}{6a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Typically the $\J$ dimensions are associated with names, and we therefore compute identifiers for the vector elements in either column- or row-major order on request (for later printing) \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap4}\raggedright\small \NWtarget{nuweb5a}{} $\langle\,${\itshape ltMatrices names}\nobreak\ {\footnotesize {5a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@nonames <- FALSE@\\ \mbox{}\verb@if (!isTRUE(names)) {@\\ \mbox{}\verb@ if (is.character(names))@\\ \mbox{}\verb@ stopifnot(is.character(names) &&@\\ \mbox{}\verb@ length(unique(names)) == J)@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ nonames <- TRUE@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ names <- as.character(1:J)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (!nonames) {@\\ \mbox{}\verb@ L1 <- matrix(names, nrow = J, ncol = J)@\\ \mbox{}\verb@ L2 <- matrix(names, nrow = J, ncol = J, byrow = TRUE)@\\ \mbox{}\verb@ L <- matrix(paste(L1, L2, sep = "."), nrow = J, ncol = J)@\\ \mbox{}\verb@ if (byrow)@\\ \mbox{}\verb@ rownames(object) <- t(L)[upper.tri(L, diag = diag)]@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ rownames(object) <- L[lower.tri(L, diag = diag)]@\\ \mbox{}\verb@} # else { ### add later@\\ \mbox{}\verb@ # warning("ltMatrices objects should be properly named")@\\ \mbox{}\verb@# }@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb6a}{6a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} If \code{object} is already a classed object representing lower triangular matrices (we will use the class name \code{ltMatrices}), we might want to change the storage form from row- to column-major or the other way round. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap5}\raggedright\small \NWtarget{nuweb5b}{} $\langle\,${\itshape ltMatrices input}\nobreak\ {\footnotesize {5b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (is.ltMatrices(object)) {@\\ \mbox{}\verb@ cls <- class(object) ### keep inheriting classes@\\ \mbox{}\verb@ ret <- .reorder(object, byrow = byrow)@\\ \mbox{}\verb@ class(ret) <- class(object)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb6a}{6a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The constructor essentially attaches attributes to a matrix \code{object}, possibly after some reordering / transposing \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap6}\raggedright\small \NWtarget{nuweb6a}{} $\langle\,${\itshape ltMatrices}\nobreak\ {\footnotesize {6a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@ltMatrices <- function(object, diag = FALSE, byrow = FALSE, names = TRUE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!is.matrix(object)) @\\ \mbox{}\verb@ object <- matrix(object, ncol = 1L)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape ltMatrices input}\nobreak\ {\footnotesize \NWlink{nuweb5b}{5b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape ltMatrices dim}\nobreak\ {\footnotesize \NWlink{nuweb4}{4}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape ltMatrices names}\nobreak\ {\footnotesize \NWlink{nuweb5a}{5a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ attr(object, "J") <- J@\\ \mbox{}\verb@ attr(object, "diag") <- diag@\\ \mbox{}\verb@ attr(object, "byrow") <- byrow@\\ \mbox{}\verb@ attr(object, "rcnames") <- names@\\ \mbox{}\verb@@\\ \mbox{}\verb@ class(object) <- c("ltMatrices", class(object))@\\ \mbox{}\verb@ object@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} For the sake of completeness, we also add a constructor for multiple symmetric matrices \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap7}\raggedright\small \NWtarget{nuweb6b}{} $\langle\,${\itshape syMatrices}\nobreak\ {\footnotesize {6b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@as.syMatrices <- function(x) {@\\ \mbox{}\verb@ if (is.syMatrices(x))@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@ x <- as.ltMatrices(x) ### make sure "ltMatrices"@\\ \mbox{}\verb@ ### is first class@\\ \mbox{}\verb@ class(x)[1L] <- "syMatrices"@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@syMatrices <- function(object, diag = FALSE, byrow = FALSE, names = TRUE)@\\ \mbox{}\verb@ as.syMatrices(ltMatrices(object = object, diag = diag, byrow = byrow, @\\ \mbox{}\verb@ names = names))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The dimensions of such an object are always $N \times \J \times \J$ and are given by \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap8}\raggedright\small \NWtarget{nuweb6c}{} $\langle\,${\itshape dim ltMatrices}\nobreak\ {\footnotesize {6c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dim.ltMatrices <- function(x) {@\\ \mbox{}\verb@ J <- attr(x, "J")@\\ \mbox{}\verb@ return(c(attr(x, "dim")[2L], J, J)) ### ncol(unclass(x)) may trigger gc@\\ \mbox{}\verb@}@\\ \mbox{}\verb@dim.syMatrices <- dim.ltMatrices@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The corresponding dimnames can be extracted as \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap9}\raggedright\small \NWtarget{nuweb7a}{} $\langle\,${\itshape dimnames ltMatrices}\nobreak\ {\footnotesize {7a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dimnames.ltMatrices <- function(x)@\\ \mbox{}\verb@ return(list(attr(x, "dimnames")[[2L]], attr(x, "rcnames"), attr(x, "rcnames")))@\\ \mbox{}\verb@dimnames.syMatrices <- dimnames.ltMatrices@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The names identifying rows and columns in each $\mC_i$ are \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap10}\raggedright\small \NWtarget{nuweb7b}{} $\langle\,${\itshape names ltMatrices}\nobreak\ {\footnotesize {7b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@names.ltMatrices <- function(x) {@\\ \mbox{}\verb@ return(attr(x, "dimnames")[[1L]])@\\ \mbox{}\verb@}@\\ \mbox{}\verb@names.syMatrices <- names.ltMatrices@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Finally, let's add two functions for checking the class and a function for coersing classes inheriting from \code{ltMatrices} to the latter, the same for \code{syMatrices}. Furthermode, \code{as.ltMatrices} coerces objects inheriting from \code{syMatrices} or \code{ltMatrices} to class \code{ltMatrices} (that is, \code{chol} or \code{invchol} is removed from the class list, unlike a call to the constructor \code{ltMatrices}). A \code{default} method is added in Chapter~\ref{inter}. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap11}\raggedright\small \NWtarget{nuweb7c}{} $\langle\,${\itshape is.ltMatrices}\nobreak\ {\footnotesize {7c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@is.ltMatrices <- function(x) inherits(x, "ltMatrices")@\\ \mbox{}\verb@is.syMatrices <- function(x) inherits(x, "syMatrices")@\\ \mbox{}\verb@as.ltMatrices <- function(x) UseMethod("as.ltMatrices")@\\ \mbox{}\verb@as.ltMatrices.syMatrices <- function(x) {@\\ \mbox{}\verb@ cls <- class(x)@\\ \mbox{}\verb@ class(x) <- cls[which(cls == "syMatrices"):length(cls)]@\\ \mbox{}\verb@ class(x)[1L] <- "ltMatrices"@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@as.ltMatrices.ltMatrices <- function(x) {@\\ \mbox{}\verb@ cls <- class(x)@\\ \mbox{}\verb@ class(x) <- cls[which(cls == "ltMatrices"):length(cls)]@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Let's set-up an example for illustration. Throughout this document, we will compare numerical results using <>= chk <- function(...) stopifnot(isTRUE(all.equal(...))) @ We start with a a simple example demonstrating how to set-up \code{ltMatrices} objects <>= library("mvtnorm") set.seed(290875) N <- 4L J <- 5L rn <- paste0("C_", 1:N) nm <- LETTERS[1:J] Jn <- J * (J - 1) / 2 ## data xn <- matrix(runif(N * Jn), ncol = N) colnames(xn) <- rn xd <- matrix(runif(N * (Jn + J)), ncol = N) colnames(xd) <- rn (lxn <- ltMatrices(xn, byrow = TRUE, names = nm)) dim(lxn) dimnames(lxn) lxd <- ltMatrices(xd, byrow = TRUE, diag = TRUE, names = nm) dim(lxd) dimnames(lxd) lxn <- as.syMatrices(lxn) lxn @ \section{Printing} For pretty printing, we coerse objects of class \code{ltMatrices} to \code{array}. The method has a logical argument called \code{symmetric}, forcing the lower triangular matrix to by interpreted as a symmetric matrix. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap12}\raggedright\small \NWtarget{nuweb10}{} $\langle\,${\itshape extract slots}\nobreak\ {\footnotesize {10}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@diag <- attr(x, "diag")@\\ \mbox{}\verb@byrow <- attr(x, "byrow")@\\ \mbox{}\verb@d <- dim(x)@\\ \mbox{}\verb@J <- d[2L]@\\ \mbox{}\verb@dn <- dimnames(x)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb11}{11}\NWlink{nuweb12}{, 12}\NWlink{nuweb13}{, 13}\NWlink{nuweb17}{, 17}\NWlink{nuweb19}{, 19}\NWlink{nuweb21}{, 21}\NWlink{nuweb23a}{, 23a}\NWlink{nuweb27}{, 27}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap13}\raggedright\small \NWtarget{nuweb11}{} $\langle\,${\itshape print ltMatrices}\nobreak\ {\footnotesize {11}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@as.array.ltMatrices <- function(x, symmetric = FALSE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ L <- matrix(1L, nrow = J, ncol = J)@\\ \mbox{}\verb@ diag(L) <- 2L@\\ \mbox{}\verb@ if (byrow) {@\\ \mbox{}\verb@ L[upper.tri(L, diag = diag)] <- floor(2L + 1:(J * (J - 1) / 2L + diag * J))@\\ \mbox{}\verb@ L <- t(L)@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ L[lower.tri(L, diag = diag)] <- floor(2L + 1:(J * (J - 1) / 2L + diag * J))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (symmetric) {@\\ \mbox{}\verb@ L[upper.tri(L)] <- 0L@\\ \mbox{}\verb@ dg <- diag(L)@\\ \mbox{}\verb@ L <- L + t(L)@\\ \mbox{}\verb@ diag(L) <- dg@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ ret <- rbind(0, 1, x)[c(L), , drop = FALSE]@\\ \mbox{}\verb@ class(ret) <- "array"@\\ \mbox{}\verb@ dim(ret) <- d[3:1]@\\ \mbox{}\verb@ dimnames(ret) <- dn[3:1]@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@as.array.syMatrices <- function(x, ...)@\\ \mbox{}\verb@ return(as.array.ltMatrices(x, symmetric = TRUE))@\\ \mbox{}\verb@@\\ \mbox{}\verb@print.ltMatrices <- function(x, ...)@\\ \mbox{}\verb@ print(as.array(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@print.syMatrices <- function(x, ...)@\\ \mbox{}\verb@ print(as.array(x))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Symmetric matrices are represented by lower triangular matrix objects, but we change the class from \code{ltMatrices} to \code{syMatrices} (which disables all functionality except printing and coersion to arrays). \section{Reordering} It is sometimes convenient to have access to lower triangular matrices in either column- or row-major order and this little helper function switches between the two forms \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap14}\raggedright\small \NWtarget{nuweb12}{} $\langle\,${\itshape reorder ltMatrices}\nobreak\ {\footnotesize {12}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@.reorder <- function(x, byrow = FALSE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(is.ltMatrices(x))@\\ \mbox{}\verb@ if (attr(x, "byrow") == byrow) return(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ rL <- cL <- diag(0, nrow = J)@\\ \mbox{}\verb@ rL[lower.tri(rL, diag = diag)] <- cL[upper.tri(cL, diag = diag)] <- 1:nrow(x)@\\ \mbox{}\verb@ cL <- t(cL)@\\ \mbox{}\verb@ if (byrow) ### row -> col order@\\ \mbox{}\verb@ return(ltMatrices(x[cL[lower.tri(cL, diag = diag)], , drop = FALSE], @\\ \mbox{}\verb@ diag = diag, byrow = FALSE, names = dn[[2L]]))@\\ \mbox{}\verb@ ### col -> row order@\\ \mbox{}\verb@ return(ltMatrices(x[t(rL)[upper.tri(rL, diag = diag)], , drop = FALSE], @\\ \mbox{}\verb@ diag = diag, byrow = TRUE, names = dn[[2L]]))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can check if this works by switching back and forth between column-major and row-major order <>= ## constructor + .reorder + as.array a <- as.array(ltMatrices(xn, byrow = TRUE)) b <- as.array(ltMatrices(ltMatrices(xn, byrow = TRUE), byrow = FALSE)) chk(a, b) a <- as.array(ltMatrices(xn, byrow = FALSE)) b <- as.array(ltMatrices(ltMatrices(xn, byrow = FALSE), byrow = TRUE)) chk(a, b) a <- as.array(ltMatrices(xd, byrow = TRUE, diag = TRUE)) b <- as.array(ltMatrices(ltMatrices(xd, byrow = TRUE, diag = TRUE), byrow = FALSE)) chk(a, b) a <- as.array(ltMatrices(xd, byrow = FALSE, diag = TRUE)) b <- as.array(ltMatrices(ltMatrices(xd, byrow = FALSE, diag = TRUE), byrow = TRUE)) chk(a, b) @ \section{Subsetting} We might want to select subsets of observations $i \in \{1, \dots, N\}$ or rows/columns $j \in \{1, \dots, \J\}$ of the corresponding matrices $\mC_i$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap15}\raggedright\small \NWtarget{nuweb13}{} $\langle\,${\itshape .subset ltMatrices}\nobreak\ {\footnotesize {13}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@.subset_ltMatrices <- function(x, i, j, ..., drop = FALSE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (drop) warning("argument drop is ignored")@\\ \mbox{}\verb@ if (missing(i) && missing(j)) return(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x) @\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(j)) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.character(j)) {@\\ \mbox{}\verb@ stopifnot(all(j %in% dn[[2L]]))@\\ \mbox{}\verb@ j <- match(j, dn[[2L]])@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ j <- (1:J)[j] ### get rid of negative indices@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (length(j) == 1L && !diag) {@\\ \mbox{}\verb@ return(ltMatrices(matrix(1, ncol = ncol(x), nrow = 1), diag = TRUE, @\\ \mbox{}\verb@ byrow = byrow, names = dn[[2L]][j]))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ L <- diag(0L, nrow = J)@\\ \mbox{}\verb@ Jp <- sum(upper.tri(L, diag = diag))@\\ \mbox{}\verb@ if (byrow) {@\\ \mbox{}\verb@ L[upper.tri(L, diag = diag)] <- 1:Jp@\\ \mbox{}\verb@ L <- L + t(L)@\\ \mbox{}\verb@ diag(L) <- diag(L) / 2@\\ \mbox{}\verb@ L <- L[j, j, drop = FALSE]@\\ \mbox{}\verb@ L <- L[upper.tri(L, diag = diag)]@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ L[lower.tri(L, diag = diag)] <- 1:Jp@\\ \mbox{}\verb@ L <- L + t(L)@\\ \mbox{}\verb@ diag(L) <- diag(L) / 2@\\ \mbox{}\verb@ L <- L[j, j, drop = FALSE]@\\ \mbox{}\verb@ L <- L[lower.tri(L, diag = diag)]@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (missing(i)) {@\\ \mbox{}\verb@ return(ltMatrices(x[c(L), , drop = FALSE], diag = diag, @\\ \mbox{}\verb@ byrow = byrow, names = dn[[2L]][j]))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ return(ltMatrices(x[c(L), i, drop = FALSE], diag = diag, @\\ \mbox{}\verb@ byrow = byrow, names = dn[[2L]][j]))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ return(ltMatrices(x[, i, drop = FALSE], diag = diag, @\\ \mbox{}\verb@ byrow = byrow, names = dn[[2L]]))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb14}{14}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap16}\raggedright\small \NWtarget{nuweb14}{} $\langle\,${\itshape subset ltMatrices}\nobreak\ {\footnotesize {14}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape .subset ltMatrices}\nobreak\ {\footnotesize \NWlink{nuweb13}{13}}$\,\rangle$}\verb@@\\ \mbox{}\verb@### if j is not ordered, result is not a lower triangular matrix@\\ \mbox{}\verb@"[.ltMatrices" <- function(x, i, j, ..., drop = FALSE) {@\\ \mbox{}\verb@ if (!missing(j)) {@\\ \mbox{}\verb@ if (is.character(j)) {@\\ \mbox{}\verb@ stopifnot(all(j %in% dimnames(x)[[2L]]))@\\ \mbox{}\verb@ j <- match(j, dimnames(x)[[2L]])@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (all(j > 0)) {@\\ \mbox{}\verb@ if (any(diff(j) < 0)) stop("invalid subset argument j")@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(.subset_ltMatrices(x = x, i = i, j = j, ..., drop = drop))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@"[.syMatrices" <- function(x, i, j, ..., drop = FALSE) {@\\ \mbox{}\verb@ x <- as.syMatrices(x)@\\ \mbox{}\verb@ ret <- .subset_ltMatrices(x = x, i = i, j = j, ..., drop = drop)@\\ \mbox{}\verb@ class(ret)[1L] <- "syMatrices"@\\ \mbox{}\verb@ ret@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We check if this works by first subsetting the \code{ltMatrices} object. Second, we coerse the object to an array and do the subset for the latter object. Both results must agree. <>= ## subset a <- as.array(ltMatrices(xn, byrow = FALSE, names = nm)[i, j]) b <- as.array(ltMatrices(xn, byrow = FALSE, names = nm))[j, j, i] chk(a, b) a <- as.array(ltMatrices(xn, byrow = TRUE, names = nm)[i, j]) b <- as.array(ltMatrices(xn, byrow = TRUE, names = nm))[j, j, i] chk(a, b) a <- as.array(ltMatrices(xd, byrow = FALSE, diag = TRUE, names = nm)[i, j]) b <- as.array(ltMatrices(xd, byrow = FALSE, diag = TRUE, names = nm))[j, j, i] chk(a, b) a <- as.array(ltMatrices(xd, byrow = TRUE, diag = TRUE, names = nm)[i, j]) b <- as.array(ltMatrices(xd, byrow = TRUE, diag = TRUE, names = nm))[j, j, i] chk(a, b) @ We start with both indices being positive integers <>= i <- colnames(xn)[1:2] j <- 2:4 <> @ proceed with characters <>= i <- 1:2 j <- nm[2:4] <> @ a different subset <>= j <- c(1, 3, 5) <> @ and characters again <>= j <- nm[c(1, 3, 5)] <> @ and finally with with negative subsets <>= j <- -c(1, 3, 5) <> @ and with non-increasing argument \code{j} (this won't work for lower triangular matrices, only for symmetric matrices) <>= ## subset j <- nm[sample(1:J)] ltM <- ltMatrices(xn, byrow = FALSE, names = nm) try(ltM[i, j]) ltM <- as.syMatrices(ltM) a <- as.array(ltM[i, j]) b <- as.array(ltM)[j, j, i] chk(a, b) @ Extracting the lower triangular elements from an \code{ltMatrices} object (or from an object of class \code{syMatrices}) returns a matrix with $N$ columns, undoing the effect of \code{ltMatrices}. Note that ordering of the rows of this matrix depend on the \code{byrow} attribute of \code{x}, unless the \code{byrow} to this function is used to overwrite it explicitly \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap17}\raggedright\small \NWtarget{nuweb17}{} $\langle\,${\itshape lower triangular elements}\nobreak\ {\footnotesize {17}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Lower_tri <- function(x, diag = FALSE, byrow = attr(x, "byrow")) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.syMatrices(x))@\\ \mbox{}\verb@ x <- as.ltMatrices(x)@\\ \mbox{}\verb@ adiag <- diag@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = byrow)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (diag == adiag)@\\ \mbox{}\verb@ return(unclass(x)[,,drop = FALSE]) ### remove attributes@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!diag && adiag) {@\\ \mbox{}\verb@ diagonals(x) <- 1@\\ \mbox{}\verb@ return(unclass(x)[,,drop = FALSE]) ### remove attributes@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x)@\\ \mbox{}\verb@ if (J == 1) {@\\ \mbox{}\verb@ idx <- 1L@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ if (byrow)@\\ \mbox{}\verb@ idx <- cumsum(c(1, 2:J))@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ idx <- cumsum(c(1, J:2))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ return(x[-idx,,drop = FALSE])@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= ## J <- 4 M <- ltMatrices(matrix(1:10, nrow = 10, ncol = 2), diag = TRUE) Lower_tri(M, diag = FALSE) Lower_tri(M, diag = TRUE) M <- ltMatrices(matrix(1:6, nrow = 6, ncol = 2), diag = FALSE) Lower_tri(M, diag = FALSE) Lower_tri(M, diag = TRUE) ## multiple symmetric matrices Lower_tri(invchol2cor(M)) @ \section{Diagonal Elements} The diagonal elements of each matrix $\mC_i$ can be extracted and are always returned as an $\J \times N$ matrix. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap18}\raggedright\small \NWtarget{nuweb19}{} $\langle\,${\itshape diagonals ltMatrices}\nobreak\ {\footnotesize {19}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@diagonals <- function(x, ...)@\\ \mbox{}\verb@ UseMethod("diagonals")@\\ \mbox{}\verb@@\\ \mbox{}\verb@diagonals.ltMatrices <- function(x, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!diag) {@\\ \mbox{}\verb@ ret <- matrix(1, nrow = J, ncol = ncol(x))@\\ \mbox{}\verb@ colnames(ret) <- dn[[1L]]@\\ \mbox{}\verb@ rownames(ret) <- dn[[2L]]@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ if (J == 1L) return(x)@\\ \mbox{}\verb@ if (byrow)@\\ \mbox{}\verb@ idx <- cumsum(c(1, 2:J))@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ idx <- cumsum(c(1, J:2))@\\ \mbox{}\verb@ ret <- x[idx, , drop = FALSE]@\\ \mbox{}\verb@ rownames(ret) <- dn[[2L]]@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@diagonals.syMatrices <- diagonals.ltMatrices@\\ \mbox{}\verb@@\\ \mbox{}\verb@diagonals.matrix <- function(x, ...) diag(x)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= all(diagonals(ltMatrices(xn, byrow = TRUE)) == 1L) @ Sometimes we need to add diagonal elements to an \code{ltMatrices} object which was set-up with constant $c_{jj} = 1$ diagonal elements. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap19}\raggedright\small \NWtarget{nuweb20}{} $\langle\,${\itshape add diagonal elements}\nobreak\ {\footnotesize {20}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@.adddiag <- function(x) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(is.ltMatrices(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (attr(x, "diag")) return(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow_orig <- attr(x, "byrow")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = FALSE)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ N <- dim(x)[1L]@\\ \mbox{}\verb@ J <- dim(x)[2L]@\\ \mbox{}\verb@ nm <- dimnames(x)[[2L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ L <- diag(J)@\\ \mbox{}\verb@ L[lower.tri(L, diag = TRUE)] <- 1:(J * (J + 1) / 2)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ D <- diag(J)@\\ \mbox{}\verb@ ret <- matrix(D[lower.tri(D, diag = TRUE)], @\\ \mbox{}\verb@ nrow = J * (J + 1) / 2, ncol = N)@\\ \mbox{}\verb@ colnames(ret) <- dimnames(x)[[1L]]@\\ \mbox{}\verb@ ret[L[lower.tri(L, diag = FALSE)],] <- unclass(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ltMatrices(ret, diag = TRUE, byrow = FALSE, names = nm)@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = byrow_orig)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap20}\raggedright\small \NWtarget{nuweb21}{} $\langle\,${\itshape assign diagonal elements}\nobreak\ {\footnotesize {21}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@"diagonals<-" <- function(x, value)@\\ \mbox{}\verb@ UseMethod("diagonals<-")@\\ \mbox{}\verb@@\\ \mbox{}\verb@"diagonals<-.ltMatrices" <- function(x, value) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (byrow)@\\ \mbox{}\verb@ idx <- cumsum(c(1, 2:J))@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ idx <- cumsum(c(1, J:2))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ### diagonals(x) <- NULL returns ltMatrices(..., diag = FALSE)@\\ \mbox{}\verb@ if (is.null(value)) {@\\ \mbox{}\verb@ if (!attr(x, "diag")) return(x)@\\ \mbox{}\verb@ if (J == 1L) {@\\ \mbox{}\verb@ x[] <- 1@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ return(ltMatrices(unclass(x)[-idx,,drop = FALSE], diag = FALSE, @\\ \mbox{}\verb@ byrow = byrow, names = dn[[2L]]))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- .adddiag(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!is.matrix(value))@\\ \mbox{}\verb@ value <- matrix(value, nrow = J, ncol = d[1L])@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(is.matrix(value) && nrow(value) == J @\\ \mbox{}\verb@ && ncol(value) == d[1L])@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (J == 1L) {@\\ \mbox{}\verb@ x[] <- value@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x[idx, ] <- value@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@"diagonals<-.syMatrices" <- function(x, value) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- as.ltMatrices(x)@\\ \mbox{}\verb@ diagonals(x) <- value@\\ \mbox{}\verb@ class(x)[1L] <- "syMatrices"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= lxd2 <- lxn diagonals(lxd2) <- 1 chk(as.array(lxd2), as.array(lxn)) @ A unit diagonal matrix is not treated as a special case but as an \code{ltMatrices} object with all lower triangular elements being zero \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap21}\raggedright\small \NWtarget{nuweb22}{} $\langle\,${\itshape diagonal matrix}\nobreak\ {\footnotesize {22}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@diagonals.integer <- function(x, ...)@\\ \mbox{}\verb@ ltMatrices(rep(0, x * (x - 1) / 2), diag = FALSE, ...)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= (I5 <- diagonals(5L)) diagonals(I5) <- 1:5 I5 @ \section{Multiplication} \label{sec:multiplication} Products $\mC_i \yvec_i$ or $\mC^\top_i \yvec_i$ with $\yvec_i \in \R^\J$ for $i = 1, \dots, N$ can be computed with $\code{y}$ being an $J \times N$ matrix of columns-wise stacked vectors $(\yvec_1 \mid \yvec_2 \mid \dots \mid \yvec_N)$. If \code{y} is a single vector, it is recycled $N$ times. If the number of columns of a matrix \code{y} is neither one nor $N$, we compute $\mC_i \yvec_j$ for all $i = 1, \dots, N$ and $j$. This is dangerous but needed in Section~\ref{sec:margcond} for defining \code{cond\_mvnorm} later on. For $\mC_i \yvec_i$, we call \proglang{C} code computing the product efficiently without copying data by leveraging the lower triangular structure of \code{x}$=\mC_i$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap22}\raggedright\small \NWtarget{nuweb23a}{} $\langle\,${\itshape mult ltMatrices}\nobreak\ {\footnotesize {23a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### C %*% y@\\ \mbox{}\verb@Mult <- function(x, y, ...)@\\ \mbox{}\verb@ UseMethod("Mult")@\\ \mbox{}\verb@Mult.default <- function(x, y, transpose = FALSE, ...) {@\\ \mbox{}\verb@ if (!transpose) return(x %*% y)@\\ \mbox{}\verb@ return(crossprod(x, y))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@Mult.ltMatrices <- function(x, y, transpose = FALSE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(is.numeric(y))@\\ \mbox{}\verb@ if (!is.matrix(y)) y <- matrix(y, nrow = d[2L], ncol = d[1L])@\\ \mbox{}\verb@ N <- ifelse(d[1L] == 1, ncol(y), d[1L])@\\ \mbox{}\verb@ stopifnot(nrow(y) == d[2L])@\\ \mbox{}\verb@ if (ncol(y) != N)@\\ \mbox{}\verb@ return(sapply(1:ncol(y), function(i) Mult(x, y[,i], transpose = transpose)))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape mult ltMatrices transpose}\nobreak\ {\footnotesize \NWlink{nuweb25}{25}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = TRUE)@\\ \mbox{}\verb@ if (!is.double(x)) storage.mode(x) <- "double"@\\ \mbox{}\verb@ if (!is.double(y)) storage.mode(y) <- "double"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_Mult, x, y, as.integer(N), @\\ \mbox{}\verb@ as.integer(d[2L]), as.logical(diag))@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ rownames(ret) <- dn[[2L]]@\\ \mbox{}\verb@ if (length(dn[[1L]]) == N)@\\ \mbox{}\verb@ colnames(ret) <- dn[[1L]]@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The underlying \proglang{C} code assumes $\mC_i$ (here called \code{C}) to be in row-major order. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap23}\raggedright\small \NWtarget{nuweb23b}{} $\langle\,${\itshape RC input}\nobreak\ {\footnotesize {23b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@/* pointer to C matrices */@\\ \mbox{}\verb@double *dC = REAL(C);@\\ \mbox{}\verb@/* number of matrices */@\\ \mbox{}\verb@int iN = INTEGER(N)[0];@\\ \mbox{}\verb@/* dimension of matrices */@\\ \mbox{}\verb@int iJ = INTEGER(J)[0];@\\ \mbox{}\verb@/* C contains diagonal elements */@\\ \mbox{}\verb@Rboolean Rdiag = asLogical(diag);@\\ \mbox{}\verb@/* p = J * (J - 1) / 2 + diag * J */@\\ \mbox{}\verb@int len = iJ * (iJ - 1) / 2 + Rdiag * iJ;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb24b}{24b}\NWlink{nuweb26}{, 26}\NWlink{nuweb29}{, 29}\NWlink{nuweb30}{, 30}\NWlink{nuweb33a}{, 33a}\NWlink{nuweb36}{, 36}\NWlink{nuweb42a}{, 42a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We also allow $\mC_i$ to be constant ($N$ is then determined from \code{ncol(y)}). The following fragment ensures that we only loop over $\mC_i$ if \code{dim(x)[1L] > 1} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap24}\raggedright\small \NWtarget{nuweb24a}{} $\langle\,${\itshape C length}\nobreak\ {\footnotesize {24a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@int p;@\\ \mbox{}\verb@if (LENGTH(C) == len)@\\ \mbox{}\verb@ /* C is constant for i = 1, ..., N */@\\ \mbox{}\verb@ p = 0;@\\ \mbox{}\verb@else @\\ \mbox{}\verb@ /* C contains C_1, ...., C_N */@\\ \mbox{}\verb@ p = len;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb24b}{24b}\NWlink{nuweb26}{, 26}\NWlink{nuweb29}{, 29}\NWlink{nuweb33a}{, 33a}\NWlink{nuweb42a}{, 42a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The \proglang{C} workhorse is now \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap25}\raggedright\small \NWtarget{nuweb24b}{} $\langle\,${\itshape mult}\nobreak\ {\footnotesize {24b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_Mult (SEXP C, SEXP y, SEXP N, SEXP J, SEXP diag) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans, *dy = REAL(y);@\\ \mbox{}\verb@ int i, j, k, start;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape C length}\nobreak\ {\footnotesize \NWlink{nuweb24a}{24a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ PROTECT(ans = allocMatrix(REALSXP, iJ, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@ start = 0;@\\ \mbox{}\verb@ for (j = 0; j < iJ; j++) {@\\ \mbox{}\verb@ dans[j] = 0.0;@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ dans[j] += dC[start + k] * dy[k];@\\ \mbox{}\verb@ if (Rdiag) {@\\ \mbox{}\verb@ dans[j] += dC[start + j] * dy[j];@\\ \mbox{}\verb@ start += j + 1;@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ dans[j] += dy[j]; @\\ \mbox{}\verb@ start += j;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ dC += p;@\\ \mbox{}\verb@ dy += iJ;@\\ \mbox{}\verb@ dans += iJ;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Some checks for $\mC_i \yvec_i$ <>= lxn <- ltMatrices(xn, byrow = TRUE) lxd <- ltMatrices(xd, byrow = TRUE, diag = TRUE) y <- matrix(runif(N * J), nrow = J) a <- Mult(lxn, y) A <- as.array(lxn) b <- do.call("rbind", lapply(1:ncol(y), function(i) t(A[,,i] %*% y[,i,drop = FALSE]))) chk(a, t(b), check.attributes = FALSE) a <- Mult(lxd, y) A <- as.array(lxd) b <- do.call("rbind", lapply(1:ncol(y), function(i) t(A[,,i] %*% y[,i,drop = FALSE]))) chk(a, t(b), check.attributes = FALSE) ### recycle C chk(Mult(lxn[rep(1, N),], y), Mult(lxn[1,], y), check.attributes = FALSE) ### recycle y chk(Mult(lxn, y[,1]), Mult(lxn, y[,rep(1, N)])) ### tcrossprod as multiplication i <- sample(1:N)[1] M <- t(as.array(lxn)[,,i]) a <- sapply(1:J, function(j) Mult(lxn[i,], M[,j,drop = FALSE])) rownames(a) <- colnames(a) <- dimnames(lxn)[[2L]] b <- as.array(Tcrossprod(lxn[i,]))[,,1] chk(a, b, check.attributes = FALSE) @ For $\mC^\top_i \yvec_i$ (\code{transpose = TRUE}), we add a dedicated \proglang{C} function paying attention to the lower triangular structure of \code{x}$= \mC_i$. This function assumes \code{x} in column-major order, so we coerce this object when necessary: \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap26}\raggedright\small \NWtarget{nuweb25}{} $\langle\,${\itshape mult ltMatrices transpose}\nobreak\ {\footnotesize {25}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (transpose) {@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = FALSE)@\\ \mbox{}\verb@ if (!is.double(x)) storage.mode(x) <- "double"@\\ \mbox{}\verb@ if (!is.double(y)) storage.mode(y) <- "double"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_Mult_transpose, x, y, as.integer(N), @\\ \mbox{}\verb@ as.integer(d[2L]), as.logical(diag))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ rownames(ret) <- dn[[2L]]@\\ \mbox{}\verb@ if (length(dn[[1L]]) == N)@\\ \mbox{}\verb@ colnames(ret) <- dn[[1L]]@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb23a}{23a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} before moving to \proglang{C} for the low-level computations: \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap27}\raggedright\small \NWtarget{nuweb26}{} $\langle\,${\itshape mult transpose}\nobreak\ {\footnotesize {26}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_Mult_transpose (SEXP C, SEXP y, SEXP N, SEXP J, SEXP diag) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans, *dy = REAL(y);@\\ \mbox{}\verb@ int i, j, k, start;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape C length}\nobreak\ {\footnotesize \NWlink{nuweb24a}{24a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ PROTECT(ans = allocMatrix(REALSXP, iJ, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@ start = 0;@\\ \mbox{}\verb@ for (j = 0; j < iJ; j++) {@\\ \mbox{}\verb@ dans[j] = 0.0;@\\ \mbox{}\verb@ if (Rdiag) {@\\ \mbox{}\verb@ dans[j] += dC[start] * dy[j];@\\ \mbox{}\verb@ start++;@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ dans[j] += dy[j]; @\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ for (k = 0; k < (iJ - j - 1); k++)@\\ \mbox{}\verb@ dans[j] += dC[start + k] * dy[j + k + 1];@\\ \mbox{}\verb@ start += iJ - j - 1;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ dC += p;@\\ \mbox{}\verb@ dy += iJ;@\\ \mbox{}\verb@ dans += iJ;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and wrap-up with some tests for computing $\mC^\top_i \yvec_i$ <>= a <- Mult(lxn, y, transpose = TRUE) A <- as.array(lxn) b <- do.call("rbind", lapply(1:ncol(y), function(i) t(t(A[,,i]) %*% y[,i,drop = FALSE]))) chk(a, t(b), check.attributes = FALSE) a <- Mult(lxd, y, transpose = TRUE) A <- as.array(lxd) b <- do.call("rbind", lapply(1:ncol(y), function(i) t(t(A[,,i]) %*% y[,i,drop = FALSE]))) chk(a, t(b), check.attributes = FALSE) ### recycle C chk(Mult(lxn[rep(1, N),], y, transpose = TRUE), Mult(lxn[1,], y, transpose = TRUE), check.attributes = FALSE) ### recycle y chk(Mult(lxn, y[,1], transpose = TRUE), Mult(lxn, y[,rep(1, N)], transpose = TRUE)) @ Now we can add a \code{Mult} method for multiple symmetric matrices, noting that for a symmetric matrix $\mA = \mC + \mC^\top - \text{diag}(\mC)$ with lower triangular part $\mC$ (including the diagonal) we can compute $\mA \yvec = \mC \yvec + \mC^\top \yvec - \text{diag}(\mC) \yvec$ using \code{Mult} applied to the lower trianular part: \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap28}\raggedright\small \NWtarget{nuweb27}{} $\langle\,${\itshape mult syMatrices}\nobreak\ {\footnotesize {27}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Mult.syMatrices <- function(x, y, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape extract slots}\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- as.ltMatrices(x)@\\ \mbox{}\verb@ stopifnot(is.numeric(y))@\\ \mbox{}\verb@ if (!is.matrix(y)) y <- matrix(y, nrow = d[2L], ncol = d[1L])@\\ \mbox{}\verb@ N <- ifelse(d[1L] == 1, ncol(y), d[1L])@\\ \mbox{}\verb@ stopifnot(nrow(y) == d[2L])@\\ \mbox{}\verb@ stopifnot(ncol(y) == N)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- Mult(x, y) + Mult(x, y, transpose = TRUE) - y * c(diagonals(x))@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= J <- 5 N1 <- 10 ex <- expression({ C <- syMatrices(matrix(runif(N2 * J * (J + c(-1, 1)[DIAG + 1L] ) / 2), ncol = N2), diag = DIAG) x <- matrix(runif(N1 * J), nrow = J) Ca <- as.array(C) p1 <- do.call("cbind", lapply(1:N1, function(i) Ca[,,c(1,i)[(N2 > 1) + 1]] %*% x[,i])) p2 <- Mult(C, x) chk(p1, p2) }) N2 <- N1 DIAG <- TRUE eval(ex) N2 <- 1 DIAG <- TRUE eval(ex) N2 <- 1 DIAG <- FALSE eval(ex) N2 <- N1 DIAG <- FALSE eval(ex) @ \section{Solving Linear Systems} Computing $\mC_i^{-1}$ or solving $\mC_i \xvec_i = \yvec_i$ for $\xvec_i$ for all $i = 1, \dots, N$ is another important task. We sometimes also need $\mC^\top_i \xvec_i = \yvec_i$ triggered by \code{transpose = TRUE}. \code{C} is $\mC_i, i = 1, \dots, N$ in column-major order (matrix of dimension $\J (\J - 1) / 2 + \J \text{diag} \times N$), and \code{y} is the $\J \times N$ matrix $(\yvec_1 \mid \yvec_2 \mid \dots \mid \yvec_N)$. This function returns the $\J \times N$ matrix $(\xvec_1 \mid \xvec_2 \mid \dots \mid \xvec_N)$ of solutions. If \code{y} is not given, $\mC_i^{-1}$ is returned in the same order as the orginal matrix $\mC_i$. If all $\mC_i$ have unit diagonals, so will $\mC_i^{-1}$. We start with some options for the \proglang{LAPACK} workhorses \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap29}\raggedright\small \NWtarget{nuweb28}{} $\langle\,${\itshape lapack options}\nobreak\ {\footnotesize {28}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@char di, lo = 'L';@\\ \mbox{}\verb@if (Rdiag) {@\\ \mbox{}\verb@ /* non-unit diagonal elements */@\\ \mbox{}\verb@ di = 'N';@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ /* unit diagonal elements; NOTE: these diagonals 1s ARE always present but@\\ \mbox{}\verb@ ignored in the computations */@\\ \mbox{}\verb@ di = 'U';@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb29}{29}\NWlink{nuweb30}{, 30}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and set-up a dedicated \proglang{C} function for computing $\mC_i \xvec_i = \yvec_i$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap30}\raggedright\small \NWtarget{nuweb29}{} $\langle\,${\itshape solve}\nobreak\ {\footnotesize {29}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_solve (SEXP C, SEXP y, SEXP N, SEXP J, SEXP diag, SEXP transpose)@\\ \mbox{}\verb@{@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans, *dy;@\\ \mbox{}\verb@ int i, ONE = 1;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ /* diagonal elements are always present */@\\ \mbox{}\verb@ if (!Rdiag) len += iJ;@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape C length}\nobreak\ {\footnotesize \NWlink{nuweb24a}{24a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape lapack options}\nobreak\ {\footnotesize \NWlink{nuweb28}{28}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ char tr = 'N';@\\ \mbox{}\verb@ /* t(C) instead of C */@\\ \mbox{}\verb@ Rboolean Rtranspose = asLogical(transpose);@\\ \mbox{}\verb@ if (Rtranspose) {@\\ \mbox{}\verb@ /* t(C) */@\\ \mbox{}\verb@ tr = 'T';@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ /* C */@\\ \mbox{}\verb@ tr = 'N';@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dy = REAL(y);@\\ \mbox{}\verb@ PROTECT(ans = allocMatrix(REALSXP, iJ, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@ memcpy(dans, dy, iJ * iN * sizeof(double));@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ /* loop over matrices, ie columns of C / y */ @\\ \mbox{}\verb@ for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* solve linear system */@\\ \mbox{}\verb@ F77_CALL(dtpsv)(&lo, &tr, &di, &iJ, dC, dans, &ONE FCONE FCONE FCONE);@\\ \mbox{}\verb@ dans += iJ;@\\ \mbox{}\verb@ dC += p;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and then for computing $\mC_i^{-1}$ explicitly \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap31}\raggedright\small \NWtarget{nuweb30}{} $\langle\,${\itshape solve C}\nobreak\ {\footnotesize {30}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_solve_C (SEXP C, SEXP N, SEXP J, SEXP diag, SEXP transpose)@\\ \mbox{}\verb@{@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans;@\\ \mbox{}\verb@ int i, info;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ /* diagonal elements are always present */@\\ \mbox{}\verb@ if (!Rdiag) len += iJ;@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape lapack options}\nobreak\ {\footnotesize \NWlink{nuweb28}{28}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ PROTECT(ans = allocMatrix(REALSXP, len, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@ memcpy(dans, dC, iN * len * sizeof(double));@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ /* loop over matrices, ie columns of C / y */ @\\ \mbox{}\verb@ for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* compute inverse */@\\ \mbox{}\verb@ F77_CALL(dtptri)(&lo, &di, &iJ, dans, &info FCONE FCONE);@\\ \mbox{}\verb@ if (info != 0)@\\ \mbox{}\verb@ error("Cannot solve ltmatices");@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dans += len;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ /* note: ans always includes diagonal elements */@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} with \proglang{R} interface \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap32}\raggedright\small \NWtarget{nuweb31}{} $\langle\,${\itshape solve ltMatrices}\nobreak\ {\footnotesize {31}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@solve.ltMatrices <- function(a, b, transpose = FALSE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow_orig <- attr(a, "byrow")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- ltMatrices(a, byrow = FALSE)@\\ \mbox{}\verb@ diag <- attr(x, "diag")@\\ \mbox{}\verb@ ### dtptri and dtpsv require diagonal elements being present@\\ \mbox{}\verb@ if (!diag) diagonals(x) <- diagonals(x)@\\ \mbox{}\verb@ d <- dim(x)@\\ \mbox{}\verb@ J <- d[2L]@\\ \mbox{}\verb@ dn <- dimnames(x)@\\ \mbox{}\verb@ if (!is.double(x)) storage.mode(x) <- "double"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(b)) {@\\ \mbox{}\verb@ if (!is.matrix(b)) b <- matrix(b, nrow = J, ncol = d[1L])@\\ \mbox{}\verb@ stopifnot(nrow(b) == J)@\\ \mbox{}\verb@ N <- ifelse(d[1L] == 1, ncol(b), d[1L])@\\ \mbox{}\verb@ stopifnot(ncol(b) == N)@\\ \mbox{}\verb@ if (!is.double(b)) storage.mode(b) <- "double"@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_solve, x, b, @\\ \mbox{}\verb@ as.integer(N), as.integer(J), as.logical(diag),@\\ \mbox{}\verb@ as.logical(transpose))@\\ \mbox{}\verb@ if (d[1L] == N) {@\\ \mbox{}\verb@ colnames(ret) <- dn[[1L]]@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ colnames(ret) <- colnames(b)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ rownames(ret) <- dn[[2L]]@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (transpose) stop("cannot compute inverse of t(a)")@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_solve_C, x, @\\ \mbox{}\verb@ as.integer(d[1L]), as.integer(J), as.logical(diag),@\\ \mbox{}\verb@ as.logical(FALSE))@\\ \mbox{}\verb@ colnames(ret) <- dn[[1L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!diag)@\\ \mbox{}\verb@ ### ret always includes diagonal elements, remove here@\\ \mbox{}\verb@ ret <- ret[- cumsum(c(1, J:2)), , drop = FALSE]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ltMatrices(ret, diag = diag, byrow = FALSE, names = dn[[2L]])@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = byrow_orig)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and some checks <>= ## solve A <- as.array(lxn) a <- solve(lxn) a <- as.array(a) b <- array(apply(A, 3L, function(x) solve(x), simplify = TRUE), dim = rev(dim(lxn))) chk(a, b, check.attributes = FALSE) A <- as.array(lxd) a <- as.array(solve(lxd)) b <- array(apply(A, 3L, function(x) solve(x), simplify = TRUE), dim = rev(dim(lxd))) chk(a, b, check.attributes = FALSE) chk(solve(lxn, y), Mult(solve(lxn), y)) chk(solve(lxd, y), Mult(solve(lxd), y)) ### recycle C chk(solve(lxn[1,], y), as.array(solve(lxn[1,]))[,,1] %*% y) chk(solve(lxn[rep(1, N),], y), solve(lxn[1,], y), check.attributes = FALSE) ### recycle y chk(solve(lxn, y[,1]), solve(lxn, y[,rep(1, N)])) @ also for $\mC^\top_i \xvec_i = \yvec_i$ <>= chk(solve(lxn[1,], y, transpose = TRUE), t(as.array(solve(lxn[1,]))[,,1]) %*% y) @ \section{Log-determinants} For computing the log-determinant $\log(\text{det}(\mC_i)) = \sum_{j = 1}^J \log(\diag(\mC_i)_j)$ we sum over the log-diagonal entries of a lower triangular matrix in \proglang{C}, both when the data are stored in row- and column-major order: \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap33}\raggedright\small \NWtarget{nuweb33a}{} $\langle\,${\itshape logdet}\nobreak\ {\footnotesize {33a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_logdet (SEXP C, SEXP N, SEXP J, SEXP diag, SEXP byrow) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans;@\\ \mbox{}\verb@ int i, j, k;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ Rboolean Rbyrow = asLogical(byrow);@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape C length}\nobreak\ {\footnotesize \NWlink{nuweb24a}{24a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ PROTECT(ans = allocVector(REALSXP, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@ dans[i] = 0.0;@\\ \mbox{}\verb@ if (Rdiag) {@\\ \mbox{}\verb@ k = 1;@\\ \mbox{}\verb@ for (j = 0; j < iJ; j++) {@\\ \mbox{}\verb@ dans[i] += log(dC[k - 1]);@\\ \mbox{}\verb@ k += (Rbyrow ? j + 2 : iJ - j);@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ dC += p;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The \proglang{R} interface now simply calls this low-level function \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap34}\raggedright\small \NWtarget{nuweb33b}{} $\langle\,${\itshape logdet ltMatrices}\nobreak\ {\footnotesize {33b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@logdet <- function(x) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!is.ltMatrices(x))@\\ \mbox{}\verb@ stop("x is not an ltMatrices object")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow <- attr(x, "byrow")@\\ \mbox{}\verb@ diag <- attr(x, "diag")@\\ \mbox{}\verb@ d <- dim(x)@\\ \mbox{}\verb@ J <- d[2L]@\\ \mbox{}\verb@ dn <- dimnames(x)@\\ \mbox{}\verb@ if (!is.double(x)) storage.mode(x) <- "double"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_logdet, x, @\\ \mbox{}\verb@ as.integer(d[1L]), as.integer(J), as.logical(diag), @\\ \mbox{}\verb@ as.logical(byrow))@\\ \mbox{}\verb@ names(ret) <- dn[[1L]]@\\ \mbox{}\verb@ return(ret) @\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We test the functionality by extracting the diagonal elements from different matrices and summing over their logarithms <>= chk(logdet(lxn), colSums(log(diagonals(lxn)))) chk(logdet(lxd[1,]), colSums(log(diagonals(lxd[1,])))) chk(logdet(lxd), colSums(log(diagonals(lxd)))) lxd2 <- ltMatrices(lxd, byrow = !attr(lxd, "byrow")) chk(logdet(lxd2), colSums(log(diagonals(lxd2)))) @ \section{Crossproducts} We want to ompute $\mC_i \mC_i^\top$ or $\text{diag}(\mC_i \mC_i^\top)$ (\code{diag\_only = TRUE}) for $i = 1, \dots, N$. These are symmetric matrices, so we store them as a lower triangular matrix using a different class name \code{syMatrices}. We write one \proglang{C} function for computing $\mC_i \mC_i^\top$ or $\mC_i^\top \mC_i$ (\code{Rtranspose} being \code{TRUE}). We differentiate between computation of the diagonal elements of the crossproduct \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap35}\raggedright\small \NWtarget{nuweb34a}{} $\langle\,${\itshape first element}\nobreak\ {\footnotesize {34a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dans[0] = 1.0;@\\ \mbox{}\verb@if (Rdiag)@\\ \mbox{}\verb@ dans[0] = pow(dC[0], 2);@\\ \mbox{}\verb@if (Rtranspose) { // crossprod@\\ \mbox{}\verb@ for (k = 1; k < iJ; k++) @\\ \mbox{}\verb@ dans[0] += pow(dC[IDX(k + 1, 1, iJ, Rdiag)], 2);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb34b}{34b}\NWlink{nuweb35a}{, 35a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap36}\raggedright\small \NWtarget{nuweb34b}{} $\langle\,${\itshape tcrossprod diagonal only}\nobreak\ {\footnotesize {34b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@PROTECT(ans = allocMatrix(REALSXP, iJ, iN));@\\ \mbox{}\verb@dans = REAL(ans);@\\ \mbox{}\verb@for (n = 0; n < iN; n++) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape first element}\nobreak\ {\footnotesize \NWlink{nuweb34a}{34a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ for (i = 1; i < iJ; i++) {@\\ \mbox{}\verb@ dans[i] = 0.0;@\\ \mbox{}\verb@ if (Rtranspose) { // crossprod@\\ \mbox{}\verb@ for (k = i + 1; k < iJ; k++)@\\ \mbox{}\verb@ dans[i] += pow(dC[IDX(k + 1, i + 1, iJ, Rdiag)], 2);@\\ \mbox{}\verb@ } else { // tcrossprod@\\ \mbox{}\verb@ for (k = 0; k < i; k++)@\\ \mbox{}\verb@ dans[i] += pow(dC[IDX(i + 1, k + 1, iJ, Rdiag)], 2);@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (Rdiag) {@\\ \mbox{}\verb@ dans[i] += pow(dC[IDX(i + 1, i + 1, iJ, Rdiag)], 2);@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ dans[i] += 1.0;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ dans += iJ;@\\ \mbox{}\verb@ dC += len;@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb36}{36}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and computation of the full $\J \times \J$ crossproduct matrix \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap37}\raggedright\small \NWtarget{nuweb35a}{} $\langle\,${\itshape tcrossprod full}\nobreak\ {\footnotesize {35a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@nrow = iJ * (iJ + 1) / 2;@\\ \mbox{}\verb@PROTECT(ans = allocMatrix(REALSXP, nrow, iN)); @\\ \mbox{}\verb@dans = REAL(ans);@\\ \mbox{}\verb@for (n = 0; n < INTEGER(N)[0]; n++) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape first element}\nobreak\ {\footnotesize \NWlink{nuweb34a}{34a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ for (i = 1; i < iJ; i++) {@\\ \mbox{}\verb@ for (j = 0; j <= i; j++) {@\\ \mbox{}\verb@ ix = IDX(i + 1, j + 1, iJ, 1);@\\ \mbox{}\verb@ dans[ix] = 0.0;@\\ \mbox{}\verb@ if (Rtranspose) { // crossprod@\\ \mbox{}\verb@ for (k = i + 1; k < iJ; k++)@\\ \mbox{}\verb@ dans[ix] += @\\ \mbox{}\verb@ dC[IDX(k + 1, i + 1, iJ, Rdiag)] *@\\ \mbox{}\verb@ dC[IDX(k + 1, j + 1, iJ, Rdiag)];@\\ \mbox{}\verb@ } else { // tcrossprod@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ dans[ix] += @\\ \mbox{}\verb@ dC[IDX(i + 1, k + 1, iJ, Rdiag)] *@\\ \mbox{}\verb@ dC[IDX(j + 1, k + 1, iJ, Rdiag)];@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (Rdiag) {@\\ \mbox{}\verb@ if (Rtranspose) {@\\ \mbox{}\verb@ dans[ix] += @\\ \mbox{}\verb@ dC[IDX(i + 1, i + 1, iJ, Rdiag)] *@\\ \mbox{}\verb@ dC[IDX(i + 1, j + 1, iJ, Rdiag)];@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ dans[ix] += @\\ \mbox{}\verb@ dC[IDX(i + 1, j + 1, iJ, Rdiag)] *@\\ \mbox{}\verb@ dC[IDX(j + 1, j + 1, iJ, Rdiag)];@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ if (j < i)@\\ \mbox{}\verb@ dans[ix] += dC[IDX(i + 1, j + 1, iJ, Rdiag)];@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ dans[ix] += 1.0;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ dans += nrow;@\\ \mbox{}\verb@ dC += len;@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb36}{36}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and put both cases together \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap38}\raggedright\small \NWtarget{nuweb35b}{} $\langle\,${\itshape IDX}\nobreak\ {\footnotesize {35b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@#define IDX(i, j, n, d) ((i) >= (j) ? (n) * ((j) - 1) - ((j) - 2) * ((j) - 1)/2 + (i) - (j) - (!d) * (j) : 0)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb36}{36}\NWlink{nuweb42a}{, 42a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap39}\raggedright\small \NWtarget{nuweb36}{} $\langle\,${\itshape tcrossprod}\nobreak\ {\footnotesize {36}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape IDX}\nobreak\ {\footnotesize \NWlink{nuweb35b}{35b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_tcrossprod (SEXP C, SEXP N, SEXP J, SEXP diag, @\\ \mbox{}\verb@ SEXP diag_only, SEXP transpose) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans;@\\ \mbox{}\verb@ int i, j, n, k, ix, nrow;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Rboolean Rdiag_only = asLogical(diag_only);@\\ \mbox{}\verb@ Rboolean Rtranspose = asLogical(transpose);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (Rdiag_only) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape tcrossprod diagonal only}\nobreak\ {\footnotesize \NWlink{nuweb34b}{34b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape tcrossprod full}\nobreak\ {\footnotesize \NWlink{nuweb35a}{35a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} with \proglang{R} interface \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap40}\raggedright\small \NWtarget{nuweb37}{} $\langle\,${\itshape tcrossprod ltMatrices}\nobreak\ {\footnotesize {37}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### C %*% t(C) => returns object of class syMatrices@\\ \mbox{}\verb@### diag(C %*% t(C)) => returns matrix of diagonal elements@\\ \mbox{}\verb@.Tcrossprod <- function(x, diag_only = FALSE, transpose = FALSE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!is.ltMatrices(x)) {@\\ \mbox{}\verb@ ret <- tcrossprod(x)@\\ \mbox{}\verb@ if (diag_only) ret <- diag(ret)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow_orig <- attr(x, "byrow")@\\ \mbox{}\verb@ diag <- attr(x, "diag")@\\ \mbox{}\verb@ d <- dim(x)@\\ \mbox{}\verb@ N <- d[1L]@\\ \mbox{}\verb@ J <- d[2L]@\\ \mbox{}\verb@ dn <- dimnames(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = FALSE)@\\ \mbox{}\verb@ if (!is.double(x)) storage.mode(x) <- "double"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_tcrossprod, x, as.integer(N), as.integer(J), @\\ \mbox{}\verb@ as.logical(diag), as.logical(diag_only), as.logical(transpose))@\\ \mbox{}\verb@ colnames(ret) <- dn[[1L]]@\\ \mbox{}\verb@ if (diag_only) {@\\ \mbox{}\verb@ rownames(ret) <- dn[[2L]]@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ ret <- ltMatrices(ret, diag = TRUE, byrow = FALSE, names = dn[[2L]])@\\ \mbox{}\verb@ ret <- as.syMatrices(ltMatrices(ret, byrow = byrow_orig))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@Tcrossprod <- function(x, diag_only = FALSE)@\\ \mbox{}\verb@ .Tcrossprod(x = x, diag_only = diag_only, transpose = FALSE)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We could have created yet another generic \code{tcrossprod}, but \code{base::tcrossprod} is more general and, because speed is an issue, we don't want to waste time on methods dispatch. <>= ## Tcrossprod a <- as.array(Tcrossprod(lxn)) b <- array(apply(as.array(lxn), 3L, function(x) tcrossprod(x), simplify = TRUE), dim = rev(dim(lxn))) chk(a, b, check.attributes = FALSE) # diagonal elements only d <- Tcrossprod(lxn, diag_only = TRUE) chk(d, apply(a, 3, diag)) chk(d, diagonals(Tcrossprod(lxn))) a <- as.array(Tcrossprod(lxd)) b <- array(apply(as.array(lxd), 3L, function(x) tcrossprod(x), simplify = TRUE), dim = rev(dim(lxd))) chk(a, b, check.attributes = FALSE) # diagonal elements only d <- Tcrossprod(lxd, diag_only = TRUE) chk(d, apply(a, 3, diag)) chk(d, diagonals(Tcrossprod(lxd))) @ We also add \code{Crossprod}, which is a call to \code{Tcrossprod} with the \code{transpose} switch turned on \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap41}\raggedright\small \NWtarget{nuweb38}{} $\langle\,${\itshape crossprod ltMatrices}\nobreak\ {\footnotesize {38}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Crossprod <- function(x, diag_only = FALSE)@\\ \mbox{}\verb@ .Tcrossprod(x, diag_only = diag_only, transpose = TRUE)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and run some checks <>= ## Crossprod a <- as.array(Crossprod(lxn)) b <- array(apply(as.array(lxn), 3L, function(x) crossprod(x), simplify = TRUE), dim = rev(dim(lxn))) chk(a, b, check.attributes = FALSE) # diagonal elements only d <- Crossprod(lxn, diag_only = TRUE) chk(d, apply(a, 3, diag)) chk(d, diagonals(Crossprod(lxn))) a <- as.array(Crossprod(lxd)) b <- array(apply(as.array(lxd), 3L, function(x) crossprod(x), simplify = TRUE), dim = rev(dim(lxd))) chk(a, b, check.attributes = FALSE) # diagonal elements only d <- Crossprod(lxd, diag_only = TRUE) chk(d, apply(a, 3, diag)) chk(d, diagonals(Crossprod(lxd))) @ \section{Cholesky Factorisation} One might want to compute the Cholesky factorisations $\mSigma_i = \mC_i \mC_i^\top$ for multiple symmetric matrices $\mSigma_i$, stored as a matrix in class \code{syMatrices}. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap42}\raggedright\small \NWtarget{nuweb39}{} $\langle\,${\itshape chol syMatrices}\nobreak\ {\footnotesize {39}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@chol.syMatrices <- function(x, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow_orig <- attr(x, "byrow")@\\ \mbox{}\verb@ dnm <- dimnames(x)@\\ \mbox{}\verb@ stopifnot(attr(x, "diag"))@\\ \mbox{}\verb@ d <- dim(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ### x is of class syMatrices, coerse to ltMatrices first and re-arrange@\\ \mbox{}\verb@ ### second@\\ \mbox{}\verb@ x <- ltMatrices(unclass(x), diag = TRUE, @\\ \mbox{}\verb@ byrow = byrow_orig, names = dnm[[2L]])@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = FALSE)@\\ \mbox{}\verb@ # class(x) <- class(x)[-1]@\\ \mbox{}\verb@ if (!is.double(x)) storage.mode(x) <- "double"@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_syMatrices_chol, x, @\\ \mbox{}\verb@ as.integer(d[1L]), as.integer(d[2L]))@\\ \mbox{}\verb@ colnames(ret) <- dnm[[1L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ltMatrices(ret, diag = TRUE,@\\ \mbox{}\verb@ byrow = FALSE, names = dnm[[2L]])@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = byrow_orig)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Luckily, we already have the data in the correct packed colum-major storage, so we swiftly loop over $i = 1, \dots, N$ in \proglang{C} and hand over to \code{LAPACK} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap43}\raggedright\small \NWtarget{nuweb40}{} $\langle\,${\itshape chol}\nobreak\ {\footnotesize {40}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_syMatrices_chol (SEXP Sigma, SEXP N, SEXP J) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans, *dSigma;@\\ \mbox{}\verb@ int iJ = INTEGER(J)[0];@\\ \mbox{}\verb@ int pJ = iJ * (iJ + 1) / 2;@\\ \mbox{}\verb@ int iN = INTEGER(N)[0];@\\ \mbox{}\verb@ int i, j, info = 0;@\\ \mbox{}\verb@ char lo = 'L';@\\ \mbox{}\verb@@\\ \mbox{}\verb@ PROTECT(ans = allocMatrix(REALSXP, pJ, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@ dSigma = REAL(Sigma);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* copy data */@\\ \mbox{}\verb@ for (j = 0; j < pJ; j++)@\\ \mbox{}\verb@ dans[j] = dSigma[j];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ F77_CALL(dpptrf)(&lo, &iJ, dans, &info FCONE);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (info != 0) {@\\ \mbox{}\verb@ if (info > 0)@\\ \mbox{}\verb@ error("the leading minor of order %d is not positive definite",@\\ \mbox{}\verb@ info);@\\ \mbox{}\verb@ error("argument %d of Lapack routine %s had invalid value",@\\ \mbox{}\verb@ -info, "dpptrf");@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dSigma += pJ;@\\ \mbox{}\verb@ dans += pJ;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} This new \code{chol} method can be used to revert \code{Tcrossprod} for \code{ltMatrices} with and without unit diagonals: <>= Sigma <- Tcrossprod(lxd) chk(chol(Sigma), lxd) Sigma <- Tcrossprod(lxn) ## Sigma and chol(Sigma) always have diagonal, lxn doesn't chk(as.array(chol(Sigma)), as.array(lxn)) @ \section{Kronecker Products} \label{sec:vectrick} We sometimes need to compute $\text{vec}(\mS)^\top (\mA^\top \otimes \mC)$, where $\mS$ is a lower triangular or other $\J \times \J$ matrix and $\mA$ and $\mC$ are lower triangular $\J \times \J$ matrices. With the ``vec trick'', we have $\text{vec}(\mS)^\top (\mA^\top \otimes \mC) = \text{vec}(\mC^\top \mS \mA^\top)^\top$. The \proglang{LAPACK} function \code{dtrmm} computes products of lower triangular matrices with other matrices, so we simply call this function looping over $i = 1, \dots, N$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap44}\raggedright\small \NWtarget{nuweb41}{} $\langle\,${\itshape t(C) S t(A)}\nobreak\ {\footnotesize {41}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@char siR = 'R', siL = 'L', lo = 'L', tr = 'N', trT = 'T', di = 'N', trs;@\\ \mbox{}\verb@double ONE = 1.0;@\\ \mbox{}\verb@int iJ2 = iJ * iJ;@\\ \mbox{}\verb@@\\ \mbox{}\verb@double tmp[iJ2];@\\ \mbox{}\verb@for (j = 0; j < iJ2; j++) tmp[j] = 0.0;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ans = PROTECT(allocMatrix(REALSXP, iJ2, iN));@\\ \mbox{}\verb@dans = REAL(ans);@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (i = 0; i < LENGTH(ans); i++) dans[i] = 0.0;@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (i = 0; i < iN; i++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* A := C */@\\ \mbox{}\verb@ for (j = 0; j < iJ; j++) {@\\ \mbox{}\verb@ for (k = 0; k <= j; k++)@\\ \mbox{}\verb@ tmp[k * iJ + j] = dC[IDX(j + 1, k + 1, iJ, 1L)];@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* S was already expanded in R code; B = S */@\\ \mbox{}\verb@ for (j = 0; j < iJ2; j++) dans[j] = dS[j];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* B := t(A) %*% B */@\\ \mbox{}\verb@ trs = (RtC ? trT : tr);@\\ \mbox{}\verb@ F77_CALL(dtrmm)(&siL, &lo, &trs, &di, &iJ, &iJ, &ONE, tmp, &iJ, @\\ \mbox{}\verb@ dans, &iJ FCONE FCONE FCONE FCONE);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* A */@\\ \mbox{}\verb@ for (j = 0; j < iJ; j++) {@\\ \mbox{}\verb@ for (k = 0; k <= j; k++)@\\ \mbox{}\verb@ tmp[k * iJ + j] = dA[IDX(j + 1, k + 1, iJ, 1L)];@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* B := B %*% t(A) */@\\ \mbox{}\verb@ trs = (RtA ? trT : tr);@\\ \mbox{}\verb@ F77_CALL(dtrmm)(&siR, &lo, &trs, &di, &iJ, &iJ, &ONE, tmp, &iJ, @\\ \mbox{}\verb@ dans, &iJ FCONE FCONE FCONE FCONE);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dans += iJ2;@\\ \mbox{}\verb@ dC += p;@\\ \mbox{}\verb@ dS += iJ2;@\\ \mbox{}\verb@ dA += p;@\\ \mbox{}\verb@} @\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb42a}{42a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap45}\raggedright\small \NWtarget{nuweb42a}{} $\langle\,${\itshape vec trick}\nobreak\ {\footnotesize {42a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape IDX}\nobreak\ {\footnotesize \NWlink{nuweb35b}{35b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_vectrick(SEXP C, SEXP N, SEXP J, SEXP S, SEXP A, SEXP diag, SEXP trans) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ int i, j, k;@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dS, *dans, *dA;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* note: diag is needed by this chunk but has no consequences */@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RC input}\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape C length}\nobreak\ {\footnotesize \NWlink{nuweb24a}{24a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ dS = REAL(S);@\\ \mbox{}\verb@ dA = REAL(A);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Rboolean RtC = LOGICAL(trans)[0];@\\ \mbox{}\verb@ Rboolean RtA = LOGICAL(trans)[1];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape t(C) S t(A)}\nobreak\ {\footnotesize \NWlink{nuweb41}{41}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} In \proglang{R}, we compute $\mC^\top \mS \mA^\top$ by default or $\mC \mS \mA^\top$ or $\mC^\top \mS \mA$ or $\mC^\top \mS \mA^\top$ by using the \code{trans} argument in \code{vectrick}. Argument \code{C} is an \code{ltMatrices} object \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap46}\raggedright\small \NWtarget{nuweb42b}{} $\langle\,${\itshape check C argument}\nobreak\ {\footnotesize {42b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@C <- as.ltMatrices(C)@\\ \mbox{}\verb@if (!attr(C, "diag")) diagonals(C) <- 1@\\ \mbox{}\verb@C_byrow_orig <- attr(C, "byrow")@\\ \mbox{}\verb@C <- ltMatrices(C, byrow = FALSE)@\\ \mbox{}\verb@dC <- dim(C)@\\ \mbox{}\verb@nm <- attr(C, "rcnames")@\\ \mbox{}\verb@N <- dC[1L]@\\ \mbox{}\verb@J <- dC[2L]@\\ \mbox{}\verb@class(C) <- class(C)[-1L] ### works because of as.ltMatrices(c)@\\ \mbox{}\verb@if (!is.double(C)) storage.mode(C) <- "double"@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb44}{44}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \code{S} can be an \code{ltMatrices} object or a $\J^2 \times N$ matrix featuring columns of vectorised $\J \times \J$ matrices \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap47}\raggedright\small \NWtarget{nuweb43a}{} $\langle\,${\itshape check S argument}\nobreak\ {\footnotesize {43a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SltM <- is.ltMatrices(S)@\\ \mbox{}\verb@if (SltM) {@\\ \mbox{}\verb@ if (!attr(S, "diag")) diagonals(S) <- 1@\\ \mbox{}\verb@ S_byrow_orig <- attr(S, "byrow")@\\ \mbox{}\verb@ stopifnot(S_byrow_orig == C_byrow_orig)@\\ \mbox{}\verb@ S <- ltMatrices(S, byrow = FALSE)@\\ \mbox{}\verb@ dS <- dim(S)@\\ \mbox{}\verb@ stopifnot(dC[2L] == dS[2L])@\\ \mbox{}\verb@ if (dC[1] != 1L) {@\\ \mbox{}\verb@ stopifnot(dC[1L] == dS[1L])@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ N <- dS[1L]@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ ## argument A in dtrmm is not in packed form, so expand in J x J@\\ \mbox{}\verb@ ## matrix@\\ \mbox{}\verb@ S <- matrix(as.array(S), ncol = dS[1L])@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ stopifnot(is.matrix(S))@\\ \mbox{}\verb@ stopifnot(nrow(S) == J^2)@\\ \mbox{}\verb@ if (dC[1] != 1L) {@\\ \mbox{}\verb@ stopifnot(dC[1L] == ncol(S))@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ N <- ncol(S)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@if (!is.double(S)) storage.mode(S) <- "double"@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb44}{44}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \code{A} is an \code{ltMatrices} object \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap48}\raggedright\small \NWtarget{nuweb43b}{} $\langle\,${\itshape check A argument}\nobreak\ {\footnotesize {43b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (missing(A)) {@\\ \mbox{}\verb@ A <- C@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ A <- as.ltMatrices(A)@\\ \mbox{}\verb@ if (!attr(A, "diag")) diagonals(A) <- 1@\\ \mbox{}\verb@ A_byrow_orig <- attr(A, "byrow")@\\ \mbox{}\verb@ stopifnot(C_byrow_orig == A_byrow_orig)@\\ \mbox{}\verb@ A <- ltMatrices(A, byrow = FALSE)@\\ \mbox{}\verb@ dA <- dim(A)@\\ \mbox{}\verb@ stopifnot(dC[2L] == dA[2L])@\\ \mbox{}\verb@ class(A) <- class(A)[-1L]@\\ \mbox{}\verb@ if (!is.double(A)) storage.mode(A) <- "double"@\\ \mbox{}\verb@ if (dC[1L] != dA[1L]) {@\\ \mbox{}\verb@ if (dC[1L] == 1L)@\\ \mbox{}\verb@ C <- C[, rep(1, N), drop = FALSE]@\\ \mbox{}\verb@ if (dA[1L] == 1L)@\\ \mbox{}\verb@ A <- A[, rep(1, N), drop = FALSE]@\\ \mbox{}\verb@ stopifnot(ncol(A) == ncol(C))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb44}{44}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We put everything together in function \code{vectrick} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap49}\raggedright\small \NWtarget{nuweb44}{} $\langle\,${\itshape kronecker vec trick}\nobreak\ {\footnotesize {44}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@vectrick <- function(C, S, A, transpose = c(TRUE, TRUE)) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(all(is.logical(transpose)))@\\ \mbox{}\verb@ stopifnot(length(transpose) == 2L)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape check C argument}\nobreak\ {\footnotesize \NWlink{nuweb42b}{42b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape check S argument}\nobreak\ {\footnotesize \NWlink{nuweb43a}{43a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape check A argument}\nobreak\ {\footnotesize \NWlink{nuweb43b}{43b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_vectrick, C, as.integer(N), as.integer(J), S, A, @\\ \mbox{}\verb@ as.logical(TRUE), as.logical(transpose))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!SltM) return(matrix(c(ret), ncol = N))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ L <- matrix(1:(J^2), nrow = J)@\\ \mbox{}\verb@ ret <- ltMatrices(ret[L[lower.tri(L, diag = TRUE)],,drop = FALSE], @\\ \mbox{}\verb@ diag = TRUE, byrow = FALSE, names = nm)@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = C_byrow_orig)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Here is a small example <>= J <- 10 d <- TRUE L <- diag(J) L[lower.tri(L, diag = d)] <- prm <- runif(J * (J + c(-1, 1)[d + 1]) / 2) C <- solve(L) D <- -kronecker(t(C), C) S <- diag(J) S[lower.tri(S, diag = TRUE)] <- x <- runif(J * (J + 1) / 2) SD0 <- matrix(c(S) %*% D, ncol = J) SD1 <- -crossprod(C, tcrossprod(S, C)) a <- ltMatrices(C[lower.tri(C, diag = TRUE)], diag = TRUE, byrow = FALSE) b <- ltMatrices(x, diag = TRUE, byrow = FALSE) SD2 <- -vectrick(a, b, a) SD2a <- -vectrick(a, b) chk(SD2, SD2a) chk(SD0[lower.tri(SD0, diag = d)], SD1[lower.tri(SD1, diag = d)]) chk(SD0[lower.tri(SD0, diag = d)], c(unclass(SD2))) ### same; but SD2 is vec(SD0) S <- t(matrix(as.array(b), byrow = FALSE, nrow = 1)) SD2 <- -vectrick(a, S, a) SD2a <- -vectrick(a, S) chk(SD2, SD2a) chk(c(SD0), c(SD2)) ### N > 1 N <- 4L prm <- runif(J * (J - 1) / 2) C <- ltMatrices(prm) S <- matrix(runif(J^2 * N), ncol = N) A <- vectrick(C, S, C) Cx <- as.array(C)[,,1] B <- apply(S, 2, function(x) t(Cx) %*% matrix(x, ncol = J) %*% t(Cx)) chk(A, B) A <- vectrick(C, S, C, transpose = c(FALSE, FALSE)) Cx <- as.array(C)[,,1] B <- apply(S, 2, function(x) Cx %*% matrix(x, ncol = J) %*% Cx) chk(A, B) @ \section{Convenience Functions} \label{sec:conv} We add a few convenience functions for computing covariance matrices $\mSigma_i = \mC_i \mC_i^\top$, precision matrices $\mP_i = \mL_i^\top \mL_i$, correlation matrices $\mR_i = \tilde{\mC}_i \tilde{\mC_i}^\top$ (where $\tilde{\mC}_i = \text{diag}(\mC_i \mC_i^\top)^{-\frac{1}{2}} \mC_i)$, or matrices of partial correlations $\mA_i = -\tilde{\mL}_i^\top \tilde{\mL}_i$ with $\tilde{\mL}_i = \mL_i \text{diag}(\mL_i^\top \mL_i)^{-\frac{1}{2}}$ from $\mL_i$ (\code{invchol}) or $\mC_i = \mL_i^{-1}$ (\code{chol}) for $i = 1, \dots, N$. Before we start, let us put a label on lower triangular matrices, such that we can differentiate between $\mC$ and $\mL$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap50}\raggedright\small \NWtarget{nuweb45}{} $\langle\,${\itshape chol classes}\nobreak\ {\footnotesize {45}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@is.chol <- function(x) inherits(x, "chol")@\\ \mbox{}\verb@as.chol <- function(x) {@\\ \mbox{}\verb@ stopifnot(is.ltMatrices(x))@\\ \mbox{}\verb@ if (is.chol(x)) return(x)@\\ \mbox{}\verb@ if (is.invchol(x))@\\ \mbox{}\verb@ return(invchol2chol(x))@\\ \mbox{}\verb@ class(x) <- c("chol", class(x))@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@is.invchol <- function(x) inherits(x, "invchol")@\\ \mbox{}\verb@as.invchol <- function(x) {@\\ \mbox{}\verb@ stopifnot(is.ltMatrices(x))@\\ \mbox{}\verb@ if (is.invchol(x)) return(x)@\\ \mbox{}\verb@ if (is.chol(x))@\\ \mbox{}\verb@ return(chol2invchol(x))@\\ \mbox{}\verb@ class(x) <- c("invchol", class(x))@\\ \mbox{}\verb@ return(x)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb48}{48}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} First, we set-up functions for computing $\tilde{\mC}_i$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap51}\raggedright\small \NWtarget{nuweb46}{} $\langle\,${\itshape D times C}\nobreak\ {\footnotesize {46}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Dchol <- function(x, D = 1 / sqrt(Tcrossprod(x, diag_only = TRUE))) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.invchol(x)) stop("Dchol cannot work with invchol objects")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- .adddiag(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow_orig <- attr(x, "byrow")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = TRUE)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ N <- dim(x)[1L]@\\ \mbox{}\verb@ J <- dim(x)[2L]@\\ \mbox{}\verb@ nm <- dimnames(x)[[2L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ### for some parameter configurations logdet(ret) would@\\ \mbox{}\verb@ ### be -Inf; make sure this does't happen@\\ \mbox{}\verb@ if (any(D < .Machine$double.eps))@\\ \mbox{}\verb@ D[D < .Machine$double.eps] <- 2 * .Machine$double.eps@\\ \mbox{}\verb@ if (any(D > 1 / .Machine$double.eps))@\\ \mbox{}\verb@ D[D > 1 / .Machine$double.eps] <- (1 / .Machine$double.eps) / 2@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x) * D[rep(1:J, 1:J),,drop = FALSE]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ltMatrices(x, diag = TRUE, byrow = TRUE, names = nm)@\\ \mbox{}\verb@ ret <- as.chol(ltMatrices(ret, byrow = byrow_orig))@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb48}{48}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and $\tilde{\mC}_i^{-1} = \mL_i \text{diag}(\mL_i^{-1} \mL_i^{-\top})^{\frac{1}{2}}$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap52}\raggedright\small \NWtarget{nuweb47}{} $\langle\,${\itshape L times D}\nobreak\ {\footnotesize {47}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### invcholD = solve(Dchol)@\\ \mbox{}\verb@invcholD <- function(x, D = sqrt(Tcrossprod(solve(x), diag_only = TRUE))) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.chol(x)) stop("invcholD cannot work with chol objects")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- .adddiag(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ byrow_orig <- attr(x, "byrow")@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- ltMatrices(x, byrow = FALSE)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ N <- dim(x)[1L]@\\ \mbox{}\verb@ J <- dim(x)[2L]@\\ \mbox{}\verb@ nm <- dimnames(x)[[2L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ### for some parameter configurations logdet(ret) would@\\ \mbox{}\verb@ ### be -Inf; make sure this does't happen@\\ \mbox{}\verb@ if (any(D < .Machine$double.eps))@\\ \mbox{}\verb@ D[D < .Machine$double.eps] <- 2 * .Machine$double.eps@\\ \mbox{}\verb@ if (any(D > 1 / .Machine$double.eps))@\\ \mbox{}\verb@ D[D > 1 / .Machine$double.eps] <- (1 / .Machine$double.eps) / 2@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x <- unclass(x) * D[rep(1:J, J:1),,drop = FALSE]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ltMatrices(x, diag = TRUE, byrow = FALSE, names = nm)@\\ \mbox{}\verb@ ret <- as.invchol(ltMatrices(ret, byrow = byrow_orig))@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb48}{48}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and now the convenience functions are one-liners: \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap53}\raggedright\small \NWtarget{nuweb48}{} $\langle\,${\itshape convenience functions}\nobreak\ {\footnotesize {48}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape chol classes}\nobreak\ {\footnotesize \NWlink{nuweb45}{45}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape D times C}\nobreak\ {\footnotesize \NWlink{nuweb46}{46}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape L times D}\nobreak\ {\footnotesize \NWlink{nuweb47}{47}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@### C -> Sigma@\\ \mbox{}\verb@chol2cov <- function(x)@\\ \mbox{}\verb@ Tcrossprod(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@### L -> C@\\ \mbox{}\verb@invchol2chol <- function(x)@\\ \mbox{}\verb@ as.chol(solve(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@### C -> L@\\ \mbox{}\verb@chol2invchol <- function(x)@\\ \mbox{}\verb@ as.invchol(solve(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@### L -> Sigma@\\ \mbox{}\verb@invchol2cov <- function(x)@\\ \mbox{}\verb@ chol2cov(invchol2chol(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@### L -> Precision@\\ \mbox{}\verb@invchol2pre <- function(x)@\\ \mbox{}\verb@ Crossprod(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@### C -> Precision@\\ \mbox{}\verb@chol2pre <- function(x)@\\ \mbox{}\verb@ Crossprod(chol2invchol(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@### C -> R@\\ \mbox{}\verb@chol2cor <- function(x) {@\\ \mbox{}\verb@ ret <- Tcrossprod(Dchol(x))@\\ \mbox{}\verb@ diagonals(ret) <- NULL@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@### L -> R@\\ \mbox{}\verb@invchol2cor <- function(x) {@\\ \mbox{}\verb@ ret <- chol2cor(invchol2chol(x))@\\ \mbox{}\verb@ diagonals(ret) <- NULL@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@### L -> A@\\ \mbox{}\verb@invchol2pc <- function(x) {@\\ \mbox{}\verb@ ret <- -Crossprod(invcholD(x, D = 1 / sqrt(Crossprod(x, diag_only = TRUE))))@\\ \mbox{}\verb@ diagonals(ret) <- 0@\\ \mbox{}\verb@ ret@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@### C -> A@\\ \mbox{}\verb@chol2pc <- function(x)@\\ \mbox{}\verb@ invchol2pc(solve(x))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Here are some tests <>= prec2pc <- function(x) { ret <- -cov2cor(x) diag(ret) <- 0 ret } L <- lxn Sigma <- apply(as.array(L), 3, function(x) tcrossprod(solve(x)), simplify = FALSE) Prec <- lapply(Sigma, solve) Corr <- lapply(Sigma, cov2cor) CP <- lapply(Corr, solve) PC <- lapply(Prec, function(x) prec2pc(x)) chk(unlist(Sigma), c(as.array(invchol2cov(L))), check.attributes = FALSE) chk(unlist(Prec), c(as.array(invchol2pre(L))), check.attributes = FALSE) chk(unlist(Corr), c(as.array(invchol2cor(L))), check.attributes = FALSE) chk(unlist(CP), c(as.array(Crossprod(invcholD(L)))), check.attributes = FALSE) chk(unlist(PC), c(as.array(invchol2pc(L))), check.attributes = FALSE) @ <>= C <- lxn Sigma <- apply(as.array(C), 3, function(x) tcrossprod(x), simplify = FALSE) Prec <- lapply(Sigma, solve) Corr <- lapply(Sigma, cov2cor) CP <- lapply(Corr, solve) PC <- lapply(Prec, function(x) prec2pc(x)) chk(unlist(Sigma), c(as.array(chol2cov(C))), check.attributes = FALSE) chk(unlist(Prec), c(as.array(chol2pre(C))), check.attributes = FALSE) chk(unlist(Corr), c(as.array(chol2cor(C))), check.attributes = FALSE) chk(unlist(CP), c(as.array(Crossprod(solve(Dchol(C))))), check.attributes = FALSE) chk(unlist(PC), c(as.array(chol2pc(C))), check.attributes = FALSE) @ <>= L <- lxd Sigma <- apply(as.array(L), 3, function(x) tcrossprod(solve(x)), simplify = FALSE) Prec <- lapply(Sigma, solve) Corr <- lapply(Sigma, cov2cor) CP <- lapply(Corr, solve) PC <- lapply(Prec, function(x) prec2pc(x)) chk(unlist(Sigma), c(as.array(invchol2cov(L))), check.attributes = FALSE) chk(unlist(Prec), c(as.array(invchol2pre(L))), check.attributes = FALSE) chk(unlist(Corr), c(as.array(invchol2cor(L))), check.attributes = FALSE) chk(unlist(CP), c(as.array(Crossprod(invcholD(L)))), check.attributes = FALSE) chk(unlist(PC), c(as.array(invchol2pc(L))), check.attributes = FALSE) @ <>= C <- lxd Sigma <- apply(as.array(C), 3, function(x) tcrossprod(x), simplify = FALSE) Prec <- lapply(Sigma, solve) Corr <- lapply(Sigma, cov2cor) CP <- lapply(Corr, solve) PC <- lapply(Prec, function(x) prec2pc(x)) chk(unlist(Sigma), c(as.array(chol2cov(C))), check.attributes = FALSE) chk(unlist(Prec), c(as.array(chol2pre(C))), check.attributes = FALSE) chk(unlist(Corr), c(as.array(chol2cor(C))), check.attributes = FALSE) chk(unlist(CP), c(as.array(Crossprod(solve(Dchol(C))))), check.attributes = FALSE) chk(unlist(PC), c(as.array(chol2pc(C))), check.attributes = FALSE) @ We also add an \code{aperm} method for class \code{ltMatrices}, implementing the parameters ($\tilde{\mC}_i$ or $\tilde{\mL}_i$) for permuted versions of the random vectors $\rY_i$. Let $\pi$ denote a permutation of $1, \dots, J$ and $\Pi$ the corresponding permutation matrix. Then, we have $\Pi \rY_i \sim \ND_\J(\mathbf{0}_\J, \Pi \mC_i \mC_i^\top \Pi^\top)$. Unfortunately, $\Pi \mC_i$ is no longer lower triangular, so we have to find the Cholesky decompositon $\tilde{\mC}_i \tilde{\mC}_i^\top$ of $\Pi \mC_i \mC_i^\top \Pi^\top$. Of course, $\tilde{\mL}_i = \tilde{\mC}_i^{-1}$. The function \code{aperm}, with argument \code{perm} $=\pi$, now computes the Cholesky factor $\tilde{\mC}_i$ of the permuted covariance matrix, or the inverse thereof (in case \code{x} is of class \code{invchol}). We start with some tests \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap54}\raggedright\small \NWtarget{nuweb50}{} $\langle\,${\itshape aperm checks}\nobreak\ {\footnotesize {50}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@J <- dim(a)[2L]@\\ \mbox{}\verb@if (missing(perm)) return(a)@\\ \mbox{}\verb@if (is.character(perm)) @\\ \mbox{}\verb@ perm <- match(perm, dimnames(a)[[2L]])@\\ \mbox{}\verb@stopifnot(all(perm %in% 1:J))@\\ \mbox{}\verb@@\\ \mbox{}\verb@args <- list(...)@\\ \mbox{}\verb@if (length(args) > 0L)@\\ \mbox{}\verb@ warning("Additional arguments", names(args), "ignored")@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb51a}{51a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and then implement the two methods \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap55}\raggedright\small \NWtarget{nuweb51a}{} $\langle\,${\itshape aperm}\nobreak\ {\footnotesize {51a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@aperm.chol <- function(a, perm, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape aperm checks}\nobreak\ {\footnotesize \NWlink{nuweb50}{50}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(as.chol(chol(chol2cov(a)[,perm])))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@aperm.invchol <- function(a, perm, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape aperm checks}\nobreak\ {\footnotesize \NWlink{nuweb50}{50}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(chol2invchol(chol(invchol2cov(a)[,perm])))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroDefBy\ \NWlink{nuweb51a}{51a}\NWlink{nuweb51b}{b}. \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= L <- as.invchol(lxn) J <- dim(L)[2L] Lp <- aperm(a = L, perm = p <- sample(1:J)) chk(invchol2cov(L)[,p], invchol2cov(Lp)) C <- as.chol(lxn) J <- dim(C)[2L] Cp <- aperm(a = C, perm = p <- sample(1:J)) chk(chol2cov(C)[,p], chol2cov(Cp)) @ We finally add a method for class \code{ltMatrices}, for which we actually cannot provide a reasonable result, and for symmetric matrices, where we simply fall-back on subsetting \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap56}\raggedright\small \NWtarget{nuweb51b}{} $\langle\,${\itshape aperm}\nobreak\ {\footnotesize {51b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@aperm.ltMatrices <- function(a, perm, ...)@\\ \mbox{}\verb@ stop("Cannot permute objects of class ltMatrices, @\\ \mbox{}\verb@ consider calling as.chol() or as.invchol() first")@\\ \mbox{}\verb@@\\ \mbox{}\verb@aperm.syMatrices <- function(a, perm, ...)@\\ \mbox{}\verb@ return(a[,perm])@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroDefBy\ \NWlink{nuweb51a}{51a}\NWlink{nuweb51b}{b}. \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \section{Marginal and Conditional Normal Distributions} \label{sec:margcond} Marginal and conditional distributions from distributions $\rY_i \sim \ND_\J(\mathbf{0}_\J, \mC_i \mC_i^\top)$ (\code{chol} argument for $\mC_i$ for $i = 1, \dots, N$) or $\rY_i \sim \ND_\J(\mathbf{0}_\J, \mL_i^{-1} \mL_i^{-\top})$ (\code{invchol} argument for $\mL_i$ for $i = 1, \dots, N$) shall be computed. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap57}\raggedright\small \NWtarget{nuweb52a}{} $\langle\,${\itshape mc input checks}\nobreak\ {\footnotesize {52a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@x <- if (missing(chol)) invchol else chol@\\ \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(is.ltMatrices(x))@\\ \mbox{}\verb@@\\ \mbox{}\verb@N <- dim(x)[1L]@\\ \mbox{}\verb@J <- dim(x)[2L]@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (missing(which)) return(x)@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (is.character(which)) which <- match(which, dimnames(x)[[2L]])@\\ \mbox{}\verb@stopifnot(all(which %in% 1:J))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb52b}{52b}\NWlink{nuweb55}{, 55}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The first $j$ marginal distributions can be obtained from subsetting $\mC$ or $\mL$ directly. Arbitrary marginal distributions are based on the corresponding subset of the covariance matrix for which we compute a corresponding Cholesky factor (such that we can use \code{lpmvnorm} later on). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap58}\raggedright\small \NWtarget{nuweb52b}{} $\langle\,${\itshape marginal}\nobreak\ {\footnotesize {52b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@marg_mvnorm <- function(chol, invchol, which = 1L) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape mc input checks}\nobreak\ {\footnotesize \NWlink{nuweb52a}{52a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (which[1] == 1L && (length(which) == 1L || @\\ \mbox{}\verb@ all(diff(which) == 1L))) {@\\ \mbox{}\verb@ ### which is 1:j@\\ \mbox{}\verb@ tmp <- x[,which]@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ if (missing(chol)) x <- invchol2chol(x)@\\ \mbox{}\verb@ ### note: aperm would work but computes@\\ \mbox{}\verb@ ### Cholesky of J^2, here only length(which)^2@\\ \mbox{}\verb@ ### is needed@\\ \mbox{}\verb@ tmp <- base::chol(chol2cov(x)[,which])@\\ \mbox{}\verb@ if (missing(chol)) tmp <- chol2invchol(tmp)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (missing(chol))@\\ \mbox{}\verb@ ret <- list(invchol = tmp)@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ ret <- list(chol = tmp)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We compute conditional distributions from the precision matrices $\mSigma^{-1}_i = \mP_i = \mL_i^\top \mL_i$ (we omit the $i$ index from now on). For an arbitrary subset $\jvec \subset \{1, \dots, \J\}$, the conditional distribution of $\rY_{-\jvec}$ given $\rY_{\jvec} = \yvec_{\jvec}$ is \begin{eqnarray*} \rY_{-\jvec} \mid \rY_{\jvec} = \yvec_{\jvec} \sim \ND_{|\jvec|}\left(-\mP^{-1}_{-\jvec,-\jvec} \mP_{-\jvec, \jvec} \yvec_{\jvec}, \mP^{-1}_{-\jvec,-\jvec}\right) \end{eqnarray*} and we return a Cholesky factor $\tilde{\mC}$ such that $\mP^{-1}_{-\jvec,-\jvec} = \tilde{\mC} \tilde{\mC}^\top$ (if \code{chol} was given) or $\tilde{\mL} = \tilde{\mC}^{-1}$ (if \code{invchol} was given). We can implement this as \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap59}\raggedright\small \NWtarget{nuweb53}{} $\langle\,${\itshape cond general}\nobreak\ {\footnotesize {53}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(!center)@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (!missing(chol)) ### chol is C = Cholesky of covariance@\\ \mbox{}\verb@ P <- Crossprod(solve(chol)) ### P = t(L) %*% L with L = C^-1@\\ \mbox{}\verb@else ### invcol is L = Cholesky of precision@\\ \mbox{}\verb@ P <- Crossprod(invchol)@\\ \mbox{}\verb@@\\ \mbox{}\verb@Pw <- P[, -which]@\\ \mbox{}\verb@chol <- solve(base::chol(Pw))@\\ \mbox{}\verb@Pa <- as.array(P)@\\ \mbox{}\verb@Sa <- as.array(S <- Crossprod(chol))@\\ \mbox{}\verb@if (dim(chol)[1L] == 1L) {@\\ \mbox{}\verb@ Pa <- Pa[,,1]@\\ \mbox{}\verb@ Sa <- Sa[,,1]@\\ \mbox{}\verb@ mean <- -Sa %*% Pa[-which, which, drop = FALSE] %*% given@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ if (ncol(given) == N) {@\\ \mbox{}\verb@ mean <- sapply(1:N, function(i) @\\ \mbox{}\verb@ -Sa[,,i] %*% Pa[-which,which,i] %*% given[,i,drop = FALSE])@\\ \mbox{}\verb@ } else { ### compare to Mult() with ncol(y) !%in% (1, N)@\\ \mbox{}\verb@ mean <- sapply(1:N, function(i) @\\ \mbox{}\verb@ -Sa[,,i] %*% Pa[-which,which,i] %*% given)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb55}{55}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} If $\jvec = \{1, \dots, j < \J \}$ and $\mL$ is given, computations simplify a lot because the conditional precision matrix is \begin{eqnarray*} \mP_{-\jvec, -\jvec} = (\mL^\top \mL)_{-\jvec, -\jvec} = \mL^\top_{-\jvec, -\jvec} \mL_{-\jvec, -\jvec} \end{eqnarray*} and thus we return $\tilde{\mL} = \mL_{-\jvec, -\jvec}$ (if \code{invchol} was given) or $\tilde{\mC} = \mL^{-1}_{-\jvec, -\jvec}$ (if \code{chol} was given). The conditional mean is \begin{eqnarray*} -\mP^{-1}_{-\jvec,-\jvec} \mP_{-\jvec, \jvec} \yvec_{\jvec} & = & -\mL^{-1}_{-\jvec, -\jvec} \mL^{-\top}_{-\jvec, -\jvec} \mL^\top_{-\jvec, -\jvec} \mL_{-\jvec, \jvec} \yvec_{\jvec} \\ & = & - \mL^{-1}_{-\jvec, -\jvec} \mL_{-\jvec, \jvec} \yvec_{\jvec}. \end{eqnarray*} We sometimes, for example when scores with respect to $\mL^{-1}_{-\jvec, -\jvec}$ shall be computed in \code{slpmvnorm}, need the negative rescaled mean $\mL_{-\jvec, \jvec} \yvec_{\jvec}$ and the \code{center = TRUE} argument triggers this values to be returned. The implementation reads \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap60}\raggedright\small \NWtarget{nuweb54}{} $\langle\,${\itshape cond simple}\nobreak\ {\footnotesize {54}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (which[1] == 1L && (length(which) == 1L || @\\ \mbox{}\verb@ all(diff(which) == 1L))) {@\\ \mbox{}\verb@ ### which is 1:j@\\ \mbox{}\verb@ L <- if (missing(invchol)) solve(chol) else invchol@\\ \mbox{}\verb@ tmp <- matrix(0, ncol = ncol(given), nrow = J - length(which))@\\ \mbox{}\verb@ centerm <- Mult(L, rbind(given, tmp)) @\\ \mbox{}\verb@ ### if ncol(given) is not N = dim(L)[1L] > 1, then@\\ \mbox{}\verb@ ### solve() below won't work and we loop over@\\ \mbox{}\verb@ ### columns of centerm@\\ \mbox{}\verb@ if (dim(L)[1L] > 1 && ncol(given) != N) {@\\ \mbox{}\verb@ centerm <- lapply(1:ncol(centerm), function(j)@\\ \mbox{}\verb@ matrix(centerm[,j], nrow = J, ncol = N)[-which,,drop = FALSE]@\\ \mbox{}\verb@ )@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ centerm <- centerm[-which,,drop = FALSE]@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ L <- L[,-which]@\\ \mbox{}\verb@ ct <- centerm@\\ \mbox{}\verb@ if (!is.matrix(ct)) ct <- do.call("rbind", ct)@\\ \mbox{}\verb@ if (is.matrix(centerm)) {@\\ \mbox{}\verb@ m <- -solve(L, centerm)@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ m <- do.call("rbind", lapply(centerm, function(cm) -solve(L, cm)))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (missing(invchol)) {@\\ \mbox{}\verb@ if (center)@\\ \mbox{}\verb@ return(list(center = ct, chol = solve(L)))@\\ \mbox{}\verb@ return(list(mean = m, chol = solve(L)))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (center)@\\ \mbox{}\verb@ return(list(center = ct, invchol = L))@\\ \mbox{}\verb@ return(list(mean = m, invchol = L))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb55}{55}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Note that we could have avoided the general case altogether by first computing a Cholesky decomposition of the permuted covariance matrix (such that the conditioning variables come first). The code above only decomposes the marginal (and thus lower-dimensional) covariance. However, we didn't implement the \code{center = TRUE} case, so we can fall back on the permuted version if this option is requested. Putting everything together gives \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap61}\raggedright\small \NWtarget{nuweb55}{} $\langle\,${\itshape conditional}\nobreak\ {\footnotesize {55}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@cond_mvnorm <- function(chol, invchol, which_given = 1L, given, center = FALSE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ which <- which_given@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape mc input checks}\nobreak\ {\footnotesize \NWlink{nuweb52a}{52a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (N == 1) N <- NCOL(given)@\\ \mbox{}\verb@ stopifnot(is.matrix(given) && nrow(given) == length(which))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape cond simple}\nobreak\ {\footnotesize \NWlink{nuweb54}{54}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ### general with center = TRUE => permute first and go simple@\\ \mbox{}\verb@ if (center) {@\\ \mbox{}\verb@ perm <- c(which, (1:J)[!(1:J) %in% which])@\\ \mbox{}\verb@ if (!missing(chol))@\\ \mbox{}\verb@ return(cond_mvnorm(chol = aperm(as.chol(chol), perm = perm),@\\ \mbox{}\verb@ which_given = 1:length(which), given = given,@\\ \mbox{}\verb@ center = center))@\\ \mbox{}\verb@ return(cond_mvnorm(invchol = aperm(as.invchol(invchol), perm = perm),@\\ \mbox{}\verb@ which_given = 1:length(which), given = given,@\\ \mbox{}\verb@ center = center))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape cond general}\nobreak\ {\footnotesize \NWlink{nuweb53}{53}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ chol <- base::chol(S)@\\ \mbox{}\verb@ if (missing(invchol)) @\\ \mbox{}\verb@ return(list(mean = mean, chol = chol))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ return(list(mean = mean, invchol = solve(chol)))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Let's check this against the commonly used formula based on the covariance matrix, first for the marginal distribution <>= Sigma <- Tcrossprod(lxd) j <- 1:3 chk(Sigma[,j], Tcrossprod(marg_mvnorm(chol = lxd, which = j)$chol)) j <- 2:4 chk(Sigma[,j], Tcrossprod(marg_mvnorm(chol = lxd, which = j)$chol)) Sigma <- Tcrossprod(solve(lxd)) j <- 1:3 chk(Sigma[,j], Tcrossprod(solve(marg_mvnorm(invchol = lxd, which = j)$invchol))) j <- 2:4 chk(Sigma[,j], Tcrossprod(solve(marg_mvnorm(invchol = lxd, which = j)$invchol))) @ and then for conditional distributions. The general case is <>= Sigma <- as.array(Tcrossprod(lxd))[,,1] j <- 2:4 y <- matrix(c(-1, 2, 1), nrow = 3) cm <- Sigma[-j, j,drop = FALSE] %*% solve(Sigma[j,j]) %*% y cS <- Sigma[-j, -j] - Sigma[-j,j,drop = FALSE] %*% solve(Sigma[j,j]) %*% Sigma[j,-j,drop = FALSE] cmv <- cond_mvnorm(chol = lxd[1,], which_given = j, given = y) chk(cm, cmv$mean) chk(cS, as.array(Tcrossprod(cmv$chol))[,,1]) Sigma <- as.array(Tcrossprod(solve(lxd)))[,,1] j <- 2:4 y <- matrix(c(-1, 2, 1), nrow = 3) cm <- Sigma[-j, j,drop = FALSE] %*% solve(Sigma[j,j]) %*% y cS <- Sigma[-j, -j] - Sigma[-j,j,drop = FALSE] %*% solve(Sigma[j,j]) %*% Sigma[j,-j,drop = FALSE] cmv <- cond_mvnorm(invchol = lxd[1,], which_given = j, given = y) chk(cm, cmv$mean) chk(cS, as.array(Tcrossprod(solve(cmv$invchol)))[,,1]) @ and the simple case is <>= Sigma <- as.array(Tcrossprod(lxd))[,,1] j <- 1:3 y <- matrix(c(-1, 2, 1), nrow = 3) cm <- Sigma[-j, j,drop = FALSE] %*% solve(Sigma[j,j]) %*% y cS <- Sigma[-j, -j] - Sigma[-j,j,drop = FALSE] %*% solve(Sigma[j,j]) %*% Sigma[j,-j,drop = FALSE] cmv <- cond_mvnorm(chol = lxd[1,], which_given = j, given = y) chk(c(cm), c(cmv$mean)) chk(cS, as.array(Tcrossprod(cmv$chol))[,,1]) Sigma <- as.array(Tcrossprod(solve(lxd)))[,,1] j <- 1:3 y <- matrix(c(-1, 2, 1), nrow = 3) cm <- Sigma[-j, j,drop = FALSE] %*% solve(Sigma[j,j]) %*% y cS <- Sigma[-j, -j] - Sigma[-j,j,drop = FALSE] %*% solve(Sigma[j,j]) %*% Sigma[j,-j,drop = FALSE] cmv <- cond_mvnorm(invchol = lxd[1,], which_given = j, given = y) chk(c(cm), c(cmv$mean)) chk(cS, as.array(Tcrossprod(solve(cmv$invchol)))[,,1]) @ \section{Continuous Log-likelihoods} With $\rZ \sim \ND_J(0, \mI_J)$ and $\rY = \mC_i \rZ + \muvec_i \sim \ND_J(\muvec_i, \mC_i \mC_i^\top)$ we want to evaluate the log-likelihood contributions for observations $\yvec_1, \dots, \yvec_N$ in a function called \code{ldmvnorm} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap62}\raggedright\small \NWtarget{nuweb57a}{} $\langle\,${\itshape ldmvnorm}\nobreak\ {\footnotesize {57a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@ldmvnorm <- function(obs, mean = 0, chol, invchol, logLik = TRUE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@ if (!is.matrix(obs)) obs <- matrix(obs, ncol = 1L)@\\ \mbox{}\verb@ p <- ncol(obs)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(chol)) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape ldmvnorm chol}\nobreak\ {\footnotesize \NWlink{nuweb59a}{59a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape ldmvnorm invchol}\nobreak\ {\footnotesize \NWlink{nuweb59b}{59b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ names(logretval) <- colnames(obs)@\\ \mbox{}\verb@ if (logLik) return(sum(logretval))@\\ \mbox{}\verb@ return(logretval)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We first check if the observations $\yvec_1, \dots, \yvec_N$ are given in an $\J \times N$ matrix \code{obs} with corresponding means $\muvec_1, \dots, \muvec_N$ in \code{means}. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap63}\raggedright\small \NWtarget{nuweb57b}{} $\langle\,${\itshape check obs}\nobreak\ {\footnotesize {57b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@.check_obs <- function(obs, mean, J, N) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ nr <- nrow(obs)@\\ \mbox{}\verb@ nc <- ncol(obs)@\\ \mbox{}\verb@ if (nc != N)@\\ \mbox{}\verb@ stop("obs and (inv)chol have non-conforming size")@\\ \mbox{}\verb@ if (nr != J)@\\ \mbox{}\verb@ stop("obs and (inv)chol have non-conforming size")@\\ \mbox{}\verb@ if (identical(unique(mean), 0)) return(obs)@\\ \mbox{}\verb@ if (length(mean) == J) @\\ \mbox{}\verb@ return(obs - c(mean))@\\ \mbox{}\verb@ if (!is.matrix(mean))@\\ \mbox{}\verb@ stop("obs and mean have non-conforming size")@\\ \mbox{}\verb@ if (nrow(mean) != nr)@\\ \mbox{}\verb@ stop("obs and mean have non-conforming size")@\\ \mbox{}\verb@ if (ncol(mean) != nc)@\\ \mbox{}\verb@ stop("obs and mean have non-conforming size")@\\ \mbox{}\verb@ return(obs - mean)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} With $\mSigma_i = \mC_i \mC_i^\top$ the log-likelihood function for $\rY_i = \yvec_i$ is \begin{eqnarray*} \ell_i(\muvec_i, \mC_i) = -\frac{k}{2} \log(2\pi) - \frac{1}{2} \log \mid \mSigma_i \mid - \frac{1}{2} (\yvec_i - \muvec_i)^\top \mSigma^{-1}_i (\yvec_i - \muvec_i) \end{eqnarray*} Because $\log \mid \mSigma_i \mid = \log \mid \mC_i \mC_i^\top \mid = 2 \log \mid \mC_i \mid = 2 \sum_{j = 1}^\J \log \diag(\mC_i)_j$ we get the simpler expression \begin{eqnarray} \label{ll_mC} \ell_i(\muvec_i, \mC_i) & = & -\frac{k}{2} \log(2\pi) - \sum_{j = 1}^\J \log \diag(\mC_i)_j - \frac{1}{2} (\yvec_i - \muvec_i)^\top \mC_i^{-\top} \mC_i^{-1} (\yvec - \muvec_i). \end{eqnarray} We need to compute \code{colSums(dnorm(z, log = TRUE))} quite often. This turns out to be time-consuming and memory intensive, so we provide a small internal helper function focusing on the necessary computations. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap64}\raggedright\small \NWtarget{nuweb58a}{} $\langle\,${\itshape colSumsdnorm}\nobreak\ {\footnotesize {58a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_ltMatrices_colSumsdnorm (SEXP z, SEXP N, SEXP J) {@\\ \mbox{}\verb@ /* number of columns */@\\ \mbox{}\verb@ int iN = INTEGER(N)[0];@\\ \mbox{}\verb@ /* number of rows */@\\ \mbox{}\verb@ int iJ = INTEGER(J)[0];@\\ \mbox{}\verb@ SEXP ans;@\\ \mbox{}\verb@ double *dans, Jl2pi, *dz;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Jl2pi = iJ * log(2 * M_PI);@\\ \mbox{}\verb@ PROTECT(ans = allocVector(REALSXP, iN));@\\ \mbox{}\verb@ dans = REAL(ans);@\\ \mbox{}\verb@ dz = REAL(z);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (int i = 0; i < iN; i++) {@\\ \mbox{}\verb@ dans[i] = 0.0;@\\ \mbox{}\verb@ for (int j = 0; j < iJ; j++)@\\ \mbox{}\verb@ dans[i] += pow(dz[j], 2);@\\ \mbox{}\verb@ dans[i] = - 0.5 * (Jl2pi + dans[i]);@\\ \mbox{}\verb@ dz += iJ;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap65}\raggedright\small \NWtarget{nuweb58b}{} $\langle\,${\itshape colSumsdnorm ltMatrices}\nobreak\ {\footnotesize {58b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@.colSumsdnorm <- function(z) {@\\ \mbox{}\verb@ stopifnot(is.numeric(z))@\\ \mbox{}\verb@ if (!is.matrix(z))@\\ \mbox{}\verb@ z <- matrix(z, nrow = 1, ncol = length(z))@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_ltMatrices_colSumsdnorm, z, ncol(z), nrow(z))@\\ \mbox{}\verb@ names(ret) <- colnames(z)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The main part is now \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap66}\raggedright\small \NWtarget{nuweb59a}{} $\langle\,${\itshape ldmvnorm chol}\nobreak\ {\footnotesize {59a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (missing(chol))@\\ \mbox{}\verb@ stop("either chol or invchol must be given")@\\ \mbox{}\verb@## chol is given@\\ \mbox{}\verb@if (!is.ltMatrices(chol)) ### NOTE: replace with is.chol@\\ \mbox{}\verb@ stop("chol is not an object of class ltMatrices")@\\ \mbox{}\verb@N <- dim(chol)[1L]@\\ \mbox{}\verb@N <- ifelse(N == 1, p, N)@\\ \mbox{}\verb@J <- dim(chol)[2L]@\\ \mbox{}\verb@obs <- .check_obs(obs = obs, mean = mean, J = J, N = N)@\\ \mbox{}\verb@z <- solve(chol, obs)@\\ \mbox{}\verb@logretval <- .colSumsdnorm(z)@\\ \mbox{}\verb@if (attr(chol, "diag"))@\\ \mbox{}\verb@ logretval <- logretval - logdet(chol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb57a}{57a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} where we can use the efficient implementations of \code{solve} and \code{logdet}. If $\mL_i = \mC_i^{-1}$ is given, we obtain \begin{eqnarray*} \ell_i(\muvec_i, \mL_i) & = & -\frac{k}{2} \log(2\pi) + \sum_{j = 1}^\J \log \diag(\mL_i)_j - \frac{1}{2} (\yvec_i - \muvec_i)^\top \mL_i^\top \mL_i (\yvec - \muvec_i). \end{eqnarray*} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap67}\raggedright\small \NWtarget{nuweb59b}{} $\langle\,${\itshape ldmvnorm invchol}\nobreak\ {\footnotesize {59b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@## invchol is given@\\ \mbox{}\verb@if (!is.ltMatrices(invchol)) ### NOTE: replace with is.invchol@\\ \mbox{}\verb@ stop("invchol is not an object of class ltMatrices")@\\ \mbox{}\verb@N <- dim(invchol)[1L]@\\ \mbox{}\verb@N <- ifelse(N == 1, p, N)@\\ \mbox{}\verb@J <- dim(invchol)[2L]@\\ \mbox{}\verb@obs <- .check_obs(obs = obs, mean = mean, J = J, N = N)@\\ \mbox{}\verb@## NOTE: obs is (J x N) @\\ \mbox{}\verb@## dnorm takes rather long@\\ \mbox{}\verb@z <- Mult(invchol, obs)@\\ \mbox{}\verb@logretval <- .colSumsdnorm(z)@\\ \mbox{}\verb@## note that the second summand gets recycled the correct number@\\ \mbox{}\verb@## of times in case dim(invchol)[1L] == 1 but ncol(obs) > 1@\\ \mbox{}\verb@if (attr(invchol, "diag"))@\\ \mbox{}\verb@ logretval <- logretval + logdet(invchol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb57a}{57a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The score function with respect to \code{obs} is \begin{eqnarray*} \frac{\partial \ell_i(\muvec_i, \mL_i)}{\partial \yvec_i} = - \mL_i^\top \mL_i \yvec_i \end{eqnarray*} and with respect to \code{invchol} we have \begin{eqnarray*} \frac{\partial \ell_i(\muvec_i, \mL_i)}{\partial \mL_i} = - 2 \mL_i \yvec_i \yvec_i^\top + \diag(\mL_i)^{-1}. \end{eqnarray*} The score function with respect to \code{chol} post-processes the above score using the vec trick~(Section~\ref{sec:vectrick}). For the log-likelihood~(\ref{ll_mC}), the score with respect to $\mC_i$ is the sum of the score functions of the two terms. We start with the simpler first term \begin{eqnarray*} \frac{\partial - \sum_{j = 1}^\J \log \diag(\mC_i)_j}{\partial \mC_i} & = & - \diag(\mC_i)^{-1} \end{eqnarray*} The second term gives (we omit the mean for the sake of simplicity) \begin{eqnarray*} \frac{\partial - \yvec_i^\top \mC_i^{-\top} \mC_i^{-1} \yvec_i}{\partial \mC_i} & = & - \left. \frac{\partial \yvec_i^\top \mA^\top \mA \yvec_i}{\partial \mA} \right|_{\mA = \mC^{-1}_i} \left. \frac{\partial \mA^{-1}}{\partial \mA} \right|_{\mA = \mC_i} \\ & = & - 2 \vecop(\mC_i^{-1} \yvec_i \yvec_i^\top)^\top (-1) (\mC_i^{-\top} \otimes \mC_i^{-1}) \\ & = & 2 \vecop(\mC_i^{-\top} \mC_i^{-1} \yvec_i \yvec_i^\top \mC_i^{-\top})^\top \end{eqnarray*} In \code{sldmvnorm}, we compute the score with respect to $\mL_i$ and use the above relationship to compute the score with respect to $\mC_i$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap68}\raggedright\small \NWtarget{nuweb61}{} $\langle\,${\itshape sldmvnorm}\nobreak\ {\footnotesize {61}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@sldmvnorm <- function(obs, mean = 0, chol, invchol, logLik = TRUE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@ if (!is.matrix(obs)) obs <- matrix(obs, ncol = 1L)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(invchol)) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ N <- dim(invchol)[1L]@\\ \mbox{}\verb@ N <- ifelse(N == 1, ncol(obs), N)@\\ \mbox{}\verb@ J <- dim(invchol)[2L]@\\ \mbox{}\verb@ obs <- .check_obs(obs = obs, mean = mean, J = J, N = N)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Mix <- Mult(invchol, obs)@\\ \mbox{}\verb@ sobs <- - Mult(invchol, Mix, transpose = TRUE)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Y <- matrix(obs, byrow = TRUE, nrow = J, ncol = N * J)@\\ \mbox{}\verb@ ret <- - matrix(Mix[, rep(1:N, each = J)] * Y, ncol = N)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ M <- matrix(1:(J^2), nrow = J, byrow = FALSE)@\\ \mbox{}\verb@ ret <- ret[M[lower.tri(M, diag = attr(invchol, "diag"))],,drop = FALSE]@\\ \mbox{}\verb@ if (!is.null(dimnames(invchol)[[1L]]))@\\ \mbox{}\verb@ colnames(ret) <- dimnames(invchol)[[1]]@\\ \mbox{}\verb@ ret <- ltMatrices(ret,@\\ \mbox{}\verb@ diag = attr(invchol, "diag"), byrow = FALSE,@\\ \mbox{}\verb@ names = dimnames(invchol)[[2L]])@\\ \mbox{}\verb@ ret <- ltMatrices(ret, diag = attr(invchol, "diag"), @\\ \mbox{}\verb@ byrow = attr(invchol, "byrow"))@\\ \mbox{}\verb@ if (attr(invchol, "diag")) {@\\ \mbox{}\verb@ ### recycle properly@\\ \mbox{}\verb@ diagonals(ret) <- diagonals(ret) + c(1 / diagonals(invchol))@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ diagonals(ret) <- 0@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ ret <- list(obs = sobs, invchol = ret)@\\ \mbox{}\verb@ if (logLik) @\\ \mbox{}\verb@ ret$logLik <- ldmvnorm(obs = obs, mean = mean, @\\ \mbox{}\verb@ invchol = invchol, logLik = FALSE)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ invchol <- solve(chol)@\\ \mbox{}\verb@ ret <- sldmvnorm(obs = obs, mean = mean, invchol = invchol)@\\ \mbox{}\verb@ ### this means: ret$chol <- - vectrick(invchol, ret$invchol, invchol)@\\ \mbox{}\verb@ ret$chol <- as.chol(- vectrick(invchol, ret$invchol))@\\ \mbox{}\verb@ ret$invchol <- NULL@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \section{Application Example} Let's say we have $\rY_i \sim \ND_\J(\mathbf{0}_J, \mC_i \mC_i^{\top})$ for $i = 1, \dots, N$ and we know the Cholesky factors $\mL_i = \mC_i^{-1}$ of the $N$ precision matrices $\Sigma^{-1}_i = \mL_i \mL_i^{\top}$. We generate $\rY_i = \mL_i^{-1} \rZ_i$ from $\rZ_i \sim \ND_\J(\mathbf{0}_\J, \mI_\J)$. Evaluating the corresponding log-likelihood is now straightforward and fast, compared to repeated calls to \code{dmvnorm} <>= N <- 1000L J <- 50L lt <- ltMatrices(matrix(runif(N * J * (J + 1) / 2) + 1, ncol = N), diag = TRUE, byrow = FALSE) Z <- matrix(rnorm(N * J), ncol = N) Y <- solve(lt, Z) ll1 <- sum(dnorm(Mult(lt, Y), log = TRUE)) + sum(log(diagonals(lt))) S <- as.array(Tcrossprod(solve(lt))) ll2 <- sum(sapply(1:N, function(i) dmvnorm(x = Y[,i], sigma = S[,,i], log = TRUE))) chk(ll1, ll2) @ The \code{ldmvnorm} function now also has \code{chol} and \code{invchol} arguments such that we can use <>= ll3 <- ldmvnorm(obs = Y, invchol = lt) chk(ll1, ll3) @ Note that argument \code{obs} in \code{ldmvnorm} is an $\J \times N$ matrix whereas the traditional interface in \code{dmvnorm} expects an $N \times \J$ matrix \code{x}. The reason is that \code{Mult} or \code{solve} work with $\J \times N$ matrices and we want to avoid matrix transposes. Sometimes it is preferable to split the joint distribution into a marginal distribution of some elements and the conditional distribution given these elements. The joint density is, of course, the product of the marginal and conditional densities and we can check if this works for our example by <>= ## marginal of and conditional on these (j <- 1:5 * 10) md <- marg_mvnorm(invchol = lt, which = j) cd <- cond_mvnorm(invchol = lt, which_given = j, given = Y[j,]) ll3 <- sum(dnorm(Mult(md$invchol, Y[j,]), log = TRUE)) + sum(log(diagonals(md$invchol))) + sum(dnorm(Mult(cd$invchol, Y[-j,] - cd$mean), log = TRUE)) + sum(log(diagonals(cd$invchol))) chk(ll1, ll3) @ \chapter{Multivariate Normal Log-likelihoods} \label{lpmvnorm} <>= set.seed(270312) @ We now discuss code for evaluating the log-likelihood \begin{eqnarray*} \sum_{i = 1}^N \log(p_i(\mC_i \mid \avec_i, \bvec_i)) \end{eqnarray*} This is relatively simple to achieve using the existing \code{pmvnorm} function, so a prototype might look like \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap69}\raggedright\small \NWtarget{nuweb63}{} $\langle\,${\itshape lpmvnormR}\nobreak\ {\footnotesize {63}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@lpmvnormR <- function(lower, upper, mean = 0, center = NULL, chol, logLik = TRUE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape input checks}\nobreak\ {\footnotesize \NWlink{nuweb66}{66}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ sigma <- Tcrossprod(chol)@\\ \mbox{}\verb@ S <- as.array(sigma)@\\ \mbox{}\verb@ idx <- 1@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- error <- numeric(N)@\\ \mbox{}\verb@ for (i in 1:N) {@\\ \mbox{}\verb@ if (dim(sigma)[[1L]] > 1) idx <- i@\\ \mbox{}\verb@ tmp <- pmvnorm(lower = lower[,i], upper = upper[,i], sigma = S[,,idx], ...)@\\ \mbox{}\verb@ ret[i] <- tmp@\\ \mbox{}\verb@ error[i] <- attr(tmp, "error")@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ attr(ret, "error") <- error@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (logLik)@\\ \mbox{}\verb@ return(sum(log(pmax(ret, .Machine$double.eps))))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item {\NWtxtMacroNoRef}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= lpmvnormR <- function(lower, upper, mean = 0, center = NULL, chol, logLik = TRUE, ...) { if (!is.matrix(lower)) lower <- matrix(lower, ncol = 1) if (!is.matrix(upper)) upper <- matrix(upper, ncol = 1) stopifnot(isTRUE(all.equal(dim(lower), dim(upper)))) stopifnot(is.ltMatrices(chol)) ### NOTE: replace with is.chol byrow_orig <- attr(chol, "byrow") chol <- ltMatrices(chol, byrow = TRUE) d <- dim(chol) ### allow single matrix C N <- ifelse(d[1L] == 1, ncol(lower), d[1L]) J <- d[2L] stopifnot(nrow(lower) == J && ncol(lower) == N) stopifnot(nrow(upper) == J && ncol(upper) == N) if (is.matrix(mean)) { if (ncol(mean) == 1L) mean <- mean[,rep(1, N),drop = FALSE] stopifnot(nrow(mean) == J && ncol(mean) == N) } lower <- lower - mean upper <- upper - mean if (!is.null(center)) { if (!is.matrix(center)) center <- matrix(center, ncol = 1) stopifnot(nrow(center) == J && ncol(center == N)) } sigma <- Tcrossprod(chol) S <- as.array(sigma) idx <- 1 ret <- error <- numeric(N) for (i in 1:N) { if (dim(sigma)[[1L]] > 1) idx <- i tmp <- pmvnorm(lower = lower[,i], upper = upper[,i], sigma = S[,,idx], ...) ret[i] <- tmp error[i] <- attr(tmp, "error") } attr(ret, "error") <- error if (logLik) return(sum(log(pmax(ret, .Machine$double.eps)))) ret } @ However, the underlying \proglang{FORTRAN} code first computes the Cholesky factor based on the covariance matrix, which is clearly a waste of time. Repeated calls to \proglang{FORTRAN} also cost some time. The code \citep[based on and evaluated in][]{Genz_Bretz_2002} implements a specific form of quasi-Monte-Carlo integration without allowing the user to change the scheme (or to fall-back to simple Monte-Carlo). We therefore implement our own simplified version, with the aim to speed-things up such that maximum-likelihood estimation becomes a bit faster. Let's look at an example first. This code estimates $p_1, \dots, p_{10}$ for a $5$-dimensional normal <>= J <- 5L N <- 10L x <- matrix(runif(N * J * (J + 1) / 2), ncol = N) lx <- ltMatrices(x, byrow = TRUE, diag = TRUE) a <- matrix(runif(N * J), nrow = J) - 2 a[sample(J * N)[1:2]] <- -Inf b <- a + 2 + matrix(runif(N * J), nrow = J) b[sample(J * N)[1:2]] <- Inf (phat <- c(lpmvnormR(a, b, chol = lx, logLik = FALSE))) @ We want to achieve the same result a bit more general and a bit faster, by making the code more modular and, most importantly, by providing score functions for all arguments $\avec_i$, $\bvec_i$, and $\mC_i$. \section{Algorithm} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap70}\raggedright\small \NWtarget{nuweb64}{} \verb@"lpmvnorm.R"@\nobreak\ {\footnotesize {64}}$\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape R Header}\nobreak\ {\footnotesize \NWlink{nuweb136}{136}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lpmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb75}{75}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape slpmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb87}{87}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape ldmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb57a}{57a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape sldmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb61}{61}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape ldpmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb99}{99}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape sldpmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb101}{101}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape deperma}\nobreak\ {\footnotesize \NWlink{nuweb106}{106}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape standardize}\nobreak\ {\footnotesize \NWlink{nuweb108}{108}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape destandardize}\nobreak\ {\footnotesize \NWlink{nuweb110}{110}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lpRR}\nobreak\ {\footnotesize \NWlink{nuweb133}{133}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape slpRR}\nobreak\ {\footnotesize \NWlink{nuweb134}{134}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap71}\raggedright\small \NWtarget{nuweb65}{} \verb@"lpmvnorm.c"@\nobreak\ {\footnotesize {65}}$\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape C Header}\nobreak\ {\footnotesize \NWlink{nuweb137}{137}}$\,\rangle$}\verb@@\\ \mbox{}\verb@#ifndef USE_FC_LEN_T@\\ \mbox{}\verb@# define USE_FC_LEN_T@\\ \mbox{}\verb@#endif@\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include /* for dtrmm */@\\ \mbox{}\verb@#ifndef FCONE@\\ \mbox{}\verb@# define FCONE@\\ \mbox{}\verb@#endif@\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include @\\ \mbox{}\verb@#include @\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape pnorm fast}\nobreak\ {\footnotesize \NWlink{nuweb70b}{70b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape pnorm slow}\nobreak\ {\footnotesize \NWlink{nuweb70c}{70c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape R lpmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb73}{73}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape R slpmvnorm}\nobreak\ {\footnotesize \NWlink{nuweb84}{84}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We implement the algorithm described by \cite{numerical-:1992}. The key point here is that the original $\J$-dimensional problem~(\ref{pmvnorm}) is transformed into an integral over $[0, 1]^{\J - 1}$. For each $i = 1, \dots, N$, do \begin{enumerate} \item Input $\mC_i$ (\code{chol}), $\avec_i$ (\code{lower}), $\bvec_i$ (\code{upper}), and control parameters $\alpha$, $\epsilon$, and $M_\text{max}$ (\code{M}). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap72}\raggedright\small \NWtarget{nuweb66}{} $\langle\,${\itshape input checks}\nobreak\ {\footnotesize {66}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!is.matrix(lower)) lower <- matrix(lower, ncol = 1)@\\ \mbox{}\verb@if (!is.matrix(upper)) upper <- matrix(upper, ncol = 1)@\\ \mbox{}\verb@stopifnot(isTRUE(all.equal(dim(lower), dim(upper))))@\\ \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(is.ltMatrices(chol)) ### NOTE: replace with is.chol@\\ \mbox{}\verb@byrow_orig <- attr(chol, "byrow")@\\ \mbox{}\verb@chol <- ltMatrices(chol, byrow = TRUE)@\\ \mbox{}\verb@d <- dim(chol)@\\ \mbox{}\verb@### allow single matrix C@\\ \mbox{}\verb@N <- ifelse(d[1L] == 1, ncol(lower), d[1L])@\\ \mbox{}\verb@J <- d[2L]@\\ \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(nrow(lower) == J && ncol(lower) == N)@\\ \mbox{}\verb@stopifnot(nrow(upper) == J && ncol(upper) == N)@\\ \mbox{}\verb@if (is.matrix(mean)) {@\\ \mbox{}\verb@ if (ncol(mean) == 1L) @\\ \mbox{}\verb@ mean <- mean[,rep(1, N),drop = FALSE]@\\ \mbox{}\verb@ stopifnot(nrow(mean) == J && ncol(mean) == N)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@lower <- lower - mean@\\ \mbox{}\verb@upper <- upper - mean@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (!is.null(center)) {@\\ \mbox{}\verb@ if (!is.matrix(center)) center <- matrix(center, ncol = 1)@\\ \mbox{}\verb@ stopifnot(nrow(center) == J && ncol(center == N))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb63}{63}\NWlink{nuweb75}{, 75}\NWlink{nuweb87}{, 87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \item Standardise integration limits $a^{(i)}_j / c^{(i)}_{jj}$, $b^{(i)}_j / c^{(i)}_{jj}$, and rows $c^{(i)}_{j\jmath} / c^{(i)}_{jj}$ for $1 \le \jmath < j < \J$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap73}\raggedright\small \NWtarget{nuweb67a}{} $\langle\,${\itshape standardise}\nobreak\ {\footnotesize {67a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (attr(chol, "diag")) {@\\ \mbox{}\verb@ ### diagonals returns J x N and lower/upper are J x N, so@\\ \mbox{}\verb@ ### elementwise standardisation is simple@\\ \mbox{}\verb@ dchol <- diagonals(chol)@\\ \mbox{}\verb@ ### zero diagonals not allowed@\\ \mbox{}\verb@ stopifnot(all(abs(dchol) > (.Machine$double.eps)))@\\ \mbox{}\verb@ ac <- lower / c(dchol)@\\ \mbox{}\verb@ bc <- upper / c(dchol)@\\ \mbox{}\verb@ C <- Dchol(chol, D = 1 / dchol)@\\ \mbox{}\verb@ if (J > 1) { ### else: univariate problem; C is no longer used@\\ \mbox{}\verb@ uC <- Lower_tri(C)@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ uC <- unclass(C)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ ac <- lower@\\ \mbox{}\verb@ bc <- upper@\\ \mbox{}\verb@ uC <- Lower_tri(chol)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \item Initialise $\text{intsum} = \text{varsum} = 0$, $M = 0$, $d_1 = \Phi\left(a^{(i)}_1\right)$, $e_1 = \Phi\left(b^{(i)}_1\right)$ and $f_1 = e_1 - d_1$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap74}\raggedright\small \NWtarget{nuweb67b}{} $\langle\,${\itshape initialisation}\nobreak\ {\footnotesize {67b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@x0 = 0.0;@\\ \mbox{}\verb@if (LENGTH(center))@\\ \mbox{}\verb@ x0 = -dcenter[0];@\\ \mbox{}\verb@d0 = pnorm_ptr(da[0], x0);@\\ \mbox{}\verb@e0 = pnorm_ptr(db[0], x0);@\\ \mbox{}\verb@emd0 = e0 - d0;@\\ \mbox{}\verb@f0 = emd0;@\\ \mbox{}\verb@intsum = (iJ > 1 ? 0.0 : f0);@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \item Repeat \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap75}\raggedright\small \NWtarget{nuweb67c}{} $\langle\,${\itshape init logLik loop}\nobreak\ {\footnotesize {67c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@d = d0;@\\ \mbox{}\verb@f = f0;@\\ \mbox{}\verb@emd = emd0;@\\ \mbox{}\verb@start = 0;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb78c}{, 78c}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{enumerate} \item Generate uniform $w_1, \dots, w_{\J - 1} \in [0, 1]$. \item For $j = 2, \dots, J$ set \begin{eqnarray*} y_{j - 1} & = & \Phi^{-1}\left(d_{j - 1} + w_{j - 1} (e_{j - 1} - d_{j - 1})\right) \end{eqnarray*} We either generate $w_{j - 1}$ on the fly or use pre-computed weights (\code{w}). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap76}\raggedright\small \NWtarget{nuweb68a}{} $\langle\,${\itshape compute y}\nobreak\ {\footnotesize {68a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Wtmp = (W == R_NilValue ? unif_rand() : dW[j - 1]);@\\ \mbox{}\verb@tmp = d + Wtmp * emd;@\\ \mbox{}\verb@if (tmp < dtol) {@\\ \mbox{}\verb@ y[j - 1] = q0;@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ if (tmp > mdtol)@\\ \mbox{}\verb@ y[j - 1] = -q0;@\\ \mbox{}\verb@ else@\\ \mbox{}\verb@ y[j - 1] = qnorm(tmp, 0.0, 1.0, 1L, 0L);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{eqnarray*} x_{j - 1} & = & \sum_{\jmath = 1}^{j - 1} c^{(i)}_{j\jmath} y_j \end{eqnarray*} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap77}\raggedright\small \NWtarget{nuweb68b}{} $\langle\,${\itshape compute x}\nobreak\ {\footnotesize {68b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@x = 0.0;@\\ \mbox{}\verb@if (LENGTH(center)) {@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ x += dC[start + k] * (y[k] - dcenter[k]);@\\ \mbox{}\verb@ x -= dcenter[j]; @\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ x += dC[start + k] * y[k];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{eqnarray*} d_j & = & \Phi\left(a^{(i)}_j - x_{j - 1}\right) \\ e_j & = & \Phi\left(b^{(i)}_j - x_{j - 1}\right) \end{eqnarray*} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap78}\raggedright\small \NWtarget{nuweb68c}{} $\langle\,${\itshape update d, e}\nobreak\ {\footnotesize {68c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@d = pnorm_ptr(da[j], x);@\\ \mbox{}\verb@e = pnorm_ptr(db[j], x);@\\ \mbox{}\verb@emd = e - d;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{eqnarray*} f_j & = & (e_j - d_j) f_{j - 1}. \end{eqnarray*} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap79}\raggedright\small \NWtarget{nuweb69a}{} $\langle\,${\itshape update f}\nobreak\ {\footnotesize {69a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@start += j;@\\ \mbox{}\verb@f *= emd;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We put everything together in a loop starting with the second dimension \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap80}\raggedright\small \NWtarget{nuweb69b}{} $\langle\,${\itshape inner logLik loop}\nobreak\ {\footnotesize {69b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@for (j = 1; j < iJ; j++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape compute y}\nobreak\ {\footnotesize \NWlink{nuweb68a}{68a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape compute x}\nobreak\ {\footnotesize \NWlink{nuweb68b}{68b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update d, e}\nobreak\ {\footnotesize \NWlink{nuweb68c}{68c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update f}\nobreak\ {\footnotesize \NWlink{nuweb69a}{69a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \item Set $\text{intsum} = \text{intsum} + f_\J$, $\text{varsum} = \text{varsum} + f^2_\J$, $M = M + 1$, and $\text{error} = \sqrt{(\text{varsum}/M - (\text{intsum}/M)^2) / M}$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap81}\raggedright\small \NWtarget{nuweb69c}{} $\langle\,${\itshape increment}\nobreak\ {\footnotesize {69c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@intsum += f;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We refrain from early stopping and error estimation. \item[Until] $\text{error} < \epsilon$ or $M = M_\text{max}$ \end{enumerate} \item Output $\hat{p}_i = \text{intsum} / M$. We return $\log{\hat{p}_i}$ for each $i$, or we immediately sum-up over $i$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap82}\raggedright\small \NWtarget{nuweb69d}{} $\langle\,${\itshape output}\nobreak\ {\footnotesize {69d}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dans[0] += (intsum < dtol ? l0 : log(intsum)) - lM;@\\ \mbox{}\verb@if (!RlogLik)@\\ \mbox{}\verb@ dans += 1L;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and move on to the next observation (note that \code{p} might be $0$ in case $\mC_i \equiv \mC$). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap83}\raggedright\small \NWtarget{nuweb70a}{} $\langle\,${\itshape move on}\nobreak\ {\footnotesize {70a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@da += iJ;@\\ \mbox{}\verb@db += iJ;@\\ \mbox{}\verb@dC += p;@\\ \mbox{}\verb@if (LENGTH(center)) dcenter += iJ;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \end{enumerate} It turned out that calls to \code{pnorm} are expensive, so a slightly faster alternative \citep[suggested by][]{Matic_Radoicic_Stefanica_2018} might provide an alternative which can be requested from using (\code{fast = TRUE} in the calls to \code{lpmvnorm} and \code{slpmvnorm}): \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap84}\raggedright\small \NWtarget{nuweb70b}{} $\langle\,${\itshape pnorm fast}\nobreak\ {\footnotesize {70b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@/* see https://doi.org/10.2139/ssrn.2842681 */@\\ \mbox{}\verb@const double g2 = -0.0150234471495426236132;@\\ \mbox{}\verb@const double g4 = 0.000666098511701018747289;@\\ \mbox{}\verb@const double g6 = 5.07937324518981103694e-06;@\\ \mbox{}\verb@const double g8 = -2.92345273673194627762e-06;@\\ \mbox{}\verb@const double g10 = 1.34797733516989204361e-07;@\\ \mbox{}\verb@const double m2dpi = -2.0 / M_PI; //3.141592653589793115998;@\\ \mbox{}\verb@@\\ \mbox{}\verb@double C_pnorm_fast (double x, double m) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ double tmp, ret;@\\ \mbox{}\verb@ double x2, x4, x6, x8, x10;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (R_FINITE(x)) {@\\ \mbox{}\verb@ x = x - m;@\\ \mbox{}\verb@ x2 = x * x;@\\ \mbox{}\verb@ x4 = x2 * x2;@\\ \mbox{}\verb@ x6 = x4 * x2;@\\ \mbox{}\verb@ x8 = x6 * x2;@\\ \mbox{}\verb@ x10 = x8 * x2;@\\ \mbox{}\verb@ tmp = 1 + g2 * x2 + g4 * x4 + g6 * x6 + g8 * x8 + g10 * x10;@\\ \mbox{}\verb@ tmp = m2dpi * x2 * tmp;@\\ \mbox{}\verb@ ret = .5 + ((x > 0) - (x < 0)) * sqrt(1 - exp(tmp)) / 2.0;@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ ret = (x > 0 ? 1.0 : 0.0);@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ return(ret);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb65}{65}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap85}\raggedright\small \NWtarget{nuweb70c}{} $\langle\,${\itshape pnorm slow}\nobreak\ {\footnotesize {70c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@double C_pnorm_slow (double x, double m) {@\\ \mbox{}\verb@ return(pnorm(x, m, 1.0, 1L, 0L));@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb65}{65}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The \code{fast} argument can be used to switch on the faster but less accurate version of \code{pnorm} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap86}\raggedright\small \NWtarget{nuweb71a}{} $\langle\,${\itshape pnorm}\nobreak\ {\footnotesize {71a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Rboolean Rfast = asLogical(fast);@\\ \mbox{}\verb@double (*pnorm_ptr)(double, double) = C_pnorm_slow;@\\ \mbox{}\verb@if (Rfast)@\\ \mbox{}\verb@ pnorm_ptr = C_pnorm_fast;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We allow a new set of weights for each observation or one set for all observations. In the former case, the number of columns is $M \times N$ and in the latter just $M$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap87}\raggedright\small \NWtarget{nuweb71b}{} $\langle\,${\itshape W length}\nobreak\ {\footnotesize {71b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@int pW = 0;@\\ \mbox{}\verb@if (W != R_NilValue) {@\\ \mbox{}\verb@ if (LENGTH(W) == (iJ - 1) * iM) {@\\ \mbox{}\verb@ pW = 0;@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ if (LENGTH(W) != (iJ - 1) * iN * iM)@\\ \mbox{}\verb@ error("Length of W incorrect");@\\ \mbox{}\verb@ pW = 1;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ dW = REAL(W);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap88}\raggedright\small \NWtarget{nuweb71c}{} $\langle\,${\itshape dimensions}\nobreak\ {\footnotesize {71c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@int iM = INTEGER(M)[0]; @\\ \mbox{}\verb@int iN = INTEGER(N)[0]; @\\ \mbox{}\verb@int iJ = INTEGER(J)[0]; @\\ \mbox{}\verb@@\\ \mbox{}\verb@da = REAL(a);@\\ \mbox{}\verb@db = REAL(b);@\\ \mbox{}\verb@dC = REAL(C);@\\ \mbox{}\verb@dW = REAL(C); // make -Wmaybe-uninitialized happy@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (LENGTH(C) == iJ * (iJ - 1) / 2)@\\ \mbox{}\verb@ p = 0;@\\ \mbox{}\verb@else @\\ \mbox{}\verb@ p = LENGTH(C) / iN;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap89}\raggedright\small \NWtarget{nuweb72a}{} $\langle\,${\itshape setup return object}\nobreak\ {\footnotesize {72a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@len = (RlogLik ? 1 : iN);@\\ \mbox{}\verb@PROTECT(ans = allocVector(REALSXP, len));@\\ \mbox{}\verb@dans = REAL(ans);@\\ \mbox{}\verb@for (int i = 0; i < len; i++)@\\ \mbox{}\verb@ dans[i] = 0.0;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The case $\J = 1$ does not loop over $M$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap90}\raggedright\small \NWtarget{nuweb72b}{} $\langle\,${\itshape univariate problem}\nobreak\ {\footnotesize {72b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (iJ == 1) {@\\ \mbox{}\verb@ iM = 0; @\\ \mbox{}\verb@ lM = 0.0;@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ lM = log((double) iM);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap91}\raggedright\small \NWtarget{nuweb72c}{} $\langle\,${\itshape init center}\nobreak\ {\footnotesize {72c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dcenter = REAL(center);@\\ \mbox{}\verb@if (LENGTH(center)) {@\\ \mbox{}\verb@ if (LENGTH(center) != iN * iJ)@\\ \mbox{}\verb@ error("incorrect dimensions of center");@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We put the code together in a dedicated \proglang{C} function \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap92}\raggedright\small \NWtarget{nuweb72d}{} $\langle\,${\itshape R slpmvnorm variables}\nobreak\ {\footnotesize {72d}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP ans;@\\ \mbox{}\verb@double *da, *db, *dC, *dW, *dans, dtol = REAL(tol)[0];@\\ \mbox{}\verb@double *dcenter;@\\ \mbox{}\verb@double mdtol = 1.0 - dtol;@\\ \mbox{}\verb@double d0, e0, emd0, f0, q0;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap93}\raggedright\small \NWtarget{nuweb73}{} $\langle\,${\itshape R lpmvnorm}\nobreak\ {\footnotesize {73}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_lpmvnorm(SEXP a, SEXP b, SEXP C, SEXP center, SEXP N, SEXP J, @\\ \mbox{}\verb@ SEXP W, SEXP M, SEXP tol, SEXP logLik, SEXP fast) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape R slpmvnorm variables}\nobreak\ {\footnotesize \NWlink{nuweb72d}{72d}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ double l0, lM, x0, intsum;@\\ \mbox{}\verb@ int p, len;@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Rboolean RlogLik = asLogical(logLik);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape pnorm}\nobreak\ {\footnotesize \NWlink{nuweb71a}{71a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape dimensions}\nobreak\ {\footnotesize \NWlink{nuweb71c}{71c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape W length}\nobreak\ {\footnotesize \NWlink{nuweb71b}{71b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init center}\nobreak\ {\footnotesize \NWlink{nuweb72c}{72c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ int start, j, k;@\\ \mbox{}\verb@ double tmp, Wtmp, e, d, f, emd, x, y[(iJ > 1 ? iJ - 1 : 1)];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape setup return object}\nobreak\ {\footnotesize \NWlink{nuweb72a}{72a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ q0 = qnorm(dtol, 0.0, 1.0, 1L, 0L);@\\ \mbox{}\verb@ l0 = log(dtol);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape univariate problem}\nobreak\ {\footnotesize \NWlink{nuweb72b}{72b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W == R_NilValue)@\\ \mbox{}\verb@ GetRNGstate();@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (int i = 0; i < iN; i++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ x0 = 0;@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape initialisation}\nobreak\ {\footnotesize \NWlink{nuweb67b}{67b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W != R_NilValue && pW == 0)@\\ \mbox{}\verb@ dW = REAL(W);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (int m = 0; m < iM; m++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init logLik loop}\nobreak\ {\footnotesize \NWlink{nuweb67c}{67c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape inner logLik loop}\nobreak\ {\footnotesize \NWlink{nuweb69b}{69b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape increment}\nobreak\ {\footnotesize \NWlink{nuweb69c}{69c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W != R_NilValue)@\\ \mbox{}\verb@ dW += iJ - 1;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape output}\nobreak\ {\footnotesize \NWlink{nuweb69d}{69d}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape move on}\nobreak\ {\footnotesize \NWlink{nuweb70a}{70a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W == R_NilValue)@\\ \mbox{}\verb@ PutRNGstate();@\\ \mbox{}\verb@@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb65}{65}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The \proglang{R} user interface consists of some checks and a call to \proglang{C}. Note that we need to specify both \code{w} and \code{M} in case we want a new set of weights for each observation. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap94}\raggedright\small \NWtarget{nuweb74a}{} $\langle\,${\itshape init random seed, reset on exit}\nobreak\ {\footnotesize {74a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### from stats:::simulate.lm@\\ \mbox{}\verb@if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) @\\ \mbox{}\verb@ runif(1)@\\ \mbox{}\verb@if (is.null(seed)) @\\ \mbox{}\verb@ RNGstate <- get(".Random.seed", envir = .GlobalEnv)@\\ \mbox{}\verb@else {@\\ \mbox{}\verb@ R.seed <- get(".Random.seed", envir = .GlobalEnv)@\\ \mbox{}\verb@ set.seed(seed)@\\ \mbox{}\verb@ RNGstate <- structure(seed, kind = as.list(RNGkind()))@\\ \mbox{}\verb@ on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap95}\raggedright\small \NWtarget{nuweb74b}{} $\langle\,${\itshape check and / or set integration weights}\nobreak\ {\footnotesize {74b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!is.null(w) && J > 1) {@\\ \mbox{}\verb@ stopifnot(is.matrix(w))@\\ \mbox{}\verb@ stopifnot(nrow(w) == J - 1)@\\ \mbox{}\verb@ if (is.null(M))@\\ \mbox{}\verb@ M <- ncol(w)@\\ \mbox{}\verb@ stopifnot(ncol(w) %in% c(M, M * N))@\\ \mbox{}\verb@ if (!is.double(w)) storage.mode(w) <- "double"@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ if (J > 1) {@\\ \mbox{}\verb@ if (is.null(M)) stop("either w or M must be specified")@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ M <- 1L@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Sometimes we want to evaluate the log-likelihood based on $\mL = \mC^{-1}$, the inverse Cholesky factor of the covariance matrix. In this case, we explicitly invert $\mL$ to give $\mC$ (both matrices are lower triangular, so this is fast). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap96}\raggedright\small \NWtarget{nuweb74c}{} $\langle\,${\itshape Cholesky of precision}\nobreak\ {\footnotesize {74c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@if (missing(chol)) chol <- solve(invchol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap97}\raggedright\small \NWtarget{nuweb75}{} $\langle\,${\itshape lpmvnorm}\nobreak\ {\footnotesize {75}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@lpmvnorm <- function(lower, upper, mean = 0, center = NULL, chol, invchol, @\\ \mbox{}\verb@ logLik = TRUE, M = NULL, w = NULL, seed = NULL, @\\ \mbox{}\verb@ tol = .Machine$double.eps, fast = FALSE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init random seed, reset on exit}\nobreak\ {\footnotesize \NWlink{nuweb74a}{74a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape Cholesky of precision}\nobreak\ {\footnotesize \NWlink{nuweb74c}{74c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape input checks}\nobreak\ {\footnotesize \NWlink{nuweb66}{66}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape standardise}\nobreak\ {\footnotesize \NWlink{nuweb67a}{67a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape check and / or set integration weights}\nobreak\ {\footnotesize \NWlink{nuweb74b}{74b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_lpmvnorm, ac, bc, uC, as.double(center), @\\ \mbox{}\verb@ as.integer(N), as.integer(J), w, as.integer(M), as.double(tol), @\\ \mbox{}\verb@ as.logical(logLik), as.logical(fast));@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Coming back to our simple example, we get (with $25000$ simple Monte-Carlo iterations) <>= phat exp(lpmvnorm(a, b, chol = lx, M = 25000, logLik = FALSE, fast = TRUE)) exp(lpmvnorm(a, b, chol = lx, M = 25000, logLik = FALSE, fast = FALSE)) @ Next we generate some data and compare our implementation to \code{pmvnorm} using quasi-Monte-Carlo integration. The \code{pmvnorm} function uses randomised Korobov rules. The experiment here applies generalised Halton sequences. Plain Monte-Carlo (\code{w = NULL}) will also work but produces more variable results. Results will depend a lot on appropriate choices and it is the user's responsibility to make sure things work as intended. If you are unsure, you should use \code{pmvnorm} which provides a well-tested configuration. <>= ) M <- 10000L if (require("qrng", quietly = TRUE)) { ### quasi-Monte-Carlo W <- t(ghalton(M, d = J - 1)) } else { ### Monte-Carlo W <- matrix(runif(M * (J - 1)), nrow = J - 1) } ### Genz & Bretz, 2002, without early stopping (really?) pGB <- lpmvnormR(a, b, chol = lx, logLik = FALSE, algorithm = GenzBretz(maxpts = M, abseps = 0, releps = 0)) ### Genz 1992 with quasi-Monte-Carlo, fast pnorm pGqf <- exp(lpmvnorm(a, b, chol = lx, w = W, M = M, logLik = FALSE, fast = TRUE)) ### Genz 1992, original Monte-Carlo, fast pnorm pGf <- exp(lpmvnorm(a, b, chol = lx, w = NULL, M = M, logLik = FALSE, fast = TRUE)) ### Genz 1992 with quasi-Monte-Carlo, R::pnorm pGqs <- exp(lpmvnorm(a, b, chol = lx, w = W, M = M, logLik = FALSE, fast = FALSE)) ### Genz 1992, original Monte-Carlo, R::pnorm pGs <- exp(lpmvnorm(a, b, chol = lx, w = NULL, M = M, logLik = FALSE, fast = FALSE)) cbind(pGB, pGqf, pGf, pGqs, pGs) @ The three versions agree nicely. We now check if the code also works for univariate problems <>= ### test univariate problem ### call pmvnorm pGB <- lpmvnormR(a[1,,drop = FALSE], b[1,,drop = FALSE], chol = lx[,1], logLik = FALSE, algorithm = GenzBretz(maxpts = M, abseps = 0, releps = 0)) ### call lpmvnorm pGq <- exp(lpmvnorm(a[1,,drop = FALSE], b[1,,drop = FALSE], chol = lx[,1], logLik = FALSE)) ### ground truth ptr <- pnorm(b[1,] / c(unclass(lx[,1]))) - pnorm(a[1,] / c(unclass(lx[,1]))) cbind(c(ptr), pGB, pGq) @ Because the default \code{fast = FALSE} was used here, all results are identical. \section{Score Function} In addition to the log-likelihood, we would also like to have access to the scores with respect to $\mC_i$. Because every element of $\mC_i$ only enters once, the chain rule rules, so to speak. We need the derivatives of $d$, $e$, $y$, and $f$ with respect to the $c$ parameters \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap98}\raggedright\small \NWtarget{nuweb77a}{} $\langle\,${\itshape chol scores}\nobreak\ {\footnotesize {77a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@double dp_c[Jp], ep_c[Jp], fp_c[Jp], yp_c[(iJ > 1 ? iJ - 1 : 1) * Jp];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb77e}{77e}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and the derivates with respect to the mean \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap99}\raggedright\small \NWtarget{nuweb77b}{} $\langle\,${\itshape mean scores}\nobreak\ {\footnotesize {77b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@double dp_m[Jp], ep_m[Jp], fp_m[Jp], yp_m[(iJ > 1 ? iJ - 1 : 1) * Jp];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb77e}{77e}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and the derivates with respect to lower (\code{a}) \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap100}\raggedright\small \NWtarget{nuweb77c}{} $\langle\,${\itshape lower scores}\nobreak\ {\footnotesize {77c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@double dp_l[Jp], ep_l[Jp], fp_l[Jp], yp_l[(iJ > 1 ? iJ - 1 : 1) * Jp];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb77e}{77e}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and the derivates with respect to upper (\code{b}) \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap101}\raggedright\small \NWtarget{nuweb77d}{} $\langle\,${\itshape upper scores}\nobreak\ {\footnotesize {77d}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@double dp_u[Jp], ep_u[Jp], fp_u[Jp], yp_u[(iJ > 1 ? iJ - 1 : 1) * Jp];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb77e}{77e}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and we start allocating the necessary memory. The output object contains the likelihood contributions (first row), the scores with respect to the mean (next $\J$ rows), with respect to the lower integration limits (next $\J$ rows), with respect to the upper integration limits (next $\J$ rows) and finally with respect to the off-diagonal elements of the Cholesky factor (last $\J (\J - 1) / 2$ rows). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap102}\raggedright\small \NWtarget{nuweb77e}{} $\langle\,${\itshape score output object}\nobreak\ {\footnotesize {77e}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@int Jp = iJ * (iJ + 1) / 2;@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape chol scores}\nobreak\ {\footnotesize \NWlink{nuweb77a}{77a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mean scores}\nobreak\ {\footnotesize \NWlink{nuweb77b}{77b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lower scores}\nobreak\ {\footnotesize \NWlink{nuweb77c}{77c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape upper scores}\nobreak\ {\footnotesize \NWlink{nuweb77d}{77d}}$\,\rangle$}\verb@@\\ \mbox{}\verb@double dtmp, etmp, Wtmp, ytmp, xx;@\\ \mbox{}\verb@@\\ \mbox{}\verb@PROTECT(ans = allocMatrix(REALSXP, Jp + 1 + 3 * iJ, iN));@\\ \mbox{}\verb@dans = REAL(ans);@\\ \mbox{}\verb@for (j = 0; j < LENGTH(ans); j++) dans[j] = 0.0;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb84}{84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} For each $i = 1, \dots, N$, do \begin{enumerate} \item Input $\mC_i$ (\code{chol}), $\avec_i$ (\code{lower}), $\bvec_i$ (\code{upper}), and control parameters $\alpha$, $\epsilon$, and $M_\text{max}$ (\code{M}). \item Standardise integration limits $a^{(i)}_j / c^{(i)}_{jj}$, $b^{(i)}_j / c^{(i)}_{jj}$, and rows $c^{(i)}_{j\jmath} / c^{(i)}_{jj}$ for $1 \le \jmath < j < \J$. Note: We later need derivatives wrt $c^{(i)}_{jj}$, so we compute derivates wrt $a^{(i)}_j$ and $b^{(i)}_j$ and post-differentiate later. \item Initialise $\text{intsum} = \text{varsum} = 0$, $M = 0$, $d_1 = \Phi\left(a^{(i)}_1\right)$, $e_1 = \Phi\left(b^{(i)}_1\right)$ and $f_1 = e_1 - d_1$. We start initialised the score wrt to $c^{(i)}_{11}$ (the parameter is non-existent here due to standardisation) \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap103}\raggedright\small \NWtarget{nuweb78a}{} $\langle\,${\itshape score c11}\nobreak\ {\footnotesize {78a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (LENGTH(center)) {@\\ \mbox{}\verb@ dp_c[0] = (R_FINITE(da[0]) ? dnorm(da[0], x0, 1.0, 0L) * (da[0] - x0 - dcenter[0]) : 0);@\\ \mbox{}\verb@ ep_c[0] = (R_FINITE(db[0]) ? dnorm(db[0], x0, 1.0, 0L) * (db[0] - x0 - dcenter[0]) : 0);@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ dp_c[0] = (R_FINITE(da[0]) ? dnorm(da[0], x0, 1.0, 0L) * (da[0] - x0) : 0);@\\ \mbox{}\verb@ ep_c[0] = (R_FINITE(db[0]) ? dnorm(db[0], x0, 1.0, 0L) * (db[0] - x0) : 0);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@fp_c[0] = ep_c[0] - dp_c[0];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb78c}{78c}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap104}\raggedright\small \NWtarget{nuweb78b}{} $\langle\,${\itshape score a, b}\nobreak\ {\footnotesize {78b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dp_m[0] = (R_FINITE(da[0]) ? dnorm(da[0], x0, 1.0, 0L) : 0);@\\ \mbox{}\verb@ep_m[0] = (R_FINITE(db[0]) ? dnorm(db[0], x0, 1.0, 0L) : 0);@\\ \mbox{}\verb@dp_l[0] = dp_m[0];@\\ \mbox{}\verb@ep_u[0] = ep_m[0];@\\ \mbox{}\verb@dp_u[0] = 0;@\\ \mbox{}\verb@ep_l[0] = 0;@\\ \mbox{}\verb@fp_m[0] = ep_m[0] - dp_m[0];@\\ \mbox{}\verb@fp_l[0] = -dp_m[0];@\\ \mbox{}\verb@fp_u[0] = ep_m[0];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb78c}{78c}\NWlink{nuweb84}{, 84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \item Repeat \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap105}\raggedright\small \NWtarget{nuweb78c}{} $\langle\,${\itshape init score loop}\nobreak\ {\footnotesize {78c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape init logLik loop}\nobreak\ {\footnotesize \NWlink{nuweb67c}{67c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape score c11}\nobreak\ {\footnotesize \NWlink{nuweb78a}{78a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape score a, b}\nobreak\ {\footnotesize \NWlink{nuweb78b}{78b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb84}{84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{enumerate} \item Generate uniform $w_1, \dots, w_{\J - 1} \in [0, 1]$. \item For $j = 2, \dots, J$ set \begin{eqnarray*} y_{j - 1} & = & \Phi^{-1}\left(d_{j - 1} + w_{j - 1} (e_{j - 1} - d_{j - 1})\right) \end{eqnarray*} We again either generate $w_{j - 1}$ on the fly or use pre-computed weights (\code{w}). We first compute the scores with respect to the already existing parameters. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap106}\raggedright\small \NWtarget{nuweb79a}{} $\langle\,${\itshape update yp for chol}\nobreak\ {\footnotesize {79a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@ytmp = exp(- dnorm(y[j - 1], 0.0, 1.0, 1L)); // = 1 / dnorm(y[j - 1], 0.0, 1.0, 0L)@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (k = 0; k < Jp; k++) yp_c[k * (iJ - 1) + (j - 1)] = 0.0;@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < (j + 1) * j / 2; idx++) {@\\ \mbox{}\verb@ yp_c[idx * (iJ - 1) + (j - 1)] = ytmp;@\\ \mbox{}\verb@ yp_c[idx * (iJ - 1) + (j - 1)] *= (dp_c[idx] + Wtmp * (ep_c[idx] - dp_c[idx]));@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap107}\raggedright\small \NWtarget{nuweb79b}{} $\langle\,${\itshape update yp for means, lower and upper}\nobreak\ {\footnotesize {79b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@for (k = 0; k < iJ; k++)@\\ \mbox{}\verb@ yp_m[k * (iJ - 1) + (j - 1)] = 0.0;@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j; idx++) {@\\ \mbox{}\verb@ yp_m[idx * (iJ - 1) + (j - 1)] = ytmp;@\\ \mbox{}\verb@ yp_m[idx * (iJ - 1) + (j - 1)] *= (dp_m[idx] + Wtmp * (ep_m[idx] - dp_m[idx]));@\\ \mbox{}\verb@}@\\ \mbox{}\verb@for (k = 0; k < iJ; k++)@\\ \mbox{}\verb@ yp_l[k * (iJ - 1) + (j - 1)] = 0.0;@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j; idx++) {@\\ \mbox{}\verb@ yp_l[idx * (iJ - 1) + (j - 1)] = ytmp;@\\ \mbox{}\verb@ yp_l[idx * (iJ - 1) + (j - 1)] *= (dp_l[idx] + Wtmp * (dp_u[idx] - dp_l[idx]));@\\ \mbox{}\verb@}@\\ \mbox{}\verb@for (k = 0; k < iJ; k++)@\\ \mbox{}\verb@ yp_u[k * (iJ - 1) + (j - 1)] = 0.0;@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j; idx++) {@\\ \mbox{}\verb@ yp_u[idx * (iJ - 1) + (j - 1)] = ytmp;@\\ \mbox{}\verb@ yp_u[idx * (iJ - 1) + (j - 1)] *= (ep_l[idx] + Wtmp * (ep_u[idx] - ep_l[idx]));@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{eqnarray*} x_{j - 1} & = & \sum_{\jmath = 1}^{j - 1} c^{(i)}_{j\jmath} y_j \end{eqnarray*} \begin{eqnarray*} d_j & = & \Phi\left(a^{(i)}_j - x_{j - 1}\right) \\ e_j & = & \Phi\left(b^{(i)}_j - x_{j - 1}\right) \end{eqnarray*} \begin{eqnarray*} f_j & = & (e_j - d_j) f_{j - 1}. \end{eqnarray*} The scores with respect to $c^{(i)}_{j\jmath}, \jmath = 1, \dots, j - 1$ are \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap108}\raggedright\small \NWtarget{nuweb80a}{} $\langle\,${\itshape score wrt new chol off-diagonals}\nobreak\ {\footnotesize {80a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dtmp = dnorm(da[j], x, 1.0, 0L);@\\ \mbox{}\verb@etmp = dnorm(db[j], x, 1.0, 0L);@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (k = 0; k < j; k++) {@\\ \mbox{}\verb@ idx = start + j + k;@\\ \mbox{}\verb@ if (LENGTH(center)) { @\\ \mbox{}\verb@ dp_c[idx] = dtmp * (-1.0) * (y[k] - dcenter[k]);@\\ \mbox{}\verb@ ep_c[idx] = etmp * (-1.0) * (y[k] - dcenter[k]);@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ dp_c[idx] = dtmp * (-1.0) * y[k];@\\ \mbox{}\verb@ ep_c[idx] = etmp * (-1.0) * y[k];@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ fp_c[idx] = (ep_c[idx] - dp_c[idx]) * f;@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and the score with respect to (the here non-existing) $c^{(i)}_{jj}$ is \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap109}\raggedright\small \NWtarget{nuweb80b}{} $\langle\,${\itshape score wrt new chol diagonal}\nobreak\ {\footnotesize {80b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@idx = (j + 1) * (j + 2) / 2 - 1;@\\ \mbox{}\verb@if (LENGTH(center)) {@\\ \mbox{}\verb@ dp_c[idx] = (R_FINITE(da[j]) ? dtmp * (da[j] - x - dcenter[j]) : 0);@\\ \mbox{}\verb@ ep_c[idx] = (R_FINITE(db[j]) ? etmp * (db[j] - x - dcenter[j]) : 0);@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ dp_c[idx] = (R_FINITE(da[j]) ? dtmp * (da[j] - x) : 0);@\\ \mbox{}\verb@ ep_c[idx] = (R_FINITE(db[j]) ? etmp * (db[j] - x) : 0);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@fp_c[idx] = (ep_c[idx] - dp_c[idx]) * f;@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap110}\raggedright\small \NWtarget{nuweb81a}{} $\langle\,${\itshape new score means, lower and upper}\nobreak\ {\footnotesize {81a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dp_m[j] = (R_FINITE(da[j]) ? dtmp : 0);@\\ \mbox{}\verb@ep_m[j] = (R_FINITE(db[j]) ? etmp : 0);@\\ \mbox{}\verb@dp_l[j] = dp_m[j];@\\ \mbox{}\verb@ep_u[j] = ep_m[j];@\\ \mbox{}\verb@dp_u[j] = 0;@\\ \mbox{}\verb@ep_l[j] = 0;@\\ \mbox{}\verb@fp_l[j] = - dp_m[j] * f;@\\ \mbox{}\verb@fp_u[j] = ep_m[j] * f;@\\ \mbox{}\verb@fp_m[j] = fp_u[j] + fp_l[j];@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We next update scores for parameters introduced for smaller $j$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap111}\raggedright\small \NWtarget{nuweb81b}{} $\langle\,${\itshape update score for chol}\nobreak\ {\footnotesize {81b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j * (j + 1) / 2; idx++) {@\\ \mbox{}\verb@ xx = 0.0;@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ xx += dC[start + k] * yp_c[idx * (iJ - 1) + k];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dp_c[idx] = dtmp * (-1.0) * xx;@\\ \mbox{}\verb@ ep_c[idx] = etmp * (-1.0) * xx;@\\ \mbox{}\verb@ fp_c[idx] = (ep_c[idx] - dp_c[idx]) * f + emd * fp_c[idx];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap112}\raggedright\small \NWtarget{nuweb82a}{} $\langle\,${\itshape update score means, lower and upper}\nobreak\ {\footnotesize {82a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j; idx++) {@\\ \mbox{}\verb@ xx = 0.0;@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ xx += dC[start + k] * yp_m[idx * (iJ - 1) + k];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dp_m[idx] = dtmp * (-1.0) * xx;@\\ \mbox{}\verb@ ep_m[idx] = etmp * (-1.0) * xx;@\\ \mbox{}\verb@ fp_m[idx] = (ep_m[idx] - dp_m[idx]) * f + emd * fp_m[idx];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j; idx++) {@\\ \mbox{}\verb@ xx = 0.0;@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ xx += dC[start + k] * yp_l[idx * (iJ - 1) + k];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ dp_l[idx] = dtmp * (-1.0) * xx;@\\ \mbox{}\verb@ dp_u[idx] = etmp * (-1.0) * xx;@\\ \mbox{}\verb@ fp_l[idx] = (dp_u[idx] - dp_l[idx]) * f + emd * fp_l[idx];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@for (idx = 0; idx < j; idx++) {@\\ \mbox{}\verb@ xx = 0.0;@\\ \mbox{}\verb@ for (k = 0; k < j; k++)@\\ \mbox{}\verb@ xx += dC[start + k] * yp_u[idx * (iJ - 1) + k];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ep_l[idx] = dtmp * (-1.0) * xx;@\\ \mbox{}\verb@ ep_u[idx] = etmp * (-1.0) * xx;@\\ \mbox{}\verb@ fp_u[idx] = (ep_u[idx] - ep_l[idx]) * f + emd * fp_u[idx];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb82b}{82b}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We put everything together in a loop starting with the second dimension \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap113}\raggedright\small \NWtarget{nuweb82b}{} $\langle\,${\itshape inner score loop}\nobreak\ {\footnotesize {82b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@for (j = 1; j < iJ; j++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape compute y}\nobreak\ {\footnotesize \NWlink{nuweb68a}{68a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape compute x}\nobreak\ {\footnotesize \NWlink{nuweb68b}{68b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update d, e}\nobreak\ {\footnotesize \NWlink{nuweb68c}{68c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update yp for chol}\nobreak\ {\footnotesize \NWlink{nuweb79a}{79a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update yp for means, lower and upper}\nobreak\ {\footnotesize \NWlink{nuweb79b}{79b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape score wrt new chol off-diagonals}\nobreak\ {\footnotesize \NWlink{nuweb80a}{80a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape score wrt new chol diagonal}\nobreak\ {\footnotesize \NWlink{nuweb80b}{80b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape new score means, lower and upper}\nobreak\ {\footnotesize \NWlink{nuweb81a}{81a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update score for chol}\nobreak\ {\footnotesize \NWlink{nuweb81b}{81b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update score means, lower and upper}\nobreak\ {\footnotesize \NWlink{nuweb82a}{82a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape update f}\nobreak\ {\footnotesize \NWlink{nuweb69a}{69a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb84}{84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \item Set $\text{intsum} = \text{intsum} + f_\J$, $\text{varsum} = \text{varsum} + f^2_\J$, $M = M + 1$, and $\text{error} = \sqrt{(\text{varsum}/M - (\text{intsum}/M)^2) / M}$. We refrain from early stopping and error estimation. \item[Until] $\text{error} < \epsilon$ or $M = M_\text{max}$ \end{enumerate} \item Output $\hat{p}_i = \text{intsum} / M$. We return $\log{\hat{p}_i}$ for each $i$, or we immediately sum-up over $i$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap114}\raggedright\small \NWtarget{nuweb83a}{} $\langle\,${\itshape score output}\nobreak\ {\footnotesize {83a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@dans[0] += f;@\\ \mbox{}\verb@for (j = 0; j < Jp; j++)@\\ \mbox{}\verb@ dans[j + 1] += fp_c[j];@\\ \mbox{}\verb@for (j = 0; j < iJ; j++) {@\\ \mbox{}\verb@ idx = Jp + j + 1;@\\ \mbox{}\verb@ dans[idx] += fp_m[j];@\\ \mbox{}\verb@ dans[idx + iJ] += fp_l[j];@\\ \mbox{}\verb@ dans[idx + 2 * iJ] += fp_u[j];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb84}{84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \end{enumerate} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap115}\raggedright\small \NWtarget{nuweb83b}{} $\langle\,${\itshape init dans}\nobreak\ {\footnotesize {83b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (iM == 0) {@\\ \mbox{}\verb@ dans[0] = intsum;@\\ \mbox{}\verb@ dans[1] = fp_c[0];@\\ \mbox{}\verb@ dans[2] = fp_m[0];@\\ \mbox{}\verb@ dans[3] = fp_l[0];@\\ \mbox{}\verb@ dans[4] = fp_u[0];@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb84}{84}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We put everything together in \proglang{C} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap116}\raggedright\small \NWtarget{nuweb84}{} $\langle\,${\itshape R slpmvnorm}\nobreak\ {\footnotesize {84}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@SEXP R_slpmvnorm(SEXP a, SEXP b, SEXP C, SEXP center, SEXP N, SEXP J, SEXP W, @\\ \mbox{}\verb@ SEXP M, SEXP tol, SEXP fast) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape R slpmvnorm variables}\nobreak\ {\footnotesize \NWlink{nuweb72d}{72d}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ double intsum;@\\ \mbox{}\verb@ int p, idx;@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape dimensions}\nobreak\ {\footnotesize \NWlink{nuweb71c}{71c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape pnorm}\nobreak\ {\footnotesize \NWlink{nuweb71a}{71a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape W length}\nobreak\ {\footnotesize \NWlink{nuweb71b}{71b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init center}\nobreak\ {\footnotesize \NWlink{nuweb72c}{72c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ int start, j, k;@\\ \mbox{}\verb@ double tmp, e, d, f, emd, x, x0, y[(iJ > 1 ? iJ - 1 : 1)];@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape score output object}\nobreak\ {\footnotesize \NWlink{nuweb77e}{77e}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ q0 = qnorm(dtol, 0.0, 1.0, 1L, 0L);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ /* univariate problem */@\\ \mbox{}\verb@ if (iJ == 1) iM = 0; @\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W == R_NilValue)@\\ \mbox{}\verb@ GetRNGstate();@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (int i = 0; i < iN; i++) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape initialisation}\nobreak\ {\footnotesize \NWlink{nuweb67b}{67b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape score c11}\nobreak\ {\footnotesize \NWlink{nuweb78a}{78a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape score a, b}\nobreak\ {\footnotesize \NWlink{nuweb78b}{78b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init dans}\nobreak\ {\footnotesize \NWlink{nuweb83b}{83b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W != R_NilValue && pW == 0)@\\ \mbox{}\verb@ dW = REAL(W);@\\ \mbox{}\verb@@\\ \mbox{}\verb@ for (int m = 0; m < iM; m++) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init score loop}\nobreak\ {\footnotesize \NWlink{nuweb78c}{78c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape inner score loop}\nobreak\ {\footnotesize \NWlink{nuweb82b}{82b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape score output}\nobreak\ {\footnotesize \NWlink{nuweb83a}{83a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ if (W != R_NilValue)@\\ \mbox{}\verb@ dW += iJ - 1;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape move on}\nobreak\ {\footnotesize \NWlink{nuweb70a}{70a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ dans += Jp + 1 + 3 * iJ;@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (W == R_NilValue)@\\ \mbox{}\verb@ PutRNGstate();@\\ \mbox{}\verb@@\\ \mbox{}\verb@ UNPROTECT(1);@\\ \mbox{}\verb@ return(ans);@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb65}{65}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The \proglang{R} code is now essentially identical to \code{lpmvnorm}, however, we need to undo the effect of standardisation once the scores have been computed \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap117}\raggedright\small \NWtarget{nuweb85a}{} $\langle\,${\itshape post differentiate mean score}\nobreak\ {\footnotesize {85a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@Jp <- J * (J + 1) / 2;@\\ \mbox{}\verb@smean <- - ret[Jp + 1:J, , drop = FALSE]@\\ \mbox{}\verb@if (attr(chol, "diag"))@\\ \mbox{}\verb@ smean <- smean / c(dchol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb87}{87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap118}\raggedright\small \NWtarget{nuweb85b}{} $\langle\,${\itshape post differentiate lower score}\nobreak\ {\footnotesize {85b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@slower <- ret[Jp + J + 1:J, , drop = FALSE]@\\ \mbox{}\verb@if (attr(chol, "diag"))@\\ \mbox{}\verb@ slower <- slower / c(dchol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb87}{87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap119}\raggedright\small \NWtarget{nuweb85c}{} $\langle\,${\itshape post differentiate upper score}\nobreak\ {\footnotesize {85c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@supper <- ret[Jp + 2 * J + 1:J, , drop = FALSE]@\\ \mbox{}\verb@if (attr(chol, "diag"))@\\ \mbox{}\verb@ supper <- supper / c(dchol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb87}{87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap120}\raggedright\small \NWtarget{nuweb85d}{} $\langle\,${\itshape post differentiate chol score}\nobreak\ {\footnotesize {85d}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (J == 1) {@\\ \mbox{}\verb@ idx <- 1L@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ idx <- cumsum(c(1, 2:J))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@if (attr(chol, "diag")) {@\\ \mbox{}\verb@ ret <- ret / c(dchol[rep(1:J, 1:J),]) ### because 1 / dchol already there@\\ \mbox{}\verb@ ret[idx,] <- -ret[idx,]@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb87}{87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We sometimes parameterise models in terms of $\mL = \mC^{-1}$, the Cholesky factor of the precision matrix. The log-likelihood operates on $\mC$, so we need to post-differentiate the score function. We have \begin{eqnarray*} \mA = \frac{\partial \mL^{-1}}{\partial \mL} = - \mL^{-\top} \otimes \mL^{-1} \end{eqnarray*} and computing $\svec \mA$ for a score vector $\svec$ with respect to $\mL$ can be implemented by the ``vec trick''~(Section~\ref{sec:vectrick}) \begin{eqnarray*} \svec \mA = \mL^{-\top} \mS \mL^{-\top} \end{eqnarray*} where $\svec = \text{vec}(\mS)$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap121}\raggedright\small \NWtarget{nuweb86a}{} $\langle\,${\itshape post differentiate invchol score}\nobreak\ {\footnotesize {86a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!missing(invchol)) {@\\ \mbox{}\verb@ ret <- ltMatrices(ret, diag = TRUE, byrow = TRUE,@\\ \mbox{}\verb@ names = dimnames(chol)[[2L]])@\\ \mbox{}\verb@ ### this means vectrick(chol, ret, chol)@\\ \mbox{}\verb@ ret <- - unclass(vectrick(chol, ret))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb87}{87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} If the diagonal elements are constants, we set them to zero. The function always returns an object of class \code{ltMatrices} with explicit diagonal elements (use \code{Lower\_tri(, diag = FALSE)} to extract the lower triangular elements such that the scores match the input) \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap122}\raggedright\small \NWtarget{nuweb86b}{} $\langle\,${\itshape post process score}\nobreak\ {\footnotesize {86b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!attr(chol, "diag"))@\\ \mbox{}\verb@ ### remove scores for constant diagonal elements@\\ \mbox{}\verb@ ret[idx,] <- 0@\\ \mbox{}\verb@ret <- ltMatrices(ret, diag = TRUE, byrow = TRUE, @\\ \mbox{}\verb@ names = dimnames(chol)[[2L]])@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb87}{87}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can now finally put everything together in a single score function. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap123}\raggedright\small \NWtarget{nuweb87}{} $\langle\,${\itshape slpmvnorm}\nobreak\ {\footnotesize {87}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@slpmvnorm <- function(lower, upper, mean = 0, center = NULL, @\\ \mbox{}\verb@ chol, invchol, logLik = TRUE, M = NULL, @\\ \mbox{}\verb@ w = NULL, seed = NULL, tol = .Machine$double.eps, @\\ \mbox{}\verb@ fast = FALSE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape init random seed, reset on exit}\nobreak\ {\footnotesize \NWlink{nuweb74a}{74a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape Cholesky of precision}\nobreak\ {\footnotesize \NWlink{nuweb74c}{74c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape input checks}\nobreak\ {\footnotesize \NWlink{nuweb66}{66}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape standardise}\nobreak\ {\footnotesize \NWlink{nuweb67a}{67a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape check and / or set integration weights}\nobreak\ {\footnotesize \NWlink{nuweb74b}{74b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- .Call(mvtnorm_R_slpmvnorm, ac, bc, uC, as.double(center), as.integer(N), @\\ \mbox{}\verb@ as.integer(J), w, as.integer(M), as.double(tol), as.logical(fast));@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ll <- log(pmax(ret[1L,], tol)) - log(M)@\\ \mbox{}\verb@ intsum <- ret[1L,]@\\ \mbox{}\verb@ m <- matrix(intsum, nrow = nrow(ret) - 1, ncol = ncol(ret), byrow = TRUE)@\\ \mbox{}\verb@ ret <- ret[-1L,,drop = FALSE] / m ### NOTE: division by zero MAY happen,@\\ \mbox{}\verb@ ### catch outside@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape post differentiate mean score}\nobreak\ {\footnotesize \NWlink{nuweb85a}{85a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape post differentiate lower score}\nobreak\ {\footnotesize \NWlink{nuweb85b}{85b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape post differentiate upper score}\nobreak\ {\footnotesize \NWlink{nuweb85c}{85c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ret[1:Jp, , drop = FALSE]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape post differentiate chol score}\nobreak\ {\footnotesize \NWlink{nuweb85d}{85d}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape post differentiate invchol score}\nobreak\ {\footnotesize \NWlink{nuweb86a}{86a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape post process score}\nobreak\ {\footnotesize \NWlink{nuweb86b}{86b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = byrow_orig)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ rownames(smean) <- rownames(slower) <- @\\ \mbox{}\verb@ rownames(supper) <- dimnames(chol)[[2L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (logLik) {@\\ \mbox{}\verb@ ret <- list(logLik = ll, @\\ \mbox{}\verb@ mean = smean, @\\ \mbox{}\verb@ lower = slower,@\\ \mbox{}\verb@ upper = supper,@\\ \mbox{}\verb@ chol = ret)@\\ \mbox{}\verb@ if (!missing(invchol)) names(ret)[names(ret) == "chol"] <- "invchol"@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Let's look at an example, where we use \code{numDeriv::grad} to check the results (this functionality from package \pkg{numDeriv} was absolutely instrumental for this project) <>= J <- 5L N <- 4L S <- crossprod(matrix(runif(J^2), nrow = J)) prm <- t(chol(S))[lower.tri(S, diag = TRUE)] ### define C mC <- ltMatrices(matrix(prm, ncol = 1), diag = TRUE) a <- matrix(runif(N * J), nrow = J) - 2 b <- a + 4 a[2,] <- -Inf b[3,] <- Inf M <- 10000L W <- matrix(runif(M * (J - 1)), ncol = M) lli <- c(lpmvnorm(a, b, chol = mC, w = W, M = M, logLik = FALSE)) fC <- function(prm) { C <- ltMatrices(matrix(prm, ncol = 1), diag = TRUE) lpmvnorm(a, b, chol = C, w = W, M = M) } sC <- slpmvnorm(a, b, chol = mC, w = W, M = M) chk(lli, sC$logLik) if (require("numDeriv", quietly = TRUE)) chk(grad(fC, unclass(mC)), rowSums(unclass(sC$chol)), check.attributes = FALSE) @ We can do the same when $\mL$ (and not $\mC$) is given <>= mL <- solve(mC) lliL <- c(lpmvnorm(a, b, invchol = mL, w = W, M = M, logLik = FALSE)) chk(lli, lliL) fL <- function(prm) { L <- ltMatrices(matrix(prm, ncol = 1), diag = TRUE) lpmvnorm(a, b, invchol = L, w = W, M = M) } sL <- slpmvnorm(a, b, invchol = mL, w = W, M = M) chk(lliL, sL$logLik) if (require("numDeriv", quietly = TRUE)) chk(grad(fL, unclass(mL)), rowSums(unclass(sL$invchol)), check.attributes = FALSE) @ The score function also works for univariate problems <>= ptr <- pnorm(b[1,] / c(unclass(mC[,1]))) - pnorm(a[1,] / c(unclass(mC[,1]))) log(ptr) lpmvnorm(a[1,,drop = FALSE], b[1,,drop = FALSE], chol = mC[,1], logLik = FALSE) lapply(slpmvnorm(a[1,,drop = FALSE], b[1,,drop = FALSE], chol = mC[,1], logLik = TRUE), unclass) sd1 <- c(unclass(mC[,1])) (dnorm(b[1,] / sd1) * b[1,] - dnorm(a[1,] / sd1) * a[1,]) * (-1) / sd1^2 / ptr @ \chapter{Maximum-likelihood Example} \label{ML} <>= set.seed(110515) @ We now discuss how this infrastructure can be used to estimate the Cholesky factor of a multivariate normal in the presence of interval-censored observations. We first generate a covariance matrix $\Sigma = \mC \mC^\top$ and extract the Cholesky factor $\mC$ <>= J <- 4 R <- diag(J) R[1,2] <- R[2,1] <- .25 R[1,3] <- R[3,1] <- .5 R[2,4] <- R[4,2] <- .75 Sigma <- diag(sqrt(1:J / 2)) %*% R %*% diag(sqrt(1:J / 2)) C <- t(chol(Sigma)) @ We now represent this matrix as \code{ltMatrices} object <>= prm <- C[lower.tri(C, diag = TRUE)] lt <- ltMatrices(matrix(prm, ncol = 1L), diag = TRUE, ### has diagonal elements byrow = FALSE) ### prm is column-major BYROW <- FALSE ### later checks lt <- ltMatrices(lt, byrow = BYROW) ### convert to row-major chk(C, as.array(lt)[,,1], check.attributes = FALSE) chk(Sigma, as.array(Tcrossprod(lt))[,,1], check.attributes = FALSE) @ We generate some data from $\ND_\J(\mathbf{0}_\J, \Sigma)$ by first sampling from $\rZ \sim \ND_\J(\mathbf{0}_\J, \mI_\J)$ and then computing $\rY = \mC \rZ + \muvec \sim \ND_\J(\muvec, \mC \mC^\top)$ <>= N <- 100L Z <- matrix(rnorm(N * J), nrow = J) Y <- Mult(lt, Z) + (mn <- 1:J) @ Before we add some interval-censoring to the data, let's estimate the Cholesky factor $\mC$ (here called \code{lt}) from the raw continuous data. The true mean $\muvec$ and the true covariance matrix $\Sigma$ can be estimated from the uncensored data via maximum likelihood as <>= rowMeans(Y) (Shat <- var(t(Y)) * (N - 1) / N) @ We first check if we can obtain the same results by numerial optimisation using \code{dmvnorm} and the scores \code{sldmvnorm}. The log-likelihood and the score function (for the centered means) in terms of $\mC$ are <>= Yc <- Y - rowMeans(Y) ll <- function(parm) { C <- ltMatrices(parm, diag = TRUE, byrow = BYROW) -ldmvnorm(obs = Yc, chol = C) } sc <- function(parm) { C <- ltMatrices(parm, diag = TRUE, byrow = BYROW) -rowSums(unclass(sldmvnorm(obs = Yc, chol = C)$chol)) } @ The diagonal elements of $\mC$ are positive, so we need box constraints <>= llim <- rep(-Inf, J * (J + 1) / 2) llim[which(rownames(unclass(lt)) %in% paste(1:J, 1:J, sep = "."))] <- 1e-4 @ The ML-estimate of $\mC \mC^\top$ is now used to obtain an estimate of $\mC$ and we check the score function for some random starting values <>= if (BYROW) { cML <- chol(Shat)[upper.tri(Shat, diag = TRUE)] } else { cML <- t(chol(Shat))[lower.tri(Shat, diag = TRUE)] } ll(cML) start <- runif(length(cML)) if (require("numDeriv", quietly = TRUE)) chk(grad(ll, start), sc(start), check.attributes = FALSE) @ Finally, we hand over to \code{optim} and compare the results of the analytically and numerically obtained ML estimates <>= op <- optim(start, fn = ll, gr = sc, method = "L-BFGS-B", lower = llim, control = list(trace = FALSE)) ## ML numerically ltMatrices(op$par, diag = TRUE, byrow = BYROW) ll(op$par) ## ML analytically t(chol(Shat)) ll(cML) ## true C matrix lt @ Under interval-censoring, the mean and $\mC$ are no longer orthogonal and there is no analytic solution to the ML estimation problem. So, we add some interval-censoring represented by \code{lwr} and \code{upr} and try to estimate the model parameters via \code{lpmvnorm} and corresponding scores \code{slpmvnorm}. <>= prb <- 1:9 / 10 sds <- sqrt(diag(Sigma)) ct <- sapply(1:J, function(j) qnorm(prb, mean = mn[j], sd = sds[j])) lwr <- upr <- Y for (j in 1:J) { f <- cut(Y[j,], breaks = c(-Inf, ct[,j], Inf)) lwr[j,] <- c(-Inf, ct[,j])[f] upr[j,] <- c(ct[,j], Inf)[f] } @ Let's do some sanity and performance checks first. For different values of $M$, we evaluate the log-likelihood using \code{pmvnorm} (called in \code{lpmvnormR}) and the simplified implementation (fast and slow). The comparison is a bit unfair, because we do not add the time needed to setup Halton sequences, but we would do this only once and use the stored values for repeated evaluations of a log-likelihood (because the optimiser expects a deterministic function to be optimised) <>= M <- floor(exp(0:25/10) * 1000) lGB <- sapply(M, function(m) { st <- system.time(ret <- lpmvnormR(lwr, upr, mean = mn, chol = lt, algorithm = GenzBretz(maxpts = m, abseps = 0, releps = 0))) return(c(st["user.self"], ll = ret)) }) lH <- sapply(M, function(m) { W <- NULL if (require("qrng", quietly = TRUE)) W <- t(ghalton(m, d = J - 1)) st <- system.time(ret <- lpmvnorm(lwr, upr, mean = mn, chol = lt, w = W, M = m)) return(c(st["user.self"], ll = ret)) }) lHf <- sapply(M, function(m) { W <- NULL if (require("qrng", quietly = TRUE)) W <- t(ghalton(m, d = J - 1)) st <- system.time(ret <- lpmvnorm(lwr, upr, mean = mn, chol = lt, w = W, M = m, fast = TRUE)) return(c(st["user.self"], ll = ret)) }) @ The evaluated log-likelihoods and corresponding timings are given in Figure~\ref{lleval}. It seems that for $M \ge 3000$, results are reasonably stable. \begin{figure} \begin{center} <>= ### use pre-computed data, otherwise CRAN complains. M <- c(1000, 1105, 1221, 1349, 1491, 1648, 1822, 2013, 2225, 2459, 2718, 3004, 3320, 3669, 4055, 4481, 4953, 5473, 6049, 6685, 7389, 8166, 9025, 9974, 11023, 12182) lGB <- matrix(c(0.054, -880.492612, 0.054, -880.492426, 0.054, -880.492996, 0.054, -880.492629, 0.054, -880.490231, 0.055, -880.492784, 0.054, -880.492632, 0.055, -880.489297, 0.054, -880.492516, 0.054, -880.491339, 0.054, -880.492091, 0.11, -880.491601, 0.114, -880.493553, 0.111, -880.49125, 0.108, -880.492151, 0.108, -880.492275, 0.109, -880.491879, 0.109, -880.492008, 0.192, -880.492132, 0.195, -880.491839, 0.194, -880.492139, 0.194, -880.491042, 0.198, -880.492198, 0.328, -880.4916, 0.323, -880.491941, 0.323, -880.491698), nrow = 2) rownames(lGB) <- c("user.self", "ll") lH <- matrix(c(0.023, -880.480296, 0.027, -880.496166, 0.029, -880.488683, 0.032, -880.496171, 0.035, -880.485597, 0.039, -880.491333, 0.043, -880.494557, 0.048, -880.495429, 0.053, -880.494391, 0.06, -880.485546, 0.064, -880.491455, 0.071, -880.494138, 0.079, -880.491619, 0.087, -880.493393, 0.095, -880.492541, 0.106, -880.491649, 0.118, -880.492508, 0.129, -880.492558, 0.141, -880.492509, 0.157, -880.490448, 0.173, -880.491686, 0.193, -880.491178, 0.211, -880.492286, 0.233, -880.491511, 0.258, -880.49153, 0.287, -880.491929), nrow = 2) rownames(lH) <- c("user.self", "ll") lHf <- matrix(c(0.018, -880.487067, 0.019, -880.488639, 0.022, -880.488569, 0.024, -880.49393, 0.026, -880.486029, 0.029, -880.491563, 0.033, -880.499415, 0.035, -880.494457, 0.038, -880.493954, 0.043, -880.493648, 0.047, -880.492955, 0.052, -880.494667, 0.059, -880.493745, 0.065, -880.494195, 0.07, -880.49333, 0.078, -880.491451, 0.086, -880.492379, 0.094, -880.490392, 0.106, -880.491061, 0.115, -880.491577, 0.129, -880.492523, 0.142, -880.491027, 0.158, -880.492086, 0.171, -880.492069, 0.189, -880.492251, 0.208, -880.492347), nrow = 2) rownames(lHf) <- c("user.self", "ll") @ <>= layout(matrix(1:2, nrow = 1)) plot(M, lGB["ll",], ylim = range(c(lGB["ll",], lH["ll",], lHf["ll",])), ylab = "Log-likelihood") points(M, lH["ll",], pch = 4) points(M, lHf["ll",], pch = 5) plot(M, lGB["user.self",], ylim = c(0, max(lGB["user.self",])), ylab = "Time (in sec)") points(M, lH["user.self",], pch = 4) points(M, lHf["user.self",], pch = 5) legend("bottomright", legend = c("pmvnorm", "lpmvnorm", "lpmvnorm(fast)"), pch = c(1, 4, 5), bty = "n") @ \caption{Evaluated log-likelihoods (left) and timings (right). \label{lleval}} \end{center} \end{figure} We now define the log-likelihood function. It is important to use weights via the \code{w} argument (or to set the \code{seed}) such that only the candidate parameters \code{parm} change with repeated calls to \code{ll}. We use an extremely low number of integration points \code{M}, let's see if this still works out. <>= M <- 500 if (require("qrng", quietly = TRUE)) { ### quasi-Monte-Carlo W <- t(ghalton(M, d = J - 1)) } else { ### Monte-Carlo W <- matrix(runif(M * (J - 1)), nrow = J - 1) } ll <- function(parm, J) { m <- parm[1:J] ### mean parameters parm <- parm[-(1:J)] ### chol parameters C <- matrix(c(parm), ncol = 1L) C <- ltMatrices(C, diag = TRUE, byrow = BYROW) -lpmvnorm(lower = lwr, upper = upr, mean = m, chol = C, w = W, M = M, logLik = TRUE) } @ We can check the correctness of our log-likelihood function <>= prm <- c(mn, unclass(lt)) ll(prm, J = J) ### ATLAS gives -880.4908, M1mac gives -880.4911 round(lpmvnormR(lwr, upr, mean = mn, chol = lt, algorithm = GenzBretz(maxpts = M, abseps = 0, releps = 0)), 3) (llprm <- lpmvnorm(lwr, upr, mean = mn, chol = lt, w = W, M = M)) chk(llprm, sum(lpmvnorm(lwr, upr, mean = mn, chol = lt, w = W, M = M, logLik = FALSE))) @ Before we hand over to the optimiser, we define the score function with respect to $\muvec$ and $\mC$ <>= sc <- function(parm, J) { m <- parm[1:J] ### mean parameters parm <- parm[-(1:J)] ### chol parameters C <- matrix(c(parm), ncol = 1L) C <- ltMatrices(C, diag = TRUE, byrow = BYROW) ret <- slpmvnorm(lower = lwr, upper = upr, mean = m, chol = C, w = W, M = M, logLik = TRUE) return(-c(rowSums(ret$mean), rowSums(unclass(ret$chol)))) } @ and check the correctness numerically <>= if (require("numDeriv", quietly = TRUE)) chk(grad(ll, prm, J = J), sc(prm, J = J), check.attributes = FALSE) @ Finally, we can hand-over to \code{optim}. Because we need $\text{diag}(\mC) > 0$, we use box constraints and \code{method = "L-BFGS-B"}. We start with the estimates obtained from the original continuous data. <>= llim <- rep(-Inf, J + J * (J + 1) / 2) llim[J + which(rownames(unclass(lt)) %in% paste(1:J, 1:J, sep = "."))] <- 1e-4 if (BYROW) { start <- c(rowMeans(Y), chol(Shat)[upper.tri(Shat, diag = TRUE)]) } else { start <- c(rowMeans(Y), t(chol(Shat))[lower.tri(Shat, diag = TRUE)]) } ll(start, J = J) op <- optim(start, fn = ll, gr = sc, J = J, method = "L-BFGS-B", lower = llim, control = list(trace = FALSE)) op$value ## compare with ll(prm, J = J) @ We can now compare the true and estimated Cholesky factor $\mC$ of our covariance matrix $\mSigma = \mC \mC^\top$ <>= (C <- ltMatrices(matrix(op$par[-(1:J)], ncol = 1), diag = TRUE, byrow = BYROW)) lt @ and the estimated means <>= op$par[1:J] mn @ We can also compare the results on the scale of the covariance matrix <>= ### ATLAS print issues round(Tcrossprod(lt), 4) ### true Sigma Tcrossprod(C) ### interval-censored obs Shat ### "exact" obs @ This looks reasonably close. \textbf{Warning:} Do NOT assume the choices made here (especially \code{M} and \code{W}) to be universally applicable. Make sure to investigate the accuracy depending on these parameters of the log-likelihood and score function in your application. One could ask what this whole exercise was about statistically. We estimated a multivariate normal distribution from interval-censored data, so what? Maybe we were primarily interested in fitting a linear regression \begin{eqnarray*} \E(Y_1 \mid Y_j = y_j, j = 2, \dots, J) = \alpha + \sum_{j = 2}^J \beta_j y_j. \end{eqnarray*} Interval-censoring in the response could have been handled by some Tobit model, but what about interval-censoring in the explanatory variables? Based on the multivariate distribution just estimated, we can obtain the regression coefficients $\beta_j$ as <>= c(cond_mvnorm(chol = C, which_given = 2:J, given = diag(J - 1))$mean) @ Alternatively, we can compute these regressions from a permuted Cholesky factor (this goes into the ``simple'' conditional distribution in Section~\ref{sec:margcond}) <>= c(cond_mvnorm(chol = aperm(as.chol(C), perm = c(2:J, 1)), which_given = 1:(J - 1), given = diag(J - 1))$mean) @ or, as a third option, from the last row of the precision matrix of the permuted Cholesky factor <>= x <- as.array(chol2pre(aperm(as.chol(C), perm = c(2:J, 1))))[J,,1] c(-x[-J] / x[J]) @ In higher dimensions, the first option is to be preferred, because it only involves computing the Cholesky decomposition of a $(\J - 1) \times (\J - 1)$ matrix, whereas the latter two options are based on a decomposition of the full $\J \times \J$ covariance matrix. We can compare these estimated regression coefficients with those obtained from a linear model fitted to the exact observations <>= dY <- as.data.frame(t(Y)) colnames(dY) <- paste0("Y", 1:J) coef(m1 <- lm(Y1 ~ ., data = dY))[-1L] @ The estimates are quite close, but what about standard errors? Interval-censoring means loss of information, so we should see larger standard errors for the interval-censored data. Let's obtain the Hessian for all parameters first <>= H <- optim(op$par, fn = ll, gr = sc, J = J, method = "L-BFGS-B", lower = llim, hessian = TRUE, control = list(trace = FALSE))$hessian @ and next we sample from the distribution of the maximum-likelihood estimators <>= L <- try(t(chol(H))) ### some check on r-oldrel-macos-arm64 if (inherits(L, "try-error")) L <- t(chol(H + 1e-4 * diag(nrow(H)))) L <- ltMatrices(L[lower.tri(L, diag = TRUE)], diag = TRUE) Nsim <- 50000 Z <- matrix(rnorm(Nsim * nrow(H)), ncol = Nsim) rC <- solve(L, Z)[-(1:J),] + op$par[-(1:J)] ### remove mean parameters @ The standard error in this sample should be close to the ones obtained from the inverse Fisher information <>= c(sqrt(rowMeans((rC - rowMeans(rC))^2))) c(sqrt(diagonals(Crossprod(solve(L))))) @ We now coerse the matrix \code{rC} to an object of class \code{ltMatrices} <>= rC <- ltMatrices(rC, diag = TRUE) @ The object \code{rC} contains all sampled Cholesky factors of the covariance matrix. From each of these matrices, we compute the regression coefficient, giving us a sample we can use to compute standard errors from <>= rbeta <- cond_mvnorm(chol = rC, which_given = 2:J, given = diag(J - 1))$mean sqrt(rowMeans((rbeta - rowMeans(rbeta))^2)) @ which are, as expected, slightly different from the ones obtained from the more informative exact observations <>= sqrt(diag(vcov(m1)))[-1L] @ \chapter{Continuous-discrete Likelihoods} \label{cdl} We sometimes are faced with outcomes measured at different levels of precision. Some variables might have been observed very exactly, and therefore we might want to use the log-Lebesque density for defining the log-likelihood. Other variables might be available as relatively wide intervals only, and thus the log-likelihood is a log-probability. We can use the infrastructure developed so far to compute a joint likelihood. Let's assume we have are interested in the joint distribution of $(\rY_i, \rX_i)$ and we observed $\rY_i = \yvec_i$ (that is, exact observations of $\rY$) and $\avec_i < \rX_i \le \bvec_i$ (that is, interval-censored observations for $\rX_i$). We define the log-likelihood based on the joint normal distribution $(\rY_i, \rX_i) \sim \ND_J((\muvec_i, \etavec_i)^\top, \mC_i \mC_i^\top)$ as \begin{eqnarray*} \ell_i(\muvec_i, \etavec_i, \mC_i) = \ell_i(\muvec_i, \mC_{\rY,i}) + \log(\Prob(\avec_i < \rX_i \le \bvec_i \mid \mC_i, \muvec_i, \etavec_i, \rY_i = \yvec_i)). \end{eqnarray*} where $\mC_{\rY,i}$ is the upper part of $\mC_i$ corresponding to the marginal distribution of $\rY_i$. The conditional probability of $\rX$ given $\rY$ depends on all parameters, as explained in Section~\ref{sec:margcond}. The trick here is to decompose the joint likelihood into a product of the marginal Lebesque density of $\rY_i$ and the conditional probability of $\rX_i$ given $\rY_i = \yvec_i$. We first check the data \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap124}\raggedright\small \NWtarget{nuweb98}{} $\langle\,${\itshape dp input checks}\nobreak\ {\footnotesize {98}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@cJ <- nrow(obs)@\\ \mbox{}\verb@dJ <- nrow(lower)@\\ \mbox{}\verb@N <- ncol(obs)@\\ \mbox{}\verb@stopifnot(N == ncol(lower))@\\ \mbox{}\verb@stopifnot(N == ncol(upper))@\\ \mbox{}\verb@if (all(mean == 0)) {@\\ \mbox{}\verb@ cmean <- 0@\\ \mbox{}\verb@ dmean <- 0@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ if (!is.matrix(mean) || NCOL(mean) == 1L) @\\ \mbox{}\verb@ mean <- matrix(mean, nrow = cJ + dJ, ncol = N)@\\ \mbox{}\verb@ stopifnot(nrow(mean) == cJ + dJ)@\\ \mbox{}\verb@ stopifnot(ncol(mean) == N)@\\ \mbox{}\verb@ cmean <- mean[1:cJ,, drop = FALSE]@\\ \mbox{}\verb@ dmean <- mean[-(1:cJ),, drop = FALSE]@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb99}{99}\NWlink{nuweb101}{, 101}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can use \code{marg\_mvnorm} and \code{cond\_mvnorm} to compute the marginal and the conditional normal distributions and the joint log-likelihood is simply the sum of the two corresponding log-likelihoods. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap125}\raggedright\small \NWtarget{nuweb99}{} $\langle\,${\itshape ldpmvnorm}\nobreak\ {\footnotesize {99}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@ldpmvnorm <- function(obs, lower, upper, mean = 0, chol, invchol, @\\ \mbox{}\verb@ logLik = TRUE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (missing(obs) || is.null(obs))@\\ \mbox{}\verb@ return(lpmvnorm(lower = lower, upper = upper, mean = mean,@\\ \mbox{}\verb@ chol = chol, invchol = invchol, logLik = logLik, ...))@\\ \mbox{}\verb@ if (missing(lower) && missing(upper) || is.null(lower) && is.null(upper))@\\ \mbox{}\verb@ return(ldmvnorm(obs = obs, mean = mean,@\\ \mbox{}\verb@ chol = chol, invchol = invchol, logLik = logLik))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape dp input checks}\nobreak\ {\footnotesize \NWlink{nuweb98}{98}}$\,\rangle$}\verb@ @\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(invchol)) {@\\ \mbox{}\verb@ J <- dim(invchol)[2L]@\\ \mbox{}\verb@ stopifnot(cJ + dJ == J)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ md <- marg_mvnorm(invchol = invchol, which = 1:cJ)@\\ \mbox{}\verb@ ret <- ldmvnorm(obs = obs, mean = cmean, invchol = md$invchol, @\\ \mbox{}\verb@ logLik = logLik)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ cd <- cond_mvnorm(invchol = invchol, which_given = 1:cJ, @\\ \mbox{}\verb@ given = obs - cmean, center = TRUE)@\\ \mbox{}\verb@ ret <- ret + lpmvnorm(lower = lower, upper = upper, mean = dmean, @\\ \mbox{}\verb@ invchol = cd$invchol, center = cd$center, @\\ \mbox{}\verb@ logLik = logLik, ...)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ J <- dim(chol)[2L]@\\ \mbox{}\verb@ stopifnot(cJ + dJ == J)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ md <- marg_mvnorm(chol = chol, which = 1:cJ)@\\ \mbox{}\verb@ ret <- ldmvnorm(obs = obs, mean = cmean, chol = md$chol, logLik = logLik)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ cd <- cond_mvnorm(chol = chol, which_given = 1:cJ, @\\ \mbox{}\verb@ given = obs - cmean, center = TRUE)@\\ \mbox{}\verb@ ret <- ret + lpmvnorm(lower = lower, upper = upper, mean = dmean, @\\ \mbox{}\verb@ chol = cd$chol, center = cd$center, @\\ \mbox{}\verb@ logLik = logLik, ...)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The score function requires a little extra work. We start with the case when \code{invchol} is given \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap126}\raggedright\small \NWtarget{nuweb100}{} $\langle\,${\itshape sldpmvnorm invchol}\nobreak\ {\footnotesize {100}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@byrow_orig <- attr(invchol, "byrow")@\\ \mbox{}\verb@invchol <- ltMatrices(invchol, byrow = TRUE)@\\ \mbox{}\verb@@\\ \mbox{}\verb@J <- dim(invchol)[2L]@\\ \mbox{}\verb@stopifnot(cJ + dJ == J)@\\ \mbox{}\verb@@\\ \mbox{}\verb@md <- marg_mvnorm(invchol = invchol, which = 1:cJ)@\\ \mbox{}\verb@cs <- sldmvnorm(obs = obs, mean = cmean, invchol = md$invchol, logLik = logLik)@\\ \mbox{}\verb@@\\ \mbox{}\verb@obs_cmean <- obs - cmean@\\ \mbox{}\verb@cd <- cond_mvnorm(invchol = invchol, which_given = 1:cJ, @\\ \mbox{}\verb@ given = obs_cmean, center = TRUE)@\\ \mbox{}\verb@ds <- slpmvnorm(lower = lower, upper = upper, mean = dmean, @\\ \mbox{}\verb@ center = cd$center, invchol = cd$invchol, @\\ \mbox{}\verb@ logLik = logLik, ...)@\\ \mbox{}\verb@@\\ \mbox{}\verb@tmp0 <- solve(cd$invchol, ds$mean, transpose = TRUE)@\\ \mbox{}\verb@tmp <- - tmp0[rep(1:dJ, each = cJ),,drop = FALSE] * @\\ \mbox{}\verb@ obs_cmean[rep(1:cJ, dJ),,drop = FALSE]@\\ \mbox{}\verb@@\\ \mbox{}\verb@Jp <- nrow(unclass(invchol))@\\ \mbox{}\verb@diag <- attr(invchol, "diag")@\\ \mbox{}\verb@M <- as.array(ltMatrices(1:Jp, diag = diag, byrow = TRUE))[,,1]@\\ \mbox{}\verb@ret <- matrix(0, nrow = Jp, ncol = ncol(obs))@\\ \mbox{}\verb@M1 <- M[1:cJ, 1:cJ]@\\ \mbox{}\verb@idx <- t(M1)[upper.tri(M1, diag = diag)]@\\ \mbox{}\verb@ret[idx,] <- Lower_tri(cs$invchol, diag = diag)@\\ \mbox{}\verb@@\\ \mbox{}\verb@idx <- c(t(M[-(1:cJ), 1:cJ]))@\\ \mbox{}\verb@ret[idx,] <- tmp@\\ \mbox{}\verb@@\\ \mbox{}\verb@M3 <- M[-(1:cJ), -(1:cJ)]@\\ \mbox{}\verb@idx <- t(M3)[upper.tri(M3, diag = diag)]@\\ \mbox{}\verb@ret[idx,] <- Lower_tri(ds$invchol, diag = diag)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ret <- ltMatrices(ret, diag = diag, byrow = TRUE)@\\ \mbox{}\verb@if (!diag) diagonals(ret) <- 0@\\ \mbox{}\verb@ret <- ltMatrices(ret, byrow = byrow_orig)@\\ \mbox{}\verb@@\\ \mbox{}\verb@### post differentiate mean @\\ \mbox{}\verb@aL <- as.array(invchol)[-(1:cJ), 1:cJ,,drop = FALSE]@\\ \mbox{}\verb@lst <- tmp0[rep(1:dJ, cJ),,drop = FALSE]@\\ \mbox{}\verb@if (dim(aL)[3] == 1)@\\ \mbox{}\verb@ aL <- aL[,,rep(1, ncol(lst)), drop = FALSE]@\\ \mbox{}\verb@dim <- dim(aL)@\\ \mbox{}\verb@dobs <- -margin.table(aL * array(lst, dim = dim), 2:3)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ret <- c(list(invchol = ret, obs = cs$obs + dobs), @\\ \mbox{}\verb@ ds[c("lower", "upper")])@\\ \mbox{}\verb@if (logLik) ret$logLik <- cs$logLik + ds$logLik@\\ \mbox{}\verb@ret$mean <- rbind(-ret$obs, ds$mean)@\\ \mbox{}\verb@return(ret)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb101}{101}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} For \code{chol}, we compute the above code for its inverse and post-differentiate using the vec-trick \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap127}\raggedright\small \NWtarget{nuweb101}{} $\langle\,${\itshape sldpmvnorm}\nobreak\ {\footnotesize {101}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@sldpmvnorm <- function(obs, lower, upper, mean = 0, chol, invchol, @\\ \mbox{}\verb@ logLik = TRUE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (missing(obs) || is.null(obs))@\\ \mbox{}\verb@ return(slpmvnorm(lower = lower, upper = upper, mean = mean,@\\ \mbox{}\verb@ chol = chol, invchol = invchol, logLik = logLik, ...))@\\ \mbox{}\verb@ if (missing(lower) && missing(upper) || is.null(lower) && is.null(upper))@\\ \mbox{}\verb@ return(sldmvnorm(obs = obs, mean = mean,@\\ \mbox{}\verb@ chol = chol, invchol = invchol, logLik = logLik))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape dp input checks}\nobreak\ {\footnotesize \NWlink{nuweb98}{98}}$\,\rangle$}\verb@ @\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(invchol)) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape sldpmvnorm invchol}\nobreak\ {\footnotesize \NWlink{nuweb100}{100}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@@\\ \mbox{}\verb@ invchol <- solve(chol)@\\ \mbox{}\verb@ ret <- sldpmvnorm(obs = obs, lower = lower, upper = upper, @\\ \mbox{}\verb@ mean = mean, invchol = invchol, logLik = logLik, ...)@\\ \mbox{}\verb@ ### this means: ret$chol <- - vectrick(invchol, ret$invchol, invchol)@\\ \mbox{}\verb@ ret$chol <- as.chol(- vectrick(invchol, ret$invchol))@\\ \mbox{}\verb@ ret$invchol <- NULL@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Let's assume we observed the first two dimensions exactly in our small example, and the remaining two dimensions are only known in intervals. The log-likelihood and score function for $\muvec$ and $\mC$ are <>= ic <- 1:2 ### position of continuous variables ll_cd <- function(parm, J) { m <- parm[1:J] ### mean parameters parm <- parm[-(1:J)] ### chol parameters C <- matrix(c(parm), ncol = 1L) C <- ltMatrices(C, diag = TRUE, byrow = BYROW) -ldpmvnorm(obs = Y[ic,], lower = lwr[-ic,], upper = upr[-ic,], mean = m, chol = C, w = W[-ic,,drop = FALSE], M = M) } sc_cd <- function(parm, J) { m <- parm[1:J] ### mean parameters parm <- parm[-(1:J)] ### chol parameters C <- matrix(c(parm), ncol = 1L) C <- ltMatrices(C, diag = TRUE, byrow = BYROW) ret <- sldpmvnorm(obs = Y[ic,], lower = lwr[-ic,], upper = upr[-ic,], mean = m, chol = C, w = W[-ic,,drop = FALSE], M = M) return(-c(rowSums(ret$mean), rowSums(Lower_tri(ret$chol, diag = TRUE)))) } @ and the score function seems to be correct <>= if (require("numDeriv", quietly = TRUE)) chk(grad(ll_cd, start, J = J), sc_cd(start, J = J), check.attributes = FALSE, tolerance = 1e-6) @ We can now jointly estimate all model parameters via <>= op <- optim(start, fn = ll_cd, gr = sc_cd, J = J, method = "L-BFGS-B", lower = llim, control = list(trace = FALSE)) ## estimated C ltMatrices(matrix(op$par[-(1:J)], ncol = 1), diag = TRUE, byrow = BYROW) ## compare with true C lt ## estimated means op$par[1:J] ## compare with true means mn @ The one restriction in both \code{ldpmvnorm} and \code{sldpmvnorm} is that the continuous variables $\rY$ are ranked before the discrete variables $\rX$ in the observation $(\rY_i, \rX_i)$, and thus also in $(\muvec, \etavec)$ and $\mC$ (the subscript $i$ is dropped from the parameters in the following paragraph to keep the notational complexity in check). While the means can be simply permuted, this is not the case for the Cholesky factor $\mC$ (see function \code{aperm} in Section~\ref{sec:conv}). Of course, we can simply permute $\hat{\mC}_i$, but we loose standard errors in this process. Alternatively, we can permute the order of variables in $\mC$ to our liking in the log-likelihood function (while keeping the original order of the observations and for the mean parameters) <>= ### discrete variables first perm <- c((1:J)[-ic], ic) ll_ap <- function(parm, J) { m <- parm[1:J] ### mean parameters; NOT permuted parm <- parm[-(1:J)] ### chol parameters C <- matrix(c(parm), ncol = 1L) C <- ltMatrices(C, diag = TRUE, byrow = BYROW) Ct <- aperm(as.chol(C), perm = perm) -ldpmvnorm(obs = Y[ic,], lower = lwr[-ic,], upper = upr[-ic,], mean = m, chol = Ct, w = W[-ic,,drop = FALSE], M = M) } @ Unfortunately, this distorts the score function and we need to ``de-permute'' the scores. We start with $\mSigma = \mC \mC^\top$, the Cholesky decomposition of a quadratic positive definite $\J \times \J$ covariance matrix. There are $\J \times (\J + 1) / 2$ parameters in the lower triagular part (including the diagonal) of $\mC$. Changing the order of the variables by a permutation $\pi$ with permutation matrix $\Pi$ gives a covariance $\Pi \mC \mC^\top \Pi^\top$. This is no longer a Cholesky decomposition, because $\Pi \mC$ is not lower triangular. The new decomposition is \begin{eqnarray*} \Pi \mC \mC^\top \Pi^\top = \tilde{\mC} \tilde{\mC}^\top \end{eqnarray*} ($\tilde{\mC}$ is what \code{aperm} computes). As $\mC$, the Cholesky factor $\tilde{\mC}$ is lower triangular with $\J \times (\J + 1) / 2$ parameters. We could write this operation as a function \begin{eqnarray*} & & f_3: \R^{\J \times (\J + 1) / 2} \rightarrow \R^{\J \times (\J + 1) / 2} \\ & & f_3(\mC) = \tilde{\mC}, \end{eqnarray*} where in fact $f_3 = $\code{aperm}, and we are interested in its gradient. Deriving the gradient of a Cholesky decomposition might seem hopeless (it certainly did, at least to me, for a very long time), but there is a trick. Let us define two other functions: \begin{eqnarray*} & & f_1: \R^{\J \times (\J + 1) / 2} \rightarrow \R^{\J \times \J} \\ & & f_1(\mC) = \Pi \mC \mC^\top \Pi^\top \\ & & f_2: \R^{\J \times (\J + 1) / 2} \rightarrow \R^{\J \times \J} \\ & & f_2(\tilde{\mC}) = \tilde{\mC} \tilde{\mC}^\top. \end{eqnarray*} Exploiting the chain rule for the composition $f_1 = f_2 \circ f_3$, we can write the gradient of $f_1$ as the product of the gradients of $f_2$ and $f_3$: \begin{eqnarray} \label{fm:chain} \frac{\partial f_1(\mC)}{\partial \mC} = \frac{\partial f_2(\tilde{\mC})}{\partial \tilde{\mC}} \frac{\partial f_3(\mC)}{\partial \mC}. \end{eqnarray} The last factor is what we want to compute. It turns out that it is simpler to compute the first two gradients first and, in a second step, to derive the last factor. In more detail \begin{eqnarray*} \frac{\partial f_1(\mC)}{\partial \mC} & = & \frac{\partial \Pi \mC \mC^\top \Pi^\top}{\partial \mC} \\ & = & \frac{\partial \Pi \mC \mC^\top \Pi^\top}{\partial \Pi \mC} \frac{\partial \Pi \mC}{\mC} \\ & = & \left( (\Pi \mC \otimes \mI_\J) + (\mI_\J \otimes \Pi \mC) \frac{\partial \mA^\top}{\partial \mA} \right) (\mI_\J \otimes \Pi). \end{eqnarray*} ($\mA$ is a quadratic matrix and the gradient of its transpose is a permutation matrix). This analytic expression only contains known elements and can be computed. The same applies to \begin{eqnarray*} \frac{\partial f_2(\tilde{\mC})}{\partial \tilde{\mC}} & = & \frac{\partial \tilde{\mC} \tilde{\mC}^\top \Pi}{\partial \tilde{\mC}} \\ &= & (\tilde{\mC} \otimes \mI_\J) + (\mI_\J \otimes \tilde{\mC}) \frac{\partial \mA^\top}{\partial \mA} \end{eqnarray*} Both expressions treat $\mC$ or $\tilde{\mC}$ as full matrices, we are only interested in the score contributions by the $\J \times (\J + 1) / 2$ lower triangular elements. Using sloppy notation, we collect the relevant columns in matrices $\mB_1 = \frac{\partial f_1(\mC)}{\partial \mC} \in \R^{\J^2 \times \J \times (\J + 1) / 2}$ and $\mB_2 = \frac{\partial f_2(\tilde{\mC})}{\partial \tilde{\mC}} \in \R^{\J^2 \times \J \times (\J + 1) / 2}$. For the last, unknown, factor, we write $\mB_3 = \frac{\partial f_3(\tilde{\mC})}{\partial \tilde{\mC}} \in \R^{\J \times (\J + 1) / 2 \times \J \times (\J + 1) / 2}$ and, with formula~(\ref{fm:chain}), $\mB_1 = \mB_2 \mB_3$. We can then solve for $\mB_3$ in the system $\mB_1^\top \mB_1 = \mB_1^\top \mB_2 \mB_3$. With \code{chol} $ = \mC$, \code{permuted\_chol} $ = \tilde{\mC}$, \code{perm} $ = \pi$ and score \code{score\_schol} of the log-likelihood $\ell(\tilde{\mC})$ with respect to the parameters in $\tilde{\mC}$, we can now implement this de-permutation of the scores. Starting with some basic sanity checks, we require lower triangular matrix objects as inputs, with diagonal elements, and check if the dimensions match \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap128}\raggedright\small \NWtarget{nuweb104a}{} $\langle\,${\itshape deperma input checks chol}\nobreak\ {\footnotesize {104a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(is.ltMatrices(chol)) ### NOTE: replace with is.chol@\\ \mbox{}\verb@byrow_orig <- attr(chol, "byrow")@\\ \mbox{}\verb@chol <- ltMatrices(chol, byrow = FALSE)@\\ \mbox{}\verb@stopifnot(is.ltMatrices(permuted_chol)) ### NOTE: replace with is.chol@\\ \mbox{}\verb@permuted_chol <- ltMatrices(permuted_chol, byrow = FALSE)@\\ \mbox{}\verb@stopifnot(max(abs(dim(chol) - dim(permuted_chol))) == 0)@\\ \mbox{}\verb@J <- dim(chol)[2L]@\\ \mbox{}\verb@stopifnot(attr(chol, "diag"))@\\ \mbox{}\verb@INVCHOL <- !missing(invchol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb106}{106}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Regarding \code{perm}, we check if this is an actual permutation \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap129}\raggedright\small \NWtarget{nuweb104b}{} $\langle\,${\itshape deperma input checks perm}\nobreak\ {\footnotesize {104b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (missing(perm)) return(score_schol)@\\ \mbox{}\verb@stopifnot(isTRUE(all.equal(sort(perm), 1:J)))@\\ \mbox{}\verb@if (max(abs(perm - 1:J)) == 0) return(score_schol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb106}{106}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The scores with respect to $\tilde{\mC}$ have been computed elsewhere, we just check the dimensions. In case we were given the scores with respect to $\mL$, we first compute the scores with respect to $\mC$ (as we were lazy and only derived the results for $\mC$). As in \code{standardize}, the argument \code{score\_schol} gives the score with respect to $\mC$ and it is the user's responsibility to provide this quantity (even when \code{invchol} is given). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap130}\raggedright\small \NWtarget{nuweb105a}{} $\langle\,${\itshape deperma input checks schol}\nobreak\ {\footnotesize {105a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (is.ltMatrices(score_schol)) { @\\ \mbox{}\verb@ byrow_orig_s <- attr(score_schol, "byrow")@\\ \mbox{}\verb@ score_schol <- ltMatrices(score_schol, byrow = FALSE)@\\ \mbox{}\verb@ ### don't do this here!@\\ \mbox{}\verb@ ### if (INVCHOL) score_schol <- -vectrick(permuted_invchol, score_schol)@\\ \mbox{}\verb@ score_schol <- unclass(score_schol) ### this preserves byrow@\\ \mbox{}\verb@}@\\ \mbox{}\verb@stopifnot(is.matrix(score_schol))@\\ \mbox{}\verb@N <- ncol(score_schol)@\\ \mbox{}\verb@stopifnot(J * (J + 1) / 2 == nrow(score_schol))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb106}{106}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We'll have to loop over $i = 1, \dots, N$ eventually and therefore coerce all objects to objects of class \code{array}, there is no need to worry about row or column storage order. We set-up indices matrices and the permutation matrix $\Pi$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap131}\raggedright\small \NWtarget{nuweb105b}{} $\langle\,${\itshape deperma indices}\nobreak\ {\footnotesize {105b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@idx <- matrix(1:J^2, nrow = J, ncol = J) ### assuming byrow = TRUE@\\ \mbox{}\verb@tidx <- c(t(idx))@\\ \mbox{}\verb@ltT <- idx[lower.tri(idx, diag = TRUE)]@\\ \mbox{}\verb@P <- matrix(0, nrow = J, ncol = J)@\\ \mbox{}\verb@P[cbind(1:J, perm)] <- 1@\\ \mbox{}\verb@ID <- diag(J)@\\ \mbox{}\verb@IDP <- (ID %x% P)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb106}{106}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and are now ready for the main course. We are gentle and also allow \code{invchol}$ = \mL$ as input, and we clean-up by post-differentiation at the very end in this case. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap132}\raggedright\small \NWtarget{nuweb106}{} $\langle\,${\itshape deperma}\nobreak\ {\footnotesize {106}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@deperma <- function(chol = solve(invchol), @\\ \mbox{}\verb@ permuted_chol = solve(permuted_invchol), @\\ \mbox{}\verb@ invchol, permuted_invchol, perm, score_schol) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape deperma input checks chol}\nobreak\ {\footnotesize \NWlink{nuweb104a}{104a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape deperma input checks perm}\nobreak\ {\footnotesize \NWlink{nuweb104b}{104b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape deperma input checks schol}\nobreak\ {\footnotesize \NWlink{nuweb105a}{105a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape deperma indices}\nobreak\ {\footnotesize \NWlink{nuweb105b}{105b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Nc <- dim(chol)[1L]@\\ \mbox{}\verb@ mC <- as.array(chol)[perm,,,drop = FALSE]@\\ \mbox{}\verb@ Ct <- as.array(permuted_chol)@\\ \mbox{}\verb@ ret <- lapply(1:Nc, function(i) {@\\ \mbox{}\verb@ B1 <- (mC[,,i] %x% ID) + (ID %x% mC[,,i])[,tidx]@\\ \mbox{}\verb@ # ^^^^^^^ <- d t(A) / d A@\\ \mbox{}\verb@ B1 <- B1 %*% IDP@\\ \mbox{}\verb@ B1 <- B1[,ltT] ### relevant columns of B1@\\ \mbox{}\verb@ B2 <- (Ct[,,i] %x% ID) + (ID %x% Ct[,,i])[,tidx]@\\ \mbox{}\verb@ B2 <- B2[,ltT] ### relevant columns of B2@\\ \mbox{}\verb@ B3 <- try(solve(crossprod(B2), crossprod(B2, B1)))@\\ \mbox{}\verb@ if (inherits(B3, "try-error")) @\\ \mbox{}\verb@ stop("failure computing permutation score")@\\ \mbox{}\verb@ if (Nc == 1L)@\\ \mbox{}\verb@ return(crossprod(score_schol, B3))@\\ \mbox{}\verb@ return(crossprod(score_schol[,i,drop = FALSE], B3))@\\ \mbox{}\verb@ })@\\ \mbox{}\verb@ ret <- do.call("rbind", ret)@\\ \mbox{}\verb@ ret <-ltMatrices(t(ret), diag = TRUE, byrow = FALSE)@\\ \mbox{}\verb@ if (INVCHOL)@\\ \mbox{}\verb@ ret <- -vectrick(chol, ret)@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = byrow_orig_s)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can now use this function to estimate the Cholesky factor for $(\rX, \rY)$ when the data comes as $(\rY, \rX)$ (which is needed because continuous variables come first in our implementation of log-likehood and score function). <>= sc_ap <- function(parm, J) { m <- parm[1:J] ### mean parameters; NOT permuted parm <- parm[-(1:J)] ### chol parameters C <- matrix(c(parm), ncol = 1L) C <- ltMatrices(C, diag = TRUE, byrow = BYROW) ### permutation Ct <- aperm(as.chol(C), perm = perm) ret <- sldpmvnorm(obs = Y[ic,], lower = lwr[-ic,], upper = upr[-ic,], mean = m, chol = Ct, w = W[-ic,,drop = FALSE], M = M) ### undo permutation for chol retC <- deperma(chol = C, permuted_chol = Ct, perm = perm, score_schol = ret$chol) return(-c(rowSums(ret$mean), rowSums(Lower_tri(retC, diag = TRUE)))) } @ and the score function seems to be correct <>= if (require("numDeriv", quietly = TRUE)) chk(grad(ll_ap, start, J = J), sc_ap(start, J = J), check.attributes = FALSE, tolerance = 1e-6) @ We can now jointly estimate all model parameters via <>= op <- optim(start, fn = ll_ap, gr = sc_ap, J = J, method = "L-BFGS-B", lower = llim, control = list(trace = FALSE)) ## estimated C for (X, Y) ltMatrices(matrix(op$par[-(1:J)], ncol = 1), diag = TRUE, byrow = BYROW) ## compare with true _permuted_ C for (X, Y) round(as.array(aperm(as.chol(lt), perm = perm)), 4) @ \chapter{Unstructured Gaussian Copula Estimation} \label{copula} With $\rZ \sim \ND_\J(0, \mI_\J)$ and $\rY = \tilde{\mC} \rZ \sim \ND_\J(0, \tilde{\mC} \tilde{\mC}^\top)$ we want to estimate the off-diagonal elements of the lower triangular unit-diagonal matrix $\mC$. We have $\tilde{\mC}(\mC) := \diag(\mC \mC^\top)^{-\nicefrac{1}{2}} \mC$ such that $\mSigma = \tilde{\mC} \tilde{\mC}^\top$ is a correlation matrix ($\diag(\mSigma) = \mI_\J$). Note that directly estimating $\tilde{\mC}$ requires $\J (\J + 1) / 2$ parameters under constraints $\diag(\mSigma) = 1$ whereas only $\J (\J - 1) / 2$ parameters are necessary when estimating the lower triangular part of $\mC$. The standardisation by $\diag(\mC \mC^\top)^{-\nicefrac{1}{2}}$ ensures that $\diag(\mSigma) \equiv 1$, that is, unconstained optimisation can be applied. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap133}\raggedright\small \NWtarget{nuweb108}{} $\langle\,${\itshape standardize}\nobreak\ {\footnotesize {108}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@standardize <- function(chol, invchol) {@\\ \mbox{}\verb@ stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@ if (!missing(invchol)) {@\\ \mbox{}\verb@ stopifnot(!attr(invchol, "diag"))@\\ \mbox{}\verb@ return(invcholD(invchol))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ stopifnot(!attr(chol, "diag"))@\\ \mbox{}\verb@ return(Dchol(chol))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} <>= C <- ltMatrices(runif(10)) all.equal(as.array(chol2cov(standardize(chol = C))), as.array(chol2cor(standardize(chol = C)))) L <- solve(C) all.equal(as.array(invchol2cov(standardize(invchol = L))), as.array(invchol2cor(standardize(invchol = L)))) @ The log-likelihood function is $\ell_i(\mC_i)$ (we omit $i$ in the following) and we assume the score \begin{eqnarray*} \frac{\partial \ell(\mC)}{\partial \mC} \end{eqnarray*} is already available. We want to compute the score \begin{eqnarray*} \frac{\partial \ell(\tilde{\mC})}{\partial \mC} \end{eqnarray*} which gives \begin{eqnarray*} \frac{\partial \ell(\tilde{\mC})}{\partial \mC} & = & \underbrace{\frac{\partial \ell(\tilde{\mC})}{\partial \tilde{\mC}}}_{=: \mT} \times \frac{\partial \tilde{\mC}(\mC)}{\partial \mC} \end{eqnarray*} We further have \begin{eqnarray*} \frac{\partial \tilde{\mC}(\mC)}{\partial \mC} = (\mC^\top \otimes \mI_\J) \frac{\partial \diag(\mC \mC^\top)^{-\nicefrac{1}{2}}}{\partial \mC} + (\mI_\J \otimes \diag(\mC \mC^\top)^{-\nicefrac{1}{2}}) \end{eqnarray*} and thus \begin{eqnarray*} \frac{\partial \ell(\tilde{\mC})}{\partial \mC} & = & \vecop(\mI_\J \mT \mC^\top)^\top \frac{\partial \diag(\mC \mC^\top)^{-\nicefrac{1}{2}}}{\partial \mC} + \vecop(\diag(\mC \mC^\top)^{-\nicefrac{1}{2}} \mT \mI_\J)^\top \end{eqnarray*} and with \begin{eqnarray*} \frac{\partial \diag(\mC \mC^\top)^{-\nicefrac{1}{2}}}{\partial \mC} & = & \left. \frac{\partial \diag(\mA)^{-\nicefrac{1}{2}}}{\partial \mA} \right|_{\mA = \mC \mC^\top} \frac{\partial \mC \mC^\top}{\partial \mC} \\ & = & -\frac{1}{2} \diag(\vecop(\diag(\mC \mC^\top)^{-\nicefrac{3}{2}})) \left[ (\mC \otimes \mI_\J) \frac{\partial \mC}{\partial \mC} + (\mI_\J \otimes \mC) \frac{\partial \mC^\top}{\partial \mC}\right] \end{eqnarray*} we can write \begin{eqnarray*} \vecop(\mI_\J \mT \mC^\top)^\top (-\frac{1}{2}) \diag(\vecop(\diag(\mC \mC^\top)^{-\nicefrac{3}{2}})) & = & -\frac{1}{2} \times \vecop(\mI_\J \mT \mC^\top)^\top \times \vecop(\diag(\mC \mC^\top)^{-\nicefrac{3}{2}})^\top \\ & =: & \bvec^\top \end{eqnarray*} thus \begin{eqnarray*} \frac{\partial \ell(\tilde{\mC})}{\partial \mC} & = & \bvec^\top \left[ (\mC \otimes \mI_\J) \frac{\partial \mC}{\partial \mC} + (\mI_\J \otimes \mC) \frac{\partial \mC^\top}{\partial \mC}\right] + \vecop(\diag(\mC \mC^\top)^{-\nicefrac{1}{2}} \mT \mI_\J)^\top \\ & = & \vecop(\mI_\J \mB \mC)^\top + \vecop(\mC^\top \mB \mI_\J)^\top \frac{\partial \mC^\top}{\partial \mC} + \vecop(\diag(\mC \mC^\top)^{-\nicefrac{1}{2}} \mT \mI_\J)^\top \end{eqnarray*} when $\bvec = \vecop(\mB)$. These scores are implemented in \code{destandardize} with \code{chol} $ = \mC$ and \code{score\_schol} $= \mT$. If the model was parameterised in $\mL = \mC^{-1}$, we have \code{invchol} $ = \mL$, however, we would still need to compute $\mT$ (\code{score\_schol}, the score with respect to $\mC$, and it is the user's responsibility to provide this quantity). \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap134}\raggedright\small \NWtarget{nuweb110}{} $\langle\,${\itshape destandardize}\nobreak\ {\footnotesize {110}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@destandardize <- function(chol = solve(invchol), invchol, score_schol)@\\ \mbox{}\verb@{@\\ \mbox{}\verb@ stopifnot(is.ltMatrices(chol)) ### NOTE: replace with is.chol@\\ \mbox{}\verb@ J <- dim(chol)[2L]@\\ \mbox{}\verb@ stopifnot(!attr(chol, "diag"))@\\ \mbox{}\verb@ byrow_orig <- attr(chol, "byrow")@\\ \mbox{}\verb@ chol <- ltMatrices(chol, byrow = FALSE)@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ ### TODO: check byrow in score_schol?@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.ltMatrices(score_schol))@\\ \mbox{}\verb@ score_schol <- matrix(as.array(score_schol), @\\ \mbox{}\verb@ nrow = dim(score_schol)[2L]^2)@\\ \mbox{}\verb@ stopifnot(is.matrix(score_schol))@\\ \mbox{}\verb@ N <- ncol(score_schol)@\\ \mbox{}\verb@ stopifnot(J^2 == nrow(score_schol))@\\ \mbox{}\verb@@\\ \mbox{}\verb@ CCt <- Tcrossprod(chol, diag_only = TRUE)@\\ \mbox{}\verb@ DC <- Dchol(chol, D = Dinv <- 1 / sqrt(CCt))@\\ \mbox{}\verb@ SDC <- solve(DC)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ IDX <- t(M <- matrix(1:J^2, nrow = J, ncol = J))@\\ \mbox{}\verb@ i <- cumsum(c(1, rep(J + 1, J - 1)))@\\ \mbox{}\verb@ ID <- diagonals(as.integer(J), byrow = FALSE)@\\ \mbox{}\verb@ if (dim(ID)[1L] != dim(chol)[1L])@\\ \mbox{}\verb@ ID <- ID[rep(1, dim(chol)[1L]),]@\\ \mbox{}\verb@@\\ \mbox{}\verb@ B <- vectrick(ID, score_schol, chol)@\\ \mbox{}\verb@ B[i,] <- B[i,] * (-.5) * c(CCt)^(-3/2)@\\ \mbox{}\verb@ B[-i,] <- 0@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Dtmp <- Dchol(ID, D = Dinv)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- vectrick(ID, B, chol, transpose = c(TRUE, FALSE)) +@\\ \mbox{}\verb@ vectrick(chol, B, ID)[IDX,] +@\\ \mbox{}\verb@ vectrick(Dtmp, score_schol, ID)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (!missing(invchol)) {@\\ \mbox{}\verb@ ### this means: ret <- - vectrick(chol, ret, chol)@\\ \mbox{}\verb@ ret <- - vectrick(chol, ret)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ ret <- ret[M[lower.tri(M)],,drop = FALSE]@\\ \mbox{}\verb@ if (!is.null(dimnames(chol)[[1L]]))@\\ \mbox{}\verb@ colnames(ret) <- dimnames(chol)[[1L]]@\\ \mbox{}\verb@ ret <- ltMatrices(ret,@\\ \mbox{}\verb@ diag = FALSE, byrow = FALSE, @\\ \mbox{}\verb@ names = dimnames(chol)[[2L]])@\\ \mbox{}\verb@ ret <- ltMatrices(ret, byrow = byrow_orig)@\\ \mbox{}\verb@ diagonals(ret) <- 0@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can now set-up the log-likelihood and score functions for a Gaussian copula model. We start with the classical approach of generating the marginal observations $\rY$ from the ECDF with denominator $N + 1$ and subsequent use of the Lebesque density as likelihood. Because no stats text on multivariate problems is complete without a reference to Edgar Anderson's iris data, let's set up a model for these four classical variables <>= data("iris", package = "datasets") J <- 4 Z <- t(qnorm(do.call("cbind", lapply(iris[1:J], rank)) / (nrow(iris) + 1))) (CR <- cor(t(Z))) ll <- function(parm) { C <- ltMatrices(parm) Cs <- standardize(C) -ldmvnorm(obs = Z, chol = Cs) } sc <- function(parm) { C <- ltMatrices(parm) Cs <- standardize(C) -rowSums(Lower_tri(destandardize(chol = C, score_schol = sldmvnorm(obs = Z, chol = Cs)$chol))) } start <- t(chol(CR)) start <- start[lower.tri(start)] if (require("numDeriv", quietly = TRUE)) chk(grad(ll, start), sc(start), check.attributes = FALSE) op <- optim(start, fn = ll, gr = sc, method = "BFGS", control = list(trace = FALSE), hessian = TRUE) op$value S_ML <- chol2cov(standardize(ltMatrices(op$par))) @ This approach is of course a bit strange, because we estimate the marginal distributions by nonparametric maximum likelihood whereas the joint distribution is estimated by plain maximum likelihood. For the latter, we can define the likelihood by boxes given by intervals obtained from the marginale ECDFs and estimate the Copula parameters by maximisation of this nonparametric likelihood. <>= lwr <- do.call("cbind", lapply(iris[1:J], rank, ties.method = "min")) - 1L upr <- do.call("cbind", lapply(iris[1:J], rank, ties.method = "max")) lwr <- t(qnorm(lwr / nrow(iris))) upr <- t(qnorm(upr / nrow(iris))) M <- 500 if (require("qrng", quietly = TRUE)) { ### quasi-Monte-Carlo W <- t(ghalton(M, d = J - 1)) } else { ### Monte-Carlo W <- matrix(runif(M * (J - 1)), nrow = J - 1) } ll <- function(parm) { C <- ltMatrices(parm) Cs <- standardize(C) -lpmvnorm(lower = lwr, upper = upr, chol = Cs, M = M, w = W) } sc <- function(parm) { C <- ltMatrices(parm) Cs <- standardize(C) -rowSums(Lower_tri(destandardize(chol = C, score_schol = slpmvnorm(lower = lwr, upper = upr, chol = Cs, M = M, w = W)$chol))) } if (require("numDeriv", quietly = TRUE)) chk(grad(ll, start), sc(start), check.attributes = FALSE) op2 <- optim(start, fn = ll, gr = sc, method = "BFGS", control = list(trace = FALSE), hessian = TRUE) S_NPML <- chol2cov(standardize(ltMatrices(op2$par))) @ For $N = \Sexpr{nrow(iris)}$, the difference is (as expected) marginal: <>= S_ML S_NPML @ with relatively close standard errors <>= sd_ML <- ltMatrices(sqrt(diag(solve(op$hessian)))) diagonals(sd_ML) <- 0 sd_NPML <- try(ltMatrices(sqrt(diag(solve(op2$hessian))))) if (!inherits(sd_NPML, "try-error")) { diagonals(sd_NPML) <- 0 print(sd_ML) print(sd_NPML) } @ \chapter{(Experimental) User Interface} \label{inter} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap135}\raggedright\small \NWtarget{nuweb114a}{} \verb@"interface.R"@\nobreak\ {\footnotesize {114a}}$\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm}\nobreak\ {\footnotesize \NWlink{nuweb116a}{116a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm methods}\nobreak\ {\footnotesize \NWlink{nuweb116b}{116b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm simulate}\nobreak\ {\footnotesize \NWlink{nuweb117}{117}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm margDist}\nobreak\ {\footnotesize \NWlink{nuweb118}{118}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm condDist}\nobreak\ {\footnotesize \NWlink{nuweb119}{119}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm logLik}\nobreak\ {\footnotesize \NWlink{nuweb122c}{122c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape mvnorm lLgrad}\nobreak\ {\footnotesize \NWlink{nuweb127}{127}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The tools provided in the previous chapters are rather low-level, so we will invest some time into setting-up a more high-level interface for representing normal models, either as $\ND_\J(\muvec, \mC \mC^\top)$ or $\ND_\J(\muvec, \mL^{-1} \mL^{-\top})$, for simulating from such models, and for evaluating the log-likelihood and corresponding score functions. The latter functionality shall also work when only incomplete (variables are missing) or censored (observations are only known as intervals) data is available. We start with the conversion of a lower triangular matrix \code{x} to an \code{ltMatrices} object \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap136}\raggedright\small \NWtarget{nuweb114b}{} $\langle\,${\itshape as.ltMatrices}\nobreak\ {\footnotesize {114b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@as.ltMatrices.default <- function(x) {@\\ \mbox{}\verb@ stopifnot(is.numeric(x))@\\ \mbox{}\verb@ if (!is.matrix(x)) x <- matrix(x) @\\ \mbox{}\verb@ DIAG <- max(abs(diag(x) - 1)) > .Machine$double.eps@\\ \mbox{}\verb@ DIAG <- DIAG & (nrow(x) > 1)@\\ \mbox{}\verb@ lt <- x[lower.tri(x, diag = DIAG)]@\\ \mbox{}\verb@ up <- x[upper.tri(x, diag = FALSE)]@\\ \mbox{}\verb@ stopifnot(max(abs(up)) < .Machine$double.eps)@\\ \mbox{}\verb@ nm <- rownames(x)@\\ \mbox{}\verb@ if (!is.null(nm))@\\ \mbox{}\verb@ return(ltMatrices(lt, diag = DIAG, names = nm))@\\ \mbox{}\verb@ return(ltMatrices(lt, diag = DIAG))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and proceed defining a constructor for object respresenting, potentially multiple, multivariate normal distributions. If the Cholesky factor $\mC$ (or multiple Cholesky factors $\mC_1, \dots, \mC_N$) are given as \code{chol} argument, we label them as being such objects using \code{as.chol}. If only a matrix is given, we convert it (if possible) to a single Cholesky factor $\mC$. The same is done when $\mL$ is given as \code{invchol} argument. Of course, only one of these arguments must be specified. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap137}\raggedright\small \NWtarget{nuweb115a}{} $\langle\,${\itshape mvnorm chol invchol}\nobreak\ {\footnotesize {115a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (missing(chol) && missing(invchol))@\\ \mbox{}\verb@ chol <- as.chol(ltMatrices(1, diag = TRUE))@\\ \mbox{}\verb@stopifnot(xor(missing(chol), missing(invchol)))@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (!missing(chol)) {@\\ \mbox{}\verb@ if (!is.ltMatrices(chol))@\\ \mbox{}\verb@ chol <- as.ltMatrices(chol)@\\ \mbox{}\verb@ scale <- as.chol(chol)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (!missing(invchol)) {@\\ \mbox{}\verb@ if (!is.ltMatrices(invchol))@\\ \mbox{}\verb@ invchol <- as.ltMatrices(invchol)@\\ \mbox{}\verb@ scale <- as.invchol(invchol)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@ret <- list(scale = scale)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb116a}{116a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The mean, or multiple means, is stored as a $\J \times 1$ or $\J \times N$ matrix, and we check if dimensions and, possibly, names are in line with what was specified as \code{chol} or \code{invchol} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap138}\raggedright\small \NWtarget{nuweb115b}{} $\langle\,${\itshape mvnorm mean}\nobreak\ {\footnotesize {115b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!missing(mean)) {@\\ \mbox{}\verb@ stopifnot(is.numeric(mean))@\\ \mbox{}\verb@ stopifnot(NROW(mean) == dim(scale)[2L])@\\ \mbox{}\verb@ if (!is.matrix(mean)) {@\\ \mbox{}\verb@ mean <- matrix(mean, nrow = NROW(mean))@\\ \mbox{}\verb@ rownames(mean) <- names(mean)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ nm <- dimnames(scale)[[2L]]@\\ \mbox{}\verb@ if (is.null(rownames(mean)))@\\ \mbox{}\verb@ rownames(mean) <- nm@\\ \mbox{}\verb@ if (!isTRUE(all.equal(rownames(mean), nm)))@\\ \mbox{}\verb@ stop("rownames of mean do not match") @\\ \mbox{}\verb@ nm <- dimnames(scale)[[1L]]@\\ \mbox{}\verb@ if (!is.null(nm) && dim(scale)[[2L]] == ncol(mean)) {@\\ \mbox{}\verb@ if (is.null(colnames(mean)))@\\ \mbox{}\verb@ colnames(mean) <- nm@\\ \mbox{}\verb@ if (!isTRUE(all.equal(colnames(mean), nm)))@\\ \mbox{}\verb@ stop("colnames of mean do not match") @\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ ret$mean <- mean@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb116a}{116a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Finally, we put everything together and return an object of class \code{mvnorm}, featuring \code{mean} and \code{scale}. The class of the latter slot carries the information how this object is to be interpreted (as Cholesky factor or inverse thereof) \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap139}\raggedright\small \NWtarget{nuweb116a}{} $\langle\,${\itshape mvnorm}\nobreak\ {\footnotesize {116a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### allow more than one distribution@\\ \mbox{}\verb@mvnorm <- function(mean, chol, invchol) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape mvnorm chol invchol}\nobreak\ {\footnotesize \NWlink{nuweb115a}{115a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape mvnorm mean}\nobreak\ {\footnotesize \NWlink{nuweb115b}{115b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ class(ret) <- "mvnorm"@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} It might have been smarter to specify the scaled mean $\etavec = \mL \muvec$ because the log-density is then jointly convex in $\etavec$ and $\mL$ and thus a convex problem would emerge \citep{Barrathh_Boyd_2023}. We add a \code{names} and \code{aperm} method. The latter returns a multivariate normal distribution with permuted order of the variables \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap140}\raggedright\small \NWtarget{nuweb116b}{} $\langle\,${\itshape mvnorm methods}\nobreak\ {\footnotesize {116b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@names.mvnorm <- function(x)@\\ \mbox{}\verb@ dimnames(x$scale)[[2L]]@\\ \mbox{}\verb@@\\ \mbox{}\verb@aperm.mvnorm <- function(a, perm, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ ret <- list(scale = aperm(a$scale, perm = perm, ...))@\\ \mbox{}\verb@ if (!is.null(a$mean))@\\ \mbox{}\verb@ ret$mean <- a$mean[perm,,drop = FALSE]@\\ \mbox{}\verb@ class(ret) <- "mvnorm"@\\ \mbox{}\verb@ ret@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We are now ready to draw samples from such an object. If multiple normal distributions are contained in \code{object}, we return one sample each, otherwise, \code{nsim} samples are returned. Because most tools in this package expect data as $\J \times N$ matrices, we return the data in this format. If a classical \code{data.frame} is preferred, \code{as.data.frame = TRUE} we provide one \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap141}\raggedright\small \NWtarget{nuweb117}{} $\langle\,${\itshape mvnorm simulate}\nobreak\ {\footnotesize {117}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@simulate.mvnorm <- function(object, nsim = dim(object$scale)[1L], seed = NULL, @\\ \mbox{}\verb@ standardize = FALSE, as.data.frame = FALSE, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ J <- dim(object$scale)[2L]@\\ \mbox{}\verb@ N <- dim(object$scale)[1L]@\\ \mbox{}\verb@ if (N > 1)@\\ \mbox{}\verb@ stopifnot(nsim == N)@\\ \mbox{}\verb@ if (standardize) {@\\ \mbox{}\verb@ if (is.chol(object$scale)) {@\\ \mbox{}\verb@ object$scale <- standardize(chol = object$scale)@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ object$scale <- standardize(invchol = object$scale)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ Z <- matrix(rnorm(nsim * J), nrow = J)@\\ \mbox{}\verb@ if (is.chol(object$scale)) {@\\ \mbox{}\verb@ Y <- Mult(object$scale, Z)@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ Y <- solve(object$scale, Z)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ ret <- Y@\\ \mbox{}\verb@ if (!is.null(object$mean))@\\ \mbox{}\verb@ ret <- ret + c(object$mean)@\\ \mbox{}\verb@ rownames(ret) <- dimnames(object$scale)[[2L]]@\\ \mbox{}\verb@ if (!as.data.frame)@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@ return(as.data.frame(t(ret)))@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} It is maybe time for a first example, and we return to the iris dataset, ignoring the iris' species for the time being. We set-up a model in terms of the sample maximum-likelihood estimates <>= data("iris", package = "datasets") vars <- names(iris)[-5L] N <- nrow(iris) m <- colMeans(iris[,vars]) V <- var(iris[,vars]) * (N - 1) / N iris_mvn <- mvnorm(mean = m, chol = t(chol(V))) iris_var <- simulate(iris_mvn, nsim = nrow(iris)) @ Marginal and conditional distributions might be of interest, the \code{margDist} and \code{condDist} methods are simple wrappers to \code{marg\_mvnorm} and \code{cond\_mvnorm} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap142}\raggedright\small \NWtarget{nuweb118}{} $\langle\,${\itshape mvnorm margDist}\nobreak\ {\footnotesize {118}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@margDist <- function(object, which, ...)@\\ \mbox{}\verb@ UseMethod("margDist")@\\ \mbox{}\verb@@\\ \mbox{}\verb@margDist.mvnorm <- function(object, which, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.chol(object$scale)) {@\\ \mbox{}\verb@ ret <- list(scale = as.chol(marg_mvnorm(chol = object$scale, @\\ \mbox{}\verb@ which = which)$chol))@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ ret <- list(scale = as.invchol(marg_mvnorm(invchol = object$scale, @\\ \mbox{}\verb@ which = which)$invchol))@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (!is.null(object$mean))@\\ \mbox{}\verb@ ret$mean <- object$mean[which,,drop = FALSE]@\\ \mbox{}\verb@ class(ret) <- "mvnorm"@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap143}\raggedright\small \NWtarget{nuweb119}{} $\langle\,${\itshape mvnorm condDist}\nobreak\ {\footnotesize {119}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@condDist <- function(object, which_given, given, ...)@\\ \mbox{}\verb@ UseMethod("condDist")@\\ \mbox{}\verb@@\\ \mbox{}\verb@condDist.mvnorm <- function(object, which_given = 1L, given, ...) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ if (is.chol(object$scale)) {@\\ \mbox{}\verb@ ret <- cond_mvnorm(chol = object$scale, which_given = which_given, @\\ \mbox{}\verb@ given = given, ...)@\\ \mbox{}\verb@ ret$scale <- as.chol(ret$chol)@\\ \mbox{}\verb@ ret$chol <- NULL@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ ret <- cond_mvnorm(invchol = object$scale, which_given = which_given, @\\ \mbox{}\verb@ given = given, ...)@\\ \mbox{}\verb@ ret$invchol <- as.chol(ret$invchol)@\\ \mbox{}\verb@ ret$invchol <- NULL@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ if (!is.null(object$mean)) {@\\ \mbox{}\verb@ if (is.character(which_given)) @\\ \mbox{}\verb@ which_given <- match(which_given, dimnames(object$scale)[[2L]])@\\ \mbox{}\verb@ if (ncol(object$mean) > 1L && ncol(ret$mean) > 1)@\\ \mbox{}\verb@ stop("dimensions do not match")@\\ \mbox{}\verb@ if (ncol(object$mean) == 1L && ncol(ret$mean) > 1L) {@\\ \mbox{}\verb@ ret$mean <- object$mean[-which_given,,drop = TRUE] + ret$mean@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ ret$mean <- object$mean[-which_given,,drop = FALSE] + c(ret$mean)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ class(ret) <- "mvnorm"@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We could now compute the marginal distribution of two Petal variables or the bivariate regressions of the two Petal variables given the observed Sepal variables. Note that the last object contains $N = \Sexpr{nrow(iris)}$ different distributions <>= j <- 3:4 margDist(iris_mvn, which = vars[j]) gm <- t(iris[,vars[-(j)]]) iris_cmvn <- condDist(iris_mvn, which_given = vars[j], given = gm) @ We now work towards implementating the corresponding log-likelihood function. This is a trivial task as long as all variables for all observations have been observed exactly (that is, we can interpret the data as being continuous). Here, we also want to allow imprecise, that is, interval-censored, measurements. The one constraint in \code{ldpmvnorm} is that the continuous variables come first, followed by the censored ones. This of course might not be in line with the variable ordering we have in mind for our model. Our log-likelihood function shall be able to evaluate the log-likelihood for arbitrary permutations of the variables and, optionally, also based on marginal distributions in case observations are missing. The following \code{logLik} method for objects of class \code{mvnorm} is essentially a wrapper for \code{ldpmvnorm}, handling permutations, marginalisation, and standardisation. We begin with some sanity checks \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap144}\raggedright\small \NWtarget{nuweb121}{} $\langle\,${\itshape argchecks}\nobreak\ {\footnotesize {121}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@args <- c(object, list(...))@\\ \mbox{}\verb@nargs <- missing(obs) + missing(lower) + missing(upper)@\\ \mbox{}\verb@stopifnot(nargs < 3L)@\\ \mbox{}\verb@@\\ \mbox{}\verb@nmobs <- NULL@\\ \mbox{}\verb@if (!missing(obs)) {@\\ \mbox{}\verb@ if (!is.null(obs)) {@\\ \mbox{}\verb@ stopifnot(is.matrix(obs))@\\ \mbox{}\verb@ nmobs <- rownames(obs)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@nmlower <- nmupper <- nmlu <- NULL@\\ \mbox{}\verb@if (!missing(lower)) {@\\ \mbox{}\verb@ if (!is.null(lower)) {@\\ \mbox{}\verb@ stopifnot(is.matrix(lower))@\\ \mbox{}\verb@ nmlu <- nmlower <- rownames(lower)@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@if (!missing(upper)) {@\\ \mbox{}\verb@ if (!is.null(lower)) {@\\ \mbox{}\verb@ stopifnot(is.matrix(upper))@\\ \mbox{}\verb@ nmupper <- rownames(upper)@\\ \mbox{}\verb@ if (!missing(lower)) {@\\ \mbox{}\verb@ stopifnot(isTRUE(all.equal(nmlower, nmupper)))@\\ \mbox{}\verb@ } else {@\\ \mbox{}\verb@ nmlu <- nmupper@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@\\ \mbox{}\verb@nm <- c(nmobs, nmlu)@\\ \mbox{}\verb@no <- names(object)@\\ \mbox{}\verb@stopifnot(nm %in% no)@\\ \mbox{}\verb@perm <- NULL@\\ \mbox{}\verb@if (!isTRUE(all.equal(nm, no)))@\\ \mbox{}\verb@ perm <- c(nm, no[!no %in% nm])@\\ \mbox{}\verb@@\\ \mbox{}\verb@if (!missing(obs)) args$obs <- obs@\\ \mbox{}\verb@if (!missing(lower)) args$lower <- lower@\\ \mbox{}\verb@if (!missing(upper)) args$upper <- upper@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb122c}{122c}\NWlink{nuweb127}{, 127}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and proceed with the workhorse when $\mC$ was given \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap145}\raggedright\small \NWtarget{nuweb122a}{} $\langle\,${\itshape logLik chol}\nobreak\ {\footnotesize {122a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@names(args)[names(args) == "scale"] <- "chol"@\\ \mbox{}\verb@if (standardize)@\\ \mbox{}\verb@ args$chol <- standardize(chol = args$chol)@\\ \mbox{}\verb@if (!is.null(perm)) {@\\ \mbox{}\verb@ args$chol <- aperm(as.chol(args$chol), perm = perm)@\\ \mbox{}\verb@ if (length(nm) < length(no))@\\ \mbox{}\verb@ args$chol <- marg_mvnorm(chol = args$chol, which = nm)$chol@\\ \mbox{}\verb@ args$mean <- args$mean[nm,,drop = FALSE]@\\ \mbox{}\verb@}@\\ \mbox{}\verb@return(do.call("ldpmvnorm", args))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb122c}{122c}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} For inverse Cholesky factors $\mL$, the code is very similar, just the argument names change \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap146}\raggedright\small \NWtarget{nuweb122b}{} $\langle\,${\itshape logLik invchol}\nobreak\ {\footnotesize {122b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@names(args)[names(args) == "scale"] <- "invchol"@\\ \mbox{}\verb@if (standardize)@\\ \mbox{}\verb@ args$invchol <- standardize(invchol = args$invchol)@\\ \mbox{}\verb@if (!is.null(perm)) {@\\ \mbox{}\verb@ args$invchol <- aperm(as.invchol(args$invchol), perm = perm)@\\ \mbox{}\verb@ if (length(nm) < length(no))@\\ \mbox{}\verb@ args$invchol <- marg_mvnorm(invchol = args$invchol, @\\ \mbox{}\verb@ which = nm)$invchol@\\ \mbox{}\verb@ args$mean <- args$mean[nm,,drop = FALSE]@\\ \mbox{}\verb@}@\\ \mbox{}\verb@return(do.call("ldpmvnorm", args))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb122c}{122c}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Putting everything together in a corresponding \code{logLik} method \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap147}\raggedright\small \NWtarget{nuweb122c}{} $\langle\,${\itshape mvnorm logLik}\nobreak\ {\footnotesize {122c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@logLik.mvnorm <- function(object, obs, lower, upper, standardize = FALSE, @\\ \mbox{}\verb@ ...) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape argchecks}\nobreak\ {\footnotesize \NWlink{nuweb121}{121}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ if (is.chol(object$scale)) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape logLik chol}\nobreak\ {\footnotesize \NWlink{nuweb122a}{122a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape logLik invchol}\nobreak\ {\footnotesize \NWlink{nuweb122b}{122b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} allows us to evaluate the log-likelihood of the conditional models for iris <>= logLik(object = iris_cmvn, obs = t(iris[,vars[-j]])) @ This implementation of the log-likelihood silently handles the case when variables have been specified in a different order than hard-wired into the model <>= logLik(object = iris_cmvn, obs = t(iris[,rev(vars[-j])])) @ The hardest task is the implementation of a score function which features the same options as the log-likelihood function and provides the gradients with respect not only to the parameters ($\mu$ and $\mC$ or $\mL$), but also with respect to the data objects \code{obs}, \code{lower}, and \code{upper}. In essence, we have to repair the damage imposed by a series of transformations in \code{logLik.mvnorm}, that is, by standardisation, permutation, and marginalisation. We start with the case when $\mC$ was given. First, we repeat all the steps performed in \code{logLik}, but call the score function \code{sldpmvnorm} instead of the log-likelihood function \code{ldpmvnorm} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap148}\raggedright\small \NWtarget{nuweb123a}{} $\langle\,${\itshape lLgrad chol}\nobreak\ {\footnotesize {123a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@names(args)[names(args) == "scale"] <- "chol"@\\ \mbox{}\verb@sc <- args$chol@\\ \mbox{}\verb@if (standardize)@\\ \mbox{}\verb@ args$chol <- sc <- standardize(chol = args$chol)@\\ \mbox{}\verb@if (!is.null(perm)) {@\\ \mbox{}\verb@ if (!attr(args$chol, "diag")) {@\\ \mbox{}\verb@ diagonals(args$chol) <- 1@\\ \mbox{}\verb@ sc <- args$chol@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ args$chol <- pc <- aperm(as.chol(args$chol), perm = perm)@\\ \mbox{}\verb@ if (length(nm) < length(no))@\\ \mbox{}\verb@ args$chol <- marg_mvnorm(chol = args$chol, which = nm)$chol@\\ \mbox{}\verb@ args$mean <- args$mean[nm,,drop = FALSE]@\\ \mbox{}\verb@}@\\ \mbox{}\verb@ret <- do.call("sldpmvnorm", args)@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lLgrad mean}\nobreak\ {\footnotesize \NWlink{nuweb123b}{123b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lLgrad marginalisation}\nobreak\ {\footnotesize \NWlink{nuweb124a}{124a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lLgrad deperma}\nobreak\ {\footnotesize \NWlink{nuweb124b}{124b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lLgrad destandarized}\nobreak\ {\footnotesize \NWlink{nuweb124c}{124c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lLgrad diagonals}\nobreak\ {\footnotesize \NWlink{nuweb125a}{125a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\hbox{$\langle\,${\itshape lLgrad return}\nobreak\ {\footnotesize \NWlink{nuweb125b}{125b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb127}{127}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The next task is to post-differentiate all scores such that the gradients with respect to the original arguments of \code{logLik} are obtained. We start with the gradient with respect to $\muvec$, in case it was not given \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap149}\raggedright\small \NWtarget{nuweb123b}{} $\langle\,${\itshape lLgrad mean}\nobreak\ {\footnotesize {123b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### sldmvnorm returns mean score as -obs@\\ \mbox{}\verb@if (is.null(ret$mean)) ret$mean <- - ret$obs@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb123a}{123a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} In case we marginalised over some variables, we have to set the omitted parameters to zero \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap150}\raggedright\small \NWtarget{nuweb124a}{} $\langle\,${\itshape lLgrad marginalisation}\nobreak\ {\footnotesize {124a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@om <- length(no) - length(nm)@\\ \mbox{}\verb@if (om > 0) {@\\ \mbox{}\verb@ am <- matrix(0, nrow = om, ncol = ncol(ret$mean))@\\ \mbox{}\verb@ rownames(am) <- no[!no %in% nm]@\\ \mbox{}\verb@ ret$mean <- rbind(ret$mean, am)@\\ \mbox{}\verb@ Jo <- dim(object$scale)[[2L]]@\\ \mbox{}\verb@ pJ <- dim(args$invchol)[[2L]]@\\ \mbox{}\verb@ am <- matrix(0, nrow = Jo * (Jo + 1) / 2 - pJ * (pJ + 1) / 2, @\\ \mbox{}\verb@ ncol = dim(ret$invchol)[1L])@\\ \mbox{}\verb@ byrow_orig <- attr(ret$chol, "byrow")@\\ \mbox{}\verb@ ret$chol <- ltMatrices(ret$chol, byrow = TRUE)@\\ \mbox{}\verb@ ### rbind only works for byrow = TRUE@\\ \mbox{}\verb@ ret$chol <- ltMatrices(rbind(unclass(ret$chol), am), @\\ \mbox{}\verb@ byrow = TRUE, @\\ \mbox{}\verb@ diag = TRUE,@\\ \mbox{}\verb@ names = perm)@\\ \mbox{}\verb@ ret$chol <- ltMatrices(ret$chol, byrow = byrow_orig)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb123a}{123a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} If the order of the variables was permuted, we compute the scores for the original ordering of the variables, as explained in Chapter~\ref{cdl} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap151}\raggedright\small \NWtarget{nuweb124b}{} $\langle\,${\itshape lLgrad deperma}\nobreak\ {\footnotesize {124b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!is.null(perm))@\\ \mbox{}\verb@ ret$chol <- deperma(chol = sc, permuted_chol = pc, @\\ \mbox{}\verb@ perm = match(perm, no), @\\ \mbox{}\verb@ score_schol = ret$chol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb123a}{123a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The effect of standardization can be removed as discussed in Chapter~\ref{copula} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap152}\raggedright\small \NWtarget{nuweb124c}{} $\langle\,${\itshape lLgrad destandarized}\nobreak\ {\footnotesize {124c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (standardize)@\\ \mbox{}\verb@ ret$chol <- destandardize(chol = object$scale, @\\ \mbox{}\verb@ score_schol = ret$chol)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb123a}{123a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and it remains to remove fix diagonal elements \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap153}\raggedright\small \NWtarget{nuweb125a}{} $\langle\,${\itshape lLgrad diagonals}\nobreak\ {\footnotesize {125a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (!attr(sc, "diag"))@\\ \mbox{}\verb@ ret$chol <- ltMatrices(Lower_tri(ret$chol, diag = FALSE),@\\ \mbox{}\verb@ diag = FALSE, @\\ \mbox{}\verb@ byrow = attr(ret$chol, "byrow"), @\\ \mbox{}\verb@ names = dimnames(ret$chol)[[2L]])@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb123a}{123a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and to return the results, with mean scores in the correct ordering \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap154}\raggedright\small \NWtarget{nuweb125b}{} $\langle\,${\itshape lLgrad return}\nobreak\ {\footnotesize {125b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@ret$scale <- ret$chol@\\ \mbox{}\verb@ret$chol <- NULL@\\ \mbox{}\verb@ret$mean <- ret$mean[no,,drop = FALSE]@\\ \mbox{}\verb@return(ret)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb123a}{123a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The steps are essentially the same when $\mL$ was given, but we have to post-differentiate $\mC = \mL^{-1}$ with respect to $\mL$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap155}\raggedright\small \NWtarget{nuweb126}{} $\langle\,${\itshape lLgrad invchol}\nobreak\ {\footnotesize {126}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@names(args)[names(args) == "scale"] <- "invchol"@\\ \mbox{}\verb@si <- args$invchol@\\ \mbox{}\verb@if (standardize)@\\ \mbox{}\verb@ args$invchol <- si <- standardize(invchol = args$invchol)@\\ \mbox{}\verb@if (!is.null(perm)) {@\\ \mbox{}\verb@ if (!attr(args$invchol, "diag")) {@\\ \mbox{}\verb@ diagonals(args$invchol) <- 1@\\ \mbox{}\verb@ si <- args$invchol@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ args$invchol <- pi <- aperm(as.invchol(args$invchol), perm = perm)@\\ \mbox{}\verb@ if (length(nm) < length(no))@\\ \mbox{}\verb@ args$invchol <- marg_mvnorm(invchol = args$invchol,@\\ \mbox{}\verb@ which = nm)$invchol@\\ \mbox{}\verb@ args$mean <- args$mean[nm,,drop = FALSE]@\\ \mbox{}\verb@}@\\ \mbox{}\verb@ret <- do.call("sldpmvnorm", args)@\\ \mbox{}\verb@### sldmvnorm returns mean score as -obs@\\ \mbox{}\verb@if (is.null(ret$mean)) ret$mean <- - ret$obs@\\ \mbox{}\verb@om <- length(no) - length(nm)@\\ \mbox{}\verb@if (om > 0) {@\\ \mbox{}\verb@ am <- matrix(0, nrow = om, ncol = ncol(ret$mean))@\\ \mbox{}\verb@ rownames(am) <- no[!no %in% nm]@\\ \mbox{}\verb@ ret$mean <- rbind(ret$mean, am)@\\ \mbox{}\verb@ Jo <- dim(object$scale)[[2L]]@\\ \mbox{}\verb@ pJ <- dim(args$invchol)[[2L]]@\\ \mbox{}\verb@ am <- matrix(0, nrow = Jo * (Jo + 1) / 2 - pJ * (pJ + 1) / 2, @\\ \mbox{}\verb@ ncol = dim(ret$invchol)[1L])@\\ \mbox{}\verb@ byrow_orig <- attr(ret$invchol, "byrow")@\\ \mbox{}\verb@ ret$invchol <- ltMatrices(ret$invchol, byrow = TRUE)@\\ \mbox{}\verb@ ### rbind only works for byrow = TRUE@\\ \mbox{}\verb@ ret$invchol <- ltMatrices(rbind(unclass(ret$invchol), am), @\\ \mbox{}\verb@ byrow = TRUE,@\\ \mbox{}\verb@ diag = TRUE,@\\ \mbox{}\verb@ names = perm)@\\ \mbox{}\verb@ ret$invchol <- ltMatrices(ret$invchol, byrow = byrow_orig)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@if (!is.null(perm))@\\ \mbox{}\verb@ ret$invchol <- deperma(invchol = si, permuted_invchol = pi, @\\ \mbox{}\verb@ perm = match(perm, no), @\\ \mbox{}\verb@ score_schol = -vectrick(pi, ret$invchol))@\\ \mbox{}\verb@if (standardize)@\\ \mbox{}\verb@ ret$invchol <- destandardize(invchol = object$scale, @\\ \mbox{}\verb@ score_schol = -vectrick(si, ret$invchol))@\\ \mbox{}\verb@if (!attr(si, "diag"))@\\ \mbox{}\verb@ ret$invchol <- ltMatrices(Lower_tri(ret$invchol, diag = FALSE),@\\ \mbox{}\verb@ diag = FALSE, @\\ \mbox{}\verb@ byrow = attr(ret$invchol, "byrow"), @\\ \mbox{}\verb@ names = dimnames(ret$invchol)[[2L]])@\\ \mbox{}\verb@ret$scale <- ret$invchol@\\ \mbox{}\verb@ret$invchol <- NULL@\\ \mbox{}\verb@ret$mean <- ret$mean[no,,drop = FALSE]@\\ \mbox{}\verb@return(ret)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb127}{127}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can now provide the log-likelihood gradients \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap156}\raggedright\small \NWtarget{nuweb127}{} $\langle\,${\itshape mvnorm lLgrad}\nobreak\ {\footnotesize {127}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@lLgrad <- function(object, ...)@\\ \mbox{}\verb@ UseMethod("lLgrad")@\\ \mbox{}\verb@@\\ \mbox{}\verb@lLgrad.mvnorm <- function(object, obs, lower, upper, standardize = FALSE, @\\ \mbox{}\verb@ ...) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape argchecks}\nobreak\ {\footnotesize \NWlink{nuweb121}{121}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ if (is.chol(object$scale)) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape lLgrad chol}\nobreak\ {\footnotesize \NWlink{nuweb123a}{123a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ }@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape lLgrad invchol}\nobreak\ {\footnotesize \NWlink{nuweb126}{126}}$\,\rangle$}\verb@@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb114a}{114a}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Let's use this infrastructure to set-up maximum-likelihood estimation procedures. We start implementing the log-likelihood and score functions for the iris dataset <>= J <- length(vars) obs <- t(iris[, vars]) lower <- upper <- NULL ll <- function(parm) { C <- ltMatrices(parm[-(1:J)], diag = TRUE, names = vars) x <- mvnorm(mean = parm[1:J], chol = C) -logLik(object = x, obs = obs, lower = lower, upper = upper) } sc <- function(parm) { C <- ltMatrices(parm[-(1:J)], diag = TRUE, names = vars) x <- mvnorm(mean = parm[1:J], chol = C) ret <- lLgrad(object = x, obs = obs, lower = lower, upper = upper) -c(rowSums(ret$mean), rowSums(Lower_tri(ret$scale, diag = TRUE))) } @ and can now estimate the mean and Cholesky factor of the covariance matrix. Before we start, we check if the gradient, evaluated at the sample maximum-likelihood estimates, is actually zero. <>= start <- c(c(iris_mvn$mean), Lower_tri(iris_mvn$scale, diag = TRUE)) max(abs(sc(start))) < sqrt(.Machine$double.eps) op <- optim(start, fn = ll, gr = sc, method = "L-BFGS-B", lower = llim, control = list(trace = FALSE)) Chat <- ltMatrices(op$par[-(1:J)], diag = TRUE, names = vars) ML <- mvnorm(mean = op$par[1:J], chol = Chat) @ Quite unsurprisingly, the results are practically equivalent to the analytically available maximum-likelihood estimators in this case <>= ### covariance chol2cov(ML$scale) V ### mean ML$mean[,,drop = TRUE] m @ Now, this was a lot of work to replace \code{mean} and \code{var} with something more fancy, and we would of course not go down this way in real life. But how about a more complex situation where one (or more) variables are only known up to intervals? Let's present the first variable is such a case <>= v1 <- vars[1] q1 <- quantile(iris[[v1]], probs = 1:4 / 5) head(f1 <- cut(iris[[v1]], breaks = c(-Inf, q1, Inf))) @ The only necessary modification to our code is the specification of \code{lower} and \code{upper} bounds for these intervals, and the removal of the first variable from the ``exact continuous'' observations \code{obs}. The rest of the machinery \emph{doesn't need any update at all}. Note that the mean and covariance parameters are no longer orthogonal (as in the toy example above), so we do have to optimise over both sets of parameters simultaneously. <>= lower <- matrix(c(-Inf, q1)[f1], nrow = 1) upper <- matrix(c(q1, Inf)[f1], nrow = 1) rownames(lower) <- rownames(upper) <- v1 obs <- obs[!rownames(obs) %in% v1,,drop = FALSE] if (require("numDeriv", quietly = TRUE)) chk(grad(ll, start), sc(start), check.attributes = FALSE) opi <- optim(start, fn = ll, gr = sc, method = "L-BFGS-B", lower = llim, control = list(trace = FALSE)) Chati <- ltMatrices(opi$par[-(1:J)], diag = TRUE, names = vars) MLi <- mvnorm(mean = opi$par[1:J], chol = Chati) @ Because the likelihood is a product of a continuous density and a conditional probability as introduced in Chapter~\ref{cdl}, the two in-sample log-likelihoods are not comparable. However, the parameters of the two estimated normal distributions can be compared directly (and are rather close in our case) <>= op$value opi$value ### covariance chol2cov(MLi$scale) chol2cov(ML$scale) ### mean MLi$mean[,,drop = TRUE] ML$mean[,,drop = TRUE] @ We close this chapter with a word of warning: If more than one variable is censored, the \code{M} and \code{w} arguments to \code{lpmvnorm} and \code{slpmvnorm} have to be specified in \code{logLik} and \code{lLgrad} as additional arguments (\code{...}) \emph{AND MUST BE IDENTICAL} in both calls. The log-likelihood and score function automagically marginalise over dimensions where all observations are $(-\infty, \infty)$. We can simply omit these dimensions from the matrices specified as \code{obs}, \code{lower}, and \code{upper} arguments. Let's say we have four dimensions called $A$ to $D$ and three observations. All observations have $A = (-1, 1)$ and $B = (-\infty, \infty)$, so in fact, the likelihood is given by the marginal distribution of $A, C, D$. <>= N <- 3 J <- 4 L <- ltMatrices(runif(J * (J + 1) / 2), diag = TRUE, names = LETTERS[1:J]) Z <- matrix(rnorm(J * N), nrow = J) Y <- solve(L, Z) lwrA <- matrix(-1, nrow = 1, ncol = N) uprA <- matrix(1, nrow = 1, ncol = N) rownames(lwrA) <- rownames(uprA) <- "A" lwrB <- matrix(-Inf, nrow = 1, ncol = N) uprB <- matrix(Inf, nrow = 1, ncol = N) rownames(lwrB) <- rownames(uprB) <- "B" lwr <- rbind(lwrA, lwrB) upr <- rbind(uprA, uprB) obs <- Y[rev(LETTERS[3:J]),] ### change order of dimensions @ With this data, we first compute the log-likelihood and score functions for the complete data, that is, including the infinite intervals for $B$. <>= w <- matrix(runif(1000), nrow = 1) lABCD <- logLik(mvnorm(invchol = L), obs = obs, lower = lwr, upper = upr, w = w) sABCD <- lLgrad(mvnorm(invchol = L), obs = obs, lower = lwr, upper = upr, w = w) @ This is (almost) the same as omitting dimension $B$ from the data, but of course not from the model <>= lACD <- logLik(mvnorm(invchol = L), obs = obs, lower = lwrA, upper = uprA) sACD <- lLgrad(mvnorm(invchol = L), obs = obs, lower = lwrA, upper = uprA) @ We can compare the results <>= chk(lABCD, lACD) nm <- names(sABCD) nm <- nm[!nm %in% c("lower", "upper")] chk(sABCD[nm], sACD[nm]) @ noting that the scores with respect to the $B$ data in \code{lower} and \code{upper} are missing from \code{sACD} <>= chk(sABCD$lower["A",,drop = FALSE], sACD$lower) chk(sABCD$upper["A",,drop = FALSE], sACD$upper) sABCD$lower["B",] ### zero sABCD$upper["B",] ### zero @ Omitting dimensions might be important because \code{lpmvnorm} introduced in Chapter~\ref{lpmvnorm} does not check if both \code{lower} and \code{upper} are infinite and omission thus reduces the dimensionality of the integral we evaluate numerically. \chapter{Reduced Rank Covariance Matrices} We sometimes can write the $\J \times \J$ covariance matrix as $\mSigma = \mB \mB^\top + \mD$ where $\mB$ is $\J \times \K$ with $\K < \J$ and $\mD$ is a $\J$-dimensional diagonal matrix. \cite{Marsaglia_1963} and \cite{Genz_Bretz_2009}, in their Chapter 2.3.1, demonstrated that the probability $\Prob(\avec < \rY \le \bvec \mid \mSigma)$ can be written as \begin{eqnarray*} \Prob(\avec < \rY \le \bvec \mid \mSigma ) = \int_{[0,1]^\K} \prod_{j = 1}^J \left(\Phi\left(\frac{b_j - \mB_{jk} \Phi^{-1}(w_k)}{\sqrt{\mD_{jj}}}\right) - \Phi\left(\frac{a_j - \mB_{jk} \Phi^{-1}(w_k)}{\sqrt{\mD_{jj}}}\right)\right) \, d \wvec \end{eqnarray*} where the integration takes place with respect to $\wvec = (w_1, \dots, w_K)^\top$ from the $\K$- (and not $\J$-) dimensional unit hypercube. We start implementing low-level functionality for computing log-probabilities for such structures with some book keeping \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap157}\raggedright\small \NWtarget{nuweb131a}{} $\langle\,${\itshape RR input B D}\nobreak\ {\footnotesize {131a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(!missing(B))@\\ \mbox{}\verb@if (!is.matrix(B)) B <- matrix(B, ncol = 1)@\\ \mbox{}\verb@J <- nrow(B)@\\ \mbox{}\verb@K <- ncol(B)@\\ \mbox{}\verb@Dsqrt <- sqrt(D)@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We use $Z = \Phi^{-1}(w)$ and optional weights and compute the products $\mB_{jk} \Phi^{-1}(w_k)$ for all $j$ and $k$ with standardisation by the diagonal elements of $\mD$. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap158}\raggedright\small \NWtarget{nuweb131b}{} $\langle\,${\itshape RR input Z, weights}\nobreak\ {\footnotesize {131b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@stopifnot(nrow(Z) == K)@\\ \mbox{}\verb@stopifnot(length(weights) == 1 || length(weights) == ncol(Z))@\\ \mbox{}\verb@BZ <- (B / Dsqrt) %*% Z@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} The limits $\avec$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap159}\raggedright\small \NWtarget{nuweb132a}{} $\langle\,${\itshape RR input lower}\nobreak\ {\footnotesize {132a}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (missing(lower)) {@\\ \mbox{}\verb@ pl <- 0@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ stopifnot(length(lower) == J)@\\ \mbox{}\verb@ lower <- c(lower)@\\ \mbox{}\verb@ lower <- (lower - mean) / Dsqrt@\\ \mbox{}\verb@ pl <- pnorm(lBZ <- lower - BZ)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} and $\bvec$ \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap160}\raggedright\small \NWtarget{nuweb132b}{} $\langle\,${\itshape RR input upper}\nobreak\ {\footnotesize {132b}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@if (missing(upper)) {@\\ \mbox{}\verb@ pl <- 0@\\ \mbox{}\verb@} else {@\\ \mbox{}\verb@ stopifnot(length(upper) == J)@\\ \mbox{}\verb@ upper <- c(upper)@\\ \mbox{}\verb@ upper <- (upper - mean) / Dsqrt@\\ \mbox{}\verb@ pu <- pnorm(uBZ <- upper - BZ)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} are processed and we finally compute the integrant, making sure to avoid negative values. We first compute log-probabilities, compute the sums and exponentiate before summing up. In contrast to \code{lpmvnorm}, we also allow weights for the summation, such that sparse grids (for example from add-on package \pkg{SparseGrid}) can be utilised. \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap161}\raggedright\small \NWtarget{nuweb132c}{} $\langle\,${\itshape RR inner}\nobreak\ {\footnotesize {132c}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@inner <- pu - pl@\\ \mbox{}\verb@inner <- pmax(0, inner)@\\ \mbox{}\verb@retw <- weights * exp(.colSums(m = J, n = ncol(Z), @\\ \mbox{}\verb@ x = log(inner), na.rm = TRUE))@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} Finally, we wrap everything up in a function called \code{lpRR} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap162}\raggedright\small \NWtarget{nuweb133}{} $\langle\,${\itshape lpRR}\nobreak\ {\footnotesize {133}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@lpRR <- function(lower, upper, mean = 0, B, D = rep(1, nrow(B)), @\\ \mbox{}\verb@ Z, weights = 1 / ncol(Z), log.p = TRUE) {@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input B D}\nobreak\ {\footnotesize \NWlink{nuweb131a}{131a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input Z, weights}\nobreak\ {\footnotesize \NWlink{nuweb131b}{131b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input lower}\nobreak\ {\footnotesize \NWlink{nuweb132a}{132a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input upper}\nobreak\ {\footnotesize \NWlink{nuweb132b}{132b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR inner}\nobreak\ {\footnotesize \NWlink{nuweb132c}{132c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ ret <- sum(retw)@\\ \mbox{}\verb@ if (log.p) return(log(max(c(0, ret))))@\\ \mbox{}\verb@ return(ret)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We test this functionality for dimensions $\J = 6$ and $\K = 3$. That is, the integration problem reduces from a $\J - 1 = 5$ dimensional one in \code{lpmvnorm} to a three dimensional one in \code{lpRR}. We first compare the two log-probabilities, computed with high accuracy <>= J <- 6 K <- 3 B <- matrix(rnorm(J * K), nrow = J) D <- runif(J) S <- tcrossprod(B) + diag(D) Linv <- t(chol(S)) Linv <- ltMatrices(Linv[lower.tri(Linv, diag = TRUE)], diag = TRUE) a <- -(2 + runif(J)) b <- 2 + runif(J) M <- 1e6 dim(w <- matrix(runif((J - 1) * M), nrow = J - 1)) lpmvnorm(lower = a, upper = b, chol = Linv, w = w) dim(Z <- matrix(rnorm(K * M), nrow = K)) lpRR(lower = a, upper = b, B = B, D = D, Z = Z) @ The score function with respect to $\avec$, $\bvec$, $\mB$, and $\mD$ is \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap163}\raggedright\small \NWtarget{nuweb134}{} $\langle\,${\itshape slpRR}\nobreak\ {\footnotesize {134}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@slpRR <- function(lower, upper, mean = 0, B, D = rep(1, nrow(B)), @\\ \mbox{}\verb@ Z, weights = 1 / ncol(Z), log.p = TRUE) {@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input B D}\nobreak\ {\footnotesize \NWlink{nuweb131a}{131a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input Z, weights}\nobreak\ {\footnotesize \NWlink{nuweb131b}{131b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input lower}\nobreak\ {\footnotesize \NWlink{nuweb132a}{132a}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR input upper}\nobreak\ {\footnotesize \NWlink{nuweb132b}{132b}}$\,\rangle$}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ @\hbox{$\langle\,${\itshape RR inner}\nobreak\ {\footnotesize \NWlink{nuweb132c}{132c}}$\,\rangle$}\verb@@\\ \mbox{}\verb@ @\\ \mbox{}\verb@ dlBZ <- dnorm(lBZ)@\\ \mbox{}\verb@ duBZ <- dnorm(uBZ)@\\ \mbox{}\verb@@\\ \mbox{}\verb@ d <- matrix(retw, nrow = nrow(B), ncol = ncol(Z), byrow = TRUE) / inner@\\ \mbox{}\verb@ db <- d * (duBZ - dlBZ)@\\ \mbox{}\verb@ tdb <- t(db)@\\ \mbox{}\verb@ dB <- -1 * do.call("cbind", lapply(1:nrow(Z), @\\ \mbox{}\verb@ function(r) colSums(tdb * Z[r,], na.rm = TRUE))) / Dsqrt@\\ \mbox{}\verb@ Du <- -.5 / D * uBZ@\\ \mbox{}\verb@ Dl <- -.5 / D * lBZ@\\ \mbox{}\verb@ dD <- rowSums(d * duBZ * Du, na.rm = TRUE) - @\\ \mbox{}\verb@ rowSums(d * dlBZ * Dl, na.rm = TRUE)@\\ \mbox{}\verb@ dl <- -rowSums(d * dlBZ, na.rm = TRUE) / Dsqrt@\\ \mbox{}\verb@ du <- rowSums(d * duBZ, na.rm = TRUE) / Dsqrt@\\ \mbox{}\verb@ dm <- -du - dl # Dinb %*% -rowSums(d * (duBZ - dlBZ))@\\ \mbox{}\verb@ fct <- 1@\\ \mbox{}\verb@ if (log.p) fct <- 1 / sum(retw)@\\ \mbox{}\verb@ list(lower = fct * dl, upper = fct * du, mean = fct * dm, @\\ \mbox{}\verb@ B = fct * dB, D = fct * dD)@\\ \mbox{}\verb@}@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb64}{64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} We can now compare the gradients for $\avec$, $\bvec$ and the mean in our small example. We cannot expect them to be equal but close <>= smv <- slpmvnorm(lower = a, upper = b, chol = Linv, w = w) sRR <- slpRR(lower = a, upper = b, B = B, D = D, Z = Z) chk(c(smv$lower), sRR$lower, tolerance = 1e-2) chk(c(smv$upper), sRR$upper, tolerance = 1e-2) chk(c(smv$mean), sRR$mean, tolerance = 1e-2) @ The gradient with respect to $\mB$ and $\mD$ are finally checked against their numerical approximations <>= Z <- matrix(rnorm(K * 1000), nrow = K) lB <- function(B) lpRR(lower = a, upper = b, B = B, D = D, Z = Z) gB <- grad(lB, B) sRR <- slpRR(lower = a, upper = b, B = B, D = D, Z = Z) chk(gB, c(sRR$B), tolerance = 1e-3) lD <- function(D) lpRR(lower = a, upper = b, B = B, D = D, Z = Z) gD <- grad(lD, D) chk(gD, c(sRR$D), tolerance = 1e-3) ### while we are at it, check lower and again llwr <- function(a) lpRR(lower = a, upper = b, B = B, D = D, Z = Z) glwr <- grad(llwr, a) chk(glwr, c(sRR$lower)) lupr <- function(b) lpRR(lower = a, upper = b, B = B, D = D, Z = Z) gupr <- grad(lupr, b) chk(gupr, c(sRR$upper)) @ \chapter{Package Infrastructure} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap164}\raggedright\small \NWtarget{nuweb136}{} $\langle\,${\itshape R Header}\nobreak\ {\footnotesize {136}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@### Copyright (C) 2022- Torsten Hothorn@\\ \mbox{}\verb@###@\\ \mbox{}\verb@### This file is part of the 'mvtnorm' R add-on package.@\\ \mbox{}\verb@###@\\ \mbox{}\verb@### 'mvtnorm' is free software: you can redistribute it and/or modify@\\ \mbox{}\verb@### it under the terms of the GNU General Public License as published by@\\ \mbox{}\verb@### the Free Software Foundation, version 2.@\\ \mbox{}\verb@###@\\ \mbox{}\verb@### 'mvtnorm' is distributed in the hope that it will be useful,@\\ \mbox{}\verb@### but WITHOUT ANY WARRANTY; without even the implied warranty of@\\ \mbox{}\verb@### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the@\\ \mbox{}\verb@### GNU General Public License for more details.@\\ \mbox{}\verb@###@\\ \mbox{}\verb@### You should have received a copy of the GNU General Public License@\\ \mbox{}\verb@### along with 'mvtnorm'. If not, see .@\\ \mbox{}\verb@###@\\ \mbox{}\verb@###@\\ \mbox{}\verb@### DO NOT EDIT THIS FILE@\\ \mbox{}\verb@###@\\ \mbox{}\verb@### Edit 'lmvnorm_src.w' and run 'nuweb -r lmvnorm_src.w'@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb2}{2}\NWlink{nuweb64}{, 64}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \begin{flushleft} \small \begin{minipage}{\linewidth}\label{scrap165}\raggedright\small \NWtarget{nuweb137}{} $\langle\,${\itshape C Header}\nobreak\ {\footnotesize {137}}$\,\rangle\equiv$ \vspace{-1ex} \begin{list}{}{} \item \mbox{}\verb@@\\ \mbox{}\verb@/*@\\ \mbox{}\verb@ Copyright (C) 2022- Torsten Hothorn@\\ \mbox{}\verb@@\\ \mbox{}\verb@ This file is part of the 'mvtnorm' R add-on package.@\\ \mbox{}\verb@@\\ \mbox{}\verb@ 'mvtnorm' is free software: you can redistribute it and/or modify@\\ \mbox{}\verb@ it under the terms of the GNU General Public License as published by@\\ \mbox{}\verb@ the Free Software Foundation, version 2.@\\ \mbox{}\verb@@\\ \mbox{}\verb@ 'mvtnorm' is distributed in the hope that it will be useful,@\\ \mbox{}\verb@ but WITHOUT ANY WARRANTY; without even the implied warranty of@\\ \mbox{}\verb@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the@\\ \mbox{}\verb@ GNU General Public License for more details.@\\ \mbox{}\verb@@\\ \mbox{}\verb@ You should have received a copy of the GNU General Public License@\\ \mbox{}\verb@ along with 'mvtnorm'. If not, see .@\\ \mbox{}\verb@@\\ \mbox{}\verb@@\\ \mbox{}\verb@ DO NOT EDIT THIS FILE@\\ \mbox{}\verb@@\\ \mbox{}\verb@ Edit 'lmvnorm_src.w' and run 'nuweb -r lmvnorm_src.w'@\\ \mbox{}\verb@*/@\\ \mbox{}\verb@@{\NWsep} \end{list} \vspace{-1.5ex} \footnotesize \begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \NWtxtMacroRefIn\ \NWlink{nuweb3}{3}\NWlink{nuweb65}{, 65}. \item{} \end{list} \end{minipage}\vspace{4ex} \end{flushleft} \chapter*{Appendix} This document uses the following matrix derivatives \begin{eqnarray*} \frac{\partial \yvec^\top \mA^\top \mA \yvec}{\partial \mA} & = & 2 \mA \yvec \yvec^\top \\ \frac{\partial \mA^{-1}}{\partial \mA} & = & -(\mA^{-\top} \otimes \mA^{-1}) \\ \frac{\partial \mA \mA^\top}{\partial \mA} & = & (\mA \otimes \mI_J) \frac{\partial \mA}{\partial \mA} + (\mI_J \otimes \mA) \frac{\partial \mA^\top}{\partial \mA} \\ & = & (\mA \otimes \mI_J) + (\mI_J \otimes \mA) \frac{\partial \mA^\top}{\partial \mA} \\ \frac{\partial \diag(\mA)}{\partial \mA} & = & \diag(\vecop(\mI_J)) \\ \frac{\partial \mA}{\partial \mA} & = & \diag(I_{J^2}) \\ \frac{\partial \yvec^\top \mA \yvec}{\partial \yvec} & = & \yvec^\top (\mA + \mA^\top) \\ \frac{\partial \mB \mA}{\partial \mA} & = & (\mI_J \otimes \mB) \end{eqnarray*} and the ``vec trick'' $\vecop(\rX)^\top (\mB \otimes \mA^\top) = \vecop(\mA \rX \mB)^\top$. \chapter*{Index} \section*{Files} {\small\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item \verb@"interface.R"@ {\footnotesize {\NWtxtDefBy} \NWlink{nuweb114a}{114a}.} \item \verb@"lpmvnorm.c"@ {\footnotesize {\NWtxtDefBy} \NWlink{nuweb65}{65}.} \item \verb@"lpmvnorm.R"@ {\footnotesize {\NWtxtDefBy} \NWlink{nuweb64}{64}.} \item \verb@"ltMatrices.c"@ {\footnotesize {\NWtxtDefBy} \NWlink{nuweb3}{3}.} \item \verb@"ltMatrices.R"@ {\footnotesize {\NWtxtDefBy} \NWlink{nuweb2}{2}.} \end{list}} \section*{Fragments} {\small\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} \item $\langle\,$.subset ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb13}{13}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb14}{14}.} \item $\langle\,$add diagonal elements\nobreak\ {\footnotesize \NWlink{nuweb20}{20}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$aperm\nobreak\ {\footnotesize \NWlink{nuweb51a}{51a}\NWlink{nuweb51b}{b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$aperm checks\nobreak\ {\footnotesize \NWlink{nuweb50}{50}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb51a}{51a}.} \item $\langle\,$argchecks\nobreak\ {\footnotesize \NWlink{nuweb121}{121}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb122c}{122c}\NWlink{nuweb127}{, 127}. } \item $\langle\,$as.ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb114b}{114b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$assign diagonal elements\nobreak\ {\footnotesize \NWlink{nuweb21}{21}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$C Header\nobreak\ {\footnotesize \NWlink{nuweb137}{137}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}\NWlink{nuweb65}{, 65}. } \item $\langle\,$C length\nobreak\ {\footnotesize \NWlink{nuweb24a}{24a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb24b}{24b}\NWlink{nuweb26}{, 26}\NWlink{nuweb29}{, 29}\NWlink{nuweb33a}{, 33a}\NWlink{nuweb42a}{, 42a}. } \item $\langle\,$check A argument\nobreak\ {\footnotesize \NWlink{nuweb43b}{43b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb44}{44}.} \item $\langle\,$check and / or set integration weights\nobreak\ {\footnotesize \NWlink{nuweb74b}{74b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. } \item $\langle\,$check C argument\nobreak\ {\footnotesize \NWlink{nuweb42b}{42b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb44}{44}.} \item $\langle\,$check obs\nobreak\ {\footnotesize \NWlink{nuweb57b}{57b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$check S argument\nobreak\ {\footnotesize \NWlink{nuweb43a}{43a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb44}{44}.} \item $\langle\,$chol\nobreak\ {\footnotesize \NWlink{nuweb40}{40}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$chol classes\nobreak\ {\footnotesize \NWlink{nuweb45}{45}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb48}{48}.} \item $\langle\,$chol scores\nobreak\ {\footnotesize \NWlink{nuweb77a}{77a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb77e}{77e}.} \item $\langle\,$chol syMatrices\nobreak\ {\footnotesize \NWlink{nuweb39}{39}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$Cholesky of precision\nobreak\ {\footnotesize \NWlink{nuweb74c}{74c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. } \item $\langle\,$colSumsdnorm\nobreak\ {\footnotesize \NWlink{nuweb58a}{58a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$colSumsdnorm ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb58b}{58b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$compute x\nobreak\ {\footnotesize \NWlink{nuweb68b}{68b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. } \item $\langle\,$compute y\nobreak\ {\footnotesize \NWlink{nuweb68a}{68a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. } \item $\langle\,$cond general\nobreak\ {\footnotesize \NWlink{nuweb53}{53}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb55}{55}.} \item $\langle\,$cond simple\nobreak\ {\footnotesize \NWlink{nuweb54}{54}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb55}{55}.} \item $\langle\,$conditional\nobreak\ {\footnotesize \NWlink{nuweb55}{55}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$convenience functions\nobreak\ {\footnotesize \NWlink{nuweb48}{48}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$crossprod ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb38}{38}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$D times C\nobreak\ {\footnotesize \NWlink{nuweb46}{46}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb48}{48}.} \item $\langle\,$deperma\nobreak\ {\footnotesize \NWlink{nuweb106}{106}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$deperma indices\nobreak\ {\footnotesize \NWlink{nuweb105b}{105b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb106}{106}.} \item $\langle\,$deperma input checks chol\nobreak\ {\footnotesize \NWlink{nuweb104a}{104a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb106}{106}.} \item $\langle\,$deperma input checks perm\nobreak\ {\footnotesize \NWlink{nuweb104b}{104b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb106}{106}.} \item $\langle\,$deperma input checks schol\nobreak\ {\footnotesize \NWlink{nuweb105a}{105a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb106}{106}.} \item $\langle\,$destandardize\nobreak\ {\footnotesize \NWlink{nuweb110}{110}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$diagonal matrix\nobreak\ {\footnotesize \NWlink{nuweb22}{22}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$diagonals ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb19}{19}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$dim ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb6c}{6c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$dimensions\nobreak\ {\footnotesize \NWlink{nuweb71c}{71c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \item $\langle\,$dimnames ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb7a}{7a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$dp input checks\nobreak\ {\footnotesize \NWlink{nuweb98}{98}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb99}{99}\NWlink{nuweb101}{, 101}. } \item $\langle\,$extract slots\nobreak\ {\footnotesize \NWlink{nuweb10}{10}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb11}{11}\NWlink{nuweb12}{, 12}\NWlink{nuweb13}{, 13}\NWlink{nuweb17}{, 17}\NWlink{nuweb19}{, 19}\NWlink{nuweb21}{, 21}\NWlink{nuweb23a}{, 23a}\NWlink{nuweb27}{, 27}. } \item $\langle\,$first element\nobreak\ {\footnotesize \NWlink{nuweb34a}{34a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb34b}{34b}\NWlink{nuweb35a}{, 35a}. } \item $\langle\,$IDX\nobreak\ {\footnotesize \NWlink{nuweb35b}{35b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb36}{36}\NWlink{nuweb42a}{, 42a}. } \item $\langle\,$increment\nobreak\ {\footnotesize \NWlink{nuweb69c}{69c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}.} \item $\langle\,$init center\nobreak\ {\footnotesize \NWlink{nuweb72c}{72c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \item $\langle\,$init dans\nobreak\ {\footnotesize \NWlink{nuweb83b}{83b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb84}{84}.} \item $\langle\,$init logLik loop\nobreak\ {\footnotesize \NWlink{nuweb67c}{67c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb78c}{, 78c}. } \item $\langle\,$init random seed, reset on exit\nobreak\ {\footnotesize \NWlink{nuweb74a}{74a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. } \item $\langle\,$init score loop\nobreak\ {\footnotesize \NWlink{nuweb78c}{78c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb84}{84}.} \item $\langle\,$initialisation\nobreak\ {\footnotesize \NWlink{nuweb67b}{67b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \item $\langle\,$inner logLik loop\nobreak\ {\footnotesize \NWlink{nuweb69b}{69b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}.} \item $\langle\,$inner score loop\nobreak\ {\footnotesize \NWlink{nuweb82b}{82b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb84}{84}.} \item $\langle\,$input checks\nobreak\ {\footnotesize \NWlink{nuweb66}{66}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb63}{63}\NWlink{nuweb75}{, 75}\NWlink{nuweb87}{, 87}. } \item $\langle\,$is.ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb7c}{7c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$kronecker vec trick\nobreak\ {\footnotesize \NWlink{nuweb44}{44}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$L times D\nobreak\ {\footnotesize \NWlink{nuweb47}{47}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb48}{48}.} \item $\langle\,$lapack options\nobreak\ {\footnotesize \NWlink{nuweb28}{28}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb29}{29}\NWlink{nuweb30}{, 30}. } \item $\langle\,$ldmvnorm\nobreak\ {\footnotesize \NWlink{nuweb57a}{57a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$ldmvnorm chol\nobreak\ {\footnotesize \NWlink{nuweb59a}{59a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb57a}{57a}.} \item $\langle\,$ldmvnorm invchol\nobreak\ {\footnotesize \NWlink{nuweb59b}{59b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb57a}{57a}.} \item $\langle\,$ldpmvnorm\nobreak\ {\footnotesize \NWlink{nuweb99}{99}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$lLgrad chol\nobreak\ {\footnotesize \NWlink{nuweb123a}{123a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb127}{127}.} \item $\langle\,$lLgrad deperma\nobreak\ {\footnotesize \NWlink{nuweb124b}{124b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb123a}{123a}.} \item $\langle\,$lLgrad destandarized\nobreak\ {\footnotesize \NWlink{nuweb124c}{124c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb123a}{123a}.} \item $\langle\,$lLgrad diagonals\nobreak\ {\footnotesize \NWlink{nuweb125a}{125a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb123a}{123a}.} \item $\langle\,$lLgrad invchol\nobreak\ {\footnotesize \NWlink{nuweb126}{126}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb127}{127}.} \item $\langle\,$lLgrad marginalisation\nobreak\ {\footnotesize \NWlink{nuweb124a}{124a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb123a}{123a}.} \item $\langle\,$lLgrad mean\nobreak\ {\footnotesize \NWlink{nuweb123b}{123b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb123a}{123a}.} \item $\langle\,$lLgrad return\nobreak\ {\footnotesize \NWlink{nuweb125b}{125b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb123a}{123a}.} \item $\langle\,$logdet\nobreak\ {\footnotesize \NWlink{nuweb33a}{33a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$logdet ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb33b}{33b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$logLik chol\nobreak\ {\footnotesize \NWlink{nuweb122a}{122a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb122c}{122c}.} \item $\langle\,$logLik invchol\nobreak\ {\footnotesize \NWlink{nuweb122b}{122b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb122c}{122c}.} \item $\langle\,$lower scores\nobreak\ {\footnotesize \NWlink{nuweb77c}{77c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb77e}{77e}.} \item $\langle\,$lower triangular elements\nobreak\ {\footnotesize \NWlink{nuweb17}{17}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$lpmvnorm\nobreak\ {\footnotesize \NWlink{nuweb75}{75}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$lpmvnormR\nobreak\ {\footnotesize \NWlink{nuweb63}{63}}$\,\rangle$ {\footnotesize {\NWtxtNoRef}.} \item $\langle\,$lpRR\nobreak\ {\footnotesize \NWlink{nuweb133}{133}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb6a}{6a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$ltMatrices dim\nobreak\ {\footnotesize \NWlink{nuweb4}{4}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb6a}{6a}.} \item $\langle\,$ltMatrices input\nobreak\ {\footnotesize \NWlink{nuweb5b}{5b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb6a}{6a}.} \item $\langle\,$ltMatrices names\nobreak\ {\footnotesize \NWlink{nuweb5a}{5a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb6a}{6a}.} \item $\langle\,$marginal\nobreak\ {\footnotesize \NWlink{nuweb52b}{52b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$mc input checks\nobreak\ {\footnotesize \NWlink{nuweb52a}{52a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb52b}{52b}\NWlink{nuweb55}{, 55}. } \item $\langle\,$mean scores\nobreak\ {\footnotesize \NWlink{nuweb77b}{77b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb77e}{77e}.} \item $\langle\,$move on\nobreak\ {\footnotesize \NWlink{nuweb70a}{70a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \item $\langle\,$mult\nobreak\ {\footnotesize \NWlink{nuweb24b}{24b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$mult ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb23a}{23a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$mult ltMatrices transpose\nobreak\ {\footnotesize \NWlink{nuweb25}{25}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb23a}{23a}.} \item $\langle\,$mult syMatrices\nobreak\ {\footnotesize \NWlink{nuweb27}{27}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$mult transpose\nobreak\ {\footnotesize \NWlink{nuweb26}{26}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$mvnorm\nobreak\ {\footnotesize \NWlink{nuweb116a}{116a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$mvnorm chol invchol\nobreak\ {\footnotesize \NWlink{nuweb115a}{115a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb116a}{116a}.} \item $\langle\,$mvnorm condDist\nobreak\ {\footnotesize \NWlink{nuweb119}{119}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$mvnorm lLgrad\nobreak\ {\footnotesize \NWlink{nuweb127}{127}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$mvnorm logLik\nobreak\ {\footnotesize \NWlink{nuweb122c}{122c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$mvnorm margDist\nobreak\ {\footnotesize \NWlink{nuweb118}{118}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$mvnorm mean\nobreak\ {\footnotesize \NWlink{nuweb115b}{115b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb116a}{116a}.} \item $\langle\,$mvnorm methods\nobreak\ {\footnotesize \NWlink{nuweb116b}{116b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$mvnorm simulate\nobreak\ {\footnotesize \NWlink{nuweb117}{117}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb114a}{114a}.} \item $\langle\,$names ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb7b}{7b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$new score means, lower and upper\nobreak\ {\footnotesize \NWlink{nuweb81a}{81a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$output\nobreak\ {\footnotesize \NWlink{nuweb69d}{69d}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}.} \item $\langle\,$pnorm\nobreak\ {\footnotesize \NWlink{nuweb71a}{71a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \item $\langle\,$pnorm fast\nobreak\ {\footnotesize \NWlink{nuweb70b}{70b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb65}{65}.} \item $\langle\,$pnorm slow\nobreak\ {\footnotesize \NWlink{nuweb70c}{70c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb65}{65}.} \item $\langle\,$post differentiate chol score\nobreak\ {\footnotesize \NWlink{nuweb85d}{85d}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb87}{87}.} \item $\langle\,$post differentiate invchol score\nobreak\ {\footnotesize \NWlink{nuweb86a}{86a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb87}{87}.} \item $\langle\,$post differentiate lower score\nobreak\ {\footnotesize \NWlink{nuweb85b}{85b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb87}{87}.} \item $\langle\,$post differentiate mean score\nobreak\ {\footnotesize \NWlink{nuweb85a}{85a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb87}{87}.} \item $\langle\,$post differentiate upper score\nobreak\ {\footnotesize \NWlink{nuweb85c}{85c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb87}{87}.} \item $\langle\,$post process score\nobreak\ {\footnotesize \NWlink{nuweb86b}{86b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb87}{87}.} \item $\langle\,$print ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb11}{11}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$R Header\nobreak\ {\footnotesize \NWlink{nuweb136}{136}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}\NWlink{nuweb64}{, 64}. } \item $\langle\,$R lpmvnorm\nobreak\ {\footnotesize \NWlink{nuweb73}{73}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb65}{65}.} \item $\langle\,$R slpmvnorm\nobreak\ {\footnotesize \NWlink{nuweb84}{84}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb65}{65}.} \item $\langle\,$R slpmvnorm variables\nobreak\ {\footnotesize \NWlink{nuweb72d}{72d}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \item $\langle\,$RC input\nobreak\ {\footnotesize \NWlink{nuweb23b}{23b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb24b}{24b}\NWlink{nuweb26}{, 26}\NWlink{nuweb29}{, 29}\NWlink{nuweb30}{, 30}\NWlink{nuweb33a}{, 33a}\NWlink{nuweb36}{, 36}\NWlink{nuweb42a}{, 42a}. } \item $\langle\,$reorder ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb12}{12}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$RR inner\nobreak\ {\footnotesize \NWlink{nuweb132c}{132c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. } \item $\langle\,$RR input B D\nobreak\ {\footnotesize \NWlink{nuweb131a}{131a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. } \item $\langle\,$RR input lower\nobreak\ {\footnotesize \NWlink{nuweb132a}{132a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. } \item $\langle\,$RR input upper\nobreak\ {\footnotesize \NWlink{nuweb132b}{132b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. } \item $\langle\,$RR input Z, weights\nobreak\ {\footnotesize \NWlink{nuweb131b}{131b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb133}{133}\NWlink{nuweb134}{, 134}. } \item $\langle\,$score a, b\nobreak\ {\footnotesize \NWlink{nuweb78b}{78b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb78c}{78c}\NWlink{nuweb84}{, 84}. } \item $\langle\,$score c11\nobreak\ {\footnotesize \NWlink{nuweb78a}{78a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb78c}{78c}\NWlink{nuweb84}{, 84}. } \item $\langle\,$score output\nobreak\ {\footnotesize \NWlink{nuweb83a}{83a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb84}{84}.} \item $\langle\,$score output object\nobreak\ {\footnotesize \NWlink{nuweb77e}{77e}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb84}{84}.} \item $\langle\,$score wrt new chol diagonal\nobreak\ {\footnotesize \NWlink{nuweb80b}{80b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$score wrt new chol off-diagonals\nobreak\ {\footnotesize \NWlink{nuweb80a}{80a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$setup return object\nobreak\ {\footnotesize \NWlink{nuweb72a}{72a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}.} \item $\langle\,$sldmvnorm\nobreak\ {\footnotesize \NWlink{nuweb61}{61}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$sldpmvnorm\nobreak\ {\footnotesize \NWlink{nuweb101}{101}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$sldpmvnorm invchol\nobreak\ {\footnotesize \NWlink{nuweb100}{100}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb101}{101}.} \item $\langle\,$slpmvnorm\nobreak\ {\footnotesize \NWlink{nuweb87}{87}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$slpRR\nobreak\ {\footnotesize \NWlink{nuweb134}{134}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$solve\nobreak\ {\footnotesize \NWlink{nuweb29}{29}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$solve C\nobreak\ {\footnotesize \NWlink{nuweb30}{30}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$solve ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb31}{31}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$standardise\nobreak\ {\footnotesize \NWlink{nuweb67a}{67a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb75}{75}\NWlink{nuweb87}{, 87}. } \item $\langle\,$standardize\nobreak\ {\footnotesize \NWlink{nuweb108}{108}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb64}{64}.} \item $\langle\,$subset ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb14}{14}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$syMatrices\nobreak\ {\footnotesize \NWlink{nuweb6b}{6b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$t(C) S t(A)\nobreak\ {\footnotesize \NWlink{nuweb41}{41}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb42a}{42a}.} \item $\langle\,$tcrossprod\nobreak\ {\footnotesize \NWlink{nuweb36}{36}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$tcrossprod diagonal only\nobreak\ {\footnotesize \NWlink{nuweb34b}{34b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb36}{36}.} \item $\langle\,$tcrossprod full\nobreak\ {\footnotesize \NWlink{nuweb35a}{35a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb36}{36}.} \item $\langle\,$tcrossprod ltMatrices\nobreak\ {\footnotesize \NWlink{nuweb37}{37}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb2}{2}.} \item $\langle\,$univariate problem\nobreak\ {\footnotesize \NWlink{nuweb72b}{72b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}.} \item $\langle\,$update d, e\nobreak\ {\footnotesize \NWlink{nuweb68c}{68c}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. } \item $\langle\,$update f\nobreak\ {\footnotesize \NWlink{nuweb69a}{69a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb69b}{69b}\NWlink{nuweb82b}{, 82b}. } \item $\langle\,$update score for chol\nobreak\ {\footnotesize \NWlink{nuweb81b}{81b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$update score means, lower and upper\nobreak\ {\footnotesize \NWlink{nuweb82a}{82a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$update yp for chol\nobreak\ {\footnotesize \NWlink{nuweb79a}{79a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$update yp for means, lower and upper\nobreak\ {\footnotesize \NWlink{nuweb79b}{79b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb82b}{82b}.} \item $\langle\,$upper scores\nobreak\ {\footnotesize \NWlink{nuweb77d}{77d}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb77e}{77e}.} \item $\langle\,$vec trick\nobreak\ {\footnotesize \NWlink{nuweb42a}{42a}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb3}{3}.} \item $\langle\,$W length\nobreak\ {\footnotesize \NWlink{nuweb71b}{71b}}$\,\rangle$ {\footnotesize {\NWtxtRefIn} \NWlink{nuweb73}{73}\NWlink{nuweb84}{, 84}. } \end{list}} %\section*{Identifiers} % % \bibliographystyle{plainnat} \bibliography{\Sexpr{gsub("\\.bib", "", system.file("litdb.bib", package = "mvtnorm"))}} \end{document}