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?