I have the following code which performs a sensitivity analysis:
sensitivity_analysis <- function(stainless_margins, standard_margins,
df_in=all_vals_expanded){
if (length(stainless_margins) != length(standard_margins)){
stop("Error: Margin arrays must be of equal length")
}
out <- numeric(length(stainless_margins)^2)
out <- list(x=out, y=out, z=out)
i <- 1
for (stainless in stainless_margins){
df_in <- change_target(target_val=stainless, target_df=df_in,
target_shape="straight",
target_cat="Stainless - R6")
for (standard in standard_margins){
df_in <- change_target(target_val=standard, target_df=df_in,
target_shape="straight",
target_cat="Standard - R6")
out$x[i] = stainless
out$y[i] = standard
out$z[i] = sum(df_in$delta.margin.dollars)
i <- i + 1
}
}
return(as.data.frame(out))
}
Where the custom change_target function is as follows:
change_target <- function(target_val, target_df, target_shape="straight", target_cat="Standard - R6"){
target_df$proposed.best.net[target_df$categ == target_cat & target_df$shape
== target_shape] <- target_val
target_df$new.margin.dollars <-
with(target_df, cost/(1 - proposed.best.net) * (percent.of.list / 100)
/ 0.5364 - cost)
target_df$delta.margin.dollars <-
with(target_df, new.margin.dollars - old.margin.dollars)
target_df$delta.margin.percent.orig <-
with(target_df, delta.margin.dollars / old.margin.dollars)
target_df$new.list.price <-
with(target_df, cost / (1 - proposed.best.net) * (1 / 0.60))
target_df$list.paid.delta <-
with(target_df, (percent.of.list / 100) * round((new.list.price -
list.price), 0))
target_df$list.paid.delta.percent.orig <-
with(target_df,list.paid.delta / (list.price * (percent.of.list / 100)))
target_df$list.paid.delta.percent.orig[is.nan(target_df$list.paid.delta.percent.orig)] <- 0
return(target_df)
}
Is there a way to use R built-in functions, or even functions from add-on libraries, to avoid the double for-loop while still keeping the code relatively simple and readable? Further, is there a solution that would lend itself to a more generic situation, say one in which I wanted to run the sensitivity analysis with four different inputs, rather than two?
I am open to suggestions in which the change_target function must be modified, but would rather avoid this.
Related
The Lux to Lumens Calculator provides relationship between Lux, Lumens, LED Beam Angle and Distance from Surface to Light. Lux and Lumens have input fields while LED Beam Angle and Distance from Surface to Light have sliding bar to set the desired values.
I appreciate if someone can help me and explain (possibly step by step) how to use rvest to obtain either Lux or Lumen values given specified LED Beam Angle and Distance from Surface to Light values. I used rvest to crawl static data from webpages, but lack any experience doing it on webpages with dynamic input through specific form submission.
I used the following code to extract the form from the webpage but it seems this is not correct attempt:
library (rvest)
calculator_webpage <- read_html("https://www.bannerengineering.com/za/en/company/expert-insights/lux-lumens-calculator.html#")
calculator_webpage %>% html_node("form") %>% html_form()
The calculation is done client side in Javascript, specifically with these JS functions, (note the calculateLumens and calculateLux functions). This is why you don't see anything in the html itself (using rvest).
The code can be easily transposed in R like the following :
convertDegreesToRadians <- function(angleInDegrees) {
return(angleInDegrees * pi / 180)
}
calculateLux <- function(lumens, surfaceAreaToIlluminate, distanceFromSurfaceToLight, beamAngleInDegrees) {
modifier <- calculateLuxLumensModifier(surfaceAreaToIlluminate, distanceFromSurfaceToLight, beamAngleInDegrees)
return(lumens / modifier)
}
calculateLuxLumensModifier <- function(surfaceAreaToIlluminate, distanceFromSurfaceToLight, beamAngleInDegrees) {
beamAngleInRadians <- convertDegreesToRadians(beamAngleInDegrees)
modifier <- surfaceAreaToIlluminate * distanceFromSurfaceToLight^2 * 2 * pi * (1 - cos(beamAngleInRadians / 2))
return(modifier)
}
calculateLumens <- function(lux, surfaceAreaToIlluminate, distanceFromSurfaceToLight, beamAngleInDegrees) {
modifier = calculateLuxLumensModifier(surfaceAreaToIlluminate, distanceFromSurfaceToLight, beamAngleInDegrees)
return(lux * modifier)
}
getLuxFromLumens <- function(lumens, distanceFromSurfaceToLight, beamAngleInDegrees){
calLux <- calculateLux(lumens,1,distanceFromSurfaceToLight,beamAngleInDegrees)
return(round(calLux))
}
getLumensFromLux <- function(lux,distanceFromSurfaceToLight,beamAngleInDegrees){
calLumen <- calculateLumens(lux,1,distanceFromSurfaceToLight,beamAngleInDegrees)
return(round(calLumen))
}
calculateBeamWidth <- function(distanceFromSurfaceToLight, beamAngleInDegrees) {
beamAngleInRadians <- convertDegreesToRadians(beamAngleInDegrees)
return(round(2 * distanceFromSurfaceToLight * tan(beamAngleInRadians / 2), digits=2))
}
# get lux from lumens, distanceFromSurfaceToLight, beamAngleInDegrees
print(getLuxFromLumens(lumens = 1000, distanceFromSurfaceToLight= 0.1, beamAngleInDegrees=120))
# get luments from lux, distanceFromSurfaceToLight, beamAngleInDegrees
print(getLumensFromLux(lux = 1000, distanceFromSurfaceToLight= 0.1, beamAngleInDegrees=120))
# get beam width from distanceFromSurfaceToLight, beamAngleInDegrees
print(calculateBeamWidth(distanceFromSurfaceToLight = 0.1,beamAngleInDegrees = 120))
Run this example on repl.it
I've wrote this nested loop so that, in the inner loop, the code runs through the first row; then, the outer one updates the loop so as to allow the inner one to run though the second row (and so on). The data comes from 'supergerador', a matrix. "rodadas" is the row size and "n" is the column size. "vec" is the vector of interest. Thank you in advance!
Edit: i, j were initially assigned i = 1, j = 2
for(e in 1:rodadas) {
for(f in 1:(n-1)) {
if(j >= 10) {
vec[f] = min(supergerador[i, j] - supergerador[i, j - 1], 1 - supergerador[i, j])
}
else {
vec[f] = func(i, j)
}
j = j + 1
}
i = i + 1
}
func is defined as
func = function(i, j) {
minf = min(supergerador[i, j] - supergerador[i, j - 1], supergerador[i, j + 1] - supergerador[i, j])
return(minf)
}
For reference, this is what the nested loop returns. You can tell that it only went through a single row.
> vec
[1] 0.127387378 0.068119707 0.043472981 0.043472981 0.027431603 0.027431603
[7] 0.015739046 0.008010766 0.008010766
I'm not quite sure what you are intending to do here, but here is a few suggestions and code edits:
Suggestions:
If you have a for loop, use the loop-index for your subsetting (as much as plausible) and avoid additional indexes where plausible.
This avoids code clutter and unforseen errors when indices should be reset but aren't.
Avoid double subsetting variables whenever possible. Eg if you have multiple calls to x[i, j], store this in a variable and then use this variable in your result.
Single line functions are fine, but should add readability to your code. Otherwise inlining your code is optimal from an efficiency perspective.
Incorporating these into your code I beliieve you are looking for
for(i in 1:rodadas) {
for(j in 2:n) {
x1 = supergerador[i, j]
x2 = supergerador[i, j - 1]
if(j >= 10) {
vec[f] = min(x1 - x2, 1 - x1)
}
else {
vec[f] = min(x1 - x2, supergerador[i, j + 1] - x1)
}
}
}
Here i am making the assumption that you wish to loop over columns for every row up to rodadas.
Once you get a bit more familiarized with R you should look into vectorization. With a bit more knowledge of your problem, we should be very easily able to vectorize your second for loop, removing your if statement and performing the calculation in 1 fast sweep. But until then this is a good place to start your programming experience and having a strong understanding of for-loops is vital in any language.
I'm doing a sequence analysis on a large data sample. What I want to do is to rewrite my old Stata code in R, so that all of my analysis is performed in one single environment.
However, I would also like to improve it a little bit - the code is pretty long, and I would like to rewrite it using loops, so that it becomes more readable. Unfortunately my loop-writing skills are questionable.
1st loop [I think it needs to include an if statement]
I would like to write a loop for the following commands:
dt$dur.ofA1 <-(dt$M2_3R_A_1 - dt$M2_2R_A_1)
dt$dur.ofB1<-(dt$M2_3R_B_1 - dt$M2_2R_B_1)
dt$dur.ofC1<-(dt$M2_3R_C_1 - dt$M2_2R_C_1)
dt$dur.ofD1<-(dt$M2_3R_D_1 - dt$M2_2R_D_1)
dt$dur.ofE1<-(dt$M2_3R_E_1 - dt$M2_2R_E_1)
dt$dur.ofF1<-(dt$M2_3R_F_1 - dt$M2_2R_F_1)
dt$dur.ofG1<-(dt$M2_3R_G_1 - dt$M2_2R_G_1)
dt$dur.ofH1<-(dt$M2_3R_H_1 - dt$M2_2R_H_1)
dt$dur.ofA2<-(dt$M2_3R_A_2 - dt$M2_2R_A_2)
dt$dur.ofB2<-(dt$M2_3R_B_2 - dt$M2_2R_B_2)
dt$dur.ofC2<-(dt$M2_3R_C_2 - dt$M2_2R_C_2)
dt$dur.ofD2<-(dt$M2_3R_D_2 - dt$M2_2R_D_2)
dt$dur.ofE2<-(dt$M2_3R_E_2 - dt$M2_2R_E_2)
dt$dur.ofF2<-(dt$M2_3R_F_2 - dt$M2_2R_F_2)
dt$dur.ofG2<-(dt$M2_3R_G_2 - dt$M2_2R_G_2)
dt$dur.ofH2<-(dt$M2_3R_H_2 - dt$M2_2R_H_2)
dt$dur.ofA3<-(dt$M2_3R_A_3 - dt$M2_2R_A_3)
dt$dur.ofB3<-(dt$M2_3R_B_3 - dt$M2_2R_B_3)
dt$dur.ofC3<-(dt$M2_3R_C_3 - dt$M2_2R_C_3)
dt$dur.ofD3<-(dt$M2_3R_D_3 - dt$M2_2R_D_3)
dt$dur.ofE3<-(dt$M2_3R_E_3 - dt$M2_2R_E_3)
dt$dur.ofF3<-(dt$M2_3R_F_3 - dt$M2_2R_F_3)
dt$dur.ofG3<-(dt$M2_3R_G_3 - dt$M2_2R_G_3)
dt$dur.ofH3<-(dt$M2_3R_H_3 - dt$M2_2R_H_3)
My attempt:
db1 <- paste(rep("M2_", 24), "2R_", rep(LETTERS[seq( from = 1, to = 8)],3), "_",
rep(seq(from=1, to =3), 8),
sep = "")
db2 <- paste(rep("M2_", 24), "3R_", rep(LETTERS[seq( from = 1, to = 8)],3), "_",
rep(seq(from=1, to =3), 8),
sep = "")
dur <- paste(rep("dur.of", 24), rep(LETTERS[seq( from = 1, to = 8)],3),
rep(seq(from=1, to =3), 8),
sep = "")
dur <- as.list(dur)
for(e in dur){
for (j in db1){
for (i in db2){
{
dt[,e] <- dt[,i] - dt[,j]
}
I think the loop needs an if statement in the middle, so that it stops at a single item (subtracts A1 from A1, A2 from A2 etc.) from the list.
2) The second case is a little bit more complicated, but essentially it is the same case as described above:
The M2_2R_A_1 (start) M2_3R_A_1 (finish) indicate the yearly dates in which an educational activity took place. I would like to generate 1948:2013 variables that indicate that an activity took place in a particular year (stedu==x). A part of my Stata code is as follows (it goes on like that up to 2013):
recode stedu1948(0=2) if M2_2R_A_1<=1948 & 1948<= M2_3R_A_1 | M2_2R_A_2<=1948 & 1948<= M2_3R_A_2 | M2_2R_A_3<=1948 & 1948<= M2_3R_A_3
recode stedu1949(0=2) if M2_2R_A_1<=1949 & 1949<= M2_3R_A_1 | M2_2R_A_2<=1949 & 1949<= M2_3R_A_2 | M2_2R_A_3<=1949 & 1949<= M2_3R_A_3
recode stedu1950(0=2) if M2_2R_A_1<=1950 & 1950<= M2_3R_A_1 | M2_2R_A_2<=1950 & 1950<= M2_3R_A_2 | M2_2R_A_3<=1950 & 1950<= M2_3R_A_3
So in order to write a loop I would also need to include some conditions in order to stop the loop at a given point.
For your first item, use #thelatemail's suggestion. For second item, consider the following for loop using the ifelse() function:
for (i in 1948:2013) {
dt[[paste0("stedu", i)]] <- ifelse((dt$M2_2R_A_1 <= i & dt$M2_3R_A_1 >= i) OR
(dt$M2_2R_A_2 <= i & dt$M2_3R_A_2 >= i) OR
(dt$M2_2R_A_3 <= i & dt$M2_3R_A_3 >= i),
2,
dt[[paste0("stedu", i)]]
}
I am a beginner in R. Here's the formula I'm trying to code to find the lambda that maximizes the log likelihood of some bigrams. When the bigrams are not found, the P_b (bigram) function fails, but the P_u (unigram) function should provide the unigram result (lambda = 0).
It works for bigrams that are found. When they're not found, tho, I only get numeric(0), not the unigram result.
p.mix <- function(w2, w1) {
(1-lambda) * uni.dfrm$prob[uni.dfrm$token==w2] + lambda * p.bi(w2,w1)
}
The p.bi() function looks complicated because of the indexing so I'm reluctant to post it but it does work when the bigrams are found. It just looks up the count of times w' appears after w and divides it by the times w appears, but I have to go through another vector of vocabulary words so it looks ugly.
When w' is never found occurring after w, instead of a zero count, there's no row at all, which is what apparently causes the numeric(0) result. That's what the mixed model is supposed to solve, but I can't get it to work. Any ideas how this can work?
You can add a test for the case where w2 is numeric(0) for example :
p.mix <- function(w2, w1) {
if(length(w2)>0){
res <- (1-lambda) * uni.dfrm$prob[uni.dfrm$token==w2] +
lambda * p.bi(w2,w1)
}else res <- 0
res
}
EDIT
p.mix <- function(w2, w1) {
if(length(w2) && length(uni.dfrm$prob[uni.dfrm$token==w2]) > 0)
(1-lambda) * uni.dfrm$prob[uni.dfrm$token==w2] + lambda * p.bi(w2,w1)
else 0
}
Please can anyone advise how I can turn the following statement into one that will do the same thing but NOT using ifelse please?
<-ifelse(y>=50, 0.2*x+0.8*y, ifelse(y<50 & x>70, y+10, ifelse(y<50 & x<70, y)))
x=80
y=60
So I the final code should give an answer of 64 - selecting the first condition. I will then test it to ensure the other 3 conditions give the correct result for varying values of x and y
Thanks a lot.
This should work:
finalmark <- (x * 0.2 + y * 0.8) * (y >= 50) + (y + 10 * (x > 70)) * (y < 50)
Something like this?
if(y>=50){
0.2*x+0.8*y
}else{
if(y<50 & x>70){
y+10
}else{
if(y<50 & x<70){
y
}else{
"OMG I did not expect this scenario"
}
}
}
try: y=45; x=70 to see why I have the last condition.
If y is a number then, once you've tested for y > = 50 then y must be less than 50 so don't keep testing for that. Similarly, once you've found x > 70 then you don't need the last ifelse. You don't have a return for x = 70. My guess is that you want to test for a <= or >= situation there.
ifelse(y>=50, 0.2*x+0.8*y, ifelse(x>70, y+10, y))
in scalar that's
if(y >= 50){
0.2*x+0.8*y
}else if(x > 70){
y+10
}else y
Given you seem to be having a hard time in general writing the logic I suggest you post a more complete question. It's possible (probable) that you're doing something here that you really don't want to do.
There are several approaches you can take. Below are a few examples of building a function 'f', so that 'f(x,y)' meets your criteria listed in the question using logic other than 'ifelse' statements.
Note: I'm also adding in one amendment to the original post, since 'x=70' would break the logic. I'm adding 'x>=70' to the second criterion.
Option 1: Use a standard 'if / else if / else' logic block. Personally, I like this option, because it's easily readable.
f <- function(x, y){
if (y>= 50){
return(0.2*x+0.8*y)
} else if (y < 50 & x >= 70){
return(y+10)
} else {
return(y)
}
}
Option 2: Combine your two logical tests (there are really only two) into a string, and use a switch. Note that the final and unnamed option is treated as an 'else'.
f <- function(x, y){
return(
switch(paste(x >= 70, y >= 50, sep=""),
TRUEFALSE = y + 10,
FALSEFALSE = y,
0.2*x+0.8*y
)
)
}
Option 3: Order your 'if' statements to reduce logical comparisons. This is the sort of thing to do if you have a large data set or very limited memory. This is slightly harder to troubleshoot, since you have to read the whole block to fully understand it. Option 1 is better if you don't have memory or cycle limitations.
f <- function(x, y){
if (y >= 50){
return(0.2*x+0.8*y)
} else {
if (x >=70){
return(y+10)
} else {
return(y)
}
}
}
There are other options, but these are the simplest that come readily to mind.