score <- function(input) {
    return(subroutine0(input))
}
subroutine0 <- function(input) {
    return(((0) + (subroutine1(input))) + (subroutine2(input)))
}
subroutine1 <- function(input) {
    if ((input[6]) > (6.918000000000001)) {
        if ((input[6]) > (7.437)) {
            var0 <- 24.81112131071211
        } else {
            var0 <- 23.5010290754961
        }
    } else {
        if ((input[13]) > (14.365)) {
            var0 <- 21.796569516771488
        } else {
            var0 <- 22.640634908349323
        }
    }
    return(var0)
}
subroutine2 <- function(input) {
    if ((input[13]) > (9.63)) {
        if ((input[13]) > (19.23)) {
            var0 <- -0.9218520876020193
        } else {
            var0 <- -0.30490175606373926
        }
    } else {
        if ((input[6]) > (7.437)) {
            var0 <- 2.028554553190867
        } else {
            var0 <- 0.45970642160364367
        }
    }
    return(var0)
}


	# DATA SETUP

		charity = read.csv("./charity.csv")
		charity.t = charity
		charity.t$avhv = log(charity.t$avhv)
		charity.t$agif = log(charity.t$agif)
		charity.t$inca = log(charity.t$inca)
		charity.t$incm = log(charity.t$incm)
		charity.t$lgif = log(charity.t$lgif)
		charity.t$rgif = log(charity.t$rgif)
		charity.t$tgif = log(charity.t$tgif)
		charity.t$tlag = log(charity.t$tlag)

		data.train = charity.t[charity$part=="train",]
		x.train = data.train[,2:21]
		c.train = data.train[,22] # donr
		n.train.c = length(c.train) # 3984
		y.train = data.train[c.train==1,23] # damt for observations with donr=1
		# x.train.mat = model.matrix(damt~., data.train[c.train==1,2:23])[,-22]
		n.train.y = length(y.train) # 1995

		data.valid = charity.t[charity$part=="valid",]
		x.valid = data.valid[,2:21]
		c.valid = data.valid[,22] # donr
		n.valid.c = length(c.valid) # 2018
		y.valid = data.valid[c.valid==1,23] # damt for observations with donr=1
		#x.valid.mat = model.matrix(damt~., data.valid[c.valid==1,2:23])[,-22]
		n.valid.y = length(y.valid) # 999

		data.test = charity.t[charity$part=="test",]
		n.test = dim(data.test)[1] # 2007
		x.test = data.test[,2:21]

		x.train.mean = apply(x.train, 2, mean)
		x.train.sd = apply(x.train, 2, sd)
		x.train.std = t((t(x.train)-x.train.mean)/x.train.sd) # standardize to have zero mean and unit sd
		# x.train.mat.mean = apply(x.train.mat, 2, mean)
		# x.train.mat.sd = apply(x.train.mat, 2, sd)
		# x.train.mat.std = t((t(x.train.mat)-x.train.mat.mean)/x.train.mat.sd) # standardize to have zero mean and unit sd
		apply(x.train.std, 2, mean) # check zero mean
		apply(x.train.std, 2, sd) # check unit sd
		data.train.std.c = data.frame(x.train.std, donr=c.train) # to classify donr
		data.train.std.y = data.frame(x.train.std[c.train==1,], damt=y.train) # to predict damt when donr=1

		x.valid.std = t((t(x.valid)-x.train.mean)/x.train.sd) # standardize using training mean and sd
		# x.valid.mat.std = t((t(x.valid.mat)-x.train.mat.mean)/x.train.mat.sd) # standardize to have zero mean and unit sd
		data.valid.std.c = data.frame(x.valid.std, donr=c.valid) # to classify donr
		data.valid.std.y = data.frame(x.valid.std[c.valid==1,], damt=y.valid) # to predict damt when donr=1

		x.test.std = t((t(x.test)-x.train.mean)/x.train.sd) # standardize using training mean and sd
		data.test.std = data.frame(x.test.std)

		train.dat = data.frame(x = x.train.std, y = as.factor(data.train.std.c$donr))
		valid.dat = data.frame(x = x.valid.std, y = as.factor(data.valid.std.c$donr))

	#LIBRARIES

		library(MASS)
		library(tree)
		library(randomForest)
		library(gbm)
		library(e1071)
		library(lars)
		library(leaps)
		library(glmnet)
		library(pls)
		library(splines)
		library(gam)
		library(ISLR)

	#CLASSIFICATION MODELS: LDA, TREES-BASED, AND SVM

		#LDA Model Base
			model.ldaB = lda(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
								x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
								x.tlag + x.agif,
							  train.dat) # include additional terms on the fly using I()

			post.valid.ldaB = predict(model.ldaB, valid.dat)$posterior[,2] # n.valid.c post probs

			profit.ldaB = cumsum(14.5*c.valid[order(post.valid.ldaB, decreasing=T)]-2)
			plot(profit.ldaB) # see how profits change as more mailings are made
			n.mail.valid = which.max(profit.ldaB) # number of mailings that maximizes profits
			c(n.mail.valid, max(profit.ldaB)) # report number of mailings and maximum profit

			cutoff.ldaB = sort(post.valid.ldaB, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
			chat.valid.ldaB = ifelse(post.valid.ldaB>cutoff.ldaB, 1, 0) # mail to everyone above the cutoff
			ldaB.table = table(chat.valid.ldaB, c.valid) # classification table
				ldaB.mail = sum(ldaB.table[2,])
				ldaB.mail.tp = ldaB.table[2,2]
				ldaB.error = (ldaB.table[2,1]+ldaB.table[1,2])/2018
				ldaB.profit = 14.5*ldaB.mail.tp - 2*ldaB.mail

				ldaB.error #validation error rate: 0.2235
				ldaB.mail #total mailings: 1,406
				ldaB.profit #total profit: $11,354.50

		#LDA Model Base + Quad (hinc, chld, tdon, tlag, wrat, inca, npro, tgif)
			model.ldaF = lda(y ~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
					 x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
					 I(x.inca^2) + I(x.npro^2) + I(x.tgif^2),
                 train.dat) # include additional terms on the fly using I()

			post.valid.ldaF = predict(model.ldaF, valid.dat)$posterior[,2] # n.valid.c post probs

			profit.ldaF = cumsum(14.5*c.valid[order(post.valid.ldaF, decreasing=T)]-2)
			#plot(profit.ldaF) # see how profits change as more mailings are made
			n.mail.valid = which.max(profit.ldaF) # number of mailings that maximizes profits
			c(n.mail.valid, max(profit.ldaF)) # report number of mailings and maximum profit

			cutoff.ldaF = sort(post.valid.ldaF, decreasing=T)[n.mail.valid+1] # set cutoff based on n.mail.valid
			chat.valid.ldaF = ifelse(post.valid.ldaF>cutoff.ldaF, 1, 0) # mail to everyone above the cutoff
			ldaF.table = table(chat.valid.ldaF, c.valid) # classification table
				ldaF.mail = sum(ldaF.table[2,])
				ldaF.mail.tp = ldaF.table[2,2]
				ldaF.error = (ldaF.table[2,1]+ldaF.table[1,2])/2018
				ldaF.profit = 14.5*ldaF.mail.tp - 2*ldaF.mail

				ldaF.error #validation error rate: 0.1660
				ldaF.mail #total mailings: 1,326
				ldaF.profit #total profit: $11,775.50

		#CLASSIFICATION TREE, BASE MODEL

				model.treeB=tree(y~.,train.dat)
				summary(model.treeB)
				model.treeB

				tree.pred=predict(model.treeB,valid.dat,type="class")
				treeB.table = table(tree.pred,valid.dat$y)
				treeB.mail = sum(treeB.table[2,])
				treeB.mail.tp = treeB.table[2,2]
				treeB.error = (treeB.table[2,1]+treeB.table[1,2])/2018
				treeB.profit = 14.5*treeB.mail.tp - 2*treeB.mail

				treeB.error #validation error rate: 0.1516
				treeB.mail #total mailings: 1,165
				treeB.profit #total profit: $11,140.50

		#CLASSIFICATION TREE, RANDOM FORESTS MODEL

			#THE BELOW LOOP TO DISCOVER WHICH SEED RETURNS MAXIMUM PROFIT (SET.SEED(53) RETURNED MAXIMUM)
			# mat = matrix(, ncol=4)

			# for(i in 1:100){
				# iter = i
				# set.seed(i)
				# model.rf = randomForest(y~., train.dat, mtry = 4, importance = TRUE)

				# summary(model.rf)
				# model.rf

				# tree.pred=predict(model.rf, valid.dat, type = "class")
				# rf.table = table(tree.pred, valid.dat$y)
				# rf.mail = sum(rf.table[2,])
				# rf.mail.tp = rf.table[2,2]
				# rf.error = (rf.table[2,1]+rf.table[1,2])/2018
				# rf.profit = 14.5*rf.mail.tp - 2*rf.mail

				# vec = c(iter, rf.error, rf.mail, rf.profit)
				# mat = rbind(mat, vec)
				# # print(i)
				# # print(rf.error) #validation error rate:
				# # print(rf.mail) #total mailings:
				# # print(rf.profit) #total profit: $
			# }

			set.seed(53)
			model.rf = randomForest(y~., train.dat, mtry = 4, importance = TRUE)

			summary(model.rf)
			model.rf

			tree.pred=predict(model.rf,valid.dat,type="class")
			rf.table = table(tree.pred,valid.dat$y)
			rf.mail = sum(rf.table[2,])
			rf.mail.tp = rf.table[2,2]
			rf.error = (rf.table[2,1]+rf.table[1,2])/2018
			rf.profit = 14.5*rf.mail.tp - 2*rf.mail

			rf.error #validation error rate: 0.1070
			rf.mail #total mailings: 1,063
			rf.profit #total profit: $11,257.50

		#SVM CLASSIFICATION MODEL

			svm.train = svm(y~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
					 x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
					 I(x.inca^2) + I(x.npro^2) + I(x.tgif^2),
					 data = train.dat, kernel = "linear", cost=10,scale = FALSE)

			summary(svm.train)
			set.seed(53)
			tune.charity = tune(svm, y~ x.reg1 + x.reg2 + x.reg3 + x.reg4 + x.home + x.chld + x.hinc + x.genf + x.wrat +
                     x.avhv + x.incm + x.inca + x.plow + x.npro + x.tgif + x.lgif + x.rgif + x.tdon +
					 x.tlag + x.agif + I(x.hinc^2) + I(x.chld^2) + I(x.tdon^2) + I(x.tlag^2) + I(x.wrat^2) +
					 I(x.inca^2) + I(x.npro^2) + I(x.tgif^2),
					 data = train.dat, kernel = "linear", ranges = list(cost = c(0.001, 0.005, 0.01, 0.05, 0.1, 1, 5, 10)))

			summary(tune.charity)
			bestmod = tune.charity$best.model
			summary(bestmod)

			svm.pred = predict(bestmod, valid.dat)
			svm.table = table(predict = svm.pred, truth = valid.dat$y)
			svm.mail = sum(svm.table[2,])
			svm.mail.tp = svm.table[2,2]
			svm.error = (svm.table[2,1]+svm.table[1,2])/2018
			svm.profit = 14.5*svm.mail.tp - 2*svm.mail

			svm.error #validation error rate: 0.1085
			svm.mail #total mailings: 1,054
			svm.profit #total profit: $11,188.50

# PREDICTION MODELING

		# LEAST SQUARES REGRESSION

		#LEAST SQUARE MODEL 1 (LM1): BASE MODEL

			model.ls1 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + wrat +
							  avhv + incm + inca + plow + npro + tgif + lgif + rgif + tdon + tlag + agif,
							data.train.std.y)

			pred.valid.ls1 = predict(model.ls1, newdata = data.valid.std.y) # validation predictions
			mean((y.valid - pred.valid.ls1)^2) # mean prediction error
			# 1.867523
			sd((y.valid - pred.valid.ls1)^2)/sqrt(n.valid.y) # std error
			# 0.1696615

		#LEAST SQUARES MODEL 2 (LM2)

			# drop wrat for illustrative purposes
			model.ls2 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf +
							  avhv + incm + inca + plow + npro + tgif + lgif + rgif + tdon + tlag + agif,
							data.train.std.y)

			pred.valid.ls2 = predict(model.ls2, newdata = data.valid.std.y) # validation predictions
			mean((y.valid - pred.valid.ls2)^2) # mean prediction error
			# 1.867433
			sd((y.valid - pred.valid.ls2)^2)/sqrt(n.valid.y) # std error
			# 0.1696498

			# Results

			# MPE  Model
			# 1.867523 LS1
			# 1.867433 LS2

			# select model.ls2 since it has minimum mean prediction error in the validation sample

			yhat.test = predict(model.ls2, newdata = data.test.std) # test predictions

		#LEAST SQUARES MODEL 3 (LM3)

			model.ls3 = lm(damt ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + incm +
						plow + tgif + lgif + rgif + tdon + agif,
						data.train.std.y)

			pred.valid.ls3 = predict(model.ls3, newdata = data.valid.std.y) # validation predictions
			ls3.mse = mean((y.valid - pred.valid.ls3)^2) # mean prediction error
			ls3.se = sd((y.valid - pred.valid.ls3)^2)/sqrt(n.valid.y) # std error

			ls3.mse
			ls3.se

		#BEST SUBSETS (BSS)

			bss.train.fit = regsubsets(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
				data=data.train.std.y, nvmax=28)

			which.min(summary(bss.train.fit)$bic)
			coef(bss.train.fit,which.min(summary(bss.train.fit)$bic))
			predict.regsubsets = function(object, newdata, id, ...){
				form = as.formula(object$call[[2]])
				mat = model.matrix(form, newdata)
				coefi = coef(object, id = id)
				xvars = names(coefi)
				mat[, xvars]%*%coefi
			}
			bss.pred = predict.regsubsets(bss.train.fit, data.valid.std.y, which.min(summary(bss.train.fit)$bic))
			bss.mse = mean((y.valid - bss.pred)^2) # mean prediction error
			bss.se = sd((y.valid - bss.pred)^2)/sqrt(n.valid.y) # std error

			bss.mse
			bss.se

		#BEST SUBSETS 10-FOLD VALIDATION (BSSF)

			k=10
			set.seed(53)
			bssf.folds = sample(1:k,nrow(data.train.std.y),replace=TRUE)
			bssf.cv.errors = matrix(NA, k, 10, dimnames=list(NULL, paste(1:10)))
			for (j in 1:k){
				bssf.train.fit=regsubsets(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
					data=data.train.std.y[bssf.folds!=j,], nvmax=28)
				for (i in 1:10){
					bssf.pred = predict(bssf.train.fit, data.train.std.y[bssf.folds==j,], id=i)
					bssf.cv.errors[j, i] = mean((bssf.pred - data.train.std.y$damt[bssf.folds==j])^2)
				}
			}
			bssf.mcv.errors = apply(bssf.cv.errors, 2, mean)
			which.min(bssf.mcv.errors) #Returns the number of variables in the Cross-Validation Selected model
			coef(bssf.train.fit, which.min(bssf.mcv.errors)) #Returns the coefficients for the CV selected model
			bssf.pred = predict.regsubsets(bssf.train.fit, data.valid.std.y, which.min(bssf.mcv.errors)) #Predicts y using the CV Selected model
			bssf.mse = mean((y.valid - bssf.pred)^2) #Calculates test MSE for the CV Selected model
			bssf.se = sd((y.valid - bssf.pred)^2)/sqrt(n.valid.y) # std error

			bssf.mse
			bssf.se

		#RIDGE REGRESSION (RR)

			#make x matrix and y from data.train.std.y
			rr.train.x = model.matrix(damt ~ ., data.train.std.y)[,-21]
			rr.train.y = data.train.std.y$damt
			rr.valid.x = model.matrix(damt ~ ., data.valid.std.y)[,-21]
			rr.valid.y = data.valid.std.y$damt

			set.seed(53)
			rr.cv.out = cv.glmnet(rr.train.x, rr.train.y, alpha=0)

			rr.bestlam = rr.cv.out$lambda.min
			rr.bestlam

			rr.train.fit = glmnet(rr.train.x, rr.train.y, alpha=0, lambda=rr.bestlam)
			coef(rr.train.fit)[, 1]

			rr.pred = predict(rr.train.fit, s=rr.bestlam, newx=rr.valid.x)
			rr.mse = mean((y.valid - rr.pred)^2) # mean prediction error
			rr.se = sd((y.valid - rr.pred)^2)/sqrt(n.valid.y) # std error

			rr.mse
			rr.se

		#LASSO

			set.seed(53)
			lasso.cv.out = cv.glmnet(rr.train.x, rr.train.y, alpha=1)

			lasso.bestlam = lasso.cv.out$lambda.min
			lasso.bestlam

			lasso.train.fit = glmnet(rr.train.x, rr.train.y, alpha=1, lambda=lasso.bestlam)
			coef(lasso.train.fit)[, 1]

			lasso.pred = predict(lasso.train.fit, s=lasso.bestlam, newx=rr.valid.x)
			lasso.mse = mean((y.valid - lasso.pred)^2)
			lasso.se = sd((y.valid - lasso.pred)^2)/sqrt(n.valid.y) # std error

			lasso.mse
			lasso.se

		#PRINCIPAL COMPONANTS

			set.seed(53)
			pcr.train.fit = pcr(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
				data=data.train.std.y, scale=TRUE, validation="CV")

			validationplot(pcr.train.fit,val.type="MSEP")

			#PCR (M=16)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=16)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

			#PCR (M=25)
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=25)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

			#PCR (M=34) All
			pcr.pred = predict(pcr.train.fit, data.valid.std.y, ncomp=34)
			pcr.mse = mean((y.valid - pcr.pred)^2) # mean prediction error
			pcr.se = sd((y.valid - pcr.pred)^2)/sqrt(n.valid.y) # std error

			pcr.mse
			pcr.se

		#PARTIAL LEAST SQUARES

			set.seed(53)
			pls.train.fit = plsr(damt ~ . + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) +
					I(wrat^2) + I(inca^2) + I(npro^2) + I(tgif^2) + I(plow^2) + I(agif^2) +
					I(avhv^2) + I(lgif^2) + I(rgif^2) + I(incm^2),
				data=data.train.std.y, scale=TRUE, validation="CV")

			validationplot(pls.train.fit,val.type="MSEP")

			#PLS (M=3)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=3)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

			#PLS (M=6)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=6)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

			#PLS (M=7)
			pls.pred = predict(pls.train.fit, data.valid.std.y, ncomp=7)
			pls.mse = mean((y.valid - pls.pred)^2) # mean prediction error
			pls.se = sd((y.valid - pls.pred)^2)/sqrt(n.valid.y) # std error

			pls.mse
			pls.se

		#GAM

			#GAM 1
			gam.train.fit1 = gam(damt ~ reg1 + reg2 + reg3 + reg4 + poly(chld, 2) + poly(hinc, 3) +
					poly(wrat, 4) + s(avhv, 3) + s(incm, 3) + s(inca, 3) + s(plow, 3) + s(npro, 3) +
					s(tgif, 3) + s(lgif, 4) + s(rgif, 4) + s(tdon, 3) + s(tlag, 3) + s(agif, 4),
				data=data.train.std.y)

			gam.pred = predict(gam.train.fit1, data.valid.std.y)
			gam.mse = mean((y.valid - gam.pred)^2) # mean prediction error
			gam.se = sd((y.valid - gam.pred)^2)/sqrt(n.valid.y) # std error

			gam.mse
			gam.se

			#GAM 2
			gam.train.fit2 = gam(damt ~ reg1 + reg2 + reg3 + reg4 + poly(chld, 2) + poly(hinc, 3) +
					poly(wrat, 4) + s(avhv, 2) + s(incm, 2) + s(inca, 2) + s(plow, 2) + s(npro, 2) +
					s(tgif, 2) + s(lgif, 3) + s(rgif, 3) + s(tdon, 2) + s(tlag, 2) + s(agif, 3),
				data=data.train.std.y)

			gam.pred = predict(gam.train.fit2, data.valid.std.y)
			gam.mse = mean((y.valid - gam.pred)^2) # mean prediction error
			gam.se = sd((y.valid - gam.pred)^2)/sqrt(n.valid.y) # std error

			gam.mse
			gam.se

	#MODEL LDAF FINAL CLASSIFICATION MODEL

		model.ldaF = lda(donr ~ reg1 + reg2 + reg3 + reg4 + home + chld + hinc + genf + wrat +
						 avhv + incm + inca + plow + npro + tgif + lgif + rgif + tdon +
						 tlag + agif + I(hinc^2) + I(chld^2) + I(tdon^2) + I(tlag^2) + I(wrat^2) +
						 I(inca^2) + I(npro^2) + I(tgif^2),
					 data.train.std.c) # include additional terms on the fly using I()

		n.mail.valid = which.max(profit.ldaF)
		tr.rate = .1 # typical response rate is .1
		vr.rate = .5 # whereas validation response rate is .5
		adj.test.1 = (n.mail.valid/n.valid.c)/(vr.rate/tr.rate) # adjustment for mail yes
		adj.test.0 = ((n.valid.c - n.mail.valid)/n.valid.c)/((1 - vr.rate)/(1 - tr.rate)) # adjustment for mail no
		adj.test = adj.test.1/(adj.test.1+adj.test.0) # scale into a proportion
		n.mail.test = round(n.test*adj.test, 0) # calculate number of mailings for test set
		post.test = predict(model.ldaF, data.test.std)$posterior[,2] # post probs for test data

		cutoff.test = sort(post.test, decreasing=T)[n.mail.test+1] # set cutoff based on n.mail.test
		chat.test = ifelse(post.test>cutoff.test, 1, 0) # mail to everyone above the cutoff
		table(chat.test)

	#GAM1 FINAL PREDICTION MODEL
		yhat.test = predict(gam.train.fit1, newdata = data.test.std) # test predictions

	#OUTPUT
	ip = data.frame(chat=chat.test, yhat=yhat.test) # data frame with two variables: chat and yhat
	write.csv(ip, file="./ip.csv",
          row.names=FALSE) # use group member initials for file name

