Related
`values <- matrix(c(0.174,0.349,1.075,3.1424,0.173,0.346,1.038,3.114,0.171,0.343,1.03,3.09,0.17,0.34,1.02,3.06),ncol=4) `
I am attempting to maximize the total value for the dataset taking only one value from each row, and with associated costs for each column
subject to:
One value column used per row.
cost of each use of column 1 is 4
cost of each use of column 2 is 3
cost of each use of column 3 is 2
cost of each use of column 4 is 1
total cost <= 11
These are stand in values for a larger dataset. I need to be able to apply it directly to all the rows of a dataset.
I have been trying to use the lpSolve package, with no success.
`f.obj <- values
f.con <- c(4,3,2,1)
f.dir <- "<="
f.rhs <- 11
lp("max", f.obj, f.con, f.dir, f.rhs)`
I am getting a solution of "0"
I do not know how to model this in a way that chooses one value per row and then uses a different value in calculating the constraints.
Looks like the problem is as follows:
We have a matrix a[i,j] with values, and a vector c[j] with costs.
We want to select one value for each row such that:
a. total cost <= 11
b. total value is maximized
To develop a mathematical model, we introduce binary variables x[i,j] ∈ {0,1}. With this, we can write:
max sum((i,j), a[i,j]*x[i,j])
subject to
sum((i,j), c[j]*x[i,j]) <= 11
sum(j, x[i,j]) = 1 ∀i
x[i,j] ∈ {0,1}
Implement in R. I use here CVXR.
#
# data
# A : values
# C : cost
#
A <- matrix(c(0.174,0.349,1.075,3.1424,0.173,0.346,1.038,3.114,0.171,0.343,1.03,3.09,0.17,0.34,1.02,3.06),ncol=4)
C <- c(4,3,2,1)
maxcost <- 11
#
# form a matrix cmat[i,j] indicating the cost of element i,j
#
cmat <- matrix(C,nrow=dim(A)[1],ncol=dim(A)[2],byrow=T)
#
# problem:
# pick one value from each row
# such that total value of selected cells is maximized
# and cost of selected cells is limited to maxcost
#
# model:
# min sum((i,j), a[i,j]*x[i,j])
# subject to
# sum((i,j), c[j]*x[i,j]) <= maxcost
# sum(j,x[i,j]) = 1 ∀i
# x[i,j] ∈ {0,1}
#
#
library(CVXR)
x = Variable(dim(A), name="x", boolean=T)
p <- Problem(Maximize(sum_entries(A*x)),
constraints=list(
sum_entries(cmat*x) <= maxcost,
sum_entries(x,axis=1) == 1
))
res <- solve(p,verbose=T)
res$status
res$value
res$getValue(x)*A
The output looks like:
> res$status
[1] "optimal"
> res$value
[1] 4.7304
> res$getValue(x)*A
[,1] [,2] [,3] [,4]
[1,] 0.0000 0 0.000 0.17
[2,] 0.0000 0 0.343 0.00
[3,] 1.0750 0 0.000 0.00
[4,] 3.1424 0 0.000 0.00
The description in the original post is not very precise. For instance, I assumed that we need to select precisely one cell from each row. If we just want "select at most one cell from each row", then replace
sum(j, x[i,j]) = 1 ∀i
by
sum(j, x[i,j]) <= 1 ∀i
As mentioned by Steve, the lpSolve package expects a single objective function not a matrix. You could reformulate as maximize(sum(RowSums(values*xij)) given constraint
Eg, change the matrix to a vector, and change the problem to a integer optimization problem
obj <- as.vector(values)
f.con <- rep(f.con, each = 4)
r <- lp('max', obj, matrix(f.con, nrow = 1), f.dir, f.rhs, int.vec = seq_along(obj))
#' Success: the objective function is 9.899925
I am trying to create multiple confusion matrices from one dataframe, with each matrix generated based off a different condition in the dataframe.
So for the dataframe below, I want a confusion matrix for when Value = 1, Value = 2, Value =3
observed predicted Value
1 1 1
0 1 1
1 0 2
0 0 2
1 1 3
0 0 3
and see the results like:
Value Sensitivity Specificity PPV NPV
1 .96 .71 .84 .95
2 .89 .63 .30 .45
3 .88 .95 .28 .80
This is what I tried with a reproducible example. I am trying to write a loop that looks at every row, determines if Age = 1, and then pulls the values from the predicted and observed columns to generate a confusion matrix. Then I manually pull out the values from the confusion matrix to write out sen, spec, ppv, and npv and tried to combine all the matrices together. And then the loop starts again with Age = 2.
data(scat)
df<-scat %>% transmute(observed=ifelse(Site=="YOLA","case", "control"), predicted=ifelse(Location=="edge","case", "control"),Age)
x<-1 #evaluate at ages 1 through 5
for (i in dim(df)[1]) { #for every row in df
while(x<6) { #loop stops at Age=5
if(x=df$Age) {
q<-confusionMatrix(data = df$predicted, reference = df$observed, positive = "case")
sensitivity = q$table[1,1]/(q$table[1,1]+q$table[2,1])
specificity = q$table[2,2]/(q$table[2,2]+q$table[1,2])
ppv = q$table[1,1]/(q$table[1,1]+q$table[1,2])
npv = q$table[2,2]/(q$table[2,2]+q$table[2,1])
matrix(c(sensitivity, specificity, ppv, npv),ncol=4,byrow=TRUE)
}
}
x <- x + 1 #confusion matrix at next Age value
}
final<- rbind(matrix) #combine all the matrices together
However, this loop is completely non-functional. I'm not sure where the error is.
Your code can be simplified and the desired output achieved like this:
library(caret)
library(dplyr)
data(scat)
df <- scat %>%
transmute(observed = factor(ifelse(Site == "YOLA","case", "control")),
predicted = factor(ifelse(Location == "edge","case", "control")),
Age)
final <- t(sapply(sort(unique(df$Age)), function(i) {
q <- confusionMatrix(data = df$predicted[df$Age == i],
reference = df$observed[df$Age == i],
positive = "case")$table
c(sensitivity = q[1, 1] / (q[1, 1] + q[2, 1]),
specificity = q[2, 2] / (q[2, 2] + q[1, 2]),
ppv = q[1, 1] / (q[1, 1] + q[1, 2]),
npv = q[2, 2] / (q[2, 2] + q[2, 1]))
}))
Resulting in
final
#> sensitivity specificity ppv npv
#> [1,] 0.0 0.5625000 0.00000000 0.8181818
#> [2,] 0.0 1.0000000 NaN 0.8000000
#> [3,] 0.2 0.5882353 0.06666667 0.8333333
#> [4,] 0.0 0.6923077 0.00000000 0.6923077
#> [5,] 0.5 0.6400000 0.25000000 0.8421053
However, it's nice to know why your own code didn't work, so here are a few issues that might be useful to consider:
You need factor columns rather than character columns for confusionMatrix
You were incrementing through the rows of df, but you need one iteration for each unique age, not each row in your data frame.
Your line to increment x happens outside of the while loop, so x never increments and the loop never terminates, so the console just hangs.
You are doing if(x = df$Age), but you need a == to test equality.
It doesn't make sense to compare x to df$Age anyway, because x is length 1 and df$Age is a long vector.
You have unnecessary repetition by doing q$table each time. You can just make q equal to q$table to make your code more readable and less error-prone.
You call matrix at the end of the loop, but you don't store it anywhere, so the whole loop doesn't actually do anything.
You are trying to rbind an object called matrix in the last line which doesn't exist
Your lack of spaces between math operators, commas and variables make the code less readable and harder to debug. I'm not just saying this as a stylistic point; it is a major source of errors I see frequently here on SO.
I'm analyzing USA election data, candidates contribution, etc. So I got raw data from internet and trying to learn some R executing some exercises in it. This is a CSV file that I successfully loaded and analyzed with ?summary.
I also used ?tapply successfully, to separate candidates money contribution by state:
data_amt_st = tapply(data$contb_receipt_amt, data[c('cand_nm', 'contbr_st')], sum)
?str (for a small sample) tells me the format of this data:
> str(data_amt_st)
num [1:3, 1:21] NA NA 451 NA NA 201 NA NA 200 NA ...
- attr(*, "dimnames")=List of 2
..$ cand_nm : chr [1:3] "Bachmann, Michele" "Obama, Barack" "Romney, Mitt"
..$ contbr_st: chr [1:21] "33" "46" "48" "7" ...
Now I need to filter out values from data_amt_st. I need states that "Obama, Barack" had more contributions than other candidates, but don't know how to do. Something with ?subset?
Thank you very much.
EDIT 1: Attending what guys told me, about making a more concrete question: I need a list of the states where Barack Obama achieved a higher contribution level (more money) than other candidates.
EDIT 2: Trying to give you a reproducible example (is it correct?):
x = c("a", "b", "c")
y0 = c(3, 5, 1)
y1 = c(2, 1, 6)
y2 = c(4, 2, 3)
m = cbind(x, y0, y1, y2)
m
# x y0 y1 y2
# [1,] "a" "3" "2" "4"
# [2,] "b" "5" "1" "2"
# [3,] "c" "1" "6" "3"
Now, I need to know, for what y values, a is higher than b and c.
Maybe
## max by column (MARGIN=2)
max_amt <- apply(data_amt_st,MARGIN=2,max,na.rm=TRUE)
data_amt_st[,max_amt==data_amt_st["Obama",]]
?
(Not sure how this will work with NA values in the Obama row: using dput to give us a reproducible example ( http://tinyurl.com/reproducible-000 ) would be useful ...)
x <- letters[1:3]
y0 <- c(3, 5, 1)
y1 <- c(2, 1, 6)
y2 <- c(4, 2, 3)
m <- data.frame(y0, y1, y2)
rownames(m) <- x
maxvals <- apply(m,2,max,na.rm=TRUE)
which(m["a",]==maxvals) ## or
names(m)[m["a",]==maxvals]
I am trying to use http://rss.acs.unt.edu/Rdoc/library/stats/html/constrOptim.html in R to do optimization in R with some given linear constraints but not able to figure out how to set up the problem.
For example, I need to maximize $f(x,y) = log(x) + \frac{x^2}{y^2}$ subject to constraints $g_1(x,y) = x+y < 1$, $g_2(x,y) = x > 0$ and $g_3(x,y) = y > 0$. How do I do this in R? This is just a hypothetical example. Do not worry about its structure, instead I am interested to know how to set this up in R.
thanks!
Setting up the function was trivial:
fr <- function(x) { x1 <- x[1]
x2 <- x[2]
-(log(x1) + x1^2/x2^2) # need negative since constrOptim is a minimization routine
}
Setting up the constraint matrix was problematic due to a lack of much documentation, and I resorted to experimentation. The help page says "The feasible region is defined by ui %*% theta - ci >= 0". So I tested and this seemed to "work":
> rbind(c(-1,-1),c(1,0), c(0,1) ) %*% c(0.99,0.001) -c(-1,0, 0)
[,1]
[1,] 0.009
[2,] 0.990
[3,] 0.001
So I put in a row for each constraint/boundary:
constrOptim(c(0.99,0.001), fr, NULL, ui=rbind(c(-1,-1), # the -x-y > -1
c(1,0), # the x > 0
c(0,1) ), # the y > 0
ci=c(-1,0, 0)) # the thresholds
For this problem there is a potential difficulty in that for all values of x the function goes to Inf as y -> 0. I do get a max around x=.95 and y=0 even when I push the starting values out to the "corner", but I'm somewhat suspicious that this is not the true maximum which I would have guessed was in the "corner".
EDIT:
Pursuing this I reasoned that the gradient might provide additional "direction" and added a gradient function:
grr <- function(x) { ## Gradient of 'fr'
x1 <- x[1]
x2 <- x[2]
c(-(1/x[1] + 2 * x[1]/x[2]^2),
2 * x[1]^2 /x[2]^3 )
}
This did "steer" the optimization a bit closer to the c(.999..., 0) corner, instead of moving away from it, as it did for some starting values. I remain somewhat disappointed that the process seems to "head for the cliff" when the starting values are close to the center of the feasible region:
constrOptim(c(0.99,0.001), fr, grr, ui=rbind(c(-1,-1), # the -x-y > -1
c(1,0), # the x > 0
c(0,1) ), # the y > 0
ci=c(-1,0, 0) )
$par
[1] 9.900007e-01 -3.542673e-16
$value
[1] -7.80924e+30
$counts
function gradient
2001 37
$convergence
[1] 11
$message
[1] "Objective function increased at outer iteration 2"
$outer.iterations
[1] 2
$barrier.value
[1] NaN
Note: Hans Werner Borchers posted a better example on R-Help that succeeded in getting the corner values by setting the constraint slightly away from the edge:
> constrOptim(c(0.25,0.25), fr, NULL,
ui=rbind( c(-1,-1), c(1,0), c(0,1) ),
ci=c(-1, 0.0001, 0.0001))
$par
[1] 0.9999 0.0001
When using formulas that have factors, the fitted models name the coefficients XY, where X is the name of the factor and Y is a particular level of it. I want to be able to create a formula from the names of these coefficients.
The reason: If I fit a lasso to a sparse design matrix (as I do below) I would like to create a new formula object that only contains terms for the nonzero coefficients.
require("MatrixModels")
require("glmnet")
set.seed(1)
n <- 200
Z <- data.frame(letter=factor(sample(letters,n,replace=T),letters),
x=sample(1:20,200,replace=T))
f <- ~ letter + x:letter + I(x>5):letter
X <- sparse.model.matrix(f, Z)
beta <- matrix(rnorm(dim(X)[2],0,5),dim(X)[2],1)
y <- X %*% beta + rnorm(n)
myfit <- glmnet(X,as.vector(y),lambda=.05)
fnew <- rownames(myfit$beta)[which(myfit$beta != 0)]
[1] "letterb" "letterc" "lettere"
[4] "letterf" "letterg" "letterh"
[7] "letterj" "letterm" "lettern"
[10] "lettero" "letterp" "letterr"
[13] "letters" "lettert" "letteru"
[16] "letterw" "lettery" "letterz"
[19] "lettera:x" "letterb:x" "letterc:x"
[22] "letterd:x" "lettere:x" "letterf:x"
[25] "letterg:x" "letterh:x" "letteri:x"
[28] "letterj:x" "letterk:x" "letterl:x"
[31] "letterm:x" "lettern:x" "lettero:x"
[34] "letterp:x" "letterq:x" "letterr:x"
[37] "letters:x" "lettert:x" "letteru:x"
[40] "letterv:x" "letterw:x" "letterx:x"
[43] "lettery:x" "letterz:x" "letterb:I(x > 5)TRUE"
[46] "letterc:I(x > 5)TRUE" "letterd:I(x > 5)TRUE" "lettere:I(x > 5)TRUE"
[49] "letteri:I(x > 5)TRUE" "letterj:I(x > 5)TRUE" "letterl:I(x > 5)TRUE"
[52] "letterm:I(x > 5)TRUE" "letterp:I(x > 5)TRUE" "letterq:I(x > 5)TRUE"
[55] "letterr:I(x > 5)TRUE" "letteru:I(x > 5)TRUE" "letterv:I(x > 5)TRUE"
[58] "letterx:I(x > 5)TRUE" "lettery:I(x > 5)TRUE" "letterz:I(x > 5)TRUE"
From this I would like to have a formula
~ I(letter=="d") + I(letter=="e") + ...(etc)
I checked out formula() and all.vars() to no avail. Also, writing a function to parse this is a bit of a pain because of the different types of terms that can arise. For example, for x:letter when x is a numeric value and letter is a factor, or I(x>5):letter as another annoying case.
So am I not aware of some function to convert between formula and its character representation and back again?
When I ran the code, I got something a bit different, since set.seed() had not been specified. Instead of using the variable name "letter", I used "letter_" as a convenient splitting marker:
> fnew <- rownames(myfit$beta)[which(myfit$beta != 0)]
> fnew
[1] "letter_c" "letter_d" "letter_e" "letter_f" "letter_h" "letter_k" "letter_l"
[8] "letter_o" "letter_q" "letter_r" "letter_s" "letter_t" "letter_u" "letter_v"
[15] "letter_w"
Then made the split and packaged into a character matrix:
> fnewmtx <- cbind( lapply(sapply(fnew, strsplit, split="_"), "[[", 2),
+ lapply(sapply(fnew, strsplit, split="_"), "[[", 1))
fnewmtx
[,1] [,2]
letter_c "c" "letter"
letter_d "d" "letter"
letter_e "e" "letter"
letter_f "f" "letter" snipped the rest
And wrapped the paste function(s) output in as.formula() which is half of the answer to how to "convert between formula and its character representation and back." The other half is as.character()
form <- as.formula( paste("~",
paste(
paste(" I(", fnewmtx[,2], "_ ==", "'",fnewmtx[,1],"') ", sep="") ,
sep="", collapse="+")
)
) # edit: needed to add back the underscore
And the output is now an appropriate class object:
> class(form)
[1] "formula"
> form
~I(letter_ == "c") + I(letter_ == "d") + I(letter_ == "e") +
I(letter_ == "f") + I(letter_ == "h") + I(letter_ == "k") +
I(letter_ == "l") + I(letter_ == "o") + I(letter_ == "q") +
I(letter_ == "r") + I(letter_ == "s") + I(letter_ == "t") +
I(letter_ == "u") + I(letter_ == "v") + I(letter_ == "w")
I find it interesting that the as.formula conversion made the single-quotes around the letters into double-quotes.
Edit: Now that the problem has an additional dimension or two, my suggestion is to skip the recreation of the formula. Note that the rownames of myfit$beta are exactly the same as the column names of X, so instead use the non-zero rownames as indices to select columns in the X matrix:
> str(X[ , which( colnames(X) %in% rownames(myfit$beta)[which(myfit$beta != 0)] )] )
Formal class 'dgCMatrix' [package "Matrix"] with 6 slots
..# i : int [1:429] 9 54 91 157 166 37 55 68 117 131 ...
..# p : int [1:61] 0 5 13 20 28 36 42 50 60 68 ...
..# Dim : int [1:2] 200 60
..# Dimnames:List of 2
.. ..$ : chr [1:200] "1" "2" "3" "4" ...
.. ..$ : chr [1:60] "letter_b" "letter_c" "letter_e" "letter_f" ...
..# x : num [1:429] 1 1 1 1 1 1 1 1 1 1 ...
..# factors : list()
> myfit2 <- glmnet(X[ , which( colnames(X) %in% rownames(myfit$beta)[which(myfit$beta != 0)] )] ,as.vector(y),lambda=.05)
> myfit2
Call: glmnet(x = X[, which(colnames(X) %in% rownames(myfit$beta)[
which(myfit$beta != 0)])],
y = as.vector(y), lambda = 0.05)
Df %Dev Lambda
[1,] 60 0.9996 0.05
Christopher, what you are asking for appears, after some consideration and examination of sparse.model.matrix etc, to be somewhat involved. You haven't explain why you do not want to form the full sparse model matrix for X_test so it is difficult to advise a way forward other than the two options below.
If you have a large number of observations in X_test and hence do not want to produce the full sparse matrix for use in predict() for computational reasons, it might be more expedient to split X_test into two or more chunks of samples and form the sparse model matrices for each one in turn, discarding it after after use.
Failing that, you will need to study code from the Matrix package in detail. Start with sparse.model.matrix and note that it then calls Matrix:::model.spmatrix and locate calls to Matrix:::fac2Sparse in that function. You will probably need to co-opt code from these functions but use a modified fac2Sparse to achieve what you want to achieve.
Sorry I cannot provide an off-the-shelf script to do this, but that is a substantial coding task. If you go down that route, check out the Sparse Model Matrices vignette in the Matrix package and get the package sources (from CRAN) to see if the functions I mention are better documented in the source code (there are no Rd files for fac2Sparse for example). You can also ask the authors of Matrix (Martin Maechler and Doug Bates) for advice, although note that both of these chaps have had a particularly heavy teaching load this term.
Good luck!