I have a data set with 10 rows and 5 columns. For example:
A <- c(15.0, 10.0, 5.50, 20, 22, 25, 30,
40, 50, 10.0)
B <- c(1, 30, 30, 6, 7, 10, 2, 25,
3, 27)
C <- c(1, 0, 0, 5, 15, 10, 20, 25,
30, 40)
D <- c(50, 100, 100, 500, 150, 100, 200, 250,
0, 0)
Date <- c("1997-05-01","1997-05-02","1997-05-03","1997-05-04","1997-05-05",
"1997-05-06","1997-05-07","1997-05-08","1997-05-09","1997-05-10")
data <- data.frame(A, B, C, D, Date)
Thus, I have a data table in R:
A B C D date
---- ---- ---- ---- ----
15.0 1 1 50 1997-05-01
10.0 20 0 100 1997-05-02
etc...
The range is based on quantile. For A I wanted < or = to quantile 25 (e.g. 11.375), and B to the > or = to quantile 75 (e.g. 23.750)
quantile(data$A, c(.25, .50, .75))
quantile(data$B, c(.25, .50, .75))
One way is to filter your data frame on those two conditions:
data[data$A <= quantile(data$A, 0.25) &
data$B >= quantile(data$B, 0.75), ]
So, I would like to create a random data (with the same amount of previous values, in this case 10 rows) from this subset of 3 rowa, for example:
The new data would be:
A B C D date
---- ---- ---- ---- ----
10.0 30 0 100 1997-05-02
5.5 30 0 100 1997-05-03
10.0 27 40 0 1997-05-10
5.5 30 0 100 1997-05-03
10.0 27 40 0 1997-05-10
10.0 30 0 100 1997-05-02
10.0 27 40 0 1997-05-10
5.5 30 0 100 1997-05-03
10.0 27 40 0 1997-05-10
10.0 30 0 100 1997-05-02
how to do that best?
Thank you!
Perhaps you would like something like this?
d_filtered <- data[data$A <= quantile(data$A, 0.25) &
data$B >= quantile(data$B, 0.75), ]
d_new <- d_filtered[sample(1:nrow(d_filtered), nrow(data), replace = TRUE), ]
A B C D Date
2 10.0 30 0 100 1997-05-02
3 5.5 30 0 100 1997-05-03
3.1 5.5 30 0 100 1997-05-03
3.2 5.5 30 0 100 1997-05-03
10 10.0 27 40 0 1997-05-10
3.3 5.5 30 0 100 1997-05-03
2.1 10.0 30 0 100 1997-05-02
2.2 10.0 30 0 100 1997-05-02
10.1 10.0 27 40 0 1997-05-10
2.3 10.0 30 0 100 1997-05-02
One mathematically oriented way to do it,
d3 <- data[data$A <= quantile(data$A, 0.25) &
data$B >= quantile(data$B, 0.75), ]
final_df <- rbind(d3[rep(seq_len(nrow(d3)), floor(nrow(data)/nrow(d3))),],
d3[(1: (nrow(data) - floor(nrow(data)/nrow(d3))*nrow(d3))),])
rownames(final_df) <- NULL
final_df
# A B C D Date
#1 10.0 30 0 100 1997-05-02
#2 5.5 30 0 100 1997-05-03
#3 10.0 27 40 0 1997-05-10
#4 10.0 30 0 100 1997-05-02
#5 5.5 30 0 100 1997-05-03
#6 10.0 27 40 0 1997-05-10
#7 10.0 30 0 100 1997-05-02
#8 5.5 30 0 100 1997-05-03
#9 10.0 27 40 0 1997-05-10
#10 10.0 30 0 100 1997-05-02
Related
I am working on a script that receives and input and generates and ouput based on the input.
There are two different inputs:
Input with data
Input with name of variable, function to apply to calculate that variable and a list of arguments to use on the variable. The arguments are the name of the columns on the data input.
Here is an example of the input data
library(data.table)
library(purrr)
values <- "END_DATE, EAD_1, EAD_2, EAD_3, W, P1, P2, P3
31/12/2019, 1, 3, 5, 0.2, 0, 0, 0
31/12/2019, 7, 11, 13, 0.2, 0, 0, 0
31/01/2020, 15, 17, 19, 0.3, 0, 0, 0
31/01/2020, 23, 29, 31, 0.4, 0, 0, 0
31/03/2020, 37, 41, 43, 0.5, 0, 0, 0
"
dt_values <- fread(values, sep = ",", header = TRUE)
This is an example of the input that has the reference to a variable and the function to apply (I have simplified the example so it can be reproducible)
operations <- " RES, FUNCTION, VAR1, VAR2, VAR3
P1, polinom_f, EAD_1, EAD_1, W
P2, polinom_d, EAD_1, EAD_2, P1
P3, polinom_f, P2, EAD_2, P2
"
dt_operations <- data.table(fread(operations, sep= ",", header = TRUE))
Then I define the functions:
polinom_f_def <- function(x, y, w ) {
return( x * w + y * w)
}
polinom_d_def <- function(x, y, w){
return (( x * w + y * w) / w )
}
my_predefined_functions <- c(
polinom_f = polinom_f_def,
polinom_d = polinom_d_def
)
The only way I have found to do this is like this.
for(i in 1:nrow(dt_operations)){
# print(i)
row <- dt_operations[i, ]
dt_values[, row[, RES] := my_predefined_functions[[row[, FUNCTION]]](get(row[, VAR1]), get(row[, VAR2]), get(row[, VAR3]) ) ]
}
How can I change my code to use map?
The expected output is:
dt_values
END_DATE EAD_1 EAD_2 EAD_3 W P1 P2 P3
1: 31/12/2019 1 3 5 0.2 0.4 4 28
2: 31/12/2019 7 11 13 0.2 2.8 18 522
3: 31/01/2020 15 17 19 0.3 9.0 32 1568
4: 31/01/2020 23 29 31 0.4 18.4 52 4212
5: 31/03/2020 37 41 43 0.5 37.0 78 9282
Here is a possible approach:
invisible(dt_operations[, {
dt_values[, (RES) := as.numeric(mapply(function(x, y, w) match.fun(FUNCTION)(x, y, w),
get(VAR1), get(VAR2), get(VAR3)))]
NULL
}, 1L:nrow(dt_operations)])
dt_values[]
output:
END_DATE EAD_1 EAD_2 EAD_3 W P1 P2 P3
1: 31/12/2019 1 3 5 0.2 0.4 4 28
2: 31/12/2019 7 11 13 0.2 2.8 18 522
3: 31/01/2020 15 17 19 0.3 9.0 32 1568
4: 31/01/2020 23 29 31 0.4 18.4 52 4212
5: 31/03/2020 37 41 43 0.5 37.0 78 9282
data:
library(data.table)
dt_values <- fread("END_DATE, EAD_1, EAD_2, EAD_3, W, P1, P2, P3
31/12/2019, 1, 3, 5, 0.2, 0, 0, 0
31/12/2019, 7, 11, 13, 0.2, 0, 0, 0
31/01/2020, 15, 17, 19, 0.3, 0, 0, 0
31/01/2020, 23, 29, 31, 0.4, 0, 0, 0
31/03/2020, 37, 41, 43, 0.5, 0, 0, 0")
dt_operations <- fread(" RES, FUNCTION, VAR1, VAR2, VAR3
P1, polinom_f, EAD_1, EAD_1, W
P2, polinom_d, EAD_1, EAD_2, P1
P3, polinom_f, P2, EAD_2, P2")
polinom_f <- function(x, y, w ) {
x * w + y * w
}
polinom_d <- function(x, y, w){
(x * w + y * w) / w
}
#convert to double to prevent class mismatch later
dt_values[, paste0("P", 1:3) := lapply(.SD, as.numeric), .SDcols=paste0("P", 1L:3L)]
p.s.:Be careful with exposing the code this way as you might accidentally run some malicious code
The difficult part of the code is that it is recursive. That is, the second operation depends on the result of the first operation. That to me suggests that a classic loop would be most appropriate.
# as noted by #chinsoon12 regarding class mismatch
dt_values[, paste0("P", 1:3) := lapply(.SD, as.numeric), .SDcols=paste0("P", 1L:3L)]
# extract vectors so we are not extracting during loop
res <- dt_operations[['RES']]
fx <- dt_operations[['FUNCTION']]
var1 <- dt_operations[['VAR1']]
var2 <- dt_operations[['VAR2']]
var3 <- dt_operations[['VAR3']]
for (i in seq_len(nrow(dt_operations))) {
dt_values[, (res[i]) := do.call(fx[i], unname(.SD)), .SDcols = c(var1[i], var2[i], var3[i])]
}
dt_values[]
END_DATE EAD_1 EAD_2 EAD_3 W P1 P2 P3
<char> <int> <int> <int> <num> <num> <num> <num>
1: 31/12/2019 1 3 5 0.2 0.4 4 28
2: 31/12/2019 7 11 13 0.2 2.8 18 522
3: 31/01/2020 15 17 19 0.3 9.0 32 1568
4: 31/01/2020 23 29 31 0.4 18.4 52 4212
5: 31/03/2020 37 41 43 0.5 37.0 78 9282
A second way is to use data.table's update-by-reference. The side effect is that during a by operation, each subsequent grouping will have access to whatever was calculated it previous groupings. The good news is that you can use Map (or map). The bad news is that you will be expanding the needed memory amount because the results are duplicated.
Hat tip to #chinsoon12 as this is derivative of their post. But, it is enlightening to see the actual printout:
dt_operations[,
dt_values[,
(RES) := Map(function(cl, v1, v2, v3) do.call(cl, unname(.SD[, c(v1, v2, v3), with = FALSE])),
FUNCTION, VAR1, VAR2, VAR3)
]
, by = seq_len(nrow(dt_operations))]
seq_len END_DATE EAD_1 EAD_2 EAD_3 W P1 P2 P3
<int> <char> <int> <int> <int> <num> <num> <num> <num>
1: 1 31/12/2019 1 3 5 0.2 0.4 0 0
2: 1 31/12/2019 7 11 13 0.2 2.8 0 0
3: 1 31/01/2020 15 17 19 0.3 9.0 0 0
4: 1 31/01/2020 23 29 31 0.4 18.4 0 0
5: 1 31/03/2020 37 41 43 0.5 37.0 0 0
6: 2 31/12/2019 1 3 5 0.2 0.4 4 0
7: 2 31/12/2019 7 11 13 0.2 2.8 18 0
8: 2 31/01/2020 15 17 19 0.3 9.0 32 0
9: 2 31/01/2020 23 29 31 0.4 18.4 52 0
10: 2 31/03/2020 37 41 43 0.5 37.0 78 0
11: 3 31/12/2019 1 3 5 0.2 0.4 4 28
12: 3 31/12/2019 7 11 13 0.2 2.8 18 522
13: 3 31/01/2020 15 17 19 0.3 9.0 32 1568
14: 3 31/01/2020 23 29 31 0.4 18.4 52 4212
15: 3 31/03/2020 37 41 43 0.5 37.0 78 9282
I have a vector in a dataframe in R which is a time series that oscillates between 0 and 100.
I am wanting to create a new column/vector in R that has that will be series on 1s and 0s. It will be 1 when the time series drops below 10 and will continue to be 1 until it reaches 80. Thereafter it will go back to zero. So there is a path dependency in this problem I am wanting to solve.
Something like;
DataFrame %>% mutate(BinaryIndicator = ....)
I think the picture below will be the easiest way to show what I am wanting to get to. Any help would be sincerely appreciated.
Here is a link to an example of what I would like to create
Any help much appreciated.
Since the value of one row depends on the value of the previous row (after its value is updated from its previous row, etc), I think a rolling-window operation is appropriate. zoo does this well.
dat <- data.frame(x=rep(c(60, 50, 40, 35, 30, 25, 20, 15, 10.2, 9, 2, 3, 9, 40, 72, 81, 90), 2))
dat$binary <- cumsum(zoo::rollapply(dat$x, 2, function(a) {
if (length(a) < 2) return(0)
if (a[1] >= 10 && a[2] < 10) return(1)
if (a[1] < 80 && a[2] >= 80) return(-1)
return(0)
}, partial = TRUE, align = "right"))
dat
# x binary
# 1 60.0 0
# 2 50.0 0
# 3 40.0 0
# 4 35.0 0
# 5 30.0 0
# 6 25.0 0
# 7 20.0 0
# 8 15.0 0
# 9 10.2 0
# 10 9.0 1
# 11 2.0 1
# 12 3.0 1
# 13 9.0 1
# 14 40.0 1
# 15 72.0 1
# 16 81.0 0
# 17 90.0 0
# 18 60.0 0
# 19 50.0 0
# 20 40.0 0
# 21 35.0 0
# 22 30.0 0
# 23 25.0 0
# 24 20.0 0
# 25 15.0 0
# 26 10.2 0
# 27 9.0 1
# 28 2.0 1
# 29 3.0 1
# 30 9.0 1
# 31 40.0 1
# 32 72.0 1
# 33 81.0 0
# 34 90.0 0
(I wonder if the internal logic can be simplified some.)
I HAVE :
A1 <- c(1, 1, 0, 93, 19, 8.7)
A2 <- c(2, 1, 0, 226, 45, 6.9)
A3 <- c(3, 2, 1, 86, 17, 8.5)
B1 <- c(1, 4, 1, 113, 23, 7 )
B2 <- c(2, 4, 0, 108, 22, 7 )
B3 <- c(3, 5, 0, 246, 49, 9.5)
C1 <- c(1, 9, 0, 127, 25, 8 )
C2 <- c(2, 10, 1, 116, 23, 8 )
C3 <- c(3, 10, 0, 159.3, 32, 8 )
D1 <- c(1, 11, 0, 431, 86, 10 )
D2 <- c(2, 12, 0, 52, 10, 8 )
D3 <- c(3, 12, 1, 171, 34, 4.2)
E1 <- c(1, 16, 0, 270, 54, 7 )
E2 <- c(2, 16, 0, 86, 17, 8 )
E3 <- c(3, 16, 1, 237, 47, 9 )
F1 <- c(1, 19, 1, 98, 20, 8 )
F2 <- c(2, 20, 1, 164, 33, 8 )
F3 <- c(3, 21, 0, 99, 25, 8 )
G1 <- c(1, 22, 1, 125, 25, 9 )
G2 <- c(2, 25, 0, 222, 44, 9 )
G3 <- c(3, 25, 0, 161, 32, 11 )
H1 <- c(1, 26, 1, 52, 10, 6.8)
H2 <- c(2, 28, 0, 405, 81, 9 )
H3 <- c(3, 29, 0, 71, 14, 8 )
DG = matrix( c(A1,A2,A3,B1,B2,B3,C1,C2,C3,D1,D2,D3,E1,E2,E3,F1,F2,F3,G1,G2,G3,H1,H2,H3), nrow=6, ncol=24 , dimnames=list( c("number","time","status","Trig","vldl","low"), c("A1","A2","A3","B1","B2","B3","C1","C2","C3","D1","D2","D3","E1","E2","E3","F1","F2","F3","G1","G2","G3","H1","H2","H3")))
TD <- t(DG)
want make combination between row without repeat as :
lapply(combn(24,3,simplify=FALSE),function(x) TD[x,]) # the some result will appear as :
[[1901]]
number time status Trig vldl low
E2 2 16 0 86 17 8
G3 3 25 0 161 32 11
H3 3 29 0 71 14 8
[[1902]]
number time status Trig vldl low
E2 2 16 0 86 17 8.0
H1 1 26 1 52 10 6.8
H2 2 28 0 405 81 9.0
[[1903]]
number time status Trig vldl low
E2 2 16 0 86 17 8.0
H1 1 26 1 52 10 6.8
H3 3 29 0 71 14 8.0
[[1904]]
number time status Trig vldl low
E2 2 16 0 86 17 8
H2 2 28 0 405 81 9
H3 3 29 0 71 14 8
[[1905]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
F2 2 20 1 164 33 8
[[1906]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
F3 3 21 0 99 25 8
[[1907]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
G1 1 22 1 125 25 9
[[1908]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
G2 2 25 0 222 44 9
[[1909]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
G3 3 25 0 161 32 11
[[1910]]
number time status Trig vldl low
E3 3 16 1 237 47 9.0
F1 1 19 1 98 20 8.0
H1 1 26 1 52 10 6.8
[[1911]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
H2 2 28 0 405 81 9
[[1912]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
H3 3 29 0 71 14 8
[[1913]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F2 2 20 1 164 33 8
F3 3 21 0 99 25 8
number time status Trig vldl low
G2 2 25 0 222 44 9.0
H1 1 26 1 52 10 6.8
H3 3 29 0 71 14 8.0
[[2020]]
number time status Trig vldl low
G2 2 25 0 222 44 9
H2 2 28 0 405 81 9
H3 3 29 0 71 14 8
[[2021]]
number time status Trig vldl low
G3 3 25 0 161 32 11.0
H1 1 26 1 52 10 6.8
H2 2 28 0 405 81 9.0
[[2022]]
number time status Trig vldl low
G3 3 25 0 161 32 11.0
H1 1 26 1 52 10 6.8
H3 3 29 0 71 14 8.0
[[2023]]
number time status Trig vldl low
G3 3 25 0 161 32 11
H2 2 28 0 405 81 9
H3 3 29 0 71 14 8
[[2024]]
number time status Trig vldl low
H1 1 26 1 52 10 6.8
H2 2 28 0 405 81 9.0
H3 3 29 0 71 14 8.0
this above some result form R but i want combination between row without repeat in letter or all matirix have semi letters as :
true resut :
[[1901]]
number time status Trig vldl low
E2 2 16 0 86 17 8
G3 3 25 0 161 32 11
H3 3 29 0 71 14 8
[[1908]]
number time status Trig vldl low
E3 3 16 1 237 47 9
F1 1 19 1 98 20 8
G2 2 25 0 222 44 9
FALSE RESULT :
[[2021]]
number time status Trig vldl low
G3 3 25 0 161 32 11.0
H1 1 26 1 52 10 6.8
H2 2 28 0 405 81 9.0
[[2023]]
number time status Trig vldl low
G3 3 25 0 161 32 11
H2 2 28 0 405 81 9
H3 3 29 0 71 14 8
[[2024]]
number time status Trig vldl low
H1 1 26 1 52 10 6.8
H2 2 28 0 405 81 9.0
H3 3 29 0 71 14 8.0
PLEASE HELP ME , can remove the repeat from combination as (H1,H2,H3) OR ( A1,A2,A3) OR (H1,A1,A2) ...... Etc, THANK U
You can generate all combinations of blocks (A, B, ...) first, and then enumerate all the combinations of rows for each combination of block:
rowidx <- as.matrix(do.call(expand.grid, rep(list(1:3), 3)))
gid <- cumsum(rep(3, 8)) - 3
res <- lapply(combn(1:8, 3, simplify = FALSE), function(x){
lapply(1:nrow(rowidx), function(y){
TD[gid[x] + rowidx[y, ], ]
})
})
res <- unlist(res, recursive = FALSE)
# sample example output
sample(res, 3)
# [[1]]
# number time status Trig vldl low
# A3 3 2 1 86 17 8.5
# E1 1 16 0 270 54 7.0
# G1 1 22 1 125 25 9.0
#
# [[2]]
# number time status Trig vldl low
# C1 1 9 0 127 25 8.0
# F2 2 20 1 164 33 8.0
# H1 1 26 1 52 10 6.8
#
# [[3]]
# number time status Trig vldl low
# B3 3 5 0 246 49 9.5
# C2 2 10 1 116 23 8.0
# E3 3 16 1 237 47 9.0
#
A generalized version:
gid <- cumsum(rep(3, 8)) - 3
n <- 4 # change n to whatever value (between 2..8) you want.
rowidx <- as.matrix(do.call(expand.grid, rep(list(1:3), n)))
res <- lapply(combn(1:8, n, simplify = FALSE), function(x){
lapply(1:nrow(rowidx), function(y){
TD[gid[x] + rowidx[y, ], ]
})
})
res <- unlist(res, recursive = FALSE)
I've this df:
set.seed(007)
x <- data.frame(v1=sample (1:100, 50),
v2=sample (1:100, 50),
v3=sample (1:100, 50),
v4=sample (1:100, 50),
v5=sample (1:100, 50))
I need to count the values across the rows (v1:v5) between these intervals: <25; 25-49; 50-74; >=75.
I tried with:
x$less.25 <- rowSums(x < 25, na.rm=TRUE)
x$between.25_49 <- rowSums(x >= 25 & x < 50, na.rm=TRUE)
x$between.50_74 <- rowSums(x >= 50 & x < 75, na.rm=TRUE)
x$greater.75 <- rowSums(x >= 75, na.rm=TRUE)
If I have correctly understood your problem:
x$less.25 <- apply(x, 1, function(x){sum(x < 25)})
x$between.25_49 <- apply(x, 1, function(x){sum(x >= 25 & x <50)})
x$between.50_74 <- apply(x, 1, function(x){sum(x >= 50 & x <75)})
x$greater.75 <- apply(x, 1, function(x){sum(x >= 75)})
This gives
v1 v2 v3 v4 v5 less.25 between.25_49 between.50_74 greater.75
1 99 58 40 10 70 1 1 2 1
2 40 72 49 90 87 0 2 1 2
3 12 76 99 19 71 2 0 1 2
4 7 61 38 20 43 2 2 1 0
5 24 70 62 28 45 1 2 2 0
6 76 37 33 76 83 0 2 0 3
I have the following simple linear programming model that I am solving with the linprog package in R:
install.packages("linprog")
library(linprog)
function_opt <- c(8, 13, 9, 8, 9, 11, 12, 10, 7, 8, 10, 9)
names(function_opt) <- c("F1A1","F1A2","F1A3","F1A4","F2A1","F2A2","F2A3","F2A4","F3A1","F3A2","F3A3","F3A4")
##Order: 3 factory capacities, 4 customer demands
cons_indep_term <- c(60, 70, 80, 75, 45, 40, 50)
names(cons_indep_term) <- c("F1","F2","F3","A1","A2","A3","A4")
r1 <- c(1,1,1,1,0,0,0,0,0,0,0,0)
r2 <- c(0,0,0,0,1,1,1,1,0,0,0,0)
r3 <- c(0,0,0,0,0,0,0,0,1,1,1,1)
r4 <- c(1,0,0,0,1,0,0,0,1,0,0,0)
r5 <- c(0,1,0,0,0,1,0,0,0,1,0,0)
r6 <- c(0,0,1,0,0,0,1,0,0,0,1,0)
r7 <- c(0,0,0,1,0,0,0,1,0,0,0,1)
cons_coef <- rbind(r1,r2,r3,r4,r5,r6,r7)
res <- solveLP(function_opt, cons_indep_term, cons_coef, maximum=FALSE, const.dir = c("<=","<=","<=",">=",">=",">=",">="))
print (res)
The sixth constraint requires that the sum of the FxA3 variables must be at least 40. However, the solution that comes out as:
Results of Linear Programming / Linear Optimization
Objective function (Minimum): 1355
Iterations in phase 1: 6
Iterations in phase 2: 3
Solution
opt
F1A1 10
F1A2 0
F1A3 0
F1A4 50
F2A1 30
F2A2 0
F2A3 0
F2A4 0
F3A1 35
F3A2 45
F3A3 0
F3A4 0
Basic Variables
opt
F1A1 10
F1A4 50
F2A1 30
F3A1 35
F3A2 45
S F2 40
S A3 40
Constraints
actual dir bvec free dual dual.reg
F1 60 <= 60 0 1 10
F2 30 <= 70 40 0 40
F3 80 <= 80 0 2 35
A1 75 >= 75 0 9 40
A2 45 >= 45 0 10 35
A3 80 >= 40 40 0 40
A4 50 >= 50 0 9 10
All Variables (including slack variables)
opt cvec min.c max.c marg marg.reg
F1A1 10 8 -9 9 NA NA
F1A2 0 13 99 77 4 10
F1A3 0 9 99 77 10 10
F1A4 50 8 -17 9 NA NA
F2A1 30 9 -10 10 NA NA
F2A2 0 11 99 77 1 30
F2A3 0 12 99 77 12 40
F2A4 0 10 99 77 1 30
F3A1 35 7 -8 9 NA NA
F3A2 45 8 -18 9 NA NA
F3A3 0 10 99 77 12 35
F3A4 0 9 99 77 2 35
S F1 0 0 -1 Inf 1 10
S F2 40 0 NA 1 0 NA
S F3 0 0 -2 Inf 2 35
S A1 0 0 -9 Inf 9 40
S A2 0 0 -10 Inf 10 35
S A3 40 0 NA 10 0 NA
S A4 0 0 -9 Inf 9 10
All three FxA3 variables are set to 0, meaning the sixth constraint is violated. What is the problem? I have triplechecked everything but still no idea.
This is... very weird, and I can't spot any issue in your code. Since this is such a simple LP, you might think about filing a bug to the package maintainers.
That being said, you should be able to get unblocked by using the lpSolve package, which has a nearly identical interface (and is, in fact, used by the linprog package you asked about):
library(lpSolve)
mod2 = lp(direction = "min",
objective.in = function_opt,
const.mat = cons_coef,
const.dir = c("<=","<=","<=",">=",">=",">=",">="),
const.rhs = cons_indep_term)
setNames(mod2$solution, names(function_opt))
# F1A1 F1A2 F1A3 F1A4 F2A1 F2A2 F2A3 F2A4 F3A1 F3A2 F3A3 F3A4
# 0 0 40 20 40 0 0 30 35 45 0 0
mod2$objval
# [1] 1785
In the optimal solution, we have F1A3 = 40, F2A3 = 0, and F3A3 = 0, so the sixth constraint is met.