Data Prep Classification and Prediction Analyis v1.r


horner <- function(x, v) {
  Reduce(v, right=T, f=function(a, b) {
    b * x + a
  })
}


#----------------------------------------------------------------------------#
#' @title "MEDIAN and Q1 and Q3"
#' @description "report MEDIAN and Q1 and Q3"
#' @param x a vector
#' @param digit digit
#' @import stats
#' @export
median_q = function(x,digit = 2) {
  n = paste("%.",digit,"f",sep = "")
  mdn1 = median(x,na.rm =T)
  mdn1 = sprintf(n, mdn1)
  q1 = quantile(x, na.rm =T)["25%"]
  Q1 = sprintf(n, q1)
  q3 = quantile(x, na.rm =T)["75%"]
  Q3 = sprintf(n, q3)
  a = paste(mdn1,"[", Q1,",",Q3,"]", sep = "")
  return(a)
}


library(tidyverse)
library(moments)
library(xtable)
library(gamlss)
options("scipen"=999, "digits"=3)
# установить рабочую директорию
setwd("/home/user/.../Hist/")
# прочитать данные, первая строка --- заголовок, разделитель колонок --- запятая, десятичный разделитель --- точка
# x --- positional аргумент
# header, sep, dec --- named
almatyFlats <- read.csv('', header = TRUE, sep = ",", dec = ".")

spbaFlats <- read.csv('https://github.com/Kirill-Murashev/datasets/blob/main/Saint-Petersburg/flats/spba_flats_210928.csv', header = TRUE, sep = ",", dec = ".")

# изменить тип объекта на более удобный и современный
as_tibble(almatyFlats)

# создать функцию для "нулевой" версии формулы Стёрджесса
kHistSturgess0 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  ks0 = (max(x)-min(x))/(1+log2(n))             # рассчитать k
  return(c(ks0))                                # возвратить k
}                                               # конец функции

# создать функцию для первой версии формулы Стёрджесса
kHistSturgess1 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  ks1 = (1+log2(n))                             # рассчитать k
  return(ks1)                                   # возвратить k
}                                               # конец функции

# создать функцию для второй версии формулы Стёрджесса
kHistSturgess2 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  ks2 = (1+(3.3*log10(n)))                      # рассчитать k
  return(ks2)                                   # возвратить k
}                                               # конец функции

# создать функцию для формулы Брукса и Каррузера
kHistBruksKarruzer <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                    # вычислить число n
  kbk = 5*log10(n)                                  # рассчитать k
  return(kbk)                                       # возвратить k
}                                                   # конец функции

# создать функцию для формулы Хайнхольда и Гаеде
kHistHeinholdGaede <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                    # вычислить число n
  khg = sqrt(n)                                     # рассчитать k
  return(khg)                                       # возвратить k
}                                                   # конец функции

# создать функцию для формулы Манна и Вальда
kHistMannWald <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                               # вычислить число n
  kmw = (4*(2^(1/5)))*((n/qnorm(0.95))^0.4)    # рассчитать k
  return(kmw)                                  # возвратить k
}                                              # конец функции

# создать функцию для формулы Уильямса
kHistWilliams <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                               # вычислить число n
  kwi = (2*(2^(1/5)))*((n/qnorm(0.95))^0.4)    # рассчитать k
  return(kwi)                                  # возвратить k
}                                              # конец функции

# создать функцию для первой формулы Хана и Шапиро
kHistHahnShapiro <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                  # вычислить число n
  khs = 4*(0.75*((n-1)^2)^0.2)                    # рассчитать k
  return(khs)                                     # возвратить k
}                                                 # конец функции

# создать функцию для второй формулы Хана и Шапиро
kHistShapiroHahn <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                  # вычислить число n
  ksh = 1.9*(n^0.4)                               # рассчитать k
  return(ksh)                                     # возвратить k
}                                                 # конец функции

# создать функцию для формулы Кендалла и Стюарта
kHistKendallStuart <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                    # вычислить число n
  b = 2                                             # задать b: 2 <= b <= 4
  t1 = qnorm(0.95)                                  # задать t1
  t2 = 0                                            # задать t2
  kks = b*(sqrt(2)*(((n-1)/(t1+t2))^0.4))           # рассчитать k
  return(kks)                                       # возвратить k
}                                                   # конец функции

# создать функцию для формулы Таушанова
kHistTaushanow <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  kta = 4*log10(n)                              # рассчитать k
  return(kta)                                   # возвратить k
}                                               # конец функции

