align-toparrow-leftarrow-rightbackbellblockcalendarcamerachatcheckchevron-downchevron-leftchevron-rightchevron-small-downchevron-small-leftchevron-small-rightchevron-small-upchevron-upcircle-with-crosscrosseditemptyheartfacebookfullheartglobegoogleimagesinstagramlocation-pinmagnifying-glassmailmoremuplabelShape 3 + Rectangle 1outlookpersonplusImported LayersImported LayersImported Layersshieldstartwitteryahoo
Shayne H.
schodge
Redwood City, CA
Post #: 1
If there's a better place on the web to post this, please let me know.

I've been having a lot of trouble with some code for an inventory analysis problem I was doing, and finally came to the conclusion that it appears that choose() is returning incorrect values. Specifically:

-------------

Browse[1]> nn
[1] 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3
Browse[1]> Q1
[1] 3
Browse[1]> choose(Q1,3)
[1] 0
Browse[1]> choose(Q1,nn)
[1] 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 0 0 0 0 0 0 0


------------------

Browse[1]> nn
[1] 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3
Browse[1]> Q1
[1] 3
Browse[1]> choose(Q1,nn)
[1] 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 0 0 0 0 0 0 0

--------------

The first was from RStudio, the second from RGui. (Windows x64, version 2.14.2). (That's executed from the point of view of browser() in ugly_function()). It's returning choose(x,x) as 0, instead of 1. It does not do this consistently - I've put the simplest code I've been able to use to consistently generate the problem beneath my sig.

Something about the loop seems to generate the problem. If I remove the loop over Q, and just set Q = 3, then choose(Q1,testn) (where testn is equal to the nn shown above) works without a problem.

??

(Commented out is my problematic solution, using R.basics' nChooseK on the values most likely to return anomalous results).

Shayne Hodge

# VeridianDynamics Inventory Optimization Script
# Copyright 2012 Shayne Hodge
# Two-vendor Sensitivity Analysis

#Rprof()
rm(list=ls()) # Clear previous session data
library("R.basic")
ptm <- proc.time()

ugly_function <- function(nn,k,Qone,Qtwo,f11,f12,f21,f22)­
{
partial1 <- (((1-f11)*(1-f12))^(Qone-nn))*((f11+(1-f­11)*f12)^nn)
partial2 <- (((1-f21)*(1-f22))^(Qtwo-k))* ((f21+(1-f21)*f22)^(k))
#ifelse ( ((Qone < 125)|((Qone-nn)<75)|(nn<75)), test1 <- nChooseK(Qone,nn), test1 <- choose(Qone,nn))
#ifelse ( ((Qtwo < 125)|((Qtwo-k)<75)|(k<75)), test2 <- nChooseK(Qtwo,k), test2 <- choose(Qtwo,k))
test1 <- choose(Qone,nn)
test2 <- choose(Qtwo,k)
print(test1[test1==0])
ptest <- ifelse( ((partial1 == 0) | (partial2 == 0)),0,
test1*partial1*partial2*test2)
return(ptest)
}

gen_nk_old <- function (k2,Q1,Q2)
{
nkmatrix <- matrix(nrow = sum(1:k2),ncol=2)
index <- 1
for (n in 0:min(Q1, k2-1)) # This corresponds to the outer sigma for P'
{
for (k in 0:min(Q2, k2-1-n)) # This is the inner sigma for P'
{
nkmatrix[index,1] <- n
nkmatrix[index,2] <- k
index <- index + 1
}
}
return(nkmatrix[(1:(index-1)),])
}

penalty <- 5000000
k2 <- 10

# [ f11 f12 f21 f22 falt v2on alton parton]
f <- c(0.5667, 0.8760, 0.5667, 0.7, 1, 0, 0, 1)

ci <- 1
Q <- 10
Q1 <- 3
Q2 <- Q-Q1
loopvar <- 1

nkmatrix <- gen_nk_old(k2,Q1,Q2)
testn <- nkmatrix[,1]
testk <- nkmatrix[,2]

testma <- ugly_function(testn, testk, Q1, Q2, f[1],f[2],f[3],f[4])
pprime <- sum(testma)

loopvar <- loopvar + 1

print(proc.time() - ptm)
Powered by mvnForum

Our Sponsors

People in this
Meetup are also in:

Sign up

Meetup members, Log in

By clicking "Sign up" or "Sign up using Facebook", you confirm that you accept our Terms of Service & Privacy Policy