#gets data for point and grid data
get_data_list<-function(data_names){
pf=parent.frame()
tryCatch({
if (pf$grid==0 & pf$points==1){
datn=as.list(paste0(data_names,"_p"))
} else if (pf$grid==1 & pf$points==0) {
datn=as.list(paste0(data_names,"_grid"))
} else if (pf$grid==1 & pf$points ==1){
datn=as.list(c(paste0(data_names,"_p"),paste0(data_names,"_grid")))
} else stop("either grid or point data have to be provided as input")
dat=lapply(datn[!sapply(datn,function(x) is.null(pf[[x]]))], function(dd) pf[[dd]])
names(dat)=lapply(datn[!sapply(datn,function(x) is.null(pf[[x]]))], function(dd) dd)
return(dat)
}, error=function(cond){
message("error in input data:")
message(cond)
stop_quietly()
})
}
# function to seect only matching time slices of different climindvis objects and/or select selyears
#data = named list of climindvis objects
cut_to_same_dates<-function(data,selyears=NULL){
tryCatch({
if(any(is.element(class(data), "climindvis"))) data<-list(data)
sapply(data,function(x) check_class(x,"climindvis"))
if(length(data) ==1 & is.null(selyears)){
return(data)
} else {
tfactors=lapply(data, function(dd) factor(dd$time))
tintersect=factor(Reduce(intersect,tfactors))
fc=which(sapply(data, function(x) grepl("fc",x$data_info$type )))
if(length(fc)>0){
dfactors=lapply(data, function(dd) factor(dd$time_factors$jdays))
dintersect=factor(Reduce(intersect,dfactors))
tfactors[fc]=NA
tintersect=factor(Reduce(intersect,tfactors[-fc]))
if(length(dintersect)==0) stop("no matching time steps in all climindvis objects")
}
if(!is.null(selyears)){
tintersect=tintersect[which(is.element(substring(tintersect,1,4),as.character(selyears)))]
}
if(length(tintersect) == 0) stop("no matching time steps in climindvis objects")
if (length(fc)>0){
selt=mapply(function(tt,jj) {
if (!is.na(tt[1])) {
return(which(is.element(tt,tintersect) & is.element(jj,dintersect)))
} else return(which(is.element(jj,dintersect)))}
,tfactors, dfactors)
} else {
selt=lapply(tfactors, function(tt) which(is.element(tt,tintersect)))
}
data_out=mapply(function(dd,yy) {
dd$time=dd$time[yy]
for(x in 1:length(dd$time_factors)){
dd$time_factors[[x]]=factor(dd$time_factors[[x]][yy])
}
for (x in 1:length(dd$data)){
#Daten auch zuschneiden
# alle in array umformen mit nur letzter Spalte Zeit alle anderen zusammen. sel replizieren
d=dim(dd$data[[x]])
ld=length(d)
dhelp <- array(dd$data[[x]],dim=c(prod(d[1:(ld-1)]),d[ld]))[,yy]
dd$data[[x]]=array(dhelp,c(d[1:(ld-1)],dim(dhelp)[-1]),dimnames=c(dimnames(dd$data[[x]])))
}
return(dd)
},data,selt,SIMPLIFY = FALSE)
return(data_out)
}
}, error=function(cond) {
message("error when cutting out same time steps for climindvis_index objects:")
message(cond)
stop_quietly()
})
}
get_index_array_input<-function(index,dimnames,dimsel){
dims=which(is.element(index$index_info$idims,dimnames))
sel=lapply(seq_along(dimnames), function(dn){
r<-which(is.element(dimnames(index$index)[[dims[dn]]],dimsel[[dn]]))
if(length(r)==0) r<-NULL
return(r)
} )
return(list(dims=dims,sel=sel))
}
cut_to_same_dates_index<-function(index_data,selyears=NULL){
tryCatch({
if(any(is.element(class(index_data), "climindvis_index"))) data<-list(data)
sapply(index_data,function(x) check_class(x,"climindvis_index"))
if(length(index_data) ==1 & is.null(selyears)){
return(index_data)
} else {
aggt=unique(sapply(index_data, function(dd) factor(dd$index_info$aggt)))
if(length(aggt)>1) stop("aggregation needs to be the same for all input objects")
agg=Reduce(intersect,lapply(index_data, function(dd) dd$index_info$aggnames))
if(length(agg)==0) stop("no matching aggregations in climindvis_index objects")
if(any(is.element(month.abb,agg))) agg=pad2(which(is.element(month.abb,agg)))
fc=which(sapply(index_data, function(x) grepl("fc",x$data_info$type )))
index_out=list()
if(length(fc)>0){
years_fc=Reduce(intersect,lapply(index_data[fc], function(dd) dd$index_info$years))
if (length(years_fc)==0) stop("no matching years in climindvis_index forecast objects")
years=Reduce(intersect,c(lapply(index_data[-fc], function(dd) dd$index_info$years),list(selyears)))
if (length(years)==0) stop("no matching years/no years selected in <<selyears>> in climindvis_index objects" )
index_out[fc]<-lapply(index_data[fc], function(dd){
sel=get_index_array_input(dd,c("agg","year"),list(agg,years_fc))
dd$index=index_array(dd$index,sel$dims,sel$sel)
return(dd)
})
index_out[-fc]<-lapply(index_data[-fc], function(dd){
sel=get_index_array_input(dd,c("agg","year"),list(agg,years))
dd$index=index_array(dd$index,sel$dims,sel$sel)
return(dd)
})
} else {
years=Reduce(intersect,c(lapply(index_data, function(dd) dd$index_info$years),list(selyears)))
if (length(years)==0) stop("no matching years/no years selected in <<selyears>> in climindvis_index objects" )
index_out<-lapply(index_data, function(dd){
sel=get_index_array_input(dd,c("agg","year"),list(agg,years))
dd$index=index_array(dd$index,sel$dims,sel$sel)
return(dd)
})
}
return(index_out)
}
}, error=function(cond) {
message("error when cutting out same time steps for climindvis_index objects:")
message(cond)
stop_quietly()
})
}
get_leg_units<-function(ind_dat,trend=FALSE){
units=Reduce(union,lapply(ind_dat[!sapply(ind_dat,is.null)], function(id) id$index_info$iformat))
#if (length(units)>1) stop("the units of the different indices should be the same")
units[units%in%"dayscount"] <- "days"
units[units%in%"perc"] <- "%"
units[units%in%"degreeC"] <- "C"
if(any(units%in%"days_since")) {
indu <- units%in%"days_since"
nc=nchar(ind_dat[[indu]]$index_info$start_days)
units[indu] = ifelse(trend,"days",paste0("days since ",substring(ind_dat[[indu]]$index_info$start_days,nc-4,nc)))
} else units=units
ret=switch(trend+1,units,paste0("[",units,"]"))
return(ret)
}
get_plot_args<-function(autoplot){
env=parent.frame()
if(autoplot=="forecast_map"){
ifelse(env$col == "default",ch <- colorRampPalette(get_default_color(env$index, env$ind_dat[[ifelse(env$points==1,"fc_p","fc_grid")]]$index_info$iname,fc=TRUE)$col)(env$ncat),ch <- colorRampPalette(col)(env$ncat))
breaks=c(0,100,110,sapply(1:env$ncat*100 , function(n) n+ seq(40 ,110,10)),(env$ncat+1.55)*100)
if(is.null(env$skillmin)) breaks=breaks[1:(length(breaks)-2)]
env$plot_args[c("p_breaks","g_breaks")] <-list(breaks)
cols=c(env$nocat_col,"white",sapply(ch , function(n) c(colorRampPalette(c("white",n))(9)[c(2,4:9)],"white")),env$noskill_col)
if(is.null(env$skillmin)) cols=cols[1:(length(cols)-2)]
env$plot_args[c("g_col","p_col")]=list(cols)
env$plot_args$leg_labs=gsub("40","<40",c("no cat/NA",paste0(rep(seq(40 ,100,20),env$ncat),"%"),switch(is.null(env$skillmin)+1,"no skill",NULL)))
env$plot_args$fc_catnames=env$cat_names
env$plot_args$leg_title=ifelse(is.null(env$leg_title),"",env$leg_title)
env$plot_args[c("p_zlims","zlims")]=list(range(env$plot_args[c("p_breaks","g_breaks")]))
} else if (autoplot=="climatology_map"){
env$plot_args["plot_scale"]= Reduce(union,lapply(env$ind_dat, function(id) !all(id$index[!is.na(id$index)] == 0)))
iname=Reduce(union,lapply(env$ind_dat, function(id) id$index_info$iname))
env$plot_args["units"] = get_leg_units(env$ind_dat) #paste0("[",Reduce(union,lapply(env$ind_dat, function(id) id$index_info$iformat)),"]")
if (env$col == "default"){
if (env$plot_value == "sd" | env$plot_value == "relsd"){
env$plot_args[c("p_col", "g_col")] = list(colorRampPalette(c("lightgrey", "palevioletred4", "slateblue4"))(10))
} else {
def_col = get_default_color(env$index, iname)
env$plot_args[c("p_col", "g_col")] <- list(def_col$col)
env$plot_args[c("p_col_center", "g_col_center")] = list(def_col$center)
}
} else {
env$plot_args[c("p_col", "g_col")] = list(env$col)
env$plot_args[c("p_col_center", "g_col_center")] = FALSE
}
} else if (autoplot=="anomaly_map"){
iname=Reduce(union,lapply(env$ind_dat, function(id) id$index_info$iname))
env$plot_args["units"] = get_leg_units(env$ind_dat) #paste0("[",Reduce(union,lapply(env$ind_dat, function(id) id$index_info$iformat)),"]")
if (env$col == "default"){
def_col = get_default_color_anom(env$index, iname)
env$plot_args[c("p_col", "g_col")] <- list(def_col$col)
env$plot_args[c("p_col_center", "g_col_center")] = list(def_col$center)
} else {
env$plot_args[c("p_col", "g_col")] = list(env$col)
env$plot_args[c("p_col_center", "g_col_center")] = TRUE
}
}else if (autoplot=="trend_map"){
#
# if (grid==1){
# plot_args$mask_NA <- array(NA,dim=dim(pdat$dat_grid))
# plot_args$mask_NA[is.na(pdat$dat_grid)] <- 1
# if(!all(unlist(lapply(pdat, is.na)))) {
# # define limit as q80 of trend distribution
# if(is.null(plot_args$g_breaks)){
# new_breaks<-get_breaks(pdat, center=TRUE, plot_args$zlims) #Farbe fuer Stationen und Grid immer dieselbe
# plot_args$g_breaks <- new_breaks$breaks
# plot_args$outliers <- new_breaks$outliers
#
# lb<- length(new_breaks$breaks)
# pdat$dat_grid[pdat$dat_grid>new_breaks$breaks[lb] ]<- new_breaks$breaks[lb]
# pdat$dat_grid[pdat$dat_grid<new_breaks$breaks[1] ]<- new_breaks$breaks[1]
#
# } else {plot_args$outliers <- c(FALSE,FALSE)} # falls die huettchen bei g_breaks auch angepasst werden sollen, dann hier
#
# plot_args$g_col <- colorRampPalette(RColorBrewer::brewer.pal(8,"PRGn"))(length(plot_args$g_breaks)-1)
#
# } else {
# plot_args$g_breaks <- 0
# message("No significant trends for grid at this significance level.")
#
# }
#
#
#
# }
# if(points==1){
# if (grid==1){
# plot_args$p_breaks <- plot_args$g_breaks
# plot_args$p_col <- plot_args$g_col
# plot_args$p_pch <- ifelse(is.na(pdat$dat_p),p_ch <-21,ifelse(pdat$dat_p>=0, p_ch <-24, p_ch <- 25))
# plot_args[c("p_col_info","p_legend")] <- list("same")
#
# } else {
# if (all(is.na(pdat$dat_p))) {
# message("No significant trends for stations at this significance level")
# upper_lim<-0
# # sonst gibt es Error spaeter im script
# plot_args$p_breaks <- 0
# plot_args$outliers <- c(FALSE,FALSE)
# plot_args[c("p_pch_s","p_pch")] <-list( ifelse(is.na(pdat$dat_p),p_ch <- 21,ifelse(pdat$dat_p>=0, p_ch <-24, p_ch <- 25)))
# plot_args[c("p_col_info","p_legend")] <- "cbar"
#
# } else {
# if (is.null(plot_args$p_breaks)){
# new_breaks<-get_breaks(pdat$dat_p,center = TRUE, plot_args$zlims)
# plot_args$p_breaks <- new_breaks$breaks
# plot_args$outliers <- new_breaks$outliers
#
# lb<- length(new_breaks$breaks)
# pdat$dat_p[pdat$dat_p>new_breaks$breaks[lb] ]<- new_breaks$breaks[lb]
# pdat$dat_p[pdat$dat_p<new_breaks$breaks[1] ]<- new_breaks$breaks[1]
#
# } else {plot_args$outliers <- c(FALSE,FALSE)}
# plot_args$p_col <- colorRampPalette(RColorBrewer::brewer.pal(8,"PRGn"))(length(plot_args$p_breaks)-1)
# plot_args[c("p_pch_s","p_pch")] <-list( ifelse(is.na(pdat$dat_p),p_ch <- 21,ifelse(pdat$dat_p>=0, p_ch <-24, p_ch <- 25)))
# plot_args[c("p_col_info","p_legend")] <- list("cbar")
#
# }
#
# }
# pdat_help <- abs(pdat$dat_p)
# p_dat_size <- (pdat_help-min(pdat_help, na.rm=TRUE))/(max(pdat_help, na.rm=TRUE)-min(pdat_help, na.rm=TRUE))
# plot_args$p_cex <- p_dat_size+1
# plot_args$p_cex[is.na(plot_args$p_cex)] <- 1
# }
}
}
get_plot_title<-function(titlestring,show_title=TRUE,autoplot,aa=NULL,yy=NULL,pp=NULL,vv=NULL,cname=NULL,tname=NULL,abs=FALSE,
sig_lev,tmet,sep_folder=TRUE, type){
env=parent.frame()
iinfo=lapply(env$ind_dat, function(i) i$index_info)
dnames=lapply(env$ind_dat, function(i) i$data_info$data_name )
fc<-which(grepl("fc",names(iinfo)))
hc<-which(grepl("hc",names(iinfo)))
if(length(c(fc,hc))>0){
fcmon=env$ind_dat[[c(fc,hc)[1]]]$data_info$fmon
}
st=which(grepl("p",names(iinfo)))
stn<-iinfo[[st[1]]]$pnames
if(length(fc)==0){
years=as.integer(iinfo[[1]]$years)
} else if(length (hc)>0){
years=as.integer(iinfo[[hc[1]]]$years)
}
if (all(diff(years)) == 1) {
yearnames = paste(range(years), collapse = "-")
} else yearnames = paste(years, collapse = "+")
output=FALSE
if(!is.null(env$output)){
if (env$output!="dev.new") output=TRUE
}
if(autoplot=="forecast_map"){
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname," forecast ",iinfo[[1]]$aggnames[aa]," ", iinfo[[fc[1]]]$years[yy]),
period = paste0("Initialized: 01-", fcmon,"-",iinfo[[fc[1]]]$years[1]," (Model climatology:", yearnames, ") "),
skill = switch(is.null(env$skillmin)+1,paste0(env$veri_metric," >= ",env$skillmin),NULL),
datap = switch(env$points==1,paste0("Stations: ",paste0(unique(dnames[grepl("p",names(env$ind_dat))]),collapse=",")),NULL),
datag = switch(env$grid==1,paste0("Grid: ",paste0(unique(dnames[grepl("grid",names(env$ind_dat))]),collapse=",")),NULL))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(env$plotdir, env$plotname, ifelse(env$plotname == "", "", "_"), "forecast_", replace_operator_name(iinfo[[1]]$iname), ifelse(!is.null(env$skillmin),paste0("_",env$veri_metric,"_gt_",env$skillmin),""), "_", iinfo[[1]]$aggnames[aa],"_",iinfo[[fc[1]]]$years[yy],"_fcmon",fcmon,"_hc",yearnames),"")
} else if (autoplot=="forecast_map_clim"){
perc=round(env$prob[env$i]*100,dig=1)
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname," forecast ",iinfo[[1]]$aggnames[aa]," ", iinfo[[fc[1]]]$years[yy]),
period = paste0(perc,".percentile ",yearnames),
datap = switch(env$points==1,paste0("Stations: ",dnames$obs_p),NULL),
datag = switch(env$grid==1,paste0("Grid: ",dnames$obs_grid),NULL))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(env$plotdir,env$plotname, ifelse(env$plotname == "", "", "_") ,"climatology",replace_operator_name(iinfo[[1]]$iname),"_",perc,"perc_ ", iinfo[[1]]$aggnames[aa],"_",yearnames),"")
} else if (autoplot=="forecast_point"){
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname," forecast ",iinfo[[1]]$aggnames[aa]," ", iinfo[[fc[1]]]$years[yy]),
station = ifelse(!is.null(stn[pp]),stn[pp],paste0("station",pp)),
period = paste0("Initialized: 01-", fcmon,"-",iinfo[[fc[1]]]$years[1]," (Model climatology:", yearnames, ") "),
skill = switch(env$verify+1,NULL,paste0(env$veri_metric," >= ",env$skillmin)),
data = paste0(unique(dnames[grepl(paste(c("hc","fc"),collapse="|"),names(env$ind_dat))]),collapse=","))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(env$plotdir, env$plotname, ifelse(env$plotname == "", "", "_"), "forecast_", replace_operator_name(iinfo[[1]]$iname), ifelse(env$verify,paste0("_",env$veri_metric,"_gt_",env$skillmin),""), "_", iinfo[[1]]$aggnames[aa],"_",iinfo[[fc[1]]]$years[yy],"_fcmon",fcmon,"_hc",yearnames,"_",ifelse(!is.null(stn[pp]),stn[pp],paste0("st",pp)),".",env$output),"")
} else if (autoplot=="verification_map"){
if (!is.null(env$output)) {
vfolder= ifelse (sep_folder==TRUE,paste0(env$plotdir,vv,"/"),env$plotdir)
if(!dir.exists(vfolder)) dir.create(vfolder)
}
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname, " ", iinfo[[1]]$aggnames[aa],"; ",vv, ifelse(is.null(cname),"",paste0("(",cname,")"))," ", ifelse(is.null(tname)," ",paste0(" ",tname))),
period =paste0("Initialization: 01-", fcmon, " (Model climatology:", yearnames, ") "),
datap = switch(env$points==1,paste0("Stations: ",paste0(unique(dnames[grepl("p",names(env$ind_dat))]),collapse=",")),NULL),
datag = switch(env$grid==1,paste0("Grid: ",paste0(unique(dnames[grepl("grid",names(env$ind_dat))]),collapse=",")),NULL))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(vfolder, env$plotname,ifelse(env$plotname == "", "", "_"), vv,ifelse(is.null(cname),"",paste0("_",cname)),ifelse(is.null(tname),"_",paste0("_",tname,"_")), replace_operator_name(iinfo[[1]]$iname), "_", iinfo[[1]]$aggnames[aa],"_fcmon",fcmon,"_hc",yearnames),"")
} else if (autoplot=="climatology_map"){
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname," ",iinfo[[1]]$aggnames[aa]),
period = paste0(env$plot_value," ",yearnames),
data = paste0(ifelse(env$points==1,paste0("Stations: ",paste0(unique(dnames[grepl("p",names(env$ind_dat))]),collapse=","),ifelse(env$grid==1 & env$points==1," | ","")),"") ,
ifelse(env$grid==1,paste0("Grid: ",paste0(unique(dnames[grepl("grid",names(env$ind_dat))]),collapse=",")),"")))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(env$plotdir, env$plotname, ifelse(env$plotname == "", "", "_"), replace_operator_name(iinfo[[1]]$iname),"_",env$plot_value, "_", iinfo[[1]]$aggnames[aa],"_",yearnames),"")
} else if (autoplot=="anomaly_map"){
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname," ",iinfo[[1]]$aggnames[aa]),
period = paste0(ifelse (all(diff(env$anomyears)==1) & length(env$anomyears)>1,paste0(env$anomyears[1],"-",tail(env$anomyears,1)),paste(env$anomyears,collapse="/") ),"(reference:",ifelse (all(diff(env$refyears)==1) & length(env$refyears)>1,paste0(env$refyears[1],"-",tail(env$refyears,1)),paste(env$refyears,collapse="/") ),")"),
data = paste0(ifelse(env$points==1,paste0("Stations: ",paste0(unique(dnames[grepl("p",names(env$ind_dat))]),collapse=","),ifelse(env$grid==1 & env$points==1," | ","")),"") ,
ifelse(env$grid==1,paste0("Grid: ",paste0(unique(dnames[grepl("grid",names(env$ind_dat))]),collapse=",")),"")))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(env$plotdir, env$plotname, ifelse(env$plotname == "", "", "_"), "Anomaly_",replace_operator_name(iinfo[[1]]$iname),"_",env$plot_value, "_", iinfo[[1]]$aggnames[aa],"_",ifelse (all(diff(env$anomyears)==1) & length(env$anomyears)>1,paste0(env$anomyears[1],"-",tail(env$anomyears,1)),paste(env$anomyears,collapse="-")),"_refyears_",ifelse (all(diff(env$refyears)==1) & length(env$refyears)>1,paste0(env$refyears[1],"-",tail(env$refyears,1)),paste(env$refyears,collapse="-"))),"")
}else if (autoplot=="trend_map"){
if(show_title){
t <- list(utitle=switch((titlestring != "")+1, NULL,titlestring),
title=paste0(iinfo[[1]]$iname," ",iinfo[[1]]$aggnames[aa]),
period = paste0("Period: ",yearnames),
trend= paste0("Trend: ",lapply(tmet, function(t) get_method(unique(t), dif=FALSE))),
sig = paste0("Sig.lev: ", sig_lev),
data = paste0(ifelse(env$points==1,paste0("Stations: ",paste0(unique(dnames[grepl("p",names(env$ind_dat))]),collapse=","),ifelse(env$grid==1 & env$points==1," | ","")),"") ,ifelse(env$grid==1,paste0("Grid: ",paste0(unique(dnames[grepl("grid",names(env$ind_dat))]),collapse=",")),"")))
} else {t <- NA}
f=ifelse(!is.null(env$output),paste0(env$plotdir, env$plotname, ifelse(env$plotname == "", "", "_"), replace_operator_name(iinfo[[1]]$iname), "_",
iinfo[[1]]$aggnames[aa],"_",ifelse(abs==TRUE,"abs-", "rel-"),"trend_",sig_lev*100,"_",yearnames),"")
}
else if (autoplot=="ts_station"){
if(show_title){
t <- list(title= paste0(ifelse(!is.null(env$pinfo$titlestring),paste0(env$pinfo$titlestring," "),""),
env$pinfo$index_name,ifelse(env$anom," anomaly","")," ",
ifelse(is.na(aa),paste(env$aggn[1]," "),paste0(env$aggn[which(env$nagg==aa)]," ")),
"",env$stname," (", env$pdims$lon[env$pp],"/ ",env$pdims$lat[env$pp],")"),
period = ifelse(env$anom,paste0("Reference period: ",gsub("_",",",env$refyears)),paste0("Period: ", env$years[1],"-",env$years[length(env$years)])))
} else {t <- NA}
inames <- switch((type=="multi_ind_")+1,replace_operator_name(iinfo[[1]]$iname), paste0(sapply(iinfo, function(x) x$iname), collapse=""))
f=ifelse(!is.null(env$output),paste0(env$plotdir, env$plotname, ifelse(env$plotname == "", "", "_"), type,
inames,ifelse(env$anom,"_anomaly",""), "_",
iinfo[[1]]$aggnames[ifelse(is.na(aa),1,aa)],"_",ifelse(env$trendplots==FALSE,"", "trend_"),
yearnames,"_",ifelse(env$anom,paste0("_refyears",env$refyears),""),"_",env$stname,".", env$output),"")
}
return(list(t=t,f=f))
}
calc_index_special_autoplot<- function(data,index,index_args, selyears){
fc=which(sapply(data, function(dd) grepl("fc",dd$data_info$type )))
if(length(fc)==0){
ind_dat<-lapply(data, function(dd) do.call("calc_index",c(list(dd,index=index),index_args)))
} else {
ind_dat=list()
ind_dat[(1:length(data))[-fc]]<-lapply(data[-fc], function(dd) do.call("calc_index",c(list(dd,index=index),index_args)))
ind_dat[fc]<-lapply(fc, function (ff){
index_args$th_object=ind_dat[[which(names(data)==gsub("fc","hc",names(data)[ff]))]]
do.call("calc_index",c(list(data[[ff]],index=index),index_args))})
}
names(ind_dat)=names(data)
if (!is.null(selyears)){
ind_dat<-cut_to_same_dates_index(ind_dat,selyears)
}
return(ind_dat)
}
get_skill_data<-function(veri_dat,vv,aa,tt,cc,aggl,nout,tdims){
#same einbauen -> dann NA
skill=lapply(veri_dat, function(vd){
if(!is.null(vd)){
if(!aggl & tdims==1){
same=vd$same
if(nout>1) {
ret=vd$verification[[vv]][[cc]]
} else ret=vd$verification[[vv]]
} else {
cd=ifelse(vd$data_info[[1]]$type=="p",1,2)
dims=c(switch(aggl+1,NULL,cd+1), switch((tdims>1)+1,NULL,cd+aggl+1))
sel=list(switch(aggl+1,NULL,aa),switch((tdims>1)+1,NULL,tt))
if(!aggl){
same=vd$same
} else same=index_array(vd$same,cd+1,sel[1],drop=TRUE)
if (nout>1){
ret=index_array(vd$verification[[vv]][[cc]],dims,sel,drop=TRUE)
} else ret=index_array(vd$verification[[vv]], dims,sel,drop=TRUE)
}
ret[same]=NA
} else ret=NULL
return(ret)
})
}
is.even <- function(x) x %% 2 == 0
return_m <- function(x){
x <- pad2(1:12)[c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")%in% x]
return(x)
}
get_method <- function(x, dif){
y <- switch(dif+1, x[!is.na(x)][1], x[!is.na(x)])
z<- ifelse(is.na(y), " ",ifelse(y==1,"Least Squares Fit", ifelse(y==2,"Logit Regression",ifelse(y==3,"MannKendall"," "))))
return(z)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.