# создать функцию для формулы Тоневой
kHistTonewa <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                             # вычислить число n
  kto = 5*log10(n)-5                         # рассчитать k
  return(kto)                                # возвратить k
}                                            # конец функции

# создать функцию для формулы Алексеевой
kHistAlekseewa <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                # вычислить число n
  kurt = kurtosis(x)                            # вычислить коэффициент эксцесса
  counterkurt = 1/(sqrt(kurt))                  # вычислить коэффициент контрэксцесса
  kal = (4/counterkurt)*(log10(n/10))           # рассчитать k
  return(kal)                                   # возвратить k
}                                               # конец функции

# создать функцию для первой формулы Новицкого
kHistNowiczkij1 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                 # вычислить число n
  kurt = kurtosis(x)                             # вычислить коэффициент эксцесса
  kn1 = ((kurt+1.5)/6)*(n^0.4)                   # рассчитать k
  return(kn1)                                    # возвратить k
}                                                # конец функции

# создать функцию для второй формулы Новицкого
kHistNowiczkij2 <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                 # вычислить число n
  kurt = kurtosis(x)                             # вычислить коэффициент эксцесса
  kn2 = (((kurt^4)*(n^2))^(1/5))*(1/3)           # рассчитать k
  return(kn2)                                    # возвратить k
}                                                # конец функции

# создать функцию для третьей формулы Новицкого
kHistNowiczkij3_min <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                     # вычислить число n
  kurt = kurtosis(x)                                 # вычислить коэффициент эксцесса
  kn3min = 0.55*(n^0.4)                              # рассчитать k min
  return(kn3min)                                     # возвратить k min
}                                                    # конец функции

# создать функцию для третьей формулы Новицкого
kHistNowiczkij3_max <- function(x, na.omit = FALSE){ # создать функцию, игнорировать пропущенные значения
  n   <- NROW(x)                                     # вычислить число n
  kurt = kurtosis(x)                                 # вычислить коэффициент эксцесса
  kn3max = 1.25*(n^0.4)                              # рассчитать k max
  return(kn3max)                                     # возвратить k max
}                                                    # конец функции

optimalK <- function(x, na.omit = FALSE){ # создать функцию для обобщения результата
  ks0 <- kHistSturgess0(x)
  ks1 <- kHistSturgess1(x)
  ks2 <- kHistSturgess2(x)
  kbk <- kHistBruksKarruzer(x)
  khg <- kHistHeinholdGaede(x)
  kmw <- kHistMannWald(x)
  kwi <- kHistWilliams(x)
  khs <- kHistHahnShapiro(x)
  ksh <- kHistShapiroHahn(x)
  kks <- kHistKendallStuart(x)
  kta <- kHistTaushanow(x)
  kto <- kHistTonewa(x)
  kal <- kHistAlekseewa(x)
  kn1 <- kHistNowiczkij1(x)
  kn2 <- kHistNowiczkij2(x)
  kn3_min <- kHistNowiczkij3_min(x)
  kn3_max <- kHistNowiczkij3_max(x)
  optimal_k <- return(c(ks0, ks1, ks2, kbk, khg, kmw, kwi, khs, ksh, kks, kta, kto, kal, kn1, kn2, kn3_min, kn3_max))
  return(k)
}

kOptimalAlmaty <- optimalK(almatyFlats$price.m)
function_name<- c("Sturgess0", "Sturgess1", "Sturgess2", "BruksKarruzer", "HeinholdGaede", "MannWald", "Williams", "HahnShapiro", "ShapiroHahn", "KendallStuart", "Taushanow", "Tonewa", "Alekseewa", "Nowiczkij1", "Nowiczkij2", "Nowiczkij3_min", "Nowiczkij3_max")
kOptimalAlmaty <- tibble(function_name, kOptimalAlmaty)

xtable(kOptimalAlmaty,caption = "оптимальное число k, полученное различными методами", auto = TRUE)

hist(almatyFlats$price.m,
     freq = FALSE,
     xlab = "price, kaz rubles",
     ylab = "probability",
     main = "Price per meter histogram, Almaty, summer 2019")

histDist(almatyFlats$price.m,
         nbins = kHistNowiczkij1(almatyFlats$price.m),
         xlab = "price, kaz rubles",
         ylab = "probability",
         main = "Price per meter histogram, Almaty, summer 2019")
lines(density(almatyFlats$price.m))
pretty(almatyFlats$price.m)
?histDist

kOptimalSpba <- optimalK(spbaFlats$price_m)
function_name<- c("Sturgess0", "Sturgess1", "Sturgess2", "BruksKarruzer", "HeinholdGaede", "MannWald", "Williams", "HahnShapiro", "ShapiroHahn", "KendallStuart", "Taushanow", "Tonewa", "Alekseewa", "Nowiczkij1", "Nowiczkij2", "Nowiczkij3_min", "Nowiczkij3_max")

kOptimalSpba <- tibble(function_name, kOptimalSpba)

xtable(kOptimalSpba,caption = "оптимальное число k, полученное различными методами", auto = TRUE)

histDist(spbaFlats$price_m,
         nbins = kHistAlekseewa(spbaFlats$price_m),
         xlab = "price, rub",
         ylab = "probability",
         main = "Price per meter, histogram, SPBA (2021-09-28)")
lines(density(spbaFlats$price_m))

rm(kOptimalAlmaty)
rm(kOptimalSpba)
rm(spbaFlats)


=begin
  # sample-factorize02.rb

  require "algebra"

  Z7 = ResidueClassRing(Integer, 7)
  P = Polynomial(Z7, "x")
  x = P.var
  f = 8*x**7 - 20*x**6 + 6*x**5 - 11*x**4 + 44*x**3 - 9*x**2 - 27
  p f.factorize #=> (x + 5)^2(x + 3)^2(x + 2)^3

((<_|CONTENTS>))
=end


model_melting <- function (jul = 0,
         Tmf = 0.5,
         DKmax = 0.0,
         Kmin = 0.0,
         tavg = 0.0){
    #'- Name: Melting -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snow in the process of melting
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: It simulates snow in the process of melting
    #'- inputs:
    #'            * name: jul
    #'                          ** description : current day of year for the calculation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : INT
    #'                          ** default : 0
    #'                          ** min : 0
    #'                          ** max : 366
    #'                          ** unit : d
    #'                          ** uri :
    #'            * name: Tmf
    #'                          ** description : threshold temperature for snow melting
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.5
    #'                          ** min : 0.0
    #'                          ** max : 1.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: DKmax
    #'                          ** description : difference between the maximum and the minimum melting rates
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW/degC/d
    #'                          ** uri :
    #'            * name: Kmin
    #'                          ** description : minimum melting rate on 21 December
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW/degC/d
    #'                          ** uri :
    #'            * name: tavg
    #'                          ** description : average temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'- outputs:
    #'            * name: M
    #'                          ** description : snow in the process of melting
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW/d
    #'                          ** uri :
    M <- 0.0
    K <- DKmax / 2.0 * -sin((2.0 * pi * as.double(jul) / 366.0 + (9.0 / 16.0 * pi))) + Kmin + (DKmax / 2.0)
    if (tavg > Tmf)
    {
        M <- K * (tavg - Tmf)
    }
    return (list('M' = M))
}


library(ggplot2)
library(gridExtra)
library(ggplot2)
library(dplyr)
library(broom)
library(gplots)
library(reshape2)
library(openxlsx)
library(heatmap.plus)
library(ggrepel)
library(xtable)
library(gee)
library(geepack)
library(igraph)

library(effsize)
library(ggpubr)

# marginal entropy, GEE (zhang,2000)
marginal_entropy<-function(mod){
    y = mod$y;
    alpha1=mean(y); alpha0=1-alpha1; # marginal probablility of response k
    pi1 = mod$fitted.values; pi0 = 1-pi1; #model predicted probability of response k
    n=length(y); T=2

    mH = 1 - (sum(pi1*log(pi1))+sum(pi0*log(pi0)))/(n*T*(sum(alpha1*log(alpha1))+sum(alpha0*log(alpha0))))
    return(mH)
}

# marginal r^2, GEE (zhang,2000)
marginal_rsquared<-function(mod,logit){
    if(logit){
        f=as.formula(paste('y~',as.character(mod$formula)[[3]]))
        data = mod$data
        data$y = mod$fitted.values
        mr2=marginal_rsquared(geeglm(f,id=mod$id,data=data),FALSE)
    }else{
        y = mod$y;
        y_bar=mean(y);
        y_hat=mod$fitted.values
        mr2=1-sum((y-y_hat)^2)/sum((y-y_bar)^2)
    }
    return(mr2)
}

# cohens d
# x; geeglm model
# xn; name of independent variable
chnD <- function(x,xn){
    secretor = cohen.d(x$data[[xn]],factor(x$data$Secretor), pooled=TRUE, paired=FALSE, na.rm=T,
            hedges.correction = FALSE, conf.level = 0.95, noncentral = FALSE)$estimate
    dpp = cohen.d(x$data[[xn]],cut(log(x$data$DPP),2), pooled=TRUE, paired=FALSE, na.rm=T,
            hedges.correction = FALSE, conf.level = 0.95, noncentral = FALSE)$estimate
    inter_term = (as.numeric(cut(log(x$data$DPP),2))-1)*(as.numeric(factor(x$data$Secretor))-1)
    inter = cohen.d(x$data[[xn]],factor(inter_term), pooled=TRUE, paired=FALSE, na.rm=T,
            hedges.correction = FALSE, conf.level = 0.95, noncentral = FALSE)$estimate
    c(secretor,dpp,inter)
}

parseSummary.GEEpack <- function(mod,odsig=3,logit=FALSE){
    #sample size
    observation_count = length(mod$id)
    group_count = length(unique(mod$id))
    #test statistics
    summary=coef(summary(mod))
    # residuals
    res = resid(mod)
    #confidence intervals
    if(logit){
        CI=paste(   '(',   signif( exp(summary$Estimate)  - 1.96 * exp(summary$Estimate) * summary[,2] ,odsig),' - ',
                 signif( exp(summary$Estimate)  + 1.96 * exp(summary$Estimate) * summary[,2] ,odsig), ')',sep='')
    }else{
        CI=paste(   '(',   signif( summary$Estimate  - 1.96 * summary$Estimate * summary[,2] ,odsig),' - ',
                signif( summary$Estimate  + 1.96 * summary$Estimate * summary[,2] ,odsig), ')',sep='')
    }
    #effect size: marginal r^2 (Zheng 2000)
    mr2 = marginal_rsquared(mod,logit)
    mh = ifelse(logit, marginal_entropy(mod),NA)
    #degrees of freedom
    df=mod$df.residual
    # anova (dQIC)
    # dfbeta/cooks/influence.measure
    # test normality
    shapiro.wilks=ifelse(logit,NA,shapiro.test(mod$y)$p.value)

    if(!is.data.frame(summary)){
    # get matrix
    summary = do.call(rbind,summary);
    # order and data.frame
    if(glm){
      summary = data.frame(summary[order(rownames(summary),summary[,4]),])
    }else{
      summary = data.frame(summary[order(summary[,4]),])
    }
    }

    if(logit){
        summary$'Coef' = signif( exp(summary$Estimate) , odsig )
    }else{
        summary$'Coef' = signif( summary$Estimate , odsig )
    }
    summary$'95 CI' = CI
    summary$'Pr(W)' = summary[,4] # NEJM_pval(summary[,4])

    # gen table
    xtab <- xtable(summary[,5:7])
    #print(xtable(summary(res)))
    singlevars = data.frame(
        value=c(observation_count,signif(group_count,odsig),signif(mr2,odsig),signif(mh,odsig),df,shapiro.wilks),
        row.names=c('Number of observations','Number of Clusters','Marginal R^2','Marginal Entropy','Degrees of Freedom',"Shapiro-Wilks P")
    )
    xtab2<-xtable(singlevars)

    return(list(xtab,xtab2))
}


sbp = function(n, a) {
  bundle = list(0, numeric(0))
  for (j in seq(n)) {
    bundle = snap(bundle[[1]], bundle[[2]], a)
    }
  c(bundle[[2]], 1 - sum(bundle[[2]]))
  }

snap = function(acc, bun, a) {
  b      = rbeta(1, 1, a)
  stick  = exp(log(b) + acc)

  nacc = log (1 - b) + acc
  nbun = c(bun, stick)
  list(nacc, nbun)
  }


### We want a piece-wise approximation of asin(x)
### But we want to have the following constraints:
### 1) each should be completely well behaved in its range
### 2) adjacent pieces will be blended using linear approximation so their regions should overlap
### 3) the blended result should have continuity
### 3) symmetry will be handled outside this approximation
### 4) the overall range handled should start at 0 and end before 1
### 5) the overall should be as large as possible, but need not reach 1

