R/qat_save_result_ncdf.R

Defines functions qat_save_result_ncdf

Documented in qat_save_result_ncdf

qat_save_result_ncdf <-
function(measurement_vector, savelist, filename, workflowlist=NULL, time=NULL, height= NULL, lat=NULL, lon=NULL, vec1=NULL,vec2=NULL,vec3=NULL,vec4=NULL, store_mes_vec=TRUE, baseunit="unitless", addunits = c("minutes","metres", "degrees", "degrees", "unitless", "unitless", "unitless", "unitless"), directoryname="", nan_value=-999, variable_name="", transformationonvariable="", authorname="", original_filename="", data_level="", workflow_filename="") {
## functionality: save 
## author: André Düsterhus
## date: 19.10.2012
## version: A0.1
## input: measurement vector, savelist, filename, optional: workflowlist, time vector, latitude vector, longitude vector, additional vectors, bool wheather store the measurement vector, baseunit, units of the dimensions, name of a directory, missing value, variable name, information on transformation on variable, name of the author, original filename, data level, workflow filename
## output: a netcdf file stored at filename with the results
	if (!is.null(savelist)&&(length(savelist)>0)){
#		library("ncdf")
		if (is.null(dim(measurement_vector))) {
			dim_mv <- 1
		} else {
			dim_mv <- length(dim(measurement_vector))
		}		
		contvar_count<- 0
		contvar <- NULL
		variables <- NULL
		# enrich workflow with internal information
		if (!is.null(workflowlist)) {
			workflowlist <- qat_add_all_algorithms(workflowlist)
			workflowlist <- qat_add_all_descriptions(workflowlist)
		}
		# define dimension(s) for mv		
		if (dim_mv == 1) {
			len_mes_vec <- length(measurement_vector)
			dim_mes_vec <- ncdim_def("measurement_vector_index", "unitless", 1:length(measurement_vector))
		} else {
			dim_mes_vec <- list()
			for (ii in 1:dim_mv) {
				dim_mes_vec[[ii]] <- ncdim_def(paste("measurement_vector_index",ii,sep=""), "unitless", 1:dim(measurement_vector)[ii])
			}
		}
		# storing mv if asked to do so
		if (store_mes_vec) {
			contvar[[contvar_count <- contvar_count+1]] <- measurement_vector
			var_temp <- ncvar_def(paste(variable_name,"measurement_vector", sep=""), baseunit, dim_mes_vec, -999, longname="Measurement Vector")
			variables[[contvar_count]] <- var_temp
		} else {
#			variables <- NULL
#			contvar <- NULL
		}
		if (!is.null(time)) {
			if (sum(is.nan(time) > 0)) {
				time[is.nan(time)] <- nan_value
			}
			if (is.null(dim(time))) {
				if (length(time) != len_mes_vec) {
					dim_time <- ncdim_def("time", addunits[1], time)
					var_temp <- ncvar_def("timevec", addunits[1], dim_time, nan_value, longname="Time Vector")
				} else {
					var_temp <- ncvar_def("timevec", addunits[1], dim_mes_vec, nan_value, longname="Time Vector")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(time))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("timevec", addunits[1], dim_mes_vec, nan_value, longname="Time Vector")
				} else {
					for (ii in 1:length(dim(time))) {
						dim_time <- list()
						dim_time[[ii]] <- ncdim_def(paste("time",ii,sep=""), addunits[1], 1:dim(time)[ii])
					}
					var_temp <- ncvar_def("timevec", addunits[1], dim_time, nan_value, longname="Time Vector")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- time
			variables[[contvar_count]] <- var_temp
		}
		if (!is.null(height)) {
			if (sum(is.nan(height) > 0)) {
				time[is.nan(height)] <- nan_value
			}
			if (is.null(dim(height))) {
				if (length(height) != len_mes_vec) {
					dim_height <- ncdim_def("height", addunits[2], height)
					var_temp <- ncvar_def("heightvec", addunits[2], dim_height, nan_value, longname="Height Vector")
				} else {
					var_temp <- ncvar_def("heightvec", addunits[2], dim_mes_vec, nan_value, longname="Height Vector")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(height))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("heightvec", addunits[2], dim_mes_vec, nan_value, longname="Height Vector")
				} else {
					for (ii in 1:length(dim(height))) {
						dim_height <- list()
						dim_height[[ii]] <- ncdim_def(paste("height",ii,sep=""), addunits[2], 1:dim(height)[ii])
					}
					var_temp <- ncvar_def("heightvec", addunits[2], dim_height, nan_value, longname="Height Vector")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- height
			variables[[contvar_count]] <- var_temp
		}
		if (!is.null(lat)) {
			if (sum(is.nan(lat) > 0)) {
				time[is.nan(lat)] <- nan_value
			}
			if (is.null(dim(lat))) {
				if (length(lat) != len_mes_vec) {
					dim_lat <- ncdim_def("latitude", addunits[3], lat)
					var_temp <- ncvar_def("latitudevec", addunits[3], dim_lat, nan_value, longname="Latitude Vector")
				} else {
					var_temp <- ncvar_def("latitudevec", addunits[3], dim_mes_vec, nan_value, longname="Latitude Vector")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(lat))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("latitudevec", addunits[3], dim_mes_vec, nan_value, longname="Latitude Vector")
				} else {
					for (ii in 1:length(dim(lat))) {
						dim_lat <- list()
						dim_lat[[ii]] <- ncdim_def(paste("latitude",ii,sep=""), addunits[3], 1:dim(lat)[ii])
					}
					var_temp <- ncvar_def("latitudevec", addunits[3], dim_lat, nan_value, longname="Latitude Vector")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- lat
			variables[[contvar_count]] <- var_temp
		}
		if (!is.null(lon)) {
			if (sum(is.nan(lon) > 0)) {
				time[is.nan(lon)] <- nan_value
			}
			if (is.null(dim(lon))) {
				if (length(lon) != len_mes_vec) {
					dim_lon <- ncdim_def("longitude", addunits[4], lon)
					var_temp <- ncvar_def("longitudevec", addunits[4], dim_lon, nan_value, longname="Longitude Vector")
				} else {
					var_temp <- ncvar_def("longitudevec", addunits[4], dim_mes_vec, nan_value, longname="Longitude Vector")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(lon))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("longitudevec", addunits[4], dim_mes_vec, nan_value, longname="Longitude Vector")
				} else {
					for (ii in 1:length(dim(lon))) {
						dim_lon <- list()
						dim_lon[[ii]] <- ncdim_def(paste("longitude",ii,sep=""), addunits[4], 1:dim(lon)[ii])
					}
					var_temp <- ncvar_def("longitudevec", addunits[4], dim_lon, nan_value, longname="Longitude Vector")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- lon
			variables[[contvar_count]] <- var_temp	
		}
		if (!is.null(vec1)) {
			if (sum(is.nan(vec1) > 0)) {
				time[is.nan(vec1)] <- nan_value
			}
			if (is.null(dim(vec1))) {
				if (length(vec1) != len_mes_vec) {
					dim_vec1 <- ncdim_def("addvec1_index", addunits[5], 1:length(vec1))
					var_temp <- ncvar_def("addvec1", addunits[5], dim_vec1, nan_value, longname="Additional Vector 1")
				} else {
					var_temp <- ncvar_def("addvec1", addunits[5], dim_mes_vec, nan_value, longname="Additional Vector 1")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(vec1))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("addvec1", addunits[5], dim_mes_vec, nan_value, longname="Additional Vector 1")
				} else {
					for (ii in 1:length(dim(vec1))) {
						dim_vec1 <- list()
						dim_vec1[[ii]] <- ncdim_def(paste("addvec1_index",ii,sep=""), addunits[5], 1:dim(vec1)[ii])
					}
					var_temp <- ncvar_def("addvec1", addunits[5], dim_vec1, nan_value, longname="Additional Vector 1")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- vec1
			variables[[contvar_count]] <- var_temp				
		}
		if (!is.null(vec2)) {
			if (sum(is.nan(vec2) > 0)) {
				time[is.nan(vec2)] <- nan_value
			}
			if (is.null(dim(vec2))) {
				if (length(vec2) != len_mes_vec) {
					dim_vec2 <- ncdim_def("addvec2_index", addunits[6], 1:length(vec2))
					var_temp <- ncvar_def("addvec2", addunits[6], dim_vec2, nan_value, longname="Additional Vector 2")
				} else {
					var_temp <- ncvar_def("addvec2", addunits[6], dim_mes_vec, nan_value, longname="Additional Vector 2")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(vec2))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("addvec2", addunits[6], dim_mes_vec, nan_value, longname="Additional Vector 2")
				} else {
					for (ii in 1:length(dim(vec2))) {
						dim_vec2 <- list()
						dim_vec2[[ii]] <- ncdim_def(paste("addvec2_index",ii,sep=""), addunits[6], 1:dim(vec2)[ii])
					}
					var_temp <- ncvar_def("addvec2", addunits[6], dim_vec2, nan_value, longname="Additional Vector 2")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- vec2
			variables[[contvar_count]] <- var_temp			
		}
		if (!is.null(vec3)) {
			if (sum(is.nan(vec3) > 0)) {
				time[is.nan(vec3)] <- nan_value
			}
			if (is.null(dim(vec3))) {
				if (length(vec3) != len_mes_vec) {
					dim_vec3 <- ncdim_def("addvec3_index", addunits[7], 1:length(vec3))
					var_temp <- ncvar_def("addvec3", addunits[7], dim_vec3, nan_value, longname="Additional Vector 3")
				} else {
					var_temp <- ncvar_def("addvec3", addunits[7], dim_mes_vec, nan_value, longname="Additional Vector 3")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(vec3))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("addvec3", addunits[7], dim_mes_vec, nan_value, longname="Additional Vector 3")
				} else {
					for (ii in 1:length(dim(vec3))) {
						dim_vec3 <- list()
						dim_vec3[[ii]] <- ncdim_def(paste("addvec3_index",ii,sep=""), addunits[7], 1:dim(vec3)[ii])
					}
					var_temp <- ncvar_def("addvec3", addunits[7], dim_vec3, nan_value, longname="Additional Vector 3")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- vec3
			variables[[contvar_count]] <- var_temp				
		}
		if (!is.null(vec4)) {
			if (sum(is.nan(vec4) > 0)) {
				time[is.nan(vec4)] <- nan_value
			}
			if (is.null(dim(vec4))) {
				if (length(vec4) != len_mes_vec) {
					dim_vec4 <- ncdim_def("addvec4_index", addunits[8], 1:length(vec4))
					var_temp <- ncvar_def("addvec4", addunits[8], dim_vec4, nan_value, longname="Additional Vector 4")
				} else {
					var_temp <- ncvar_def("addvec4", addunits[8], dim_mes_vec, nan_value, longname="Additional Vector 4")
				}
			} else {
				if (sum(dim(measurement_vector)==dim(vec4))==length(dim(measurement_vector))) {
					var_temp <- ncvar_def("addvec4", addunits[8], dim_mes_vec, nan_value, longname="Additional Vector 4")
				} else {
					for (ii in 1:length(dim(vec4))) {
						dim_vec4 <- list()
						dim_vec4[[ii]] <- ncdim_def(paste("addvec4_index",ii,sep=""), addunits[8], 1:dim(vec4)[ii])
					}
					var_temp <- ncvar_def("addvec4", addunits[8], dim_vec4, nan_value, longname="Additional Vector 4")
				}
			}
			contvar[[contvar_count <- contvar_count+1]] <- vec4
			variables[[contvar_count]] <- var_temp				
		}
		contvar_count_secure <- contvar_count
		# constructing variables and dimensions
		for (ii in 2:length(savelist)) {
			if (is.null(savelist[[ii]]$tosave$returntext)) {
#				print((savelist[[ii]]$tosave$dimension))
				for(jj in 1:length(savelist[[ii]]$tosave$dimension)) {
					if (is.list(savelist[[ii]]$tosave$dimension[[jj]])) {
						dim_temp <- list()
						for (kk in 1:length(savelist[[ii]]$tosave$dimension[[jj]])) {
#							print(kk)
							# ask if it is a dimension of a measurement vector
							if (substr(names(savelist[[ii]]$tosave$dimension[[jj]])[kk], 1, 7)=="mes_vec") {
								if (nchar(names(savelist[[ii]]$tosave$dimension[[jj]])[kk]) >= 8) {
									mesvec_num <- as.integer(substr(names(savelist[[ii]]$tosave$dimension[[jj]])[kk], 8, nchar(names(savelist[[ii]]$tosave$dimension[[jj]])[kk])))
#									if(kk==1){
#									print(names(savelist[[ii]]$tosave$dimension[[jj]])[kk])
#									print(nchar(names(savelist[[ii]]$tosave$dimension[[jj]])[kk]))
#									}
									dim_temp[[kk]] <- dim_mes_vec[[mesvec_num]]
#									if(ii==12){
#									print(mesvec_num)
#									print(length(dim_temp))
#									}
									
								} else {
									dim_temp[[kk]] <- dim_mes_vec
								}
							} else {
								if (is.character(savelist[[ii]]$tosave$dimunit[[jj]][[kk]])) {
									dim_temp[[kk]] <- ncdim_def(names(savelist[[ii]]$tosave$dimension[[jj]])[kk], savelist[[ii]]$tosave$dimunit[[jj]][[kk]], 1:savelist[[ii]]$tosave$dimension[[jj]][[kk]])
								} else {
									dim_temp[[kk]] <- ncdim_def(names(savelist[[ii]]$tosave$dimension[[jj]])[kk], "unitless", 1:savelist[[ii]]$tosave$dimension[[jj]][[kk]])
								}
							}
						}
					} else {
						dim_temp <- list()
						if (substr(names(savelist[[ii]]$tosave$dimension)[jj], 1, 7)=="mes_vec") {
							if (length(savelist[[ii]]$tosave$dimension[[jj]]) >= 8) {
								mesvec_num <- substr(savelist[[ii]]$tosave$dimension[[jj]], 7, length(savelist[[ii]]$tosave$dimension[[jj]]))
								dim_temp[[1]] <- dim_mes_vec[[mesvec_num]]
							} else {
								dim_temp[[1]] <- dim_mes_vec
							}
						} else {
							if (is.character(savelist[[ii]]$tosave$dimunit[[jj]])) {
								dim_temp[[1]] <- ncdim_def(names(savelist[[ii]]$tosave$dimension)[jj], savelist[[ii]]$tosave$dimunit[[jj]], 1:savelist[[ii]]$tosave$dimension[[jj]])
							} else {
								dim_temp[[1]] <- ncdim_def(names(savelist[[ii]]$tosave$dimension)[jj], "unitless", 1:savelist[[ii]]$tosave$dimension[[jj]])
							}
						}
					}
					var_temp <- ncvar_def(paste(variable_name,"_",savelist[[ii]]$tosave$method,"_", savelist[[ii]]$element,"_" , names(savelist[[ii]]$tosave$longname)[jj], sep=""), savelist[[ii]]$tosave$unit[[jj]], dim_temp, savelist[[ii]]$tosave$fillvalue, longname=savelist[[ii]]$tosave$longname[[jj]])
#					if (((ii==12)&&(jj==1))||((ii==3)&&(jj==1))) {
#						print("test")
#						print(var_temp)
#					}
					# store variables
					if (!is.null(savelist[[ii]]$tosave$content[[jj]])) {
						contvar[[contvar_count <- contvar_count+1]] <- savelist[[ii]]$tosave$content[[jj]]
					} else {
						contvar[[contvar_count <- contvar_count+1]] <- NaN
					}
					variables[[contvar_count]] <- var_temp
				}
			}
		}
		# create file
		ncnew <- nc_create(paste(directoryname,filename,".nc", sep=""),variables, verbose=FALSE)
		contvar_count <- contvar_count_secure
		for (ii in 2:length(savelist)) {
			if (is.null(savelist[[ii]]$tosave$returntext)) {
				for(jj in 1:length(savelist[[ii]]$tosave$dimension)) {
					contvar_count <- contvar_count + 1
					if (!is.null(savelist[[ii]]$tosave$meanings)) {
						ncatt_put(ncnew, variables[[contvar_count]], "meanings", savelist[[ii]]$tosave$meanings[[jj]])
					}
					if (!is.null(savelist[[ii]]$tosave$unit)) {
						ncatt_put(ncnew, variables[[contvar_count]], "unit", savelist[[ii]]$tosave$unit[[jj]])
					}
					if (!is.null(workflowlist[[savelist[[ii]]$element]]$additional_information$description)) {
						ncatt_put(ncnew, variables[[contvar_count]], "description", workflowlist[[savelist[[ii]]$element]]$additional_information$description)
					}
					if (!is.null(workflowlist[[savelist[[ii]]$element]]$additional_information$algorithm)) {
						ncatt_put(ncnew, variables[[contvar_count]], "algorithm", workflowlist[[savelist[[ii]]$element]]$additional_information$algorithm)
					}
					if (!is.null(workflowlist[[savelist[[ii]]$element]]$additional_information$result$comment_on_result)) {
						ncatt_put(ncnew, variables[[contvar_count]], "comment", workflowlist[[savelist[[ii]]$element]]$additional_information$result$comment_on_result)
					}
					if (transformationonvariable != "") {
						ncatt_put(ncnew, variables[[contvar_count]], "testedvariable_transformation", transformationonvariable)
					}
					if (data_level != "") {
						ncatt_put(ncnew, variables[[contvar_count]], "data_level", data_level)
					}
					if (!is.null(savelist[[ii]]$tosave$parameter)) {
						for (kk in 1:length(savelist[[ii]]$tosave$parameter)) {
							if (!is.null(savelist[[ii]]$tosave$parameter[[kk]])) {
								ncatt_put(ncnew, variables[[contvar_count]], paste("parameter_", names(savelist[[ii]]$tosave$parameter)[kk], sep=""), savelist[[ii]]$tosave$parameter[[kk]])
							}
						}
					}			
				}
			} else {
				if (transformationonvariable != "") {
					transformationonvariable <- paste(transformationonvariable, ":", savelist[[ii]]$tosave$returntext)
				} else {
					transformationonvariable <- savelist[[ii]]$tosave$returntext
				}
			}
		}
		if (authorname != "") {
			ncatt_put(ncnew, 0, "author", authorname)
		}
#			ncatt_put(ncnew, 0, "date", date())
		ncatt_put(ncnew, 0, "title", "Quality Assurance Information")
		if ((variable_name != "") || (original_filename != "")) {
			comm <- "This file includes quality information"
			if (variable_name != "") {
				comm <- paste(comm, "on the variable",variable_name)
			}
			if (original_filename != "") {
				comm <- paste(comm, "of the file",original_filename)
			}
			ncatt_put(ncnew, 0, "comment", comm)
		}
		sour <- "quality information"
		if (original_filename!="") {
			sour <- paste(sour, ":", original_filename)
		}
		if (workflow_filename!="") {
			sour <- paste(sour, ":", workflow_filename)
		}
		ncatt_put(ncnew, 0, "source", sour)
		ncatt_put(ncnew, 0, "reference", "This file was produced with help of the R-Package qat, version 0.6")
		ncatt_put(ncnew, 0, "history", paste(date(),"Performance of test"))

		for (ii in 1:contvar_count) {
			vari <- variables[[ii]]
			conti <- contvar[[ii]]
			conti[is.nan(conti)] <- nan_value
#			if (ii==18) {
#				print(vari)
#				print(dim(conti))
#			}
			ncvar_put(ncnew, vari$name, conti)
		}
		nc_close(ncnew)
	}
}

Try the qat package in your browser

Any scripts or data that you put into this service are public.

qat documentation built on May 2, 2019, 4:06 p.m.