#
#   Copyright 2007-2019 by the individuals mentioned in the source code history
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
# 
#        http://www.apache.org/licenses/LICENSE-2.0
# 
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.


#------------------------------------------------------------------------------
# Author: Michael D. Hunter
# Date: 2015-03-11
# Filename: ModificationIndexCheck.R
# Purpose: Check that modification indices are behaving reasonably.
#------------------------------------------------------------------------------



#------------------------------------------------------------------------------
# Factor model check

require(OpenMx)

vv <- c("No","Yes")

for(v in vv){
	mxOption(NULL,"Analytic Gradients",v); mxOption(NULL,"Analytic RAM derivatives",v)
	
	data(demoOneFactor)
	manifests <- names(demoOneFactor)
	latents <- c("G")
	factorModel <- mxModel(
		"One Factor",
		type="RAM",
		manifestVars = manifests,
		latentVars = latents,
		mxPath(from=latents, to=manifests),
		mxPath(from=manifests, arrows=2),
		mxPath(from=latents, arrows=2,
					 free=FALSE, values=1.0),
		mxPath(from = 'one', to = manifests),
		mxData(demoOneFactor, type="raw"))
	factorRun <- mxRun(factorModel)
	
	# This test script fails when CSOLNP and NPSOL are in use with analytic gradients.  The reason is that they both reach a solution such that, 
	# when it comes time to compute the modification index for the sole fixed parameter in the 'M' matrix, the corresponding 
	# "full Hessian" is just barely uninvertible.  This seems to simply be an edge case, due to "bad luck".
	mm <- c("A","S","M")
	if(mxOption(NULL,"Analytic gradients")=="Yes" && mxOption(NULL,"Default optimizer")!="SLSQP"){
		mm <- c("A","S")
	}
	fim <- mxMI(factorRun,matrices=mm)
	
	
	mplusON.mi <- c(NA, 0.001, 1.582, .272, .285, NA, 0.001, NA, 1.540, 4.041, .748, NA, 1.582, 1.540, NA, .151, 5.339, NA, .272, 4.042, .151, NA, 3.574, NA, NA, .748, 5.339, 3.574, NA, NA, NA)
	mplusWITH.mi <- c(0.001, 1.582, 1.540, .272, NA, .151, .285, .748, 5.339, 3.574)
	
	Adiag <- c(1L, 8L, 15L, 22L, 29L, 31L)
	mplus.mi <- c(mplusON.mi[-Adiag], mplusWITH.mi)
	
	plot(fim$MI.Full[1:length(mplus.mi)], mplus.mi)
	abline(a=0, b=1)
	points(fim$MI[1:length(mplus.mi)], mplus.mi, col='blue')
	(theCor <- cor(fim$MI.Full[1:length(mplus.mi)], mplus.mi, use="pair"))
	rms <- function(x, y){sqrt(mean((x-y)^2, na.rm=TRUE))}
	(theRMS <- rms(fim$MI.Full[1:length(mplus.mi)], mplus.mi))
	
	omxCheckTrue(theCor > 0.95)
	omxCheckTrue(theRMS < 0.50)
	
	omCheck <- fim$MI.Full[1:length(mplus.mi)][!is.na(mplus.mi)]
	mpCheck <- mplus.mi[!is.na(mplus.mi)]
	relMean <- mean(omCheck/mpCheck)
	omxCheckTrue( relMean < 1.05 & relMean > 0.95)
	
	
	#------------------------------------------------------------------------------
	# State space model check
	
	
	# Create data based on state space model.
	require(OpenMx)
	nvar <- 5
	varnames <- paste("x", 1:nvar, sep="")
	ssModel <- mxModel(
		model="State Space Manual Example",
		mxMatrix("Full", 1, 1, TRUE, .3, name="A"),
		mxMatrix("Zero", 1, 1, name="B"),
		mxMatrix("Full", nvar, 1, TRUE, .6, name="C", dimnames=list(varnames, "F1")),
		mxMatrix("Zero", nvar, 1, name="D"),
		mxMatrix("Diag", 1, 1, FALSE, 1, name="Q"),
		mxMatrix("Diag", nvar, nvar, TRUE, .2, name="R"),
		mxMatrix("Zero", 1, 1, name="x0"),
		mxMatrix("Diag", 1, 1, FALSE, 1, name="P0"),
		mxMatrix("Zero", 1, 1, name="u"),
		mxExpectationStateSpace("A", "B", "C", "D", "Q", "R", "x0", "P0", "u"),
		mxFitFunctionML()
	)
	
	
	Rmis <- ssModel$R
	lsel <- lower.tri(Rmis$values, TRUE)
	mval <- Rmis$values[lsel]
	mval[2] <- .05
	mfre <- Rmis$free[lsel]
	mfre[2] <- TRUE
	mlab <- Rmis$labels[lsel]
	Rmis <- mxMatrix("Symm", nrow(Rmis), ncol(Rmis), values=mval, labels=mlab, free=mfre, name=Rmis$name)
	ssMis <- mxModel(ssModel, Rmis)
	
	set.seed(101)
	ssMisData <- mxGenerateData(ssMis, 200)
	
	ssMisRun <- mxRun(mxModel(ssModel, mxData(ssMisData, 'raw')))
	
	mi.mis <- mxMI(ssMisRun, full=FALSE)
	
	if( any(mi.mis$MI > qchisq(p=1-0.01, df=1), na.rm=TRUE)){
		print("Large modification index found")
		# Grab the plus.param model that has the highest modification index
		newModelAttempt <- mi.mis$plusOneParamModels[[which.max(mi.mis$MI)]]
		newRunAttempt <- mxRun(newModelAttempt)
		mi.cor <- mxMI(newRunAttempt, full=FALSE)
		foundFirst <- TRUE
		if(  any(mi.cor$MI > qchisq(p=1-0.01, df=1), na.rm=TRUE ) ){
			print("Problem.  Model still may need modification")
			foundSecond <- TRUE
		} else{
			print("Success.  All modification indices are sufficiently small now.")
			foundSecond <- FALSE
		}
		fim <- mxMI(factorRun)
		
		
		mplusON.mi <- c(NA, 0.001, 1.582, .272, .285, NA, 0.001, NA, 1.540, 4.041, .748, NA, 1.582, 1.540, NA, .151, 5.339, NA, .272, 4.042, .151, NA, 3.574, NA, NA, .748, 5.339, 3.574, NA, NA, NA)
		mplusWITH.mi <- c(0.001, 1.582, 1.540, .272, NA, .151, .285, .748, 5.339, 3.574)
		
		Adiag <- c(1L, 8L, 15L, 22L, 29L, 31L)
		mplus.mi <- c(mplusON.mi[-Adiag], mplusWITH.mi)
		
		plot(fim$MI.Full[1:length(mplus.mi)], mplus.mi)
		abline(a=0, b=1)
		points(fim$MI[1:length(mplus.mi)], mplus.mi, col='blue')
		(theCor <- cor(fim$MI.Full[1:length(mplus.mi)], mplus.mi, use="pair"))
		rms <- function(x, y){sqrt(mean((x-y)^2, na.rm=TRUE))}
		(theRMS <- rms(fim$MI.Full[1:length(mplus.mi)], mplus.mi))
		
		omxCheckTrue(theCor > 0.95)
		omxCheckTrue(theRMS < 0.50)
		
		omCheck <- fim$MI.Full[1:length(mplus.mi)][!is.na(mplus.mi)]
		mpCheck <- mplus.mi[!is.na(mplus.mi)]
		relMean <- mean(omCheck/mpCheck)
		omxCheckTrue( relMean < 1.05 & relMean > 0.95)
		
		
		#------------------------------------------------------------------------------
		# State space model check
		
		
		# Create data based on state space model.
		require(OpenMx)
		nvar <- 5
		varnames <- paste("x", 1:nvar, sep="")
		ssModel <- mxModel(model="State Space Manual Example",
											 mxMatrix("Full", 1, 1, TRUE, .3, name="A"),
											 mxMatrix("Zero", 1, 1, name="B"),
											 mxMatrix("Full", nvar, 1, TRUE, .6, name="C", dimnames=list(varnames, "F1")),
											 mxMatrix("Zero", nvar, 1, name="D"),
											 mxMatrix("Diag", 1, 1, FALSE, 1, name="Q"),
											 mxMatrix("Diag", nvar, nvar, TRUE, .2, name="R"),
											 mxMatrix("Zero", 1, 1, name="x0"),
											 mxMatrix("Diag", 1, 1, FALSE, 1, name="P0"),
											 mxMatrix("Zero", 1, 1, name="u"),
											 mxExpectationStateSpace("A", "B", "C", "D", "Q", "R", "x0", "P0", "u"),
											 mxFitFunctionML()
		)
		
		
		Rmis <- ssModel$R
		lsel <- lower.tri(Rmis$values, TRUE)
		mval <- Rmis$values[lsel]
		mval[2] <- .05
		mfre <- Rmis$free[lsel]
		mfre[2] <- TRUE
		mlab <- Rmis$labels[lsel]
		Rmis <- mxMatrix("Symm", nrow(Rmis), ncol(Rmis), values=mval, labels=mlab, free=mfre, name=Rmis$name)
		ssMis <- mxModel(ssModel, Rmis)
		
		set.seed(101)
		ssMisData <- mxGenerateData(ssMis, 400)
		
		ssMisRun <- mxRun(mxModel(ssModel, mxData(ssMisData, 'raw')))
		
		mi.mis <- mxMI(ssMisRun, full=FALSE)
		
		if( any(mi.mis$MI > qchisq(p=0.05, df=1, lower.tail=FALSE), na.rm=TRUE)){
			print("Large modification index found")
			# Grab the plus.param model that has the highest modification index
			newModelAttempt <- mi.mis$plusOneParamModels[[which.max(mi.mis$MI)]]
			newRunAttempt <- mxRun(newModelAttempt)
			mi.cor <- mxMI(newRunAttempt, full=FALSE)
			foundFirst <- TRUE
			if(  any(mi.cor$MI > qchisq(p=0.05, df=1, lower.tail=FALSE), na.rm=TRUE ) ){
				print("Problem.  Model still may need modification")
				foundSecond <- TRUE
			} else{
				foundFirst <- FALSE
			}
			
			omxCheckTrue(all( c(foundFirst, foundSecond) == c(TRUE, FALSE) ) )
			
			prevMIsForSS <- c(0.000002, 10.827511, 1.664330, 2.062372, 1.211038,
												1.428606, 3.021569, 1.749314, 0.752319, 2.663316, 1.167776,
												0.032929, -0.186243)
			
			miSSCheck <- mi.mis$MI[!is.na(mi.mis$MI)]
			miSSCheck <- miSSCheck[-length(miSSCheck)]
			prevMIsForSS <- prevMIsForSS[-length(prevMIsForSS)]
			
			omxCheckCloseEnough(miSSCheck, prevMIsForSS, 0.01)
			
			#------------------------------------------------------------------------------
			# State space model check
			# Similar to the above, but tests the respect of fixed parameter labels.
			# When a fixed parameter occurs in more than one spot (and thus necessarily
			#  has a label), it is freed by its label instead of by the matrix element.
			
			
			# Create data based on state space model.
			require(OpenMx)
			nvar <- 5
			varnames <- paste("x", 1:nvar, sep="")
			ssModel <- mxModel(
				model="State Space Manual Example",
				mxMatrix("Full", 1, 1, TRUE, .3, name="A"),
				mxMatrix("Zero", 1, 1, name="B"),
				mxMatrix("Full", nvar, 1, TRUE, .6, name="C", dimnames=list(varnames, "F1")),
				mxMatrix("Zero", nvar, 1, name="D"),
				mxMatrix("Diag", 1, 1, FALSE, 1, name="Q"),
				mxMatrix("Diag", nvar, nvar, c(F, F, T, T, T), .2, name="R", labels=paste('resid', c(1, 1, 3:nvar), sep='')),
				mxMatrix("Zero", 1, 1, name="x0"),
				mxMatrix("Diag", 1, 1, FALSE, 1, name="P0"),
				mxMatrix("Zero", 1, 1, name="u"),
				mxExpectationStateSpace("A", "B", "C", "D", "Q", "R", "x0", "P0", "u"),
				mxFitFunctionML()
			)
			
			
			Rmis <- ssModel$R
			lsel <- lower.tri(Rmis$values, TRUE)
			mval <- Rmis$values[lsel]
			mval[2] <- .05
			mfre <- Rmis$free[lsel]
			mfre[2] <- TRUE
			mlab <- Rmis$labels[lsel]
			Rmis <- mxMatrix("Symm", nrow(Rmis), ncol(Rmis), values=mval, labels=mlab, free=mfre, name=Rmis$name)
			ssMis <- mxModel(ssModel, Rmis)
			
			set.seed(101)
			ssMisData <- mxGenerateData(ssMis, 200)
			
			ssMisRun <- mxRun(mxModel(ssModel, mxData(ssMisData, 'raw')))
			
			mi.mis <- mxMI(ssMisRun, full=FALSE)
			
			if( any(mi.mis$MI > qchisq(p=1-0.01, df=1), na.rm=TRUE)){
				print("Large modification index found")
				# Grab the plus.param model that has the highest modification index
				newModelAttempt <- mi.mis$plusOneParamModels[[which.max(mi.mis$MI)]]
				newRunAttempt <- mxRun(newModelAttempt)
				mi.cor <- mxMI(newRunAttempt, full=FALSE)
				foundFirst <- TRUE
				if(  any(mi.cor$MI > qchisq(p=1-0.01, df=1), na.rm=TRUE ) ){
					print("Problem.  Model still may need modification")
					foundSecond <- TRUE
				} else{
					print("Success.  All modification indices are sufficiently small now.")
					foundSecond <- FALSE
				}
			} else{
				foundFirst <- FALSE
			}
			
			omxCheckTrue(all( c(foundFirst, foundSecond) == c(TRUE, FALSE) ) )
			
			
			prevMIsForSS <- c(0.000000, 5.201267, 1.857374, 0.681598, 1.678599,
												0.247626, 0.962515, 0.018834, 4.511735, 3.853470, 0.000809, 0.032943)
			
			miSSCheck <- mi.mis$MI[!is.na(mi.mis$MI)]
			miSSCheck <- miSSCheck[-length(miSSCheck)]
			
			omxCheckCloseEnough(miSSCheck, prevMIsForSS, 0.01)
			
			#------------------------------------------------------------------------------
			# State space model check
			# Similar to the above, but tests the respect of fixed parameter labels.
			# When a fixed parameter occurs in more than one spot (and thus necessarily
			#  has a label), it is freed by its label instead of by the matrix element.
			
			
			# Create data based on state space model.
			require(OpenMx)
			nvar <- 5
			varnames <- paste("x", 1:nvar, sep="")
			ssModel <- mxModel(model="State Space Manual Example",
												 mxMatrix("Full", 1, 1, TRUE, .3, name="A"),
												 mxMatrix("Zero", 1, 1, name="B"),
												 mxMatrix("Full", nvar, 1, TRUE, .6, name="C", dimnames=list(varnames, "F1")),
												 mxMatrix("Zero", nvar, 1, name="D"),
												 mxMatrix("Diag", 1, 1, FALSE, 1, name="Q"),
												 mxMatrix("Diag", nvar, nvar, c(F, F, T, T, T), .2, name="R", labels=paste('resid', c(1, 1, 3:nvar), sep='')),
												 mxMatrix("Zero", 1, 1, name="x0"),
												 mxMatrix("Diag", 1, 1, FALSE, 1, name="P0"),
												 mxMatrix("Zero", 1, 1, name="u"),
												 mxExpectationStateSpace("A", "B", "C", "D", "Q", "R", "x0", "P0", "u"),
												 mxFitFunctionML()
			)
			
			
			Rmis <- ssModel$R
			lsel <- lower.tri(Rmis$values, TRUE)
			mval <- Rmis$values[lsel]
			mval[2] <- .05
			mfre <- Rmis$free[lsel]
			mfre[2] <- TRUE
			mlab <- Rmis$labels[lsel]
			Rmis <- mxMatrix("Symm", nrow(Rmis), ncol(Rmis), values=mval, labels=mlab, free=mfre, name=Rmis$name)
			ssMis <- mxModel(ssModel, Rmis)
			
			set.seed(101)
			ssMisData <- mxGenerateData(ssMis, 200)
			
			ssMisRun <- mxRun(mxModel(ssModel, mxData(ssMisData, 'raw')))
			
			mi.mis <- mxMI(ssMisRun, full=FALSE)
			
			if( any(mi.mis$MI > qchisq(p=1-0.01, df=1), na.rm=TRUE)){
				print("Large modification index found")
				# Grab the plus.param model that has the highest modification index
				newModelAttempt <- mi.mis$plusOneParamModels[[which.max(mi.mis$MI)]]
				newRunAttempt <- mxRun(newModelAttempt)
				mi.cor <- mxMI(newRunAttempt, full=FALSE)
				foundFirst <- TRUE
				if(  any(mi.cor$MI > qchisq(p=1-0.01, df=1), na.rm=TRUE ) ){
					print("Problem.  Model still may need modification")
					foundSecond <- TRUE
				} else{
					foundFirst <- FALSE
				}
				
				omxCheckTrue(all( c(foundFirst, foundSecond) == c(TRUE, FALSE) ) )
				
				
				miSSCheck <- mi.mis$MI[!is.na(mi.mis$MI)]
				miSSCheck <- miSSCheck['resid1']
				prevMIsForSS <- 3.909195
				
				omxCheckCloseEnough(miSSCheck, prevMIsForSS, 0.01)
				
				
			}
		}
	}
}
mxOption(reset=TRUE)