fit = function(param) {
    c0.high = param[1]
    c1.high = param[2]
    c2.low = param[3]
    c2.high = param[4]
    c3.low = param[5]
    c3.high = param[6]
    c4.low = param[7]

    x = seq(-c0.high, c0.high, by=0.01)
    d0 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m0 = glm(y ~ x + x2 + x3 + i1 + i2, d0, family='gaussian')

    x = seq(0, c1.high, by=0.01)
    d1 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m1 = glm(y ~ x + x2 + x3 + i1 + i2, d1, family='gaussian')

    x = seq(c2.low, c2.high, by=0.01)
    d2 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m2 = glm(y ~ x + x2 + x3 + i1 + i2, d2, family='gaussian')

    x = seq(c3.low, c3.high, by=0.01)
    d3 = data.frame(y=asin(x), x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    m3 = glm(y ~ x + x2 + x3 + i1 + i2, d3, family='gaussian')

    list(m0=m0,m1=m1,m2=m2,m3=m3,
         c0.high=c0.high,c1.high=c1.high, c2.low=c2.low, c2.high=c2.high,
         c3.low=c3.low, c3.high=c3.high, c4.low=c4.low)
}

follow = function(models) {
    x = seq(0, models$c3.high, by=0.01)
    data = data.frame(x=x, x2=x*x, x3=x*x*x, i1=1/(1-x), i2=1/(1-x)/(1-x))
    raw = data.frame(
        y0=predict(models$m0, newdata=data),
        y1=predict(models$m1, newdata=data),
        y2=predict(models$m2, newdata=data),
        y3=predict(models$m3, newdata=data),
        y4=asin(x)
    )

    ## c0.high, c1.high, c2.low, c1.high, c3.low, c2.high, c3.high, c4.low
    mix = with(models, {
         mix = matrix(0, nrow=dim(raw)[1], ncol=5)
         x0 = bound((c0.high - x) / c0.high)
         x1 = bound((c1.high - x) / (c1.high - c2.low));
         x2 = bound((c2.high - x) / (c2.high - c3.low));
         x3 = bound((c3.high - x) / (c3.high - c4.low));

         mix[, 1] = x0
         mix[, 2] = (1-x0) * x1
         mix[, 3] = (1-x1) * x2
         mix[, 4] = (1-x2) * x3
         mix[, 5] = 1-x3
         mix
     })

    data.frame(x=x, yhat=rowSums(raw * mix), y=asin(x))
}

bound = function(v) {
    over = v > 1
    under = v < 0
    v * (1-over) * (1-under) + over
}


data  <- read.csv("datasets/project-46.csv", header=T)
head(data)
tail(data)
attach(data)
data = data.frame(�..country,year,sex,gdp_per_capita....,suicides.100k.pop)
data = aggregate(data, by = list(�..country,year), FUN=mean)
attach(data)
data = data.frame(Group.1,year,gdp_per_capita....,suicides.100k.pop)
EU = c("Belgium","France","Germany")
dataEU = data[Group.1 %in% EU,]
colnames(dataEU)=c("Country","Year","GDP_per_capita","Suicide_rate")
dataEU$GDP_per_capita = dataEU$GDP_per_capita/1000
m=lm(dataEU$Suicide_rate~dataEU$GDP_per_capita)
summary(m)
plot(dataEU$GDP_per_capita,dataEU$Suicide_rate, xlab="GDP per capita, $1000", ylab = "Suicide rate")
abline(m)


 C05QBJ Example Program Results

 Final 2-norm of the residuals =  1.1926E-08

 Final approximate solution
      -0.5707      -0.6816      -0.7017
      -0.7042      -0.7014      -0.6919
      -0.6658      -0.5960      -0.4164


context("Tests that need to be cleaned up.")

fit_linear <- lm(Sepal.Length ~ ., iris)
sd(iris$Sepal.Length - predict(fit_linear, iris))

m1 <- dglm(iris,
           Sepal.Length ~ .,
           hidden_layers = c(16, 2),
           hidden_layers_activation = c("linear", "linear"),
           verbose = TRUE, epochs = 1000)

sd(iris$Sepal.Length - dglm_predict(iris, m1))

library(dplyr)

dglm_predict(iris, m1)

m2 <- dglm(iris,
           Species ~ .,
           hidden_layers = c(24, 12),
           epochs = 100,
           verbose = FALSE)

dglm_predict(iris, m2)
dglm_predict(iris, m2, type = "one-hot")

m3 <- dglm(iris,
           Sepal.Length ~ .,
           verbose = TRUE, epochs = 1000)
get_weights(m3$model)
fit_linear

#expect_equal(predict(fit_dl1, iris), predict(fit_linear, iris))


rm(list=ls())

######################################
# set path
######################################
print("**************************")
print(getwd())
# print(regexpr( getwd(), "Laboratorio_R"   )  )
if ( !regexpr( getwd(), "Laboratorio_R"   )    ) {
  lab_path <- paste( getwd() , "/mine4204/Laboratorio_R" , sep="")
  print(lab_path)
  setwd(lab_path)
  print(getwd())
}

######################################
# functions for lab
######################################
getMaxValueFromColumn <- function (index , df ) {
  print("**************************")
  print(" getMaxValueFromColumn   *")
  #print(paste("index: ", index ))
  column <- df[,index]
  #print(column)
  maxValue <- .Machine$double.xmin
  for(i in column){
    #print(i)
    if (i>maxValue){
      maxValue = i
    }
  }
  print("**************************")
  maxValue
}

getMinValueFromColumn <- function (index , df ) {
  print("**************************")
  print(" getMinValueFromColumn   *")
  #print(paste("index: ", index ))
  column <- df[,index]
  #print(column)
  minValue <- .Machine$double.xmax
  for(i in column){
    #print(i)
    if (i<maxValue){
      minValue = i
    }
  }
  print("**************************")
  minValue
}

getAverageValueFromColumn <- function (index , df ) {
  print("**************************")
  print(paste(" getAverageValueFromColumn   index: ", index ))
  column <- df[,index]
  #print(column)
  total <- 0
  for(i in column){
      total = total + i

  }
  #print(length(column))
  averageValue = total / length(column)
  print("**************************")
  averageValue
}

# índice de la columna con el valor promedio más alto
getIndexOfColumnWithMaxAverageValue <- function (df ) {
  print("*******************************************")
  print(" getIndexOfColumnWithMaxAverageValue   *")
  maxAverage = 0
  indexOfMaxAverage = 0
  for(i in 1:length(df)) {
    averageValue <- getAverageValueFromColumn(i, df)
    print(averageValue)
    if (averageValue >= maxAverage){
      maxAverage = averageValue
      indexOfMaxAverage = i
    }
  }
  print("*******************************************")
  indexOfMaxAverage
}

# índice de la fila con el valor más alto en un campo particular
# (recibe el índice del campo/ columna que se quiere revisar)
# retorna un vector con todos los índices de las filas que obtuvieron el máximo valor
getIndexOfRowsWithMaxValueInColumn <- function (columnIdx, df  ){
  print("**************************")
  print(paste(" getIndexOfRowsWithMaxValueInColumn   columnIdx: ", columnIdx ))
  column <- df[,columnIdx]
  maxValue <- .Machine$double.xmin
  rowIdx = 0
  rowsWithMaxValue  <- c()
  for(i in column){
    rowIdx = rowIdx + 1
    if (i>maxValue){
      maxValue = i
      rowsWithMaxValue <- c(rowIdx)
      #print(paste(" val    ", i, " : ",  rowIdx  ))
    }else if (  i ==  maxValue ){
      rowsWithMaxValue <- c(rowsWithMaxValue, rowIdx)
      #print(paste(" val    ", i, " : ",  rowIdx  ))
      #print(rowsWithMaxValue)
    }
  }
  print("**************************")
  rowsWithMaxValue
}

######################################
# read data
######################################
print("**************************")
data <- read.table("datos.txt",  header = TRUE)
print(data )
print("**************************")
dataColumnsWithoutId = data[, 2 : length(data)  ]
print( dataColumnsWithoutId )
print("**************************")

######################################
# test
######################################

maxValue <- getMaxValueFromColumn(2, dataColumnsWithoutId)
print(paste("maxValue: ", maxValue ))
maxValue <- getMaxValueFromColumn(4, dataColumnsWithoutId)
print(paste("maxValue: ", maxValue ))

minValue <- getMinValueFromColumn(2, dataColumnsWithoutId)
print(paste("minValue: ", minValue ))
minValue <- getMinValueFromColumn(4, dataColumnsWithoutId)
print(paste("minValue: ", minValue ))

averageValue <- getAverageValueFromColumn(2, dataColumnsWithoutId)
print(paste("averageValue: ", averageValue ))
averageValue <- getAverageValueFromColumn(4, dataColumnsWithoutId)
print(paste("averageValue: ", averageValue ))

indexOfMaxAverage<- getIndexOfColumnWithMaxAverageValue(dataColumnsWithoutId)
print(paste("indexOfMaxAverage: ", indexOfMaxAverage ))

rowIdx <- getIndexOfRowsWithMaxValueInColumn(1, dataColumnsWithoutId)
print("rows with max value: ")
print(rowIdx )

rowIdx <- getIndexOfRowsWithMaxValueInColumn(5, dataColumnsWithoutId)
print("rows with max value: ")
print(rowIdx )

rowIdx <- getIndexOfRowsWithMaxValueInColumn(7, dataColumnsWithoutId)
print("rows with max value: ")
print(rowIdx )

print("**************************")


library("ggplot2")

t0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2010/master/csv/ti_1500_2xxx_monthly.csv", sep=",", na = "NA")
t1 <- t0[,c("year","month","ti")]
p0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2019/master/csv/pi_1500_2xxx_monthly.csv", sep=",", na = "NA")
spifull <- read.csv("https://raw.githubusercontent.com/climdata/dwdSPI/master/csv/spi_de.csv", sep=",", na = "NA")
spi <- spifull[, c("year","month","spi1")]

tps <- merge(t1,p0, by=c("year","month"))
tps <- merge(tps,spi, by=c("year","month"))
tps$t1 <- sin(tps$month*pi/6)
tps$t2 <- cos(tps$month*pi/6)

tps <- tps[order(tps$ts),]

mx2 <- lm(spi1 ~ (pi+ti+t1+t2)^2, tps)
summary(mx2)
pr2 <- predict(mx2, newdata=tps, se.fit=TRUE)
tps$spi2 <- pr2$fit
tps$se2 <- pr2$se

mx3 <- lm(spi1 ~ pi, tps)
summary(mx3)
pr3 <- predict(mx3, newdata=tps, se.fit=TRUE)
tps$spi3 <- pr3$fit
tps$se3 <- pr3$se

mx4 <- lm(spi1 ~ pi+ti*t2, tps)
summary(mx4)
pr4 <- predict(mx4, newdata=tps, se.fit=TRUE)
tps$spi4 <- pr4$fit
tps$se4 <- pr4$se

p <- ggplot(data = tps, aes(x = spi1, y = spi2)) +
   geom_point(aes(x = spi1, y = spi3), color="#00FF00", alpha=0.3, size=2) +
   geom_point(aes(x = spi1, y = spi4), color="#0000BB", alpha=0.3, size=2) +
   geom_point(aes(x = spi1, y = spi2), color="#FF0000", alpha=0.5, size=2)
p


## load necessary R packages
library(ggplot2)

# Definition of vectors
name <- c("Mercury", "Venus", "Earth", "Mars", "Jupiter", "Saturn", "Uranus", "Neptune")
type <- c("Terrestrial planet", "Terrestrial planet", "Terrestrial planet",
          "Terrestrial planet", "Gas giant", "Gas giant", "Gas giant", "Gas giant")

diameter <- c(0.382, 0.949, 1, 0.532, 11.209, 9.449, 4.007, 3.883)
rotation <- c(58.64, -243.02, 1, 1.03, 0.41, 0.43, -0.72, 0.67)
rings <- c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE)

# Create a data frame from the vectors
planets_df <- data.frame(name, type, diameter,rotation,rings)

## plot relationships between planets and diameters
qplot(name,rotation,data=planets_df)

max(planets_df$diameter)
# Use order() to create positions
positions <-  order(planets_df$diameter)

# Use positions to sort planets_df
planets_df[positions, name]

pl <- name[order(positions)]
planets_df <- planets_df[order(planets_df$diameter), ]

planets_df$name <- factor(planets_df$name, levels = planets_df$name[order(planets_df$diameter)])
ggplot(planets_df, aes(x = name, y = diameter))+ theme_bw() + geom_bar(stat = "identity")


suppressMessages(library(craze))

x = matrix(as.double(1:30), 10)
y = matrix(as.double(1:10), 10, 2)
z = matrix(as.double(1:5), 5, 3)

x_fml = fmlmat(x)
y_fml = fmlmat(y)
z_fml = fmlmat(z)

test = as.matrix(crossprod(x_fml))
truth = crossprod(x)
stopifnot(all.equal(test[lower.tri(test, TRUE)], truth[lower.tri(truth, TRUE)]))

test = as.matrix(crossprod(x_fml, y_fml))
truth = crossprod(x, y)
stopifnot(all.equal(test[lower.tri(test, TRUE)], truth[lower.tri(truth, TRUE)]))

test = as.matrix(tcrossprod(x_fml))
truth = tcrossprod(x)
stopifnot(all.equal(test[lower.tri(test, TRUE)], truth[lower.tri(truth, TRUE)]))

test = as.matrix(tcrossprod(x_fml, z_fml))
truth = tcrossprod(x, z)
stopifnot(all.equal(test[lower.tri(test, TRUE)], truth[lower.tri(truth, TRUE)]))


#
# Testing the fit of Dq applying Liebovitch 1989 oscillations
#

source("R/Neutral_fun.r")

setwd("Simul")

zq <- readDq_fit(256,64,"Logseries")
g <-plotDqFitG(zq)
g

