I run the R program from article where used mknapsack function from adagio package, and everything's good. But if I want using a random values I get an error "Error condition raised".
I have a program:
n=16
m=5
max=700
min = 10
planks_we_have = floor(runif(n=m, min = 100, max = max))
planks_we_want = floor(runif(n=n, min = min, max = 16))
library(adagio)
# mknapsack calling signature is: mknapsack(values, weights, capacities)
solution <- mknapsack(planks_we_want, planks_we_want, planks_we_have)
# Above I added +1 cm to each length to compensate for the loss when sawing.
solution$ksack
# Now pretty printing what to cut so that we don't make mistakes...
assignment <- data.frame(cut_this = planks_we_have[solution$ksack], into_this = planks_we_want)
t(assignment[order(assignment[,1]), ])
Result:
Warning
In mknapsack(planks_we_want, planks_we_want, planks_we_have) :
Error condition raised: check input data ...!
Error
In data.frame(cut_this = planks_we_have[solution$ksack], into_this = planks_we_want) :
Arguments imply different numbers of lines: 0, 5
I don't understand what is the reason. The source code of the knapsack function gives me nothing:
function (p, w, k, bck = -1)
{
stopifnot(is.numeric(p), is.numeric(w), is.numeric(k))
if (any(w <= 0))
stop("'weights' must be a vector of positive numbers.")
if (any(p <= 0))
stop("'profits' must be a vector of positive numbers.")
if (any(floor(p) != ceiling(p)) || any(floor(w) != ceiling(w)) ||
any(floor(k) != ceiling(k)) || any(p >= 2^31) || any(w >=
2^31) || any(k >= 2^31))
stop("All inputs must be positive integers < 2^31 !")
n <- length(p)
m <- length(k)
if (length(w) != n)
stop("Profit 'p' and weight 'w' must be vectors of equal length.")
xstar <- vector("integer", n)
vstar <- 0
num <- 5 * m + 14 * n + 4 * m * n + 3
wk <- numeric(n)
iwk <- vector("integer", num)
S <- .Fortran("mkp", as.integer(n), as.integer(m), as.integer(p),
as.integer(w), as.integer(k), bs = as.integer(bck),
xs = as.integer(xstar), vs = as.integer(vstar), as.numeric(wk),
as.integer(iwk), as.integer(num), PACKAGE = "adagio")
if (S$vs < 0)
warning("Error condition raised: check input data ...!")
return(list(ksack = S$xs, value = S$vs, btracks = S$bs))
}
Versions:
R - 3.4.1
Adagio - 0.7.1
Please read first the help page if you have problems with a function. Looking at the solution returned, it has error code vs=-7 and help says "vs=-7 if array k is not correctly sorted". Sorting the vector of capacities may give another error, for instance in case all items can be put in one knapsack. Of course, all this depends on the random numbers generated (better fix random numbers before asking).
Related
I need to integrate the following function where there is a differentiation term inside. Unfortunately, that term is not easily differentiable.
Is this possible to do something like numerical integration to evaluate this in R?
You can assume 30,50,0.5,1,50,30 for l, tau, a, b, F and P respectively.
UPDATE: What I tried
InnerFunc4 <- function(t,x){digamma(gamma(a*t*(LF-LP)*b)/gamma(a*t))*(x-t)}
InnerIntegral4 <- Vectorize(function(x) { integrate(InnerFunc4, 1, x, x = x)$value})
integrate(InnerIntegral4, 30, 80)$value
It shows the following error:
Error in integrate(InnerFunc4, 1, x, x = x) : non-finite function value
UPDATE2:
InnerFunc4 <- function(t,L){digamma(gamma(a*t*(LF-LP)*b)/gamma(a*t))*(L-t)}
t_lower_bound = 0
t_upper_bound = 30
L_lower_bound = 30
L_upper_bound = 80
step_size = 0.5
integral = 0
t <- t_lower_bound + 0.5*step_size
while (t < t_upper_bound){
L = L_lower_bound + 0.5*step_size
while (L < L_upper_bound){
volume = InnerFunc4(t,L)*step_size**2
integral = integral + volume
L = L + step_size
}
t = t + step_size
}
Since It seems that your problem is only the derivative, you can get rid of it by means of partial integration:
Edit
Not applicable solution for lower integration bound 0.
I need minimize a funtion based in Hsieh Model, using R language. The main objective is to minimize a distance function that depends on a set of other functions.
obj = function(x1){
s = sf()
h_til = h_tilf()
w_til = w_tilf(x1)
w_r = w_rf()
p_ir = p_irf()
#H_tr = H_trf(x1)
W = Wf(x1)
f1 = matrix(0, i, r)
f2 = matrix(0, i, r)
for (c in 1:i){
for (j in 1:r){
f1[c, j] = ( (W[c, j] - W_t[c, j]) / W_t[c, j] ) ** 2
f2[c, j] = ( (p_ir[c, j] - p_t[c, j]) / p_t[c, j] ) ** 2
}
}
d1 = sum(f1)
d2 = sum(f2)
D = d1 + d2
return(D)
}
Therefore, my algorithm must find three parameters (w, tau_w, tau_h) that minimize this distance function. These three parameters are arrays with i rows and r columns. Given by:
w = runif(i*r, 0, 1)
tau_w = runif(i*r, -1, 1)
tau_h = runif(i*r, -1, 1)
x1 = array( c(tau_w, tau_h, w), dim = c(i, r, 3))
I trying solve this using optimx and Rsolnp libraries.
res = optim(x1, #starting values
obj) #function to optimise
But i get this error:
Error in x1[c, j, 1] : incorrect number of dimensions
This minimization is usually done using the Nelder-Mead algorithm.
I'm beginner in optimization and apreciate any help. My complete code is here.
The dimensions of the array x1 are lost when you do optim(x1, obj). So the error you get is returned by w_tilf(x1) because it involves x1[c,j,1].
Reconstruct the array at the beginning of the obj function:
obj = function(x1){
x1 = array(x1, dim = c(i, r, 3))
s = sf()
......
}
Then opt <- optim(x1, obj) should work now. It will return the solution in the opt$par field as a vector, you will have to do array(opt$par, dim = c(i, r, 3)) to get an array.
I am solving a task for my R online course. The task is to write a function, that solves the quadratic equation with the Lagrange resolvents, or:
x1<--p/2+sqrt((p/2)^2-q)
x2<--p/2-sqrt((p/2)^2-q)
1) If the arguments are non-numeric, the function should return an explained error (or why the error has happend). 2) If there are missing arguments, the function should return an explained error (different from the default). 3) If x1 and x2 are complex numbers (for example if p=-4 and q=7, then x1=2+i*1.73 and x2=2-i*1.73), the function should should also solve the equation instead of generating NaNs and return a warning message, that the numbers are complex. Maybe if I somehow cast it to as.complex, but I want this to be a special case and don't want to cast the basic formula.
My function looks like this:
quadraticEquation<-function(p,q){
if(!is.numeric(c(p,q)))stop("p and q are not numeric") #partly works
if(is.na(c(p,q)))stop("there are argument/s missing") #does not work
x1<--p/2+sqrt((p/2)^2-q)
x2<--p/2-sqrt((p/2)^2-q)
#x1<--p/2+sqrt(as.complex((p/2)^2-q)) works, but I want to perform this only in case the numbers are complex
#x2<--p/2-sqrt(as.complex((p/2)^2-q))
return (c(x1,x2))
}
When testing the function:
quadraticEquation(4,3) #basic case is working
quadraticEquation(TRUE,5) #non-numeric, however the if-statement is not executed, because it assumes that TRUE==1
quadraticEquation(-4,7) #complex number
1) how to write the function, so it assumes TRUE (without "") and anything that is non-numeric as non-numeric?
2) basic case, works.
3) how can I write the function, so it solves the equation and prints the complex numbers and also warns that the numbers are complex (warning())?
Something like this?
quadraticEquation <- function(p, q){
## ------------------------% chek the arguments %---------------------------##
if(
missing(p) | missing(q) # if any of arguments is
){ # missing - stop.
stop("[!] There are argument/s missing")
}
else if(
!is.numeric(p) | !is.numeric(q) | any(is.na(c(p, q))) # !is.numeric(c(1, T))
){ # returns TRUE - conver-
stop("[!] Argument/s p or/and q are not numeric") # tion to the same type
}
## --------------------% main part of the function %--------------------------##
r2 <- p^2 - 4*q # calculate r^2,
if(r2 < 0){ # if r2 < 0 (convert) it
warning("equation has complex roots") # to complex and warn
r2 <- as.complex(r2)
}
# return named roots
setNames(c(-1, 1) * sqrt(r2)/2 - p/2, c("x1", "x2"))
}
quadraticEquation() # No arguments provided
#Error in quadraticEquation() : [!] There are argument/s missing
quadraticEquation(p = 4) # Argument q is missing
#Error in quadraticEquation(p = 4) : [!] There are argument/s missing
quadraticEquation(p = TRUE, q = 7) # p is logical
#Error in quadraticEquation(p = TRUE, q = 7) :
#[!] Argument/s p or/and q are not numeric
quadraticEquation(p = NA, q = 7) # p is NA
#Error in quadraticEquation(p = NA, q = 7) :
#[!] Argument/s p or/and q are not numeric
quadraticEquation(p = 7, q = -4) # real roots
# x1 x2
#-7.5311289 0.5311289
quadraticEquation(p = -4, q = 7) # complex roots
# x1 x2
#2-1.732051i 2+1.732051i
#Warning message:
#In quadraticEquation(p = -4, q = 7) : equation has complex roots
When you write is.numeric(c(p, q)), R first evaluates c(p, q) before determining whether it is numeric or not. In particular if p = TRUE and q = 3, then c(p, q) is promoted to the higher type: c(1, 3).
Here is a vectorized solution, so if p and q are vectors instead of scalars the result is also a vector.
quadraticEquation <- function(p, q) {
if (missing(p)) {
stop("`p` is missing.")
}
if (missing(q)) {
stop("`q` is missing.")
}
if (!is.numeric(p)) {
stop("`p` is not numeric.")
}
if (!is.numeric(q)) {
stop("`q` is not numeric.")
}
if (anyNA(p)) {
stop("`p` contains NAs.")
}
if (anyNA(q)) {
stop("`q` contains NAs.")
}
R <- p^2 / 4 - q
if (min(R) < 0) {
R <- as.complex(R)
warning("Returning complex values.")
}
list(x1 = -p / 2 + sqrt(R),
x2 = -p / 2 - sqrt(R))
}
Also, you should never write x1<--p/2. Keep spaces around infix operators: x1 <- -p/2.
How can the Kendall tau distance (a.k.a. bubble-sort distance) between two permutations be calculated in R without loading additional libraries?
Here is an O(n.log(n)) implementation scraped together after reading around, but I suspect there may be better R solutions.
inversionNumber <- function(x){
mergeSort <- function(x){
if(length(x) == 1){
inv <- 0
#printind(' base case')
} else {
n <- length(x)
n1 <- ceiling(n/2)
n2 <- n-n1
y1 <- mergeSort(x[1:n1])
y2 <- mergeSort(x[n1+1:n2])
inv <- y1$inversions + y2$inversions
x1 <- y1$sortedVector
x2 <- y2$sortedVector
i1 <- 1
i2 <- 1
while(i1+i2 <= n1+n2+1){
if(i2 > n2 || (i1 <= n1 && x1[i1] <= x2[i2])){ # ***
x[i1+i2-1] <- x1[i1]
i1 <- i1 + 1
} else {
inv <- inv + n1 + 1 - i1
x[i1+i2-1] <- x2[i2]
i2 <- i2 + 1
}
}
}
return (list(inversions=inv,sortedVector=x))
}
r <- mergeSort(x)
return (r$inversions)
}
.
kendallTauDistance <- function(x,y){
return(inversionNumber(order(x)[rank(y)]))
}
If one needs custom tie-breaking one would have to fiddle with the last condition on the line marked # ***
Usage:
> kendallTauDistance(c(1,2,4,3),c(2,3,1,4))
[1] 3
You could use
(choose(length(x),2) - cov(x,y,method='kendall')/2)/2
if you know that both of the input lists x and y do not contain duplicates.
Hmmm. Somebody is interested in exactly same thing which I have been working on.
Below is my code in python.
from collections import OrderedDict
def invert(u):
identity = sorted(u)
ui = []
for x in identity:
index = u.index(x)
ui.append(identity[index])
print "Given U is:\n",u
print "Inverse of U is:\n",ui
return identity,ui
def r_vector(x,y,id):
# from collections import OrderedDict
id_x_Map = OrderedDict(zip(id,x))
id_y_Map = OrderedDict(zip(id,y))
r = []
for x_index,x_value in id_x_Map.items():
for y_index,y_value in id_y_Map.items():
if (x_value == y_index):
r.append(y_value)
print r
return r
def xr_vector(x):
# from collections import OrderedDict
values_checked = []
unorderd_xr = []
ordered_xr = []
for value in x:
values_to_right = []
for n in x[x.index(value)+1:]:
values_to_right.append(n)
result = [i for i in values_to_right if i < value]
if(len(result)!=0):
values_checked.append(value)
unorderd_xr.append(len(result))
value_ltValuePair = OrderedDict(zip(values_checked,unorderd_xr))
for key in sorted(value_ltValuePair):
# print key,value_ltValuePair[key]
ordered_xr.append(value_ltValuePair[key])
print "Xr= ",ordered_xr
print "Kendal Tau distance = ",sum(ordered_xr)
if __name__ == '__main__':
print "***********************************************************"
print "Enter the first string (U):"
u = raw_input().split()
print "Enter the second string (V):"
v = raw_input().split()
print "***********************************************************"
print "Step 1: Find U Inverse"
identity,uinverse = invert(u)
print "***********************************************************"
print "Step 2: Find R = V.UInverse"
r = r_vector(v,uinverse,identity)
print "***********************************************************"
print "Step 3: Finding XR and Kenday_Tau"
xr_vector(r)
About the approach/ algorithm to find Kendall Tau distance this way, I would either leave it to you, or point towards the research paper Optimal Permutation Codes and the Kendall’s τ-Metric
You can implement (Approach) the same in R.
I've just been working though converting some MATLAB scripts to work in R, however having never used MATLAB in my life, and not exactly being an expert on R I'm having some trouble.
Edit: It's a script I was given designed to correct temperature measurements for lag generated by insulation mass effects. My understanding is that It looks at the rate of change of the temperature and attempts to adjust for errors generated by the response time of the sensor. Unfortunately there is no literature available to me to give me an indication of the numbers i am expecting from the function, and the only way to find out will be to experimentally test it at a later date.
the original script:
function [Tc, dT] = CTD_TempTimelagCorrection(T0,Tau,t)
N1 = Tau/t;
Tc = T0;
N = 3;
for j=ceil(N/2):numel(T0)-ceil(N/2)
A = nan(N,1);
# Compute weights
for k=1:N
A(k) = (1/N) + N1 * ((12*k - (6*(N+1))) / (N*(N^2 - 1)));
end
A = A./sum(A);
# Verify unity
if sum(A) ~= 1
disp('Error: Sum of weights is not unity');
end
Comp = nan(N,1);
# Compute components
for k=1:N
Comp(k) = A(k)*T0(j - (ceil(N/2)) + k);
end
Tc(j) = sum(Comp);
dT = Tc - T0;
end
where I've managed to get to:
CTD_TempTimelagCorrection <- function(temp,Tau,t){
## Define which equation to use based on duration of lag and frequency
## With ESM2 profiler sampling # 2hz: N1>tau/t = TRUE
N1 = Tau/t
Tc = temp
N = 3
for(i in ceiling(N/2):length(temp)-ceiling(N/2)){
A = matrix(nrow=N,ncol=1)
# Compute weights
for(k in 1:N){
A[k] = (1/N) + N1 * ((12*k - (6*(N+1))) / (N*(N^2 - 1)))
}
A = A/sum(A)
# Verify unity
if(sum(A) != 1){
print("Error: Sum of weights is not unity")
}
Comp = matrix(nrow=N,ncol=1)
# Compute components
for(k in 1:N){
Comp[k] = A[k]*temp[i - (ceiling(N/2)) + k]
}
Tc[i] = sum(Comp)
dT = Tc - temp
}
return(dT)
}
I think the problem is the Comp[k] line, could someone point out what I've done wrong? I'm not sure I can select the elements of the array in such a way.
by the way, Tau = 1, t = 0.5 and temp (or T0) will be a vector.
Thanks
edit: apparently my description is too brief in explaining my code samples, not really sure what more I could write that would be relevant and not just wasting peoples time. Is this enough Mr Filter?
The error is as follows:
Error in Comp[k] = A[k] * temp[i - (ceiling(N/2)) + k] :
replacement has length zero
In addition: Warning message:
In Comp[k] = A[k] * temp[i - (ceiling(N/2)) + k] :
number of items to replace is not a multiple of replacement length
If you write print(i - (ceiling(N/2)) + k) before that line, you will see that you are using incorrect indices for temp[i - (ceiling(N/2)) + k], which means that nothing is returned to be inserted into Comp[k]. I assume this problem is due to Matlab allowing the use of 0 as an index and not R, and the way negative indices are handled (they don't work the same in both languages). You need to implement a fix to return the correct indices.