library(mvord) library(copula) library(MASS) source("simulate.R") nvec <- c(100, 200, 500, 1000) linkvec <- c("logit", "probit") for (s in 1:400) { idn <- (s - 1) %/% 100 + 1 idlink <- ((s - 1) %/% 50 + 1) %% 2 + 1 n <- nvec[idn] link <- linkvec[idlink] rep <- 20 sim_5J_6sec <- vector("list", rep) sim_5J_6sec_NA <- vector("list", rep) for (i in 1:rep){ seed <- i + ((s - 1)%/%200 + 1) * 100 nsec <- 6 sobs <- rep(n, nsec) # number of observations per sector mult.obs <- 5 # number of responses sigma1 <- matrix(c(1,0.8,0.7,0.9,0.8,0.8,1,0.8,0.8,0.7,0.7, 0.8,1,0.7,0.8,0.9,0.8,0.7,1,0.9,0.8,0.7,0.8,0.9,1),ncol=5) sigma2 <- matrix(c(1,0.4,0.5,0.6,0.5,0.4,1,0.3,0.5,0.7,0.5, 0.3,1,0.3,0.6,0.6,0.5,0.3,1,0.5,0.5,0.7,0.6,0.5,1),ncol=5) sigma3 <- matrix(c(1,0.1,0.2,0.3,0.2,0.1,1,0.2,0.3, 0.1,0.2,0.2,1,0.1,0.3,0.3,0.3,0.1, 1,0.2,0.2,0.1,0.3,0.2,1), ncol = 5) sigma4 <- matrix(rep(0.9, 25), ncol = 5) diag(sigma4) <- 1 sigma5 <- matrix(c(1,0.5,0.2,0.3,0.6, 0.5,1,0.2, 0.3,0.1, 0.2,0.2, 1, 0.8,0.3, 0.3,0.3,0.8, 1,0.2, 0.6,0.1,0.3, 0.2, 1), ncol = 5) sigma6 <- matrix(rep(0.1, 25),ncol=5) diag(sigma6) <- 1 sigma <- list(sigma1, sigma2, sigma3, sigma4, sigma5, sigma6) betas5 <- lapply(1:mult.obs, function(j) c(1.2,-0.2,-1)) thresholds5 <- list(c(-1, 0, 1), c(-2, 0, 2), c(-1.5, -0.5, 0, 0.5, 1.5), c(-2,-1,0,1,2), c(-1.5,-1,-0.5,0,0.5,1,1.5)) sim_data_6sec <- simulate.mvord.sec(sobs, betas = betas5, thresholds = thresholds5, sigma = sigma, link = link, seed = seed) linkfct <- switch(link, "probit" = mvprobit(), "logit" = mvlogit(df = 8L)) Y <- as.data.frame(sim_data_6sec[["y.ord"]]) for (j in 1:mult.obs) Y[, j] <- as.ordered(Y[, j]) colnames(Y) <- paste0("Y", 1:mult.obs) X <- sim_data_6sec[["predictors.fixed"]][[1]] colnames(X) <- paste0("X", 1:NCOL(X)) sec <- rep(1: nsec, sobs) df <- data.frame(Y, X, sec = factor(sec)) FORMULA <- as.formula(sprintf("MMO2(%s) ~ - 1 + %s", paste0(colnames(Y), collapse = ", "), paste0(colnames(X), collapse = " + "))) res <- mvord(FORMULA, data = df, error.structure = cor_general( ~ sec), link = linkfct) sum.res <- summary(res) sim_5J_6sec[[i]] <- rbind(sum.res[["thresholds"]][1:2], sum.res[["coefficients"]][1:2], sum.res[["error.structure"]][1:2]) ## introduce observations missing completely at random set.seed(2016) df[sample(1:NROW(df), NROW(df) * 0.05), 1] <- NA df[sample(1:NROW(df), NROW(df) * 0.2), 2] <- NA df[sample(1:NROW(df), NROW(df) * 0.5), 3] <- NA df[sample(1:NROW(df), NROW(df) * 0.1), 4] <- NA df[sample(1:NROW(df), NROW(df) * 0.7), 5] <- NA NA5 <- which(rowSums(is.na(df[, 1:mult.obs]))== 5) df[NA5, 1] <- Y[NA5, 1] resNA <- mvord(FORMULA, data = df, error.structure = cor_general( ~ sec), link = linkfct) sum.resNA <- summary(resNA) sim_5J_6sec_NA[[i]] <- rbind(sum.resNA[["thresholds"]][1:2], sum.resNA[["coefficients"]][1:2], sum.resNA[["error.structure"]][1:2]) } save(sim_5J_6sec, sim_5J_6sec_NA, file = sprintf("sim_5J_6sec_%s_%i_%i.rda",link, n, (s-1) %% 50 + 1)) } makeResultsFile5J <- function(link = c("probit", "logit"), n, rep = 20, cores = 50) { npar <- 98 resMat.5J <- matrix(ncol = 1000, nrow = npar) resMat.5J.NA <- matrix(ncol = 1000, nrow = npar) seMat.5J <- matrix(ncol = 1000, nrow = npar) seMat.5J.NA <- matrix(ncol = 1000, nrow = npar) for (i in 1:cores) { load(sprintf("sim_5J_6sec_%s_%i_%i.rda", link, n, i)) resMat.5J[, (i - 1) * rep + seq_len(rep)] <- sapply(sim_5J_6sec, function(x) x[,1]) resMat.5J.NA[, (i - 1) * rep + seq_len(rep)] <- sapply(sim_5J_6sec_NA, function(x) x[,1]) seMat.5J[, (i - 1) * rep + seq_len(rep)] <- sapply(sim_5J_6sec, function(x) x[,2]) seMat.5J.NA[, (i - 1) * rep + seq_len(rep)] <- sapply(sim_5J_6sec_NA, function(x) x[,2]) } save(resMat.5J, seMat.5J, resMat.5J.NA, seMat.5J.NA, file = sprintf("results_%s_5J_6sec_%i.RData", link, n)) } makeResultsFile5J("probit", 100) makeResultsFile5J("probit", 200) makeResultsFile5J("probit", 500) makeResultsFile5J("probit", 1000) makeResultsFile5J("logit", 100) makeResultsFile5J("logit", 200) makeResultsFile5J("logit", 500) makeResultsFile5J("logit", 1000) p <- function(x) { format(x, digits=2,nsmall=2, scientific = FALSE) # as.numeric(xx) #gsub("-", "$-$", xx) } #pvec <- function(x) as.numeric(format(x,digits=2,nsmall=2, scientific = FALSE)) percent_latex <- function(x, digits = 2, format = "f", ...) { per <- NULL perc <- paste0(formatC(100 * x, format = format, digits = digits, ...), "\\%") per[is.na(x)] <- "\\multicolumn{1}{c}{\\quad -}" per[!is.na(x)] <- sapply(perc[!is.na(x)], function(z){ if(grepl("-", z)){ paste0("$-$", substring(z, 2)) } else z}) per } computeTableMeasures <- function(resMat, seMat, param_true) { ME <- rowMeans(resMat) bias <- param_true - ME APB <- abs(((ME - param_true)/param_true)) APB[param_true == 0] <- NA sd.sample <- apply(resMat, 1, sd) mean.asy.se <- rowMeans(seMat) median.asy.se <- apply(seMat, 1, median) list(ME = ME, bias = bias, APB = APB, sd.sample = sd.sample, mean.asy.se = mean.asy.se, median.asy.se = median.asy.se) } make_5J_table <- function(link = c("probit", "logit"), n, param_true) { load(sprintf("results_%s_5J_6sec_%i.RData", link, n)) tab1 <- computeTableMeasures(resMat.5J, seMat.5J, param_true=param_true) tab2 <- computeTableMeasures(resMat.5J.NA, seMat.5J.NA,param_true=param_true) tab <- data.frame(param_true, rep(" ",length(tab1$ME)), tab1$ME, #bias.biv, percent_latex(tab1$APB,2), tab1$mean.asy.se, tab1$sd.sample, rep(" ",length(tab1$ME)), tab2$ME, #bias.triv, percent_latex(tab2$APB,2), tab2$median.asy.se, tab2$sd.sample, rep(" ",length(tab1$ME)), tab1$mean.asy.se/tab2$median.asy.se, tab1$sd.sample/tab2$sd.sample) rownames(tab) <- c( ## thetas "$\\theta_{1,1}$","$\\theta_{1,2}$","$\\theta_{1,3}$", "$\\theta_{2,1}$","$\\theta_{2,2}$","$\\theta_{2,3}$", "$\\theta_{3,1}$","$\\theta_{3,2}$","$\\theta_{3,3}$","$\\theta_{3,4}$","$\\theta_{3,5}$", "$\\theta_{4,1}$","$\\theta_{4,2}$","$\\theta_{4,3}$","$\\theta_{4,4}$","$\\theta_{4,5}$", "$\\theta_{5,1}$","$\\theta_{5,2}$","$\\theta_{5,3}$","$\\theta_{5,4}$","$\\theta_{5,5}$","$\\theta_{5,6}$","$\\theta_{5,7}$", ## betas "$\\beta_{1,1}$","$\\beta_{1,2}$","$\\beta_{1,3}$", "$\\beta_{2,1}$","$\\beta_{2,2}$","$\\beta_{2,3}$", "$\\beta_{3,1}$","$\\beta_{3,2}$","$\\beta_{3,3}$", "$\\beta_{4,1}$","$\\beta_{4,2}$","$\\beta_{4,3}$", "$\\beta_{5,1}$","$\\beta_{5,2}$","$\\beta_{5,3}$", ## correlations "$\\rho_{12}^1$","$\\rho_{13}^1$","$\\rho_{14}^1$","$\\rho_{15}^1$", "$\\rho_{23}^1$","$\\rho_{24}^1$","$\\rho_{25}^1$", "$\\rho_{34}^1$","$\\rho_{35}^1$","$\\rho_{45}^1$", "$\\rho_{12}^2$","$\\rho_{13}^2$","$\\rho_{14}^2$","$\\rho_{15}^2$", "$\\rho_{23}^2$","$\\rho_{24}^2$","$\\rho_{25}^2$", "$\\rho_{34}^2$","$\\rho_{35}^2$","$\\rho_{45}^2$", "$\\rho_{12}^3$","$\\rho_{13}^3$","$\\rho_{14}^3$","$\\rho_{15}^3$", "$\\rho_{23}^3$","$\\rho_{24}^3$","$\\rho_{25}^3$", "$\\rho_{34}^3$","$\\rho_{35}^3$","$\\rho_{45}^3$", "$\\rho_{12}^4$","$\\rho_{13}^4$","$\\rho_{14}^4$","$\\rho_{15}^4$", "$\\rho_{23}^4$","$\\rho_{24}^4$","$\\rho_{25}^4$", "$\\rho_{34}^4$","$\\rho_{35}^4$","$\\rho_{45}^4$", "$\\rho_{12}^5$","$\\rho_{13}^5$","$\\rho_{14}^5$","$\\rho_{15}^5$", "$\\rho_{23}^5$","$\\rho_{24}^5$","$\\rho_{25}^5$", "$\\rho_{34}^5$","$\\rho_{35}^5$","$\\rho_{45}^5$", "$\\rho_{12}^6$","$\\rho_{13}^6$","$\\rho_{14}^6$","$\\rho_{15}^6$", "$\\rho_{23}^6$","$\\rho_{24}^6$","$\\rho_{25}^6$", "$\\rho_{34}^6$","$\\rho_{35}^6$","$\\rho_{45}^6$") tab_char <- p(tab) tab_char <- apply(tab_char, 2, function(x) gsub("-", "$-$", x)) xtable::xtable(tab_char) } mult.obs <- 5 # number of responses sigma1 <- matrix(c(1,0.8,0.7,0.9,0.8,0.8,1,0.8,0.8,0.7,0.7, 0.8,1,0.7,0.8,0.9,0.8,0.7,1,0.9,0.8,0.7,0.8,0.9,1),ncol=5) sigma2 <- matrix(c(1,0.4,0.5,0.6,0.5,0.4,1,0.3,0.5,0.7,0.5, 0.3,1,0.3,0.6,0.6,0.5,0.3,1,0.5,0.5,0.7,0.6,0.5,1),ncol=5) sigma3 <- matrix(c(1,0.1,0.2,0.3,0.2,0.1,1,0.2,0.3, 0.1,0.2,0.2,1,0.1,0.3,0.3,0.3,0.1, 1,0.2,0.2,0.1,0.3,0.2,1), ncol = 5) sigma4 <- matrix(rep(0.9, 25), ncol = 5) diag(sigma4) <- 1 sigma5 <- matrix(c(1,0.5,0.2,0.3,0.6, 0.5,1,0.2, 0.3,0.1, 0.2,0.2, 1, 0.8,0.3, 0.3,0.3,0.8, 1,0.2, 0.6,0.1,0.3, 0.2, 1), ncol = 5) sigma6 <- matrix(rep(0.1, 25),ncol=5) diag(sigma6) <- 1 sigma <- list(sigma1, sigma2, sigma3, sigma4, sigma5, sigma6) betas5 <- rep(c(1.2,-0.2,-1), each = 5) thresholds5 <- list(c(-1, 0, 1), c(-2, 0, 2), c(-1.5, -0.5, 0, 0.5, 1.5), c(-2,-1,0,1,2), c(-1.5,-1,-0.5,0,0.5,1,1.5)) parametersTrue <- c(unlist(thresholds5), unlist(betas5), unlist(lapply(sigma, function(x) x[lower.tri(x)]))) make_5J_table("probit", 1000, param_true = parametersTrue)