# Calculate small sample corrected  AIC
AICc <- function(mo)
{
  k <-attributes(logLik(mo))$df-1
  n <-attributes(logLik(mo))$nobs
  AIC(mo)+2*k*(k+1)/(n-k-1)
}

# Calculate AICc differences between linear an linear+quadratic models
#
linQuadAic <- function(y,x){
  mod1 <- lm(y~x)
  mod2 <- lm(y~x+I(x^2))
  AICc(mod1)-AICc(mod2)
}

# Calculate AICc differences between linear an linear+periodic models (tiene problemas)
#
linPerAic <- function(y,x){
  mod1 <- lm(y~x)
  mod3 <- lm(y~x+I(sin(2*pi*x)),data=zq1)

  c1 <- round(coef(mod3)[1],4)
  c2 <- round(coef(mod3)[2],4)
  c3 <- round(coef(mod3)[3],4)
  mod3 <- nls(y~a + b*x+ c*sin(2*pi*x/d),
              data=zq1,
              start=list(a=c1,b=c2,c=c3,d=1))

  AICc(mod1)-AICc(mod3) # r2_l = mod1$r.squared
}

# Compare linear and quadratic models using AICc
#
require(dplyr)
aDif <- group_by(zq,Type,q) %>% summarize(AICDif=linQuadAic(logTr,LogBox))

ggplot(aDif,aes(q,AICDif,colour=Type)) + geom_point() + geom_line()

ggplot(aDif,aes(q,AICDif,shape=Type)) + geom_point()

# Select
zq1 <- filter(zq,q==-1,Type=="DqSAD")

# Test quadratic term
#
mod1 <- lm(logTr~LogBox,data=zq1)
summary(mod1)
coef(mod1)
mod2 <- lm(logTr~LogBox+I(LogBox^2),data=zq1)
summary(mod2)
coef(mod2)[3]
mod3 <- lm(logTr~LogBox+I(sin(2*pi*LogBox)),data=zq1)

c1 <- round(coef(mod3)[1],4)
c2 <- round(coef(mod3)[2],4)
c3 <- round(coef(mod3)[3],4)
mod3 <- nls(logTr~a + b*LogBox+ c*sin(2*pi*LogBox/d),
            data=zq1,
            start=list(a=c1,b=c2,c=c3,d=1))
summary(mod3)
coef(mod3)
AICc(mod1)
AICc(mod2)
AICc(mod3)

coef(mod1)
coef(mod3)

x <- seq(min(zq1$LogBox),max(zq1$LogBox),0.01)
plot(zq1$LogBox,zq1$logTr,data=zq1)
lines(x,predict(mod1,list(LogBox=x)),col="brown")
lines(x,predict(mod2,list(LogBox=x)),col="red")
lines(x,predict(mod3,list(LogBox=x)),col="blue")

anova(mod1,mod2)
AIC(mod1,mod2)
AICc(mod1)-AICc(mod2)
AICc(mod1)-AICc(mod3)

###### FUNCTION TO CALCULATE DIF IN AICc for all the models for use with dplyr/plyr

# Select
zq1 <- filter(zq,q==-1,Type=="DqSRS")

# Test quadratic term
#
mod1 <- lm(logTr~LogBox,data=zq1)
summary(mod1)
mod2 <- lm(logTr~LogBox+I(LogBox^2),data=zq1)
summary(mod2)
anova(mod1,mod2)
AIC(mod1,mod2)
AICc(mod1)-AICc(mod2)

# Select
zq1 <- filter(zq,q==-1,Type=="rnzSRS")

# Test quadratic term
#
mod1 <- lm(logTr~LogBox,data=zq1)
summary(mod1)
mod2 <- lm(logTr~LogBox+I(LogBox^2),data=zq1)
summary(mod2)
AIC(mod1,mod2)
AICc(mod1)-AICc(mod2)

# Nonlinear estimation has many problems!

oscill_frac <- function(x){
  (a * x ^b)*sin(2*pi*log(x)/log(c))
}

zq1$Tr <- exp(zq1$logTr)
nm1 <-nls(Tr ~ oscill_frac(BoxSize),data=zq1,start = list(a = 1, b = 1, c = 10),
          algorithm = "port")


/*
 * fmath.r -- sin, cos, tan, acos, asin, atan, dtor, rtod, exp, log, sqrt
 */

/*
 * Most of the math ops are simple calls to underlying C functions,
 * sometimes with additional error checking to avoid and/or detect
 * various C runtime errors.
 */
#begdef MathOp(funcname,ccode,comment,pre,post)
#funcname "(r)" comment
function{1} funcname(x)

   if !cnv:C_double(x) then
      runerr(102, x)

   abstract {
      return real
      }
   inline {
      double y;
      pre		/* Pre math-operation range checking */
      errno = 0;
      y = ccode(x);
      post		/* Post math-operation C library error detection */
      return C_double y;
      }
end
#enddef

#define aroundone if (x < -1.0 || x > 1.0) {drunerr(205, x); errorfail;}
#define positive  if (x < 0)               {drunerr(205, x); errorfail;}

#define erange    if (errno == ERANGE)     runerr(204);
#define edom      if (errno == EDOM)       runerr(205);

MathOp(sin, sin,  ", x in radians.", ;, ;)
MathOp(cos, cos,  ", x in radians.", ;, ;)
MathOp(tan, tan,  ", x in radians.", ; , erange)
MathOp(acos,acos, ", x in radians.", aroundone, edom)
MathOp(asin,asin, ", x in radians.", aroundone, edom)

#if NT
double atanh(double x)
{
   return 0.5 * 2.302585093 * log((1 + x) / (1 - x));
}
#endif

MathOp(atanh,atanh, ", x in radians.", aroundone, edom)
MathOp(exp, exp,  " - e^x.", ; , erange)
MathOp(sqrt,sqrt, " - square root of x.", positive, edom)
#define DTOR(x) ((x) * Pi / 180)
#define RTOD(x) ((x) * 180 / Pi)
MathOp(dtor,DTOR, " - convert x from degrees to radians.", ; , ;)
MathOp(rtod,RTOD, " - convert x from radians to degrees.", ; , ;)

"atan(r1,r2) -- r1, r2  in radians; if r2 is present, produces atan2(r1,r2)."

function{1} atan(x,y)

   if !cnv:C_double(x) then
      runerr(102, x)

   abstract {
      return real
      }
   if is:null(y) then
      inline {
         return C_double atan(x);
         }
   if !cnv:C_double(y) then
      runerr(102, y)
   inline {
      return C_double atan2(x,y);
      }
end

"log(r1,r2) - logarithm of r1 to base r2."

function{1} log(x,b)

   if !cnv:C_double(x) then
      runerr(102, x)

   abstract {
      return real
      }
   inline {
      if (x <= 0.0) {
         drunerr(205, x);
         errorfail;
         }
      }
   if is:null(b) then
      inline {
         return C_double log(x);
         }
   else {
      if !cnv:C_double(b) then
         runerr(102, b)
      body {
#ifndef Concurrent
         static double lastbase = 0.0;
         static double divisor;
#endif					/* Concurrent */
	 CURTSTATE();

         if (b <= 1.0) {
            drunerr(205, b);
            errorfail;
            }
         if (b != lastbase) {
            divisor = log(b);
            lastbase = b;
            }
	 x = log(x) / divisor;
         return C_double x;
         }
      }
end

"max(x,y,...) - return the maximum of the arguments"

function{1} max(argv[argc])
abstract {
   return any_value
   }
body {
   int i;
   struct descrip dtmp;
   if (argc == 0) fail;
   dtmp = argv[0];
   if (argc == 1) {
      if (is:list(dtmp)) {
	 int i, j, size;
	 union block *bp;
	 size = BlkD(dtmp,List)->size;
	 if (size==0) fail;
#ifdef Arrays
	 if (BlkD(dtmp,List)->listtail == NULL) {
	    bp = BlkD(dtmp,List)->listhead;
	    if (bp->Intarray.title == T_Intarray) {
	       word mymax = bp->Intarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Intarray.a[i] > mymax) mymax = bp->Intarray.a[i];
	       return C_integer mymax;
	       }
	    else {
	       double mymax = bp->Realarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Realarray.a[i] > mymax) mymax = bp->Realarray.a[i];
	       dtmp.dword = D_Real;
#ifdef DescriptorDouble
	       dtmp.vword.realval = mymax;
#else					/* DescriptorDouble */
	       dtmp.vword.bptr = (union block *)alcreal(mymax);
#endif					/* DescriptorDouble */
	       return dtmp;
	       }
	    }

#endif
	 /*
	  * normal max(L), walk through list elements
	  */
	 bp = dtmp.vword.bptr;
	 dtmp = nulldesc; /* the minimal value */
	 for (bp = Blk(bp,List)->listhead; BlkType(bp) == T_Lelem;
	      bp = Blk(bp,Lelem)->listnext) {
	    for (i = 0; i < Blk(bp,Lelem)->nused; i++) {
	       j = bp->Lelem.first + i;
	       if (j >= bp->Lelem.nslots)
		  j -= bp->Lelem.nslots;
	       if (anycmp(bp->Lelem.lslots+j, &dtmp) == Greater)
		  dtmp = bp->Lelem.lslots[j];
	       }
	    }
	 }
      }
   else
      for(i=1;i<argc;i++) if (anycmp(&dtmp, argv+i) < 0) dtmp = argv[i];
   return dtmp;
   }
end

"min(x,y,...) - return the minimum of the arguments"

function{1} min(argv[argc])
abstract {
   return any_value
   }
body {
   int i;
   struct descrip dtmp;
   if (argc == 0) fail;
   dtmp = argv[0];
   if (argc == 1) {
      if (is:list(dtmp)) {
	 int i, j, size;
	 union block *bp;
	 size = BlkD(dtmp,List)->size;
	 if (size==0) fail;
#ifdef Arrays
	 if (BlkD(dtmp,List)->listtail == NULL) {
	    bp = BlkD(dtmp,List)->listhead;
	    if (bp->Intarray.title == T_Intarray) {
	       word mymin = bp->Intarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Intarray.a[i] < mymin) mymin = bp->Intarray.a[i];
	       return C_integer mymin;
	       }
	    else {
	       double mymin = bp->Realarray.a[0];
	       for(i = 1; i < size; i++)
		  if (bp->Realarray.a[i] < mymin) mymin = bp->Realarray.a[i];
	       dtmp.dword = D_Real;
#ifdef DescriptorDouble
	       dtmp.vword.realval = mymin;
#else					/* DescriptorDouble */
	       dtmp.vword.bptr = (union block *)alcreal(mymin);
#endif					/* DescriptorDouble */
	       return dtmp;
	       }
	    }

#endif
	 /*
	  * normal min(L), walk through list elements
	  */
	 bp = dtmp.vword.bptr;
	 dtmp = nulldesc;
	 for (bp = Blk(bp,List)->listhead; BlkType(bp) == T_Lelem;
	      bp = Blk(bp,Lelem)->listnext) {
	    for (i = 0; i < Blk(bp,Lelem)->nused; i++) {
	       j = bp->Lelem.first + i;
	       if (j >= bp->Lelem.nslots)
		  j -= bp->Lelem.nslots;
		  dtmp = bp->Lelem.lslots[j]; /* the minimal value for now */
		  break;break;
	       }
	    }

	 for (bp = Blk(bp,List)->listhead; BlkType(bp) == T_Lelem;
	      bp = Blk(bp,Lelem)->listnext) {
	    for (i = 0; i < Blk(bp,Lelem)->nused; i++) {
	       j = bp->Lelem.first + i;
	       if (j >= bp->Lelem.nslots)
		  j -= bp->Lelem.nslots;
	       if (anycmp(bp->Lelem.lslots+j, &dtmp) == Less)
		  dtmp = bp->Lelem.lslots[j];
	       }
	    }
	 }
      }
   else
      for(i=1;i<argc;i++) if (anycmp(&dtmp, argv+i) > 0) dtmp = argv[i];
   return dtmp;
   }
end


## Use cut2 to create groups of observations having about m observations
## per group, and plot flat lines covering each interval, with y = group mean
require(Hmisc)
set.seed(1)
n <- 3000
m <- 200
x <- c(0, 1, round(runif(n - 3, 5, 100)), 200)
y <- rbinom(n, 1, ifelse(x < 50, .3, .7))
plsmo(x, y, xlim=range(x))
plsmo(x, y, f=.25, col='red', add=TRUE)
lines(supsmu(x, y, bass=2), col='green')
g <- cut2(x, m=m)
w <- cut2(x, m=m, onlycuts=TRUE)
p <- tapply(y, g, mean)
segments(w[-length(w)], p, w[-1], p)
## lines((w[-length(w)] + w[-1]) / 2, p, col=adjustcolor('blue', alpha=.2))
ne <- 2 : (length(w) - 1)
segments(w[ne], p[-1], w[ne], p[-length(p)], col=adjustcolor('blue', alpha=.15))


G01ALJ Example Program Results

Maximum                      12.0000
Upper Hinge (75% quantile)   9.5000
Median      (50% quantile)   6.5000
Lower Hinge (25% quantile)   2.5000
Minimum                      1.0000


