{"id":32202742,"url":"https://github.com/boennecd/mdgc","last_synced_at":"2025-10-22T04:12:10.279Z","repository":{"id":56934846,"uuid":"284975214","full_name":"boennecd/mdgc","owner":"boennecd","description":"Provides functions to impute missing values using Gaussian copulas for mixed data types.","archived":false,"fork":false,"pushed_at":"2023-05-12T13:39:01.000Z","size":1610,"stargazers_count":9,"open_issues_count":0,"forks_count":2,"subscribers_count":2,"default_branch":"master","last_synced_at":"2023-11-20T10:47:27.277Z","etag":null,"topics":["binary","gaussian-copula","imputation","multinomial-variables","ordinal","semi-parametric"],"latest_commit_sha":null,"homepage":"","language":"C++","has_issues":true,"has_wiki":null,"has_pages":null,"mirror_url":null,"source_name":null,"license":null,"status":null,"scm":"git","pull_requests_enabled":true,"icon_url":"https://github.com/boennecd.png","metadata":{"files":{"readme":"README.Rmd","changelog":null,"contributing":null,"funding":null,"license":null,"code_of_conduct":null,"threat_model":null,"audit":null,"citation":null,"codeowners":null,"security":null,"support":null}},"created_at":"2020-08-04T12:37:43.000Z","updated_at":"2023-09-08T07:29:37.000Z","dependencies_parsed_at":"2022-08-21T06:50:44.594Z","dependency_job_id":null,"html_url":"https://github.com/boennecd/mdgc","commit_stats":null,"previous_names":[],"tags_count":7,"template":null,"template_full_name":null,"purl":"pkg:github/boennecd/mdgc","repository_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmdgc","tags_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmdgc/tags","releases_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmdgc/releases","manifests_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmdgc/manifests","owner_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/owners/boennecd","download_url":"https://codeload.github.com/boennecd/mdgc/tar.gz/refs/heads/master","sbom_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmdgc/sbom","scorecard":null,"host":{"name":"GitHub","url":"https://github.com","kind":"github","repositories_count":280377332,"owners_count":26320454,"icon_url":"https://github.com/github.png","version":null,"created_at":"2022-05-30T11:31:42.601Z","updated_at":"2022-07-04T15:15:14.044Z","status":"online","status_checked_at":"2025-10-22T02:00:06.515Z","response_time":63,"last_error":null,"robots_txt_status":"success","robots_txt_updated_at":"2025-07-24T06:49:26.215Z","robots_txt_url":"https://github.com/robots.txt","online":true,"can_crawl_api":true,"host_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub","repositories_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories","repository_names_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repository_names","owners_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/owners"}},"keywords":["binary","gaussian-copula","imputation","multinomial-variables","ordinal","semi-parametric"],"created_at":"2025-10-22T04:12:06.128Z","updated_at":"2025-10-22T04:12:10.267Z","avatar_url":"https://github.com/boennecd.png","language":"C++","funding_links":[],"categories":[],"sub_categories":[],"readme":"---\noutput:\n  github_document:\n    pandoc_args: --webtex=https://render.githubusercontent.com/render/math?math=\nbibliography: ref.bib\n---\n\n```{r setup, include = FALSE}\nknitr::opts_chunk$set(\n  collapse = TRUE,\n  comment = \"#\u003e\",\n  fig.path = \"man/figures/README-\",\n  out.width = \"100%\")\noptions(digits = 3)\n```\n\n# mdgc\n\n[![R-CMD-check](https://github.com/boennecd/mdgc/workflows/R-CMD-check/badge.svg)](https://github.com/boennecd/mdgc/actions) \n[![](https://www.r-pkg.org/badges/version/mdgc)](http://cran.rstudio.com/web/packages/mdgc/index.html) \n[![CRAN RStudio mirror\ndownloads](http://cranlogs.r-pkg.org/badges/mdgc)](http://cran.rstudio.com/web/packages/mdgc/index.html)\n\nThis package contains a marginal likelihood approach to estimating the \nmodel discussed by @hoff07, @zhao20, and @zhao20Mat. That is, a missing data approach\nwhere one uses Gaussian copulas in the latter case. \nWe have modified the Fortran\ncode by @Genz02 to supply an approximation of the gradient for the log \nmarginal likelihood and to use an approximation of the marginal likelihood \nsimilar to the CDF approximation in @Genz02. We have also used the same \nFortran code to perform the imputation conditional on a covariance matrix\nand the observed data. The method is described by @Christoffersen21 which can \nbe found at [arxiv.org](https://arxiv.org/abs/2102.02642).\n\nImportantly, we also extend the model used by @zhao20 to support multinomial \nvariables. Thus, our model supports both continuous, binary, ordinal, and \nmultinomial variables which makes it applicable to a large number of data sets.\n\nThe package can be useful for a lot of other models. For instance, \nthe methods are directly applicable to other Gaussian copula models and some \nmixed effect models. All methods are implemented in C++, support computation \nin parallel, and should easily be able to be ported to other languages. \n\n## Installation\nThe package can be installed from Github by calling:\n\n```{r, eval = FALSE}\nremotes::install_github(\"boennecd/mdgc\")\n```\n\nor from CRAN by calling:\n\n```{r, eval = FALSE}\ninstall.packages(\"mdgc\")\n```\n\nThe code benefits from being build with automatic vectorization so having e.g.  \n`-O3 -mtune=native` in the `CXX11FLAGS` flags in your Makevars file may be \nuseful.\n\n## The Model\nWe observe four types of variables for each observation: continuous, \nbinary, ordinal, and multinomial variables. Let $\\vec X_i$ be a K\ndimensional vector for the i'th observation. The variables $X_{ij}$ are \ncontinuous \nif $j\\in\\mathcal C$, binary if $j\\in\\mathcal B$ with probability $p_j$ of \nbeing true, ordinal if $j\\in\\mathcal O$ with $m_j$ levels and borders \n$\\alpha_{j0} = -\\infty \u003c \\alpha_1\u003c\\cdots \u003c \\alpha_{m_j} = \\infty$, and \nmultinomial if $j\\in\\mathcal M$ with $m_j$ levels. $\\mathcal C$, \n$\\mathcal B$, $\\mathcal O$, and $\\mathcal M$ are mutually exclusive.\n\nWe assume that there is\na latent variable $\\vec Z_i$ which is multivariate normally distributed such \nthat:\n\n\u003c!-- $$ --\u003e\n\u003c!-- \\begin{align*} --\u003e\n\u003c!-- \\vec Z_i \u0026 \\sim N\\left(\\vec\\mu, --\u003e\n\u003c!--   \\Sigma\\right) \\nonumber\\\\ --\u003e\n\u003c!-- X_{ij} \u0026= f_j(Z_{ih(j)}) \u0026 j \u0026\\in \\mathcal C \\\\ --\u003e\n\u003c!-- X_{ij} \u0026= \\begin{cases} --\u003e\n\u003c!--   1 \u0026 Z_{ij} \u003e \\underbrace{-\\Phi^{-1}(p_{j})}_{\\mu_{h(j)}} \\\\ --\u003e\n\u003c!--   0 \u0026 \\text{otherwise}   --\u003e\n\u003c!-- \\end{cases} \u0026 j \u0026\\in \\mathcal B \\\\ --\u003e\n\u003c!-- X_{ij} \u0026= k\\Leftrightarrow \\alpha_{jk} \u003c Z_{ih(j)} \\leq \\alpha_{j,k + 1} --\u003e\n\u003c!--   \u0026 j \u0026\\in \\mathcal O\\wedge k = 0,\\dots m_j -1 \\\\ --\u003e\n\u003c!-- X_{ij} \u0026= k \\Leftrightarrow Z_{i,h(j) + k} \\geq --\u003e\n\u003c!--   \\max(Z_{ih(j)},\\cdots,Z_{i,h(j) + m_j - 1}) --\u003e\n\u003c!--   \u0026 j\u0026\\in \\mathcal M \\wedge k = 0,\\dots m_j -1 --\u003e\n\u003c!-- \\end{align*} --\u003e\n\u003c!-- $$ --\u003e\n\n$$\\begin{align*}  \\vec Z_i \u0026 \\sim N\\left(\\vec\\mu,    \\Sigma\\right) \\nonumber\\\\  X_{ij} \u0026= f_j(Z_{ih(j)}) \u0026 j \u0026\\in \\mathcal C \\\\  X_{ij} \u0026= 1_{\\{Z_{ih(j)} \u003e \\underbrace{-\\Phi^{-1}(p_{j})}_{\\mu_{h(j)}}\\}} \u0026 j \u0026\\in \\mathcal B \\\\  X_{ij} \u0026= k\\Leftrightarrow \\alpha_{jk} \u003c Z_{ih(j)} \\leq \\alpha_{j,k + 1}    \u0026 j \u0026\\in \\mathcal O\\wedge k = 0,\\dots m_j -1 \\\\  X_{ij} \u0026= k \\Leftrightarrow Z_{i,h(j) + k} \\geq    \\max(Z_{ih(j)},\\cdots,Z_{i,h(j) + m_j - 1})    \u0026 j\u0026\\in \\mathcal M \\wedge k = 0,\\dots m_j -1  \\end{align*}$$\n\nwhere $1_{\\{\\cdot\\}}$ is one if the condition in the subscript is true and zero \notherwise, $h(j)$ is a map to the index of the first latent variable associated with \nthe j'th variable in $\\vec X_i$ and $f_j$ is a bijective function. We only \nestimate some of the means, the $\\vec\\mu$, and some of the covariance \nparameters. Furthermore, we set $Z_{ih(j)} = 0$ if $j\\in\\mathcal M$ and assume\nthat the variable is uncorrelated with all the other $\\vec Z_i$'s.\n\nIn principle, we could use other distributions than a multivariate normal \ndistribution for $\\vec Z_i$. However, the multivariate normal distribution\nhas the advantage that it is very easy to marginalize which is convenient when \nwe have to estimate the model with missing entries and it is also has some \ncomputational advantages for approximating the log marginal likelihood as \nsimilar intractable problem have been thoroughly studied.\n\n## Examples\nBelow, we provide an example similar to @zhao20 [Section 7.1]. The authors \nuse a data set with a random correlation matrix, 5 continuous variables, \n5 binary variables, and 5 ordinal variables with 5 levels. There is a total \nof 2000 observations and 30% of the variables are missing completely at \nrandom.\n\nTo summarize @zhao20 results, they show that their approximate EM algorithm \nconverges in what seems to be 20-25 seconds (this is with a pure R \nimplementation to be fair) while it takes more than 150\nseconds for the MCMC algorithm used by @hoff07. These figures\nshould be kept in mind when looking at the results below. Importantly, \n@zhao20 use an approximation in the E-step of an EM algorithm which is \nfast but might be crude in some settings. Using a potentially arbitrarily \nprecise approximation of the log  marginal likelihood is useful if this can \nbe done quickly enough.\n\nWe will provide a [quick example](#quick-example) and \n[an even shorter example](#an-even-shorter-example)\nwhere we show how to use the methods in the package to estimate the \ncorrelation matrix and to perform the imputation. We then show a \n[simulation study](#simulation-study) where we compare with the method \nsuggested by @zhao20.\n\nThe last section called [adding multinomial variables](#adding-multinomial-variables)\ncovers data sets which also have multinomial variables.\n\n## Quick Example\n\nWe first simulate a data set and provide an example which shows how to use \nthe package. The [an even shorter example](#an-even-shorter-example) section \nshows a shorter example then what is shown here. You may want to see this \nfirst if you just want to perform some quick imputation.\n\n```{r load_pkgs}\n# load the packages we need\nlibrary(bench)\nlibrary(mdgc)\nlibrary(missForest, quietly = TRUE)\n# remotes::install_github(\"udellgroup/mixedgcImp\", ref = \"5ad6d523d\")\nlibrary(mixedgcImp)\nlibrary(doParallel)\n```\n\n```{r sim_dat, cache = 1, fig.height = 3, fig.width = 7}\n# simulates a data set and mask some of the data.\n#\n# Args: \n#   n: number of observations. \n#   p: number of variables. \n#   n_lvls: number of levels for the ordinal variables. \n# \n# Returns: \n#   Simulated masked data, the true data, and true covariance matrix. \nsim_dat \u003c- function(n, p = 3L, n_lvls = 5L){\n  # get the covariance matrix\n  Sig \u003c- cov2cor(drop(rWishart(1L, p, diag(p))))\n    \n  # draw the observations\n  truth \u003c- matrix(rnorm(n * p), n) %*% chol(Sig)\n  \n  # determine the type\n  n_rep \u003c- floor((p + 3 - 1) / 3)\n  type \u003c- rep(1:3, each = n_rep)[1:p]\n  is_con \u003c- type == 1L\n  is_bin \u003c- type == 2L\n  is_ord \u003c- type == 3L\n  col_nam \u003c- c(outer(1:n_rep, c(\"C\", \"B\", \"O\"), \n                     function(x, y) paste0(y, x)))[1:p]\n  \n  # sample which are masked data \n  is_mask \u003c- matrix(runif(n * p) \u003c .3, n)\n  \n  # make sure we have no rows with all missing data\n  while(any(all_nans \u003c- rowSums(is_mask) == NCOL(is_mask)))\n    is_mask[all_nans, ] \u003c- runif(sum(all_nans) * p) \u003c .3\n  \n  # create observed data\n  truth_obs \u003c- data.frame(truth)\n  colnames(truth_obs) \u003c- col_nam\n  truth_obs[, is_con] \u003c- qexp(pnorm(as.matrix(truth_obs[, is_con])))\n  \n  bs_border \u003c- 0\n  truth_obs[, is_bin] \u003c- \n    truth_obs[, is_bin] \u003e rep(bs_border, each = NROW(truth_obs))\n  \n  bs_ord \u003c- qnorm(seq(0, 1, length.out = n_lvls + 1L))\n  truth_obs[, is_ord] \u003c- as.integer(cut(truth[, is_ord], breaks = bs_ord))\n  for(i in which(is_ord)){\n    truth_obs[, i] \u003c- ordered(truth_obs[, i])\n    levels(truth_obs[, i]) \u003c- \n      LETTERS[seq_len(length(unique(truth_obs[, i])))]\n  }\n\n  # mask the data\n  seen_obs \u003c- truth_obs\n  seen_obs[is_mask] \u003c- NA\n  \n  list(truth = truth, truth_obs = truth_obs, seen_obs = seen_obs, \n       Sigma = Sig)\n}\n\n# simulate and show the data\nset.seed(1)\np \u003c- 15L\ndat \u003c- sim_dat(2000L, p = p)\n\n# how an observed data set could look\nhead(dat$seen_obs)\n\n# assign objects needed for model estimation\nmdgc_obj \u003c- get_mdgc(dat$seen_obs)\nlog_ml_ptr \u003c- get_mdgc_log_ml(mdgc_obj)\nstart_val \u003c- mdgc_start_value(mdgc_obj)\n\n# this is very fast so we can neglect this when we consider the computation \n# time\nmark(`Setup time` = {\n  mdgc_obj \u003c- get_mdgc(dat$seen_obs)\n  log_ml_ptr \u003c- get_mdgc_log_ml(mdgc_obj)\n  start_val \u003c- mdgc_start_value(mdgc_obj)\n}, min_iterations = 10)\n\n# fit the model using three different methods\nset.seed(60941821)\nsystem.time(\n  fit_Lagran_start \u003c- mdgc_fit(\n    ptr = log_ml_ptr, vcov = start_val, mea = mdgc_obj$means, \n    n_threads = 4L, maxit = 100L, method = \"aug_Lagran\", rel_eps = 1e-3, \n    maxpts = 200L))\nsystem.time(\n  fit_Lagran \u003c- mdgc_fit(\n    ptr = log_ml_ptr, vcov = fit_Lagran_start$result$vcov, \n    mea = fit_Lagran_start$result$mea, \n    n_threads = 4L, maxit = 100L, method = \"aug_Lagran\", rel_eps = 1e-3, \n    maxpts = 5000L, mu = fit_Lagran_start$mu, \n    lambda = fit_Lagran_start$lambda))\n\nsystem.time(\n  fit_adam \u003c- mdgc_fit(\n    ptr = log_ml_ptr, vcov = start_val, mea = mdgc_obj$means, \n    n_threads = 4L, lr = 1e-3, maxit = 25L, batch_size = 100L, \n    method = \"adam\", rel_eps = 1e-3, maxpts = 5000L))\n\nset.seed(fit_seed \u003c- 19570958L)\nsystem.time(\n  fit_svrg \u003c- mdgc_fit(\n    ptr = log_ml_ptr, vcov = start_val, mea = mdgc_obj$means, \n    n_threads = 4L, lr = 1e-3, maxit = 25L, batch_size = 100L, \n    method = \"svrg\", verbose = TRUE, rel_eps = 1e-3, maxpts = 5000L))\n\n# compare the log marginal likelihood \nprint(rbind(\n  `Augmented Lagrangian` = \n    mdgc_log_ml(vcov = fit_Lagran$result$vcov, mea = fit_Lagran$result$mea, \n                ptr = log_ml_ptr, rel_eps = 1e-3),\n  ADAM = \n    mdgc_log_ml(vcov = fit_adam$result$vcov  , mea = fit_adam$result$mea, \n                ptr = log_ml_ptr, rel_eps = 1e-3),\n  SVRG =\n    mdgc_log_ml(vcov = fit_svrg$result$vcov  , mea = fit_svrg$result$mea, \n                ptr = log_ml_ptr, rel_eps = 1e-3),\n  Truth = \n    mdgc_log_ml(vcov = dat$Sigma             , mea = numeric(5), \n                ptr = log_ml_ptr, rel_eps = 1e-3)),\n  digits = 10)\n\n# we can use an approximation in the method\nset.seed(fit_seed)\nsystem.time(\n  fit_svrg_aprx \u003c- mdgc_fit(\n    ptr = log_ml_ptr, vcov = start_val, mea = mdgc_obj$means, \n    n_threads = 4L, lr = 1e-3, maxit = 25L, batch_size = 100L, \n    method = \"svrg\", rel_eps = 1e-3, maxpts = 5000L, use_aprx = TRUE))\n\n# essentially the same estimates\nnorm(fit_svrg_aprx$result$vcov - fit_svrg$result$vcov, \"F\") \nsd(fit_svrg_aprx$result$mea - fit_svrg$result$mea)\n\n# compare the estimated correlation matrix with the true value\ndo_plot \u003c- function(est, truth, main){\n  par_old \u003c- par(mfcol = c(1, 3), mar  = c(1, 1, 4, 1))\n  on.exit(par(par_old))\n  sc \u003c- colorRampPalette(c(\"Red\", \"White\", \"Blue\"))(201)\n  \n  f \u003c- function(x, main)\n    image(x[, NCOL(x):1], main = main, col = sc, zlim = c(-1, 1), \n          xaxt = \"n\", yaxt = \"n\", bty = \"n\")\n  f(est, main)\n  f(truth, \"Truth\")\n  f(est - truth, \"Difference\")\n}\n\ndo_plot(fit_Lagran$result$vcov, dat$Sigma, \"Estimates (Aug. Lagrangian)\")\ndo_plot(fit_adam  $result$vcov, dat$Sigma, \"Estimates (ADAM)\")\ndo_plot(fit_svrg  $result$vcov, dat$Sigma, \"Estimates (SVRG)\")\n\nnorm(fit_Lagran$result$vcov - dat$Sigma, \"F\")\nnorm(fit_adam  $result$vcov - dat$Sigma, \"F\")\nnorm(fit_svrg  $result$vcov - dat$Sigma, \"F\")\n\n# perform the imputation\nsystem.time(imp_res \u003c- mdgc_impute(\n  mdgc_obj, fit_svrg$result$vcov, mea = fit_svrg$result$mea, rel_eps = 1e-3, \n  maxit = 10000L, n_threads = 4L))\n\n# look at the result for one of the observations\nimp_res[2L]\n\n# compare with the observed and true data\nrbind(truth = dat$truth_obs[2L, ], observed = dat$seen_obs[2L, ])\n\n# we can threshold the data like this\nthreshold \u003c- function(org_data, imputed){\n  # checks\n  stopifnot(NROW(org_data) == length(imputed), \n            is.list(imputed), is.data.frame(org_data))\n  \n  # threshold\n  is_cont \u003c- which(sapply(org_data, is.numeric))\n  is_bin  \u003c- which(sapply(org_data, is.logical)) \n  is_ord  \u003c- which(sapply(org_data, is.ordered))\n  stopifnot(\n    length(is_cont) + length(is_bin) + length(is_ord) == NCOL(org_data))\n  is_cat \u003c- c(is_bin, is_ord)\n  \n  trans_to_df \u003c- function(x){\n    if(is.matrix(x))\n      as.data.frame(t(x))\n    else\n      as.data.frame(  x )\n  }\n  \n  out_cont \u003c- trans_to_df(sapply(imputed, function(x) unlist(x[is_cont])))\n  out_cat \u003c- trans_to_df(sapply(imputed, function(x) \n    sapply(x[is_cat], which.max)))\n  out \u003c- cbind(out_cont, out_cat)\n  \n  # set factor levels etc. \n  out \u003c- out[, order(c(is_cont, is_bin, is_ord))]\n  if(length(is_bin) \u003e 0)\n    out[, is_bin] \u003c- out[, is_bin] \u003e 1L\n  if(length(is_ord) \u003e 0)\n    for(i in is_ord)\n      out[[i]] \u003c- ordered(\n        unlist(out[[i]]), labels = levels(org_data[, i]))\n  \n  colnames(out) \u003c- colnames(org_data)\n  out\n}\nthresh_dat \u003c- threshold(dat$seen_obs, imp_res)\n\n# compare thresholded data with observed and true data\nhead(thresh_dat)\nhead(dat$seen_obs)  # observed data\nhead(dat$truth_obs) # true data\n\n# compare correct categories\nget_classif_error \u003c- function(impu_dat, truth = dat$truth_obs, \n                              observed = dat$seen_obs){\n  is_cat \u003c- sapply(truth, function(x)\n    is.logical(x) || is.ordered(x))\n  is_match \u003c- impu_dat[, is_cat] == truth[, is_cat]\n  is_match[!is.na(observed[, is_cat])] \u003c- NA_integer_\n  1 - colMeans(is_match, na.rm = TRUE)\n}\nget_classif_error(thresh_dat)\n\n# compute RMSE\nget_rmse \u003c- function(impu_dat, truth = dat$truth_obs,\n                     observed = dat$seen_obs){\n  is_con \u003c- sapply(truth, is.numeric)\n  err \u003c- as.matrix(impu_dat[, is_con] - truth[, is_con])\n  err[!is.na(observed[, is_con])] \u003c- NA_real_\n  sqrt(colMeans(err^2, na.rm = TRUE))\n}\nget_rmse(thresh_dat)\n\n# we can compare this with missForest\nmiss_forest_arg \u003c- dat$seen_obs\nis_log \u003c- sapply(miss_forest_arg, is.logical)\nmiss_forest_arg[, is_log] \u003c- lapply(miss_forest_arg[, is_log], as.factor)\nset.seed(1)\nsystem.time(miss_res \u003c- missForest(miss_forest_arg))\n\n# turn binary variables back to logicals\nmiss_res$ximp[, is_log] \u003c- lapply(\n  miss_res$ximp[, is_log], function(x) as.integer(x) \u003e 1L)\n\nrbind(mdgc       = get_classif_error(thresh_dat),\n      missForest = get_classif_error(miss_res$ximp))\nrbind(mdgc       = get_rmse(thresh_dat),\n      missForest = get_rmse(miss_res$ximp))\n```\n\n## An Even Shorter Example\n\nHere is an example where we use the `mdgc` function to do the model \nestimation and the imputation:\n\n```{r very_quick_example, cache = 1, eval = TRUE}\n# have a data set with missing continuous, binary, and ordinal variables\nhead(dat$seen_obs)\n  \n# perform the estimation and imputation\nset.seed(1)\nsystem.time(res \u003c- mdgc(dat$seen_obs, verbose = TRUE, maxpts = 5000L, \n                        n_threads = 4L, maxit = 25L, use_aprx = TRUE))\n\n# compare the estimated correlation matrix with the truth\nnorm(dat$Sigma - res$vcov, \"F\") / norm(dat$Sigma, \"F\")\n\n# compute the classifcation error and RMSE\nget_classif_error(res$ximp)\nget_rmse(res$ximp)\n```\n\nWe can compare this with the `mixedgcImp` which uses the method described \nin @zhao20:\n\n```{r use_zhao19, eval = TRUE, cache = 1}\n# turn the data to a format that can be based\ndat_pass \u003c- dat$seen_obs\nis_cat \u003c- sapply(dat_pass, function(x) is.logical(x) | is.ordered(x))\ndat_pass[, is_cat] \u003c- lapply(dat_pass[, is_cat], as.integer)\n\nsystem.time(imp_apr_em \u003c- impute_mixedgc(dat_pass, eps = 1e-4))\n\n# compare the estimated correlation matrix with the truth\nget_rel_err \u003c- function(est, keep = seq_len(NROW(truth)), truth = dat$Sigma)\n  norm(truth[keep, keep] - est[keep, keep], \"F\") / \n  norm(truth, \"F\")\n\nc(mdgc                     = get_rel_err(res$vcov), \n  mixedgcImp               = get_rel_err(imp_apr_em$R), \n  `mdgc bin/ordered`       = get_rel_err(res$vcov    , is_cat),\n  `mixedgcImp bin/ordered` = get_rel_err(imp_apr_em$R, is_cat),\n  `mdgc continuous`        = get_rel_err(res$vcov    , !is_cat),\n  `mixedgcImp continuous`  = get_rel_err(imp_apr_em$R, !is_cat))\n\n# compare the classifcation error and RMSE\nimp_apr_res \u003c- as.data.frame(imp_apr_em$Ximp)\nis_bin \u003c- sapply(dat$seen_obs, is.logical)\nimp_apr_res[, is_bin] \u003c- lapply(imp_apr_res[, is_bin], `\u003e`, e2 = 0)\nis_ord \u003c- sapply(dat$seen_obs, is.ordered)\nimp_apr_res[, is_ord] \u003c- mapply(function(x, idx)\n  ordered(x, labels = levels(dat$seen_obs[[idx]])), \n  x = imp_apr_res[, is_ord], i = which(is_ord), SIMPLIFY = FALSE)\n\nrbind(mdgc       = get_classif_error(res$ximp),\n      mixedgcImp = get_classif_error(imp_apr_res))\nrbind(mdgc       = get_rmse(res$ximp),\n      mixedgcImp = get_rmse(imp_apr_res))\n```\n\n## Simulation Study\n\n```{r before_sim_clean, echo = FALSE}\nrm(list = setdiff(ls(), c(\n  \"dat\", \"get_rmse\", \"get_rel_err\", \"get_classif_error\", \"sim_dat\", \n  \"threshold\", \"log_ml_ptr\", \"mdgc_obj\", \"p\", \"do_plot\")))\n```\n\nWe will perform a simulation study in this section to compare different \nmethods in terms of their computation time and performance. We first \nperform the simulation.\n\n```{r sim_study, message = FALSE}\n# the seeds we will use\nseeds \u003c- c(293498804L, 311878062L, 370718465L, 577520465L, 336825034L, 661670751L, 750947065L, 255824398L, 281823005L, 721186455L, 251974931L, 643568686L, 273097364L, 328663824L, 490259480L, 517126385L, 651705963L, 43381670L, 503505882L, 609251792L, 643001919L, 244401725L, 983414550L, 850590318L, 714971434L, 469416928L, 237089923L, 131313381L, 689679752L, 344399119L, 330840537L, 6287534L, 735760574L, 477353355L, 579527946L, 83409653L, 710142087L, 830103443L, 94094987L, 422058348L, 117889526L, 259750108L, 180244429L, 762680168L, 112163383L, 10802048L, 440434442L, 747282444L, 736836365L, 837303896L, 50697895L, 231661028L, 872653438L, 297024405L, 719108161L, 201103881L, 485890767L, 852715172L, 542126886L, 155221223L, 18987375L, 203133067L, 460377933L, 949381283L, 589083178L, 820719063L, 543339683L, 154667703L, 480316186L, 310795921L, 287317945L, 30587393L, 381290126L, 178269809L, 939854883L, 660119506L, 825302990L, 764135140L, 433746745L, 173637986L, 100446967L, 333304121L, 225525537L, 443031789L, 587486506L, 245392609L, 469144801L, 44073812L, 462948652L, 226692940L, 165285895L, 546908869L, 550076645L, 872290900L, 452044364L, 620131127L, 600097817L, 787537854L, 15915195L, 64220696L)\n\n# gather or compute the results (you may skip this)\nres \u003c- lapply(seeds, function(s){\n  file_name \u003c- file.path(\"sim-res\", sprintf(\"seed-%d.RDS\", s))\n  \n  if(file.exists(file_name)){\n    message(sprintf(\"Reading '%s'\", file_name))\n    out \u003c- readRDS(file_name)\n  } else { \n    message(sprintf(\"Running '%s'\", file_name))\n    \n    # simulate the data\n    set.seed(s)\n    dat \u003c- sim_dat(2000L, p = 15L)\n    \n    # fit models and impute\n    mdgc_time \u003c- system.time(\n      mdgc_res \u003c- mdgc(dat$seen_obs, verbose = FALSE, maxpts = 5000L, \n                        n_threads = 4L, maxit = 25L, use_aprx = TRUE))\n    \n    dat_pass \u003c- dat$seen_obs\n    is_cat \u003c- sapply(dat_pass, function(x) is.logical(x) | is.ordered(x))\n    dat_pass[, is_cat] \u003c- lapply(dat_pass[, is_cat], as.integer)\n    mixedgc_time \u003c- \n      system.time(mixedgc_res \u003c- impute_mixedgc(dat_pass, eps = 1e-4))\n    \n    miss_forest_arg \u003c- dat$seen_obs\n    is_log \u003c- sapply(miss_forest_arg, is.logical)\n    miss_forest_arg[, is_log] \u003c- lapply(\n      miss_forest_arg[, is_log], as.factor)\n    sink(tempfile())\n    miss_time \u003c- system.time(\n      miss_res \u003c- missForest(miss_forest_arg, verbose = FALSE))\n    sink()\n    \n    miss_res$ximp[, is_log] \u003c- lapply(\n      miss_res$ximp[, is_log], function(x) as.integer(x) \u003e 1L)\n    \n    # impute using the other estimate\n    mdgc_obj \u003c- get_mdgc(dat$seen_obs)\n    impu_mixedgc_est \u003c- mdgc_impute(mdgc_obj, mixedgc_res$R, mdgc_obj$means)\n    impu_mixedgc_est \u003c- threshold(dat$seen_obs, impu_mixedgc_est)\n    \n    # gather output for the correlation matrix estimates\n    vcov_res \u003c- list(truth = dat$Sigma, mdgc = mdgc_res$vcov, \n                     mixedgc = mixedgc_res$R)\n    get_rel_err \u003c- function(est, truth, keep = seq_len(NROW(truth)))\n      norm(truth[keep, keep] - est[keep, keep], \"F\") / norm(truth, \"F\")\n    \n    vcov_res \u003c- within(vcov_res, {\n      mdgc_rel_err    = get_rel_err(mdgc   , truth)\n      mixedgc_rel_err = get_rel_err(mixedgc, truth)\n    })\n    \n    # gather the estimated means\n    mea_ests \u003c- list(marginal = mdgc_obj$means, \n                     joint    = mdgc_res$mea)\n    \n    # gather output for the imputation \n    mixedgc_imp_res \u003c- as.data.frame(mixedgc_res$Ximp)\n    is_bin \u003c- sapply(dat$seen_obs, is.logical)\n    mixedgc_imp_res[, is_bin] \u003c- \n      lapply(mixedgc_imp_res[, is_bin, drop = FALSE], `\u003e`, e2 = 0)\n    is_ord \u003c- sapply(dat$seen_obs, is.ordered)\n    mixedgc_imp_res[, is_ord] \u003c- mapply(function(x, idx)\n      ordered(x, labels = levels(dat$seen_obs[[idx]])), \n      x = mixedgc_imp_res[, is_ord, drop = FALSE], \n      i = which(is_ord), SIMPLIFY = FALSE)\n    \n    get_bin_err \u003c- function(x){\n      . \u003c- function(z) z[, is_bin, drop = FALSE]\n      get_classif_error(\n        .(x), truth = .(dat$truth_obs), observed = .(dat$seen_obs))\n    }\n    get_ord_err \u003c- function(x){\n      . \u003c- function(z) z[, is_ord, drop = FALSE]\n      get_classif_error(\n        .(x), truth = .(dat$truth_obs), observed = .(dat$seen_obs))\n    }\n          \n    err \u003c- list(\n      mdgc_bin = get_bin_err(mdgc_res$ximp), \n      mixedgc_bin = get_bin_err(mixedgc_imp_res), \n      mixed_bin = get_bin_err(impu_mixedgc_est),\n      missForest_bin = get_bin_err(miss_res$ximp),\n      \n      mdgc_class = get_ord_err(mdgc_res$ximp), \n      mixedgc_class = get_ord_err(mixedgc_imp_res), \n      mixed_class = get_ord_err(impu_mixedgc_est),\n      missForest_class = get_ord_err(miss_res$ximp),\n      \n      mdgc_rmse = get_rmse(\n        mdgc_res$ximp, truth = dat$truth_obs, observed = dat$seen_obs),\n      mixedgc_rmse = get_rmse(\n        mixedgc_imp_res, truth = dat$truth_obs, observed = dat$seen_obs),\n      mixed_rmse = get_rmse(\n        impu_mixedgc_est, truth = dat$truth_obs, observed = dat$seen_obs), \n      missForest_rmse = get_rmse(\n        miss_res$ximp, truth = dat$truth_obs, observed = dat$seen_obs))\n    \n    # gather the times\n    times \u003c- list(mdgc = mdgc_time, mixedgc = mixedgc_time, \n                  missForest = miss_time)\n    \n    # save stats to check convergence\n    conv_stats \u003c- list(mdgc = mdgc_res$logLik, \n                       mixedgc = mixedgc_res$loglik)\n    \n    # save output \n    out \u003c- list(vcov_res = vcov_res, err = err, times = times, \n                conv_stats = conv_stats, mea_ests = mea_ests)\n    saveRDS(out, file_name)\n  }\n  \n  # print summary stat to the console while knitting\n  out \u003c- readRDS(file_name)\n  . \u003c- function(x)\n    message(paste(sprintf(\"%8.3f\", x), collapse = \" \"))\n  with(out, {\n    message(paste(\n      \"mdgc    logLik\", \n      paste(sprintf(\"%.2f\", conv_stats$mdgc), collapse = \" \")))\n    message(paste(\n      \"mixedgc logLik\", \n      paste(sprintf(\"%.2f\", conv_stats$mixedgc), collapse = \" \")))\n    message(sprintf(\n      \"Relative correlation matrix estimate errors are %.4f %.4f\", \n      vcov_res$mdgc_rel_err, vcov_res$mixedgc_rel_err))\n    message(sprintf(\n      \"Times are %.2f %.2f %.2f\", \n      times$mdgc[\"elapsed\"], times$mixedgc[\"elapsed\"], \n      times$missForest[\"elapsed\"]))\n    \n    message(sprintf(\n      \"Binary classifcation errors are %.2f %.2f %.2f (%.2f)\", \n      mean(err$mdgc_bin), mean(err$mixedgc_bin), \n      mean(err$missForest_bin), mean(err$mixed_bin)))\n    \n    message(sprintf(\n      \"Ordinal classifcation errors are %.2f %.2f %.2f (%.2f)\", \n      mean(err$mdgc_class), mean(err$mixedgc_class), \n      mean(err$missForest_class), mean(err$mixed_class)))\n    \n    message(sprintf(\n      \"Mean RMSEs are %.2f %.2f %.2f (%.2f)\",\n      mean(err$mdgc_rmse), mean(err$mixedgc_rmse), \n      mean(err$missForest_rmse), mean(err$mixed_rmse)))\n    message(\"\")\n  })\n  \n  out  \n})\n```\n\nThe difference in computation time is given below:\n\n```{r time_diff_est}\n# assign function to show the summary stats\nshow_sim_stats \u003c- function(v1, v2, v3, what, sub_ele = NULL){\n  vals \u003c- sapply(res, function(x) \n    do.call(rbind, x[[what]][c(v1, v2, v3)]), \n    simplify = \"array\")\n  if(!is.null(sub_ele))\n    vals \u003c- vals[, sub_ele, , drop = FALSE]\n    \n  cat(\"Means and standard errors:\\n\")\n  mea_se \u003c- function(x)\n    c(mean = mean(x), SE = sd(x) / sqrt(length(x)))\n  print(t(apply(vals, 1L, mea_se)))\n  \n  cat(\"\\nDifference:\\n\")\n  print(t(apply(\n    c(vals[v1, , ]) - \n      aperm(vals[c(v2, v3), , , drop = FALSE], c(3L, 2L, 1L)), \n    3L, mea_se)))\n}\n\n# compare estimation time\nshow_sim_stats(1L, 2L, 3L, \"times\", \"elapsed\")\n```\n\nThe summary stats for the relative Frobenius norm between the estimated and \ntrue correlation matrix is given below:\n\n```{r F_norm_diff_est}\n# relative norms\nshow_sim_stats(\"mixedgc_rel_err\", \"mdgc_rel_err\", NULL, \"vcov_res\")\n```\n\nFinally, here are the results for the classification error for the binary \nand ordinal outcomes and the root mean square error:\n\n```{r impu_diff_est}\n# the binary variables\nshow_sim_stats(\"mdgc_bin\", \"mixedgc_bin\", \"missForest_bin\", \"err\")\n\n# the ordinal variables\nshow_sim_stats(\"mdgc_class\", \"mixedgc_class\", \"missForest_class\", \"err\")\n\n# the continuous variables\nshow_sim_stats(\"mdgc_rmse\", \"mixedgc_rmse\", \"missForest_rmse\", \"err\")\n```\n\nIt is important to emphasize that missForest is not estimating the true \nmodel.\n\n## Adding Multinomial Variables\nWe extend the model suggested by @zhao20 in this section. The example is \nvery similar to the previous one but with multinomial variables.\n\n```{r mult_sim, cache = 1, fig.height = 3, fig.width = 7}\n# simulates a data set and mask some of the data.\n#\n# Args: \n#   n: number of observations. \n#   p: number of variables. \n#   n_lvls: number of levels for the ordinal and multinomial variables. \n#   verbose: print status during the simulation.\n# \n# Returns: \n#   Simulated masked data, the true data, and true covariance matrix. \nsim_dat \u003c- function(n, p = 4L, n_lvls = 5L, verbose = FALSE){\n  # determine the type\n  n_rep \u003c- floor((p + 4 - 1) / 4)\n  type \u003c- rep(1:4, n_rep)[1:p]\n  is_con  \u003c- type == 1L\n  is_bin  \u003c- type == 2L\n  is_ord  \u003c- type == 3L\n  is_mult \u003c- type == 4L\n  \n  col_nam \u003c- c(outer(c(\"C\", \"B\", \"O\", \"M\"), 1:n_rep, paste0))[1:p]\n  idx \u003c- head(cumsum(c(1L, ifelse(type == 4, n_lvls, 1L))), -1L)\n  \n  # get the covariance matrix\n  n_latent \u003c- p + (n_lvls - 1L) * (p %/% 4)\n  Sig \u003c- drop(rWishart(1L, 2 * n_latent, diag(1 / n_latent / 2, n_latent)))\n  \n  # essentially set the reference level to zero\n  for(i in idx[is_mult]){\n    Sig[i,  ] \u003c- 0\n    Sig[ , i] \u003c- 0\n  }\n  \n  # rescale some rows and columns\n  sds \u003c- sqrt(diag(Sig))\n  for(i in idx[is_mult]){\n    sds[i] \u003c- 1\n    sds[i + 3:n_lvls - 1] \u003c- 1\n  }\n  Sig \u003c- diag(1/sds) %*% Sig %*% diag(1/sds)\n      \n  # draw the observations\n  truth \u003c- mvtnorm::rmvnorm(n, sigma = Sig)\n  truth[, idx[is_mult]] \u003c- 0\n  \n  # sample which are masked data \n  is_mask \u003c- matrix(runif(n * p) \u003c .3, n)\n  \n  # make sure we have no rows with all missing data\n  while(any(all_nans \u003c- rowSums(is_mask) == NCOL(is_mask)))\n    is_mask[all_nans, ] \u003c- runif(sum(all_nans) * p) \u003c .3\n  \n  # create the observed data\n  truth_obs \u003c- lapply(type, function(i) if(i == 1L) numeric(n) else integer(n))\n  truth_obs \u003c- data.frame(truth_obs)\n  colnames(truth_obs) \u003c- col_nam\n  \n  bs_ord \u003c- qnorm(seq(0, 1, length.out = n_lvls + 1L))\n  for(i in 1:p){\n    idx_i \u003c- idx[i]\n    switch(\n      type[i],\n      # continuous\n      truth_obs[, i] \u003c- qexp(pnorm(truth[, idx_i])),\n      # binary\n      truth_obs[, i] \u003c- truth[, idx_i] \u003e 0,\n      # ordinal\n      {\n        truth_obs[, i] \u003c- \n          ordered(as.integer(cut(truth[, idx_i], breaks = bs_ord)))\n        levels(truth_obs[, i]) \u003c- \n          LETTERS[seq_len(length(unique(truth_obs[, i])))]\n      },\n      # multinomial\n      {\n        truth_obs[, i] \u003c- apply(\n          truth[, idx_i + 1:n_lvls - 1L], 1L, which.max)\n        truth_obs[, i] \u003c- factor(truth_obs[, i], \n                                 labels = paste0(\"T\", 1:n_lvls))\n      }, \n      stop(\"Type is not implemented\"))\n  }\n\n  # mask the data\n  seen_obs \u003c- truth_obs\n  seen_obs[is_mask] \u003c- NA\n  \n  list(truth = truth, truth_obs = truth_obs, seen_obs = seen_obs, \n       Sigma = Sig)\n}\n\n# simulate and show the data\nset.seed(1)\np \u003c- 8L\ndat \u003c- sim_dat(2000L, p = p, verbose = TRUE, n_lvls = 4)\n\n# show the first rows of the observed data\nhead(dat$seen_obs)\n\n# assign object to perform the estimation and the imputation\nobj \u003c- get_mdgc(dat$seen_obs)\nptr \u003c- get_mdgc_log_ml(obj)\n\n# get starting values\nstart_vals \u003c- mdgc_start_value(obj)\n\n# plot the starting values and the true values\ndo_plot \u003c- function(est, truth, main){\n  par_old \u003c- par(mfcol = c(1, 3), mar  = c(1, 1, 4, 1))\n  on.exit(par(par_old))\n  sc \u003c- colorRampPalette(c(\"Red\", \"White\", \"Blue\"))(201)\n\n  ma \u003c- max(abs(est), max(abs(truth)))  \n  f \u003c- function(x, main)\n    image(x[, NCOL(x):1], main = main, col = sc, zlim = c(-ma, ma), \n          xaxt = \"n\", yaxt = \"n\", bty = \"n\")\n  f(est, main)\n  f(truth, \"Truth\")\n  f(est - truth, \"Difference\")\n}\n\ndo_plot(start_vals, dat$Sigma, \"Starting values\")\n# check the log marginal likelihood at the starting values and compare with\n# the true values at the starting values\nmdgc_log_ml(ptr, start_vals, mea = obj$means, n_threads = 1L)\n# and at the true values\nmdgc_log_ml(ptr, dat$Sigma , mea = numeric(length(obj$means)), \n            n_threads = 1L)\n\n# much better than using a diagonal matrix!\nmdgc_log_ml(ptr, diag(NROW(dat$Sigma)), mea = obj$means, n_threads = 1L)\n\n# estimate the model\nsystem.time(\n  ests \u003c- mdgc_fit(ptr, vcov = start_vals, mea = obj$means, \n                   method = \"aug_Lagran\",\n                   n_threads = 4L, rel_eps = 1e-2, maxpts = 1000L, \n                   minvls = 200L, use_aprx = TRUE, conv_crit = 1e-8))\n\n# refine the estimates\nsystem.time(\n  ests \u003c- mdgc_fit(ptr, vcov = ests$result$vcov, \n                   mea = ests$result$mea, \n                   method = \"aug_Lagran\",\n                   n_threads = 4L, rel_eps = 1e-3, maxpts = 10000L, \n                   minvls = 1000L, mu = ests$mu, lambda = ests$lambda, \n                   use_aprx = TRUE, conv_crit = 1e-8))\n\n# use ADAM\nsystem.time(\n  fit_adam \u003c- mdgc_fit(\n    ptr, vcov = start_vals, mea = obj$means, minvls = 200L,\n    n_threads = 4L, lr = 1e-3, maxit = 25L, batch_size = 100L, \n    method = \"adam\", rel_eps = 1e-3, maxpts = 5000L, \n    use_aprx = TRUE))\n\n# use SVRG\nsystem.time(\n  fit_svrg \u003c- mdgc_fit(\n    ptr, vcov = start_vals, mea = obj$means,  minvls = 200L,\n    n_threads = 4L, lr = 1e-3, maxit = 25L, batch_size = 100L, \n    method = \"svrg\", verbose = TRUE, rel_eps = 1e-3, maxpts = 5000L, \n    use_aprx = TRUE, conv_crit = 1e-8))\n\n# compare log marginal likelihood\nprint(rbind(\n  `Augmented Lagrangian` = \n    mdgc_log_ml(ptr, ests$result$vcov    , mea = ests$result$mea, \n                n_threads = 1L),\n  ADAM = \n    mdgc_log_ml(ptr, fit_adam$result$vcov, mea = fit_adam$result$mea, \n                n_threads = 1L),\n  SVRG = \n    mdgc_log_ml(ptr, fit_svrg$result$vcov, mea = fit_svrg$result$mea, \n                n_threads = 1L),\n  Truth = \n    mdgc_log_ml(ptr, dat$Sigma           , mea = numeric(length(obj$means)), \n                n_threads = 1L)), digits = 10)\n\n# compare the estimated and the true values (should not match because of\n# overparameterization? See https://stats.stackexchange.com/q/504682/81865)\ndo_plot(ests$result$vcov    , dat$Sigma, \"Estimates (Aug. Lagrangian)\")\ndo_plot(fit_adam$result$vcov, dat$Sigma, \"Estimates (ADAM)\")\ndo_plot(fit_svrg$result$vcov, dat$Sigma, \"Estimates (SVRG)\")\n# after rescaling\ndo_plot_rescale \u003c- function(x, lab){\n  trans \u003c- function(z){\n    scal \u003c- diag(NCOL(z))\n    m \u003c- obj$multinomial[[1L]]\n    for(i in seq_len(NCOL(m))){\n      idx \u003c- m[3, i] + 1 + seq_len(m[2, i] - 1)\n      scal[idx, idx] \u003c- solve(t(chol(z[idx, idx])))\n    }\n    tcrossprod(scal %*% z, scal)\n  }\n  \n  do_plot(trans(x), trans(dat$Sigma), lab)  \n}\ndo_plot_rescale(ests$result$vcov    , \"Estimates (Aug. Lagrangian)\")\ndo_plot_rescale(fit_adam$result$vcov, \"Estimates (ADAM)\")\ndo_plot_rescale(fit_svrg$result$vcov, \"Estimates (SVRG)\")\n# perform the imputation\nsystem.time(\n  imp_res \u003c- mdgc_impute(obj, ests$result$vcov, mea = ests$result$mea, \n                         rel_eps = 1e-3, maxit = 10000L, n_threads = 4L))\n\n# look at the result for one of the observations\nimp_res[1L]\n\n# compare with the observed and true data\nrbind(truth = dat$truth_obs[1L, ], observed = dat$seen_obs[1L, ])\n\n# we can threshold the data like this\nthreshold \u003c- function(org_data, imputed){\n  # checks\n  stopifnot(NROW(org_data) == length(imputed), \n            is.list(imputed), is.data.frame(org_data))\n  \n  # threshold\n  is_cont \u003c- which(sapply(org_data, is.numeric))\n  is_bin  \u003c- which(sapply(org_data, is.logical)) \n  is_ord  \u003c- which(sapply(org_data, is.ordered))\n  is_mult \u003c- which(sapply(org_data, is.factor))\n  is_mult \u003c- setdiff(is_mult, is_ord)\n  stopifnot(\n    length(is_cont) + length(is_bin) + length(is_ord) + length(is_mult) == \n      NCOL(org_data))\n  is_cat \u003c- c(is_bin, is_ord, is_mult)\n  \n  trans_to_df \u003c- function(x){\n    if(is.matrix(x))\n      as.data.frame(t(x))\n    else\n      as.data.frame(  x )\n  }\n  \n  out_cont \u003c- trans_to_df(sapply(imputed, function(x) unlist(x[is_cont])))\n  out_cat \u003c- trans_to_df(sapply(imputed, function(x) \n    sapply(x[is_cat], which.max)))\n  out \u003c- cbind(out_cont, out_cat)\n  \n  # set factor levels etc. \n  out \u003c- out[, order(c(is_cont, is_bin, is_ord, is_mult))]\n  if(length(is_bin) \u003e 0)\n    out[, is_bin] \u003c- out[, is_bin] \u003e 1L\n  if(length(is_ord) \u003e 0)\n    for(i in is_ord)\n      out[[i]] \u003c- ordered(\n        unlist(out[[i]]), labels = levels(org_data[, i]))\n  if(length(is_mult) \u003e 0)\n    for(i in is_mult)\n      out[[i]] \u003c- factor(\n        unlist(out[[i]]), labels = levels(org_data[, i]))\n  \n  colnames(out) \u003c- colnames(org_data)\n  out\n}\nthresh_dat \u003c- threshold(dat$seen_obs, imp_res)\n\n# compare thresholded data with observed and true data\nhead(thresh_dat)\nhead(dat$seen_obs)  # observed data\nhead(dat$truth_obs) # true data\n\n# compare correct categories\nget_classif_error \u003c- function(impu_dat, truth = dat$truth_obs, \n                              observed = dat$seen_obs){\n  is_cat \u003c- sapply(truth, function(x)\n    is.logical(x) || is.factor(x))\n  is_match \u003c- impu_dat[, is_cat] == truth[, is_cat]\n  is_match \u003c- matrix(is_match, ncol = sum(is_cat))\n  is_match[!is.na(observed[, is_cat])] \u003c- NA_integer_\n  setNames(1 - colMeans(is_match, na.rm = TRUE), \n           colnames(truth)[is_cat])\n}\nget_classif_error(thresh_dat)\n\n# compute RMSE\nget_rmse \u003c- function(impu_dat, truth = dat$truth_obs,\n                     observed = dat$seen_obs){\n  is_con \u003c- sapply(truth, is.numeric)\n  err \u003c- as.matrix(impu_dat[, is_con] - truth[, is_con])\n  err[!is.na(observed[, is_con])] \u003c- NA_real_\n  sqrt(colMeans(err^2, na.rm = TRUE))\n}\nget_rmse(thresh_dat)\n\n# we can compare this with missForest\nmiss_forest_arg \u003c- dat$seen_obs\nis_log \u003c- sapply(miss_forest_arg, is.logical)\nmiss_forest_arg[, is_log] \u003c- lapply(miss_forest_arg[, is_log], as.factor)\nset.seed(1)\nsystem.time(miss_res \u003c- missForest(miss_forest_arg))\n\n# turn binary variables back to logical variables\nmiss_res$ximp[, is_log] \u003c- lapply(\n  miss_res$ximp[, is_log], function(x) as.integer(x) \u003e 1L)\n\n# compare errors\nrbind(mdgc       = get_classif_error(thresh_dat),\n      missForest = get_classif_error(miss_res$ximp))\nrbind(mdgc       = get_rmse(thresh_dat),\n      missForest = get_rmse(miss_res$ximp))\n```\n\n### Edgar Anderson's Iris Data\nWe make a small example below were we take the iris data set and randomly \nmask it. Then we compare the imputation method in this package with \nmissForest.\n\n```{r comp_w_iris, cache=1}\n# re-scales continuous variables to have scale 1.\n#\n# Args:\n#   dat: data to rescale.\nre_scale \u003c- function(dat){\n  is_num \u003c- sapply(dat, is.numeric)\n  if(!any(is_num))\n    return(dat)\n  dat[is_num] \u003c- lapply(dat[is_num], scale)\n  dat[is_num] \u003c- lapply(dat[is_num], c)\n  dat\n}\n\n# load the iris data set\ndata(iris)\niris \u003c- re_scale(iris)\n\n# assign function to produce iris data set with NAs.\n# \n# Args:\n#   dat: data set to mask.\n#   p_na: chance of missing a value.\nmask_dat \u003c- function(dat, p_na = .3){\n  is_miss \u003c- matrix(p_na \u003e runif(NROW(dat) * NCOL(dat)), \n                    NROW(dat), NCOL(dat))\n  while(any(all_missing \u003c- apply(is_miss, 1, all)))\n    # avoid rows with all missing variables\n    is_miss[all_missing, ] \u003c- p_na \u003e runif(sum(all_missing) * NCOL(dat))\n  \n  # create data set with missing values\n  out \u003c- dat\n  out[is_miss] \u003c- NA \n  out\n}\n\n# get a data set with all missing values\nset.seed(68129371)\ndat \u003c- mask_dat(iris)\n\n# use the mdgc method\nsystem.time(\n  mdgc_res \u003c- mdgc(dat, maxpts = 10000L, minvls = 500L, n_threads = 4L, \n                   maxit = 50L, use_aprx = TRUE, conv_crit = 1e-8, \n                   method = \"svrg\", rel_eps = 1e-2, batch_size = 100L, \n                   iminvls = 2000L, imaxit = 20000L, irel_eps = 1e-3, \n                   lr = 1e-3))\n\n# some of the imputed values\nhead(mdgc_res$ximp)\n\n# compare with missForest\nsystem.time(miss_res \u003c- missForest(dat))\n\n# the errors\nrbind(\n  mdgc = get_classif_error(\n    impu_dat = mdgc_res$ximp, truth = iris, observed = dat), \n  missForest = get_classif_error(\n    impu_dat = miss_res$ximp, truth = iris, observed = dat))\n\nrbind(\n  mdgc = get_rmse(\n    impu_dat = mdgc_res$ximp, truth = iris, observed = dat), \n  missForest = \n    get_rmse(impu_dat = miss_res$ximp, truth = iris, observed = dat))\n```\n\nWe repeat this a few times to get Monte Carlo estimates of the errors:\n\n```{r mult_iris, message=FALSE, cache=1}\n# function to get Monte Carlo estimates of the errors. \n# \n# Args:\n#   dat: data set to use. \n#   seeds: seeds to use.\nget_err_n_time \u003c- function(dat, seeds){\n  cl \u003c- makeCluster(4L)\n  registerDoParallel(cl)\n  on.exit(stopCluster(cl))\n    \n  sapply(seeds, function(s){\n    # mask data\n    set.seed(s)\n    dat_mask \u003c- mask_dat(dat)\n    \n    # fit models\n    mdgc_time \u003c- system.time(\n      mdgc_res \u003c- mdgc(dat_mask, maxpts = 10000L, minvls = 500L, n_threads = 4L, \n                       maxit = 50L, use_aprx = TRUE, conv_crit = 1e-8, \n                       method = \"svrg\", rel_eps = 1e-2, batch_size = 100L, \n                       iminvls = 2000L, imaxit = 20000L, irel_eps = 1e-3, \n                       lr = 1e-3))\n    \n    # compare with missForest\n    miss_forest_arg \u003c- dat_mask\n    is_log \u003c- sapply(miss_forest_arg, is.logical)\n    miss_forest_arg[, is_log] \u003c- lapply(miss_forest_arg[, is_log], as.factor)\n    sink(tempfile())\n    miss_time \u003c- system.time(miss_res \u003c- missForest(\n      miss_forest_arg, parallelize = \"forests\"))\n    sink()\n    \n    # turn binary variables back to logicals\n    miss_res$ximp[, is_log] \u003c- lapply(\n      miss_res$ximp[, is_log], function(x) as.integer(x) \u003e 1L)\n    \n    # get the errors\n    er_int \u003c- rbind(\n      mdgc = get_classif_error(\n        impu_dat = mdgc_res$ximp, truth = dat, observed = dat_mask), \n      missForest = get_classif_error(\n        impu_dat = miss_res$ximp, truth = dat, observed = dat_mask))\n    er_con \u003c- rbind(\n      mdgc = get_rmse(\n        impu_dat = mdgc_res$ximp, truth = dat, observed = dat_mask), \n      missForest = \n        get_rmse(impu_dat = miss_res$ximp, truth = dat, observed = dat_mask))\n      \n    # gather the output and return \n    er \u003c- cbind(er_int, er_con)\n    er \u003c- er[, match(colnames(er), colnames(dat))]\n    ti \u003c- rbind(mdgc_time, miss_time)[, 1:3]\n    out \u003c- cbind(er, ti)\n    message(sprintf(\"\\nResult with seed %d is:\", s))\n    message(paste0(capture.output(print(out)), collapse = \"\\n\"))\n    out\n\n  }, simplify = \"array\")\n}\n\n# get the results\nseeds \u003c- c(40574428L, 13927943L, 31430660L, 38396447L, 20137114L, 59492953L, \n           93913797L, 95452931L, 77261969L, 10996196L)\nres \u003c- get_err_n_time(iris, seeds)\n```\n\n```{r show_res_mult_iris}\n# compute means and Monte Carlo standard errors\nshow_res \u003c- function(res, dat){\n  stats \u003c- apply(res, 1:2, function(x) \n    c(mean = mean(x), SE = sd(x) / sqrt(length(x))))\n  stats \u003c- stats[, , c(colnames(dat), \"user.self\", \"elapsed\")]\n  for(i in seq_len(dim(stats)[[3]])){\n    nam \u003c- dimnames(stats)[[3]][i]\n    cap \u003c- if(nam %in% colnames(dat)){\n      if(is.ordered(dat[[nam]]))\n        \"ordinal\"\n      else if(is.factor(dat[[nam]]))\n        \"multinomial\"\n      else if(is.logical(dat[[nam]]))\n        \"binary\"\n      else\n        \"continuous\"\n    } else\n      \"computation time\"\n    \n    cat(sprintf(\"\\n%s (%s):\\n\", nam, cap))\n    print(apply(round(\n      stats[, , i], 4), 2, function(x) sprintf(\"%.4f (%.4f)\", x[1], x[2])), \n      quote = FALSE)\n  }\n}\n\nshow_res(res, iris)\n```\n\n### Chemotherapy for Stage B/C Colon Cancer\nWe do as in the [Edgar Anderson's Iris Data](#edgar-andersons-iris-data)\nsection here but with a different data set.\n\n```{r colon, cache = 1}\n# prepare the data\nlibrary(survival)\ncolon_use \u003c- colon[, setdiff(\n  colnames(colon), c(\"id\", \"study\", \"time\", \"status\", \"node4\", \"etype\"))]\ncolon_use \u003c- within(colon_use, {\n  sex \u003c- sex \u003e 0\n  obstruct \u003c- obstruct \u003e 0\n  perfor \u003c- perfor \u003e 0\n  adhere \u003c- adhere \u003e 0\n  differ \u003c- ordered(differ)\n  extent \u003c- ordered(extent)\n  surg \u003c- surg \u003e 0\n})\ncolon_use \u003c- colon_use[complete.cases(colon_use), ]\ncolon_use \u003c- re_scale(colon_use)\n\n# stats for the data set\nsummary(colon_use)\n\n# sample missing values\nset.seed(68129371)\ndat \u003c- mask_dat(colon_use)\n\n# use the mdgc method\nsystem.time(\n  mdgc_res \u003c- mdgc(dat, maxpts = 10000L, minvls = 500L, n_threads = 4L, \n                   maxit = 50L, use_aprx = TRUE, conv_crit = 1e-8, \n                   method = \"svrg\", rel_eps = 1e-2, batch_size = 100L, \n                   iminvls = 2000L, imaxit = 20000L, irel_eps = 1e-3, \n                   lr = 1e-3))\n\n# some of the imputed values\nhead(mdgc_res$ximp)\n\n# compare with missForest\nmiss_forest_arg \u003c- dat\nis_log \u003c- sapply(miss_forest_arg, is.logical)\nmiss_forest_arg[, is_log] \u003c- lapply(miss_forest_arg[, is_log], as.factor)\nsystem.time(miss_res \u003c- missForest(miss_forest_arg))\n\n# turn binary variables back to logicals\nmiss_res$ximp[, is_log] \u003c- lapply(\n  miss_res$ximp[, is_log], function(x) as.integer(x) \u003e 1L)\n\n# the errors\nrbind(\n  mdgc = get_classif_error(\n    impu_dat = mdgc_res$ximp, truth = colon_use, observed = dat), \n  missForest = get_classif_error(\n    impu_dat = miss_res$ximp, truth = colon_use, observed = dat))\n\nrbind(\n  mdgc = get_rmse(\n    impu_dat = mdgc_res$ximp, truth = colon_use, observed = dat), \n  missForest = get_rmse(\n    impu_dat = miss_res$ximp, truth = colon_use, observed = dat))\n```\n\n```{r mult_colon, message=FALSE, cache=1}\n# get the results\nres \u003c- get_err_n_time(colon_use, seeds)\n```\n\n```{r show_res_mult_colon}\n# compute means and Monte Carlo standard errors\nshow_res(res, colon_use)\n```\n\n### Cholesterol Data From a US Survey\nWe do as in the [Edgar Anderson's Iris Data](#edgar-andersons-iris-data)\nsection here but with a different data set.\n\n```{r nhanes, cache = 1}\n# prepare the data\ndata(\"nhanes\", package = \"survey\")\n\nnhanes_use \u003c- within(nhanes, {\n  HI_CHOL \u003c- HI_CHOL \u003e 0\n  race \u003c- factor(race)\n  agecat \u003c- ordered(agecat)\n  RIAGENDR \u003c- RIAGENDR \u003e 1\n})[, c(\"HI_CHOL\", \"race\", \"agecat\", \"RIAGENDR\")]\nnhanes_use \u003c- nhanes_use[complete.cases(nhanes_use), ]\nnhanes_use \u003c- re_scale(nhanes_use)\n\n# summary stats for the data\nsummary(nhanes_use)\n\n# sample a data set\nset.seed(1)\ndat \u003c- mask_dat(nhanes_use)\n\n# use the mdgc method\nsystem.time(\n  mdgc_res \u003c- mdgc(dat, maxpts = 10000L, minvls = 500L, n_threads = 4L, \n                   maxit = 50L, use_aprx = TRUE, conv_crit = 1e-8, \n                   method = \"svrg\", rel_eps = 1e-2, batch_size = 100L, \n                   iminvls = 2000L, imaxit = 20000L, irel_eps = 1e-3, \n                   lr = 1e-3))\n\n# some of the imputed values\nhead(mdgc_res$ximp)\n\n# compare with missForest\nmiss_forest_arg \u003c- dat\nis_log \u003c- sapply(miss_forest_arg, is.logical)\nmiss_forest_arg[, is_log] \u003c- lapply(miss_forest_arg[, is_log], as.factor)\nsystem.time(miss_res \u003c- missForest(miss_forest_arg))\n\n# turn binary variables back to logicals\nmiss_res$ximp[, is_log] \u003c- lapply(\n  miss_res$ximp[, is_log], function(x) as.integer(x) \u003e 1L)\n\n# the errors\nrbind(\n  mdgc = get_classif_error(\n    impu_dat = mdgc_res$ximp, truth = nhanes_use, observed = dat), \n  missForest = get_classif_error(\n    impu_dat = miss_res$ximp, truth = nhanes_use, observed = dat))\n```\n\n```{r mult_nhanes, message=FALSE, cache=1}\n# get the results\nres \u003c- get_err_n_time(nhanes_use, seeds)\n```\n\n```{r show_res_mult_nhanes}\n# compute means and Monte Carlo standard errors\nshow_res(res, nhanes_use)\n```\n\n## References\n","project_url":"https://awesome.ecosyste.ms/api/v1/projects/github.com%2Fboennecd%2Fmdgc","html_url":"https://awesome.ecosyste.ms/projects/github.com%2Fboennecd%2Fmdgc","lists_url":"https://awesome.ecosyste.ms/api/v1/projects/github.com%2Fboennecd%2Fmdgc/lists"}