Computing Irreducible Inconsistent Subsystem (IIS) using Julia JuMP (Gurobi) - julia

Trying to compute IIS for my stupidly overcomplicated model.
I'll include the whole model for clarity:
using JuMP
using Gurobi
import XLSX
roster = Model(Gurobi.Optimizer)
Intern = 1:11 #i
Week = 1:52 #k
Rotation = 1:23 #j
Leave_week = 1:3
Dec_leave = 1:2
M = 1000
clins = 7:52
non_clins = 5:52
early = 5:28
gen = [5,8]
#variables(roster, begin
x[Intern,Week, Rotation], Bin
y[Intern,Week, Rotation], Bin
L[Leave_week, Week], Bin
D[Dec_leave, Intern], Bin
s[Intern, Week], Bin
g[Intern, gen], Bin
end
)
#physical constraint
#constraint(roster, phys[i in Intern, k in Week],
sum(x[i,k,j] for j in Rotation) == 1)
#Rotation capacity
rots = [1,2,3,4,5,6,7,8,9,10,12,13,15,16,17,18,19]
cap_rhs = [2,1,1,1,1,1,1,1,1, 1, 1, 1, 2, 1, 1, 2, 1, 1]
cap = #constraint(roster, [(b,d) in zip(rots, cap_rhs), k in 1:52],
sum(x[i,k,b] for i in Intern) <= d)
#dispensary
disp = #constraint(roster, [i in Intern], sum(x[i,k,j] for k in Week, j in 14:18) >= 5)
disp1 = #constraint(roster, [i in Intern], sum(x[i,k,j] for k in 29:40, j in 14:18) >= 1)
disp2 = #constraint(roster, [i in Intern], sum(x[i,k,j] for k in 41:52, j in 14:18) >= 1)
clay_cap_o = #constraint(roster, [k in 1:4],
sum(x[i,k,14] for i in Intern) <=3)
clay_cap_o = #constraint(roster, [k in 5:52],
sum(x[i,k,14] for i in Intern) <=2)
#Orientation
IP_1 = #constraint(roster, [i in Intern], sum(x[i,k,1] for k in 1:6) >= 1)
IP_3_1 = #constraint(roster, [i in Intern], sum(s[i,k] for k in 1:5) <= 1)
IP_3_11 = #constraint(roster, sum(s[i,k] for i in Intern, k in 1:5) == 10)
IP_3_2 = #constraint(roster, [i in Intern, k in 1:4], x[i,k,1] == s[i,k])
# IP_lazy = #constraint(roster, [(i,k) in zip(Intern, [1 1 2 2 3 3 4 4 5 5 6])], x[i,k,1] ==1)
orien = #constraint(roster, [i in Intern], sum(x[i,k,j] for k in 1:4, j in [1,14,15,16,17,18] ) == 4)
orien1 = #constraint(roster, [i in Intern, j in [1,14,15,16,17,18]], sum(x[i,k,j] for k in 1:4 ) <= 2)
#leave
# 2 weeks leave
#constraint(roster, [i in Intern],
sum(x[i,k,j] for k in Week, j in 20:22) == 2)
week1_dvar = #constraint(roster, sum(L[1, k] for k in 17:22) == 1)
#constraint(roster, week1[k in 17:22], sum(x[i,k,20] for i in Intern) == 11*L[1,k])
#constraint(roster, week2_3_dvar[l in 2:3], sum(L[l, k] for k in 35:41) == 1)
#constraint(roster, week2_3[(l, j, rhs) in zip(2:3, 21:22, [6,5]), k in 35:41],
sum(x[i,k,j] for i in Intern) == rhs*L[l, k] )
#constraint(roster, max_leave[i in Intern], sum(x[i,k,j] for j in 20:22, k in Week) ==2)
## - Dec_leave
#constraint(roster,[i in Intern], sum(D[l,i] for l in 1:2) == 1)
#constraint(roster, [(l,d) in zip(1:2,[6,5])], sum(D[l,i] for i in Intern) == d)
#constraint(roster, [i in Intern, (l,b) in zip(1:2, [49:50, 51:52])],
sum(x[i,k,23] for k in b) == 2*D[l,i])
#constraint(roster, [i in Intern], sum(x[i,k,23] for k in Week) == 2)
#MIC
MIC_1_dvar = #constraint(roster, [i in Intern], sum(y[i,k,4] for k in 5:27 ) == 1)
MIC_2_dvar = #constraint(roster, [i in Intern], sum(y[i,k,4] for k in 29:51 ) == 1)
MIC = #constraint(roster, [ i in Intern, k in 5:27],
2 - sum(x[i, k + alpha, 4] for alpha in 0:1 ) <= M*(1-y[i,k,4]))
MIC = #constraint(roster, [ i in Intern, k in 29:51],
2 - sum(x[i, k + alpha, 4] for alpha in 0:1 ) <= M*(1-y[i,k,4]))
#gen_med
g_vars = #constraint(roster, [i in Intern], sum(g[i,m] for m in gen) ==1)
gen_duration_dvar = #constraint(roster, [(b,d) in zip(gen,[6,7]), i in Intern],
sum(y[i,k,b] for k in 1:(52 - (d-1) ) ) == g[i,b])
gen_limit = #constraint(roster, [(b,d) in zip(gen,[6,7]), i in Intern],
sum(x[i,k,b] for k in Week) == g[i,b]*d)
gen_durations = #constraint(roster, [(b,d) in zip(gen,[6,7]),
i in Intern, k in 1:(52 - (d-1) )],
d - sum(x[i, k + alpha, b] for alpha in 0:(d-1) ) <= M*(1-y[i,k,b]))
ed_with_gen = #constraint(roster, [i in Intern, k in 2:50], y[i,k,23] - x[i,k-1,8] - x[i,k+2,8] <= (1-g[i,5]))
#qum
qum_1 = #constraint(roster, [i in Intern], sum(x[i,k,13] for k in early) >= 1)
qum_2 = #constraint(roster, [i in Intern], sum(x[i,k,13] for k in 1:39) == 2)
# duration
dur_rot = [2,6,7,9,10,11,19]
durs = [2,4,2,3, 3, 4, 2]
duration_dvar = #constraint(roster, [(b,d) in zip(dur_rot, durs), i in Intern],
sum(y[i,k,b] for k in 1:(52 - (d-1) ) ) == 1)
durations = #constraint(roster, [(b,d) in zip(dur_rot, durs),
i in Intern, k in 1:(52 - (d-1) )],
d - sum(x[i, k + alpha, b] for alpha in 0:(d-1) ) <= M*(1-y[i,k,b]))
AP_dur_var = #constraint(roster, [i in Intern], sum(y[i,k,3] for k in 5:35) == 1)
AP_dur = #constraint(roster, [i in Intern, k in 5:35],
2 - sum(x[i,k + alpha, 3] for alpha in 0:1) <= M*(1 - y[i,k,3]))
AP_third = #constraint(roster,[i in Intern], sum(x[i,k,3] for k in 37:52) == 1)
# rotations_lengths
completion = #constraint(roster,
[(j,c,d) in zip([1,2,3,4,6,7,9,10,11,12,19],
[ 1:28,clins,non_clins, non_clins,clins,clins, clins, clins, 29:52, early, clins],
[3,2,3,4,4,2,3, 3, 4, 1, 2]), i in Intern],
sum(x[i,k,j] for k in c) == d)
IP_soft = #constraint(roster, [i in Intern], sum(x[i,k,1] for k in Week) >= 5)
whole_year = #constraint(roster, [(j,d) in zip([1,2,3,4,6,7,9,10,11,12,13,19],
[5,2,3,4,4,2,3, 3, 4, 1, 2, 2]), i in Intern],
sum(x[i,k,j] for k in Week) == d)
# public holiday constraints
no_pubs = #constraint(roster,
[i in Intern, k in [4,7,10,13,14,22,24,29,39,44,52], j in [12,13]],
x[i,k,j] == 0 )
z = #expression(roster, sum(x[i,k,j] for i in Intern, j in Rotation, k in Week))
obj_z = #objective(roster, Max, z)
optimize!(roster)
Tried a few approaches, such as those recommended here and here but ran into errors.
Tried Gurobi.computeIIS(roster) but came up with:
The C API of Gurobi.jl has been rewritten to expose the complete C API, and
all old functions have been removed. For more information, see the Discourse
announcement: https://discourse.julialang.org/t/ann-upcoming-breaking-changes-to-cplex-jl-and-gurobi-jl
Here is a brief summary of the changes.
...
Any help or advise appreciated. Please feel free to edit the example for clarity.
Many thanks.