#' Plot the severity versus age
#'
#' Creates a plot of the proportion of severe cases by age category. Severe is
#' assumed to be those that would need hospitalization
#'
#' @param s.lo proportion of severe cases in the lowest age category
#' @param s.hi proportion of severe cases in the highest age category
#' @param n.age.cats number of age categories
#' @return a plot of severity versus age
#'
#' @import ggplot2
#' @examples
#' plot_severity(s.lo = 0.0001, s.hi = 0.2, n.age.cats = 10)
#'
#' @export

plot_severity <- function(s.lo, s.hi, n.age.cats){
  if(missing(s.lo)==TRUE) warning("missing s.lo parameter")
  if(missing(s.hi)==TRUE) warning("missing s.hi parameter")
  if(missing(n.age.cats)==TRUE) warning("missing n.age.cats parameter")

  # calculate severity vector as an exponential model from lo to hi
  # based on s_t = s_0(1+r)^n.age.cats
  r <- (s.hi / s.lo)^(1/n.age.cats) - 1
  dat <- data.frame(severity = s.lo * (1+r) ^ seq(1,n.age.cats, 1),
                       age = seq(1,n.age.cats,1))

  ggplot(dat, aes(age, severity)) + geom_line(size = 1.5) +
    xlab("Age category") + ylab("% severe cases") +
    theme_light(base_size = 16) +
    theme(panel.grid.minor = element_blank(),
        panel.grid.major.x = element_blank())
}


## @knitr ciCoverage
# abundance CI coverage
#
U = 100
u = 10
N = 100
n.true=rnorm(U,N/U)
#sum(n.true)
# sampling with replacement
sample.it <- function(x,n,U,u){
  n = sample(n,u,replace=TRUE)
  somevariable = x
  N.hat = mean(n)*U
  N.var = U^2*var(n)/u
  N.CI = c(N.hat-qt(0.975,9)*sqrt(N.var),N.hat+qt(0.975,9)*sqrt(N.var))
  return(c(N.hat,N.var,N.CI))
}

samples = sapply(1:20,sample.it,U=U,u=u,n=n.true)
plot(samples[1,],ylim=range(samples[3:4,]),pch=19,axes=FALSE,xlab="",ylab="Abundance")
box()
axis(2,at=seq(0,200,50))
arrows(1:20,samples[3,],1:20,samples[4,],angle=90,code=3,length=0.1)
abline(h=sum(n.true),lty=2)


# Load tag intent data and calculate inter-rater agreement

json.tagOverlap2 <- read.csv(file="json_overlap_2.csv", header = TRUE)
django.tagOverlap2 <- read.csv(file="django_overlap_2.csv", header = TRUE)
regex.tagOverlap2 <- read.csv(file="regex_overlap_2.csv", header = TRUE)
head(json.tagOverlap1)

# load the library
library(irr)

kappam.fleiss(json.tagOverlap2[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(django.tagOverlap2[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(regex.tagOverlap2[c("Rater1", "Rater2", "Rater3")])

tagOverlap2 <- rbind(json.tagOverlap2, django.tagOverlap2, regex.tagOverlap2)
kappam.fleiss(tagOverlap2[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(json.tagOverlap2[c("ResRater1", "ResRater2", "ResRater3")])

kappam.fleiss(django.tagOverlap2[c("ResRater1", "ResRater2", "ResRater3")])

kappam.fleiss(regex.tagOverlap2[c("ResRater1", "ResRater2", "ResRater3")])


#input matrix is made by MakeHistograms.java
x<-read.table("ExperimentToConceptMatrix.txt")
x <- as.matrix(x)

#transpose
x <- t(x)

#remove experiments with no experiments
s<-sd(x)
x <- x[,which(s!=0)]

#show the data
#map <- heatmap(x, keep.dendro = TRUE, scale = "none", margins=c(20,10))

map <- heatmap(cor(x), symm = TRUE, distfun = function(c) as.dist(1 - abs(c)), keep.dendro = TRUE, scale = "none", margins=c(10,10))

png("dendro.png", width=8840, height=1040)
par(mar=c(42,8,4,6))
plot(map$Colv)
dev.off()

c<- cor(x)

threshold <- 0.7
where <- which(c>threshold & c!=1, arr.ind=TRUE)[,2]
where <- unique(where)
length(where)

xx <- x[,where]

map <- heatmap(cor(xx), symm = TRUE, distfun = function(c) as.dist(1 - abs(c)), keep.dendro = TRUE, scale = "none", margins=c(10,10))

png("dendro.png", width=1340, height=5040)
#bottom, ?, top, right
par(mar=c(2,13,2,42))
plot(map$Colv, horiz=TRUE)
dev.off()


# file score could be produced by function implemented in permutationLsqLambdaK
# this script is used to estimate the K and lambda value to calculate E-value and P-value

data1 = read.table("randomScores")
u = unique(data1$V1)
s = u[order(u)]

data = data.frame(x=s, y=s)
for ( i in 1:length(s) ){
	data[i, 2] =  length(which(data1$V1 >= data$x[i])) / nrow(data1)
}
x=data$x
y=data$y
library(minpack.lm)
nonlin_mod=nlsLM(y~(1-exp(-1*k*1000000*exp(-1*l*x))), control=nls.lm.control(maxiter=550), start=list(k=0.3, l=0.2))
plot(x, y, xlab="s", ylab="p-value")
lines(x,predict(nonlin_mod),col="red")
nonlin_mod

4000000
nonlin_mod
Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 4e+06 * exp(-1 * l * x)))
   data: parent.frame()
       k        l
0.001959 0.344325
 residual sum-of-squares: 0.003286

Number of iterations to convergence: 25
Achieved convergence tolerance: 1.49e-08

1000000
nonlin_mod
Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 1e+06 * exp(-1 * l * x)))
   data: parent.frame()
       k        l
0.006662 0.382291
 residual sum-of-squares: 0.001207

Number of iterations to convergence: 29
Achieved convergence tolerance: 1.49e-08

## for masking
1000000
nonlin_mod
Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 1e+06 * exp(-1 * l * x)))
   data: parent.frame()
      k       l
0.01011 0.38877
 residual sum-of-squares: 0.0002461

Number of iterations to convergence: 25
Achieved convergence tolerance: 1.49e-08

int matchingScore = 2;
int mismatchingPenalty = -3;
int openGapPenalty = -3;
int extendGapPenalty = -1;

data1 = read.table("score")
u = unique(data1$V1)
s = u[order(u)]

data = data.frame(x=s, y=s)
for ( i in 1:length(s) ){
	data[i, 2] =  length(which(data1$V1 >= data$x[i])) / nrow(data1)
}
x=data$x
y=data$y
library(minpack.lm)
nonlin_mod=nlsLM(y~(1-exp(-1*k*1000000*exp(-1*l*x))), control=nls.lm.control(maxiter=550), start=list(k=0.3, l=0.2))
plot(x, y, xlab="s", ylab="p-value")
lines(x,predict(nonlin_mod),col="red")

nonlin_mod

Nonlinear regression model
  model: y ~ (1 - exp(-1 * k * 1e+06 * exp(-1 * l * x)))
   data: parent.frame()
        k         l
1.807e-05 5.740e-02
 residual sum-of-squares: 0.001187

Number of iterations to convergence: 32
Achieved convergence tolerance: 1.49e-08


model_diffusionlimitedevaporation <- function (deficitOnTopLayers = 5341.0,
         soilDiffusionConstant = 4.2){
    #'- Name: DiffusionLimitedEvaporation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: DiffusionLimitedEvaporation Model
    #'            * Author: Pierre Martre
    #'            * Reference:  From the wheat simulation model SiriusQuality
    #'                    Published in 2009
    #'                    doi:http://dx.doi.org/10.1016/j.eja.2006.04.007
    #'
    #'            * Institution: INRA Montpellier
    #'            * Abstract: the evaporation from the diffusion limited soil when the surface has
    #'            dried sufficiently to provide a significant barrier to water vapor diffusion
    #'
    #'- inputs:
    #'            * name: deficitOnTopLayers
    #'                          ** description : deficit On TopLayers
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 5341
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: soilDiffusionConstant
    #'                          ** description : soil Diffusion Constant
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** default : 4.2
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: diffusionLimitedEvaporation
    #'                          ** description : the evaporation from the diffusion limited soil
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    if (deficitOnTopLayers / 1000.0 <= 0.0)
    {
        diffusionLimitedEvaporation <- 8.3 * 1000.0
    }
    else
    {
        if (deficitOnTopLayers / 1000.0 < 25.0)
        {
            diffusionLimitedEvaporation <- 2.0 * soilDiffusionConstant * soilDiffusionConstant / (deficitOnTopLayers / 1000.0) * 1000.0
        }
        else
        {
            diffusionLimitedEvaporation <- 0.0
        }
    }
    return (list('diffusionLimitedEvaporation' = diffusionLimitedEvaporation))
}


source("original/model_fitting.r")
source("visualization.r")
library(RJSONIO)

timestamp = "202005262246"
bootstrap_params = list(
  "number_samples" = 1000,
  "window_size" = 10,
  "confidence" = 0.95
)

model = fromJSON(paste("original", "tuned", timestamp, "model.json", sep="/"))

# plot retrospective R
steps = length(model$beta)
p_sick_days = diff(pexp(0:steps, model$lambda, lower.tail=TRUE))
R = NULL
for (t in 1:steps) {
  p_sick_over_s_days = rev(cumsum(rev(p_sick_days[1:t]))) / pexp(t, model$lambda, lower.tail=TRUE)
  R = c(R, sum(p_sick_over_s_days * rev(model$beta[1:t])))
}
plot(1:steps, R, main="Retrospective R", type="l")
# plot prospective R
plot(1:steps, model$beta / model$lambda, main="Prospective R", type="l")

# plot retrospective R
steps = length(model$beta)
cum_exp = pexp(0:steps, model$lambda, lower.tail=FALSE)
R = NULL
for (t in 1:49) {
  R = c(R, sum(model$beta[1:t] * rev(cum_exp[1:t])))
}
plot(1:49, R, main="Retrospective R", type="l")
# plot prospective R
plot(1:steps, model$beta / model$lambda, main="Prospective R", type="l")

load("CasosAjustados_Diagnostico.Rda")
observed_I = data$`Estimados Totales`
observed_I = c(observed_I[1], 0, tail(observed_I, -1))
expected_I = get_expected_I(model$beta, model$N0, model$lambda)
b_samples = bootstrap_samples(expected_I, observed_I,
                              bootstrap_params$number_samples,
                              bootstrap_params$window_size)
plot_I_intervals(expected_I, observed_I, b_samples, confidence=bootstrap_params$confidence)


forwarddif <- function(a, n) {
  if ( n == 1 )
    a[2:length(a)] - a[1:length(a)-1]
  else {
    r <- forwarddif(a, 1)
    forwarddif(r, n-1)
  }
}

fdiff <- function(a, n) {
  r <- a
  for(i in 1:n) {
    r <- r[2:length(r)] - r[1:length(r)-1]
  }
  r
}

v <- c(90, 47, 58, 29, 22, 32, 55, 5, 55, 73)

print(forwarddif(v, 9))
print(fdiff(v, 9))


 DGGEVX Example Program Results

 Eigenvalue( 1) =     2.00000

 Eigenvector( 1)
     0.99606
     0.00569
     0.06261
     0.06261

 Eigenvalue( 2) = (    3.00000,   -4.00000)

 Eigenvector( 2)
 (    0.94491,   -0.00000)
 (    0.18898,    0.00000)
 (    0.11339,    0.15119)
 (    0.11339,    0.15119)

 Eigenvalue( 3) = (    3.00000,    4.00000)

 Eigenvector( 3)
 (    0.94491,    0.00000)
 (    0.18898,   -0.00000)
 (    0.11339,   -0.15119)
 (    0.11339,   -0.15119)

 Eigenvalue( 4) =     4.00000

 Eigenvector( 4)
     0.98752
     0.01097
    -0.03292
     0.15361


# d: dataset, m: mean, sd: width, a: aplitude

normApplitude <- function(d, m, sd) {
  d[length(d)] / pnorm(length(d):length(d), mean = m, sd = sd)
}

normVariance <- function(d, m, sd, a) {
  var(d - pnorm(1:length(d), mean = m, sd = sd) * a)
}

mTab = c(length(d):(length(d)+40))
sdTab = c(4:10)

print(mTab)
print(sdTab)
vOrig = Inf

aApprox = 0
mApprox = 0
sdApprox = 0

for (a in c(data[length(data)]:20000)) {
  for (sd in sdTab) {
    for(m in mTab) {
      v = normVariance(data, m, sd, a)
      if (v < vOrig) {
        sdApprox = sd
        mApprox = m
        aApprox = a
        vOrig = v
      }
    }
  }
}


# LINKS
# modelStudio github: https://github.com/ModelOriented/modelStudio
# modelStudio package: https://modelstudio.drwhy.ai/index.html
# book: Explanatory Model Analysis Explore, Explain, and Examine Predictive Models: http://ema.drwhy.ai/
# website: https://modeloriented.github.io/DrWhy/

# location
rstudioapi::getSourceEditorContext()$path %>%
  dirname() %>%
  setwd()

# Import & Reshape
pacman::p_load(tidyverse)

