# Code to generate data similar to the simulation study iter <- 1 set.seed( iter ) library( MCMCpack ) library( dirmult ) library( mvtnorm ) library( MicroMiss ) # Generate data active_cov <- 25 # Number of compositional elements with active association with covariates data <- simulate_MicroMiss( N = 50, T. = 50, C. = 50, P_eta = 2, P_gamma = 2, total = 10000, active_cov = active_cov ) # Set up parameters iterations <- 5000 thin <- 5 samples <- floor(iterations/thin) Z <- array( 0, dim = c( data$N, data$T., samples ) ) Zsum <- rowSums( data$Y ) alpha_it <- array( 0, dim = c( data$N, data$T., samples ) ) mu_i <- matrix( 0, data$N, samples ) zeta_it <- array( 0, dim = c( data$N, data$T., samples ) ) omega_eta <- array( 0, dim = c( data$N, data$T., samples ) ) beta_eta <- array( 0, dim = c( data$T., data$P_eta, samples ) ) beta_gamma <- array( 0, dim = c( data$T., data$P_gamma, samples ) ) a_tc <- array( 0, dim = c( data$T., data$C., samples ) ) u_t <- rep( 1, data$T. ) # Set up priors nu <- matrix( 1, nrow = data$T., ncol = data$C. ) diag(nu) <- 100 mu_beta_eta_prior <- matrix( 0, data$T., data$P_eta ) mu_beta_gamma_prior <- matrix( 0, data$T., data$P_gamma ) sigma2_beta_eta <- 5 sigma2_beta_gamma <- 5 # Initialize Z[ , , 1 ] <- data$Y alpha_it[ , , 1 ] <- data$Y for( n in 1:nrow( data$Y ) ){ sum_Z <- sum( data$Y[ n, ] ) mu_i[ n, 1 ] <- rgamma( 1, sum_Z, sum_Z ); } zeta_it[ , , 1 ] <- 1 omega_eta[ , , 1 ] <- 1 a_tc[ , , 1 ] <- 1 # Beta gamma true beta_gamma_true <- data$beta_gamma_true X_gamma <- data$X_gamma effect <- function(beta, cov, j, p){ adding <- rep( 0, length( cov ) ) adding[ p ] <- 1 exp( beta[ j, p ] )*sum( exp( beta%*%cov ) ) / sum( exp( beta%*%(cov + adding ) ) ) } true_gamma_unit <- array( 0, dim = c( data$N, data$T., data$P_gamma - 1 ) ) for( p in 2:data$P_gamma ){ for( i in 1:data$N ){ for( t in 1:data$T. ){ true_gamma_unit[ i, t, p - 1 ] <- effect( beta_gamma_true, X_gamma[ i, ], t, p ) } } } ptm_MicroMiss <- proc.time() output <- MicroMiss( iterations, thin, data$N, data$T., data$C., data$P_eta, data$P_gamma, data$Y, Z, Zsum, alpha_it, zeta_it, beta_eta, data$X_eta, omega_eta, beta_gamma, data$X_gamma, mu_i, a_tc, u_t, nu, mu_beta_eta_prior, mu_beta_gamma_prior, sigma2_beta_eta, sigma2_beta_gamma ) time_MicroMiss <- proc.time() - ptm_MicroMiss names( output ) <- c( "Z", "alpha_t", "zeta", "beta_eta", "omega_eta", "a_tc", "beta_gamma", "mu") # at-risk coeff post_beta_eta_MicroMiss <- apply( output$beta_eta[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), mean ) post_beta_eta_MicroMiss_upper <- apply( output$beta_eta[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), function( x ){ quantile( x , 0.975 ) } ) post_beta_eta_MicroMiss_lower <- apply( output$beta_eta[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), function( x ){ quantile( x , 0.025 ) } ) abs_beta_eta_MicroMiss_sig <- c( abs( post_beta_eta_MicroMiss[,-1] - data$beta_eta_true[,-1] ) )[ data$beta_eta_true[,-1] != 0 ] abs_beta_eta_MicroMiss_non <- c( abs( post_beta_eta_MicroMiss[,-1] - data$beta_eta_true[,-1] ) )[ data$beta_eta_true[,-1] == 0 ] cov_beta_eta_MicroMiss <- post_beta_eta_MicroMiss_upper[,-1] > data$beta_eta_true[,-1] & post_beta_eta_MicroMiss_lower[,-1] < data$beta_eta_true[,-1] cov_beta_eta_MicroMiss_sig <- cov_beta_eta_MicroMiss[ data$beta_eta_true[,-1] != 0 ] cov_beta_eta_MicroMiss_non <- cov_beta_eta_MicroMiss[ data$beta_eta_true[,-1] == 0 ] # Beta_gamma post_beta_gamma_MicroMiss <- apply( output$beta_gamma[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), mean ) post_beta_gamma_MicroMiss_upper <- apply( output$beta_gamma[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), function( x ){ quantile( x , 0.975 ) } ) post_beta_gamma_MicroMiss_lower <- apply( output$beta_gamma[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), function( x ){ quantile( x , 0.025 ) } ) abs_beta_gamma_MicroMiss_sig <- c( abs( post_beta_gamma_MicroMiss[,-1] - data$beta_gamma_true[,-1] ) )[ data$beta_gamma_true[,-1] != 0 ] abs_beta_gamma_MicroMiss_non <- c( abs( post_beta_gamma_MicroMiss[,-1] - data$beta_gamma_true[,-1] ) )[ data$beta_gamma_true[,-1] == 0 ] cov_beta_gamma_MicroMiss <- post_beta_gamma_MicroMiss_upper[,-1] > data$beta_gamma_true[,-1] & post_beta_gamma_MicroMiss_lower[,-1] < data$beta_gamma_true[,-1] cov_beta_gamma_MicroMiss_sig <- cov_beta_gamma_MicroMiss[ data$beta_gamma_true[,-1] != 0 ] cov_beta_gamma_MicroMiss_non <- cov_beta_gamma_MicroMiss[ data$beta_gamma_true[,-1] == 0 ] # Misclassification probability a_norm_t <- apply( output$a_tc[ , , (floor(samples)/2 + 1):(floor(samples)) ], c(1,3), sum ) theta <- output$a_tc[ , , (floor(samples)/2 + 1):(floor(samples)) ] for (i in 1:length((floor(samples)/2 + 1):(floor(samples))) ){ theta[,,i] <- theta[,,i]/a_norm_t[,i] } post_theta <- apply( theta , c(1,2), mean ) post_theta_upper <- apply( theta , c(1,2), function( x ){ quantile( x , 0.975 ) } ) post_theta_lower <- apply( theta , c(1,2), function( x ){ quantile( x , 0.025 ) } ) abs_theta_MicroMiss <- abs( c( post_theta - data$classifications ) ) cov_theta_MicroMiss <- c( post_theta_upper > data$classifications & post_theta_lower < data$classifications ) # Relative abundance alpha_norm_MicroMiss <- apply( output$alpha_t[ , , (floor(samples)/2 + 1):(floor(samples)) ], c(1,3), sum ) psi_MicroMiss <- output$alpha_t[ , , (floor(samples)/2 + 1):(floor(samples)) ] for (i in 1:length((floor(samples)/2 + 1):(floor(samples))) ){ psi_MicroMiss[,,i] <- psi_MicroMiss[,,i]/alpha_norm_MicroMiss[,i] } post_psi_MicroMiss <- apply( psi_MicroMiss , c(1,2), mean ) post_psi_MicroMiss_upper <- apply( psi_MicroMiss , c(1,2), function( x ){ quantile( x , 0.975 ) } ) post_psi_MicroMiss_lower <- apply( psi_MicroMiss , c(1,2), function( x ){ quantile( x , 0.025 ) } ) abs_psi_MicroMiss <- c( abs( post_psi_MicroMiss - data$true_prob ) ) cov_psi_MicroMiss <- c( post_psi_MicroMiss_upper > data$true_prob & post_psi_MicroMiss_lower < data$true_prob ) # Multiplicative Effect on RA gamma_unit_mean <- array( 0, dim = c( data$N, dim(output$beta_gamma)[1], dim(output$beta_gamma)[2] - 1 ) ) gamma_unit_upper <- array( 0, dim = c( data$N, dim(output$beta_gamma)[1], dim(output$beta_gamma)[2] - 1 ) ) gamma_unit_lower <- array( 0, dim = c( data$N, dim(output$beta_gamma)[1], dim(output$beta_gamma)[2] - 1 ) ) for( p in 2:data$P_gamma ){ MCMC_gamma_unit <- array( 0, dim = c( data$N, dim(output$beta_gamma)[1], samples ) ) MCMC_gamma_unit <- effects_all(output$beta_gamma, X_gamma, data$T., samples, p-1 ) gamma_unit_mean[,,p - 1] <- apply( MCMC_gamma_unit[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), mean ) gamma_unit_upper[,,p - 1] <- apply( MCMC_gamma_unit[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), function( x ){ quantile( x , 0.975 ) } ) gamma_unit_lower[,,p - 1] <- apply( MCMC_gamma_unit[ , , (floor(samples)/2 + 1):(floor(samples)) ] , c(1,2), function( x ){ quantile( x , 0.025 ) } ) } ave_gamma_MicroMiss <- mean( abs( gamma_unit_mean - true_gamma_unit ) ) cov_gamma_MicroMiss <- mean( c( gamma_unit_upper > true_gamma_unit & gamma_unit_lower < true_gamma_unit )) # Compile results out = list( abs_beta_eta_MicroMiss_sig = mean( abs_beta_eta_MicroMiss_sig ), cov_beta_eta_MicroMiss_sig = mean( cov_beta_eta_MicroMiss_sig ), abs_beta_eta_MicroMiss_non = mean( abs_beta_eta_MicroMiss_non ), cov_beta_eta_MicroMiss_non = mean( cov_beta_eta_MicroMiss_non ), abs_beta_gamma_MicroMiss_sig = mean( abs_beta_gamma_MicroMiss_sig ), cov_beta_gamma_MicroMiss_sig = mean( cov_beta_gamma_MicroMiss_sig ), abs_beta_gamma_MicroMiss_non = mean( abs_beta_gamma_MicroMiss_non ), cov_beta_gamma_MicroMiss_non = mean( cov_beta_gamma_MicroMiss_non ), abs_theta_MicroMiss = mean( abs_theta_MicroMiss ), cov_theta_MicroMiss = mean( cov_theta_MicroMiss ), ave_gamma_MicroMiss = ave_gamma_MicroMiss, cov_gamma_MicroMiss = cov_gamma_MicroMiss, abs_psi_MicroMiss = mean( abs_psi_MicroMiss ), cov_psi_MicroMiss = mean( cov_psi_MicroMiss ), time_MicroMiss = as.numeric( time_MicroMiss[ 3 ] ) )