This is a little advanced, and some of the plumbing is missing (you have to use direct_model at present), but you can go:
using JuMP, Gurobi
model = direct_model(Gurobi.Optimizer())
#variable(model, x >= 0)
#constraint(model, c1, x <= -1)
#constraint(model, c2, 2 * x <= 1)
optimize!(model)
#assert termination_status(model) == MOI.INFEASIBLE
compute_conflict!(model)
julia> MOI.get(model, MOI.ConstraintConflictStatus(), LowerBoundRef(x))
IN_CONFLICT::ConflictParticipationStatusCode = 1
julia> MOI.get(model, MOI.ConstraintConflictStatus(), c1)
IN_CONFLICT::ConflictParticipationStatusCode = 1
julia> MOI.get(model, MOI.ConstraintConflictStatus(), c2)
NOT_IN_CONFLICT::ConflictParticipationStatusCode = 0

Related

How to find k solutions of an optimization with CVXR

I'm trying to find multiple solutions (TXs[1],TXs[2],TXs[3],TXs[4],TXs[5],TZs) that respect the following conditions:
# Variables :
TXs <- Variable(5)
TZs <- Variable(1)
# Objectif :
obj = abs(TXs[1] + TXs[2] + TXs[3] + TXs[4] + TXs[5] + TZs - 100)
# Conditions :
abs(TXs[1] - 2) <=1
abs(TXs[2] - 55) <= 2
abs(TXs[3] - 25) <= 0.5
abs(TXs[4] - 8) <= 1
abs(TXs[5] - 7) <= 1
abs(TZs[1] - 1.5) <= 1
cor(TXs[1], TXs[2]) = 0.77
cor(TXs[3], TXs[2]) = 0.85
cor(TXs[4], TXs[2]) = 0.88
cor(TXs[5], TXs[2]) = 0.99
cor(TZs, TXs[2]) = 0.4
abs(TXs[1] + TXs[2] + TXs[3] + TXs[4] + TXs[5] + TZs[1] - 100) <= 0.001)
I've written the following code that tries to find k solutions but it fails as I always get the same result:
library(CVXR)
# k solutions
k <- 10
solutions <- matrix(NA, nrow = k, ncol = 6)
# Variables
TXs <- Variable(5)
TZs <- Variable(1)
# Objectif
obj = abs(TXs[1] + TXs[2] + TXs[3] + TXs[4] + TXs[5] + TZs - 100)
for (i in 1:k) {
print(i)
# Problem
prob = Problem(Minimize(obj),
list(abs(TXs[1] - 2) <= 1, ((TXs[1] - 2)/ 1) == (0.77 * (TXs[2] - 55)/ 2),
abs(TXs[3] - 25) <= 2, ((TXs[3] - 25)/ 2) == (0.85 * (TXs[2] - 55)/ 2),
abs(TXs[4] - 8) <= 0.5, ((TXs[4] - 8)/ 0.5) == (0.88 * (TXs[2] - 55)/ 2),
abs(TXs[5] - 7) <= 1, ((TXs[5] - 7)/ 1) == (0.99 * (TXs[2] - 55)/ 2),
abs(TZs[1] - 1.5) <= 1.2, ((TZs - 1.5)/ 1.2) == (0.4 * (TXs[2] - 55)/ 2),
abs(TXs[1] + TXs[2] + TXs[3] + TXs[4] + TXs[5] + TZs[1] - 100) <= 0.001))
result = solve(prob, verbose = TRUE )
solutions[i,] <- c(result$getValue(TXs[1]),
result$getValue(TXs[2]),#TXs[2],
result$getValue(TXs[3]),
result$getValue(TXs[4]),
result$getValue(TXs[5]),
result$getValue(TZs[1]))
}
solutions = as.data.frame(solutions)
colnames(solutions) = c("TXs[1]","TXs[2]","TXs[3]","TXs[4]","TXs[5]","TZs" )
solutions$Somme = rowSums(solutions)
Is there a way to modify my code to get multiple solutions? I am also open to other alternatives to "CVXR".

