I've looked at several questions like this on SO and still cannot resolve it. But I'm looking to add a constraint where the change in volume (New Volume / Old Volume - 1 >= -10%) cannot be less than -10%.
Example
Customer
Old_volume
Elasticity
Price
X
100
-0.68
15.00
#example dataset
df <- data.frame(customer = c("X"),
old_volume = c(100),
elasticity = c(-0.68),
price = c(15.00))
#function
f3 <- function(x) {
new_vol = 100 * (1+(-0.68 * x))
new_rev = new_vol * (15.00 * (1+x))
new_cost = new_vol * 11.25
return(new_rev - new_cost) }
n_vol <- function(x) {
new_vol = 100 * (1+(-0.68 * x))
return(new_vol) }
#example run function
f3(0.25)
>>>[1] 622.5
#running the optimization
res <- optimize(f3, lower=0, upper=10, maximum = TRUE)
res$maximum
>>>0.6102941
res$objective
>>>[1] 754.9081
n_vol(0.6102941)
>>> 58.5
Therefore vol change % = 58.5/100-1 = -0.415, however I want to limit this to -0.1.
Now I want to add in a constraint where new_vol/old_vol-1 >= -0.1. However, I'm not sure how to add this in using Optimize(), optim() or lpsolve(). I was reading through the lpsolve() documentation and it seemed like the way to go, but I am confused as to what my vector of coefficients would be in the objective.in. Also looking at other packages like constrOptim, it seemed too complex for something one dimensional.
Thanks
As an example, normally on Excel, I would have a bunch of columns with these calculations and run solver with the constraint of volume change >= -0.1. However running a macro takes too long with rows > 1,000
EDIT: Added input example
You can calculate your new boundary algebraically.
change_inv <- function(frac, oldvol = 100) { oldvol * (1 + frac) }
n_vol_inv <- function(vol) { (vol / 100 - 1) / -0.68 }
n_vol_inv(vol = change_inv(frac = -0.1))
# [1] 0.1470588
max_x <- optimize(f3,
lower = 0,
upper = n_vol_inv(vol = change_inv(-0.1)),
maximum = TRUE)
max_x
# $maximum
# [1] 0.1469922
#
# $objective
# [1] 535.9664
n_vol(max_x$maximum) / 100 - 1
# [1] -0.09995469
Unfortunately, this means that the maximum is just the boundary.
Related
The code below estimates pi in R, now I am trying to find the minimum number of terms N_Min
you would have to include in your estimate of pie to make it accurate to three decimal places.
pi_Est<- function(NTerms){
NTerms = 5 # start with an estimate of just five terms
pi_Est = 0 # initialise the value of pi to zero
Sum_i = NA # initialise the summation variable to null
for(ii in 1:NTerms)
{
Sum_i[ii] = (-1)^(ii+1)/(2*ii - 1) # this is the series equation for calculating pi
}
Sum_i = 4*Sum_i # multiply by four as required in the formula (see lecture notes)
pi_Est = sum(Sum_i)
cat('\nThe estimate of pi with terms = ', NTerms ,' is ',pi_Est)
}
First of all, I would change some things about your function. Instead of getting it to print out a message, get it to return a value. Otherwise it becomes very difficult to do anything with its output, including testing it for convergence to pi.
Also, no matter what the value of NTerms is you feed this function, you are immediately over-writing NTerms inside the function.
You could rewrite the function like this:
pi_Est <- function(NTerms) {
pi_Est <- 0
Sum_i <- numeric()
for(ii in seq(NTerms))
{
Sum_i[ii] <- (-1)^(ii+1)/(2*ii - 1)
}
return(sum(4 * Sum_i))
}
And to show it converges to pi, let's test it with 50,000 terms:
pi_Est(50000)
#> [1] 3.141573
Now, if we want to find the first value of NTerms that is correct to 3 decimal places, we are going to need to be able to call this function on a vector of NTerms - at the moment it is only working on a single number. So let's define the function f that vectorizes pi_Est:
f <- Vectorize(pi_Est)
Now, let's create the estimate for all values of NTerms between 1 and 2,000 and store them in a vector:
estimates <- f(1:2000)
We can see that the values of estimates seem to oscillate round and converge to pi if we plot the first 100 values:
plot(estimates[1:100], type = 'l')
abline(h = pi)
Our answer is just the first value which, when rounded to three decimal places, is the same as pi rounded to three decimal places:
result <- which(round(estimates, 3) == round(pi, 3))[1]
result
#> [1] 1103
And we can check this is correct by feeding 1103 into our original function:
pi_Est(result)
#> [1] 3.142499
You will see that this gives us 3.142, which is the same as pi rounded to 3 decimal places.
Created on 2022-01-31 by the reprex package (v2.0.1)
1000 terms are required to make the estimate accurate to within 0.001:
pi_Est1 <- function(n) {
if (n == 0) return(0)
neg <- 1/seq(3, 2*n + 1, 4)
if (n%%2) neg[length(neg)] <- 0
4*sum(1/seq(1, 2*n, 4) - neg)
}
pi_Est2 <- function(tol) {
for (i in ceiling(1/tol + 0.5):0) {
est <- pi_Est1(i)
if (abs(est - pi) > tol) break
est1 <- est
}
list(NTerms = i + 1, Estimate = est1)
}
tol <- 1e-3
pi_Est2(tol)
#> $NTerms
#> [1] 1000
#>
#> $Estimate
#> [1] 3.140593
tol - abs(pi - pi_Est2(tol)$Estimate)
#> [1] 2.500001e-10
tol - abs(pi - pi_Est1(pi_Est2(tol)$NTerms - 1))
#> [1] -1.00075e-06
Created on 2022-01-31 by the reprex package (v2.0.1)
Perhaps we can try the code below
pi_Est <- function(digits = 3) {
s <- 0
ii <- 1
repeat {
s <- s + 4 * (-1)^(ii + 1) / (2 * ii - 1)
if (round(s, digits) == round(pi, digits)) break
ii <- ii + 1
}
list(est = s, iter = ii)
}
and you will see
> pi_Est()
$est
[1] 3.142499
$iter
[1] 1103
> pi_Est(5)
$est
[1] 3.141585
$iter
[1] 130658
Why not use a single line of code for the calculation?
Pi <- tail(cumsum(4*(1/seq(1,4*50000000,2))*rep(c(1,-1), 50000000)),1)
LCI.materials <- read.csv('LCImaterials.csv')
LCA.bridge <- function(length, width, height, thickness, girder.Option, deck.Option, materials) {
prefab.girder.Section <- 0.78
steel.girders.unitWeight <- 317 #the weight for HEM800 steel profile
asphalt.Q <- length * width * thickness
materials.split <- split(materials, materials$scope)
# calculate the volume of the deck based on different materials strategies
if(deck.Option == "RC") {
deck.volume <- length * width * height
interventions.deck <- 2.5
} else if (deck.Option == "PRC") {
deck.volume <- 0.5 * length * width * height
interventions.deck <- 2
} else if (deck.Option == "FRP") {
deck.volume <- 0.2 * length * width * height
interventions.deck <- 1
}
#girder options
if (girder.Option == "PRC") {
#get the numbers of girders
n <-round(width / 3.75, 0)
interventions.girders <- 2
#get the volume of the concrete for the prefab girders
girders.V <- n * prefab.girder.Section * length
} else if (girder.Option == "steel") {
n <- round(width / 3, 0)
girders.V <- n * steel.girders.unitWeight * length
interventions.girders <- 2
} else if (girder.Option == "none") {
n <- 0
girders.V <- 0
interventions.girders <- 0
}
asphalt <- mutate(materials.split$asphalt, bridge.Q = asphalt.Q, interventions = 12)
deck <- mutate(materials.split[[deck.Option]], bridge.Q = deck.volume, interventions = interventions.deck)
if (!is.null(materials.split[[girder.Option]])) {
girders <- mutate(materials.split[[girder.Option]], bridge.Q = girders.V, interventions = interventions.girders)
LCA.matrix <- rbind(deck, girders, asphalt)
} else {
LCA.matrix <- rbind(deck, asphalt)
}
LCA.matrix <- mutate(LCA.matrix, TotalMaterials.Q = **strong text**quantities * bridge.Q / 1000,
materials.LC = TotalMaterials.Q * interventions,
Energy.LC = materials.LC * energy,
CO2.LC = materials.LC * CO2 * 1000,
NOx.LC = materials.LC * NOx * 1000,
SO2.LC = materials.LC * SO2 * 1000)
LCA.results <- list(Energy = sum(LCA.matrix$Energy.LC),
CO2 = sum(LCA.matrix$CO2.LC),
NOx = sum(LCA.matrix$NOx.LC),
SO2 = sum(LCA.matrix$SO2.LC))
return(LCA.results)
}
b.length <- 16 # units: m
b.width <- 15 #units m
bd.depth <- 0.25 #units m
asphalt.tk <- 0.12 #units m
girder.Options <- c("PRC", "steel", "none")
deck.options <- c("RC", "PRC", "FRP")
Option1 <- LCA.bridge(b.length, b.width, bd.depth, asphalt.tk, girder.Options[1], deck.options[1], LCI.materials)
Hello people. This R function is completely working without any problem. It is reading a small table from excel. I am asking this. How can this function understand and read the quantities column well? I made it bold. I am doing a similar thing to this function but I am always getting an error:
Error in LCA.bridge(b.length, b.width, b.height, b.thickness, column.Options1, :
'quantities' can not be found
Here is my small table.
I want to understand how the first code can recognize/understand/find the "quantities" from small table? How can we read a column from a CSV file in R by using dplyr and mutate? Could you please explain to me? Thanks in advance.
LCA.matrix <- c(LCA.matrix |
mutate(TotalMaterials.Q = quantities * bridge.Q / 1000) |
mutate(materials.LC = TotalMaterials.Q * interventions) |
mutate(Energy.LC = materials.LC*energy) |
mutate(CO2.LC = materials.LC*CO2*1000) |
mutate(NOx.LC = materials.LC*NOx*1000) |
mutate(SO2.LC = materials.LC*SO2*1000))
Thanks for the idea, I deleted the previous one and tried to add this.But still bridge.Q can not be found. I could not understand the problem.
The first line of your code reads the .csv file and transfer it to data.frame object named LCI.materials:
LCI.materials <- read.csv('LCImaterials.csv')
For testing ppurposes I have created such file with 2 lines and loaded it. If we would like to see what's inside, head() function helps:
head(LCI.materials)
material scope quantities energy CO2 NOx SO2
1 Brick brick 1 3.56 0.271 0.050 0.100
2 Cement RC 167 3.26 0.822 0.177 0.065
As you see, the columns corresponds to these, you have in .csv file, including quantities.
The last parameter of LCA.bridge function is named materials, and when you call this function in the last line of your code:
Option1 <- LCA.bridge(b.length, b.width, bd.depth, asphalt.tk, girder.Options[1], deck.options[1], LCI.materials)
you substitute materials with the LCI.materials data frame. Internally, the functions splits the LCI.materials by the scope:
materials.split <- split(materials, materials$scope)
There is another observation: your LCA.bridge function looks for asphalt in the materials data frame:
asphalt <-
mutate(materials.split$asphalt,
bridge.Q = asphalt.Q,
interventions = 12)
However in your example (in small table) there is no such material. Might that be an issue?
Grzegorz
it was useful but there is another problem with mutate
Not sure what you would like to achieve in this part:
LCA.matrix <- c(LCA.matrix, TotalMaterials.Q = quantities * bridge.Q / 1000,
materials.LC = TotalMaterials.Q * interventions,
Energy.LC = materials.LC * energy,
CO2.LC = materials.LC * CO2 * 1000,
NOx.LC = materials.LC * NOx * 1000,
SO2.LC = materials.LC * SO2 * 1000)
If the intention is to calculate additional columns like TotalMaterials.Q etc, then use mutate:
LCA.matrix <- LCA.matrix |>
mutate(TotalMaterials.Q = quantities * bridge.Q / 1000) |>
mutate(materials.LC = TotalMaterials.Q * interventions)
[...]
Regards,
Grzegorz
LCA.matrix <- LCA.matrix |>
mutate(TotalMaterials.Q = quantities * bridge.Q / 1000) |>
mutate(materials.LC = TotalMaterials.Q * interventions) |>
mutate(Energy.LC = energy ) |>
mutate(CO2.LC = CO2 * 1000) |>
mutate(NOx.LC = NOx*1000) |>
mutate(SO2.LC = SO2*1000)
should do the trick
I'm trying to write a piece of optimization code in R to calculate a set of unknown values for a biological question concerning drosophila flies.
The dataframe is composed of 13 columns (just showing 9 in code below for clarity) with varying numbers of rows. The first three columns contain collected data and the rest of the columns are calculated using various formulas. Two of the columns, Missing_C and Missing_D are initially populated with empty data and in the optimization problem represent the initial values.
Time.min. Prob_C Prob_D Miss_C Miss_D Event_C Event_D Risk_C Risk_D
1 0 1.00 1.00 0 0 0.00 0.00 86.00 78.00
2 5 0.98 0.97 0 0 1.93 1.98 84.07 76.02
3 16 0.84 0.95 0 0 10.67 1.90 73.40 74.12
4 17 0.50 0.75 0 0 21.02 12.85 52.38 61.27
5 20 0.30 0.50 0 0 14.97 15.32 37.42 45.95
As an example of the some of the formulas used, Event_C and Risk_C are calculated with a for loop as follows:
#define values for events_c and risk_c with for loops`
temp_events_c <-vector()
temp_risk_c <-vector()
for (i in 2:no_rows) {
temp_events_c <- ((prob_c[i] * risk_c[i-1]) - (prob_c[i] * miss_c[i-1]) - (prob_c[i-1] * risk_c[i-1]) + (prob_c[i-1] * miss_c[i-1])) / (prob_c[i] - (2 * prob_c[i-1]))
events_c[i] <- temp_events_c
temp_risk_c <- risk_c[i-1] - miss_c[i-1] - events_c[i]
risk_c[i] <- temp_risk_c
}
From this data, I also have a single, collected, value (9.1 in this instance) which relates to the values in the table. The following function defines the relationship to this value to columns Event_C, Event_D and two columns not shown in the above, Expected_C and Expected_D where the sums of those columns are represented by x[1], x[2], x[3], x[4]:
fn <- function(x) ((x[1]-x[2])^2)/x[2] + ((x[3]-x[4])^2)/x[4]
I then would like to use a minimization algorithm i.e. slsqp from nloptr to calculate the values in the Miss_C and Miss_D which ultimately satisfy this single value. The extra code for the optimization would be something like this:
x0 <- c(Miss_C,Miss_D)
heq <- function(x) (((x[1]-x[2])^2)/x[2] + ((x[3]-x[4])^2)/x[4]) - 9.1 # heq == 0
slsqp(x0, fn, gr = NULL,
hin = NULL, heq = heq)
Obviously, that doesn't work as the initial values are not directly contained within the function that needs to be solved and that is the point I am stuck at! I'm not sure if this is an optimization problem as such or more of a general R coding question - either way, any help would be much appreciated.
Cheers, Andrew
* Edit - complete code added as per request *
#input variables
time_vector <- c(0,5,16,17,20)
prob_c <- c(1,0.977,0.835,0.5,0.30)
prob_d <- c(1,0.974,0.949,0.75,0.50)
miss_c <- c(0,0,0,0,0)
miss_d <- c(0,0,0,0,0)
#get number of rows
no_rows <- length(time_vector)
#fill events columns with dummy data
events_c <- c(0:(no_rows - 1))
events_d <- c(0:(no_rows - 1))
#define starting number at risk
risk_c_t0 <- 86
risk_d_t0 <- 78
#add t0 risk to each column
risk_c <- risk_c_t0
risk_d <-risk_d_t0
#fill risk columns with dummy data
risk_c[2:no_rows] <- c(2:no_rows)
risk_d[2:no_rows] <- c(2:no_rows)
#re-define values for events_c and risk_c with for loops
temp_events_c <-vector()
temp_risk_c <-vector()
for (i in 2:no_rows) {
temp_events_c <- ((prob_c[i] * risk_c[i-1]) - (prob_c[i] * miss_c[i-1]) - (prob_c[i-1] * risk_c[i-1]) + (prob_c[i-1] * miss_c[i-1])) / (prob_c[i] - (2 * prob_c[i-1]))
events_c[i] <- temp_events_c
temp_risk_c <- risk_c[i-1] - miss_c[i-1] - events_c[i]
risk_c[i] <- temp_risk_c
}
#re-define values for events_t with for loops
temp_events_d <-vector()
temp_risk_d <-vector()
for (j in 2:no_rows) {
temp_events_d <- ((prob_d[j] * risk_d[j-1]) - (prob_d[j] * miss_d[j-1]) - (prob_d[j-1] * risk_d[j-1]) + (prob_d[j-1] * miss_d[j-1])) / (prob_d[j] - (2 * prob_d[j-1]))
events_d[j] <- temp_events_d
temp_risk_d <- risk_d[j-1] - miss_d[j-1] - events_d[j]
risk_d[j] <- temp_risk_d
}
#calculate total risk, events and expected
total_risk <- risk_c + risk_d
total_events <- events_c + events_d
expected_c <- (risk_c * (total_events/total_risk))
expected_d <- (risk_d * (total_events/total_risk))
#place values into dataframe
df1 <- data.frame(time_vector,prob_c,prob_d, miss_c, miss_d, events_c, events_d, risk_c, risk_d, total_risk, total_events, expected_c, expected_d)
#sum of values
sum_events_C <- sum(events_c)
sum_events_d <- sum(events_d)
sum_expected_c <- sum(expected_c)
sum_expected_d <- sum(expected_d)
#chi_sq formula
chi_sq_combo <- (((sum_events_C - sum_expected_c)^2)/sum_expected_c) + (((sum_events_d - sum_expected_d)^2)/sum_expected_d)
#### end of table calculations before sim
#x <- c(sum_events_C, sum_expected_c, sum_events_d, sum_expected_d)
#x0 <- c(miss_c,miss_d) #inital values
#fn <- function(x) ((x[1]-x[2])^2)/x[2] + ((x[3]-x[4])^2)/x[4]
#heq <- function(x) (((x[1]-x[2])^2)/x[2] + ((x[3]-x[4])^2)/x[4]) - 6.5 # heq == 0
#slsqp(x0, fn, gr = NULL,
# hin = NULL, heq = heq)
Rephrasing the comments above, I believe the problem is to use optimization to find
two values which yield a target chi-square value. A complication which may cause problems is that there are likely many solutions that yield the target, so it might be necessary to add some other requirement to make the answer unique.
To do this, you need a function of two variables which calculates the square of the difference between the chi-square value using those variables and the target value, and then you minimize that.
For example,
fn2 <- function(x) {
c <- x[1]
d <- x[2]
chisq <- (((c - sum_expected_c)^2)/sum_expected_c) +
(((d - sum_expected_d)^2)/sum_expected_d)
(chisq - 6.5)^2
}
for (i in 1:no_rows) {
x0 <- c(df1$miss_c[i],df1$miss_d[i]) #initial values
res <- nloptr::slsqp(x0, fn2)
miss_c[i] <- res$par[1]
miss_d[i] <- res$par[2]
}
This gives the same values all 5 times, so I might not have understood you completely.
I have a vector as below
data <- c("6X75ML","24X37.5ML(KKK)", "6X2X75ML", "168X5CL (UUU)", "168X5CLKK (BUU)")
The above data is basically pack sizes of bottles in a case. What it means is in case of "6X75ML" there are 6 bottles of 75CL (Centi liters) liquid each. For "6X2X75ML" which is basically a promotion pack has 6X2 = 12 bottles of 75ML (Milli liters) in a case.
I need to find the volume in liters available in each case:
e.g -
"6X75ML" should be (6 * 75 * 0.001) = 0.45 Liters
"24X37.5ML(KKK)" should be (6 * 37.5 * 0.001) = 0.9 Liters
"6X2X75ML" should be (6 * 2 * 75 * 0.001) = 0.9 Liters
[there can only be a maximum of 3 digits between the X]
Conversions:
ML - Milli liters
CL - Centi liters
LTR - Liters
1ML = 0.001LTR
1CL = 0.01LTR
In some cases as in the above there could be values like "168X5CLKK (BUU)" where only CL needs to be taken.
I have the below code helping me to find the quantity of bottles in a case
dataList <- strsplit(data, split="X")
Pack <- sapply(dataList, function(x) prod(as.numeric(head(x, -1))))
eg. "6X2X75ML" ll give 12; "168X5CL (UUU)" ll give 168 etc
Working:
strplit breaks up the vector along "X". The resulting list is fed to sapply which the performs an operation on all but the final element of each vector in the list. The operation is to transform the elements into numeric s and the multiply them. The final element is dropped using head(x, -1).
I am not able to find a way around the an efficient way to split the last element to get the volume.
data <- c("6X75ML","24X37.5ML(KKK)", "6X2X75ML", "168X5CL (UUU)", "168X5CLKK (BUU)")
Replace ML with X0.001
data <- gsub("ML", "X0.001", data)
Replace CL with X0.01
data <- gsub("CL", "X0.01", data)
split the string and do the multiplication
unlist(lapply(strsplit(gsub("[A-Z() ]*$", "", data), "X"), function(x){ prod(as.numeric(x))}))
Output:
[1] 0.45 0.90 0.90 8.40 8.40
Sathish solution is straightforward.
If you would require to extract and store the volume and number of bottles, you could also use this code:
# Data
data <- c("6X75ML","24X37.5ML(KKK)", "6X2X75ML", "168X5CL (UUU)", "168X5CLKK (BUU)")
# (1) Calculate volume per unit/bottle
# ------------
# Get volume measurement:
# Extract bottle volume and define conversion factor
bottle.volumes.units <- substr(sub(".*X[0-9,.]+", "", data), 0, 2)
bottle.volumes.in.liter <- gsub("ML", 0.001, bottle.volumes.units)
bottle.volumes.in.liter <- gsub("CL", 0.01, bottle.volumes.in.liter)
# Get volume per bottle
# All numbers in every vector
all.numbers <- regmatches(data, gregexpr('\\(?[0-9,.]+', data))
# The volume information for each bottle
bottle.volumes <- as.numeric(unlist(lapply(all.numbers, last)))
# Harmonize volume measuremet to "liters"
bottle.volumes.in.liters <- as.numeric(bottle.volumes.in.liter) * bottle.volumes
# (2) Get the number of units/bottles
# ------------
number.of.bottles.temp <- lapply(all.numbers, function(x)as.numeric(setdiff(x, as.list(bottle.volumes))))
number.of.bottles <- sapply(number.of.bottles.temp, prod)
# (3) Calculate volume
# ------------
number.of.bottles * bottle.volumes.in.liters
# [1] 0.45 0.90 0.90 8.40 8.40
I am using the following R code, taken from a published paper (citation below). This is the code:
int2=function(x,r,n,p) {
(1+x)^((n-1-p)/2)*(1+(1-r^2)*x)^(-(n-1)/2)*x^(-3/2)*exp(-n/(2*x))}
integrate(f=int2,lower=0,upper=Inf,n=530,r=sqrt(.245),p=3, stop.on.error=FALSE)
When I run it, I get the error "non-finite function value". Yet Maple is able to compute this as 4.046018765*10^27.
I tried using "integral" in package pracma, which gives me a different error:
Error in if (delta < tol) break : missing value where TRUE/FALSE needed
The overall goal is to compute a ratio of two integrals, as described in Wetzels & Wagenmakers (2012) "A default Bayesian hypothesis test for correlations" (http://www.ncbi.nlm.nih.gov/pmc/articles/PMC3505519/). The entire function is as follows:
jzs.pcorbf = function(r0, r1, p0, p1, n) {
int = function(r,n,p,g) {
(1+g)^((n-1-p)/2)*(1+(1-r^2)*g)^(-(n-1)/2)*g^(-3/2)*exp(-n/(2*g))};
bf10=integrate(int, lower=0,upper=Inf,r=r1,p=p1,n=n)$value/
integrate(int,lower=0,upper=Inf,r=r0,p=p0,n=n)$value;
return(bf10)
}
Thanks!
The issue is that your integral function is generating NaN values when called with x values in its domain. You're integrating from 0 to Infinity, so let's check a valid x value of 1000:
int2(1000, sqrt(0.245), 530, 3)
# [1] NaN
Your objective multiplies four pieces:
x <- 1000
r <- sqrt(0.245)
n <- 530
p <- 3
(1+x)^((n-1-p)/2)
# [1] Inf
(1+(1-r^2)*x)^(-(n-1)/2)
# [1] 0
x^(-3/2)
# [1] 3.162278e-05
exp(-n/(2*x))
# [1] 0.7672059
We can now see that the issue is that you're multiplying infinity by 0 (or rather something numerically equal to infinity times something numerically equal to 0), which is causing the numerical issues. Instead of calculating a*b*c*d, it will be more stable to calculate exp(log(a) + log(b) + log(c) + log(d)) (using the identity that log(a*b*c*d) = log(a)+log(b)+log(c)+log(d)). One other quick note -- the value x=0 needs a special case.
int3 = function(x, r, n, p) {
loga <- ((n-1-p)/2) * log(1+x)
logb <- (-(n-1)/2) * log(1+(1-r^2)*x)
logc <- -3/2 * log(x)
logd <- -n/(2*x)
return(ifelse(x == 0, 0, exp(loga + logb + logc + logd)))
}
integrate(f=int3,lower=0,upper=Inf,n=530,r=sqrt(.245),p=3, stop.on.error=FALSE)
# 1.553185e+27 with absolute error < 2.6e+18