d1 <- read.csv("https://raw.githubusercontent.com/VIS-SIG/Wonderful-Wednesdays/master/data/2020/2020-12-09/Reexcision.csv") %>%
  mutate( hist         = factor(hist, labels = c("Others", "Invasive-duct./ductal-lob.")) %>%
            fct_rev(),
          mult.foc     = factor(mult.foc, labels = c("No","Yes")),
          acc.in.situ  = factor(acc.in.situ, labels = c("Others","DCIS & LCIS")),
          lymph.inv    = factor(lymph.inv, labels = c("No","Yes")) %>%
            fct_rev(),
          estr.rec     = factor(estr.rec, labels = c("No","Yes")),
          prog.rec     = factor(prog.rec, labels = c("No","Yes")) ) %>%
  rename(`Residual_Tumor` = RE,
         `Age` = age,
         `Tumor_Size` = tumor.size,
         `Histology` = hist,
         `Multifocality` = mult.foc,
         `Accomp_in_situ` = acc.in.situ,
         `Lymphovascular` = lymph.inv,
         `Estrogen_receptor` = estr.rec,
         `Progesterone_receptor` = prog.rec)

# Logistic Regression w/ Interactions
f2 <- glm(Residual_Tumor ~ Age + Tumor_Size + Histology +
            Multifocality + Accomp_in_situ + Lymphovascular +
            Age*Lymphovascular + Accomp_in_situ*Lymphovascular,
          data = d1, family = "binomial")

# Model Studio
pacman::p_load(modelStudio)
pacman::p_load(DALEX)

# Explain
explainer <- explain(f2,
                     data = d1,
                     y = d1$Residual_Tumor,
                     type = 'classification',
                     verbose = FALSE,
                     precalculate = FALSE)

# Interactive
modelStudio(explainer,
            facet_dim = c(1,1),
            new_observation = d1[140:150,],
            eda       = FALSE,
            show_info = FALSE,
            options = ms_options(w = 500, h = 400,
                                 margin_left = 200,
                                 show_boxplot = FALSE,
                                 show_subtitle = TRUE,
                                 ms_title    = "Interactive Model Studio",
                                 ms_subtitle = "Predictors of Residual Tumor in Breast-Conserving Therapy",
                                 positive_color = '#1a9641',
                                 negative_color = '#d7191c',
                                 default_color  = '#404040',
                                 bd_title     = 'Break-down Plot for Logistic Regression model',
                                 bd_subtitle = 'Shows contributions of every variable to a final prediction',
                                 fi_subtitle = '')) %>%
  r2d3::save_d3_html(file = "viz_ms.html",
                     selfcontained = TRUE)

# Upload to RPubs
# markdown::rpubsUpload(title = "Interactive Model Studio",
#                       htmlFile = "viz_ms_edited.html")

posts/2021-01-11-wonderful-wednesdays-january-2021/code/viz_ms - Agustin Calatroni.r


require(ggplot2)
require(gridExtra)
require(reshape2)

source('fmm_multivariate_conditional.r')

dimension = 3

config = list(
    k = 3
  , m = dimension
  , a = 1
  , l = rep(0, dimension)
  , r = diag(0.05, dimension)
  , b = dimension
  , w = diag(1, dimension)
  , n = 5000
  )

set.seed(222)

d = list(
    t(replicate(250, rnorm(config$m, c(5, 5))))
  , t(replicate(250, rnorm(config$m, c(-5, -5))))
  , t(replicate(500, rnorm(config$m))))
dn = lapply(d, function(j) { data.frame(x = j[,1], y = j[,2], z = j[,3]) })
m  = melt(dn, id.vars = c('x', 'y', 'z'))

set.seed(990909)

params = inverse_model(
    config$n, config$k, m[, c('x', 'y', 'z')]
  , config$a
  , config$l, config$r
  , config$b, config$w
  )

dp = melt(data.frame(params$p))

dm = melt(lapply(params$m, data.frame), id.vars = c('x', 'y', 'z'))

py = ggplot(m, aes(x, y)) + geom_point()

pp = ggplot(dp, aes(seq_along(value), value, colour = variable)) +
       geom_line() + facet_grid(. ~ variable)

pm = ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) +
       geom_point(alpha = 0.5)

early = data.frame(x = m$x, y = m$y, variable = params$z[1,])
mid   = data.frame(x = m$x, y = m$y, variable = params$z[round(config$n / 2),])
late  = data.frame(x = m$x, y = m$y, variable = params$z[config$n - 1,])

p_early =
  ggplot(early, aes(x, y, colour = factor(variable), fill = factor(variable))) +
    geom_point(alpha = 0.5)

p_mid =
  ggplot(mid, aes(x, y, colour = factor(variable), fill = factor(variable))) +
    geom_point(alpha = 0.5)

p_late =
  ggplot(late, aes(x, y, value, colour = factor(variable), fill = factor(variable))) +
    geom_point(alpha = 0.5)

mean_convergence_plots =
  ggplot(dm, aes(x, y, colour = factor(L1), fill = factor(L1))) +
    geom_point(alpha = 0.2) + facet_grid(. ~ L1)

chain_plots = grid.arrange(pp, mean_convergence_plots, nrow = 2)

inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2)


context("dotproduct")

test_that("dotproduct functions properly with two iterators", {
  it <- iterators::iter(1:5)
  it2 <- iterators::iter(1:5)
  expect_equal(dotproduct(it, it2), 55)
})

test_that("dotproduct functions properly with two numeric vectors", {
  vec1 <- c(10, 10)
  vec2 <- c(20, 20)
  expect_equal(dotproduct(vec1, vec2), 400)
})


#####################################################################################
#                                                                                #
# TITLE: Building Health State Transition Models in R: Chapter 3.3                  #
#                                                                                #
# DESCRIPTION: In this section, we explore making 2D and 3D arrays in R             #
#                                                                                #
# AUTHOR: Ian Cromwell                                                              #
#                                                                                #
# DATE: August, 2014                                                                #
#                                                                                #
#####################################################################################

test2d <- array(0,dim=c(3,3), dimnames=list(
          c("X1","X2","X3"),
          c("Y1","Y2","Y3")   ))
test2d

test3d <- array(0,dim=c(3,3,3), dimnames=list(
          c("X1","X2","X3"),
          c("Y1","Y2","Y3"),
          c("Z1","Z2","Z3")   ))
test3d

test3d[1,,]

test3d[1,,] <- sample(1:100, 9, replace=T)
test3d[2,,] <- sample(1000:10000, 9, replace=T)
test3d[3,,] <- sample(10001:1000000, 9, replace=T)

test3d[,1,] <- sample(1:100, 9, replace=T)
test3d[,2,] <- sample(1000:10000, 9, replace=T)
test3d[,3,] <- sample(10001:1000000, 9, replace=T)

test3d[,,] <- sample(1:100, 27, replace=T)

test3d[2,3,] <- 999

colSums(test3d)
colSums(test3d[1,,])
colSums(test3d[2,,])
rowSums(test3d)
rowSums(test3d[1,,])


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 8   Chapter : 5.3     Page No: 276
# CrossProduct of Vectors

library(pracma)
u<-c(1,1,1)
v<-c(1,1,2)
cp<-cross(u,v)
print("u * v is ")
print(cp)


#simulations for 'Covariate adjustment and estimation of mean response in randomised trials'
#Jonathan Bartlett

library(MASS)
library(sandwich)
library(blockrand)

expit <- function(x) {
  exp(x)/(1+exp(x))
}

#define function which runs simulations

runNegBinSim <- function(nSim, n, b0, bx, bz, bxz, gammadisp, nbwm,randtype) {
  muhat1 <- array(0, dim=c(nSim,2))
  varest1 <- array(0, dim=c(nSim,3))

  muhat2 <- array(0, dim=c(nSim))
  varest2 <- array(0, dim=c(nSim,2))

  muhat3 <- array(0, dim=c(nSim))
  varest3 <- array(0, dim=c(nSim))

  for (sim in 1:nSim) {
    print(sim)

    x <- 1*(runif(n)<0.5)
    if (randtype==1) {
      #simple randomisation
      z <- 1*(runif(n)<0.5)
    } else if (randtype==2) {
      #random permuted block randomisation
      rand <- blockrand(n=n, num.levels=2)
      z <- as.numeric(rand$treatment)[1:n]-1
    } else if (randtype==3) {
      #stratified random permuted block
      z <- x
      n0 <- sum(x==0)
      z[x==0] <- as.numeric(blockrand(n=n0, num.levels=2)$treatment)[1:n0]-1
      n1 <- sum(x==1)
      z[x==1] <- as.numeric(blockrand(n=n1, num.levels=2)$treatment)[1:n1]-1
    }

    xb <- b0+bx*(x-0.5)+bz*(z-0.5)+bxz*(x-0.5)*(z-0.5)
    #specify shape of gamma
    k <- 2
    if (gammadisp==T) {
      #shape k
      gamma <- rgamma(n, k, k)
    } else {
      #we use log normal which has mean 1 and variance matching the gamma variance
      gamma <- exp(rnorm(n,-0.5*log(1+1/k),(log(1+1/k))^0.5))
    }

    #simulate follow-up time
    t <- rep(1,n)
    shortFup <- 1*(runif(n)<0.25)
    t[shortFup] <- runif(sum(shortFup))

    y <- rpois(n, t*gamma*exp(xb))

    simdata <- data.frame(y,x,z)

    if (nbwm==T) {
      mod <- glm.nb(y~x+z+offset(log(t)))
    } else {
      mod <- glm(y~x+z+offset(log(t)), family="poisson")
    }

    #calculate predictions for z=1
    pihat <- mean(z)

    #muhat1
    muhat1[sim,1] <- sum(y[z==1])/sum(t[z==1])
    #standard SE for this
    varest1[sim,1] <- (pihat^(-2))*(mean(t[z==1]))^(-2)*mean((z*(y-muhat1[sim,1]))^2)/n

    #muhat2
    activePredxb <- cbind(rep(1,n),x,rep(1,n)) %*% coef(mod)
    activePred <- exp(activePredxb)
    muhat2[sim] <- mean(activePred)
    #calculate delta method variances
    outer <- colMeans(as.numeric(exp(activePredxb)) * cbind(1,x,rep(1,n)))
    outer <- array(outer, dim=c(3,1))
    #sandwich variance treating covariates as fixed
    varest2[sim,1] <- t(outer) %*% vcovHC(mod, type = "HC0") %*% outer
    #variance estimator accounting random X assuming model correct
    varest2[sim,2] <- varest2[sim,1] + sum((activePred-muhat2[sim])^2)/(n^2)

    #muhat3
    muhat3[sim] <- muhat1[sim,1] - mean(((z-pihat)/pihat)*activePred)
    #variance of muhat3
    tauz <- mean(t[z==1])
    varest3[sim] <- (pihat^(-2))*tauz^(-2)*mean((z*(y-muhat3[sim]) -tauz*(z-pihat)*(activePred-muhat2[sim]) )^2)/n

  }

  list(muhat1=muhat1, muhat2=muhat2, muhat3=muhat3, varest1=varest1, varest2=varest2, varest3=varest3)

}

set.seed(698123)

nSim <- 10000
n <- 400

simRuns <- vector("list", 4)

simRuns[[1]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=T,nbwm=T,randtype=2)
#log normal dispersion parameter, but conditional mean model correct
simRuns[[2]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=F,nbwm=T,randtype=2)
#now conditional mean model wrong, gamma distributed dispersion
simRuns[[3]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=T,randtype=2)
#now use a Poisson working model
simRuns[[4]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=F,randtype=2)