C stack usage 15927808 is too close to the limit

library(ggplot2)
dev.new()
n = 0
x_accept <- list()
set.seed(1684)
x = seq(15, 33, by = 0.1)
f <- function(x) {
out <- ifelse(
x < 15 | 33 < x,
0,
ifelse(
15 <= x & x <= 24,
(2*(x-15))/((33-15)*(24-15)),
ifelse(
24 < x & x <= 33,
(2*(33-x))/((33-15)*(33-24)),
NA_real_
)))
if (any((is.na(out) | is.nan(out)) & (!is.na(x) & !is.nan(x)))) {
warning("f(x) undefined for some input values")
out
}
while (n != 105) {
n = n + 1
x1 = runif(1, min = 15 , max = 33)
num = runif(1, min = 0 , max = 1)
if (num < (f(x1)/2/(33-15)) && num <- (18*(f(x1)/2)))
x_accept = list(x_accept, x1)
}
}
histo <- data.frame(x_histo = x1, y_histo = x1)
dat <- data.frame(x = x, y = f(x))
ggplot(dat, aes(x, y)) +
geom_line()
ggplot(histo, aes(x_histo, y_histo) +
geom_histogram()
It gives me this error, it's the first time I've seen it and I don't really how what it means or how to solve it. C stack usage 15927808 is too close to the limit.

Probability density function with triangular distribution of parameters

How do you compute this probability density function, with a triangular distribution of parameters (a,b,c)?
f(x)= 0 , x<a
2(x-a)/((b-a)(c-a)) , a <= x <= c
2(b-x)/((b-a)(b-c)) , c < x <=b
0 , x> b
Expanding on #StéphaneLaurent‘s comments, you can define a piecewise function using a series of ifelse() calls (or dplyr::case_when()).
f <- function(x, A, B, C) {
out <- ifelse(
x < A | B < x,
0,
ifelse(
A <= x & x <= C,
(2*(x-A))/((B-A)*(C-A)),
ifelse(
C < x & x <= B,
(2*(B-x))/((B-A)*(B-C)),
NA_real_
)))
if (any((is.na(out) | is.nan(out)) & (!is.na(x) & !is.nan(x)))) {
warning("f(x) undefined for some input values")
}
out
}
Taking it for a spin:
library(ggplot2)
dat <- expand.grid(
x = seq(-1.5, 1.5, by = 0.1),
A = -1:1,
B = -1:1,
C = -1:1
)
dat$y <- with(dat, f(x, A, B, C))
# Warning message:
# In f(x, A, B, C) : f(x) undefined for some input values
ggplot(dat, aes(x, y)) +
geom_line(aes(color = factor(C))) +
facet_grid(B ~ A, labeller = label_both)
Here is an option for a density function and a random function.
dtri <- function(x, A, B, C) {
n <- length(x)
i <- 1:n
if (length(A) == 1) A <- rep(A, n)
if (length(B) == 1) B <- rep(B, n)
if (length(C) == 1) C <- rep(C, n)
abc <- Rfast::rowSort(matrix(c(A, B, C), n, 3))
bln <- x < abc[,2]
p <- 2*abs(x - abc[i + 2*n*!bln])/(abc[,3] - abc[,1])/(abc[i + n*(2 - bln)] - abc[i + n*(1 - bln)])
p[x < abc[,1] | x > abc[,3]] <- 0
p
}
rtri <- function(n, a, b, c) {
if (a > b) {a <- (b - a) + (b <- a)}
if (b > c) {c <- (b - c) + (b <- c)}
fb <- (b - a)/(c - a)
U <- runif(n)
blna <- U < fb
r <-numeric(n)
r[blna] <- a + sqrt(U[blna]*(c - a)*(b - a))
r[!blna] <- c - sqrt((1 - U[!blna])*(c - a)*(c - b))
r
}
Using R's vectorized cabilities:
my_fun <- function(x, a, b, c) {
i1 <- x >= a & x <= c
i2 <- x > c & x <= b
f <- rep(NA, length(x))
f[x < a | x > b] <- 0
f[i1] <- 2 * (x[i1] - a) / ((b - a) * (c - a))
f[i2] <- 2 * (b - x[i2]) / ((b - a) * (b - c))
return(f)
}
Test:
set.seed(123)
x <- sort(rnorm(1000, 0, 5))
a <- runif(1, -10, -2)
c <- runif(1, -2, 2)
b <- runif(1, 2, 10)
f <- my_fun(x, a, b, c)
plot(x, f, type="l")

How to just print the chart from `mult.chart` in MSQC package for statistical process control

I am using mult.chart for SPC in an Rmarkdown file for a proof of concept. I just want to print the chart and leave out all the decompositions, xmv, covariance and t2.
when I use
t <- mult.chart(na.omit(test.data), type = "t2", Xmv = Xmv, S = S, colm = colm)
the object has everything but the chart.
> str(t)
List of 5
$ : chr "Hotelling Control Chart"
$ ucl : num 13.8
$ t2 : num [1:154, 1] 6.1 1.11 3.13 0.66 2.26 2.13 2.02 3.45 4.17 2.41 ...
$ Xmv : num [1:4] 130.9 94.8 957.4 490.1
$ covariance: num [1:4, 1:4] 320 11 130 1000 11 0.87 4.9 32 130 4.9 ...
How can I extract the chart out of it?
I updated the code of the function to add a ggplot chart to the output. I am posting the code below for everyone's benefit.
mult.chart2 <- function (type = c("chi", "t2", "mewma", "mcusum",
"mcusum2"), x, Xmv, S, colm, alpha = 0.01, lambda = 0.1,
k = 0.5, h = 5.5, phase = 1, method = "sw", ...)
{
type <- match.arg(type)
p <- ncol(x)
m <- nrow(x)
if (class(x) == "matrix" || class(x) == "data.frame")
(x <- array(data.matrix(x), c(m, p, 1)))
n <- dim(x)[3]
if (!missing(Xmv))
(phase <- 2)
x.jk <- matrix(0, m, p)
t2 <- matrix(0, m, 1)
x.jk <- apply(x, 1:2, mean)
if (missing(Xmv))
(Xmv <- colMeans(x.jk))
if (missing(S))
(S <- covariance(x, method = method))
if (missing(colm))
(colm <- nrow(x))
if (type == "chi") {
name <- paste("Chi-squared Control Chart")
for (ii in 1:m) {
t2[ii, 1] <- n * t(x.jk[ii, ] - Xmv) %*% solve(S) %*%
(x.jk[ii, ] - Xmv)
}
ucl <- qchisq(1 - alpha, p)
if (any(t2 > ucl)) {
cat("The following(s) point(s) fall outside the control limits")
t3 <- which(t2 > ucl)
print(t3)
}
}
if (type == "t2") {
name <- paste("Hotelling Control Chart")
for (ii in 1:m) {
t2[ii, 1] <- n * t(x.jk[ii, ] - Xmv) %*% solve(S) %*%
(x.jk[ii, ] - Xmv)
}
ifelse(n == 1, ifelse(phase == 1, ucl <- ((colm - 1)^2)/colm *
qbeta(1 - alpha, p/2, ((colm - p - 1)/2)), ucl <- ((p *
(colm + 1) * (colm - 1))/((colm^2) - colm * p)) *
qf(1 - alpha, p, colm - p)), ifelse(phase == 1, ucl <- (p *
(colm - 1) * (n - 1))/(colm * n - colm - p + 1) *
qf(1 - alpha, p, colm * n - colm - p + 1), ucl <- (p *
(colm + 1) * (n - 1))/(colm * n - colm - p + 1) *
qf(1 - alpha, p, colm * n - colm - p + 1)))
if (any(t2 > ucl)) {
cat("The following(s) point(s) fall outside of the control limits")
t3 <- which(t2 > ucl)
print(t3)
for (ii in 1:length(t3)) {
v = 1
k = 0
for (i in 1:p) {
k <- k + factorial(p)/(factorial(i) * factorial(p -
i))
}
q <- matrix(0, k, p + 3)
for (i in 1:p) {
a <- t(combn(p, i))
for (l in 1:nrow(a)) {
for (j in 1:ncol(a)) {
q[v, j + 3] <- a[l, j]
}
v = v + 1
}
}
for (i in 1:nrow(q)) {
b <- subset(q[i, 4:ncol(q)], q[i, 4:ncol(q)] >
0)
di <- length(b)
if (length(b) > 1) {
q[i, 1] <- n * t(Xmv[b] - x.jk[t3[ii], ][b]) %*%
solve(S[b, b]) %*% (Xmv[b] - x.jk[t3[ii],
][b])
}
else (q[i, 1] <- n * (x.jk[t3[ii], ][b] - Xmv[b])^2/S[b,
b])
ifelse(n == 1, ifelse(phase == 1, q[i, 2] <- ((colm -
1)^2)/colm * qbeta(1 - alpha, di/2, (((2 *
(colm - 1)^2)/(3 * colm - 4) - di - 1)/2)),
q[i, 2] <- ((di * (colm + 1) * (colm - 1))/((colm^2) -
colm * di)) * qf(1 - alpha, di, colm -
di)), ifelse(phase == 1, q[i, 2] <- (di *
(colm - 1) * (n - 1))/(colm * n - colm -
di + 1) * qf(1 - alpha, di, colm * n - colm -
di + 1), q[i, 2] <- (di * (colm + 1) * (n -
1))/(colm * n - colm - di + 1) * qf(1 - alpha,
di, colm * n - colm - di + 1)))
q[i, 3] <- 1 - pf(q[i, 1], di, colm - 1)
}
colnames(q) <- c("t2 decomp", "ucl",
"p-value", 1:p)
print(list(`Decomposition of` = t3[ii]))
print(round(q, 4))
}
}
}
if (type == "mewma") {
h4 <- matrix(c(8.6336, 9.6476, 10.083, 10.3114, 10.4405,
10.5152, 10.5581, 10.5816, 10.5932, 10.814, 11.8961,
12.3505, 12.5845, 12.7143, 12.788, 12.8297, 12.8524,
12.8635, 12.7231, 13.8641, 14.3359, 14.576, 14.7077,
14.7818, 14.8234, 14.846, 14.857, 14.5363, 15.7293,
16.217, 16.4629, 16.5965, 16.6711, 16.7127, 16.7352,
16.7463, 16.2634, 17.5038, 18.0063, 18.2578, 18.3935,
18.4687, 18.5105, 18.5331, 18.5442, 17.9269, 19.2113,
19.7276, 19.9845, 20.1223, 20.1982, 20.2403, 20.2631,
20.2743, 19.541, 20.8665, 21.396, 21.6581, 21.798,
21.8747, 21.9171, 21.9401, 21.9515, 21.1152, 22.4796,
23.0217, 23.2887, 23.4307, 23.5082, 23.551, 23.5742,
23.5858, 22.6565, 24.0579, 24.6119, 24.8838, 25.0278,
25.1062, 25.1493, 25.1728, 25.1846), nrow = 9)
rownames(h4) <- c(seq(0.1, 0.9, by = 0.1))
colnames(h4) <- c(1:9)
z <- matrix(0, m, p)
m1 <- rownames(h4)
m2 <- colnames(h4)
l <- lambda * 10
ucl <- h4[m1[l], m2[p - 1]]
name <- paste("MEWMA Control Chart")
for (i in 1:m) {
if (i == 1) {
z[i, ] <- lambda * (x.jk[i, ] - Xmv)
}
else {
z[i, ] <- lambda * (x.jk[i, ] - Xmv) + (1 - lambda) *
z[i - 1, ]
}
weig <- S * (lambda * (1 - ((1 - lambda)^(2 * i)))/(2 -
lambda))
t2[i, 1] <- t(z[i, ]) %*% solve(weig) %*% z[i, ]
}
}
if (type == "mcusum") {
name <- paste("MCUSUM Control Chart by Crosier (1988)")
ucl <- h
dif <- sweep(x.jk, 2, Xmv)
s <- matrix(0, m, p)
ci <- matrix(0, m, 1)
ci[1] <- sqrt(dif[1, ] %*% solve((S/n)) %*% dif[1, ])
if (ci[1] > k) {
s[1, ] <- (s[1, ] + dif[1, ]) * (1 - k/ci[1])
}
else (s[1, ] = matrix(0, ncol = p))
for (i in 2:m) {
ci[i, ] = sqrt((s[i - 1, ] + dif[i, ]) %*% solve(S/n) %*%
(s[i - 1, ] + dif[i, ]))
if (ci[i] > k) {
s[i, ] = (s[i - 1, ] + dif[i, ]) * (1 - k/ci[i])
}
else {
s[i, ] = matrix(0, ncol = p)
}
}
for (i in 1:m) {
t2[i] = sqrt(s[i, ] %*% solve((S/n)) %*% (s[i, ]))
}
}
if (type == "mcusum2") {
name <- paste("MCUSUM Control Chart by Pignatiello (1990)")
ucl <- h
dif <- sweep(x.jk, 2, Xmv)
s <- matrix(0, m, p)
l <- matrix(0, m, 1)
for (i in 1:m) {
if (i == 1) {
l[i, 1] <- 1
}
if (i > 1) {
if (t2[i - 1, 1] > 0) {
l[i, 1] <- l[i - 1, 1] + 1
}
else {
l[i, 1] <- 1
}
}
if (i == ((i - l[i, 1] + 1))) {
s[i, ] <- dif[i, ]
}
else {
s[i, ] <- colSums(dif[(i - l[i, 1] + 1):i, ])
}
t2[i, 1] <- max(0, (t(s[i, ]) %*% solve(S/n) %*%
s[i, ])^0.5 - k * l[i, 1])
}
}
t3 <- which(t2 > ucl)
# par(mar = c(4, 5, 3, 5))
# plot(t2, ylim = c(0, 1.1 * max(max(t2), ucl)), main = name,
# xlab = "Sample", ylab = expression(T^2), type = "o",
# las = 1)
# points(t3, t2[t3], col = 2)
# segments(0, ucl, m, ucl, col = 2)
# mtext(paste(" UCL=", round(ucl, 2)), side = 4, at = ucl,
# las = 2)
t2df <- data.frame(t2)
t2df$oob <- ifelse(t2df$t2 > ucl, "bad", "good")
t2df$sample <- seq(1:nrow(t2df))
p2 <- ggplot(data = t2df) +
geom_point(aes(x = sample, y = t2, color = oob)) +
scale_color_manual(values = c( "Red", "Grey20")) +
geom_path(aes(x = sample, y = t2))+
geom_hline(yintercept = ucl, color = "red") +
theme(legend.position = "none")
outList = list(
name,
ucl = round(ucl, 2),
t2 = round(t2, 2),
Xmv = round(Xmv, 2),
covariance = signif(S, 2),
plot2 = p2
)
return(outList)
}

Using R: How to repeat a function I made thousands of times keeping a count of which number it ends on for each repeat

Here's the code I made so far:
z = vector()
for(i in 1:20){
Alkie = function(T=20, lambda=2.5, k=2, mu=3) {
t = 0
N = 0
i = 1
A.t = rexp(1, lambda)
D.t = Inf
while(t[i] < T) {
t[i+1] = min(A.t, D.t)
N[i+1] = N[i] + ifelse(A.t < D.t, 1, -1)
if(A.t < D.t) {
A.t = A.t + rexp(1,lambda)
if(N[i+1] == 1) D.t = t[i+1] + rgamma(1, k, mu)
if(N[i+1] == 6) D.t = t[i+1] + rgamma(1, 0, mu)
}
else
D.t = ifelse(N[i+1] == 0, Inf, t[i+1] + rgamma(1, k, mu))
i = i + 1
}
cbind(t=t, N=N)
}
x = Alkie(T=20, lambda=2.5, k=2, mu=3)
n = nrow(x)
plot(c(x[1,1], rep(x[-1,1], each=2), x[n,1]), rep(x[,2], each=2), type="l",
xlab="t(mins)", ylab="N(t)", col="blue")
How do I store the counts?

Resources