I just wrote my first attempt of providing a neuronal network for household classification by using energy consumption features. So far I could make it run but the output seems to be questionable.
So like you can see I'm using 18 features (maybe to much?) to predict if it's a single or non-single household.
I got 3488 rows like this:
c_day c_weekend c_evening c_morning c_night c_noon c_max c_min r_mean_max r_min_mean r_night_day r_morning_noon
12 14 1826 9 765 3 447 2 878 0 7338 4
r_evening_noon t_above_1kw t_above_2kw t_above_mean t_daily_max single
3424 1 695 0 174319075712881 1
My neuronal network using these parameters:
net.nn <- neuralnet(single
~ c_day
+ c_weekend
+ c_weekday
+ c_evening
+ c_morning
+ c_night
+ c_noon
+ c_max
+ c_min
+ r_mean_max
+ r_min_mean
+ r_night_day
+ r_morning_noon
+ r_evening_noon
+ t_above_1kw
+ t_above_2kw
+ t_above_mean
+ t_daily_max
,train, hidden=15, threshold=0.01,linear.output=F)
1 repetition was calculated.
Error Reached Threshold Steps
1 126.3425379 0.009899229932 4091
I normalized the data before by using the min-max normalization formula:
for(i in names(full_data)){
x <- as.numeric(full_data[,i])
full_data[,i] <- (x-min(x)/max(x)-min(x))
}
I got 3488 rows of data and splitted them into a training and a test set.
half <- nrow(full_data)/2
train <- full_data[1:half,]
test <- full_data[half:3488,]
net.results <- compute(net.nn,test)
nn$net.result
I used the prediction method and bound it to the actual "single[y/no]"-column to compare the result:
predict <- nn$net.result
cleanoutput <- cbind(predict,full_data$single[half:3488])
colnames(cleanoutput) <- c("predicted","actual")
So when I print it, this is my classification result for the first 10 rows:
predicted actual
1701 0.1661093405 0
1702 0.1317067578 0
1703 0.1677147708 1
1704 0.2051188618 1
1705 0.2013035634 0
1706 0.2088726723 0
1707 0.2683753128 1
1708 0.1661093405 0
1709 0.2385537285 1
1710 0.1257108821 0
So if I understand it right, when I round the predicted output it should be either a 0 or 1 but it always ends up being a 0!
Am I using the wrong parameters? Is my data simply not suitable for nn prediction? Is the normalization wrong?
It means your model performance is still not good. Once you have reached good model performance after tuning you should get correct expected behavior. Neural net techniques are very susceptible of scale difference between different columns so standardization of data [mean =0 std =1] is a good practice. As pointed by OP scale() does the job.
Using scale(full_data) for the entire data did the trick. Now the data is normalized through standard-mean deviation and the output seems much more reliable.
Related
I'm using the MCMCglmm function in its package to create a mixed-effects model for three-level categorical model. The goal is to get probabilities of each of the three classes in response for each row of data in the 5000 row test_week test set.
prior6 <- list(R=list(V=diag(2), nu=0.0001),
G=list(G1=list(V=diag(4), nu=0.0001, alpha.mu=rep(0,4), alpha.V=diag(4) * 25),
G2=list(V=diag(1), nu=0.0001, alpha.mu=rep(0,1), alpha.V=diag(1) * 25),
G3=list(V=diag(2), nu=0.0001, alpha.mu=rep(0,2), alpha.V=diag(2) * 25),
G4=list(V=diag(1), nu=0.0001, alpha.mu=rep(0,1), alpha.V=diag(1) * 25),
G5=list(V=diag(2), nu=0.0001, alpha.mu=rep(0,2), alpha.V=diag(2) * 25),
G6=list(V=diag(1), nu=0.0001, alpha.mu=rep(0,1), alpha.V=diag(1) * 25)))
mix_mod_fit6 <- MCMCglmm(response ~ 1 + x + y + z, random=~us(1 + x + y + z):a +
us(1):d + us(1 + x):b + us(1):e + us(1 + z):c + us(1):f,
rcov=~ us(trait):units, prior=prior6, family='categorical',
data=train_weeks_sample1, nitt=3850, thin=45, burnin=2500)
mixed_final_predictions6 <- predict.MCMCglmm(mix_mod_fit6, test_week,
type='response', interval='prediction')
The issue arises with the predict function, returning a 10000x1 matrix of numbers that very roughly mirror the probabilities of the 2nd and 3rd levels in response (the first 5000 rows corresponding to the 2nd level and the following 5000 to the 3rd level) after I split them into a 5000x2 matrix. I can then backsolve to get the predictions for the 1st level, but the predictions are problematic. They only predict in multiples of 1/30 as shown below (and also illustrated in the histograms in the picture).
temp6
0 0.0333333333333333 0.0666666666666667 0.1 0.133333333333333 0.166666666666667
7935 3914 2199 1901 1883 2173
0.2 0.233333333333333 0.266666666666667 0.3 0.333333333333333 0.366666666666667
2257 2198 1991 1703 1465 1184
0.4 0.433333333333333 0.466666666666667 0.5 0.533333333333333 0.566666666666667
987 756 527 410 268 164
0.6 0.633333333333333 0.666666666666667 0.7
98 35 24 6
Any insight or examples on how the predict.MCMCglmm function works, how to receive predictions more granular than just thirtieths, as well as predictions for all three levels rather than just two would be greatly appreciated! Thank you!
Note: The prior's V values were specifically selected to match the element sizes in the MCMCglmm call, and cannot be changed. However, altering the value of nu has no effect on the predictions, nor does ommitting alpha.mu and alpha.V.
Current results vs ideal results distribution example:
We have the below code for solving an optimization problem where we want to maximize sales by applying constraint on profit and no. of items.
We want to apply this profit threshold as a percentage of Revenue generated by 200 items only.
We have done it by applying a formula on profit using changing variable in Excel Solver using GRGE non-linear algorithm. We want a similar alternative for R.
Is there any way to assign changing variable in R?
Dataset
item sales profit
A 1200 120
B 5600 45
C 450 00
D 990 -90
E 1000 80
F 560 120
G 500 23
H 2000 350
Code
library(lpSolveAPI)
dataset<-read.csv("Dataset.csv",header=T,na.strings='NA',stringsAsFactors =F)
dataset$keep_flag <-1
**all the func in LPsolve API**
ls("package:lpSolveAPI")
summary(dataset)
**Passing the parameters**
ncol <- nrow(dataset)
**you have eight rows that can be picked or dropped from the solution set**
lp_rowpicker <- make.lp(ncol=ncol)
set.type(lp_rowpicker, columns=1:ncol, type = c("binary"))
**checking the model**
lp_rowpicker
**setting objective**
obj_vals <- dataset$Revenue_1hr.Projected
#obj_vals<- dataset[, 2]
obj_vals
set.objfn(lp_rowpicker, obj_vals)
lp.control(lp_rowpicker,sense='max')
**Adding contraints**
Profit constraint
xt<- (dataset$Profit_1hr.Projected)
add.constraint(lp_rowpicker, xt, ">=", 100)
xt
#No.of items to be kept
xt<- (dataset$keep_flag)
add.constraint(lp_rowpicker, xt, "=", 4)
xt
#model check
lp_rowpicker
#solving equation
solve(lp_rowpicker)
#Maximised revenue
get.objective(lp_rowpicker)
#The one with binary as 1 is our item
dataset$keep_flag<- get.variables(lp_rowpicker)
dataset$keep_flag <- as.data.frame(dataset$keep_flag)
sum(dataset$keep_flag)
final_set <- cbind(dataset,final_flag)
final_set <- final_set[which(final_set$final_flag==1),]
final_set$keep_flag <- NULL
final_set$final_flag<- NULL
This code snippet applies the profit threshold on total no. of items rather than applying it on selected items.
Edit
This is the model that got created when I ran #Karsten W. code:
C1 C2 C3 C4 C5 C6 C7 C8
Maximize 1200 5600 450 990 1000 560 500 2000
R1 120 45 0 -90 80 120 23 350 >= 100
R2 1 1 1 1 1 1 1 1 = 4
Kind Std Std Std Std Std Std Std Std
Type Int Int Int Int Int Int Int Int
Upper 1 1 1 1 1 1 1 1
Lower 0 0 0 0 0 0 0 0
And the output obtained is:
item sales profit
1 A 1200 120
1.1 A 1200 120
1.2 A 1200 120
1.3 A 1200 120
The same item is returned four times. I want 4 unique items. Plus I want to apply constraint of profit as a percentage of Sales generated by those 4 items.
By the way, we kept 'keep_flag' for the similar function to what your 'nitems' is doing. It is a changing variable that takes binary value.
Your code seems ok to me, except for that the variable names do not fit to the dataset you provided. In particular it is not clear to me what keep_flag stands for, is that some sort of preselection?
The profit constraint in your code is applied only the four from the solver selected variabes.
Here is your code, a bit cleaned up.
library(lpSolveAPI)
dataset <- data.frame(item=LETTERS[1:8], sales=c(1200, 5600, 450, 990, 1000, 560, 500, 2000), profit=c(120, 45, 0, -90, 80, 120, 23, 350))
nitems <- nrow(dataset)
# make lp
lprec <- make.lp(0, ncol=nitems)
set.type(lprec, columns=seq.int(nitems), type="binary")
# set objective
lp.control(lprec, sense="max", bb.rule="gap", timeout=30)
set.objfn(lprec, obj=dataset[, "sales"])
# constraints
min_rel_profit <- 0.10 # min. 10% profit
add.constraint(lprec, dataset[, "profit"]-min_rel_profit*dataset[,"sales"], ">=", 0) # required profit
add.constraint(lprec, rep(1, nitems), "=", 4) # four products
print(lprec)
solve(lprec)
dataset[get.variables(lprec)==1,]
The profit constraint is derived as follows (p is the vector of profits, s is the vector of sales, x is the decision variable 0/1, all of length nitems, minp is the minimum relative profit):
sum(profit) / sum(sales) >= minprofit translates to p'x/s'x >= minp
this is equivalent to (p - minp s)'x >= 0
Hence the minimum profit has to appear as part of the coefficients on the LHS.
If you are encountering long solving times, you can finetune the parameters. See ?lp.control.options for more details. Use timeout to set a time limit while testing. For this kind of problem (MIP) the bb.rule parameter is helpful. Given your example data, a solution for 9.5% was found in less than one second.
I would look at a few and choose the best
LPSolve https://cran.r-project.org/web/packages/lpSolve/lpSolve.pdf,
This is a simple linear solver. Its pretty much similar to LPSolve Api but I find it much more easier.
Minqa https://cran.r-project.org/web/packages/minqa/minqa.pdf
This is a quadriatic solver that works mostly for non linear problems
Gurobi http://www.gurobi.com/products/modeling-languages/r
This is an open source implementation of IBM's CPLEX solver. Very good and competent.
I am trying to run a nls model for a pavement data ,I have different sections and I need to run a same model (of course with different variables for each section)
following is my model
data<-read.csv(file.choose(),header=TRUE)
data
SecNum=data[,1]
t=c()
PCI=c()
t
PCI
for(i in 1:length(SecNum)){
if(SecNum[i] == SecNum[i+1]){
tt=data[i,2]
PCIt=data[i,3]
t=c(t, tt)
PCI=c(PCI, PCIt)
} else {
tt=data[i,2]
PCIt=data[i,3]
t=c(t, tt)
PCI=c(PCI, PCIt)
alpha=1
betha=1
theta=1
fit = nls(PCI ~ alpha-beta*exp((-theta*(t^gama))),
start=c(alpha=min(c(PCI, PCIt)),beta=1,theta=1,gama=1))
fitted(fit)
resid(fit)
print(t)
print(PCI)
t= c()
PCI= c()
}
}
after running my model I received an error like this
Error in nls(PCI ~ alpha - beta * exp((-theta * (t^gama))), start = c(alpha = min(c(PCI, :
singular gradient
My professor told me to use "nlsList" instead and that might solve the problem.
since I am new in R I don't know how to do that .I would be really thankful if anyone can advice me how to do it.
here is a sample of my data.
SecNum t PCI AADT ESAL
1 962 1 90.46 131333 3028352
2 962 2 90.01 139682 3213995
3 962 3 86.88 137353 2205859
4 962 4 86.36 137353 2205859
5 962 5 84.56 137353 2205859
6 962 6 85.11 137353 2205859
7 963 1 91.33 91600 3726288
I have data.frame TC, with 17744 observations of 13 variables. The last variable is target: a Factor w/ 2 levels "0", "1".
I do:
n.col <- ncol(TC)
x.train.or <- TC[1:12000, -n.col]
y.train.or <- TC[1:12000, n.col]
x.test.or <- TC[12000:17000, -n.col]
y.test.or <- TC[12000:17000, n.col]
rf.or <- randomForest(y=y.train.or, x=x.train.or, ntree=500, mtry=5,
importance=TRUE, keep.forest=TRUE,
na.action=na.roughfix, replace=FALSE)
pr.or <- predict(rf.or, x.test.or)
table(y.test.or, pr.or, dnn=c("Actual", "Predicted"))
# Predicted
# Actual 0 1
# 0 2424 780
# 1 1056 741
Very bad result.
Then I repeat the model fitting with a random sample:
set.seed <- 123
t.t <- holdout(TC[, n.col], ratio=3/5, mode = "random")
x.train.r <- TC[t.t$tr, - (n.col)]
y.train.r <- TC[t.t$tr, (n.col)]
x.test.r <- TC[t.t$ts, - (n.col)]
rf.r <- randomForest(y=y.train.r, x=x.train.r, ntree=500, mtry=5,
importance=TRUE, keep.forest=TRUE,
na.action=na.roughfix, replace=FALSE)
pr.r <- predict(rf.r, x.test.r)
table(y.test.r, pr.r, dnn=c("Actual", "Predicted"))
# Predicted
# Actual 0 1
# 0 4274 215
# 1 353 2257
Very good result but depended on a way of formation of sample of an one data set.
Problem which I solves assumed only serial sample.
Please, help me!
Answer to questions:
(1)Certainly I do:
library(randomForest)
library(rminer)
(3) I repeat with:
n.col <- ncol(TC)
x.train.or <- TC[1:12000, -n.col]
y.train.or <- TC[1:12000, n.col]
x.test.or <- TC[12001:17000, -n.col]
y.test.or <- TC[12001:17000, n.col]
and receiving the same awful result
Predicted
Actual 0 1
0 2413 790
1 1049 748
(4)There could be a problem in it? Some variables are random on [1:17000], but not random on [1:100]
(I had no rights to drawings).
What to do in that case?
First, it's going to be a little difficult to answer without knowing the state of the data. Sometimes you can be including your test set in your train set if observations repeat themselves in some sort of manner.
One of the best ways to validate your results is through using some sort of cross-validation technique paying heed to making sure you completely separate your test and train set. Below is a good video to watch on that.
http://vimeo.com/75432414
I asked this question a year ago and got code for this "probability heatmap":
numbet <- 32
numtri <- 1e5
prob=5/6
#Fill a matrix
xcum <- matrix(NA, nrow=numtri, ncol=numbet+1)
for (i in 1:numtri) {
x <- sample(c(0,1), numbet, prob=c(prob, 1-prob), replace = TRUE)
xcum[i, ] <- c(i, cumsum(x)/cumsum(1:numbet))
}
colnames(xcum) <- c("trial", paste("bet", 1:numbet, sep=""))
mxcum <- reshape(data.frame(xcum), varying=1+1:numbet,
idvar="trial", v.names="outcome", direction="long", timevar="bet")
library(plyr)
mxcum2 <- ddply(mxcum, .(bet, outcome), nrow)
mxcum3 <- ddply(mxcum2, .(bet), summarize,
ymin=c(0, head(seq_along(V1)/length(V1), -1)),
ymax=seq_along(V1)/length(V1),
fill=(V1/sum(V1)))
head(mxcum3)
library(ggplot2)
p <- ggplot(mxcum3, aes(xmin=bet-0.5, xmax=bet+0.5, ymin=ymin, ymax=ymax)) +
geom_rect(aes(fill=fill), colour="grey80") +
scale_fill_gradient("Outcome", formatter="percent", low="red", high="blue") +
scale_y_continuous(formatter="percent") +
xlab("Bet")
print(p)
(May need to change this code slightly because of this)
This is almost exactly what I want. Except each vertical shaft should have different numbers of bins, ie the first should have 2, second 3, third 4 (N+1). In the graph shaft 6 +7 have the same number of bins (7), where 7 should have 8 (N+1).
If I'm right, the reason the code does this is because it is the observed data and if I ran more trials we would get more bins. I don't want to rely on the number of trials to get the correct number of bins.
How can I adapt this code to give the correct number of bins?
I have used R's dbinom to generate the frequency of heads for n=1:32 trials and plotted the graph now. It will be what you expect. I have read some of your earlier posts here on SO and on math.stackexchange. Still I don't understand why you'd want to simulate the experiment rather than generating from a binomial R.V. If you could explain it, it would be great! I'll try to work on the simulated solution from #Andrie to check out if I can match the output shown below. For now, here's something you might be interested in.
set.seed(42)
numbet <- 32
numtri <- 1e5
prob=5/6
require(plyr)
out <- ldply(1:numbet, function(idx) {
outcome <- dbinom(idx:0, size=idx, prob=prob)
bet <- rep(idx, length(outcome))
N <- round(outcome * numtri)
ymin <- c(0, head(seq_along(N)/length(N), -1))
ymax <- seq_along(N)/length(N)
data.frame(bet, fill=outcome, ymin, ymax)
})
require(ggplot2)
p <- ggplot(out, aes(xmin=bet-0.5, xmax=bet+0.5, ymin=ymin, ymax=ymax)) +
geom_rect(aes(fill=fill), colour="grey80") +
scale_fill_gradient("Outcome", low="red", high="blue") +
xlab("Bet")
The plot:
Edit: Explanation of how your old code from Andrie works and why it doesn't give what you intend.
Basically, what Andrie did (or rather one way to look at it) is to use the idea that if you have two binomial distributions, X ~ B(n, p) and Y ~ B(m, p), where n, m = size and p = probability of success, then, their sum, X + Y = B(n + m, p) (1). So, the purpose of xcum is to obtain the outcome for all n = 1:32 tosses, but to explain it better, let me construct the code step by step. Along with the explanation, the code for xcum will also be very obvious and it can be constructed in no time (without any necessity for for-loop and constructing a cumsum everytime.
If you have followed me so far, then, our idea is first to create a numtri * numbet matrix, with each column (length = numtri) having 0's and 1's with probability = 5/6 and 1/6 respectively. That is, if you have numtri = 1000, then, you'll have ~ 834 0's and 166 1's *for each of the numbet columns (=32 here). Let's construct this and test this first.
numtri <- 1e3
numbet <- 32
set.seed(45)
xcum <- t(replicate(numtri, sample(0:1, numbet, prob=c(5/6,1/6), replace = TRUE)))
# check for count of 1's
> apply(xcum, 2, sum)
[1] 169 158 166 166 160 182 164 181 168 140 154 142 169 168 159 187 176 155 151 151 166
163 164 176 162 160 177 157 163 166 146 170
# So, the count of 1's are "approximately" what we expect (around 166).
Now, each of these columns are samples of binomial distribution with n = 1 and size = numtri. If we were to add the first two columns and replace the second column with this sum, then, from (1), since the probabilities are equal, we'll end up with a binomial distribution with n = 2. Similarly, instead, if you had added the first three columns and replaced th 3rd column by this sum, you would have obtained a binomial distribution with n = 3 and so on...
The concept is that if you cumulatively add each column, then you end up with numbet number of binomial distributions (1 to 32 here). So, let's do that.
xcum <- t(apply(xcum, 1, cumsum))
# you can verify that the second column has similar probabilities by this:
# calculate the frequency of all values in 2nd column.
> table(xcum[,2])
0 1 2
694 285 21
> round(numtri * dbinom(2:0, 2, prob=5/6))
[1] 694 278 28
# more or less identical, good!
If you divide the xcum, we have generated thus far by cumsum(1:numbet) over each row in this manner:
xcum <- xcum/matrix(rep(cumsum(1:numbet), each=numtri), ncol = numbet)
this will be identical to the xcum matrix that comes out of the for-loop (if you generate it with the same seed). However I don't quite understand the reason for this division by Andrie as this is not necessary to generate the graph you require. However, I suppose it has something to do with the frequency values you talked about in an earlier post on math.stackexchange
Now on to why you have difficulties obtaining the graph I had attached (with n+1 bins):
For a binomial distribution with n=1:32 trials, 5/6 as probability of tails (failures) and 1/6 as the probability of heads (successes), the probability of k heads is given by:
nCk * (5/6)^(k-1) * (1/6)^k # where nCk is n choose k
For the test data we've generated, for n=7 and n=8 (trials), the probability of k=0:7 and k=0:8 heads are given by:
# n=7
0 1 2 3 4 5
.278 .394 .233 .077 .016 .002
# n=8
0 1 2 3 4 5
.229 .375 .254 .111 .025 .006
Why are they both having 6 bins and not 8 and 9 bins? Of course this has to do with the value of numtri=1000. Let's see what's the probabilities of each of these 8 and 9 bins by generating probabilities directly from the binomial distribution using dbinom to understand why this happens.
# n = 7
dbinom(7:0, 7, prob=5/6)
# output rounded to 3 decimal places
[1] 0.279 0.391 0.234 0.078 0.016 0.002 0.000 0.000
# n = 8
dbinom(8:0, 8, prob=5/6)
# output rounded to 3 decimal places
[1] 0.233 0.372 0.260 0.104 0.026 0.004 0.000 0.000 0.000
You see that the probabilities corresponding to k=6,7 and k=6,7,8 corresponding to n=7 and n=8 are ~ 0. They are very low in values. The minimum value here is 5.8 * 1e-7 actually (n=8, k=8). This means that you have a chance of getting 1 value if you simulated for 1/5.8 * 1e7 times. If you check the same for n=32 and k=32, the value is 1.256493 * 1e-25. So, you'll have to simulate that many values to get at least 1 result where all 32 outcomes are head for n=32.
This is why your results were not having values for certain bins because the probability of having it is very low for the given numtri. And for the same reason, generating the probabilities directly from the binomial distribution overcomes this problem/limitation.
I hope I've managed to write with enough clarity for you to follow. Let me know if you've trouble going through.
Edit 2:
When I simulated the code I've just edited above with numtri=1e6, I get this for n=7 and n=8 and count the number of heads for k=0:7 and k=0:8:
# n = 7
0 1 2 3 4 5 6 7
279347 391386 233771 77698 15763 1915 117 3
# n = 8
0 1 2 3 4 5 6 7 8
232835 372466 259856 104116 26041 4271 392 22 1
Note that, there are k=6 and k=7 now for n=7 and n=8. Also, for n=8, you have a value of 1 for k=8. With increasing numtri you'll obtain more of the other missing bins. But it'll require a huge amount of time/memory (if at all).