resultPrint <- function(resultSet) {
  c(mean(resultSet$muhat1[,1]),
    100*mean((resultSet$muhat1[,1]*exp(-1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])<mean(resultSet$muhat1[,1])) &
      (resultSet$muhat1[,1]*exp(1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat2)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat2),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
           (resultSet$muhat2*exp(1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
           (resultSet$muhat2*exp(1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat3)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat3),
    100*mean((resultSet$muhat3*exp(-1.96*resultSet$varest3^0.5 / resultSet$muhat3)<mean(resultSet$muhat1[,1])) &
           (resultSet$muhat3*exp(1.96*resultSet$varest3^0.5 / resultSet$muhat3)>mean(resultSet$muhat1[,1]))))
}

resTable <- matrix(unlist(lapply(simRuns, resultPrint)), byrow=F, ncol=length(simRuns))
colnames(resTable) <- c("Scenario 1", "Scenario 2", "Scenario 3", "Scenario 4")
rownames(resTable) <- c("Mean $\\hat{\\mu}_{1}(1)$", "95\\% CI Cov.",
                         "Bias $\\hat{\\mu}_{2}(1)$", "Rel. eff.",
                          "Fixed $X$ 95\\% CI Cov.","Random $X$ 95\\% CI Cov.",
                         "Bias $\\hat{\\mu}_{3}(1)$", "Rel. eff.", "95\\% CI Cov.")

library(xtable)
print(xtable(data.frame(row = rownames(resTable),data.frame(resTable)), digits=2),sanitize.text.function=function(x){x}, include.rownames = F)

#stratified randomisation

simRuns2 <- vector("list", 4)

simRuns2[[1]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=T,nbwm=T,randtype=3)
#log normal dispersion parameter, but conditional mean model correct
simRuns2[[2]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=0,gammadisp=F,nbwm=T,randtype=3)
#now conditional mean model wrong, gamma distributed dispersion
simRuns2[[3]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=T,randtype=3)
#now use a Poisson working model
simRuns2[[4]] <- runNegBinSim(nSim=nSim,n=n,b0=0,bx=3,bz=1,bxz=-1.5,gammadisp=T,nbwm=F,randtype=3)

resultPrint <- function(resultSet) {
  c(mean(resultSet$muhat1[,1]),
    100*mean((resultSet$muhat1[,1]*exp(-1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat1[,1]*exp(1.96*resultSet$varest1[,1]^0.5 / resultSet$muhat1[,1])>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat2)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat2),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat2*exp(1.96*resultSet$varest2[,1]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    100*mean((resultSet$muhat2*exp(-1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat2*exp(1.96*resultSet$varest2[,2]^0.5 / resultSet$muhat2)>mean(resultSet$muhat1[,1]))),
    mean(resultSet$muhat3)-mean(resultSet$muhat1[,1]),
    var(resultSet$muhat1[,1])/var(resultSet$muhat3),
    100*mean((resultSet$muhat3*exp(-1.96*resultSet$varest3^0.5 / resultSet$muhat3)<mean(resultSet$muhat1[,1])) &
               (resultSet$muhat3*exp(1.96*resultSet$varest3^0.5 / resultSet$muhat3)>mean(resultSet$muhat1[,1]))))
}

resTable <- matrix(unlist(lapply(simRuns2, resultPrint)), byrow=F, ncol=length(simRuns2))
colnames(resTable) <- c("Scenario 1", "Scenario 2", "Scenario 3", "Scenario 4")
rownames(resTable) <- c("Mean $\\hat{\\mu}_{1}(1)$", "95\\% CI Cov.",
                        "Bias $\\hat{\\mu}_{2}(1)$", "Rel. eff.",
                        "Fixed $X$ 95\\% CI Cov.","Random $X$ 95\\% CI Cov.",
                        "Bias $\\hat{\\mu}_{3}(1)$", "Rel. eff.", "95\\% CI Cov.")

print(xtable(data.frame(row = rownames(resTable),data.frame(resTable)), digits=2),sanitize.text.function=function(x){x}, include.rownames = F)


library('OpenMx')

setwd('~/git/sem_python/tests')
# data <- read.csv('PoliticalDemocracy_missing.csv')
data <- read.csv('PoliticalDemocracy.csv')

ind60 <- c('x1', 'x2', 'x3')
dem60 <- c('y1', 'y2', 'y3', 'y4')
dem65 <- c('y5', 'y6', 'y7', 'y8')
manifest <- c(ind60, dem60, dem65)
latent <- c('ind60', 'dem60', 'dem65')
data <- data[manifest]

model <- mxModel(
    "PoliticalDemocracy",
    type="RAM",
    manifestVars=manifest,
    latentVars=latent,
    mxData(observed=data, type="raw"),
    mxPath(from=manifest, arrows=2, free=TRUE, values=diag(var(data, na.rm=TRUE)) / 2),
    mxPath(from='y1', to='y5', arrows=2, free=TRUE, values=0),
    mxPath(from='y3', to='y7', arrows=2, free=TRUE, values=0),
    mxPath(from='y2', to=c('y4', 'y6'), arrows=2, free=TRUE, values=0),
    mxPath(from='y4', to='y6', arrows=2, free=TRUE, values=0),
    mxPath(from='y6', to='y8', arrows=2, free=TRUE, values=0),
    mxPath(from=latent, arrows=2, free=FALSE, values=1),

    mxPath(from='ind60', to='dem60', arrows=1, free=TRUE, values=1, labels='ind60_dem60'),
    mxPath(from='ind60', to='dem65', arrows=1, free=TRUE, values=1, labels='ind60_dem65'),
    mxPath(from='dem60', to='dem65', arrows=1, free=TRUE, values=1, labels='dem60_dem65'),

    mxPath(from="ind60", to=ind60, arrows=1, free=TRUE, values=1, labels=c('indo60_x1', 'ind60_x2', 'ind60_x3')),
    mxPath(from="dem60", to=dem60, arrows=1, free=TRUE, values=1, labels=c('dem60_y1', 'dem60_y2', 'dem60_y3', 'dem60_y4')),
    mxPath(from="dem65", to=dem65, arrows=1, free=TRUE, values=1, labels=c('dem65_y1', 'dem65_y2', 'dem65_y3', 'dem65_y4')),
    mxPath(from='one', to=manifest, free=TRUE, values=colMeans(data, na.rm=TRUE)))

fit <- mxRun(model)

summary(fit)


##	This code is radically more efficient than the original code that inspired it
##		as I reworked it to not process cell by cell but rather row by row.  I'm sure
##		it could be improved further but hopefully someone will find it a nice starting
##		point just as I found the original code as good inspiration:
##		http://aschinchon.wordpress.com/2014/01/14/cellular-automata-the-beauty-of-simplicity/

##	This projected is licensed under the terms of the MIT license.
##	Copyright (c) 2014 Forrest R. Stevens
##	http://www.forreststevens.com/teaching

require(raster)

##	Create the field size:
width <- 2^10
depth <- width/2

##	Create a data.frame object large enough to hold the data:
gridded <- matrix(0, nrow=depth, ncol=width)

##	Initialized to zeroes above, we could sample 0:1 to create a random
##		starting row or keep it 0:0 to keep it null and assign 1s to the
##		center of the field:
gridded[1, 1:width] <- sample(0:0, width, replace=T)
gridded[1, width/2] <- 1
gridded[1, width/2+1] <- 1

gridded[1, 1:width] <- sample(0:1, width, replace=T)

##	Create indices for our field width that correspond to left, right and up
##		for the row above as we loop through.  First we create a shift() function
##		that can rotate a vector around (so that rows wrap, creating a continuous
##		2D world):
##	First is good for data.frame objects, second for vectors:
#shiftx <- function(d, k) { rbind( tail(d,k), head(d,-k), deparse.level = 0 ) }
shiftx <- function(d, k) { c( tail(d,k), head(d,-k)) }

##	Loop over rows, checking left, above, and right above every item in the rows
##		and assigning a new value to the new row based on its sum:
for (i in 2:depth) {
	row <- i - 1

	z <- shiftx(gridded[row,1:width], 1) + gridded[row,1:width] + shiftx(gridded[row,1:width], -1)

	gridded[i,] <- as.numeric( (z > 0) & (z < 3) )
}

image(raster(gridded), col=c("white", "black"), axes=FALSE, xlab="", ylab="")


# Github: DreamFireworks
# Serhan Eraslan
size<-c(10000) # Simulation size
flip<-c(sample((0:1),size= size, replace=T)) # Random flipping
tails<-sum(flip)/size # Prob. of tails
heads<-1-yazi # Prob. of heads

result<-data.frame(size,tails,heads)
colnames(result)<-c("SIM. SIZE","PROB. OF TAILS","PROB. OF HEADS")
rownames(result)<-c("SIM. 1")

result


rm(list=ls())

library(missForest)
library(mice)
library(doParallel)
library(doMC)
library(tools)

source('a1_functions_train.r')
load('a1_simulated_data.RData')

train.prop <- 0.50
train.split.seed <- 78901
outcome.var <- "Y"
rf.iter <- 12
mice.iter <- 10

miss.prop.list <- c(0.10, 0.20, 0.30, 0.40) #proportion of missingness to assign
miss.type.list <- c('mcar', 'mnar') #mcar = missing completely at random; mnar = missing not at random
data.idx <- 1 #the dataset to use
miss.type.idx <- 1 #type of missingness to use
miss.prop.idx <- 2 #proportio of missingness to use

t.st <- Sys.time() #time the run

data <- data.list[[data.idx]]
miss.prop <- miss.prop.list[miss.prop.idx]
miss.type <- miss.type.list[miss.type.idx]

split <- split.data(data, train.prop, set.seed=train.split.seed)
train.set <- split$train; test.set <- split$test
pred.var <- colnames(data)[-which(colnames(data) == outcome.var)]

##########################
## Set the missing data ##
train.set.miss <- train.set
train.set.miss[,pred.var] <- miss.set.df(train.set.miss[,pred.var], miss.prop, miss.type)

################
#MICE Imputation
mice.data <- train.set.miss

#run an imputation on the mice.data dataframe using the mice function from the mice package
#use 'mice.iter' datasets and cap the iterations at 25
#DO NOT INCLUDE the outcome 'Y' in the imputation, impute only mice.data[,pred.var]
#try to parallelize the computation by running several interations in parallel

#####################
#Impute with the mean
mean.data <- train.set.miss

#finish the mean.imp function from the functions file and impute mean.data[,pred.var]

#########################
#Random Forest Imputation
total.cores <- detectCores()
?detectCores
print(total.cores)
cl <- makeCluster(total.cores)
registerDoParallel(cl)

rf.data <- train.set.miss

#impute using random forest imputation, use 500 trees, and cap the number of iterations at 12 (rf.iter)
#try to parallelize the forests using the doParallel package to save time

##############################
#finish the get.resid.err function and calculate the test set errors for each imputed dataset
mean.imp.err <- get.resid.err(mean.data, test.set)
mice.imp.err <- get.resid.err(mice.data, test.set)
rf.imp.err <- get.resid.err(rf.data, test.set)
no.imp.err <- get.resid.err(train.set, test.set)

print(Sys.time() - t.st)

#Repeat the above for every combination of missing proportion, type of missingness and data
#put the results into a 3x5x2x3 array corresponding to the method (mean, mice, rf)x(missing proportion = 0, 0.1, 0.2, 0.3, 0.4)x(random/non-random missingness)x(dataset)
#output.array <- array(0, dim=c(3, 5, 2, 3)) #method, missing prop, missing type, dataset

###########################################
#Generate and save the plots of the results
miss.type.idx <- 1; data.idx <- 1
col.list <- c('black', 'blue', 'darkgreen')

pdf(paste0('error_plot_dataset.pdf'), height=15, width=10)
par(mfrow=c(3, 2))
for (data.idx in 1:3) {
for (miss.type.idx in 1:length(miss.type.list)) {
x.lim=c(0, max(miss.prop.list))
y.lim <- c(0, max(1, max(output.array[,,miss.type.idx,data.idx])))
plot(c(0, miss.prop.list), output.array[1,,miss.type.idx, data.idx], main=paste('Dataset:', data.idx, 'Missingness:', miss.type.list[miss.type.idx]), xlab="% Missing", ylab='Residual Error', pch=NA, ylim=y.lim, xlim=x.lim)
for (i in 1:3) {
	lines(c(0, miss.prop.list), output.array[i,,miss.type.idx, data.idx], lty=1, pch=i, type='b', col=col.list[i])
}
abline(h=1, col='gray')
legend('topleft', legend=c('Mean', 'MICE', 'RF'), pch=1:3, col=col.list, lty=1, bty='n')
}
}
dev.off()


require(Hmisc)
set.seed(1)
n <- 100
x1 <- runif(n)
x2 <- runif(n)
x3 <- x1 + x2 + runif(n)/10
x4 <- x1 + x2 + x3 + runif(n)/10
x5 <- factor(sample(c('a','b','c'),n,replace=TRUE))
x6 <- 1*(x5=='a' | x5=='c')
redun(~x1+x2+x3+x4+x5+x6, r2=.8)
redun(~x1+x2+x3+x4+x5+x6, r2=.8, allcat=TRUE)
# redun(.., allcat=TRUE, minfreq=40) gives same result as allcat=FALSE

x0 <- c(rep(0,99),1)
redun(~x0+x1+x2+x3+x4+x5+x6, r2=.8, minfreq=2)


# sintegral function from Bolstad class, but without the silly message
# that always appears

integral <- function (x, fx, n.pts = 256, ret = FALSE)
{
  if (class(fx) == "function")
    fx = fx(x)
  n.x = length(x)
  if (n.x != length(fx))
    stop("Unequal input vector lengths")
  if (n.pts < 64)
    n.pts = 64
  ap = approx(x, fx, n = 2 * n.pts + 1)
  h = diff(ap$x)[1]
  integral = h * (ap$y[2 * (1:n.pts) - 1] + 4 * ap$y[2 * (1:n.pts)] +
    ap$y[2 * (1:n.pts) + 1])/3
  invisible(list(value = sum(integral), cdf = list(x = ap$x[2 *
    (1:n.pts)], y = cumsum(integral))))
}


 F08FAJ Example Program Results

 Eigenvalues
     -2.0531  -0.5146  -0.2943  12.8621
 Eigenvectors
          1       2       3       4
 1   0.7003 -0.5144 -0.2767  0.4103
 2   0.3592  0.4851  0.6634  0.4422
 3  -0.1569  0.5420 -0.6504  0.5085
 4  -0.5965 -0.4543  0.2457  0.6144

 Error estimate for the eigenvalues
        1.4e-15

 Error estimates for the eigenvectors
     9.3e-16     6.5e-15     6.5e-15     1.1e-16


library(plyr)

combos <- combn(ncol(pain),2)
#Where "pain" is the dataset. Adjust also in four places below as need be.

adply(combos, 2, function(x) {
  test <- chisq.test(pain[, x[1]], pain[, x[2]])

  out <- data.frame("Row" = colnames(pain)[x[1]]
                    , "Column" = colnames(pain[x[2]])
                    , "Chi.Square" = round(test$statistic,3)
                    ,  "df"= test$parameter
                    ,  "p.value" = round(test$p.value, 3)
                    )
  return(out)

})

Chisquare on full combination of variables in a dataset.r