|
| 1 | +#help: Random sampling |
| 2 | +#tags: uncertainties |
| 3 | +#options: sample_size='100'; seed='1'; model[x]='{"x":"Unif(0,1)"}' |
| 4 | +#require: jsonlite |
| 5 | +#input: x=list(min=0,max=1) |
| 6 | +#output: y=0.99 |
| 7 | + |
| 8 | +#' constructor and initializer of R session |
| 9 | +RandomSampling <- function(opts) { |
| 10 | + randomsampling = new.env() |
| 11 | + |
| 12 | + randomsampling$sample_size <- as.integer(opts$sample_size) |
| 13 | + randomsampling$seed <- as.integer(opts$seed) |
| 14 | + if (is.list(opts[['model[x]']])) |
| 15 | + randomsampling[['model[x]']] <- opts[['model[x]']] |
| 16 | + else |
| 17 | + randomsampling[['model[x]']] <- jsonlite::fromJSON(opts[['model[x]']]) |
| 18 | + |
| 19 | + return(randomsampling) |
| 20 | +} |
| 21 | + |
| 22 | +#' first design building. All variables are set in [min,max] |
| 23 | +#' @param input variables description (min/max, properties, ...) |
| 24 | +#' @param output values of interest description |
| 25 | +getInitialDesign <- function(algorithm,input,output) { |
| 26 | + algorithm$output = output |
| 27 | + algorithm$i = 0 |
| 28 | + set.seed(algorithm$seed) |
| 29 | + X = NULL |
| 30 | + for (x in names(algorithm[['model[x]']])) { |
| 31 | + mx = unlist(strsplit(algorithm[['model[x]']][[x]],"::")) # supports evd::GEV(...) |
| 32 | + if (length(mx)>1) { |
| 33 | + library(mx[1]) |
| 34 | + mx = mx[-1] |
| 35 | + } |
| 36 | + X = cbind(X,eval(parse( |
| 37 | + text=paste0("r", |
| 38 | + gsub( "(", |
| 39 | + paste0("(",algorithm$sample_size,","), |
| 40 | + tolower(mx), fixed=T |
| 41 | + ) |
| 42 | + )) |
| 43 | + )) |
| 44 | + } |
| 45 | + names(X) <- names(algorithm[['model[x]']]) |
| 46 | + return(X) |
| 47 | +} |
| 48 | + |
| 49 | +#' iterated design building. |
| 50 | +#' @param X data frame of current doe variables |
| 51 | +#' @param Y data frame of current results |
| 52 | +#' @return data frame or matrix of next doe step |
| 53 | +getNextDesign <- function(algorithm,X,Y) { |
| 54 | + return(NULL) |
| 55 | +} |
| 56 | + |
| 57 | +#' final analysis. Return HTML string |
| 58 | +#' @param X data frame of doe variables |
| 59 | +#' @param Y data frame of results |
| 60 | +#' @return HTML string of analysis |
| 61 | +displayResults <- function(algorithm,X,Y) { |
| 62 | + Y = Y[,1] |
| 63 | + |
| 64 | + algorithm$files <- paste0("hist_",algorithm$i-1,".png",sep="") |
| 65 | + png(file=algorithm$files,bg="transparent",height=600,width = 600) |
| 66 | + hist(Y,xlab=algorithm$output, main=paste("Histogram of" , algorithm$output)) |
| 67 | + dev.off() |
| 68 | + |
| 69 | + html=paste0("<HTML name='summary'>mean=",mean(Y),"<br/>", |
| 70 | + "standard deviation=",sd(Y),"<br/>", |
| 71 | + "median=",median(Y),"<br/>", |
| 72 | + "quantile 0.05=",quantile(Y,0.05),"<br/>", |
| 73 | + "quantile 0.95=",quantile(Y,0.95),"<br/>", |
| 74 | + "<img src='", algorithm$files, "' width='600' height='600'/></HTML>") |
| 75 | + |
| 76 | + m=paste("<mean>",mean(Y),"</mean>") |
| 77 | + sd=paste("<sd>",sd(Y),"</sd>") |
| 78 | + sd=paste("<median>",median(Y),"</median>") |
| 79 | + q05=paste("<q05>",quantile(Y,0.05),"</q05>") |
| 80 | + q95=paste("<q95>",quantile(Y,0.95),"</q95>") |
| 81 | + |
| 82 | + return(paste(html,m,sd,q05,q95,collapse=';')) |
| 83 | +} |
| 84 | + |
| 85 | +#' temporary analysis. Return HTML string |
| 86 | +#' @param X data frame of doe variables |
| 87 | +#' @param Y data frame of results |
| 88 | +#' @returnType String |
| 89 | +#' @return HTML string of analysis |
| 90 | +displayResultsTmp <- function(algorithm,X,Y) { |
| 91 | + displayResults(algorithm,X,Y) |
| 92 | +} |
| 93 | + |
| 94 | +############################################################################################## |
| 95 | +# @test |
| 96 | +# f <- function(X) matrix(apply(X,1,function (x) { |
| 97 | +# x1 <- x[1] * 15 - 5 |
| 98 | +# x2 <- x[2] * 15 |
| 99 | +# (x2 - 5/(4 * pi^2) * (x1^2) + 5/pi * x1 - 6)^2 + 10 * (1 - 1/(8 * pi)) * cos(x1) + 10 |
| 100 | +# }),ncol=1) |
| 101 | +# # f1 = function(x) f(cbind(.5,x)) |
| 102 | +# |
| 103 | +# options = list(sample_size = 100, seed = 1, 'model[x]' = '{"x1":"Unif(-1,1)","x2":"Unif(1,2)"}') |
| 104 | +# gd = RandomSampling(options) |
| 105 | +# |
| 106 | +# X0 = getInitialDesign(gd, input=list(x1=list(min=0,max=1),x2=list(min=0,max=1)), "y") |
| 107 | +# Y0 = f(X0) |
| 108 | +# # X0 = getInitialDesign(gd, input=list(x2=list(min=0,max=1)), NULL) |
| 109 | +# # Y0 = f1(X0) |
| 110 | +# Xi = X0 |
| 111 | +# Yi = Y0 |
| 112 | +# |
| 113 | +# finished = FALSE |
| 114 | +# while (!finished) { |
| 115 | +# Xj = getNextDesign(gd,Xi,Yi) |
| 116 | +# if (is.null(Xj) | length(Xj) == 0) { |
| 117 | +# finished = TRUE |
| 118 | +# } else { |
| 119 | +# Yj = f1(Xj) |
| 120 | +# Xi = rbind(Xi,Xj) |
| 121 | +# Yi = rbind(Yi,Yj) |
| 122 | +# } |
| 123 | +# } |
| 124 | +# |
| 125 | +# print(displayResults(gd,Xi,Yi)) |
0 commit comments